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