mirror of
https://github.com/PDP-10/its.git
synced 2026-01-14 23:55:40 +00:00
311 lines
11 KiB
Common Lisp
311 lines
11 KiB
Common Lisp
; Monday April 28,1980 7:09 FQ+6D.2H.56M.40S. -*- Lisp -*-
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; STACK DEBUGGING TOOLS
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;; Robert V. Baron (RVB@ML)
|
||
;;; NE43-316 x3-3539
|
||
;;; Last modified by GSB - should work without conditionalization
|
||
;;; in Multics lisp, having lowercasified the code.
|
||
;;; If you modify this, please use LOWERCASE!
|
||
|
||
;;; These routines are for crawling around in the LISP stack. For
|
||
;;;any meaningful stack information to be available *RSET must be set to
|
||
;;;T. Further, only minimal information will be present for compiled
|
||
;;;calls unless NOUUO is T. This package takes up 376. decimal words.
|
||
|
||
;;; The variable *FRAME*-*POINTER* (hereafter called the CURSOR) is
|
||
;;;always bound to a "stack frame 4-tuple". Each tuple is the value of
|
||
;;;an EVALFRAME function call. All the functions described below,
|
||
;;;unless otherwise noted, have as their value the current CURSOR.
|
||
|
||
;;; The CURSOR is either of the form:
|
||
;;; (EVAL <pdl-ptr> <form> <spec-pdl-ptr>) or
|
||
;;; (APPLY <pdl-ptr> (<operator> <arglist>) <spec-pdl-ptr>)
|
||
|
||
;;;The first atom is a keyword identifier indicating the format of the
|
||
;;;third entry. EVAL means that the form is an entity that is being
|
||
;;;EVAL'ed and the user could EVAL to see the effect. APPLY means that
|
||
;;;the third element is the list of the operator and its argument list.
|
||
;;;The argument list has been evaluated and is ready for the operator to
|
||
;;;be APPLY'ed to it. The user can do the latter by hand to see the
|
||
;;;effect.
|
||
|
||
;;; The <pdl-ptr> and <spec-pdl-ptr> print as FIXNUM's. They are
|
||
;;;pointers that are meaningful for EVALFRAME, FRETURN, EVAL, APPLY and
|
||
;;;a few other commands. The reader is refered to the MACLISP manual
|
||
;;;for a more detailed discussion.
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; COMMANDS
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;;TOP (no args)
|
||
;;; Set the CURSOR to the "top" of the stack. The "top" is closest
|
||
;;;to the break. Like a plant the growing point of a stack is at its top.
|
||
|
||
;;;BOT (no args)
|
||
;;; Set the CURSOR to the "bottom" of the stack. The "bottom" is
|
||
;;;the frame of the last call from "command line".
|
||
|
||
;;;UP (fexpr)
|
||
;;; Move the CURSOR another frame towards the top.
|
||
;;; Falling off the top of the stack causes an error message to be
|
||
;;;printed. The CURSOR is not changed. (Thus the value of UP will be
|
||
;;;EQ to its previous value).
|
||
|
||
;;;DN (fexpr)
|
||
;;; Move the CURSOR another frame towards the bottom.
|
||
;;; Falling off the bottom of the stack causes an error message to
|
||
;;;be printed. The CURSOR is not changed. (Thus the value of DN will
|
||
;;;be EQ to its previous value).
|
||
|
||
|
||
;;;both UP and DN
|
||
;;;take the following arguments:
|
||
;;; <some number> do the operation that many times
|
||
;;; <some function> go to the frame where that function was invoked
|
||
;;; the letter F move the CURSOR until the first user function
|
||
;;; call is encountered
|
||
;;; the letter I move the CURSOR until the first non-compiled
|
||
;;; user function call is encountered
|
||
;;; the letter C move the CURSOR until the first compiled user
|
||
;;; function call is encountered
|
||
;;; the letter M move the CURSOR until the first user macro call
|
||
|
||
;;;FR (lexpr)
|
||
;;; Given no argument, its value is simply the CURSOR.
|
||
;;; Given an argument, it will reset the CURSOR to the argument.
|
||
|
||
;;;FM (no args)
|
||
;;; Return only the FORM of the stack frame. This is the third
|
||
;;;element of the CURSOR structure.
|
||
|
||
;;;RET (lexpr)
|
||
;;; no arg - reexecute the form at the cursor and unwind the stack
|
||
;;; Only this type execution of RET evaluates in the
|
||
;;; original (CURSOR) lambda variable binding environment
|
||
;;; one arg - return the arg in place of computing the value of the
|
||
;;; form at the CURSOR.
|
||
;;; two arg - as above, but use (arg 2) in place of the CURSOR.
|
||
|
||
;;;EV (lexpr)
|
||
;;; one arg - evaluate the arg in the binding environment of the
|
||
;;; CURSOR frame.
|
||
;;; two arg - as above, but use (arg 2) in place of the CURSOR.
|
||
|
||
;;;EVQ (fexpr)
|
||
;;; The evalquote version of the above function.
|
||
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; Printing the stuff
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; All of the above routines which move around in the stack
|
||
;;; (UP, DN, TOP, and BOT) simply return the frame. This can be
|
||
;;; somewhat disconcerting if the amount of code is huge, with
|
||
;;; lots of macro expansions. So, they also have alternate routines,
|
||
;;; which take the same arguments, and pretty-print the data part of
|
||
;;; the frame with the pretty-printer of your choice.
|
||
;;; The variable *STACK-PP should be a function of one argument to
|
||
;;; print the form. If the frame is an EVAL frame, then the data part
|
||
;;; is passed to it; if an APPLY frame, then a cons of the function
|
||
;;; and the argument list is.
|
||
;;; PRINLEVEL and PRINLENGTH are bound to *STACK-PRINLEVEL and
|
||
;;; *STACK-PRINLENGTH respectively when the printer gets called.
|
||
;;; The following routines are implemented:
|
||
;;; PPTOP - like TOP
|
||
;;; PPBOT - like BOT
|
||
;;; PPUP - like UP
|
||
;;; PPDN - like DN
|
||
;;; PPFR - like FM
|
||
;;; PP* - calls the pretty printer in *STACK-PP on the value of *,
|
||
;;; and returns that as its value (so it won't be clobbered).
|
||
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; HINTS
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
|
||
;;; When the CURSOR 4-tuple is of the EVAL type (the first element
|
||
;;;of the tuple is EVAL), the form component is EQ to the piece of code
|
||
;;;that is in the actual function being executed. Thus RPLAC operators
|
||
;;;on this form wil make patches to the function.
|
||
|
||
;;; RET is most useful to return the correct value for some
|
||
;;;evaluation sequence that has gone amuck and proceed with the overall
|
||
;;;processing. It eliminates the necessity of starting again from the
|
||
;;;beginning because of some "simple" bug.
|
||
|
||
;;; To evaluate a number of variables and forms in some frame
|
||
;;;context it is often easier to do a (EVQ (BREAK FOO)) rather than
|
||
;;;repetitive EVQ's. The former expression places a BREAK "at an
|
||
;;;earlier place in the evaluation". Obviously this BREAK should be
|
||
;;;$P'ed, when it is no longer needed.
|
||
|
||
|
||
(declare (genprefix stack-crawl)
|
||
(special *frame*-*pointer*)
|
||
(*fexpr dn up retb evq)
|
||
(*lexpr ret ev pretty-print)
|
||
(special *stack-pp *stack-prinlevel *stack-prinlength))
|
||
|
||
(or (boundp '*stack-pp) (setq *stack-pp 'pretty-print))
|
||
(or (boundp '*stack-prinlevel) (setq *stack-prinlevel 10.))
|
||
(or (boundp '*stack-prinlength) (setq *stack-prinlength 15.))
|
||
|
||
|
||
(or (fboundp 'pretty-print)
|
||
(get 'pretty-print 'autoload)
|
||
(putprop 'pretty-print
|
||
(cond ((status feature Multics) ">udd>Mathlab>LSB>pretty")
|
||
(t '((format) pretty fasl)))
|
||
'autoload))
|
||
|
||
|
||
(defun stack-pp (frame)
|
||
(cond ((not (null frame))
|
||
((lambda (data prinlevel prinlength)
|
||
(funcall *stack-pp (cond ((eq (car frame) 'apply)
|
||
(cons (car data) (cadr data)))
|
||
(t data)))
|
||
(car frame) ; EVAL or APPLY
|
||
)
|
||
(caddr frame) *stack-prinlevel *stack-prinlength))))
|
||
|
||
|
||
(defun pp* ()
|
||
(funcall *stack-pp *)
|
||
*)
|
||
|
||
|
||
(defun top ()
|
||
((lambda (*rset)
|
||
(setq *frame*-*pointer* (evalframe (cadr (evalframe nil)))))
|
||
nil))
|
||
|
||
(defun pptop ()
|
||
(stack-pp (top)))
|
||
|
||
|
||
(defun bot ()
|
||
((lambda (*rset) (setq *frame*-*pointer* (evalframe 0))) nil))
|
||
|
||
(defun ppbot ()
|
||
(stack-pp (bot)))
|
||
|
||
|
||
(defun fr lexpr
|
||
(cond ((= lexpr 0) *frame*-*pointer*)
|
||
(t (setq *frame*-*pointer* (arg 1)))))
|
||
|
||
(defun fm ()
|
||
(caddr *frame*-*pointer*))
|
||
|
||
(defun ppfm ()
|
||
(stack-pp *frame*-*pointer*))
|
||
|
||
|
||
|
||
(defun up fexpr (arg)
|
||
(declare (fixnum temp-fixnum))
|
||
(setq *frame*-*pointer*
|
||
(do ((move (evalframe (abs (cadr *frame*-*pointer*)))
|
||
(evalframe (abs (cadr move))))
|
||
(option (and arg (car arg)))
|
||
(temp-fixnum (cond (arg (car arg)) (t 0)))
|
||
(temp))
|
||
((null move) (print 't-o-s) *frame*-*pointer*)
|
||
(cond ((null arg) (return move))
|
||
((numberp option)
|
||
(cond ((< (setq temp-fixnum
|
||
(1- temp-fixnum)) 1)
|
||
(return move))))
|
||
((and (not (atom (caddr move)))
|
||
(symbolp (car (setq temp (caddr move)))))
|
||
(cond ((and (memq option '(i f c m))
|
||
(memq (sysp temp) '(nil autoload)))
|
||
(cond ((eq option 'f) (return move))
|
||
((and (eq option 'i)
|
||
(getl temp '(expr fexpr)))
|
||
(return move))
|
||
((and (eq option 'c)
|
||
(getl temp '(subr fsubr lsubr)))
|
||
(return move))
|
||
((and (eq option 'm) (get temp 'macro))
|
||
(return move))))
|
||
((eq option temp) (return move))))))) )
|
||
|
||
|
||
(defun ppup fexpr (arg)
|
||
(stack-pp (apply (function up) arg)))
|
||
|
||
|
||
(defun dn fexpr (arg)
|
||
(declare (fixnum temp-fixnum))
|
||
(setq *frame*-*pointer*
|
||
(do ((move (evalframe (cadr *frame*-*pointer*))
|
||
(evalframe (cadr move)))
|
||
(option (and arg (car arg)))
|
||
(temp-fixnum (cond (arg (car arg)) (t 0)))
|
||
(temp))
|
||
((null move) (print 'b-o-s) *frame*-*pointer*)
|
||
|
||
(cond ((null arg) (return move))
|
||
((numberp option)
|
||
(cond ((< (setq temp-fixnum
|
||
(1- temp-fixnum)) 1)
|
||
(return move))))
|
||
((and (not (atom (caddr move)))
|
||
(atom (setq temp (caaddr move))))
|
||
(cond ((and (memq option '(i f c m))
|
||
(memq (sysp temp) '(nil autoload)))
|
||
(cond ((eq option 'f)
|
||
(return move))
|
||
((and (eq option 'i)
|
||
(getl temp '(expr fexpr)))
|
||
(return move))
|
||
((and (eq option 'c)
|
||
(getl temp '(subr fsubr lsubr)))
|
||
(return move))
|
||
((and (eq option 'm)
|
||
(get temp 'macro))
|
||
(return move))))
|
||
((eq option temp)
|
||
(return move))))))) )
|
||
|
||
(defun ppdn fexpr (arg)
|
||
(stack-pp (apply (function dn) arg)))
|
||
|
||
(defun ret lexpr
|
||
(cond ((= lexpr 2) (freturn (cadr (arg 2)) (arg 1)))
|
||
((= lexpr 1) (freturn (cadr *frame*-*pointer*) (arg 1)))
|
||
((= lexpr 0)
|
||
((lambda (ptr val)
|
||
(cond ((eq (car *frame*-*pointer*) 'eval)
|
||
(setq ptr (cadr *frame*-*pointer*)
|
||
val (eval (caddr *frame*-*pointer*)
|
||
(cadddr *frame*-*pointer*))))
|
||
((eq (car *frame*-*pointer*) 'apply)
|
||
(setq ptr (cadr *frame*-*pointer*)
|
||
val (apply (caaddr *frame*-*pointer*)
|
||
(cadr (caddr *frame*-*pointer*))
|
||
(cadddr *frame*-*pointer*))))
|
||
(t (break damn-lisp t)))
|
||
(and ptr (freturn ptr val)))
|
||
nil nil))
|
||
(t (break wrong-number-of-args t))))
|
||
|
||
(defun ev lexpr
|
||
(cond ((= lexpr 2) (eval (arg 1) (cadddr (arg 2))))
|
||
((= lexpr 1) (eval (arg 1) (cadddr *frame*-*pointer*)))
|
||
(t (break wrong-number-of-args t))))
|
||
|
||
(defun evq fexpr (x)
|
||
(cond ((null x) (break wrong-number-of-args t))
|
||
((null (cdr x)) (eval (car x) (cadddr *frame*-*pointer*)))
|
||
((null (cddr x)) (eval (car x) (cadddr (eval (cadr x)))))
|
||
(t (break wrong-number-of-args t))))
|