Return to trace.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/trace.l, revision 1.1

1.1     ! root        1: (setq rcs-trace-
        !             2:    "$Header: /usr/lib/lisp/RCS/trace.l,v 1.2 83/08/15 22:30:36 jkf Exp $")
        !             3: 
        !             4: ;---- The Joseph Lister Trace Package, v1
        !             5: ;         John Foderaro, Sept 1979
        !             6: ;------------------------------------------------------------------;
        !             7: ; Copyright (c) 1979 The Regents of the University of California   ;
        !             8: ;      All rights reserved.                                       ;
        !             9: ;------------------------------------------------------------------;
        !            10: (eval-when (eval)
        !            11:   (setq old-read-table-trace readtable)
        !            12:   (setq readtable (makereadtable t))
        !            13:   (setq old-uctolc-value (status uctolc))
        !            14:   (sstatus uctolc nil)         ; turn off case conversion
        !            15:   (load 'charmac)
        !            16:   (setsyntax '\; 'macro 'zapline)
        !            17:   )
        !            18: 
        !            19: 
        !            20: 
        !            21: ;----
        !            22: ; trace uses these properties on the property list:
        !            23: ;    trace-orig-fcn: original occupant of the function cell
        !            24: ;    trace-trace-fcn: the value trace puts in the  function cell
        !            25: ;      (used to check if the trace function has be overwritten).
        !            26: ;    trace-trace-args: the arguments when function was traced.
        !            27: ;    trace-printargs: function to print argument to function
        !            28: ;    trace-printres: function to print result of function
        !            29: 
        !            30: (declare (nlambda T-status T-sstatus)
        !            31:   (special piport
        !            32:           if ifnot evalin evalout 
        !            33:           printargs printres evfcn
        !            34:           traceenter traceexit
        !            35:           prinlevel prinlength
        !            36:           $$traced-functions$$         ; all functions being traced
        !            37:           $$functions-in-trace$$       ; active functions 
        !            38:           $$funcargs-in-trace$$        ; arguments to active functions.
        !            39:           $tracemute                   ; if t, then enters and exits
        !            40:                                        ; are quiet, but info is still
        !            41:                                        ; kept so (tracedump) will work
        !            42:           trace-prinlevel              ; default values
        !            43:           trace-prinlength
        !            44:           trace-printer                ; function trace uses to print
        !            45:           ))
        !            46: 
        !            47: 
        !            48: 
        !            49: (cond ((null (boundp '$$traced-functions$$)) (setq $$traced-functions$$ nil)))
        !            50: (cond ((null (boundp '$$functions-in-trace$$)) (setq $$functions-in-trace$$ nil)))
        !            51: (cond ((null (boundp '$$funcargs-in-trace$$)) (setq $$funcargs-in-trace$$ nil)))
        !            52: (cond ((null (boundp '$tracemute)) (setq $tracemute nil)))
        !            53: (cond ((null (boundp 'trace-prinlevel)) (setq trace-prinlevel 4)))
        !            54: (cond ((null (boundp 'trace-prinlength)) (setq trace-prinlength 5)))
        !            55: (cond ((null (boundp 'trace-printer)) (setq trace-printer 'Trace-print)))
        !            56: 
        !            57: ;----> It is important that the trace package not use traced functions
        !            58: ;      thus we give the functions the trace package uses different
        !            59: ;      names and make them equivalent at this time to their 
        !            60: ;      traceable counterparts.  
        !            61: (defun trace-startup-func nil
        !            62:   (do ((i '( (add1 T-add1)(append T-append)
        !            63:             (and T-and)  (apply T-apply)
        !            64:             (cond T-cond) (cons T-cons) (delq T-delq)
        !            65:             (def T-def) (do T-do) (drain T-drain)
        !            66:             (dtpr T-dtpr)  (eval T-eval)(funcall T-funcall)
        !            67:             (get T-get) (getd T-getd)(getdisc T-getdisc)
        !            68:             (greaterp T-greaterp)(lessp T-lessp)
        !            69:             (mapc T-mapc) (not T-not)(nreverse T-nreverse)
        !            70:             (patom T-patom) (print T-print) (prog T-prog)
        !            71:             (patom T-patom)(putd T-putd) 
        !            72:             (putprop T-putprop)
        !            73:             (read T-read)(remprop T-remprop) (reverse T-reverse)
        !            74:             (return T-return)
        !            75:             (set T-set) (setq T-setq)
        !            76:             (status T-status) (sstatus T-sstatus)
        !            77:             (sub1 T-sub1) (terpr T-terpr) 
        !            78:             (zerop T-zerop))
        !            79:          (cdr i)))
        !            80:       ((null i))
        !            81:       (putd (cadar i) (getd (caar i)))
        !            82:       (putprop (cadar i) t 'Untraceable)))
        !            83: 
        !            84: (trace-startup-func)
        !            85: 
        !            86: 
        !            87: (putprop 'quote t 'Untraceable)                ; this prevents the common error
        !            88:                                        ; of (trace 'foo) from causing big
        !            89:                                        ; problems.
        !            90: 
        !            91: ;--- trace - arg1,arg2, ... names of functions to trace
        !            92: ;      This is the main user callable trace routine. 
        !            93: ; work in progress, documentation incomplete since im not sure exactly
        !            94: ; where this is going. 
        !            95: ;
        !            96: (def trace
        !            97:   (nlambda (argl)
        !            98:    (prog (if ifnot evalin evalout funnm  typ
        !            99:          funcd did break printargs printres evfcn traceenter traceexit
        !           100:          traceargs)
        !           101: 
        !           102:     ; turn off transfer table linkages if they are on
        !           103:     (cond ((T-status translink) (T-sstatus translink nil)))
        !           104: 
        !           105:     ; process each argument     
        !           106: 
        !           107:     (do ((ll argl (cdr ll))
        !           108:         (funnm) 
        !           109:         (funcd))
        !           110:        ((null ll))
        !           111:       (setq funnm (car ll)
        !           112:                if t
        !           113:                break nil
        !           114:                ifnot nil
        !           115:                evalin nil
        !           116:                evalout nil
        !           117:                printargs nil
        !           118:                printres nil
        !           119:                evfcn nil
        !           120:                traceenter 'T-traceenter
        !           121:                traceexit  'T-traceexit
        !           122:                traceargs  nil)
        !           123: 
        !           124:        ; a list as an argument means that the user is specifying
        !           125:        ; conditions on the trace
        !           126:       (cond ((not (atom funnm))
        !           127:             (cond ((not (atom (setq funnm (car funnm))))
        !           128:                    (T-print (car funnm))
        !           129:                    (T-patom '" is non an function name")
        !           130:                    (go botloop)))
        !           131:             ; remember the arguments in case a retrace is requested
        !           132:             (setq traceargs (cdar ll))
        !           133:             ; scan the arguments
        !           134:             (do ((rr (cdar ll) (cdr rr)))
        !           135:                 ((null rr))
        !           136:                 (cond ((memq (car rr) '(if ifnot evalin evalout
        !           137:                                            printargs printres evfcn
        !           138:                                            traceenter traceexit))
        !           139:                        (T-set (car rr) (cadr rr))
        !           140:                        (setq rr    (cdr rr)))
        !           141:                       ((eq (car rr) 'evalinout)
        !           142:                        (setq evalin (setq evalout (cadr rr))
        !           143:                              rr (cdr rr)))
        !           144:                       ((eq (car rr) 'break)
        !           145:                        (setq break t))
        !           146:                       ((eq (car rr) 'lprint)
        !           147:                        (setq printargs 'T-levprint
        !           148:                              printres  'T-levprint))
        !           149:                       (t (T-patom '"bad request: ")
        !           150:                          (T-print (car rr))
        !           151:                          (T-terpr)))))
        !           152:            (t (setq traceargs nil)  ;no args given
        !           153:               ))
        !           154: 
        !           155:            ; if function is untraceable, print error message and skip
        !           156:        (cond ((get funnm 'Untraceable)
        !           157:              (setq did (cons `(,funnm untraceable) did))
        !           158:              (go botloop)))
        !           159: 
        !           160: 
        !           161:        ; Untrace before tracing
        !           162:        (let ((res (funcall 'untrace (list funnm))))
        !           163:          (cond (res (setq did (cons `(,funnm untraced) did)))))
        !           164: 
        !           165:        ; store the names of the arg printing routines if they are
        !           166:        ; different than print
        !           167: 
        !           168:        (cond (printargs (T-putprop funnm printargs 'trace-printargs)))
        !           169:        (cond (printres  (T-putprop funnm printres 'trace-printres)))
        !           170:        (T-putprop funnm traceargs 'trace-trace-args)
        !           171: 
        !           172:        ; we must determine the type of function being traced
        !           173:        ; in order to create the correct replacement function
        !           174: 
        !           175:        (cond ((setq funcd (T-getd funnm))
        !           176:              (cond ((bcdp funcd)               ; machine code
        !           177:                     (cond ((or (eq 'lambda (T-getdisc funcd))
        !           178:                                (eq 'nlambda (T-getdisc funcd))
        !           179:                                (eq 'macro (T-getdisc funcd)))
        !           180:                            (setq typ (T-getdisc funcd)))
        !           181:                           ((stringp (T-getdisc funcd)) ; foreign func
        !           182:                            (setq typ 'lambda))         ; close enough
        !           183:                           (t (T-patom '"Unknown type of compiled function")
        !           184:                              (T-print funnm)
        !           185:                              (setq typ nil))))
        !           186: 
        !           187:                    ((dtpr funcd)               ; lisp coded
        !           188:                     (cond ((or (eq 'lambda (car funcd))
        !           189:                                (eq 'lexpr (car funcd)))
        !           190:                            (setq typ 'lambda))
        !           191:                           ((or (eq 'nlambda (car funcd))
        !           192:                                (eq 'macro (car funcd)))
        !           193:                            (setq typ (car funcd)))
        !           194:                           (t (T-patom '"Bad function definition: ")
        !           195:                              (T-print funnm)
        !           196:                              (setq typ nil))))
        !           197:                    ((arrayp funcd)             ; array
        !           198:                     (setq typ 'lambda))
        !           199:                    (t (T-patom '"Bad function defintion: ")
        !           200:                       (T-print funnm)))
        !           201: 
        !           202:              ; now that the arguments have been examined for this
        !           203:              ; function, do the tracing stuff.
        !           204:              ; First save the old function on the property list
        !           205: 
        !           206:              (T-putprop funnm funcd 'trace-orig-fcn)
        !           207: 
        !           208:              ; now build a replacement
        !           209: 
        !           210:              (cond
        !           211:                 ((eq typ 'lambda)
        !           212:                  (T-eval
        !           213:                     `(T-def
        !           214:                         ,funnm
        !           215:                         (lexpr (T-nargs)
        !           216:                                ((lambda (T-arglst T-res T-rslt
        !           217:                                                   $$functions-in-trace$$
        !           218:                                                   $$funcargs-in-trace$$)
        !           219:                                    (T-do ((i T-nargs (T-sub1 i)))
        !           220:                                          ((T-zerop i))
        !           221:                                          (T-setq T-arglst
        !           222:                                                  (T-cons (arg i) T-arglst)))
        !           223:                                    (T-setq $$funcargs-in-trace$$
        !           224:                                            (T-cons T-arglst
        !           225:                                                    $$funcargs-in-trace$$))
        !           226:                                    (T-cond ((T-setq T-res
        !           227:                                                     (T-and ,if
        !           228:                                                             (T-not ,ifnot)))
        !           229:                                             (,traceenter ',funnm T-arglst)
        !           230:                                             ,@(cond (evalin
        !           231:                                                        `((T-patom ,'":in: ")
        !           232:                                                          ,evalin
        !           233:                                                          (T-terpr))))
        !           234:                                             (T-cond (,break
        !           235:                                                       (trace-break)))))
        !           236:                                    (T-setq T-rslt
        !           237:                                            ,(cond
        !           238:                                                (evfcn)
        !           239:                                                (t `(T-apply
        !           240:                                                       ',funcd
        !           241:                                                       T-arglst))))
        !           242:                                    (T-cond (T-res
        !           243:                                               ,@(cond (evalout
        !           244:                                                          `((T-patom ,'":out: ")
        !           245:                                                            ,evalout
        !           246:                                                            (T-terpr))))
        !           247:                                               (,traceexit ',funnm T-rslt)))
        !           248:                                    T-rslt)
        !           249:                                 nil nil nil
        !           250:                                 (T-cons ',funnm $$functions-in-trace$$)
        !           251:                                 $$funcargs-in-trace$$))))
        !           252:                  (T-putprop funnm (T-getd funnm) 'trace-trace-fcn)
        !           253:                  (setq did (cons funnm did)
        !           254:                        $$traced-functions$$ (cons funnm
        !           255:                                                   $$traced-functions$$)))
        !           256: 
        !           257:                 ((or (eq typ 'nlambda)
        !           258:                      (eq typ 'macro))
        !           259:                  (T-eval
        !           260:                     `(T-def ,funnm
        !           261:                              (,typ (T-arglst)
        !           262:                                ((lambda (T-res T-rslt
        !           263:                                                $$functions-in-trace$$
        !           264:                                                $$funcargs-in-trace$$)
        !           265:                                    (T-setq $$funcargs-in-trace$$
        !           266:                                            (T-cons
        !           267:                                               T-arglst
        !           268:                                               $$funcargs-in-trace$$))
        !           269:                                    (T-cond ((T-setq
        !           270:                                                T-res
        !           271:                                                (T-and ,if
        !           272:                                                        (not ,ifnot)))
        !           273:                                             (,traceenter
        !           274:                                               ',funnm
        !           275:                                               T-arglst)
        !           276:                                             ,evalin
        !           277:                                             (T-cond (,break
        !           278:                                                       (trace-break)))))
        !           279:                                    (T-setq T-rslt
        !           280:                                            ,(cond
        !           281:                                                (evfcn `(,evfcn
        !           282:                                                          ',funcd
        !           283:                                                          T-arglst))
        !           284:                                                (t `(T-apply ',funcd
        !           285:                                                             T-arglst))))
        !           286:                                    (T-cond (T-res
        !           287:                                               ,evalout
        !           288:                                               (,traceexit ',funnm T-rslt)))
        !           289:                                    T-rslt)
        !           290:                                 nil nil
        !           291:                                 (cons ',funnm $$functions-in-trace$$)
        !           292:                                 $$funcargs-in-trace$$))))
        !           293:                  (T-putprop funnm (T-getd funnm) 'trace-trace-fcn)
        !           294:                  (setq did (cons funnm did)
        !           295:                        $$traced-functions$$ (cons funnm
        !           296:                                                   $$traced-functions$$)))
        !           297: 
        !           298:                 (t (T-patom '"No such function as: ")
        !           299:                    (T-print funnm)
        !           300:                    (T-terpr)))))
        !           301:            botloop )
        !           302:         ; if given no args, just return the function currently being traced
        !           303:         (return (cond ((null argl) $$traced-functions$$)
        !           304:                       (t (T-nreverse did)))))))
        !           305: 
        !           306: ;--- untrace
        !           307: ; (untrace foo bar baz)
        !           308: ;    untraces foo, bar and baz.
        !           309: ; (untrace)
        !           310: ;    untraces all functions being traced.
        !           311: ;
        !           312: 
        !           313: (def untrace
        !           314:   (nlambda (argl)
        !           315:           (cond ((null argl) (setq argl $$traced-functions$$)))
        !           316: 
        !           317:           (do ((i argl (cdr i))
        !           318:                (tmp)
        !           319:                (curf)
        !           320:                (res))
        !           321:               ((null i)  
        !           322:                (cond ((null $$traced-functions$$)
        !           323:                       (setq $$functions-in-trace$$ nil)
        !           324:                       (setq $$funcargs-in-trace$$ nil)))
        !           325:                res)
        !           326:               (cond ((and (T-getd (setq curf (car i)))
        !           327:                           (eq (T-getd (car i))
        !           328:                               (get (car i) 'trace-trace-fcn)))
        !           329:                      ; we only want to restore the original definition
        !           330:                      ; if this function has not been redefined!
        !           331:                      ; we test this by checking to be sure that the
        !           332:                      ; trace-trace-property is the same as the function
        !           333:                      ; definition.
        !           334:                      (T-putd curf (get curf 'trace-orig-fcn))
        !           335:                      (T-remprop curf 'trace-orig-fcn)
        !           336:                      (T-remprop curf 'trace-trace-fcn)
        !           337:                      (T-remprop curf 'trace-trace-args)
        !           338:                      (T-remprop curf 'entercount)
        !           339:                      (setq $$traced-functions$$ 
        !           340:                              (T-delq curf $$traced-functions$$))
        !           341:                      (setq res (cons curf res)))))))
        !           342: 
        !           343: 
        !           344: ;--- retrace :: trace again all function thought to be traced.
        !           345: ;
        !           346: (def retrace
        !           347:    (nlambda (args)
        !           348:        (cond ((null args) (setq args $$traced-functions$$)))
        !           349:        (mapcan '(lambda (fcn)
        !           350:                    (cond ((and (symbolp fcn)
        !           351:                                (not (eq (T-getd fcn)
        !           352:                                         (get fcn 'trace-trace-fcn))))
        !           353:                           
        !           354:                           (funcall 'trace
        !           355:                                    `((,fcn ,@(get fcn 'trace-trace-args)))))))
        !           356:                args)))
        !           357: 
        !           358: ;--- tracedump :: dump the currently active trace frames
        !           359: ;
        !           360: (def tracedump
        !           361:   (lambda nil
        !           362:          (let (($tracemute nil))
        !           363:               (T-tracedump-recursive $$functions-in-trace$$ 
        !           364:                                      $$funcargs-in-trace$$))))
        !           365: 
        !           366: 
        !           367: ;--- traceargs :: return list of args to currently entered traced functions
        !           368: ;  call is:
        !           369: ;      (traceargs foo)  returns first call to foo starting at most current
        !           370: ;       (traceargs foo 3) returns args to third call to foo, starting at
        !           371: ;                        most current
        !           372: ;
        !           373: (def traceargs
        !           374:   (nlambda (args)
        !           375:           (cond ((and args $$functions-in-trace$$)
        !           376:                  (let ((name (car args))
        !           377:                        (amt (cond ((numberp (cadr args)) (cadr args))
        !           378:                                   (t 1))))
        !           379:                       (do ((fit $$functions-in-trace$$ (cdr fit))
        !           380:                            (fat $$funcargs-in-trace$$ (cdr fat)))
        !           381:                           ((null fit))
        !           382:                           (cond ((eq name (car fit))
        !           383:                                  (cond ((zerop (setq amt (1- amt)))
        !           384:                                         (return (car fat))))))))))))
        !           385: 
        !           386: ;--- T-tracedump-recursive
        !           387: ; since the lists of functions being traced and arguments are in the reverse
        !           388: ; of the order we want to print them, we recurse down the lists and on the
        !           389: ; way back we print the information.
        !           390: ;
        !           391: (def T-tracedump-recursive
        !           392:   (lambda ($$functions-in-trace$$ $$funcargs-in-trace$$)
        !           393:          (cond ((null $$functions-in-trace$$))
        !           394:                (t (T-tracedump-recursive (cdr $$functions-in-trace$$)
        !           395:                                          (cdr $$funcargs-in-trace$$))
        !           396:                   (T-traceenter (car $$functions-in-trace$$)
        !           397:                                 (car $$funcargs-in-trace$$))))))
        !           398: 
        !           399: 
        !           400: 
        !           401: ;--- T-traceenter - funnm : name of function just entered
        !           402: ;                - count : count to print out
        !           403: ;      This routine is called to print the entry banner for a
        !           404: ;      traced function.
        !           405: ;
        !           406: (def T-traceenter
        !           407:   (lambda (name args)
        !           408:          (prog (count indent)
        !           409:                (cond ((not $tracemute)
        !           410:                       (setq count 0 indent 0)
        !           411:                       (do ((ll $$functions-in-trace$$ (cdr ll)))
        !           412:                           ((null ll))
        !           413:                           (cond ((eq (car ll) name) (setq count (1+ count))))
        !           414:                           (setq indent (1+ indent)))
        !           415:                       
        !           416:                       (T-traceindent indent)
        !           417:                       (T-print count)
        !           418:                       (T-patom '" <Enter> ")
        !           419:                       (T-print name)
        !           420:                       (T-patom '" ")
        !           421:                       (cond ((setq count (T-get name 'trace-printargs))
        !           422:                              (funcall count args))
        !           423:                             (t (funcall trace-printer args)))
        !           424:                       (T-terpr))))))
        !           425: 
        !           426: (def T-traceexit
        !           427:   (lambda (name res)
        !           428:          (prog (count indent)
        !           429:                (cond ((not $tracemute)
        !           430:                       (setq count 0 indent 0)
        !           431:                       (do ((ll $$functions-in-trace$$ (cdr ll)))
        !           432:                           ((null ll))
        !           433:                           (cond ((eq (car ll) name) (setq count (1+ count))))
        !           434:                           (setq indent (1+ indent)))
        !           435:                       
        !           436:                       
        !           437:                       (T-traceindent indent)
        !           438:                       (T-print count)
        !           439:                       (T-patom " <EXIT>  ")
        !           440:                       (T-print name)
        !           441:                       (T-patom "  ")
        !           442:                       
        !           443:                       (cond ((setq count (T-get name 'trace-printres))
        !           444:                              (funcall count res))
        !           445:                             (t (funcall trace-printer res)))
        !           446:                       
        !           447:                       (T-terpr))))))
        !           448: 
        !           449: 
        !           450: ;--- Trace-printer
        !           451: ;  this is the default value of trace-printer.  It prints a form after
        !           452: ; binding prinlevel and prinlength.
        !           453: ;
        !           454: (def Trace-print
        !           455:    (lambda (form)
        !           456:       (let ((prinlevel trace-prinlevel)
        !           457:            (prinlength trace-prinlength))
        !           458:         (T-print form))))
        !           459: 
        !           460: ; T-traceindent
        !           461: ; - n   :  indent to column n
        !           462: 
        !           463: (def T-traceindent
        !           464:   (lambda (col)
        !           465:          (do ((i col (1- i))
        !           466:               (char '| |))
        !           467:              ((< i 2))
        !           468:              (T-patom (cond ((eq char '| |) (setq char '\|))
        !           469:                             (t (setq char '| |)))))))
        !           470: ; from toplevel.l:
        !           471: ;
        !           472: ;--- read and print functions are user-selectable by just
        !           473: ; assigning another value to top-level-print and top-level-read
        !           474: ;
        !           475: (declare (special top-level-read top-level-print))
        !           476: 
        !           477: (defmacro top-print (&rest args)
        !           478:    `(cond (top-level-print (funcall top-level-print ,@args))
        !           479:          (t (T-print ,@args))))
        !           480: 
        !           481: (defmacro top-read (&rest args)
        !           482:    `(cond ((and top-level-read
        !           483:                (T-getd top-level-read))
        !           484:           (funcall top-level-read ,@args))
        !           485:          (t (T-read ,@args))))
        !           486: 
        !           487: 
        !           488: ; trace-break  - this is the trace break loop
        !           489: (def trace-break
        !           490:   (lambda nil
        !           491:         (prog (tracevalread piport)
        !           492:               (T-terpr) (T-patom '"[tracebreak]")
        !           493:        loop   (T-terpr)
        !           494:               (T-patom '"T>")
        !           495:               (T-drain)
        !           496:               (cond ((or (eq nil (setq tracevalread
        !           497:                                         (car
        !           498:                                          (errset (top-read nil nil)))))
        !           499:                          (and (dtpr tracevalread)
        !           500:                               (eq 'tracereturn (car tracevalread))))
        !           501:                        (T-terpr)
        !           502:                        (return nil)))
        !           503:               (top-print (car (errset (T-eval tracevalread))))
        !           504:               (go loop))))
        !           505: 
        !           506: 
        !           507: (def T-levprint
        !           508:   (lambda (x)
        !           509:          ((lambda (prinlevel prinlength)
        !           510:                  (T-print x))
        !           511:           3 10)))
        !           512: 
        !           513:                       
        !           514: (eval-when (eval)
        !           515:   (apply 'sstatus `(uctolc ,old-uctolc-value))
        !           516:   (setq readtable old-read-table-trace)
        !           517:   )

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