![[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] / 43BSD / ucb / lisp / lisplib|
Return to fix.l CVS log | Up to [CSRG BSD Unix] / 43BSD / 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.