Return to vars.l CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl

Annotation of 43BSDReno/pgrm/lisp/pearl/vars.l, revision 1.1

1.1     ! root        1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; vars.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             2: ; Functions for declaring and creating pattern-matching variables
        !             3: ;    and blocks and for freezing and thawing them.
        !             4: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             5: ; Copyright (c) 1983 ,  The Regents of the University of California.
        !             6: ; All rights reserved.  
        !             7: ; Authors: Joseph Faletti and Michael Deering.
        !             8: 
        !             9: ; Convert a question mark variable ?var to either (*global* var) if "var"
        !            10: ;    is in *globallist* or else make it local (*var* var).
        !            11: (drm \?
        !            12:   (lambda ()
        !            13:          (let ((nextchar (tyipeek))
        !            14:                var)
        !            15:               (cond ((\=&  9. nextchar) '\?)
        !            16:                     ((\=& 10. nextchar) '\?)
        !            17:                     ((\=& 13. nextchar) '\?)
        !            18:                     ((\=& 32. nextchar) '\?)
        !            19:                     ((\=& 41. nextchar) '\?)
        !            20:                     ( t (setq var (read))
        !            21:                         (cond ((memq var *globallist*)
        !            22:                                (list '*global* var))
        !            23:                               (  t  (list '*var* var))))))))
        !            24:  
        !            25: ; VALUEOF and VARVALUE are EXPR and FEXPR versions of a function to
        !            26: ;     get the value of the variable VAR in the structure STRUCT.
        !            27: (de valueof (var struct)
        !            28:   (getvalofequivorvar
        !            29:    (cdr (or (assq var (getalist struct))
        !            30:            (assq var (getalistcp struct))
        !            31:            (progn (msg t "VALUEOF: Variable " var
        !            32:                        " does not occur in structure:" struct t)
        !            33:                   (pearlbreak))))))
        !            34:  
        !            35: ;    This is a FEXPR version of valueof (above).
        !            36: (df varvalue (l)     ; (VAR STRUCT)
        !            37:   (let ((var (car l))
        !            38:        (struct (eval (cadr l))))
        !            39:        (getvalofequivorvar
        !            40:        (cdr (or (assq var (getalist struct))
        !            41:                 (assq var (getalistcp struct))
        !            42:                 (progn (msg t "VARVALUE: Variable " var
        !            43:                             " does not occur in structure:" struct t)
        !            44:                        (pearlbreak)))))))
        !            45: 
        !            46: ; Set the given variable, in the given environment (if present) to
        !            47: ;    the value given.  If no environment given, look first at
        !            48: ;    *currentstructure*, then at *currentpearlstructure*, then at
        !            49: ;    *blockstack*, else complain.
        !            50: (df setv (l)    ; (var 'val 'environment)
        !            51:   (let*
        !            52:    ((var (car l))
        !            53:     (type (car var))
        !            54:     (name (cadr var))
        !            55:     (val (eval (cadr l)))
        !            56:     (environment (eval (caddr l)))
        !            57:     varcell
        !            58:     oldvarval)
        !            59:    (cond ((eq '*global* type)   ; global variable.
        !            60:          (setq oldvarval (eval name))
        !            61:          (set name val))
        !            62:         ((eq '*var* type)      ; local or block variable.
        !            63:          (cond (environment
        !            64:                 ; optional 3rd argument given for environment.
        !            65:                 (cond ((structurep environment)
        !            66:                        (setq varcell
        !            67:                              (or (assq name (getalist environment))
        !            68:                                  (assq name (getalistcp environment))
        !            69:                                  (progn (msg t "SETV: No variable named: " name
        !            70:                                              " in structure: " t environment t)
        !            71:                                         (pearlbreak)))))
        !            72:                       ((blockp environment)
        !            73:                        (setq varcell
        !            74:                              (or (assq name environment)
        !            75:                                  (progn (msg t "SETV: No variable named: " name
        !            76:                                              " in block: " t environment t)
        !            77:                                         (pearlbreak)))))
        !            78:                       ( t (msg t "SETV: Given environment is neither "
        !            79:                                "a block nor a structure: " t environment)
        !            80:                           (pearlbreak))))
        !            81:                ; otherwise, try to find in standard environment.
        !            82:                ((setq varcell
        !            83:                       (or (and (structurep *currentstructure*)
        !            84:                                (or (assq name (getalist *currentstructure*))
        !            85:                                    (assq name (getalistcp *currentstructure*))
        !            86:                                    ))
        !            87:                           (and (structurep *currentpearlstructure*)
        !            88:                                (or (assq name
        !            89:                                          (getalist *currentpearlstructure*))
        !            90:                                    (assq name
        !            91:                                          (getalistcp *currentpearlstructure*))
        !            92:                                    ))
        !            93:                           (and *blockstack*
        !            94:                                (assq name (cdar *blockstack*))))))
        !            95:                ( t ; Else if not there either, blow up.
        !            96:                    (msg t "SETV: No variable in the current"
        !            97:                         " environment named: " name t)
        !            98:                    (pearlbreak)))
        !            99:          ; Successfully found the variable.
        !           100:          (and varcell
        !           101:               (setq oldvarval (cdr varcell))
        !           102:               (rplacd varcell val)))
        !           103:         ( t (msg t "SETV: " var " is not a variable." t)
        !           104:             (pearlbreak)))
        !           105:    (and (equivclassp oldvarval)
        !           106:        (mapc (funl (newvar) (cond ((dtpr newvar)           ; a local var cell.
        !           107:                                    (and (eq (cdr newvar) oldvarval)
        !           108:                                         (rplacd newvar val)))
        !           109:                                   ( t ; otherwise a global var's name.
        !           110:                                       (and (eq (eval newvar) oldvarval)
        !           111:                                            (set newvar val)))))
        !           112:              (cdr oldvarval)))
        !           113:    val))
        !           114: 
        !           115: ; Get the value of a local variable.   Look in the same places as
        !           116: ;    SETV above but return nil if not found.
        !           117: (df *var* (l)
        !           118:   (let ((var (car l)))
        !           119:        (getvalofequivorvar
        !           120:          (cdr (or (and (structurep *currentstructure*)
        !           121:                        (or (assq var (getalist *currentstructure*))
        !           122:                            (assq var (getalistcp *currentstructure*))))
        !           123:                   (and (structurep *currentpearlstructure*)
        !           124:                        (or (assq var (getalist *currentpearlstructure*))
        !           125:                            (assq var
        !           126:                                  (getalistcp *currentpearlstructure*))))
        !           127:                   (and *blockstack*
        !           128:                        (assq var (cdar *blockstack*))))))))
        !           129: 
        !           130: ; Get the value of a global variable.
        !           131: (df *global* (l)
        !           132:   (getvalofequivorvar
        !           133:      (eval (car l))))
        !           134: 
        !           135: ; Declare a variable to be GLOBAL by entering it on the *GLOBALLIST*
        !           136: ;    and PEARL-unbinding it.
        !           137: (df global (l)
        !           138:   (let ((variable (car l)))
        !           139:        (set variable (punbound))
        !           140:        (push variable *globallist*)
        !           141:        variable))
        !           142:  
        !           143: ; PEARL-unbind a global variable. ("unbindvars" does the local variables
        !           144: ;    in an entire structure (see match.l)).
        !           145: (df unbind (l)
        !           146:   (let ((var (car l)))
        !           147:        (cond ((memq var *globallist*)
        !           148:              (set var (punbound)))
        !           149:             ( t (set var (punbound))
        !           150:                 (and *warn*
        !           151:                      (msg t "UNBIND: Warning: " var
        !           152:                           " is not a global variable but unbound it anyway."
        !           153:                           t))))))
        !           154: 
        !           155: ; Determine if the variable is GLOBAL, i.e., on the *GLOBALLIST*
        !           156: (de globalp (variable)
        !           157:   (memq variable *globallist*))
        !           158:  
        !           159: ; (BLOCK <name> (<LIST OF VARIABLES>)) starts a (possibly embedded)
        !           160: ;    set of variables accessible to all structure CREATEd within
        !           161: ;    the block.   Terminated by a call to (ENDBLOCK <name>).
        !           162: ; The name is optional.  If used, then the block may be reaccessed
        !           163: ;    with b:<name>.
        !           164:  
        !           165: (df block (l)
        !           166:   (let ((name (car l))
        !           167:        varlist
        !           168:        alist)
        !           169:        (cond ((reallitatom name) (setq varlist (cadr l)))
        !           170:             ( t  (setq varlist name)
        !           171:                  (setq name 'unnamedblock)))
        !           172:        (setq alist
        !           173:             (nconc (ncons (cons nil (punbound)))  ; Cell for Frozen vars.
        !           174:                    (mapcar (funl (varname) (cons varname (punbound)))
        !           175:                            varlist)
        !           176:                    (cond (*blockstack* (cdar *blockstack*))
        !           177:                          ( t nil))))
        !           178:        (and name
        !           179:            (set name alist))
        !           180:        ; Create a special cons cell, point b:<name> at it and push it.
        !           181:        (push (set (blockatom name)
        !           182:                  (cons name alist))
        !           183:             *blockstack*)
        !           184:        name))
        !           185:  
        !           186: ; (ENDBLOCK <name>) ends the block with name <name>.
        !           187: ;    If <name> is * then close one block, regardless of name.
        !           188: ;    If <name> is nil then close one unnamed block only.
        !           189: (df endblock (l)
        !           190:   (let ((name (car l)))
        !           191:        (and (null name)
        !           192:            (setq name 'unnamedblock))
        !           193:        (cond ((not *blockstack*)
        !           194:              (msg t "ENDBLOCK: No blocks to end")
        !           195:              (msg ", not even named: " name t)
        !           196:              (pearlbreak))
        !           197:             ((or (eq name '*)
        !           198:                  (eq name (caar *blockstack*)))
        !           199:              (prog1 (caar *blockstack*)
        !           200:                     (setq *blockstack* (cdr *blockstack*))))
        !           201:             ( t (msg t "ENDBLOCK: Block to be ended, "
        !           202:                      name " doesn't match innermost block, named: "
        !           203:                      (caar *blockstack*) t)
        !           204:                 (pearlbreak)))))
        !           205: 
        !           206: ; (ENDANYBLOCKS <name>) ends all blocks back through the block
        !           207: ;    with name <name>.
        !           208: ; If <name> is * then end all blocks.
        !           209: ; If <name> is nil then end all blocks back through the
        !           210: ;    last unnamed block.
        !           211: (df endanyblocks (l)
        !           212:   (let ((name (car l))
        !           213:        (block *blockstack*))
        !           214:        (cond ((not *blockstack*)    nil)
        !           215:             ((eq name '*)       (setq *blockstack* nil))
        !           216:             ((null (while (and block
        !           217:                                (neq (caar block) name))
        !           218:                           (setq block (cdr block))))
        !           219:              (msg t "ENDANYBLOCKS: No currently open block named "
        !           220:                   name " to end blocks back to." t)
        !           221:              (pearlbreak))
        !           222:             ( t (setq *blockstack* (pop block))
        !           223:                 (caar *blockstack*)))
        !           224:        t))
        !           225: 
        !           226: ; (ENDALLBLOCKS <name>) ends any open blocks, regardless of name.
        !           227: (de endallblocks ()
        !           228:   (setq *blockstack* nil)
        !           229:   t)
        !           230: 
        !           231: ; (SETBLOCK <blockname>) changes the current scope to that of
        !           232: ;      <blockname>, BUT doesn't allow ending former blocks!
        !           233: (df setblock (l)
        !           234:   (let ((blockname (car l)))
        !           235:        (cond ((and (boundp (blockatom blockname))
        !           236:                   (blockp (eval (blockatom blockname))))
        !           237:              (setq *blockstack* (eval (blockatom blockname))))
        !           238:             ( t (msg t "SETBLOCK: There is no block named: " blockname t)
        !           239:                 (pearlbreak)))))
        !           240:  
        !           241: ; Take all the bound variables off the STRUCT'S ALIST, and put them on
        !           242: ; the ALISTCP, preserving unique alist pairs.  Also take care of all the
        !           243: ; BLOCK alists.  WARNING: This code is tough so be careful with it!
        !           244: (de freezebindings (struct)
        !           245:   (let ((oldalist (getalist struct))     ; to be frozen.
        !           246:        (unboundalist (ncons nil))       ; to still unbound variables.
        !           247:        (boundalist (getalistcp struct)) ; already frozen.
        !           248:        rest
        !           249:        currentblock)
        !           250:        ; While there are more variables to process, and we haven't reached
        !           251:        ;     a block, add either to "unboundalist" or "boundalist".
        !           252:        (while (and oldalist
        !           253:                   (reallitatom (caar oldalist)))
        !           254:              (setq rest (cdr oldalist))
        !           255:              (cond ((eq (cdar oldalist) (punbound))
        !           256:                     (tconc unboundalist (car oldalist)))
        !           257:                    ( t (setq boundalist (rplacd oldalist boundalist))))
        !           258:              (setq oldalist rest))
        !           259:        (and oldalist
        !           260:            (rplaca unboundalist
        !           261:                    (nconc (car unboundalist)
        !           262:                           oldalist))) ; pointer to the enclosing blocks.
        !           263:        ; Store new lists.
        !           264:        (putalist (car unboundalist) struct)
        !           265:        (putalistcp boundalist struct)
        !           266:        ; Process blocks one at a time.
        !           267:        (while oldalist
        !           268:              (setq currentblock oldalist)
        !           269:              (setq oldalist (cdr oldalist))
        !           270:              (setq unboundalist (ncons nil))
        !           271:              (setq boundalist (caar currentblock))
        !           272:              (while (and oldalist
        !           273:                          (reallitatom (caar oldalist)))
        !           274:                     (setq rest (cdr oldalist))
        !           275:                     (cond ((eq (cdar oldalist) (punbound))
        !           276:                            (tconc unboundalist (car oldalist)))
        !           277:                           ( t (setq boundalist (rplacd oldalist boundalist))))
        !           278:                     (setq oldalist rest))
        !           279:              (and oldalist
        !           280:                   (rplaca unboundalist
        !           281:                           (nconc (car unboundalist)
        !           282:                                  oldalist))) ; pointer to the enclosing blocks.
        !           283:              ; store frozen vars.
        !           284:              (rplaca (car currentblock) boundalist)
        !           285:              (rplacd currentblock (car unboundalist)))
        !           286:        t))
        !           287:  
        !           288: ; Take all the bound variables off the STRUCT's ALIST, and put them on
        !           289: ;   the ALISTCP, preserving unique alist pairs.
        !           290: (de freezestruct (struct)
        !           291:   (let ((oldalist (getalist struct))
        !           292:        (unboundalist (ncons nil))
        !           293:        (boundalist (getalistcp struct))
        !           294:        rest)
        !           295:        (while (and oldalist                       ; is not NIL, and
        !           296:                   (reallitatom (caar oldalist))) ; have not reached block
        !           297:              (setq rest (cdr oldalist))
        !           298:              (cond ((eq (cdar oldalist) (punbound))
        !           299:                     (tconc unboundalist (car oldalist)))
        !           300:                    ( t (setq boundalist (rplacd oldalist boundalist))))
        !           301:              (setq oldalist rest))
        !           302:        (and oldalist
        !           303:            (rplaca unboundalist
        !           304:                    (nconc (car unboundalist)
        !           305:                           oldalist))) ; pointer to the enclosing blocks.
        !           306:        (putalist (car unboundalist) struct)
        !           307:        (putalistcp boundalist struct)
        !           308:        t))
        !           309:  
        !           310: (df freezeblock (blockname)
        !           311:   (let (block
        !           312:        oldalist
        !           313:        unboundalist
        !           314:        boundalist
        !           315:        rest)
        !           316:        (cond ((and (boundp (blockatom (car blockname)))
        !           317:                   (setq block (eval (blockatom (car blockname))))
        !           318:                   (blockp block)))
        !           319:             ( t (msg t "FREEZEBLOCK: " blockname
        !           320:                      " is not the name of a block." t)
        !           321:                 (pearlbreak)))
        !           322:        (setq oldalist (cddr block))
        !           323:        (setq unboundalist (ncons nil))
        !           324:        (setq boundalist (caadr block))
        !           325:        (while (and oldalist
        !           326:                   (reallitatom (caar oldalist)))
        !           327:              (setq rest (cdr oldalist))
        !           328:              (cond ((eq (cdar oldalist) (punbound))
        !           329:                     (tconc unboundalist (car oldalist)))
        !           330:                    ( t (setq boundalist (rplacd oldalist boundalist))))
        !           331:              (setq oldalist rest))
        !           332:        (and oldalist
        !           333:            (rplaca unboundalist
        !           334:                    (nconc (car unboundalist)
        !           335:                           oldalist))) ; pointer to the enclosing blocks.
        !           336:        (rplaca (cadr block) boundalist) ; store frozen vars.
        !           337:        (rplacd (cdr block) (car unboundalist))
        !           338:        t))
        !           339:  
        !           340: (dm findnextblockstart (none) ; But expects ALIST
        !           341:   '(while (and alist
        !           342:               (reallitatom (caar alist)))
        !           343:          (setq alist (cdr alist))))
        !           344:  
        !           345: ; This is for JUST THE STRUCT.
        !           346: (de thawstruct (struct)
        !           347:   (let ((alist (getalist struct)))
        !           348:        (putalist (nconc (getalistcp struct) alist) struct)
        !           349:        (putalistcp nil struct)
        !           350:        t))
        !           351:  
        !           352: ; Restore the Alist to include all values. (Undo FREEZEBINDINGS)
        !           353: ; This is done for ALL BLOCKs that STRUCT is a member of.
        !           354: (de thawbindings (struct)
        !           355:   (let ((alist (getalist struct)))
        !           356:        (putalist (nconc (getalistcp struct) alist) struct)
        !           357:        (putalistcp nil struct)
        !           358:        (while (findnextblockstart)
        !           359:              (rplacd alist (nconc (caar alist) (cdr alist)))
        !           360:              (rplaca (car alist) nil))
        !           361:        t))
        !           362:  
        !           363: ; This is for JUST ONE BLOCK.
        !           364: (df thawblock (blockname)
        !           365:   (let (alist
        !           366:        block)
        !           367:        (cond ((and (boundp (blockatom (car blockname)))
        !           368:                   (setq block (eval (blockatom (car blockname))))
        !           369:                   (blockp block))
        !           370:              block)
        !           371:             ( t (msg t "THAWBLOCK: " blockname
        !           372:                      " is not the name of a block." t)
        !           373:                 (pearlbreak)))
        !           374:        (setq alist (cddr block))
        !           375:        (rplacd (cdr block) (nconc (caadr block) alist))
        !           376:        (rplaca (cadr block) nil)
        !           377:        t))
        !           378: 
        !           379: 
        !           380: ; vi: set lisp:

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.