Return to print.l CVS log

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

Annotation of 42BSD/ucb/lisp/pearl/print.l, revision 1.1

1.1     ! root        1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; print.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             2: ; Functions for converting from internal form to a printable form.
        !             3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             4: ; Copyright (c) 1983 ,  The Regents of the University of California.
        !             5: ; All rights reserved.  
        !             6: ; Authors: Joseph Faletti and Michael Deering.
        !             7: 
        !             8: ; Convert a predicate, which might be a structure, to printable form.
        !             9: (de convertpreds (pred)
        !            10:   (cond ((or (litatom pred)
        !            11:             (dtpr pred)
        !            12:             (numberp pred))
        !            13:         pred)
        !            14:        ((structurep pred) (allform pred))
        !            15:        ((definitionp pred) (getpname pred))
        !            16:        ( t pred)))
        !            17:  
        !            18: ; Reverse assoc through a list of cons-cells -- look at the CDRs
        !            19: ;   for value and return the first cons-cell that matches.
        !            20: (de revassq (value alist)
        !            21:   (while alist  ; is not NIL
        !            22:         (and (eq value (cdar alist))
        !            23:              (return (car alist)))
        !            24:         (setq alist (cdr alist))))
        !            25: 
        !            26: ; Convert an ordinal to printable form.
        !            27: (defmacro ppsetform (slotval ppset)
        !            28:   `(cond ((eq 'int ,ppset) ,slotval)
        !            29:         ( t (let ((assqlist (eval (ordatom ,ppset)))
        !            30:                   assqresult)
        !            31:                  (cond ((setq assqresult (revassq ,slotval assqlist))
        !            32:                         (car assqresult))
        !            33:                        ((\=& 0 ,slotval) '*zero-ordinal-value*)
        !            34:                        ( t  (list ,ppset ,slotval)))))))
        !            35: 
        !            36: ; Convert a stream to printable form.
        !            37: (defmacro streamform (item)
        !            38:   `(cond ((eq t (cadr ,item)) (list '*function-stream:*
        !            39:                                    (structureform (cddr ,item))))
        !            40:         ((or *fullprint*
        !            41:              (not *streamprintlength*))
        !            42:          (list '*stream:*
        !            43:                (structureform (cadr ,item))
        !            44:                (mapcan (funl (struct)
        !            45:                              (cond ((eq '*db* struct) nil)
        !            46:                                    ( t (ncons (structureform struct)))))
        !            47:                        (cddr ,item))))
        !            48:         ( t
        !            49:          (list
        !            50:           '*stream:*
        !            51:           (structureform (cadr ,item))
        !            52:           (let
        !            53:            ((rest (cddr ,item))
        !            54:             (result (ncons nil))
        !            55:             next)
        !            56:            (cond ((dtpr (car rest))
        !            57:                   ; stream built by expandedfetch.
        !            58:                   (let ((itemnum 1)
        !            59:                         bucket)
        !            60:                        (while (setq bucket (pop rest))
        !            61:                               (mapc
        !            62:                                (funl (next)
        !            63:                                      (or (eq '*db* next)
        !            64:                                          (progn
        !            65:                                           (and (>& itemnum *streamprintlength*)
        !            66:                                                (progn
        !            67:                                                 (tconc result '|...|)
        !            68:                                                 (return (car result))))
        !            69:                                           (tconc result (structureform next))
        !            70:                                           (setq itemnum (1+ itemnum))
        !            71:                                           )))
        !            72:                                bucket)
        !            73:                               (or rest
        !            74:                                   (return (car result))))))
        !            75:                  ( t (for itemnum 1 *streamprintlength*
        !            76:                           (while (and (setq next (pop rest))
        !            77:                                       (eq '*db* next))
        !            78:                                  ) ; do nothing
        !            79:                           (or next
        !            80:                               (return (car result)))
        !            81:                           (tconc result (structureform next)))))
        !            82:            (and rest
        !            83:                 (tconc result '|...|))
        !            84:            (car result))))))
        !            85:  
        !            86: ; Convert a symbol to printable form.
        !            87: (defmacro symbolform (item)
        !            88:   `(getsymbolpname ,item))
        !            89: 
        !            90: ; Convert an equivalence class list to printable form.
        !            91: (defmacro equivclassform (equiv)
        !            92:   `(let ((equivclass ,equiv))
        !            93:        (mapcan (funl (var)
        !            94:                      (cond ((dtpr var) ; a local var
        !            95:                             ; filter out variables which are no longer
        !            96:                             ; members of the equivalence class
        !            97:                             (and (eq (cdr var) equivclass)
        !            98:                                  (ncons (list '*var* (car var)))))
        !            99:                            ( t ; otherwise a global var
        !           100:                                (and (eq (eval var) equivclass)
        !           101:                                     (ncons (list '*global* var))))))
        !           102:                (cdr equivclass))))
        !           103: 
        !           104: ; Convert a definition to printable form.
        !           105: (defmacro defform (item)
        !           106:   `(cons 'definition-of:
        !           107:         (structureform (getdefaultinst ,item))))
        !           108: 
        !           109: ; Convert the constant portion of a slot
        !           110: (defmacro slotconstform (item typenum ppset)
        !           111:   `(selectq ,typenum
        !           112:            (0 (or (and *abbrevprint*
        !           113:                        (getabbrev ,item))
        !           114:                   (structureform ,item)))
        !           115:            (1 (symbolform ,item))
        !           116:            (2 (ppsetform ,item ,ppset))
        !           117:            (3 (allform ,item))
        !           118:            (otherwise
        !           119:             (let ((newtypenum (- ,typenum 4.)))
        !           120:                  (cond ((dtpr ,item)
        !           121:                         (mapcar
        !           122:                          (funl (singleitem)
        !           123:                                (listitemform singleitem newtypenum ,ppset))
        !           124:                          ,item))
        !           125:                        ; otherwise, in case value is somehow not a list,
        !           126:                        ;    do your best.
        !           127:                        (t (allform ,item)))))))
        !           128: 
        !           129: ; Makes a function out of slotconstform for mapping on a setof slot.
        !           130: (de listitemform (item typenum ppset)
        !           131:   (slotconstform item typenum ppset))
        !           132: 
        !           133: ; Macro version of slotconstform for normal use on a slot's value.
        !           134: (defmacro slotitemform (printval)
        !           135:   `(let ((item ,printval)
        !           136:         (typenum (getslottype slotnum defblock))
        !           137:         (ppset (getppset slotnum defblock)))
        !           138:        (slotconstform item typenum ppset)))
        !           139: 
        !           140: ; Convert a slot from internal form to a list form.
        !           141: (dm slotform (none)    ; but assumes SLOTNUM, ITEM, PRINTVAL and PRINTVAR.
        !           142:   '(progn
        !           143:     (setq printval (getslotvalue slotnum item))
        !           144:     (selectq (getslotvaluetype slotnum item)
        !           145:             (CONSTANT  (slotitemform printval))
        !           146:             (LOCAL     (cond ((eq (punbound) (cdr printval))
        !           147:                               (list '*var* (car printval)))
        !           148:                              ((equivclassp (cdr printval))
        !           149:                               (list (list '*var* (car printval))
        !           150:                                     ; Unfortunate kludge to get rid of \'s.
        !           151:                                     (ncons 'pearlequals)
        !           152:                                     (equivclassform (cdr printval))))
        !           153:                              ( t (list (list '*var* (car printval))
        !           154:                                        ; Unfortunate kludge to get rid of \'s.
        !           155:                                        (ncons 'pearlequals)
        !           156:                                        (slotitemform (cdr printval))))))
        !           157:             (ADJUNCT   (list (slotitemform (car printval))
        !           158:                              (ncons 'pearlequals)
        !           159:                              (let ((var (cdr printval)))
        !           160:                                   (cond ((dtpr var)
        !           161:                                          (list '*var* (car var)))
        !           162:                                         ( t (list '*global* var))))))
        !           163:             (GLOBAL    (cond ((eq (punbound) (eval printval))
        !           164:                               (list '*global* printval))
        !           165:                              ((equivclassp (eval printval))
        !           166:                               (list (list '*global* printval)
        !           167:                                     ; Unfortunate kludge to get rid of \'s.
        !           168:                                     (ncons 'pearlequals)
        !           169:                                     (equivclassform (eval printval))))
        !           170:                              ( t (list (list '*global* printval)
        !           171:                                        ; Unfortunate kludge to get rid of \'s.
        !           172:                                        (ncons 'pearlequals)
        !           173:                                        (slotitemform (eval printval)))))))))
        !           174: 
        !           175: (de structureform (item)
        !           176:   (let* ((curlist (ncons nil))
        !           177:         (defblock (getdefinition item))
        !           178:         (basehooks (getbasehooks defblock))
        !           179:         ppset
        !           180:         printvar
        !           181:         printval)
        !           182:        (cond ((and *uniqueprint*
        !           183:                    ; if there then return it.
        !           184:                    (cdr (assq item *uniqueprintlist*))))
        !           185:              ( t (tconc curlist (getpname defblock))
        !           186:                  (and *fullprint*
        !           187:                       basehooks
        !           188:                       (tconc curlist (cons 'if basehooks)))
        !           189:                  (and *uniqueprint*
        !           190:                       (push (cons item (car curlist))
        !           191:                             *uniqueprintlist*))
        !           192:                  (for slotnum 1 (getstructlength defblock)
        !           193:                       (tconc curlist
        !           194:                              (nconc (ncons (car
        !           195:                                             (getslotname slotnum defblock)))
        !           196:                                     (ncons (slotform))
        !           197:                                     (and *fullprint*
        !           198:                                          (mapcar (function convertpreds)
        !           199:                                                  (getpred slotnum item)))
        !           200:                                     (and *fullprint*
        !           201:                                          (getslothooks slotnum item)))))
        !           202:                  (car curlist)))))
        !           203: 
        !           204: ; Convert any combination of PEARL and Lisp items (possibly from internal
        !           205: ; form) to a printable list structure.
        !           206: (de allform (item)
        !           207:   (cond ((hunkp item)
        !           208:         (selectq (gettypetag item)
        !           209:                  (*pearlinst* (structureform item))
        !           210:                  (*pearlsymbol* (symbolform item))
        !           211:                  (*pearldef* (defform item))
        !           212:                  (*pearldb*  (list 'database: (getdbname item)))
        !           213:                  (*pearlinactivedb*  (list 'Inactive 'Database))
        !           214:                  (otherwise item))) ; arbitrary hunk?.
        !           215:        ((streamp item) (streamform item))
        !           216:        ((equivclassp item) (equivclassform item))
        !           217:        ((atom item) item)
        !           218:        ((dtpr item) (cons (allform (car item))
        !           219:                           (allform (cdr item))))
        !           220:        ; Else return item (arbitrary pieces of core?).
        !           221:        ( t item)))
        !           222: 
        !           223: ; Convert a PEARL item in full detail and SPRINT the result.
        !           224: (de fullform (item)
        !           225:   (let ((*fullprint* t)
        !           226:        (*abbrevprint* nil)
        !           227:        (*uniqueprintlist* nil))
        !           228:        (allform item)))
        !           229: 
        !           230: ; Convert a PEARL item using abbreviations and SPRINT the result.
        !           231: (de abbrevform (item)
        !           232:   (let ((*abbrevprint* t)
        !           233:        (*fullprint* nil)
        !           234:        (*uniqueprintlist* nil))
        !           235:        (allform item)))
        !           236: 
        !           237: ; Normal function to convert a PEARL item and SPRINT the result.
        !           238: (de valform (item)
        !           239:   (let ((*fullprint* nil)
        !           240:        (*abbrevprint* nil)
        !           241:        (*uniqueprintlist* nil))
        !           242:        (allform item)))
        !           243: 
        !           244: ; Convert any PEARL item using whatever the current settings of 
        !           245: ;   *abbrevprint*, *fullprint* and *uniqueprint* are,
        !           246: ;   and SPRINT the result.
        !           247: ; BUT, don't bother if *quiet* is non-nil.
        !           248: (de allprint (item &optional (lmar 0) (rmar 0))
        !           249:   (or *quiet*
        !           250:       (sprint (allform item) lmar rmar))
        !           251:   '*invisible*)
        !           252:  
        !           253: (de structureprint (item &optional (lmar 0) (rmar 0))
        !           254:   (or *quiet*
        !           255:       (sprint (structureform item) lmar rmar))
        !           256:   '*invisible*)
        !           257:  
        !           258: (de symbolprint (item &optional (lmar 0) (rmar 0))
        !           259:   (or *quiet*
        !           260:       (sprint (symbolform item) lmar rmar))
        !           261:   '*invisible*)
        !           262:  
        !           263: (de streamprint (item &optional (lmar 0) (rmar 0))
        !           264:   (or *quiet*
        !           265:       (sprint (streamform item) lmar rmar))
        !           266:   '*invisible*)
        !           267:  
        !           268: (de fullprint (item &optional (lmar 0) (rmar 0))
        !           269:   (or *quiet*
        !           270:       (sprint (fullform item) lmar rmar))
        !           271:   '*invisible*)
        !           272:  
        !           273: (de valprint (item &optional (lmar 0) (rmar 0))
        !           274:   (or *quiet*
        !           275:       (sprint (valform item) lmar rmar))
        !           276:   '*invisible*)
        !           277:  
        !           278: (de abbrevprint (item &optional (lmar 0) (rmar 0))
        !           279:   (or *quiet*
        !           280:       (sprint (abbrevform item) lmar rmar))
        !           281:   '*invisible*)
        !           282:  
        !           283: ; Run some commands but silence any printing it normally does.
        !           284: (df quiet (command)
        !           285:   (let ((*quiet* t))
        !           286:        (eval `(progn ,@command))))
        !           287: 
        !           288: ; Print out a data base, printing only buckets that have something in them.
        !           289: (de printdb (&optional (db *db*))
        !           290:   (let ((db1 (getdb1 db))
        !           291:        (db2 (getdb2 db))
        !           292:        bucket)
        !           293:        (or (databasep db)
        !           294:           (progn (msg t "PRINTDB: Argument is not a database." t)
        !           295:                  (pearlbreak)))
        !           296:        (msg t "DB-Name: " (getdbname db))
        !           297:        (msg t "Active: " (getdbactive db))
        !           298:        (msg t "Children: " (mapcar (function pname) (getdbchildren db)))
        !           299:        (msg t "Parent: " (pname (getdbparent db)))
        !           300:        (msg t "DB1:")
        !           301:        (and db1
        !           302:            (for slotnum 0 (1- *db1size*)
        !           303:                 (and (setq bucket (remq '*db* (cxr slotnum db1)))
        !           304:                      (progn (msg t "    " slotnum ": ")
        !           305:                             (pearlprintfn bucket)))))
        !           306:        
        !           307:        (msg t "DB2:")
        !           308:        (and db2
        !           309:            (for slotnum 0 (1- *db2size*)
        !           310:                 (and (setq bucket (remq '*db* (cxr slotnum db2)))
        !           311:                      (progn (msg t "    " slotnum ": ")
        !           312:                             (pearlprintfn bucket)))))
        !           313:        '*invisible*))
        !           314: 
        !           315: ; Print complete information on the internal values stored in a structure
        !           316: ;    and its definition (or a definition and its default instance).
        !           317: (de debugprint (item)
        !           318:   (let (def name)
        !           319:        (cond ((definitionp item)
        !           320:              (setq def item)
        !           321:              (setq item (getdefaultinst def)))
        !           322:             ( t  (setq def (getdefinition item))))
        !           323:        (and (setq name (getabbrev item))
        !           324:            (msg t "******** " name " ********"))
        !           325:        (msg t "Definition:")
        !           326:        (msg t "   Unique\#: " (getuniquenum def))
        !           327:        (msg "  Length: " (getstructlength def))
        !           328:        (msg "  DefaultInst: " (getdefaultinst def))
        !           329:        (msg t "   Isa: " (getisa def))
        !           330:        (msg t "   Pname: " (getpname def))
        !           331:        (msg "  HashAlias: " (gethashalias def))
        !           332:        (msg "  ExpansionList: " (getexpansionlist def))
        !           333:        (msg t "   BaseIfs: " (getbasehooks def))
        !           334:        (msg t "Individual:")
        !           335:        (msg "  Abbrev: " (getabbrev item))
        !           336:        (msg t "   AList: " (getalist item))
        !           337:        (msg "  AListcp: " (getalistcp item))
        !           338:        (for slotnum 1 (getstructlength def)
        !           339:            (msg t t "***Slotnum " slotnum
        !           340:                 " : " (getslotname slotnum def))
        !           341:            (msg t "Formatinfo: " (getformatinfo slotnum def))
        !           342:            (msg "  HashInfo: " (gethashinfo slotnum def))
        !           343:            (msg "  Enforce: " (getenforce slotnum def))
        !           344:            (msg "  Type: " (getslottype slotnum def))
        !           345:            (msg "  PPSet: " (getppset slotnum def))
        !           346:            (msg t "ValueType: " (getslotvaluetype slotnum item))
        !           347:            (msg "  Internal Value: " (getslotvalue slotnum item))
        !           348:            (msg t "Value: " (getvalue slotnum item))
        !           349:            (msg "  Preds: " (getpred slotnum item))
        !           350:            (msg "  SlotIfs: " (getslothooks slotnum item)))
        !           351:        '*invisible*))
        !           352:  
        !           353: 
        !           354: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !           355: ; the print functions for use with the top level, msg, and the
        !           356: ;    trace, break, etc. packages.
        !           357: 
        !           358: ; standard trace print should use allform after turning off tracing.
        !           359: (de pearltraceprintfn (*traceval*)
        !           360:   ; Set the $tracemute flag to t so that tracing won't be done
        !           361:   ; inside allform.
        !           362:   (let ((\$tracemute t))
        !           363:        (print (allform *traceval*))))
        !           364: 
        !           365: ; standard showstack print should use allform.
        !           366: (de pearlshowstackprintfn (*showstackval*)
        !           367:   (print (allform *showstackval*)))
        !           368: 
        !           369: ; standard break print should use allform.
        !           370: (de pearlbreakprintfn (*breakval*)
        !           371:   (print (allform *breakval*)))
        !           372: 
        !           373: ; standard fix print should use allform.
        !           374: (de pearlfixprintfn (*fixval*)
        !           375:   (print (allform *fixval*)))
        !           376: 
        !           377: ; msg should allform, unless *invisible*.
        !           378: (de msgprintfn (*msgval*)
        !           379:   (or (eq '*invisible* *msgval*)
        !           380:       (patom (allform *msgval*))))
        !           381: 
        !           382: ; printing in a trace-break should allprint.
        !           383: (de pearltracebreakprintfn (*printval*)
        !           384:   (allprint *printval* 3))
        !           385: 
        !           386: ; standard print should allprint.
        !           387: (de pearlprintfn (*printval*)
        !           388:   (allprint *printval* 3))
        !           389: 
        !           390: ; standard dskin print should use allform unless an atom.
        !           391: (de dskprintfn (*dskval*)
        !           392:   (cond ((atom *dskval*) (patom *dskval*))
        !           393:        ( t (print (allform  *dskval*)))))
        !           394:  
        !           395: 
        !           396: ; vi: set lisp:

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