Return to lowlevel.l CVS log

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

Annotation of 43BSD/ucb/lisp/pearl/lowlevel.l, revision 1.1

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.