![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to print.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl|
Return to print.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl |
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.