![[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] / 43BSDReno / pgrm / lisp / pearl|
Return to fix.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fix.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; The fixit debugger modified to use "pearlfixprintfn" and to allow
3: ; use of "> fcnname" or "> 'newvalue" in case of an undefined
4: ; function or unbound variable respectively.
5: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6:
7: ; Modified for use with PEARL by Joe Faletti 1/6/82
8:
9: ;; (eval-when (compile eval)
10: ;; (or (get 'cmumacs 'version) (load 'cmumacs)))
11: ; Only the necessary functions are included, below
12: ; dv (=defv), ***, lineread, and ty
13:
14: ;--- dv :: set variable to value
15: ; (dv name value) name is setq'ed to value (no evaluation)
16: ; (same as defv)
17: ;
18: (defmacro dv (name value)
19: `(setq ,name ',value))
20:
21: ;--- *** :: comment macro
22: ;
23: (defmacro *** (&rest x) nil)
24:
25: (defmacro lineread (&optional (x nil))
26: `(%lineread ,x))
27:
28: (def ty (macro (f) (append '(exec cat) (cdr f))))
29:
30: ; LWE 1/11/81 Hack hack....
31: ;
32: ; LWE 1/11/81 Bet you didn't know this, but this won't work INTERPRETED,
33: ; but Dave assures me it works compiled. (In MACLisp...)
34: ;
35: (declare (special cmd frame x cnt var init label part incr limit selectq))
36:
37: (dv fixfns
38: ((*** This is FIXIT written by David Touretzky and adapted to Franz by Don
39: Cohen)
40: (declare (special framelist rframelist interrupt-handlers handler-labels)
41: (special prinlevel prinlength evalhook-switch traced-stuff)
42: (special lastword piport hush-debug)
43: (*fexpr editf step type))
44: (sstatus feature fixit)
45: (*rset t)
46: ER%tpl
47: fixit
48: debug
49: debug-iter
50: debug1
51: debug-bktrace
52: Pdebug-print
53: Pdebug-print1
54: debug-findcall
55: debug-scanflist
56: debug-scanstk
57: debug-getframes
58: debug-nextframe
59: debug-upframe
60: debug-dnframe
61: debug-upfn
62: debug-dnfn
63: debug-showvar
64: debug-nedit
65: debug-insidep
66: debug-findusrfn
67: debug-findexpr
68: debug-replace-function-name
69: debug-pop
70: debug-where
71: debug-sysp
72: interrupt-handlers
73: handler-labels
74: (or (boundp 'traced-stuff) (setq traced-stuff nil))
75: (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
76: (setq hush-debug nil)))
77:
78: (or (boundp 'traced-stuff) (setq traced-stuff nil))
79: (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
80: (or (boundp 'debug-sysmode) (setq debug-sysmode nil))
81: (setq hush-debug nil)
82:
83: (*** This is FIXIT written by David Touretzky and adapted to Franz by Don Cohen)
84:
85: (declare (special framelist rframelist interrupt-handlers handler-labels)
86: (special prinlevel prinlength evalhook-switch traced-stuff)
87: (special lastword piport hush-debug debug-sysmode)
88: (*fexpr editf step type)
89: (special system-functions\))
90:
91: (sstatus feature fixit)
92:
93: (*rset t)
94:
95: (progn 'compile
96: (dv ER%tpl fixit)
97: (dv ER%brk fixit)
98: (dv ER%err fixit)
99: )
100:
101: (def fixit
102: (nlambda (l)
103: (prog (piport)
104: (do nil (nil) (eval (cons 'debug l))))))
105:
106: (def debug
107: (nlambda (params)
108: (prog (cmd frame framelist rframelist nframe val infile)
109: (setq infile t)
110: (and evalhook-switch (step nil))
111: (setq rframelist
112: (reverse
113: (setq framelist
114: (or (debug-getframes)
115: (list
116: (debug-scanstk '(nil) '(debug)))))))
117: (setq frame (debug-findexpr (car framelist)))
118: ;(tab 0)
119: ; top level ones and calls to err and break.
120: (cond
121: ((and (car params) (not (eq (car params) 'edit)))
122: (terpri)
123: ; (princ '|;debug |)
124: ; (princ params)
125: (princ (cadddr params))
126: (cond ((cddddr params)
127: (princ '| -- |)
128: (princ (cddddr params))))
129: (terpri)
130: (go loop)))
131: (Pdebug-print1 frame nil)
132: (terpri)
133: (cond (hush-debug (setq hush-debug nil) (go loop))
134: ((not (memq 'edit params)) (go loop)))
135: (drain nil)
136: (princ '|type e to edit, <cr> to debug: |)
137: (setq val (tyi))
138: (cond ((or (\=& val 69) (\=& val 101))
139: (and (errset (debug-nedit frame))
140: (setq cmd '(ok))
141: (go cmdr)))
142: ((or (\=& val 78) (\=& val 110)) (terpri) (debug-pop)))
143: loop (terpri)
144: (princ ':)
145: (cond ((null (setq cmd (lineread)))
146: (terpri) (reset)))
147: cmdr (cond
148: ((dtpr (car cmd))
149: (setq val (eval (car cmd) (cadddr frame)))
150: (pearlfixprintfn val)
151: ; (print (valform val))
152: (terpri)
153: (go loop)))
154: (setq nframe (debug1 cmd frame))
155: (and (not (atom nframe)) (setq frame nframe) (go loop))
156: (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) (\=& 0 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 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 (Pdebug-print1 (setq frame topframe) nil))
198: (bot (Pdebug-print1 (setq frame (car rframelist)) nil))
199: (p (Pdebug-print1 frame nil))
200: (pp (valprint (caddr frame)))
201: (where (debug-where frame))
202: (help
203: (cond ((cdr cmd) (eval cmd))
204: (t (ty |/usr/lisp/doc/fixit.ref|))))
205: ((\? h) (ty |/usr/lisp/doc/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: (Pdebug-print1 (setq frame (or nframe frame)) nil))
234: (d (setq nframe
235: (or (debug-iter (debug-dnframe frame)) frame))
236: (Pdebug-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: (Pdebug-print1 frame nil))
246: (dn (setq frame
247: (or (debug-iter (debug-dnfn frame))
248: (car rframelist)))
249: (Pdebug-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 (Pdebug-print1 frame nil)))
258: (dns (setq frame
259: (debug-iter
260: (debug-findcall item frame framelist)))
261: (and frame (Pdebug-print1 frame nil)))
262: (sys (setq debug-sysmode (not debug-sysmode))
263: (patom "sysmode now ")(patom debug-sysmode) (terpr))
264: (otherwise
265: (cond ((not (dtpr (car cmd)))
266: (*** should there also be a boundp test here)
267: (debug-showvar (car cmd) frame))
268: (t (setq frame (car cmd))))))
269: (return (or frame item)))))
270:
271: (def debug-replace-function-name
272: (lambda (cmd frame) (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: (otherwise '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 ((\=& 0 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 (Pdebug-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 Pdebug-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: (Pdebug-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 Pdebug-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: (pearlfixprintfn (caddr frame))
382: ; (print (valform (caddr frame)))
383: (princ '| <- eval error|)
384: (return t)))
385: (and (memq 'bind sel)
386: (cond ((memq (caaddr frame) '(prog lambda))
387: (setq varlist (cadr (caddr frame))))
388: ((and (atom (caaddr frame)) (dtpr (getd (caaddr frame))))
389: (setq varlist (cadr (getd (caaddr frame))))))
390: (mapc (function
391: (lambda (v)
392: (debug-showvar v
393: (or (debug-upframe frame)
394: frame))))
395: (cond ((and varlist (atom varlist)) (ncons varlist))
396: (t varlist))))
397: (and (memq 'user sel)
398: (debug-sysp (caaddr frame))
399: (return nil))
400: (cond ((memq (caaddr frame) interrupt-handlers)
401: (terpri)
402: (princ '<------------)
403: (print (cadr (assq (caaddr frame) handler-labels)))
404: (princ '-->))
405: ((eq (caaddr frame) 'debug)
406: (terpri)
407: (princ '<------debug------>))
408: ((memq 'fns sel)
409: (terpri)
410: (and (debug-sysp (caaddr frame)) (princ '| |))
411: (print (caaddr frame)))
412: (t (terpri)
413: (pearlfixprintfn
414: (cond ((eq (car frame) 'eval) (caddr frame))
415: (t (cons (caaddr frame) (cadr (caddr frame))))))
416: ; (print
417: ; (valform
418: ; (cond ((eq (car frame) 'eval) (caddr frame))
419: ; (t (cons (caaddr frame) (cadr (caddr frame)))))))
420: ))
421: (or (not (symbolp (caaddr frame)))
422: (eq (caaddr frame) (concat (caaddr frame)))
423: (princ '| <not interned>|))
424: (return t))))
425:
426: (def debug-findcall
427: (lambda (fn frame flist)
428: (prog nil
429: loop (setq frame (debug-nextframe frame flist nil))
430: (or frame (return nil))
431: (cond ((atom (caddr frame))
432: (cond ((eq (caddr frame) fn) (return frame)) (t (go loop))))
433: ((eq (caaddr frame) fn) (return frame))
434: (t (go loop))))))
435:
436: (def debug-scanflist
437: (lambda (frame fnset)
438: (prog nil
439: loop (or frame (return nil))
440: (and (not (atom (caddr frame)))
441: (memq (caaddr frame) fnset)
442: (return frame))
443: (setq frame (debug-dnframe frame))
444: (go loop))))
445:
446: (def debug-scanstk
447: (lambda (frame fnset)
448: (prog nil
449: loop (or frame (return nil))
450: (and (not (atom (caddr frame)))
451: (memq (caaddr frame) fnset)
452: (return frame))
453: (setq frame (evalframe (cadr frame)))
454: (go loop))))
455:
456: (def debug-getframes
457: (lambda nil
458: (prog (flist fnew)
459: (setq fnew
460: (debug-scanstk '(nil)
461: (cons 'debug interrupt-handlers)))
462: loop (and (not debug-sysmode)
463: (not (atom (caddr fnew)))
464: (eq (caaddr fnew) 'debug)
465: (eq (car (evalframe (cadr fnew))) 'apply)
466: (memq (caaddr (evalframe (cadr fnew))) interrupt-handlers)
467: (setq fnew (evalframe (cadr fnew))))
468: (and (not debug-sysmode)
469: (null flist)
470: (eq (car fnew) 'apply)
471: (memq (caaddr fnew) interrupt-handlers)
472: (setq fnew (evalframe (cadr fnew))))
473: (and (not debug-sysmode)
474: (eq (car fnew) 'apply)
475: (eq (typep (caaddr fnew)) 'symbol)
476: (not (eq (caaddr fnew) (concat (caaddr fnew))))
477: (setq fnew (evalframe (cadr fnew)))
478: (setq fnew (evalframe (cadr fnew)))
479: (setq fnew (evalframe (cadr fnew)))
480: (setq fnew (evalframe (cadr fnew)))
481: (go loop))
482: (and (not debug-sysmode)
483: (not (atom (caddr fnew)))
484: (memq (caaddr fnew) '(evalhook* evalhook))
485: (setq fnew (evalframe (cadr fnew)))
486: (go loop))
487: (and (not debug-sysmode)
488: (eq (car fnew) 'apply)
489: (eq (caaddr fnew) 'eval)
490: (cadadr (caddr fnew))
491: (or (not (fixp (cadadr (caddr fnew))))
492: (\= (cadadr (caddr fnew)) -1))
493: (setq fnew (evalframe (cadr fnew)))
494: (go loop))
495: (and fnew
496: (setq flist (cons fnew flist))
497: (setq fnew (evalframe (cadr fnew)))
498: (go loop))
499: (return (nreverse flist)))))
500:
501: (def debug-nextframe
502: (lambda (frame flist sel)
503: (prog nil
504: (setq flist (cdr (memq frame flist)))
505: (and (not (memq 'user sel)) (return (car flist)))
506: loop (or flist (return nil))
507: (cond
508: ((or (atom (caddr (car flist)))
509: (not (debug-sysp (caaddr (car flist)))))
510: (return (car flist))))
511: (setq flist (cdr flist))
512: (go loop))))
513:
514: (def debug-upframe
515: (lambda (frame)
516: (debug-nextframe frame rframelist nil)))
517:
518: (def debug-dnframe
519: (lambda (frame)
520: (debug-nextframe frame framelist nil)))
521:
522: (def debug-upfn
523: (lambda (frame)
524: (debug-nextframe frame rframelist '(user))))
525:
526: (def debug-dnfn
527: (lambda (frame)
528: (debug-nextframe frame framelist '(user))))
529:
530: (def debug-showvar
531: (lambda (var frame)
532: (terpri)
533: (princ '| |)
534: (princ var)
535: (princ '| = |)
536: (pearlfixprintfn
537: ((lambda (val) (cond ((atom val) '\?) (t (car val))))
538: (errset (eval var (cadddr frame)) nil)))))
539: ; (print
540: ; (valform
541: ; ((lambda (val) (cond ((atom val) '\?) (t (car val))))
542: ; (errset (eval var (cadddr frame)) nil))))))
543:
544: (def debug-nedit
545: (lambda (frame)
546: (prog (val body elem nframe)
547: (setq elem (caddr frame))
548: (setq val frame)
549: scan (setq val (debug-findusrfn val))
550: (or val (go nofn))
551: (setq body (getd (caaddr val)))
552: (cond ((debug-insidep elem body)
553: (princ '\=)
554: (print (caaddr val))
555: (edite body
556: (list 'f (cons '\=\= elem) 'tty:)
557: (caaddr val))
558: (return frame))
559: ((or (eq elem (caddr val)) (debug-insidep elem (caddr val)))
560: (setq val (debug-dnframe val))
561: (go scan)))
562: nofn (setq nframe (debug-dnframe frame))
563: (or nframe (go doit))
564: (and (debug-insidep elem (caddr nframe))
565: (setq frame nframe)
566: (go nofn))
567: doit (edite (caddr frame)
568: (and (debug-insidep elem (caddr frame))
569: (list 'f (cons '\=\= elem) 'tty:))
570: nil)
571: (return frame))))
572:
573: (def debug-insidep
574: (lambda (elem expr)
575: (car (errset (edite expr (list 'f (cons '\=\= elem)) nil)))))
576:
577: (def debug-findusrfn
578: (lambda (frame)
579: (cond ((null frame) nil)
580: ((and (dtpr (caddr frame))
581: (symbolp (caaddr frame))
582: (dtpr (getd (caaddr frame))))
583: frame)
584: (t (debug-findusrfn (debug-dnframe frame))))))
585:
586: (def debug-findexpr
587: (lambda (frame)
588: (cond ((null frame) nil)
589: ((and (eq (car frame) 'eval) (not (atom (caddr frame))))
590: frame)
591: (t (debug-findexpr (debug-dnframe frame))))))
592:
593: (def debug-pop
594: (lambda nil
595: (prog (frame)
596: (setq frame (car framelist))
597: l (cond ((null (setq frame (evalframe (cadr frame))))(reset)))
598: (cond ((and (dtpr (caddr frame))(eq (caaddr frame) 'debug))
599: (freturn (cadr frame) nil)))
600: (go l))))
601:
602: (def debug-where
603: (lambda (frame)
604: (prog (lev diff nframe)
605: (setq lev (- (length framelist) (length (memq frame rframelist))))
606: (setq diff (- (length framelist) lev 1))
607: (Pdebug-print1 frame nil)
608: (terpri)
609: (cond ((\=& 0 diff) (princ '|you are at top of stack.|))
610: ((\=& 0 lev) (princ '|you are at bottom of stack.|))
611: (t (princ '|you are |)
612: (princ diff)
613: (cond ((\=& diff 1) (princ '| frame from the top.|))
614: (t (princ '| frames from the top.|)))))
615: (terpri)
616: (and (or (atom (caddr frame)) (not (eq (car frame) 'eval)))
617: (return nil))
618: (setq lev 0)
619: (setq nframe frame)
620: lp (and (setq nframe (debug-findcall (caaddr nframe) nframe framelist))
621: (setq lev (|1+| lev))
622: (go lp))
623: (princ '|there are |)
624: (princ lev)
625: (princ '| |)
626: (princ (caaddr frame))
627: (princ '|'s below.|)
628: (terpri))))
629:
630: (def debug-sysp
631: (lambda (x)
632: (and (sysp x) (symbolp x) (not (dtpr (getd x))))))
633:
634: (dv interrupt-handlers (fixit))
635:
636: (dv handler-labels
637: ((fixit error)
638: (debug-ubv-handler ubv)
639: (debug-udf-handler udf)
640: (debug-fac-handler fac)
641: (debug-ugt-handler ugt)
642: (debug-wta-handler wta)
643: (debug-wna-handler wna)
644: (debug-iol-handler iol)
645: (debug-*rset-handler rst)
646: (debug-mer-handler mer)
647: (debug-gcd-handler gcd)
648: (debug-gcl-handler gcl)
649: (debug-gco-handler gco)
650: (debug-pdl-handler pdl)))
651:
652:
653: (or (boundp 'traced-stuff) (setq traced-stuff nil))
654:
655: (or (boundp 'evalhook-switch) (setq evalhook-switch nil))
656:
657: (setq hush-debug nil)
658:
659:
660: ;; other functions grabbed from other cmu files to make this file complete
661: ;; unto itself
662:
663: ;- from sysfunc.l
664:
665: (defun build-sysp nil
666: (do ((temp (oblist) (cdr temp))
667: (sysfuncs))
668: ((null temp)(setq system-functions\ sysfuncs));atom has ^G at end
669: (cond ((getd (car temp))
670: (setq sysfuncs (cons (car temp) sysfuncs))))))
671:
672: (defun sysp (x) ; (cond ((memq x system-functions\)t))
673: (memq x '(funcallhook* funcallhook evalhook evalhook*
674: continue-evaluation)))
675:
676: (or (boundp 'system-functions\) (build-sysp))
677:
678: (defun fretry (pdlpnt frame)
679: (freturn pdlpnt
680: (cond ((eq (car frame) 'eval) (eval (caddr frame) (cadddr frame)))
681: ((eq (car frame) 'apply)
682: (eval `(apply ',(caaddr frame) ',(cadaddr frame))
683: (cadddr frame))))))
684:
685:
686: ; - from cmu.l
687:
688: (def %lineread
689: (lambda (chan)
690: (prog (ans)
691: loop (setq ans (cons (read chan 'EOF) ans))
692: (cond ((eq (car ans) 'EOF) (return (reverse (cdr ans)))))
693: loop2(cond ((eq 10 (tyipeek chan)) (return (reverse ans)))
694: ((memq (tyipeek chan) '(41 93))
695: (tyi chan)
696: (go loop2))
697: (t (go loop))))))
698:
699:
700: (aliasdef 'pearlbreak 'fixit)
701:
702: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.