![[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] / 43BSD / ucb / lisp / pearl|
Return to create.l CVS log | Up to [CSRG BSD Unix] / 43BSD / 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.