![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lowlevel.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl|
Return to lowlevel.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;; lowlevel.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Macros (mostly) for accessing structures, symbols and definitions.
3: ; See the file "template" for a picture of how structures and
4: ; symbols and data bases are arranged to explain the simplest
5: ; of the functions below.
6: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7: ; Copyright (c) 1983 , The Regents of the University of California.
8: ; All rights reserved.
9: ; Authors: Joseph Faletti and Michael Deering.
10:
11: ; Throughout the code for PEARL:
12: ; defblock: will contain a definition of a structure,
13: ; valblock: will contain an instance of a structure,
14: ; slotnum: will contain a slot number to index into a structure.
15: ; An attempt has been made throughout the rest to similarly name
16: ; things to be obvious.
17:
18: ; These macros are designed so that PEARL can be moved to a new Lisp
19: ; simply by implementing the functions "makhunk", "cxr", and
20: ; "rplacx" to behave as they do in Franz Lisp.
21:
22: (defmacro getdefaultinst (defblock)
23: `(cxr 3 ,defblock))
24:
25: (defmacro getdefinition (valblock)
26: `(cxr 0 ,valblock))
27:
28: (defmacro allocdef (numofslots)
29: `(makhunk (+ 10 (* 4 ,numofslots))))
30:
31: (defmacro allocval (numofslots)
32: `(makhunk (+ 4 (* 4 ,numofslots))))
33:
34: (defmacro puttypetag (tag hunk)
35: `(rplacx 1 ,hunk ,tag))
36:
37: (defmacro gettypetag (hunk)
38: `(cxr 1 ,hunk))
39:
40: (defmacro putstructlength (size defblock)
41: `(rplacx 2 ,defblock ,size))
42:
43: (defmacro getstructlength (defblock)
44: `(cxr 2 ,defblock))
45:
46: (defmacro putuniquenum (num defblockorsym)
47: `(rplacx 0 ,defblockorsym ,num))
48:
49: (defmacro getuniquenum (defblockorsym)
50: `(cxr 0 ,defblockorsym))
51:
52: ; Generate a new unique number.
53: (dm newnum (none)
54: '(setq *lastsymbolnum* (1+ *lastsymbolnum*)))
55:
56: ; Special atom for each structure's definition.
57: (de defatom (symbol)
58: (concat 'd: symbol))
59:
60: ; Special atom for each structure's default instance.
61: (de instatom (symbol)
62: (concat 'i: symbol))
63:
64: ; Special atom for each symbol.
65: (de symatom (symbol)
66: (concat 's: symbol))
67:
68: ; Special atom for each block.
69: (de blockatom (symbol)
70: (concat 'b: symbol))
71:
72: ; Special atom for each ordinal type.
73: (de ordatom (symbol)
74: (concat 'o: symbol))
75:
76: (defmacro putsymbolpname (name block)
77: `(rplacx 2 ,block ,name))
78:
79: (defmacro getsymbolpname (symbolitem)
80: `(cxr 2 ,symbolitem))
81:
82: (defmacro putpname (name blk)
83: `(rplacx 5 ,blk ,name))
84:
85: (defmacro getpname (blk)
86: `(cxr 5 ,blk))
87:
88: (defmacro putdef (defblock valblock)
89: `(rplacx 0 ,valblock ,defblock))
90:
91: (defmacro putisa (isa valblock)
92: `(rplacx 4 ,valblock ,isa))
93:
94: (defmacro getisa (valblock)
95: `(cxr 4 ,valblock))
96:
97: (defmacro putdefaultinst (valblock defblock)
98: `(rplacx 3 ,defblock ,valblock))
99:
100: (defmacro puthashalias (hashnum blk)
101: `(rplacx 6 ,blk ,hashnum))
102:
103: (defmacro gethashalias (blk)
104: `(cxr 6 ,blk))
105:
106: (defmacro puthashfocus (hashnum blk)
107: `(rplacx 7 ,blk ,hashnum))
108:
109: (defmacro gethashfocus (blk)
110: `(cxr 7 ,blk))
111:
112: (defmacro putexpansionlist (explist blk)
113: `(rplacx 8 ,blk ,explist))
114:
115: (defmacro getexpansionlist (blk)
116: `(cxr 8 ,blk))
117:
118: (defmacro putbasehooks (hooklist defblk)
119: `(rplacx 9 ,defblk ,hooklist))
120:
121: (defmacro getbasehooks (defblk)
122: `(cxr 9 ,defblk))
123:
124: (de addbasehook (conscell item)
125: (let* ((itemdef (getdefinition item))
126: (oldhooks (getbasehooks itemdef)))
127: (cond (oldhooks (nconc1 oldhooks conscell))
128: ( t (putbasehooks itemdef (ncons conscell))))))
129:
130: (defmacro getslotname (slotnum blk)
131: `(cxr (+ 8 (* 4 ,slotnum)) ,blk))
132:
133: (defmacro putslotname (slotnum slotname blk)
134: `(rplacx (+ 8 (* 4 ,slotnum)) ,blk ,slotname))
135:
136: (defmacro addslotname (slotnum slotname blk)
137: `(rplacx (+ 8 (* 4 ,slotnum)) ,blk
138: (cons ,slotname (cxr (+ 8 (* 4 ,slotnum)) ,blk))))
139:
140: (defmacro putslottype (slotnum typenum blk)
141: `(rplacx (+ 7 (* 4 ,slotnum)) ,blk ,typenum))
142:
143: (defmacro getslottype (slotnum blk)
144: `(cxr (+ 7 (* 4 ,slotnum)) ,blk))
145:
146: (defmacro putppset (slotnum setname blk)
147: `(rplacx (+ 9 (* 4 ,slotnum)) ,blk ,setname))
148:
149: (defmacro getppset (slotnum blk)
150: `(cxr (+ 9 (* 4 ,slotnum)) ,blk))
151:
152: (defmacro initbothalists (inst)
153: `(rplacx 2 ,inst (ncons nil)))
154:
155: (defmacro putbothalists (alist inst)
156: `(rplacx 2 ,inst ,alist))
157:
158: (defmacro getbothalists (inst)
159: `(cxr 2 ,inst))
160:
161: (defmacro getalist (inst)
162: `(cdr (cxr 2 ,inst)))
163:
164: (defmacro putalist (alist inst)
165: `(rplacd (cxr 2 ,inst) ,alist))
166:
167: ; This must return the new special conscell.
168: (defmacro addalist (var inst)
169: `(let ((specialcell (cons ,var (punbound))))
170: (putalist (cons specialcell (getalist ,inst)) ,inst)
171: specialcell))
172:
173: ; The frozen variables are kept here instead of the regular assoc-list.
174: (defmacro getalistcp (inst)
175: `(car (cxr 2 ,inst)))
176:
177: (defmacro putalistcp (alist inst)
178: `(rplaca (cxr 2 ,inst) ,alist))
179:
180: (defmacro getabbrev (inst)
181: `(cxr 3 ,inst))
182:
183: (defmacro putabbrev (abbrev inst)
184: `(rplacx 3 ,inst ,abbrev))
185:
186: ; Put zero as the (initial) hash and format info.
187: (defmacro clearhashandformat (slotnum defblock)
188: `(rplacx (+ 6 (* 4 ,slotnum)) ,defblock 0))
189:
190: (defmacro puthashandformat (slotnum hashnum defblock)
191: `(rplacx (+ 6 (* 4 ,slotnum)) ,defblock ,hashnum))
192:
193: (defmacro gethashandformat (slotnum defblock)
194: `(cxr (+ 6 (* 4 ,slotnum)) ,defblock))
195:
196: (defmacro puthashandenforce (slotnum hashnum blk)
197: `(rplacx (+ 6 (* 4 ,slotnum)) ,blk
198: (boole 7 (boole 1 (boole 10. 127. 0)
199: (cxr (+ 6 (* 4 ,slotnum)) ,blk))
200: (boole 1 127. ,hashnum))))
201:
202: (defmacro puthashinfo (slotnum hashnum blk)
203: `(rplacx (+ 6 (* 4 ,slotnum)) ,blk
204: (boole 7 (boole 1 (boole 10. 63. 0)
205: (cxr (+ 6 (* 4 ,slotnum)) ,blk))
206: (boole 1 63. ,hashnum))))
207:
208: (defmacro addhash* (hashnum)
209: `(setq ,hashnum (boole 7 1 ,hashnum)))
210:
211: (defmacro addhash** (hashnum)
212: `(setq ,hashnum (boole 7 2 ,hashnum)))
213:
214: (defmacro addhash: (hashnum)
215: `(setq ,hashnum (boole 7 4 ,hashnum)))
216:
217: (defmacro addhash:: (hashnum)
218: `(setq ,hashnum (boole 7 8. ,hashnum)))
219:
220: (defmacro addhash> (hashnum)
221: `(setq ,hashnum (boole 7 16. ,hashnum)))
222:
223: (defmacro addhash< (hashnum)
224: `(setq ,hashnum (boole 7 32. ,hashnum)))
225:
226: (defmacro addhash*** (hashnum)
227: `(setq ,hashnum (boole 7 64. ,hashnum)))
228:
229: (defmacro addenforce (hashnum)
230: `(setq ,hashnum (boole 7 128. ,hashnum)))
231:
232: (defmacro gethashinfo (slotnum blk)
233: `(boole 1 63.
234: (cxr (+ 6 (* 4 ,slotnum)) ,blk)))
235:
236: (defmacro gethash* (hashnum)
237: `(\=& 1 (boole 1 1 ,hashnum)))
238:
239: (defmacro gethash** (hashnum)
240: `(\=& 2 (boole 1 2 ,hashnum)))
241:
242: (defmacro gethash: (hashnum)
243: `(\=& 4 (boole 1 4 ,hashnum)))
244:
245: (defmacro gethash:: (hashnum)
246: `(\=& 8. (boole 1 8. ,hashnum)))
247:
248: (defmacro gethash> (hashnum)
249: `(\=& 16. (boole 1 16. ,hashnum)))
250:
251: (defmacro gethash< (hashnum)
252: `(\=& 32. (boole 1 32. ,hashnum)))
253:
254: (defmacro gethash*** (hashnum)
255: `(\=& 64. (boole 1 64. ,hashnum)))
256:
257: (defmacro getenforce (slotnum defblock)
258: `(\=& 128. (boole 1 128. (cxr (+ 6 (* 4 ,slotnum)) ,defblock))))
259:
260: ; The format information is eventually intended for custom tailoring of
261: ; printing of structures but we've never gotten around to adding it.
262: ; The main idea is whether to print it if it contains the default
263: ; value, or whether to print to a limited depth, or whether to print
264: ; at all, etc.
265: (defmacro putformatinfo (slotnum hashnum blk)
266: `(rplacx (+ 6 (* 4 ,slotnum)) ,blk
267: (boole 7
268: (boole 1 (boole 10. 192. 0)
269: (cxr (+ 6 (* 4 ,slotnum)) ,blk))
270: (boole 1 192. (lsh ,hashnum 6)))))
271:
272: (defmacro getformatinfo (slotnum blk)
273: `(lsh (boole 1
274: (boole 10. 192. 0)
275: (cxr (+ 6 (* 4 ,slotnum)) ,blk)) -6))
276:
277: (defmacro putpred (slotnum value inst)
278: `(rplacx (+ 2 (* 4 ,slotnum)) ,inst ,value))
279:
280: (defmacro getpred (slotnum inst)
281: `(cxr (+ 2 (* 4 ,slotnum)) ,inst))
282:
283: (defmacro putslothooks (slotnum slothooklist inst)
284: `(rplacx (+ 3 (* 4 ,slotnum)) ,inst ,slothooklist))
285:
286: (defmacro getslothooks (slotnum inst)
287: `(cxr (+ 3 (* 4 ,slotnum)) ,inst))
288:
289: ; Values of slots in PEARL structures are of one of four types.
290: ; The type is stored as an atom in the "slotvaluetype"
291: ; and describes what type of value will be found in the "slotvalue".
292: ; The possible types and what is put in "slotvalue" are:
293: ; CONSTANT A constant value -- the value.
294: ; LOCAL A local variable -- the variable's alist conscell
295: ; (name . value).
296: ; ADJUNCT A constant value plus an adjunct variable
297: ; -- a conscell with CAR = the constant value
298: ; and CDR = the adjvar's conscell
299: ; (name . value).
300: ; GLOBAL A global variable -- the (atom) name of the global variable.
301: ;
302:
303: (defmacro putslotvaluetype (slotnum type inst)
304: `(rplacx (* 4 ,slotnum) ,inst ,type))
305:
306: (defmacro getslotvaluetype (slotnum inst)
307: `(cxr (* 4 ,slotnum) ,inst))
308:
309: (defmacro putslotvalue (slotnum value inst)
310: `(rplacx (1+ (* 4 ,slotnum)) ,inst ,value))
311:
312: (defmacro getslotvalue (slotnum inst)
313: `(cxr (1+ (* 4 ,slotnum)) ,inst))
314:
315: (dm equivclass (none)
316: ''*equivclass*)
317:
318: (de equivclassp (potequivclass)
319: (and (dtpr potequivclass)
320: (eq (equivclass) (car potequivclass))))
321:
322: ; returns (punbound) for unified variables instead of the equiv cons cell.
323: (defmacro getvalofequivorvar (equivorvar)
324: `(let ((val ,equivorvar))
325: (cond ((equivclassp val) (punbound))
326: ( t val))))
327:
328: (defmacro getvalue (slotnum inst)
329: `(let ((value (getslotvalue ,slotnum ,inst)))
330: (selectq (getslotvaluetype ,slotnum ,inst)
331: (CONSTANT value) ; A constant value.
332: (LOCAL (getvalofequivorvar (cdr value))) ; A local var.
333: (ADJUNCT (car value)) ; A constant plus adjvar.
334: (GLOBAL (getvalofequivorvar (eval value))) ; A global var.
335: (otherwise (punbound)))))
336:
337: ; Same as getvalue, except that if the slot has an variable in it
338: ; the atom in "var" gets set to that value.
339: (defmacro getvarandvalue (slotnum inst var)
340: `(let ((value (getslotvalue ,slotnum ,inst)))
341: (selectq (getslotvaluetype ,slotnum ,inst)
342: (CONSTANT (set ,var nil)
343: value) ; A constant value.
344: (LOCAL (set ,var value)
345: (getvalofequivorvar (cdr value))) ; A local var.
346: (ADJUNCT (set ,var (cdr value))
347: (car value)) ; A constant plus adjvar.
348: (GLOBAL (set ,var value)
349: (getvalofequivorvar (eval value))) ; A global var.
350: (otherwise (punbound)))))
351:
352: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
353: ; The next bunch of functions are for hashing and building data bases.
354: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
355:
356: ; For each data base, there are three parts (each a hunk):
357: ; the header which contains the name,
358: ; whether it is active
359: ; its parent and children and ...
360: ; the two parts of the actual data base:
361: ; DB1 for items hashed under one value.
362: ; DB2 for items hashed under two or more values.
363: ; DB1 and DB2 each contain pointers to conscells whose cars are the
364: ; atom *db* and whose cdrs are the list of items in that bucket.
365:
366: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
367: ; FIRST, the functions to access and add to a hash bucket:
368:
369: ; Items hashed under only one integer are in DB1.
370: (defmacro gethash1 (num1 db1)
371: `(cxr (\\ ,num1 *db1size*) ,db1))
372:
373: ; Add the item to the front of the appropriate hash bucket (AFTER the
374: ; special *db* conscell).
375: (defmacro puthash1 (num1 db1 item)
376: `(let ((bucket (gethash1 ,num1 ,db1)))
377: ; Avoid exact duplicates.
378: (or (memq ,item bucket)
379: (rplacd bucket (cons ,item (cdr bucket))))
380: bucket))
381:
382: ; Items hashed under either two or more integers are in DB2.
383: (defmacro gethash2 (num1 num2 db2)
384: `(cxr (\\ (+ ,num1 (* ,num2 1024.)) *db2size*)
385: ,db2))
386:
387: ; Add the item to the front of the appropriate hash bucket (AFTER the
388: ; special *db* conscell).
389: (defmacro puthash2 (num1 num2 db2 item)
390: `(let ((bucket (gethash2 ,num1 ,num2 ,db2)))
391: ; Avoid exact duplicates.
392: (or (memq ,item bucket)
393: (rplacd bucket (cons ,item (cdr bucket))))
394: bucket))
395:
396: (defmacro gethash3 (num1 num2 num3 db2)
397: `(cxr (\\ (+ ,num1
398: (* ,num2 1024.)
399: (* ,num3 1048576.)) ; = 1024 * 1024
400: *db2size*)
401: ,db2))
402:
403: ; Add the item to the front of the appropriate hash bucket (AFTER the
404: ; special *db* conscell).
405: (defmacro puthash3 (num1 num2 num3 db2 item)
406: `(let ((bucket (gethash3 ,num1 ,num2 ,num3 ,db2)))
407: ; Avoid exact duplicates.
408: (or (memq ,item bucket)
409: (rplacd bucket (cons ,item (cdr bucket))))
410: bucket))
411:
412: (defmacro gethashmulti (num1 others db2)
413: `(cxr (\\ (+ ,num1
414: (apply (function +)
415: (mapcar (function *)
416: ,others *multiproducts*)))
417: *db2size*)
418: ,db2))
419:
420: ; Add the item to the front of the appropriate hash bucket (AFTER the
421: ; special *db* conscell).
422: (defmacro puthashmulti (num1 others db2 item)
423: `(let ((bucket (gethashmulti ,num1 ,others ,db2)))
424: ; Avoid exact duplicates.
425: (or (memq ,item bucket)
426: (rplacd bucket (cons ,item (cdr bucket))))
427: bucket))
428:
429: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
430: ; Now the header info.
431:
432: (defmacro putdbname (name db)
433: `(rplacx 0 ,db ,name))
434:
435: (defmacro putdbchildren (childlist db)
436: `(rplacx 2 ,db ,childlist))
437:
438: (defmacro setdbactive (db)
439: `(rplacx 3 ,db t))
440:
441: (defmacro cleardbactive (db)
442: `(rplacx 3 ,db nil))
443:
444: (defmacro putdbparent (parent db)
445: `(rplacx 4 ,db ,parent))
446:
447: (defmacro putdb1 (db1 db)
448: `(rplacx 5 ,db ,db1))
449:
450: (defmacro putdb2 (db2 db)
451: `(rplacx 6 ,db ,db2))
452:
453: (defmacro getdbname (db)
454: `(cxr 0 ,db))
455:
456: (defmacro getdbchildren (db)
457: `(cxr 2 ,db))
458:
459: (defmacro getdbactive (db)
460: `(cxr 3 ,db))
461:
462: (defmacro getdbparent (db)
463: `(cxr 4 ,db))
464:
465: (defmacro getdb1 (db)
466: `(cxr 5 ,db))
467:
468: (defmacro getdb2 (db)
469: `(cxr 6 ,db))
470:
471: ; The following predicates do the best we can to check for the type of
472: ; object by checking what we hope are reasonably unique arrangements
473: ; of values. In the case of definitions, instances, databases and
474: ; symbols, a tag is put in the hunk saying what it is. This is
475: ; assumed to be enough.
476:
477: (de streamp (potstream)
478: (and (dtpr potstream)
479: (eq '*stream* (car potstream))))
480:
481: (de databasep (potdb)
482: (and (hunkp potdb)
483: (let ((tag (gettypetag potdb)))
484: (or (eq tag '*pearldb*)
485: (eq tag '*pearlinactivedb*)))))
486:
487: (de blockp (potblock)
488: (let* ((name (car potblock))
489: (blockname (blockatom name)))
490: (and (boundp blockname)
491: (eq name
492: (car (eval blockname)))
493: (eq potblock
494: (eval blockname)))))
495:
496: (de definitionp (potdef)
497: (and (hunkp potdef)
498: (eq '*pearldef* (gettypetag potdef))))
499:
500: (de psymbolp (potsymbol)
501: (and (hunkp potsymbol)
502: (eq '*pearlsymbol* (gettypetag potsymbol))))
503:
504: (de structurep (potstruct)
505: (and (hunkp potstruct)
506: (eq '*pearlinst* (gettypetag potstruct))))
507:
508: (de symbolnamep (potname)
509: (let ((symname (symatom potname)))
510: (and (boundp symname)
511: (psymbolp (eval symname)))))
512:
513: (de structurenamep (potname)
514: (let ((defname (defatom potname)))
515: (and (boundp defname)
516: (definitionp (eval defname)))))
517:
518: ; Determine the print name of an arbitrary object.
519: (de pname (item)
520: (cond ((definitionp item) (getpname item))
521: ((structurep item) (getpname (getdefinition item)))
522: ((psymbolp item) (getsymbolpname item))
523: ((databasep item) (getdbname item))
524: ((atom item) item)
525: ((streamp item) (msg t "PNAME: streams do not have pnames: "
526: item t))
527: ( t (msg t "PNAME: " item " does not have a printname"))))
528:
529: ; For loop patterned after (do for ...) in UCI Lisp, except that an
530: ; initial value is required instead of RPT (and there is no DO).
531: (defmacro for (val init final &rest body)
532: `((lambda (,val pforlim)
533: (prog (pforval)
534: pforlab
535: (and (>& ,val pforlim)
536: (return pforval))
537: (setq pforval (progn .,body))
538: (setq ,val (1+ ,val))
539: (go pforlab)))
540: ,init
541: ,final))
542:
543: ; While loop patterned after (do while ...) in UCI Lisp.
544: (defmacro while (val &rest body)
545: `(prog (pwhval)
546: pwhlab
547: (and (not ,val)
548: (return pwhval))
549: (setq pwhval (progn .,body))
550: (go pwhlab)))
551:
552: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.