From c84db70e9636a509544e76eba4e493f4f35ab813 Mon Sep 17 00:00:00 2001 From: CSRG Date: Tue, 9 Aug 1983 00:25:44 -0800 Subject: [PATCH] BSD 4_3_Net_2 development Work on file usr/src/usr.bin/lisp/lisplib/fix.l Synthesized-from: CSRG/cd2/net.2 --- usr/src/usr.bin/lisp/lisplib/fix.l | 687 +++++++++++++++++++++++++++++ 1 file changed, 687 insertions(+) create mode 100644 usr/src/usr.bin/lisp/lisplib/fix.l diff --git a/usr/src/usr.bin/lisp/lisplib/fix.l b/usr/src/usr.bin/lisp/lisplib/fix.l new file mode 100644 index 0000000000..9eaa0d91d7 --- /dev/null +++ b/usr/src/usr.bin/lisp/lisplib/fix.l @@ -0,0 +1,687 @@ +(setq rcs-fix- + "$Header: /usr/lib/lisp/RCS/fix.l,v 1.2 83/08/06 08:39:58 jkf Exp $") + +; vi: set lisp : + +(eval-when (compile eval) + (or (get 'cmumacs 'version) (load 'cmumacs))) + +; LWE 1/11/81 Hack hack.... +; +; LWE 1/11/81 Bet you didn't know this, but this won't work INTERPRETED, +; but Dave assures me it works compiled. (In MACLisp...) +; +(declare (special cmd frame x cnt var init label part incr limit selectq)) + +(dv fixfns + ((*** This is FIXIT written by David Touretzky and adapted to Franz by Don + Cohen) + (declare (special framelist rframelist interrupt-handlers handler-labels) + (special prinlevel prinlength evalhook-switch traced-stuff) + (special lastword piport hush-debug) + (*fexpr editf step type)) + (sstatus feature fixit) + (*rset t) + ER%tpl + fixit + debug + debug-iter + debug1 + debug-bktrace + debug-print + debug-print1 + debug-findcall + debug-replace-function-name + debug-scanflist + debug-scanstk + debug-getframes + debug-nextframe + debug-upframe + debug-dnframe + debug-upfn + debug-dnfn + debug-showvar + debug-nedit + debug-insidep + debug-findusrfn + debug-findexpr + debug-pop + debug-where + debug-sysp + interrupt-handlers + handler-labels + (or (boundp 'traced-stuff) (setq traced-stuff nil)) + (or (boundp 'evalhook-switch) (setq evalhook-switch nil)) + (setq hush-debug nil))) + +(or (boundp 'traced-stuff) (setq traced-stuff nil)) +(or (boundp 'evalhook-switch) (setq evalhook-switch nil)) +(or (boundp 'debug-sysmode) (setq debug-sysmode nil)) +(setq hush-debug nil) + +(*** This is FIXIT written by David Touretzky and adapted to Franz by Don Cohen) + +(declare (special framelist rframelist interrupt-handlers handler-labels) + (special prinlevel prinlength evalhook-switch traced-stuff) + (special lastword piport hush-debug debug-sysmode) + (*fexpr editf step type)) + +(defvar fixit-eval nil) +(defvar fixit-print nil) +(defvar fixit-pp nil) + +(sstatus feature fixit) + +(*rset t) + +; (jkf) it is not clear that you want this to take over on all errors, +; but the cmu people seem to want that. +#+cmu (progn 'compile + (dv ER%tpl fixit) + (dv ER%all fixit) ; LWE 1/17/81 MAYBE THIS WILL FIX THIS code + ) + +;--- eval, print and pretty-print functions are user-selectable by just +; assigning another value to fixit-eval, fixit-print and fixit-pp. +; +(defmacro fix-eval (&rest args) + `(cond ((and fixit-eval + (getd fixit-eval)) + (funcall fixit-eval ,@args)) + (t (eval ,@args)))) + +(defmacro fix-print (&rest args) + `(cond ((and fixit-print + (getd fixit-print)) + (funcall fixit-print ,@args)) + (t (print ,@args)))) + +(defmacro fix-pp (&rest args) + `(cond ((and fixit-pp + (getd fixit-pp)) + (funcall fixit-pp ,@args)) + (t ($prpr ,@args)))) + +(def fixit + (nlambda (l) + (prog (piport) + (do nil (nil) (eval (cons 'debug l)))))) + +(def debug + (nlambda (params) + (prog (cmd frame framelist rframelist nframe val infile) + (setq infile t) + (and evalhook-switch (step nil)) + (setq rframelist + (reverse + (setq framelist + (or (debug-getframes) + (list + (debug-scanstk '(nil) '(debug))))))) + (setq frame (debug-findexpr (car framelist))) + ;(tab 0) + (cond + ((and (car params) (not (eq (car params) 'edit))) + (terpri) + (princ '|;debug: |) + (princ (cadddr params)) + (cond ((cddddr params) + (princ '| -- |) + (fix-print (cddddr params)))) + (terpri) + (go loop))) + (debug-print1 frame nil) + (terpri) + (cond (hush-debug (setq hush-debug nil) (go loop)) + ((not (memq 'edit params)) (go loop))) + (drain nil) + (princ '|type e to edit, to debug: |) + (setq val (tyi)) + (cond ((or (= val 69) (= val 101)) + (and (errset (debug-nedit frame)) + (setq cmd '(ok)) + (go cmdr))) + ((or (= val 78) (= val 110)) (terpri) (debug-pop))) + loop (terpri) + (princ ':) + (cond ((null (setq cmd (lineread))) (reset))) + cmdr (cond + ((dtpr (car cmd)) + (setq val (fix-eval (car cmd) (cadddr frame))) + (fix-print val) + (terpri) + (go loop))) + (setq nframe (debug1 cmd frame)) + (and (not (atom nframe)) (setq frame nframe) (go loop)) + (fix-print (or nframe (car cmd))) + (princ '" Huh? - type h for help") + (go loop)))) + +(def debug-iter + (macro (x) + (cons 'prog + (cons 'nil + (cons 'loop + (cons (list 'setq 'nframe (cadr x)) + '((setq cnt (|1-| cnt)) + (and (or (null nframe) (zerop cnt)) + (return nframe)) + (setq frame nframe) + (go loop)))))))) + +(def debug1 + (lambda (cmd frame) + (prog (nframe val topframe cnt item) + (setq topframe (car framelist)) + (or (eq (typep (car cmd)) 'symbol) (return nil)) + ; if "> name", replace function or variable name with new atom + (and (eq (car cmd) '>) + (return (debug-replace-function-name cmd topframe))) + (and (eq (getchar (car cmd) 1) 'b) + (eq (getchar (car cmd) 2) 'k) + (return (debug-bktrace cmd frame))) + (setq cnt + (cond ((fixp (cadr cmd)) (cadr cmd)) + ((fixp (caddr cmd)) (caddr cmd)) + (t 1))) + (and (< cnt 1) (setq cnt 1)) + (setq item + (cond ((symbolp (cadr cmd)) (cadr cmd)) + ((symbolp (caddr cmd)) (caddr cmd)))) + (and item + (cond ((memq (car cmd) '(u up)) + (setq cmd (cons 'ups (cdr cmd)))) + ((memq (car cmd) '(d dn)) + (setq cmd (cons 'dns (cdr cmd)))))) + (selectq (car cmd) + (top (debug-print1 (setq frame topframe) nil)) + (bot (debug-print1 (setq frame (car rframelist)) nil)) + (p (debug-print1 frame nil)) + (pp (fix-pp (caddr frame))) + (where (debug-where frame)) + (help + (cond ((cdr cmd) (eval cmd)) + (t (ty |/usr/lib/lisp/fixit.ref|)))) + ((? h) (ty |/usr/lib/lisp/fixit.ref|)) + ((go ok) + (setq frame (debug-findexpr topframe)) + (cond ((eq (caaddr frame) 'debug) + (freturn (cadr frame) t)) + (t (fretry (cadr frame) frame)))) + (pop (debug-pop)) + (step (setq frame (debug-findexpr frame)) + (step t) + (fretry (cadr (debug-dnframe frame)) frame)) + (redo (and item + (setq frame + (debug-findcall item frame framelist))) + (and frame (fretry (cadr frame) frame))) + (return (setq val (eval (cadr cmd))) + (freturn (cadr frame) val)) + (edit (debug-nedit frame)) + (editf + (cond ((null item) + (setq frame + (or (debug-findusrfn (debug-nedit frame)) + (car rframelist)))) + ((dtpr (getd item)) + (errset (funcall 'editf (list item)))) + (t (setq frame nil)))) + (u (debug-iter (debug-upframe frame)) + (cond + ((null nframe) (terpri) (princ '||))) + (debug-print1 (setq frame (or nframe frame)) nil)) + (d (setq nframe + (or (debug-iter (debug-dnframe frame)) frame)) + (debug-print1 nframe nil) + (cond ((eq frame nframe) + (terpri) + (princ '||)) + (t (setq frame nframe)))) + (up (setq nframe (debug-iter (debug-upfn frame))) + (cond + ((null nframe) (terpri) (princ '|top of stack|))) + (setq frame (or nframe topframe)) + (debug-print1 frame nil)) + (dn (setq frame + (or (debug-iter (debug-dnfn frame)) + (car rframelist))) + (debug-print1 frame nil) + (cond + ((not (eq frame nframe)) + (terpri) + (princ '||)))) + (ups (setq frame + (debug-iter + (debug-findcall item frame rframelist))) + (and frame (debug-print1 frame nil))) + (dns (setq frame + (debug-iter + (debug-findcall item frame framelist))) + (and frame (debug-print1 frame nil))) + (sys (setq debug-sysmode (not debug-sysmode)) + (patom "sysmode now ")(patom debug-sysmode) (terpr)) + (cond ((not (dtpr (car cmd))) + (*** should there also be a boundp test here) + (debug-showvar (car cmd) frame)) + (t (setq frame (car cmd))))) + (return (or frame item))))) + +(def debug-replace-function-name + (lambda (cmd frame) + (prog (oldname newname errorcall nframe) + (setq errorcall (caddr frame)) + (cond ((eq (caddddr errorcall) '|eval: Undefined function |) + (setq oldname (cadddddr errorcall)) + (setq newname (cadr cmd)) + (setq cnt 3.) + (setq frame (debug-iter (debug-dnframe frame))) + (dsubst newname oldname frame) + (fretry (cadr frame) frame)) + ((eq (caddddr errorcall) '|Unbound Variable:|) + (setq oldname (cadddddr errorcall)) + (setq newname (eval (cadr cmd))) + (setq cnt 3.) + (setq frame (debug-iter (debug-dnframe frame))) + (dsubst newname oldname frame) + (fretry (cadr frame) frame)) + ( t (return nil)))))) + +(def debug-bktrace + (lambda (cmd oframe) + (prog (sel cnt item frame nframe) + (mapc '(lambda (x) + (setq sel + (cons (selectq x + (f 'fns) + (a 'sysp) + (v 'bind) + (e 'expr) + (c 'current) + 'bogus) + sel))) + (cddr (explodec (car cmd)))) + (setq item + (cond ((eq (typep (cadr cmd)) 'symbol) (cadr cmd)) + ((eq (typep (caddr cmd)) 'symbol) (caddr cmd)))) + (cond ((debug-sysp item) (setq sel (cons 'sysp sel))) + ((not (memq 'sysp sel)) + (setq sel (cons 'user sel)))) + (setq cnt + (cond ((fixp (cadr cmd)) (cadr cmd)) + ((fixp (caddr cmd)) (caddr cmd)) + (item 1))) + (cond ((null cnt) + (setq frame + (cond ((memq 'current sel) oframe) + (t (car rframelist)))) + (go dbpr)) + ((null item) + (setq frame (car framelist)) + (and (or (not (memq 'user sel)) + (atom (caddr (car framelist))) + (not (debug-sysp (caaddr (car framelist))))) + (setq cnt (|1-| cnt))) + (setq frame + (cond ((zerop cnt) frame) + ((memq 'user sel) + (debug-iter (debug-dnfn frame))) + (t (debug-iter (debug-dnframe frame))))) + (setq frame (or frame (car rframelist))) + (go dbpr)) + (t (setq frame (car framelist)))) + (setq frame + (cond ((and (= cnt 1) + (not (atom (caddr (car framelist)))) + (eq item (caaddr (car framelist)))) + (car framelist)) + ((debug-iter (debug-findcall item frame framelist))) + (t (car rframelist)))) + dbpr (debug-print frame sel oframe) + (cond ((eq frame (car rframelist)) + (terpri) + (princ '||) + (terpri)) + (t (terpri))) + (cond + ((memq 'bogus sel) + (terpri) + (princ (car cmd)) + (princ '| contains an invalid bk modifier|))) + (return oframe)))) + +(def debug-print + (lambda (frame sel ptr) + (prog (curframe) + (setq curframe (car framelist)) + loop (cond ((not + (and (memq 'user sel) + (not (atom (caddr curframe))) + (debug-sysp (caaddr curframe)))) + (debug-print1 curframe sel) + (and (eq curframe ptr) (princ '| <--- you are here|))) + ((eq curframe ptr) + (terpri) + (princ '| <--- you are somewhere in here|))) + (and (eq curframe frame) (return frame)) + (setq curframe (debug-dnframe curframe)) + (or curframe (return frame)) + (go loop)))) + +(def debug-print1 + (lambda (frame sel) + (prog (prinlevel prinlength varlist) + (and (not (memq 'expr sel)) + (setq prinlevel 2) + (setq prinlength 5)) + (cond + ((atom (caddr frame)) + (terpri) + (princ '| |) + (fix-print (caddr frame)) + (princ '| <- eval error|) + (return t))) + (and (memq 'bind sel) + (cond ((memq (caaddr frame) '(prog lambda)) + (setq varlist (cadr (caddr frame)))) + ((and (atom (caaddr frame)) (dtpr (getd (caaddr frame)))) + (setq varlist (cadr (getd (caaddr frame)))))) + (mapc (function + (lambda (v) + (debug-showvar v + (or (debug-upframe frame) + frame)))) + (cond ((and varlist (atom varlist)) (ncons varlist)) + (t varlist)))) + (and (memq 'user sel) + (debug-sysp (caaddr frame)) + (return nil)) + (cond ((memq (caaddr frame) interrupt-handlers) + (terpri) + (princ '<------------) + (fix-print (cadr (assq (caaddr frame) handler-labels))) + (princ '-->)) + ((eq (caaddr frame) 'debug) + (terpri) + (princ '<------debug------>)) + ((memq 'fns sel) + (terpri) + (and (debug-sysp (caaddr frame)) (princ '| |)) + (fix-print (caaddr frame))) + (t (terpri) + (fix-print + (cond ((eq (car frame) 'eval) (caddr frame)) + (t (cons (caaddr frame) (cadr (caddr frame)))))))) + (or (not (symbolp (caaddr frame))) + (eq (caaddr frame) (concat (caaddr frame))) + (princ '| |)) + (return t)))) + +(def debug-findcall + (lambda (fn frame flist) + (prog nil + loop (setq frame (debug-nextframe frame flist nil)) + (or frame (return nil)) + (cond ((atom (caddr frame)) + (cond ((eq (caddr frame) fn) (return frame)) (t (go loop)))) + ((eq (caaddr frame) fn) (return frame)) + (t (go loop)))))) + +(def debug-scanflist + (lambda (frame fnset) + (prog nil + loop (or frame (return nil)) + (and (not (atom (caddr frame))) + (memq (caaddr frame) fnset) + (return frame)) + (setq frame (debug-dnframe frame)) + (go loop)))) + +(def debug-scanstk + (lambda (frame fnset) + (prog nil + loop (or frame (return nil)) + (and (not (atom (caddr frame))) + (memq (caaddr frame) fnset) + (return frame)) + (setq frame (evalframe (cadr frame))) + (go loop)))) + +(def debug-getframes + (lambda nil + (prog (flist fnew) + (setq fnew + (debug-scanstk '(nil) + (cons 'debug interrupt-handlers))) + loop (and (not debug-sysmode) + (not (atom (caddr fnew))) + (eq (caaddr fnew) 'debug) + (eq (car (evalframe (cadr fnew))) 'apply) + (memq (caaddr (evalframe (cadr fnew))) interrupt-handlers) + (setq fnew (evalframe (cadr fnew)))) + (and (not debug-sysmode) + (null flist) + (eq (car fnew) 'apply) + (memq (caaddr fnew) interrupt-handlers) + (setq fnew (evalframe (cadr fnew)))) + (and (not debug-sysmode) + (eq (car fnew) 'apply) + (eq (typep (caaddr fnew)) 'symbol) + (not (eq (caaddr fnew) (concat (caaddr fnew)))) + (setq fnew (evalframe (cadr fnew))) + (setq fnew (evalframe (cadr fnew))) + (setq fnew (evalframe (cadr fnew))) + (setq fnew (evalframe (cadr fnew))) + (go loop)) + (and (not debug-sysmode) + (not (atom (caddr fnew))) + (memq (caaddr fnew) '(evalhook* evalhook)) + (setq fnew (evalframe (cadr fnew))) + (go loop)) + (and (not debug-sysmode) + (eq (car fnew) 'apply) + (eq (caaddr fnew) 'eval) + (cadadr (caddr fnew)) + (or (not (fixp (cadadr (caddr fnew)))) + (= (cadadr (caddr fnew)) -1)) + (setq fnew (evalframe (cadr fnew))) + (go loop)) + (and fnew + (setq flist (cons fnew flist)) + (setq fnew (evalframe (cadr fnew))) + (go loop)) + (return (nreverse flist))))) + +(def debug-nextframe + (lambda (frame flist sel) + (prog nil + (setq flist (cdr (memq frame flist))) + (and (not (memq 'user sel)) (return (car flist))) + loop (or flist (return nil)) + (cond + ((or (atom (caddr (car flist))) + (not (debug-sysp (caaddr (car flist))))) + (return (car flist)))) + (setq flist (cdr flist)) + (go loop)))) + +(def debug-upframe + (lambda (frame) + (debug-nextframe frame rframelist nil))) + +(def debug-dnframe + (lambda (frame) + (debug-nextframe frame framelist nil))) + +(def debug-upfn + (lambda (frame) + (debug-nextframe frame rframelist '(user)))) + +(def debug-dnfn + (lambda (frame) + (debug-nextframe frame framelist '(user)))) + +(def debug-showvar + (lambda (var frame) + (terpri) + (princ '| |) + (princ var) + (princ '| = |) + (fix-print + ((lambda (val) (cond ((atom val) '?) (t (car val)))) + (errset (fix-eval var (cadddr frame)) nil))))) + +(def debug-nedit + (lambda (frame) + (prog (val body elem nframe) + (setq elem (caddr frame)) + (setq val frame) + scan (setq val (debug-findusrfn val)) + (or val (go nofn)) + (setq body (getd (caaddr val))) + (cond ((debug-insidep elem body) + (princ '=) + (fix-print (caaddr val)) + (edite body + (list 'f (cons '== elem) 'tty:) + (caaddr val)) + (return frame)) + ((or (eq elem (caddr val)) (debug-insidep elem (caddr val))) + (setq val (debug-dnframe val)) + (go scan))) + nofn (setq nframe (debug-dnframe frame)) + (or nframe (go doit)) + (and (debug-insidep elem (caddr nframe)) + (setq frame nframe) + (go nofn)) + doit (edite (caddr frame) + (and (debug-insidep elem (caddr frame)) + (list 'f (cons '== elem) 'tty:)) + nil) + (return frame)))) + +(def debug-insidep + (lambda (elem expr) + (car (errset (edite expr (list 'f (cons '== elem)) nil))))) + +(def debug-findusrfn + (lambda (frame) + (cond ((null frame) nil) + ((and (dtpr (caddr frame)) + (symbolp (caaddr frame)) + (dtpr (getd (caaddr frame)))) + frame) + (t (debug-findusrfn (debug-dnframe frame)))))) + +(def debug-findexpr + (lambda (frame) + (cond ((null frame) nil) + ((and (eq (car frame) 'eval) (not (atom (caddr frame)))) + frame) + (t (debug-findexpr (debug-dnframe frame)))))) + +(def debug-pop + (lambda nil + (prog (frame) + (setq frame (car framelist)) + l (cond ((null (setq frame (evalframe (cadr frame))))(reset))) + (cond ((and (dtpr (caddr frame))(eq (caaddr frame) 'debug)) + (freturn (cadr frame) nil))) + (go l)))) + +(def debug-where + (lambda (frame) + (prog (lev diff nframe) + (setq lev (- (length framelist) (length (memq frame rframelist)))) + (setq diff (- (length framelist) lev 1)) + (debug-print1 frame nil) + (terpri) + (cond ((zerop diff) (princ '|you are at top of stack.|)) + ((zerop lev) (princ '|you are at bottom of stack.|)) + (t (princ '|you are |) + (princ diff) + (cond ((= diff 1) (princ '| frame from the top.|)) + (t (princ '| frames from the top.|))))) + (terpri) + (and (or (atom (caddr frame)) (not (eq (car frame) 'eval))) + (return nil)) + (setq lev 0) + (setq nframe frame) + lp (and (setq nframe (debug-findcall (caaddr nframe) nframe framelist)) + (setq lev (|1+| lev)) + (go lp)) + (princ '|there are |) + (princ lev) + (princ '| |) + (princ (caaddr frame)) + (princ '|'s below.|) + (terpri)))) + +(def debug-sysp + (lambda (x) + (and (sysp x) (symbolp x) (not (dtpr (getd x)))))) + +(dv interrupt-handlers (fixit)) + +(dv handler-labels + ((fixit error) + (debug-ubv-handler ubv) + (debug-udf-handler udf) + (debug-fac-handler fac) + (debug-ugt-handler ugt) + (debug-wta-handler wta) + (debug-wna-handler wna) + (debug-iol-handler iol) + (debug-*rset-handler rst) + (debug-mer-handler mer) + (debug-gcd-handler gcd) + (debug-gcl-handler gcl) + (debug-gco-handler gco) + (debug-pdl-handler pdl))) + + +(or (boundp 'traced-stuff) (setq traced-stuff nil)) + +(or (boundp 'evalhook-switch) (setq evalhook-switch nil)) + +(setq hush-debug nil) + + +;; other functions grabbed from other cmu files to make this file complete +;; unto itself + +;- from sysfunc.l +(declare (special system-functions\)) +(defun build-sysp nil + (do ((temp (oblist) (cdr temp)) + (sysfuncs)) + ((null temp)(setq system-functions\ sysfuncs));atom has ^G at end + (cond ((getd (car temp)) + (setq sysfuncs (cons (car temp) sysfuncs)))))) + +(defun sysp (x) ; (cond ((memq x system-functions\)t)) + (memq x '(funcallhook* funcallhook evalhook evalhook* + continue-evaluation))) + +(or (boundp 'system-functions\) (build-sysp)) + +(defun fretry (pdlpnt frame) + (freturn pdlpnt + (cond ((eq (car frame) 'eval) (eval (caddr frame) (cadddr frame))) + ((eq (car frame) 'apply) + (eval `(apply ',(caaddr frame) ',(cadaddr frame)) + (cadddr frame)))))) + + +; - from cmu.l + +(def %lineread + (lambda (chan) + (prog (ans) + loop (setq ans (cons (read chan 'EOF) ans)) + (cond ((eq (car ans) 'EOF) (return (reverse (cdr ans))))) + loop2(cond ((eq 10 (tyipeek chan)) (return (reverse ans))) + ((memq (tyipeek chan) '(41 93)) + (tyi chan) + (go loop2)) + (t (go loop)))))) -- 2.20.1