![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to create.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl|
Return to create.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; create.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Functions for creating, copying, and merging structures.
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: ; Create a new structure of one of the five types:
9: ; BASE: build a new structure with all new slots.
10: ; EXPANDED: build new slots in addition to slots inherited from
11: ; a BASE or EXPANDED structure.
12: ; INDIVIDUAL: create an instance of a BASE or EXPANDED structure,
13: ; filling in slots or inheriting defaults from above.
14: ; PATTERN: create an instance of a BASE or EXPANDED structure but
15: ; fill in unspecified slots with ?*ANY*.
16: ; FUNCTION: build a new structure with slots describing the
17: ; arguments to the function.
18:
19: ; Generalized syntax for this function is:
20: ;
21: ; (CREATE <StructureType> <ExpandedorBaseName> <NewItemName>
22: ; [{HashingInfo} <OldSlotName> {{{:=} <SlotValue>} | ^}
23: ; { : <Variable> }
24: ; {<ListOfRestrictionStructureOrSlotIfNames>} ]
25: ; . . . . . . .
26: ; [{HashingInfo} <NewSlotName> <Type> {{{:=} <SlotValue>} | ^}
27: ; { : <Variable> }
28: ; {<ListOfRestrictionStructureOrSlotIfNames>} ] )
29:
30: ; BASE structures have no <ExpandedorBaseName> and only new slots.
31: ; EXPANDED structures should have at least one new slot and inherit
32: ; default values from the <ExpandedorBaseName>.
33: ; INDIVIDUAL structures have only old slots and inherit default values from
34: ; the <ExpandedorBaseName>; if the <NewItemName> occurs, the atom
35: ; <NewItemName> is set to point to the internal form which is also
36: ; returned as the value of CREATE.
37: ; PATTERN structures have only old slots and all unspecified slots are
38: ; set to ?*ANY* rather than inheriting a default.
39: ; FUNCTION structures have no <ExpandedOrBaseName> and only new slots.
40: ; They are interpreted as functions to be run rather than structures
41: ; to be accessed when they are MATCHed, FETCHed or PATHed.
42: ;
43: ; The structure created is always stored in the SPECIAL variable *LASTCREATED*
44: ; in addition to the <NewItemName> if specified and the atom formed
45: ; by prepending a 'd:' to the front of the <ExpandedOrBaseName>.
46: ;
47: ; If the SlotValue for a slot in a BASE or EXPANDED structure is preceded
48: ; by a :=, then the slot is filled with this value but it is not
49: ; used as the default for this slot in future INDIVIDUALS and
50: ; EXPANDEDS.
51: ; If the SlotValue is not preceded by a :=, then the value represents a
52: ; default to be inherited by INDIVIDUALs and new EXPANDEDS.
53:
54: ; This just sets the two atoms *toplevelp* and *currentcreatetype*
55: ; and calls the real workhorse "insidecreate".
56: (df create (l)
57: (setq *toplevelp* t)
58: (setq *currentcreatetype* (car l))
59: (apply (function insidecreate) l))
60:
61: ; Pick apart the atoms before the slots, handle them and pass the
62: ; rest on to the appropriate version of create XXX.
63: (df insidecreate (l)
64: (let ((type (car l))
65: (abbrev (cond (*toplevelp* '*buildabbrev*)
66: ( t nil)))
67: (name1 (cadr l))
68: (name2 (caddr l))
69: (name3 (cadddr l))
70: slots)
71: (cond ((reallitatom name2)
72: (setq abbrev name2)
73: (setq slots (cdddr l))
74: (cond ((reallitatom name3)
75: (setq abbrev name3)
76: (setq slots (cddddr l)))
77: ( t (setq name3 name2))))
78: ( t (setq name3 (setq name2 name1))
79: (setq slots (cddr l))))
80: (and (memq type '(ind individual pat pattern))
81: (eq name1 name3)
82: (setq name3 '*lastcreated*))
83: (set name3
84: (setq *lastcreated*
85: (selectq type
86: ((individual ind)
87: (createindividual name1 abbrev slots))
88: (base
89: (createbase name1 abbrev slots))
90: ((expanded exp)
91: (createexpanded name1 name2 abbrev slots))
92: ((pattern pat)
93: (createpattern name1 abbrev slots))
94: ((function fn)
95: (createfunction name1 abbrev slots))
96: (otherwise (msg t "CREATE: Illegal selector: " type
97: " in created structure: " l t)
98: (pearlbreak)))))))
99:
100: ; Create a new structure and insert it in the database.
101: (defmacro dbcreate (&rest rest)
102: `(insertdb (create .,rest)))
103:
104: (defmacro cb (&rest rest)
105: `(create base .,rest))
106:
107: (defmacro ci (&rest rest)
108: `(create individual .,rest))
109:
110: (defmacro ce (&rest rest)
111: `(create expanded .,rest))
112:
113: (defmacro cp (&rest rest)
114: `(create pattern .,rest))
115:
116: (defmacro cf (&rest rest)
117: `(create function .,rest))
118:
119: (defmacro base (&rest rest)
120: `(create base .,rest))
121:
122: (defmacro ind (&rest rest)
123: `(create individual .,rest))
124:
125: (defmacro individual (&rest rest)
126: `(create individual .,rest))
127:
128: (defmacro pexp (&rest rest)
129: `(create expanded .,rest))
130:
131: (defmacro expanded (&rest rest)
132: `(create expanded .,rest))
133:
134: (defmacro pat (&rest rest)
135: `(create pattern .,rest))
136:
137: (defmacro pattern (&rest rest)
138: `(create pattern .,rest))
139:
140: (defmacro fn (&rest rest)
141: `(create function .,rest))
142:
143: (defmacro pfunction (&rest rest)
144: `(create function .,rest))
145:
146: ; Put a *VAR* variable in the structure's assoc-list and return the cons-cell.
147: (defmacro installvar (varname)
148: `(cond ((eq '*any* ,varname) *any*conscell*)
149: ; else, if there, return it.
150: ((assq ,varname (getalist *currenttopcreated*)))
151: ; else, add it (which also returns the special conscell).
152: ( t (addalist ,varname *currenttopcreated*))))
153:
154: ; Install an adjunct variable in the slot.
155: (defmacro installadjunct (adjunctvar)
156: `(let (var)
157: (cond ((dtpr ,adjunctvar)
158: (setq var (cadr ,adjunctvar))
159: (selectq (car ,adjunctvar)
160: (*var* (installvar var))
161: (*global* var)
162: (otherwise
163: (msg t "CREATE: no adjunct variable given after colon "
164: "-- rest of slot is: " ,adjunctvar slot t)
165: (pearlbreak))))
166: ( t (msg t "CREATE: no adjunct variable given after colon. "
167: "Rest of slot is: " ,adjunctvar slot t)
168: (pearlbreak)))))
169:
170: (dm handlepossibleadjunctvar (none) ; but assumes SLOT, SLOTVALUE, & VALUETYPE.
171: '(let ((adjunctvar (car slot)))
172: (and (eq adjunctvar ':)
173: (cond ((neq valuetype 'CONSTANT)
174: (msg t "CREATE: Adjunct variables not allowed in "
175: "slots whose values are also variables." t)
176: (pearlbreak))
177: ( t (setq slot (cdr slot)) ; throw away ":".
178: (setq adjunctvar (pop slot))
179: (setq valuetype 'ADJUNCT)
180: (setq slotvalue (cons slotvalue
181: (installadjunct adjunctvar))))))))
182:
183: ; Ensure that value is of type TYPENUM (used after ! or on value in atom
184: ; where setof value expected). Value returned (t / never) is used
185: ; only in evaluating atom. If error, doesn't return.
186: (de enforcetype (value typenum)
187: (or (selectq typenum
188: (0 (structurep value))
189: (1 (psymbolp value))
190: (2 (numberp value))
191: (3 (not (reallitatom value)))
192: (otherwise
193: (apply (function and)
194: (mapcar (funl (singlevalue)
195: (enforcetype singlevalue
196: (- typenum 4)))
197: value))))
198: (progn (msg t "CREATE: Value after ! or bound to atom in SETOF "
199: "slot is of wrong type. Value is: " value t)
200: (pearlbreak))))
201:
202: ; Get the value for a slot.
203: ; If preceded by an ! then it is already in internal form but verify this.
204: ; If is preceded by a $ then it should be evaluated before continuing
205: ; processing (on its value).
206: (dm constructvalue (none)
207: '(let ((typenum (getslottype slotnum defblock))
208: (ppset (getppset slotnum defblock)))
209: (selectq (car slot)
210: (\! (setq slot (cdr slot))
211: (setq newvalue (eval (pop slot)))
212: (enforcetype newvalue typenum)
213: (setq valuetype 'CONSTANT)
214: (setq slotvalue newvalue))
215: (\$ (setq slot (cdr slot))
216: (setq newvalue (eval (pop slot)))
217: (setq valuetype 'CONSTANT)
218: (setq slotvalue (buildvalue newvalue typenum ppset)))
219: (otherwise
220: (cond ((and (dtpr (car slot))
221: (eq (caar slot) '*var*))
222: (setq valuetype 'LOCAL)
223: (setq newvalue (cadr (pop slot)))
224: (setq slotvalue (installvar newvalue)))
225: ((and (dtpr (car slot))
226: (eq (caar slot) '*global*))
227: (setq valuetype 'GLOBAL)
228: (setq slotvalue (cadr (pop slot))))
229: ( t (setq valuetype 'CONSTANT)
230: (setq slotvalue
231: (buildvalue (pop slot) typenum ppset))))))))
232:
233: ; Generate the default value for slots of the given type.
234: (defmacro defaultfortype (typenum)
235: `(selectq ,typenum
236: (0 (eval (instatom 'nilstruct)))
237: (1 (eval (symatom 'nilsym)))
238: (2 0)
239: (3 nil)))
240:
241: ; Look at the ISA to find the default value, or the else use
242: ; the default default for that type.
243: (defmacro inheritvalue (structdef)
244: `(let ((isa ,structdef))
245: (cond ((or (null isa)
246: (not (getenforce slotnum isa)))
247: (setq slotvalue (defaultfortype (getslottype slotnum defblock)))
248: (setq valuetype 'CONSTANT))
249: ( t (let ((default (getdefaultinst isa)))
250: (setq slotvalue (getslotvalue slotnum default))
251: (setq valuetype (getslotvaluetype slotnum default)))))))
252:
253: ; Look for predicates and hooks. Use tconc to keep in order.
254: (dm handlepredicatesandhooks (none)
255: '(progn
256: (setq predlist (ncons nil))
257: (setq slothooklist (ncons nil))
258: (while (setq fcn (pop slot))
259: (cond ((atom fcn)
260: (cond ((eq fcn 'instead)
261: ; Don't inherit hooks.
262: (putpred slotnum nil valblock))
263: ((memq fcn '(if hook))
264: ; A hook follows.
265: (tconc slothooklist (cons (pop slot) (pop slot))))
266: ; Structure predicate.
267: ((structurenamep fcn)
268: (tconc predlist (eval (defatom fcn))))
269: ; Otherwise, a predicate name.
270: ( t (tconc predlist fcn))))
271: ; Otherwise an s-expression predicate.
272: ( t (tconc predlist fcn))))
273: (putpred slotnum
274: (nconc (car predlist) (getpred slotnum valblock))
275: valblock)
276: (putslothooks slotnum
277: (nconc (car slothooklist) (getslothooks slotnum valblock))
278: valblock)))
279:
280: ; Build a new slot in the current structure.
281: (dm buildslot (none)
282: '(progn
283: (setq slotname (pop slot))
284: (clearhashandformat slotnum defblock)
285: ; To gather hashing and enforce information before installing in defblock.
286: (setq hashcollect 0)
287: (setq reqstruct nil)
288:
289: ; Check for hashing marks first.
290: (while (selectq slotname
291: ; First starred slot used for > hashing if no & present.
292: (* (and (\=& 0 first*edslot)
293: (setq first*edslot (minus slotnum)))
294: (addhash* hashcollect))
295: (** (addhash** hashcollect))
296: (*** (addhash*** hashcollect))
297: (& (cond ((not (\=& 0 hashalias))
298: (msg t "CREATE: Only 1 hash alias (&) or "
299: "selected slot (^) allowed in: "
300: newname t)
301: t)
302: ( t (setq hashalias slotnum))))
303: (^ (cond ((not (\=& 0 hashalias))
304: (msg t "CREATE: Only 1 hash alias (&) or "
305: "selected slot (^) allowed in: "
306: newname t)
307: t)
308: ( t (setq hashalias (minus slotnum)))))
309: (&& (cond ((not (\=& 0 hashfocus))
310: (msg t "CREATE: Only 1 hash focus (&&) "
311: "allowed in: " newname t)
312: t)
313: ( t (setq reqstruct t)
314: (setq hashfocus slotnum))))
315: (: (addhash: hashcollect))
316: (:: (addhash:: hashcollect))
317: (> (addhash> hashcollect))
318: (< (addhash< hashcollect)))
319: (setq slotname (pop slot)))
320: (and (\=& 0 (length slot))
321: (progn (msg t "CREATE: Missing slot name and/or type in slot number "
322: slotnum " of structure: " newname t)
323: (pearlbreak)))
324:
325: ; Slotname now holds the slotname. Should be checked for duplicates!!
326: (putslotname slotnum (ncons slotname) defblock)
327:
328: ; Now look for the type.
329: (setq typenum 0)
330: (setq slottype (pop slot))
331: (while (selectq slottype
332: (struct (setq reqstruct nil)
333: nil) ; i. e., add 0 to TYPENUM.
334: (symbol (setq typenum (1+ typenum)) nil)
335: (int (setq typenum (+ 2 typenum)) nil)
336: (lisp (cond ((not (\=& 0 typenum))
337: (msg t "CREATE: <setof lisp> not allowed. "
338: "Type changed to <lisp> in slot "
339: slotname " of " newname t)
340: (setq typenum 3) nil)
341: ((not (\=& 0 hashcollect))
342: (setq hashcollect 0)
343: (msg t "CREATE: No hashing allowed on "
344: "<lisp> slots in slot " slotname
345: " of " newname t)))
346: (setq typenum 3) nil)
347: (setof (setq typenum (+ 4 typenum)) t)
348: (otherwise
349: ; Either an ordinal type ==> integer,
350: ; or a structure name ==> struct, or an error.
351: (cond ((memq slottype *ordinalnames*)
352: (setq typenum (+ 2 typenum)) nil)
353: ((structurenamep slottype)
354: (setq reqstruct nil)
355: nil) ; i. e., add 0 to TYPENUM.
356: ( t (msg t "CREATE: Illegal type: " slottype
357: " in slot: " slotname " of " newname t)
358: nil))))
359: (setq slottype (pop slot)))
360: (and reqstruct
361: (progn (msg t "CREATE: && hashing only allowed on STRUCT slots."
362: t " Bad slot is called " slotname
363: " and is of type " slottype t)
364: (pearlbreak)))
365: ; Save the last word of the type which is possibly a structure or
366: ; ordinal type name for future use.
367: (putppset slotnum slottype defblock)
368: (putslottype slotnum typenum defblock)
369:
370: ; Next, look for a value, or ^ to inherit from above;
371: ; these may be preceded by := or == to determine future
372: ; "enforcing" (should be less strong term) of this default.
373: (setq slotvalue nil)
374: (setq valuetype nil)
375: (setq enforce (pop slot))
376: (selectq enforce
377: (:\= (cond ((eq (car slot) '^)
378: (setq slot (cdr slot))
379: (inheritvalue nil))
380: ( t (constructvalue))))
381: (\=\= (addenforce hashcollect)
382: (cond ((eq (car slot) '^)
383: (setq slot (cdr slot))
384: (inheritvalue nil))
385: ( t (constructvalue))))
386: ((^ nil)
387: (addenforce hashcollect)
388: (inheritvalue nil))
389: (otherwise (push enforce slot)
390: (addenforce hashcollect)
391: (constructvalue)))
392:
393: (handlepossibleadjunctvar)
394:
395: ; Hash, enforce, slotvalue and valuetype can now be installed.
396: (puthashandenforce slotnum hashcollect defblock)
397: (putslotvaluetype slotnum valuetype valblock)
398: (putslotvalue slotnum slotvalue valblock)
399:
400: (handlepredicatesandhooks)))
401:
402: ; Create a new structure of type BASE: a structure with ALL NEW slots.
403: (de createbase (newname abbrev slots)
404: (and (eq newname 'nilstruct)
405: (boundp (defatom 'nilstruct))
406: (progn (msg t "CREATE BASE: Cannot redefine nilstruct." t)
407: (pearlbreak)))
408: (and (structurenamep newname)
409: *warn*
410: (msg t "CREATE BASE: Warning: Creating a new definition"
411: " of an existing structure: " newname t))
412: (prog (defblock slotname slottype enforce fcn ppset slot length isa
413: typenum valblock predlist slothooklist
414: first*edslot basehooks basehookbefore newvalue reqstruct
415: hashalias hashfocus hashcollect slotvalue valuetype)
416:
417: ; Process base hooks if the first "slot" is named "if" or "hook".
418: (cond ((memq (caar slots) '(if hook))
419: (setq basehookbefore (cdr (pop slots)))
420: (setq basehooks (ncons nil))
421:
422: ; Use tconc to preserve order.
423: (while basehookbefore ; is not NIL
424: (tconc basehooks (cons (pop basehookbefore)
425: (pop basehookbefore))))
426: (setq basehooks (car basehooks)))
427: ( t (setq basehooks nil)))
428:
429: ; Allocate hunks for definition and default instance (valblock)
430: ; based on number of slots.
431: (setq defblock (allocdef (setq length (length slots))))
432: (setq valblock (allocval length))
433: (puttypetag '*pearldef* defblock)
434: (puttypetag '*pearlinst* valblock)
435: (cond (*toplevelp* (setq *currenttopcreated* valblock)
436: (setq *currentpearlstructure* valblock)
437: (initbothalists valblock)
438: (setq *currenttopalists* (getbothalists valblock))
439: ; Include the current environment in
440: ; the variable assoc-list.
441: (and *blockstack*
442: (putalist (cdar *blockstack*) valblock))
443: (setq *toplevelp* nil))
444: ( t (putbothalists *currenttopalists* valblock)))
445:
446: (putdef defblock valblock)
447: (putdefaultinst valblock defblock)
448: (set (instatom newname) valblock)
449: (set (defatom newname) defblock)
450: (and abbrev
451: (cond ((eq abbrev '*buildabbrev*)
452: (putabbrev (instatom newname) valblock))
453: ( t (putabbrev abbrev valblock))))
454: (putuniquenum (newnum) defblock)
455: (putstructlength length defblock)
456: (putisa nil defblock)
457: (putexpansionlist nil defblock)
458: (putbasehooks basehooks defblock)
459: (putpname newname defblock)
460:
461: (setq hashalias 0)
462: (setq hashfocus 0)
463: (setq first*edslot 0)
464: (for slotnum 1 length
465: (setq slot (pop slots))
466: (buildslot))
467:
468: (cond ((\=& 0 hashalias) (puthashalias first*edslot defblock))
469: ( t (puthashalias hashalias defblock)))
470: (puthashfocus hashfocus defblock)
471:
472: (return valblock)))
473:
474: ; Create a new individual just for this slot.
475: (defmacro buildstructvalue (struct)
476: `(cond ((and (atom ,struct) ; if an atom
477: (boundp ,struct) ; and bound
478: (structurep (eval ,struct))) ; to a structure,
479: (eval ,struct)) ; evaluate it.
480: ; Otherwise, recursively call create.
481: ( t (selectq (car ,struct)
482: ; New create type in slot.
483: ((ind individual pat pattern fn function
484: base exp expanded)
485: (let ((*currentcreatetype* (car ,struct)))
486: (apply (function insidecreate) ,struct)))
487: (otherwise
488: ; Otherwise, use current create type.
489: (apply (function insidecreate)
490: (cons *currentcreatetype* ,struct)))))))
491:
492: ; Get a pointer to the symbol.
493: (defmacro buildsymbolvalue (sym)
494: `(cond ((symbolnamep ,sym) (eval (symatom ,sym)))
495: ; If not a symbol name, then ...
496: ((and (atom ,sym) ; if an atom
497: (boundp ,sym) ; and bound
498: (psymbolp (eval ,sym))) ; to a symbol,
499: (eval ,sym)) ; evaluate it.
500: ; Otherwise, error.
501: ( t (msg t "CREATE: " ,sym " is used in a slot of type SYMBOL but "
502: "neither is the name of a symbol nor evaluates to one." t)
503: (pearlbreak))))
504:
505: ; Get an integer using PPSET if not an integer.
506: (defmacro buildintvalue (intval bppset)
507: `(let (assocval)
508: (cond ((numberp ,intval) ,intval)
509: ; Ordinal type given for ppset.
510: ((and ,bppset ; is not NIL.
511: (setq assocval (assq ,intval (eval (ordatom ,bppset)))))
512: (cdr assocval))
513: ; Some other atom which is bound to an integer.
514: ((and (atom ,intval)
515: (boundp ,intval)
516: (numberp (eval ,intval)))
517: (eval ,intval))
518: ; Otherwise, error.
519: ( t (msg t "CREATE: Unbound atom or non-integer value: "
520: ,intval " in integer slot." t)
521: (pearlbreak)))))
522:
523: ; Construct a new value of the specified type using the pplist if necessary
524: (de buildvalue (value typenum ppset)
525: (selectq typenum
526: (0 (buildstructvalue value))
527: (1 (buildsymbolvalue value))
528: (2 (buildintvalue value ppset))
529: (3 value) ; i.e., could be anything they want.
530: (otherwise
531: (cond ((and (atom value)
532: (boundp value)
533: (enforcetype (eval value) typenum))
534: (eval value))
535: ( t (mapcar (funl (singlevalue)
536: (buildvalue singlevalue
537: (- typenum 4) ppset))
538: value))))))
539:
540: ; Return the position number of SLOTNAME in structure DEFBLOCK.
541: (defmacro slotnametonumber (slotname defblock)
542: `(progn
543: (setq slotlocation 0)
544: (for slotnum 1 (getstructlength ,defblock)
545: (and (memq ,slotname (getslotname slotnum ,defblock))
546: (setq slotlocation slotnum)))
547: slotlocation))
548:
549: ; Find the slotname in SLOT, put it in SLOTNAME, and find its SLOTNUM.
550: (dm findslotnum (none)
551: '(progn
552: (setq slotname slot)
553: (while (memq (car slotname) '(* ** *** & ^ && : :: < > +))
554: (setq slotname (cdr slotname)))
555: (cond ((and (dtpr (cadr slotname))
556: (eq '*slot* (car (cadr slotname))))
557: (setq slotname (cadr (cadr slotname)))
558: (minus (slotnametonumber slotname olddefblock)))
559: ( t (setq slotname (car slotname))
560: (slotnametonumber slotname olddefblock)))))
561:
562: ; Look up through ISA links and add name to Expansion Lists.
563: ; Assumes PROG vars NEWNAME and OLDDEFBLOCK.
564: (dm addtoexpansionlists (none)
565: '(progn
566: (setq isa olddefblock)
567: (while isa ; is not null
568: (putexpansionlist (cons defblock (getexpansionlist isa)) isa)
569: (setq isa (getisa isa)))))
570:
571: ; Copy definition for one slot.
572: (dm copyslice (none)
573: '(progn
574: (putslottype slotnum (getslottype slotnum olddefblock) defblock)
575: (putslotname slotnum (getslotname slotnum olddefblock) defblock)
576: (putppset slotnum (getppset slotnum olddefblock) defblock)
577: (puthashandformat slotnum (gethashandformat slotnum olddefblock) defblock)))
578:
579: ; Copy default values, predicates, and hooks for one slot.
580: (dm copyslot (none)
581: '(progn
582: (putslotvaluetype slotnum (getslotvaluetype slotnum oldvalblock) valblock)
583: (putslotvalue slotnum (getslotvalue slotnum oldvalblock) valblock)
584: (putpred slotnum (getpred slotnum oldvalblock) valblock)
585: (putslothooks slotnum (getslothooks slotnum oldvalblock) valblock)))
586:
587: ; Copy an old slot from an ISA into the current structure.
588: (dm fillbaseslot (none)
589: '(progn
590: (cond ((<& slotnum 0)
591: (setq slotnum (minus slotnum))
592: (setq newslotnamep t))
593: ( t (setq newslotnamep nil)))
594:
595: ; First check for changed hashing.
596: (setq slotname (pop slot))
597: (clearhashandformat slotnum defblock)
598: (setq hashcollect 0)
599: (while (selectq slotname
600: (* (and (\=& 0 first*edslot)
601: (setq first*edslot (minus slotnum)))
602: (addhash* hashcollect) t)
603: (** (addhash** hashcollect) t)
604: (*** (addhash*** hashcollect) t)
605: (& (cond ((not (\=& 0 hashalias))
606: (msg t "CREATE EXPANDED: Only 1 hash alias "
607: "(&) or selected slot (^) allowed in: "
608: newname t)
609: t)
610: ( t (setq hashalias slotnum))))
611: (^ (cond ((not (\=& 0 hashalias))
612: (msg t "CREATE EXPANDED: Only 1 hash alias "
613: "(&) or selected slot (^) allowed in: "
614: newname t)
615: t)
616: ( t (setq hashalias (minus slotnum)))))
617: (&& (cond ((not (\=& 0 hashfocus))
618: (msg t "CREATE EXPANDED: Only 1 hash focus "
619: "(&&) allowed in: " newname t)
620: t)
621: ( t (setq hashfocus slotnum))))
622: (: (addhash: hashcollect) t)
623: (:: (addhash:: hashcollect) t)
624: (> (addhash> hashcollect) t)
625: (< (addhash< hashcollect) t)
626: (+ (setq hashcollect (gethashinfo slotnum olddefblock))
627: t))
628: (setq slotname (pop slot)))
629:
630: (and (\=& 0 (length slot))
631: (progn (msg t "CREATE EXPANDED: Missing slot name and/or value in: "
632: newname t)
633: (pearlbreak)))
634:
635: (and newslotnamep
636: (pop slot)
637: (addslotname slotnum slotname defblock))
638:
639: ; Next, check for value or ^, possibly preceded by := or ==.
640: (setq enforce (pop slot))
641: (selectq enforce
642: (:\= (cond ((eq (car slot) '^) ; a waste.
643: (setq slot (cdr slot))
644: (inheritvalue (getisa defblock)))
645: ( t (constructvalue))))
646: (\=\= (addenforce hashcollect)
647: (cond ((eq (car slot) '^)
648: (setq slot (cdr slot))
649: (inheritvalue (getisa defblock)))
650: ( t (constructvalue))))
651: ((^ nil) (addenforce hashcollect)
652: (inheritvalue (getisa defblock)))
653: (otherwise (push enforce slot)
654: (addenforce hashcollect)
655: (constructvalue)))
656:
657: (handlepossibleadjunctvar)
658:
659: ; Hash, enforce, slotvalue and valuetype can now be installed.
660: (puthashandenforce slotnum hashcollect defblock)
661: (putslotvaluetype slotnum valuetype valblock)
662: (putslotvalue slotnum slotvalue valblock)
663:
664: (handlepredicatesandhooks)))
665:
666: ; Create a new structure of type EXPANDED: build new slots in
667: ; addition to slots inherited from a BASE or EXPANDED structure.
668: (de createexpanded (basename newname abbrev slots)
669: (and (eq newname 'nilstruct)
670: (progn (msg t "CREATE EXPANDED: Cannot redefine nilstruct." t)
671: (pearlbreak)))
672: (and (structurenamep newname)
673: *warn*
674: (msg t "CREATE EXPANDED: Warning: Creating a new definition of "
675: "an existing structure: " newname t))
676: (or (structurenamep basename)
677: (progn (msg t "CREATE EXPANDED: " basename
678: " is not the name of a previously declared structure." t
679: " New name is " newname ". Slots are: " slots t)
680: (pearlbreak)))
681: (prog (defblock valblock oldvalblock olddefblock slotname
682: slottype enforce slot oldlength length slotnum
683: typenum slotnumlist beginslots predlist slothooklist
684: fcn ppset isa first*edslot slotlocation basehooks
685: basehookbefore newvalue result item reqstruct
686: newslotnamep hashalias hashfocus hashcollect
687: slotvalue valuetype)
688: (setq olddefblock (eval (defatom basename)))
689: (setq oldlength (getstructlength olddefblock))
690:
691: ; Handle base hooks, if first "slot" is called "if" or "hook".
692: (cond ((memq (caar slots) '(if hook))
693: (setq basehookbefore (cdr (pop slots)))
694: (setq basehooks (ncons nil))
695: (while basehookbefore ; is not NIL
696: (tconc basehooks (cons (pop basehookbefore)
697: (pop basehookbefore))))
698: (setq basehooks (nconc (car basehooks)
699: (getbasehooks olddefblock))))
700: ( t (setq basehooks (getbasehooks olddefblock))))
701:
702: ; Create a list of slotnumbers for the slotnames in SLOTS,
703: ; meanwhile also determining the LENGTH.
704: (setq beginslots slots) ; save to process again.
705: (setq slotnumlist (ncons nil))
706: (setq length oldlength)
707: (while (setq slot (pop slots))
708: (cond ((not (\=& 0 (setq slotnum (findslotnum))))
709: ; Old slot name or new name for old slot (negative).
710: (tconc slotnumlist slotnum))
711: ; Otherwise, new slot name: increase length.
712: ( t (setq length (1+ length))
713: (tconc slotnumlist length))))
714: (setq slotnumlist (car slotnumlist))
715: (setq slots beginslots)
716:
717: ; Allocate new hunks.
718: (setq defblock (allocdef length))
719: (setq valblock (allocval length))
720: (puttypetag '*pearldef* defblock)
721: (puttypetag '*pearlinst* valblock)
722: (cond (*toplevelp* (setq *currenttopcreated* valblock)
723: (setq *currentpearlstructure* valblock)
724: (initbothalists valblock)
725: (setq *currenttopalists* (getbothalists valblock))
726: ; Include the current environment in
727: ; the variable assoc-list.
728: (and *blockstack*
729: (putalist (cdar *blockstack*) valblock))
730: (setq *toplevelp* nil))
731: ( t (putbothalists *currenttopalists* valblock)))
732:
733: (putdef defblock valblock)
734: (putdefaultinst valblock defblock)
735: (set (instatom newname) valblock)
736: (set (defatom newname) defblock)
737: (and abbrev
738: (cond ((eq abbrev '*buildabbrev*)
739: (putabbrev (instatom newname) valblock))
740: ( t (putabbrev abbrev valblock))))
741: (putuniquenum (newnum) defblock)
742: (putstructlength length defblock)
743:
744: ; Set up the hierarchy of ISAs.
745: (putisa olddefblock defblock)
746: (putexpansionlist nil defblock)
747: (addtoexpansionlists)
748:
749: (putbasehooks basehooks defblock)
750: (putpname newname defblock)
751: (setq oldvalblock (getdefaultinst olddefblock))
752:
753: ; (puthashalias 0 defblock)
754: (setq hashalias 0)
755: (setq hashfocus 0)
756: (or (<& (setq first*edslot (gethashalias olddefblock)) 0)
757: (setq first*edslot 0))
758: ; Copy old slots in first.
759: (for slotnum 1 oldlength
760: (copyslice)
761: (copyslot olddefblock))
762: ; Run base hooks attached to the base we are expanding.
763: (and (getbasehooks olddefblock)
764: (setq item valblock)
765: (checkrunhandlebasehooks1 '<expanded *runexpandedhooks*)
766: (setq valblock item))
767:
768: ; For each slot, if it's new, build a new slot;
769: ; if it's old, fill it in differently.
770: (while (setq slot (pop slots))
771: (setq slotnum (pop slotnumlist))
772: (cond ((>& slotnum oldlength)
773: (buildslot))
774: ( t (fillbaseslot))))
775: (cond ((\=& 0 hashalias) (puthashalias first*edslot defblock))
776: ( t (puthashalias hashalias defblock)))
777: (cond ((\=& 0 hashfocus) (puthashfocus (gethashfocus olddefblock)
778: defblock))
779: ( t (puthashfocus hashfocus defblock)))
780:
781: ; Run base hooks attached to the base we are expanding.
782: (and (getbasehooks olddefblock)
783: (setq item valblock)
784: (checkrunhandlebasehooks1 '>expanded *runexpandedhooks*)
785: (setq valblock item))
786: (return valblock)))
787:
788: ; Fill in an individual slot with the value specified. If the value is
789: ; prefaced by the character "^" then the value should be inherited from
790: ; above but there are still predicates and/or IFs to process.
791: (dm fillindivslot (none)
792: '(progn
793: (setq slotname (pop slot))
794: ; Find slot number.
795: (and (\=& 0 (setq slotnum (slotnametonumber slotname defblock)))
796: (progn (msg t "CREATE: Undefined slot: " slotname
797: ", in individual or pattern: " basename)
798: (pearlbreak)))
799: (cond ((\=& 0 (length slot))
800: (msg t "Missing value in: CREATE INDIVIDUAL (or PATTERN) "
801: basename ". Remaining slots are: " slots t)
802: (pearlbreak))
803: ; If ^, inherit.
804: ((eq (car slot) '^)
805: (setq slot (cdr slot))
806: (inheritvalue defblock))
807: ; Otherwise, construct a new value and insert.
808: ( t (constructvalue)))
809:
810: (handlepossibleadjunctvar)
811:
812: ; Store type and value.
813: (putslotvaluetype slotnum valuetype valblock)
814: (putslotvalue slotnum slotvalue valblock)
815:
816: (handlepredicatesandhooks)))
817:
818: ; Create a new structure of type INDIVIDUAL: an instance of a
819: ; BASE or EXPANDED structure. Slots are either filled explicitly
820: ; or they inherit defaults from above.
821: (de createindividual (basename abbrev slots)
822: (or (structurenamep basename)
823: (progn (msg t "CREATE INDIVIDUAL: " basename
824: " is not the name of a previously declared structure."
825: t " Slots are: " slots t)
826: (pearlbreak)))
827: (prog (defblock valblock slotname length slotnum oldvalblock
828: isa typenum ppset slot predlist slothooklist fcn
829: slotlocation newvalue result item
830: slotvalue valuetype)
831:
832: ; Find definition and allocate hunk for individual.
833: (setq defblock (eval (defatom basename)))
834: (setq valblock (allocval (setq length (getstructlength defblock))))
835: (puttypetag '*pearlinst* valblock)
836: (cond (*toplevelp* (setq *currenttopcreated* valblock)
837: (setq *currentpearlstructure* valblock)
838: (initbothalists valblock)
839: (setq *currenttopalists* (getbothalists valblock))
840: ; Include the current environment in
841: ; the variable assoc-list.
842: (and *blockstack*
843: (putalist (cdar *blockstack*) valblock))
844: (setq *toplevelp* nil))
845: ( t (putbothalists *currenttopalists* valblock)))
846:
847: (and abbrev
848: (cond ((eq abbrev '*buildabbrev*)
849: (putabbrev (eval `(newsym ,(getpname defblock))) valblock))
850: ( t (putabbrev abbrev valblock))))
851: (putdef defblock valblock)
852: (setq oldvalblock (getdefaultinst defblock))
853:
854: ; Copy slots from old structure first, then run base hooks.
855: (for slotnum 1 length
856: (copyslot defblock))
857: (and (getbasehooks defblock)
858: (setq item valblock)
859: (checkrunhandlebasehooks1 '<individual *runindividualhooks*)
860: (setq valblock item))
861:
862: ; Replace copied values for slots that are actually listed
863: ; then run base hooks.
864: (while (setq slot (pop slots))
865: (fillindivslot))
866: (and (getbasehooks defblock)
867: (setq item valblock)
868: (checkrunhandlebasehooks1 '>individual *runindividualhooks*)
869: (setq valblock item))
870: (return valblock)))
871:
872: ; Copy default values, predicates, and hooks for one slot.
873: (dm copypatternslot (none)
874: '(progn
875: (putslotvaluetype slotnum 'LOCAL valblock)
876: (putslotvalue slotnum *any*conscell* valblock)
877: (putpred slotnum (getpred slotnum oldvalblock) valblock)
878: (putslothooks slotnum (getslothooks slotnum oldvalblock) valblock)))
879:
880: ; Create a new structure of type PATTERN: an instance of a BASE or
881: ; EXPANDED structure. Unspecified slots are filled with ?*ANY*.
882: (de createpattern (basename abbrev slots)
883: (prog (defblock valblock oldvalblock slotname length slotnum isa
884: slotlocation slot predlist slothooklist fcn typenum
885: ppset newvalue result item slotvalue valuetype)
886: (or (structurenamep basename)
887: (progn (msg t "CREATE PATTERN: " basename
888: " is not the name of a previously declared structure."
889: t)
890: (pearlbreak)))
891:
892: ; Get definition and allocate hunk for pattern.
893: (setq defblock (eval (defatom basename)))
894: (setq valblock (allocval (setq length (getstructlength defblock))))
895: (setq oldvalblock (getdefaultinst defblock))
896: (puttypetag '*pearlinst* valblock)
897: (cond (*toplevelp* (setq *currenttopcreated* valblock)
898: (setq *currentpearlstructure* valblock)
899: (initbothalists valblock)
900: (setq *currenttopalists* (getbothalists valblock))
901: ; Include the current environment in
902: ; the variable assoc-list.
903: (and *blockstack*
904: (putalist (cdar *blockstack*) valblock))
905: (setq *toplevelp* nil))
906: ( t (putbothalists *currenttopalists* valblock)))
907:
908: (putdef defblock valblock)
909: (and abbrev
910: (cond ((eq abbrev '*buildabbrev*)
911: (putabbrev (eval `(newsym ,(getpname defblock))) valblock))
912: ( t (putabbrev abbrev valblock))))
913:
914: ; Copy slot values from base and run base hooks on base structure.
915: (for slotnum 1 length
916: (copypatternslot))
917: (and (getbasehooks defblock)
918: (setq item valblock)
919: (checkrunhandlebasehooks1 '<pattern *runpatternhooks*)
920: (setq valblock item))
921:
922: ; Fill in new values for any slots listed and run base hooks.
923: (while (setq slot (pop slots))
924: (fillindivslot))
925: (and (getbasehooks defblock)
926: (setq item valblock)
927: (checkrunhandlebasehooks1 '>pattern *runpatternhooks*)
928: (setq valblock item))
929: (return valblock)))
930:
931: ; Create a new structure of type FUNCTION: a structure with slots
932: ; describing the arguments to the function of the same name.
933: (de createfunction (fcnname abbrev slots)
934: ; Function must already be defined and be a lambda (expr).
935: (cond ((islambda fcnname)
936: (putprop fcnname t 'functionstruct)
937: (createbase fcnname abbrev slots))
938: ( t (msg t "CREATE FUNCTION: Only lambdas (exprs) allowed as "
939: "function structures: " fcnname slots t)
940: (pearlbreak))))
941:
942: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.