Return to trace.l CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib

Annotation of 3BSD/cmd/lisp/lib/trace.l, revision 1.1

1.1     ! root        1: ;---- The Joseph Lister Trace Package, v1
        !             2: ;         John Foderaro, Sept 1979
        !             3: ;------------------------------------------------------------------;
        !             4: ; Copyright (c) 1979 The Regents of the University of California   ;
        !             5: ;      All rights reserved.                                       ;
        !             6: ;------------------------------------------------------------------;
        !             7: (eval-when (eval)
        !             8:   (setq old-read-table-trace readtable)
        !             9:   (setq readtable (makereadtable t))
        !            10:   (load 'backquote))
        !            11: (cond ((null (boundp '$$traced-functions$$)) (setq $$traced-functions$$ nil)))
        !            12: (setq $$trace-indent$$ 0)
        !            13: 
        !            14: ;----> It is important that the trace package not use traced functions
        !            15: ;      thus we give the functions the trace package uses different
        !            16: ;      names and make them equivalent at this time to their 
        !            17: ;      traceable counterparts.  
        !            18: 
        !            19: (do ((i '( (add1 T-add1)(append T-append)
        !            20:           (apply T-apply)(atom T-atom)(bcdp T-bcdp)
        !            21:           (car T-car)(cadr T-cadr)(cdr T-cdr)(cons T-cons) (delq T-delq)
        !            22:           (drain T-drain)
        !            23:           (dtpr T-dtpr) (eq T-eq) (eval T-eval)(funcall T-funcall)
        !            24:           (get T-get) (getd T-getd)(getdisc T-getdisc)
        !            25:           (greaterp T-greaterp)(memq T-memq)(not T-not)
        !            26:           (null T-null) (patom T-patom) (print T-print) 
        !            27:           (prog T-prog)
        !            28:           (or T-or) (patom T-patom)(putd T-putd) 
        !            29:           (putprop T-putprop)
        !            30:           (read T-read)(remprop T-remprop) (reverse T-reverse)
        !            31:           (set T-set)
        !            32:           (setq T-setq) (sub1 T-sub1) (terpr T-terpr)
        !            33:           (zerop T-zerop))
        !            34:        (cdr i)))
        !            35:     ((null i))
        !            36:     (putd (cadar i) (getd (caar i)))
        !            37:     (putprop (cadar i) t 'Untraceable))
        !            38: 
        !            39: ;--- trace - arg1,arg2, ... names of functions to trace
        !            40: ;      This is the main user callable trace routine. 
        !            41: ; work in progress, documentation incomplete since im not sure exactly
        !            42: ; where this is going. 
        !            43: ;
        !            44: (def trace
        !            45:   (nlambda (argl)
        !            46:    (prog (if ifnot evalin evalout funnm funcd did break)
        !            47: 
        !            48:     ; process each argument     
        !            49: 
        !            50:     (do ((ll argl (cdr ll))
        !            51:         (funnm) 
        !            52:         (funcd))
        !            53:        ((T-null ll))
        !            54:        (T-setq funnm (car ll)
        !            55:                if t
        !            56:                break nil
        !            57:                ifnot nil
        !            58:                evalin nil
        !            59:                evalout nil)
        !            60: 
        !            61:        ; a list as an argument means that the user is specifying
        !            62:        ; conditions on the trace
        !            63:        (cond ((T-not (atom funnm))
        !            64:               (cond ((T-not (T-atom (T-setq funnm (car funnm))))
        !            65:                      (T-print (car funnm))
        !            66:                      (T-patom '" is non an function name")
        !            67:                      (go botloop)))
        !            68:               (do ((rr (cdar ll) (cdr rr)))
        !            69:                   ((T-null rr))
        !            70:                   (cond ((T-memq (T-car rr) '(if ifnot evalin evalout))
        !            71:                          (T-set (T-car rr) (T-cadr rr))
        !            72:                          (T-setq rr    (T-cdr rr)))
        !            73:                         ((T-eq (T-car rr) 'evalinout)
        !            74:                          (T-setq evalin (T-setq evalout (T-cadr rr))
        !            75:                                rr (T-cdr rr)))
        !            76:                         ((T-eq (T-car rr) 'break)
        !            77:                          (T-setq break t))
        !            78:                         (t (T-patom '"bad request ")
        !            79:                            (T-print (T-car rr)))))))
        !            80: 
        !            81: 
        !            82:         ; if function is already traced, untrace it first
        !            83:         (cond ((get funnm 'T-original) 
        !            84:                (apply 'untrace `(,funnm))
        !            85:                (T-setq did (T-cons `(,funnm untraced) did))))
        !            86: 
        !            87:         ; we must determine the type of function being traced
        !            88:         ; in order to create the correct replacement function  
        !            89: 
        !            90:         (cond ((T-setq funcd (T-getd funnm))
        !            91:               (cond ((T-bcdp funcd)            ; machine code
        !            92:                      (cond ((T-eq 'lambda (T-getdisc funcd))
        !            93:                             (T-setq typ 'lambda))
        !            94:                            ((T-eq 'nlambda (T-getdisc funcd))
        !            95:                             (T-setq typ 'nlambda))
        !            96:                            (t (T-patom '"Unknown type of compiled function")
        !            97:                               (T-print funnm)
        !            98:                               (T-setq typ nil))))
        !            99: 
        !           100:                     ((T-dtpr funcd)            ; lisp coded
        !           101:                      (cond ((T-or (T-eq 'lambda (T-car funcd))
        !           102:                                 (T-eq 'lexpr (T-car funcd)))
        !           103:                             (T-setq typ 'lambda))
        !           104:                            ((T-or (T-eq 'nlambda (T-car funcd))
        !           105:                                   (T-eq 'macro (T-car funcd)))
        !           106:                             (T-setq typ 'nlambda))
        !           107:                            (t (T-patom '"Bad function definition: ")
        !           108:                               (T-print funnm)
        !           109:                               (T-setq typ nil))))
        !           110:                     (t (T-patom '"Bad function defintion: ")
        !           111:                        (T-print funnm)))
        !           112:               
        !           113:               ; now that the arguments have been examined for this
        !           114:               ; function, do the tracing stuff.
        !           115:               ; First save the old function on the property list
        !           116: 
        !           117:               (T-putprop funnm funcd 'T-original)
        !           118: 
        !           119:               ; now build a replacement
        !           120: 
        !           121:               (cond ((T-eq typ 'lambda)
        !           122:                      (T-eval 
        !           123:                           `(def ,funnm
        !           124:                              (lexpr (nargs)
        !           125:                                (prog (T-arglst T-res T-rslt)    
        !           126:                                      (do ((i nargs (T-sub1 i)))
        !           127:                                          ((T-zerop i))
        !           128:                                          (T-setq T-arglst 
        !           129:                                                  (T-cons (arg i) T-arglst)))
        !           130:                                      (cond ((T-setq T-res 
        !           131:                                                   (and ,if
        !           132:                                                        (not ,ifnot)))
        !           133:                                             (T-traceenter ,funnm)
        !           134:                                             (T-print T-arglst)
        !           135:                                             (T-terpr)
        !           136:                                             ,evalin
        !           137:                                             (cond (,break (trace-break)))))
        !           138:                                      (T-setq T-rslt 
        !           139:                                            (T-apply ',funcd T-arglst))
        !           140:                                      (cond (T-res 
        !           141:                                             ,evalout 
        !           142:                                             (T-traceexit ',funnm T-rslt)
        !           143:                                             (T-terpr)))
        !           144:                                      (return T-rslt)))))
        !           145:                      (T-setq did (T-cons funnm did)
        !           146:                              $$traced-functions$$ (cons funnm
        !           147:                                                         $$traced-functions$$)))
        !           148: 
        !           149:                     ((T-eq typ 'nlambda)
        !           150:                      (T-eval 
        !           151:                       `(def ,funnm
        !           152:                            (nlambda (T-arglst)
        !           153:                                     (prog ( T-res T-rslt)       
        !           154:                                           (cond ((T-setq T-res 
        !           155:                                                          (and ,if
        !           156:                                                               (not ,ifnot)))
        !           157:                                                  (T-traceenter ,funnm)
        !           158:                                                  (T-print T-arglst)
        !           159:                                                  (T-terpr)
        !           160:                                                  ,evalin
        !           161:                                                  (cond (,break (trace-break)))))
        !           162:                                           (T-setq T-rslt 
        !           163:                                                   (T-apply ',funcd T-arglst))
        !           164:                                           (cond (T-res 
        !           165:                                                  ,evalout 
        !           166:                                                  (T-traceexit ',funnm T-rslt)
        !           167:                                                  (T-terpr)))
        !           168:                                           (return T-rslt)))))
        !           169:                      (T-setq did (T-cons funnm did)
        !           170:                              $$traced-functions$$ (T-cons funnm
        !           171:                                                           $$traced-functions$$)))
        !           172:                     
        !           173:                     (t (T-patom '"No such function as: ")
        !           174:                        (T-print funnm)
        !           175:                        (T-terpr))))))
        !           176:         (return (nreverse did)))))
        !           177: 
        !           178: 
        !           179: 
        !           180: (def untrace
        !           181:   (nlambda (argl)
        !           182:           (cond ((T-null argl) (T-setq argl $$traced-functions$$)))
        !           183: 
        !           184:           (do ((i argl (T-cdr i))
        !           185:                (curf)
        !           186:                (res))
        !           187:               ((T-null i)  
        !           188:                (cond ((T-null $$traced-functions$$)
        !           189:                       (T-setq $$trace-indent$$ 0)))
        !           190:                res)
        !           191:               (cond ((T-setq tmp (T-get (T-setq curf (T-car i)) 'T-original))
        !           192:                      (T-putd curf tmp)
        !           193:                      (T-remprop curf 'T-original)
        !           194:                      (T-remprop curf 'entercount)
        !           195:                      (T-setq $$traced-functions$$ 
        !           196:                              (T-delq curf $$traced-functions$$))
        !           197:                      (T-setq res (T-cons curf res)))
        !           198:                     (t (T-setq res (T-cons `(,curf not traced) res)))))))
        !           199: 
        !           200: 
        !           201: ;--- T-traceenter - funnm : name of function just entered
        !           202: ;                - count : count to print out
        !           203: ;      This routine is called to print the entry banner for a
        !           204: ;      traced function.
        !           205: ;
        !           206: (def T-traceenter
        !           207:   (nlambda (nm)
        !           208:           (T-prog (name count)
        !           209:                 (T-setq name (T-car nm))
        !           210:                 (cond ((T-null (T-setq count (T-get name 'entercount)))
        !           211:                        (T-setq count 1)))
        !           212:                 (T-putprop name (add1 count) 'entercount)
        !           213: 
        !           214:                 (do ((i 1 (T-add1 i)))
        !           215:                     ((T-greaterp i $$trace-indent$$))
        !           216:                     (T-patom '" "))
        !           217:                 (T-setq $$trace-indent$$ (T-add1 $$trace-indent$$))
        !           218:                 (T-print count)
        !           219:                 (T-patom '" <Enter> ")
        !           220:                 (T-print name)
        !           221:                 (T-patom '" "))))
        !           222: 
        !           223: (def T-traceexit
        !           224:   (lambda (name retval)
        !           225:          (T-prog (count)
        !           226:                (T-putprop name 
        !           227:                         (T-setq count (T-sub1 (T-get name 'entercount)))
        !           228:                         'entercount)
        !           229:                (do ((i 1 (T-add1 i))
        !           230:                     (over (T-setq $$trace-indent$$ (T-sub1 $$trace-indent$$))))
        !           231:                    ((T-greaterp i over))
        !           232:                    (T-patom '" "))
        !           233: 
        !           234:                (T-print count)
        !           235:                (T-patom '" <EXIT>  ")
        !           236:                (T-print name)
        !           237:                (T-patom '"  ")
        !           238:                (T-print retval)
        !           239:                (return retval))))
        !           240: 
        !           241: ; trace-break  - this is the trace break loop
        !           242: (def trace-break
        !           243:   (lambda nil
        !           244:         (prog (tracevalread)
        !           245:               (T-terpr) (T-patom '"[tracebreak]")
        !           246:        loop   (T-terpr)
        !           247:               (T-patom '"T>")
        !           248:               (T-drain)
        !           249:               (cond ((eq '<EOF> (T-setq tracevalread
        !           250:                                         (car
        !           251:                                          (errset (T-read nil '<EOF>)))))
        !           252:                      (return nil)))
        !           253:               (T-print (car (errset (T-eval tracevalread))))
        !           254:               (go loop))))
        !           255: 
        !           256: (eval-when (eval)
        !           257:   (setq readtable old-read-table-trace))

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