Return to step.l CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib

Annotation of 43BSDTahoe/ucb/lisp/lisplib/step.l, revision 1.1

1.1     ! root        1: (setq rcs-step-
        !             2:    "$Header: /usr/lib/lisp/step.l,v 1.1 83/01/29 18:39:46 jkf Exp $")
        !             3: 
        !             4: ; vi: set lisp :
        !             5: 
        !             6: ;;;                     LISP Stepping Package
        !             7: ;;;
        !             8: ;;; Adapted by Mitch Marcus for Franz Lisp from Chuck Rich's MACLISP
        !             9: ;;; package.
        !            10: ;;;
        !            11: ;;;
        !            12: ;;; Adapted 2/80 from the Maclisp version of 11/03/76
        !            13: ;;; Further modified 5/80 by Don Cohen (DNC)
        !            14: ;;;
        !            15: ;;; modified by jkf 6/81 to handle funcallhook.
        !            16: ;;;
        !            17: ;;; User Interface Function
        !            18: ;;;
        !            19: ;;;             Valid Forms:                            
        !            20: ;;; (step) or (step nil)       :: turn off stepping
        !            21: ;;; (step t)                   :: turn on stepping right away.
        !            22: ;;; (step e)                   :: turn on stepping of eval only
        !            23: ;;; (step foo1 foo2 ...)       :: turn on stepping when one of fooi is
        !            24: ;;;                            :: called
        !            25: ;;;
        !            26: ;------ implementation:
        !            27: ; evalhook* is nil meaning no stepping, or t meaning always step
        !            28: ;    or is a list of forms which will start continuous stepping.
        !            29: ;
        !            30: ; The hook functions are evalhook* and funcallhook*.
        !            31: ;
        !            32: 
        !            33: (declare (special 
        !            34:          evalhook-switch piport        
        !            35:          hookautolfcount funcallhook
        !            36:          evalhook evalhook* |evalhook#| prinlevel prinlength
        !            37:          fcn-evalhook fcn-funcallhook
        !            38:          Standard-Input)
        !            39:          (macros nil))
        !            40: 
        !            41: ;; First Some Macros
        !            42: 
        !            43: (defun 7bit macro (s)
        !            44:        ;; (7BIT n c) tests if n is ascii for c
        !            45:        (list '= (list 'boole 1 127. (cadr s)) (caddr s)))
        !            46: 
        !            47: ;--- print* 
        !            48: ; indent based on current evalhook recursion level then print the
        !            49: ; arg in form
        !            50: ;
        !            51: (defun print* macro (s)
        !            52:           ;; print with indentation
        !            53:          '(do ((i 1 (1+ i))
        !            54:                (indent (* 2 |evalhook#|))
        !            55:                (prinlevel 3)
        !            56:                (prinlength 5))
        !            57:               ((> i indent) 
        !            58:               (cond ((eq type 'funcall) (patom "f:")))
        !            59:               (print form))
        !            60:               (tyo 32.)))
        !            61: 
        !            62: (defun step fexpr (arg)
        !            63:   (cond ((or (null arg) (car arg))
        !            64:         (setq evalhook-switch t) ; for fixit package
        !            65:         (setq |evalhook#| 0.)                  ;initialize depth count
        !            66:          (setq hookautolfcount 0)              ; count if auto lfs at break
        !            67:         (setq evalhook nil)                  ;for safety
        !            68:         (setq funcallhook nil)
        !            69:         ; (step e) means just step eval things, else step eval and funcal
        !            70:         (cond ((eq (car arg) 'e) 
        !            71:                (setq fcn-evalhook 'evalhook* fcn-funcallhook nil))
        !            72:               (t (setq fcn-evalhook 'evalhook* fcn-funcallhook 'funcallhook*)))
        !            73:         (setq evalhook*
        !            74:               (cond ((null arg) nil)
        !            75:                     ((or (eq (car arg) t) (eq (car arg) 'e)))
        !            76:                     (arg)))
        !            77:         (setq evalhook fcn-evalhook)      ;turn system hook to my function
        !            78:         (setq funcallhook fcn-funcallhook)
        !            79:         (sstatus translink nil)
        !            80:         (*rset t)                            ;must be on for hook to work
        !            81:         (sstatus evalhook t))           ;arm it
        !            82:        (t (setq evalhook* nil)
        !            83:           (setq evalhook nil)
        !            84:           (setq hookautolfcount 0)             ; count if auto lfs at break
        !            85:           (setq evalhook-switch nil)
        !            86:           (sstatus evalhook nil))))
        !            87: 
        !            88: 
        !            89: ;---- funcall-evalhook*
        !            90: ;
        !            91: ; common function to handle evalhook's and funcallhook's.
        !            92: ; the form to be evaluated is given as form and the type (eval or funcall)
        !            93: ; is given as type.
        !            94: ;
        !            95: 
        !            96: (defun funcall-evalhook* (form type)
        !            97:   (cond (evalhook*
        !            98:         ;; see if selective feature kicks in here
        !            99:         (and (not (atom form))
        !           100:              (not (eq evalhook* t))
        !           101:              (memq (car form) evalhook*)
        !           102:              (setq evalhook* t))       ; yes, begin stepping always
        !           103: 
        !           104:         (cond ((eq evalhook* t)
        !           105:                ;; print out form before evaluation
        !           106:                (print*)
        !           107: 
        !           108:                (cond ((atom form)
        !           109:                       ;; since form is atom, we just eval it and print
        !           110:                       ;; out its value, no need to ask user what to do
        !           111:                       (cond ((not (or (numberp form)(null form)(eq form t)))
        !           112:                              (princ '" = ")
        !           113:                              ((lambda (prinlevel prinlength)
        !           114:                                       (setq form (evalhook form nil nil))
        !           115:                                       (print form))    
        !           116:                               3 5)))
        !           117:                       (terpri))
        !           118:                      (t ; s-expression
        !           119:                         (prog (cmd ehookfn fhookfcn)
        !           120: 
        !           121:                           cmdlp  (cond ((greaterp hookautolfcount 0)
        !           122:                                         (setq hookautolfcount (sub1 hookautolfcount))
        !           123:                                         (terpr)
        !           124:                                         (setq cmd #\lf))
        !           125:                                        (t (setq cmd (let ((piport 
        !           126:                                                            Standard-Input))
        !           127:                                                          (drain piport)
        !           128:                                                          (tyi piport)))))
        !           129: 
        !           130:                               ;; uppercase alphabetics
        !           131:                               ;; dispatch on command character
        !           132:                               (cond ((eq cmd #\lf)    
        !           133:                                      ; \n so continue
        !           134:                                      (setq ehookfn fcn-evalhook
        !           135:                                            fhookfcn fcn-funcallhook))
        !           136: 
        !           137:                                     ((memq cmd '(#/p #/P))
        !           138:                                      ; "P" print in full
        !           139:                                      (print form)
        !           140:                                      (go cmdlp))
        !           141: 
        !           142:                                     ; "G"
        !           143:                                     ((memq cmd '(#/g #/G))
        !           144:                                      (setq evalhook* nil  ;stop everything
        !           145:                                            ehookfn nil
        !           146:                                            fhookfcn nil))
        !           147: 
        !           148:                                     ((memq cmd '(#/c #/C))
        !           149:                                      ;"C" no deeper
        !           150:                                      (setq ehookfn nil
        !           151:                                            fhookfcn nil))
        !           152: 
        !           153:                                     ((memq cmd '(#/d #/D))
        !           154:                                      ;"D" call debug
        !           155:                                      (setq evalhook-switch nil)
        !           156:                                      (sstatus evalhook nil)
        !           157:                                      (debug)
        !           158:                                      (setq evalhook-switch t)
        !           159:                                      (sstatus evalhook t)
        !           160:                                      (go cmdlp))
        !           161: 
        !           162: 
        !           163:                                     ((memq cmd '(#/b #/B))
        !           164:                                      ; "B" give breakpoint
        !           165:                                      (break step)
        !           166:                                      (print*)
        !           167:                                      (go cmdlp))
        !           168: 
        !           169:                                     ((memq cmd '(#/q #/Q))
        !           170:                                      ; "Q" stop stepping
        !           171:                                      (step nil)
        !           172:                                      (reset))
        !           173: 
        !           174:                                     ((memq cmd '(#/n #/N))
        !           175:                                      (setq hookautolfcount 
        !           176:                                            (let ((piport Standard-Input))
        !           177:                                                 (read)))
        !           178:                                      (cond ((not (numberp hookautolfcount))
        !           179:                                             (patom "arg to n should be number")
        !           180:                                             (terpr)
        !           181:                                             (setq hookautolfcount 0))))
        !           182: 
        !           183:                                     ; "s" eval form
        !           184:                                     ((memq cmd '(#/s #/S))
        !           185:                                      (let ((piport Standard-Input)
        !           186:                                            (fcns nil))
        !           187:                                           (setq fcns (read))
        !           188:                                           (cond ((dtpr fcns) 
        !           189:                                                  (setq evalhook* fcns))
        !           190:                                                 ((symbolp fcns)
        !           191:                                                  (setq evalhook* (list fcns))))))
        !           192: 
        !           193:                                     ; "e" step eval only
        !           194:                                     ((memq cmd '(#/e #/E))
        !           195:                                      (setq fcn-funcallhook nil))
        !           196: 
        !           197:                                     ; "?", "H" show the options
        !           198:                                     ((memq cmd '(72 104 63.))
        !           199:                                      #+cmu (ty /usr/lisp/doc/step\.ref)
        !           200:                                      #-cmu(stephelpform)
        !           201:                                      (terpri)
        !           202:                                      (go cmdlp))
        !           203:                                     ((eq cmd #\eof)
        !           204:                                      (patom "EOF typed")
        !           205:                                      (terpr))
        !           206: 
        !           207:                                     (t (princ '"Try one of ?BCDGMPQ or <cr>")
        !           208:                                        (go cmdlp)))
        !           209: 
        !           210:                               ;; evaluate form
        !           211:                               (clear-input-buffer)
        !           212:                               ((lambda (|evalhook#|)
        !           213:                                        (setq form (continue-evaluation 
        !           214:                                                    form 
        !           215:                                                    type 
        !           216:                                                    ehookfn 
        !           217:                                                    fhookfcn)))
        !           218:                                (1+ |evalhook#|))
        !           219: 
        !           220:                               ;; print out evaluated form
        !           221:                               (cond ((and evalhook* 
        !           222:                                           (or (eq type 'funcall)
        !           223:                                               (not (zerop |evalhook#|))))
        !           224:                                      (let ((type nil))
        !           225:                                           (print*))
        !           226:                                      (terpri)
        !           227:                                      )))))
        !           228:                ;;return evaluated form
        !           229:                form)
        !           230:               (t ;  why was this here? (clear-input-buffer)
        !           231:                  (continue-evaluation form type fcn-evalhook fcn-funcallhook))))   
        !           232:        (t ;  why was this here? (clear-input-buffer)
        !           233:           (continue-evaluation form type fcn-evalhook fcn-funcallhook))))
        !           234: 
        !           235: ;--- stephelpform 
        !           236: ;
        !           237: ; print a summary of the functions of step
        !           238: ;
        !           239: (defun stephelpform nil
        !           240:   (patom "<cr> - single step;  n <number> - step <number> times")(terpr)
        !           241:   (patom "b - break;  q - quit stepping;  d - call debug;") (terpri)
        !           242:   (patom "c - turn off step for deeper levels; e - stop at eval forms only")
        !           243:   (terpri)
        !           244:   (patom "h,? - print this") (terpr))
        !           245: 
        !           246: ;--- funcallhook* 
        !           247: ;
        !           248: ; automatically called when a funcall is done and funcallhook*'s 
        !           249: ; value is the name of this function (funcallhook*).  When this is
        !           250: ; called, a function with n-1 args is being funcalled, the args
        !           251: ; to the function are (arg 1) through (arg (sub1 n)), the name of
        !           252: ; the function is (arg n)
        !           253: ;
        !           254: (defun funcallhook* n
        !           255:   (let ((name (arg n))
        !           256:        (args (listify (sub1 n))))
        !           257:        (funcall-evalhook* (cons name args) 'funcall)))
        !           258: 
        !           259: ;--- evalhook* 
        !           260: ;
        !           261: ; called whenever an eval is done and evalhook*'s value is the 
        !           262: ; name of this function (evalhook*).  arg is the thing being
        !           263: ; evaluated.
        !           264: ;
        !           265: (defun evalhook* (arg)
        !           266:   (funcall-evalhook* arg 'eval))
        !           267: 
        !           268: (defun continue-evaluation (form type evalhookfcn funcallhookfcn)
        !           269:   (cond ((eq type 'eval) (evalhook form evalhookfcn funcallhookfcn))
        !           270:        (t (funcallhook form funcallhookfcn evalhookfcn))))
        !           271: 
        !           272: 
        !           273: (or (boundp 'prinlength) (setq prinlength nil))
        !           274: 
        !           275: (or (boundp 'prinlevel) (setq prinlevel nil))
        !           276: 
        !           277: ; Standard-Input is a variable bound to the initial stdin port. It is 
        !           278: ; bound in the auxfns0 package, but older lisps may not have that new
        !           279: ; package, so in case they don't we approximate Standard-Input with nil
        !           280: ; which works in many cases, but drain's do not work.
        !           281: (or (boundp 'Standard-Input) (setq Standard-Input nil))
        !           282: (defun clear-input-buffer nil (drain Standard-Input))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.