![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fix.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib|
Return to fix.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-fix-
2: "$Header: /usr/lib/lisp/RCS/fix.l,v 1.2 83/08/06 08:39:58 jkf Exp $")
3:
4: ; vi: set lisp :
5:
6: (eval-when (compile eval)
7: (or (get 'cmumacs 'version) (load 'cmumacs)))
8:
9: ; LWE 1/11/81 Hack hack....
10: ;
11: ; LWE 1/11/81 Bet you didn't know this, but this won't work INTERPRETED,
12: ; but Dave assures me it works compiled. (In MACLisp...)
13: ;
14: (declare (special cmd frame x cnt var init label part incr limit selectq))
15:
16: (dv fixfns
17: ((*** This is FIXIT written by David Touretzky and adapted to Franz by Don
18: Cohen)
19: (declare (special framelist rframelist interrupt-handlers handler-labels)
20: (special prinlevel prinlength evalhook-switch traced-stuff)
21: (special lastword piport hush-debug)
22: (*fexpr editf step type))
23: (sstatus feature fixit)
24: (*rset t)
25: ER%tpl
26: fixit
27: debug
28: debug-iter
29: debug1
30: debug-bktrace
31: debug-print
32: debug-print1
33: debug-findcall
34: debug-replace-function-name
35: debug-scanflist
36: debug-scanstk
37: debug-getframes
38: debug-nextframe
39: debug-upframe
40: debug-dnframe
41: debug-upfn
42: debug-dnfn
43: debug-showvar
44: debug-nedit
45: debug-insidep
46: debug-findusrfn
47: debug-findexpr
48: debug-pop
49: debug-where
50: debug-sysp
51: interrupt-handlers
52: handler-labels
53: (or (boundp 'traced-stuff) (setq traced-stuff nil))
54: (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
55: (setq hush-debug nil)))
56:
57: (or (boundp 'traced-stuff) (setq traced-stuff nil))
58: (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
59: (or (boundp 'debug-sysmode) (setq debug-sysmode nil))
60: (setq hush-debug nil)
61:
62: (*** This is FIXIT written by David Touretzky and adapted to Franz by Don Cohen)
63:
64: (declare (special framelist rframelist interrupt-handlers handler-labels)
65: (special prinlevel prinlength evalhook-switch traced-stuff)
66: (special lastword piport hush-debug debug-sysmode)
67: (*fexpr editf step type))
68:
69: (defvar fixit-eval nil)
70: (defvar fixit-print nil)
71: (defvar fixit-pp nil)
72:
73: (sstatus feature fixit)
74:
75: (*rset t)
76:
77: ; (jkf) it is not clear that you want this to take over on all errors,
78: ; but the cmu people seem to want that.
79: #+cmu (progn 'compile
80: (dv ER%tpl fixit)
81: (dv ER%all fixit) ; LWE 1/17/81 MAYBE THIS WILL FIX THIS code
82: )
83:
84: ;--- eval, print and pretty-print functions are user-selectable by just
85: ; assigning another value to fixit-eval, fixit-print and fixit-pp.
86: ;
87: (defmacro fix-eval (&rest args)
88: `(cond ((and fixit-eval
89: (getd fixit-eval))
90: (funcall fixit-eval ,@args))
91: (t (eval ,@args))))
92:
93: (defmacro fix-print (&rest args)
94: `(cond ((and fixit-print
95: (getd fixit-print))
96: (funcall fixit-print ,@args))
97: (t (print ,@args))))
98:
99: (defmacro fix-pp (&rest args)
100: `(cond ((and fixit-pp
101: (getd fixit-pp))
102: (funcall fixit-pp ,@args))
103: (t ($prpr ,@args))))
104:
105: (def fixit
106: (nlambda (l)
107: (prog (piport)
108: (do nil (nil) (eval (cons 'debug l))))))
109:
110: (def debug
111: (nlambda (params)
112: (prog (cmd frame framelist rframelist nframe val infile)
113: (setq infile t)
114: (and evalhook-switch (step nil))
115: (setq rframelist
116: (reverse
117: (setq framelist
118: (or (debug-getframes)
119: (list
120: (debug-scanstk '(nil) '(debug)))))))
121: (setq frame (debug-findexpr (car framelist)))
122: ;(tab 0)
123: (cond
124: ((and (car params) (not (eq (car params) 'edit)))
125: (terpri)
126: (princ '|;debug: |)
127: (princ (cadddr params))
128: (cond ((cddddr params)
129: (princ '| -- |)
130: (fix-print (cddddr params))))
131: (terpri)
132: (go loop)))
133: (debug-print1 frame nil)
134: (terpri)
135: (cond (hush-debug (setq hush-debug nil) (go loop))
136: ((not (memq 'edit params)) (go loop)))
137: (drain nil)
138: (princ '|type e to edit, <cr> to debug: |)
139: (setq val (tyi))
140: (cond ((or (= val 69) (= val 101))
141: (and (errset (debug-nedit frame))
142: (setq cmd '(ok))
143: (go cmdr)))
144: ((or (= val 78) (= val 110)) (terpri) (debug-pop)))
145: loop (terpri)
146: (princ ':)
147: (cond ((null (setq cmd (lineread))) (reset)))
148: cmdr (cond
149: ((dtpr (car cmd))
150: (setq val (fix-eval (car cmd) (cadddr frame)))
151: (fix-print val)
152: (terpri)
153: (go loop)))
154: (setq nframe (debug1 cmd frame))
155: (and (not (atom nframe)) (setq frame nframe) (go loop))
156: (fix-print (or nframe (car cmd)))
157: (princ '" Huh? - type h for help")
158: (go loop))))
159:
160: (def debug-iter
161: (macro (x)
162: (cons 'prog
163: (cons 'nil
164: (cons 'loop
165: (cons (list 'setq 'nframe (cadr x))
166: '((setq cnt (|1-| cnt))
167: (and (or (null nframe) (zerop cnt))
168: (return nframe))
169: (setq frame nframe)
170: (go loop))))))))
171:
172: (def debug1
173: (lambda (cmd frame)
174: (prog (nframe val topframe cnt item)
175: (setq topframe (car framelist))
176: (or (eq (typep (car cmd)) 'symbol) (return nil))
177: ; if "> name", replace function or variable name with new atom
178: (and (eq (car cmd) '>)
179: (return (debug-replace-function-name cmd topframe)))
180: (and (eq (getchar (car cmd) 1) 'b)
181: (eq (getchar (car cmd) 2) 'k)
182: (return (debug-bktrace cmd frame)))
183: (setq cnt
184: (cond ((fixp (cadr cmd)) (cadr cmd))
185: ((fixp (caddr cmd)) (caddr cmd))
186: (t 1)))
187: (and (< cnt 1) (setq cnt 1))
188: (setq item
189: (cond ((symbolp (cadr cmd)) (cadr cmd))
190: ((symbolp (caddr cmd)) (caddr cmd))))
191: (and item
192: (cond ((memq (car cmd) '(u up))
193: (setq cmd (cons 'ups (cdr cmd))))
194: ((memq (car cmd) '(d dn))
195: (setq cmd (cons 'dns (cdr cmd))))))
196: (selectq (car cmd)
197: (top (debug-print1 (setq frame topframe) nil))
198: (bot (debug-print1 (setq frame (car rframelist)) nil))
199: (p (debug-print1 frame nil))
200: (pp (fix-pp (caddr frame)))
201: (where (debug-where frame))
202: (help
203: (cond ((cdr cmd) (eval cmd))
204: (t (ty |/usr/lib/lisp/fixit.ref|))))
205: ((? h) (ty |/usr/lib/lisp/fixit.ref|))
206: ((go ok)
207: (setq frame (debug-findexpr topframe))
208: (cond ((eq (caaddr frame) 'debug)
209: (freturn (cadr frame) t))
210: (t (fretry (cadr frame) frame))))
211: (pop (debug-pop))
212: (step (setq frame (debug-findexpr frame))
213: (step t)
214: (fretry (cadr (debug-dnframe frame)) frame))
215: (redo (and item
216: (setq frame
217: (debug-findcall item frame framelist)))
218: (and frame (fretry (cadr frame) frame)))
219: (return (setq val (eval (cadr cmd)))
220: (freturn (cadr frame) val))
221: (edit (debug-nedit frame))
222: (editf
223: (cond ((null item)
224: (setq frame
225: (or (debug-findusrfn (debug-nedit frame))
226: (car rframelist))))
227: ((dtpr (getd item))
228: (errset (funcall 'editf (list item))))
229: (t (setq frame nil))))
230: (u (debug-iter (debug-upframe frame))
231: (cond
232: ((null nframe) (terpri) (princ '|<top of stack>|)))
233: (debug-print1 (setq frame (or nframe frame)) nil))
234: (d (setq nframe
235: (or (debug-iter (debug-dnframe frame)) frame))
236: (debug-print1 nframe nil)
237: (cond ((eq frame nframe)
238: (terpri)
239: (princ '|<bottom of stack>|))
240: (t (setq frame nframe))))
241: (up (setq nframe (debug-iter (debug-upfn frame)))
242: (cond
243: ((null nframe) (terpri) (princ '|top of stack|)))
244: (setq frame (or nframe topframe))
245: (debug-print1 frame nil))
246: (dn (setq frame
247: (or (debug-iter (debug-dnfn frame))
248: (car rframelist)))
249: (debug-print1 frame nil)
250: (cond
251: ((not (eq frame nframe))
252: (terpri)
253: (princ '|<bottom of stack>|))))
254: (ups (setq frame
255: (debug-iter
256: (debug-findcall item frame rframelist)))
257: (and frame (debug-print1 frame nil)))
258: (dns (setq frame
259: (debug-iter
260: (debug-findcall item frame framelist)))
261: (and frame (debug-print1 frame nil)))
262: (sys (setq debug-sysmode (not debug-sysmode))
263: (patom "sysmode now ")(patom debug-sysmode) (terpr))
264: (cond ((not (dtpr (car cmd)))
265: (*** should there also be a boundp test here)
266: (debug-showvar (car cmd) frame))
267: (t (setq frame (car cmd)))))
268: (return (or frame item)))))
269:
270: (def debug-replace-function-name
271: (lambda (cmd frame)
272: (prog (oldname newname errorcall nframe)
273: (setq errorcall (caddr frame))
274: (cond ((eq (caddddr errorcall) '|eval: Undefined function |)
275: (setq oldname (cadddddr errorcall))
276: (setq newname (cadr cmd))
277: (setq cnt 3.)
278: (setq frame (debug-iter (debug-dnframe frame)))
279: (dsubst newname oldname frame)
280: (fretry (cadr frame) frame))
281: ((eq (caddddr errorcall) '|Unbound Variable:|)
282: (setq oldname (cadddddr errorcall))
283: (setq newname (eval (cadr cmd)))
284: (setq cnt 3.)
285: (setq frame (debug-iter (debug-dnframe frame)))
286: (dsubst newname oldname frame)
287: (fretry (cadr frame) frame))
288: ( t (return nil))))))
289:
290: (def debug-bktrace
291: (lambda (cmd oframe)
292: (prog (sel cnt item frame nframe)
293: (mapc '(lambda (x)
294: (setq sel
295: (cons (selectq x
296: (f 'fns)
297: (a 'sysp)
298: (v 'bind)
299: (e 'expr)
300: (c 'current)
301: 'bogus)
302: sel)))
303: (cddr (explodec (car cmd))))
304: (setq item
305: (cond ((eq (typep (cadr cmd)) 'symbol) (cadr cmd))
306: ((eq (typep (caddr cmd)) 'symbol) (caddr cmd))))
307: (cond ((debug-sysp item) (setq sel (cons 'sysp sel)))
308: ((not (memq 'sysp sel))
309: (setq sel (cons 'user sel))))
310: (setq cnt
311: (cond ((fixp (cadr cmd)) (cadr cmd))
312: ((fixp (caddr cmd)) (caddr cmd))
313: (item 1)))
314: (cond ((null cnt)
315: (setq frame
316: (cond ((memq 'current sel) oframe)
317: (t (car rframelist))))
318: (go dbpr))
319: ((null item)
320: (setq frame (car framelist))
321: (and (or (not (memq 'user sel))
322: (atom (caddr (car framelist)))
323: (not (debug-sysp (caaddr (car framelist)))))
324: (setq cnt (|1-| cnt)))
325: (setq frame
326: (cond ((zerop cnt) frame)
327: ((memq 'user sel)
328: (debug-iter (debug-dnfn frame)))
329: (t (debug-iter (debug-dnframe frame)))))
330: (setq frame (or frame (car rframelist)))
331: (go dbpr))
332: (t (setq frame (car framelist))))
333: (setq frame
334: (cond ((and (= cnt 1)
335: (not (atom (caddr (car framelist))))
336: (eq item (caaddr (car framelist))))
337: (car framelist))
338: ((debug-iter (debug-findcall item frame framelist)))
339: (t (car rframelist))))
340: dbpr (debug-print frame sel oframe)
341: (cond ((eq frame (car rframelist))
342: (terpri)
343: (princ '|<bottom of stack>|)
344: (terpri))
345: (t (terpri)))
346: (cond
347: ((memq 'bogus sel)
348: (terpri)
349: (princ (car cmd))
350: (princ '| contains an invalid bk modifier|)))
351: (return oframe))))
352:
353: (def debug-print
354: (lambda (frame sel ptr)
355: (prog (curframe)
356: (setq curframe (car framelist))
357: loop (cond ((not
358: (and (memq 'user sel)
359: (not (atom (caddr curframe)))
360: (debug-sysp (caaddr curframe))))
361: (debug-print1 curframe sel)
362: (and (eq curframe ptr) (princ '| <--- you are here|)))
363: ((eq curframe ptr)
364: (terpri)
365: (princ '| <--- you are somewhere in here|)))
366: (and (eq curframe frame) (return frame))
367: (setq curframe (debug-dnframe curframe))
368: (or curframe (return frame))
369: (go loop))))
370:
371: (def debug-print1
372: (lambda (frame sel)
373: (prog (prinlevel prinlength varlist)
374: (and (not (memq 'expr sel))
375: (setq prinlevel 2)
376: (setq prinlength 5))
377: (cond
378: ((atom (caddr frame))
379: (terpri)
380: (princ '| |)
381: (fix-print (caddr frame))
382: (princ '| <- eval error|)
383: (return t)))
384: (and (memq 'bind sel)
385: (cond ((memq (caaddr frame) '(prog lambda))
386: (setq varlist (cadr (caddr frame))))
387: ((and (atom (caaddr frame)) (dtpr (getd (caaddr frame))))
388: (setq varlist (cadr (getd (caaddr frame))))))
389: (mapc (function
390: (lambda (v)
391: (debug-showvar v
392: (or (debug-upframe frame)
393: frame))))
394: (cond ((and varlist (atom varlist)) (ncons varlist))
395: (t varlist))))
396: (and (memq 'user sel)
397: (debug-sysp (caaddr frame))
398: (return nil))
399: (cond ((memq (caaddr frame) interrupt-handlers)
400: (terpri)
401: (princ '<------------)
402: (fix-print (cadr (assq (caaddr frame) handler-labels)))
403: (princ '-->))
404: ((eq (caaddr frame) 'debug)
405: (terpri)
406: (princ '<------debug------>))
407: ((memq 'fns sel)
408: (terpri)
409: (and (debug-sysp (caaddr frame)) (princ '| |))
410: (fix-print (caaddr frame)))
411: (t (terpri)
412: (fix-print
413: (cond ((eq (car frame) 'eval) (caddr frame))
414: (t (cons (caaddr frame) (cadr (caddr frame))))))))
415: (or (not (symbolp (caaddr frame)))
416: (eq (caaddr frame) (concat (caaddr frame)))
417: (princ '| <not interned>|))
418: (return t))))
419:
420: (def debug-findcall
421: (lambda (fn frame flist)
422: (prog nil
423: loop (setq frame (debug-nextframe frame flist nil))
424: (or frame (return nil))
425: (cond ((atom (caddr frame))
426: (cond ((eq (caddr frame) fn) (return frame)) (t (go loop))))
427: ((eq (caaddr frame) fn) (return frame))
428: (t (go loop))))))
429:
430: (def debug-scanflist
431: (lambda (frame fnset)
432: (prog nil
433: loop (or frame (return nil))
434: (and (not (atom (caddr frame)))
435: (memq (caaddr frame) fnset)
436: (return frame))
437: (setq frame (debug-dnframe frame))
438: (go loop))))
439:
440: (def debug-scanstk
441: (lambda (frame fnset)
442: (prog nil
443: loop (or frame (return nil))
444: (and (not (atom (caddr frame)))
445: (memq (caaddr frame) fnset)
446: (return frame))
447: (setq frame (evalframe (cadr frame)))
448: (go loop))))
449:
450: (def debug-getframes
451: (lambda nil
452: (prog (flist fnew)
453: (setq fnew
454: (debug-scanstk '(nil)
455: (cons 'debug interrupt-handlers)))
456: loop (and (not debug-sysmode)
457: (not (atom (caddr fnew)))
458: (eq (caaddr fnew) 'debug)
459: (eq (car (evalframe (cadr fnew))) 'apply)
460: (memq (caaddr (evalframe (cadr fnew))) interrupt-handlers)
461: (setq fnew (evalframe (cadr fnew))))
462: (and (not debug-sysmode)
463: (null flist)
464: (eq (car fnew) 'apply)
465: (memq (caaddr fnew) interrupt-handlers)
466: (setq fnew (evalframe (cadr fnew))))
467: (and (not debug-sysmode)
468: (eq (car fnew) 'apply)
469: (eq (typep (caaddr fnew)) 'symbol)
470: (not (eq (caaddr fnew) (concat (caaddr fnew))))
471: (setq fnew (evalframe (cadr fnew)))
472: (setq fnew (evalframe (cadr fnew)))
473: (setq fnew (evalframe (cadr fnew)))
474: (setq fnew (evalframe (cadr fnew)))
475: (go loop))
476: (and (not debug-sysmode)
477: (not (atom (caddr fnew)))
478: (memq (caaddr fnew) '(evalhook* evalhook))
479: (setq fnew (evalframe (cadr fnew)))
480: (go loop))
481: (and (not debug-sysmode)
482: (eq (car fnew) 'apply)
483: (eq (caaddr fnew) 'eval)
484: (cadadr (caddr fnew))
485: (or (not (fixp (cadadr (caddr fnew))))
486: (= (cadadr (caddr fnew)) -1))
487: (setq fnew (evalframe (cadr fnew)))
488: (go loop))
489: (and fnew
490: (setq flist (cons fnew flist))
491: (setq fnew (evalframe (cadr fnew)))
492: (go loop))
493: (return (nreverse flist)))))
494:
495: (def debug-nextframe
496: (lambda (frame flist sel)
497: (prog nil
498: (setq flist (cdr (memq frame flist)))
499: (and (not (memq 'user sel)) (return (car flist)))
500: loop (or flist (return nil))
501: (cond
502: ((or (atom (caddr (car flist)))
503: (not (debug-sysp (caaddr (car flist)))))
504: (return (car flist))))
505: (setq flist (cdr flist))
506: (go loop))))
507:
508: (def debug-upframe
509: (lambda (frame)
510: (debug-nextframe frame rframelist nil)))
511:
512: (def debug-dnframe
513: (lambda (frame)
514: (debug-nextframe frame framelist nil)))
515:
516: (def debug-upfn
517: (lambda (frame)
518: (debug-nextframe frame rframelist '(user))))
519:
520: (def debug-dnfn
521: (lambda (frame)
522: (debug-nextframe frame framelist '(user))))
523:
524: (def debug-showvar
525: (lambda (var frame)
526: (terpri)
527: (princ '| |)
528: (princ var)
529: (princ '| = |)
530: (fix-print
531: ((lambda (val) (cond ((atom val) '?) (t (car val))))
532: (errset (fix-eval var (cadddr frame)) nil)))))
533:
534: (def debug-nedit
535: (lambda (frame)
536: (prog (val body elem nframe)
537: (setq elem (caddr frame))
538: (setq val frame)
539: scan (setq val (debug-findusrfn val))
540: (or val (go nofn))
541: (setq body (getd (caaddr val)))
542: (cond ((debug-insidep elem body)
543: (princ '=)
544: (fix-print (caaddr val))
545: (edite body
546: (list 'f (cons '== elem) 'tty:)
547: (caaddr val))
548: (return frame))
549: ((or (eq elem (caddr val)) (debug-insidep elem (caddr val)))
550: (setq val (debug-dnframe val))
551: (go scan)))
552: nofn (setq nframe (debug-dnframe frame))
553: (or nframe (go doit))
554: (and (debug-insidep elem (caddr nframe))
555: (setq frame nframe)
556: (go nofn))
557: doit (edite (caddr frame)
558: (and (debug-insidep elem (caddr frame))
559: (list 'f (cons '== elem) 'tty:))
560: nil)
561: (return frame))))
562:
563: (def debug-insidep
564: (lambda (elem expr)
565: (car (errset (edite expr (list 'f (cons '== elem)) nil)))))
566:
567: (def debug-findusrfn
568: (lambda (frame)
569: (cond ((null frame) nil)
570: ((and (dtpr (caddr frame))
571: (symbolp (caaddr frame))
572: (dtpr (getd (caaddr frame))))
573: frame)
574: (t (debug-findusrfn (debug-dnframe frame))))))
575:
576: (def debug-findexpr
577: (lambda (frame)
578: (cond ((null frame) nil)
579: ((and (eq (car frame) 'eval) (not (atom (caddr frame))))
580: frame)
581: (t (debug-findexpr (debug-dnframe frame))))))
582:
583: (def debug-pop
584: (lambda nil
585: (prog (frame)
586: (setq frame (car framelist))
587: l (cond ((null (setq frame (evalframe (cadr frame))))(reset)))
588: (cond ((and (dtpr (caddr frame))(eq (caaddr frame) 'debug))
589: (freturn (cadr frame) nil)))
590: (go l))))
591:
592: (def debug-where
593: (lambda (frame)
594: (prog (lev diff nframe)
595: (setq lev (- (length framelist) (length (memq frame rframelist))))
596: (setq diff (- (length framelist) lev 1))
597: (debug-print1 frame nil)
598: (terpri)
599: (cond ((zerop diff) (princ '|you are at top of stack.|))
600: ((zerop lev) (princ '|you are at bottom of stack.|))
601: (t (princ '|you are |)
602: (princ diff)
603: (cond ((= diff 1) (princ '| frame from the top.|))
604: (t (princ '| frames from the top.|)))))
605: (terpri)
606: (and (or (atom (caddr frame)) (not (eq (car frame) 'eval)))
607: (return nil))
608: (setq lev 0)
609: (setq nframe frame)
610: lp (and (setq nframe (debug-findcall (caaddr nframe) nframe framelist))
611: (setq lev (|1+| lev))
612: (go lp))
613: (princ '|there are |)
614: (princ lev)
615: (princ '| |)
616: (princ (caaddr frame))
617: (princ '|'s below.|)
618: (terpri))))
619:
620: (def debug-sysp
621: (lambda (x)
622: (and (sysp x) (symbolp x) (not (dtpr (getd x))))))
623:
624: (dv interrupt-handlers (fixit))
625:
626: (dv handler-labels
627: ((fixit error)
628: (debug-ubv-handler ubv)
629: (debug-udf-handler udf)
630: (debug-fac-handler fac)
631: (debug-ugt-handler ugt)
632: (debug-wta-handler wta)
633: (debug-wna-handler wna)
634: (debug-iol-handler iol)
635: (debug-*rset-handler rst)
636: (debug-mer-handler mer)
637: (debug-gcd-handler gcd)
638: (debug-gcl-handler gcl)
639: (debug-gco-handler gco)
640: (debug-pdl-handler pdl)))
641:
642:
643: (or (boundp 'traced-stuff) (setq traced-stuff nil))
644:
645: (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
646:
647: (setq hush-debug nil)
648:
649:
650: ;; other functions grabbed from other cmu files to make this file complete
651: ;; unto itself
652:
653: ;- from sysfunc.l
654: (declare (special system-functions\))
655: (defun build-sysp nil
656: (do ((temp (oblist) (cdr temp))
657: (sysfuncs))
658: ((null temp)(setq system-functions\ sysfuncs));atom has ^G at end
659: (cond ((getd (car temp))
660: (setq sysfuncs (cons (car temp) sysfuncs))))))
661:
662: (defun sysp (x) ; (cond ((memq x system-functions\)t))
663: (memq x '(funcallhook* funcallhook evalhook evalhook*
664: continue-evaluation)))
665:
666: (or (boundp 'system-functions\) (build-sysp))
667:
668: (defun fretry (pdlpnt frame)
669: (freturn pdlpnt
670: (cond ((eq (car frame) 'eval) (eval (caddr frame) (cadddr frame)))
671: ((eq (car frame) 'apply)
672: (eval `(apply ',(caaddr frame) ',(cadaddr frame))
673: (cadddr frame))))))
674:
675:
676: ; - from cmu.l
677:
678: (def %lineread
679: (lambda (chan)
680: (prog (ans)
681: loop (setq ans (cons (read chan 'EOF) ans))
682: (cond ((eq (car ans) 'EOF) (return (reverse (cdr ans)))))
683: loop2(cond ((eq 10 (tyipeek chan)) (return (reverse ans)))
684: ((memq (tyipeek chan) '(41 93))
685: (tyi chan)
686: (go loop2))
687: (t (go loop))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.