;;;;;;;;;;;;;;;;;;;;;;;;;;;;; vars.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for declaring and creating pattern-matching variables
; and blocks and for freezing and thawing them.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 , The Regents of the University of California.
; Authors: Joseph Faletti and Michael Deering.
; Convert a question mark variable ?var to either (*global* var) if "var"
; is in *globallist* or else make it local (*var* var).
(let ((nextchar (tyipeek))
(cond ((\=& 9. nextchar) '\?)
(cond ((memq var *globallist*)
( t (list '*var* var))))))))
; VALUEOF and VARVALUE are EXPR and FEXPR versions of a function to
; get the value of the variable VAR in the structure STRUCT.
(cdr (or (assq var (getalist struct))
(assq var (getalistcp struct))
(progn (msg t "VALUEOF: Variable " var
" does not occur in structure:" struct t)
; This is a FEXPR version of valueof (above).
(df varvalue (l) ; (VAR STRUCT)
(struct (eval (cadr l))))
(cdr (or (assq var (getalist struct))
(assq var (getalistcp struct))
(progn (msg t "VARVALUE: Variable " var
" does not occur in structure:" struct t)
; Set the given variable, in the given environment (if present) to
; the value given. If no environment given, look first at
; *currentstructure*, then at *currentpearlstructure*, then at
; *blockstack*, else complain.
(df setv (l) ; (var 'val 'environment)
(environment (eval (caddr l)))
(cond ((eq '*global* type) ; global variable.
(setq oldvarval (eval name))
((eq '*var* type) ; local or block variable.
; optional 3rd argument given for environment.
(cond ((structurep environment)
(or (assq name (getalist environment))
(assq name (getalistcp environment))
(progn (msg t "SETV: No variable named: " name
" in structure: " t environment t)
(or (assq name environment)
(progn (msg t "SETV: No variable named: " name
" in block: " t environment t)
( t (msg t "SETV: Given environment is neither "
"a block nor a structure: " t environment)
; otherwise, try to find in standard environment.
(or (and (structurep *currentstructure*)
(or (assq name (getalist *currentstructure*))
(assq name (getalistcp *currentstructure*))
(and (structurep *currentpearlstructure*)
(getalist *currentpearlstructure*))
(getalistcp *currentpearlstructure*))
(assq name (cdar *blockstack*))))))
( t ; Else if not there either, blow up.
(msg t "SETV: No variable in the current"
" environment named: " name t)
; Successfully found the variable.
(setq oldvarval (cdr varcell))
( t (msg t "SETV: " var " is not a variable." t)
(and (equivclassp oldvarval)
(mapc (funl (newvar) (cond ((dtpr newvar) ; a local var cell.
(and (eq (cdr newvar) oldvarval)
( t ; otherwise a global var's name.
(and (eq (eval newvar) oldvarval)
; Get the value of a local variable. Look in the same places as
; SETV above but return nil if not found.
(cdr (or (and (structurep *currentstructure*)
(or (assq var (getalist *currentstructure*))
(assq var (getalistcp *currentstructure*))))
(and (structurep *currentpearlstructure*)
(or (assq var (getalist *currentpearlstructure*))
(getalistcp *currentpearlstructure*))))
(assq var (cdar *blockstack*))))))))
; Get the value of a global variable.
; Declare a variable to be GLOBAL by entering it on the *GLOBALLIST*
; and PEARL-unbinding it.
(let ((variable (car l)))
(set variable (punbound))
(push variable *globallist*)
; PEARL-unbind a global variable. ("unbindvars" does the local variables
; in an entire structure (see match.l)).
(cond ((memq var *globallist*)
(msg t "UNBIND: Warning: " var
" is not a global variable but unbound it anyway."
; Determine if the variable is GLOBAL, i.e., on the *GLOBALLIST*
(memq variable *globallist*))
; (BLOCK <name> (<LIST OF VARIABLES>)) starts a (possibly embedded)
; set of variables accessible to all structure CREATEd within
; the block. Terminated by a call to (ENDBLOCK <name>).
; The name is optional. If used, then the block may be reaccessed
(cond ((reallitatom name) (setq varlist (cadr l)))
(setq name 'unnamedblock)))
(nconc (ncons (cons nil (punbound))) ; Cell for Frozen vars.
(mapcar (funl (varname) (cons varname (punbound)))
(cond (*blockstack* (cdar *blockstack*))
; Create a special cons cell, point b:<name> at it and push it.
(push (set (blockatom name)
; (ENDBLOCK <name>) ends the block with name <name>.
; If <name> is * then close one block, regardless of name.
; If <name> is nil then close one unnamed block only.
(setq name 'unnamedblock))
(cond ((not *blockstack*)
(msg t "ENDBLOCK: No blocks to end")
(msg ", not even named: " name t)
(eq name (caar *blockstack*)))
(prog1 (caar *blockstack*)
(setq *blockstack* (cdr *blockstack*))))
( t (msg t "ENDBLOCK: Block to be ended, "
name " doesn't match innermost block, named: "
; (ENDANYBLOCKS <name>) ends all blocks back through the block
; If <name> is * then end all blocks.
; If <name> is nil then end all blocks back through the
(cond ((not *blockstack*) nil)
((eq name '*) (setq *blockstack* nil))
(setq block (cdr block))))
(msg t "ENDANYBLOCKS: No currently open block named "
name " to end blocks back to." t)
( t (setq *blockstack* (pop block))
; (ENDALLBLOCKS <name>) ends any open blocks, regardless of name.
; (SETBLOCK <blockname>) changes the current scope to that of
; <blockname>, BUT doesn't allow ending former blocks!
(let ((blockname (car l)))
(cond ((and (boundp (blockatom blockname))
(blockp (eval (blockatom blockname))))
(setq *blockstack* (eval (blockatom blockname))))
( t (msg t "SETBLOCK: There is no block named: " blockname t)
; Take all the bound variables off the STRUCT'S ALIST, and put them on
; the ALISTCP, preserving unique alist pairs. Also take care of all the
; BLOCK alists. WARNING: This code is tough so be careful with it!
(de freezebindings (struct)
(let ((oldalist (getalist struct)) ; to be frozen.
(unboundalist (ncons nil)) ; to still unbound variables.
(boundalist (getalistcp struct)) ; already frozen.
; While there are more variables to process, and we haven't reached
; a block, add either to "unboundalist" or "boundalist".
(reallitatom (caar oldalist)))
(setq rest (cdr oldalist))
(cond ((eq (cdar oldalist) (punbound))
(tconc unboundalist (car oldalist)))
( t (setq boundalist (rplacd oldalist boundalist))))
(nconc (car unboundalist)
oldalist))) ; pointer to the enclosing blocks.
(putalist (car unboundalist) struct)
(putalistcp boundalist struct)
; Process blocks one at a time.
(setq currentblock oldalist)
(setq oldalist (cdr oldalist))
(setq unboundalist (ncons nil))
(setq boundalist (caar currentblock))
(reallitatom (caar oldalist)))
(setq rest (cdr oldalist))
(cond ((eq (cdar oldalist) (punbound))
(tconc unboundalist (car oldalist)))
( t (setq boundalist (rplacd oldalist boundalist))))
(nconc (car unboundalist)
oldalist))) ; pointer to the enclosing blocks.
(rplaca (car currentblock) boundalist)
(rplacd currentblock (car unboundalist)))
; Take all the bound variables off the STRUCT's ALIST, and put them on
; the ALISTCP, preserving unique alist pairs.
(de freezestruct (struct)
(let ((oldalist (getalist struct))
(unboundalist (ncons nil))
(boundalist (getalistcp struct))
(while (and oldalist ; is not NIL, and
(reallitatom (caar oldalist))) ; have not reached block
(setq rest (cdr oldalist))
(cond ((eq (cdar oldalist) (punbound))
(tconc unboundalist (car oldalist)))
( t (setq boundalist (rplacd oldalist boundalist))))
(nconc (car unboundalist)
oldalist))) ; pointer to the enclosing blocks.
(putalist (car unboundalist) struct)
(putalistcp boundalist struct)
(df freezeblock (blockname)
(cond ((and (boundp (blockatom (car blockname)))
(setq block (eval (blockatom (car blockname))))
( t (msg t "FREEZEBLOCK: " blockname
" is not the name of a block." t)
(setq oldalist (cddr block))
(setq unboundalist (ncons nil))
(setq boundalist (caadr block))
(reallitatom (caar oldalist)))
(setq rest (cdr oldalist))
(cond ((eq (cdar oldalist) (punbound))
(tconc unboundalist (car oldalist)))
( t (setq boundalist (rplacd oldalist boundalist))))
(nconc (car unboundalist)
oldalist))) ; pointer to the enclosing blocks.
(rplaca (cadr block) boundalist) ; store frozen vars.
(rplacd (cdr block) (car unboundalist))
(dm findnextblockstart (none) ; But expects ALIST
(reallitatom (caar alist)))
(setq alist (cdr alist))))
; This is for JUST THE STRUCT.
(let ((alist (getalist struct)))
(putalist (nconc (getalistcp struct) alist) struct)
; Restore the Alist to include all values. (Undo FREEZEBINDINGS)
; This is done for ALL BLOCKs that STRUCT is a member of.
(de thawbindings (struct)
(let ((alist (getalist struct)))
(putalist (nconc (getalistcp struct) alist) struct)
(while (findnextblockstart)
(rplacd alist (nconc (caar alist) (cdr alist)))
(rplaca (car alist) nil))
; This is for JUST ONE BLOCK.
(df thawblock (blockname)
(cond ((and (boundp (blockatom (car blockname)))
(setq block (eval (blockatom (car blockname))))
( t (msg t "THAWBLOCK: " blockname
" is not the name of a block." t)
(setq alist (cddr block))
(rplacd (cdr block) (nconc (caadr block) alist))
(rplaca (cadr block) nil)