[unix-history] / usr / src / old / lisp / pearl / vars.l

;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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.
; All rights reserved.  
; 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).
(drm \?
  (lambda ()
	  (let ((nextchar (tyipeek))
		var)
	       (cond ((\=&  9. nextchar) '\?)
		     ((\=& 10. nextchar) '\?)
		     ((\=& 13. nextchar) '\?)
		     ((\=& 32. nextchar) '\?)
		     ((\=& 41. nextchar) '\?)
		     ( t (setq var (read))
			 (cond ((memq var *globallist*)
				(list '*global* var))
			       (  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.
(de valueof (var struct)
  (getvalofequivorvar
   (cdr (or (assq var (getalist struct))
	    (assq var (getalistcp struct))
	    (progn (msg t "VALUEOF: Variable " var
			" does not occur in structure:" struct t)
		   (pearlbreak))))))
 
;    This is a FEXPR version of valueof (above).
(df varvalue (l)     ; (VAR STRUCT)
  (let ((var (car l))
	(struct (eval (cadr l))))
       (getvalofequivorvar
	(cdr (or (assq var (getalist struct))
		 (assq var (getalistcp struct))
		 (progn (msg t "VARVALUE: Variable " var
			     " does not occur in structure:" struct t)
			(pearlbreak)))))))

; 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)
  (let*
   ((var (car l))
    (type (car var))
    (name (cadr var))
    (val (eval (cadr l)))
    (environment (eval (caddr l)))
    varcell
    oldvarval)
   (cond ((eq '*global* type)   ; global variable.
	  (setq oldvarval (eval name))
	  (set name val))
	 ((eq '*var* type)      ; local or block variable.
	  (cond (environment
		 ; optional 3rd argument given for environment.
		 (cond ((structurep environment)
			(setq varcell
			      (or (assq name (getalist environment))
				  (assq name (getalistcp environment))
				  (progn (msg t "SETV: No variable named: " name
					      " in structure: " t environment t)
					 (pearlbreak)))))
		       ((blockp environment)
			(setq varcell
			      (or (assq name environment)
				  (progn (msg t "SETV: No variable named: " name
					      " in block: " t environment t)
					 (pearlbreak)))))
		       ( t (msg t "SETV: Given environment is neither "
				"a block nor a structure: " t environment)
			   (pearlbreak))))
		; otherwise, try to find in standard environment.
		((setq varcell
		       (or (and (structurep *currentstructure*)
				(or (assq name (getalist *currentstructure*))
				    (assq name (getalistcp *currentstructure*))
				    ))
			   (and (structurep *currentpearlstructure*)
				(or (assq name
					  (getalist *currentpearlstructure*))
				    (assq name
					  (getalistcp *currentpearlstructure*))
				    ))
			   (and *blockstack*
				(assq name (cdar *blockstack*))))))
		( t ; Else if not there either, blow up.
		    (msg t "SETV: No variable in the current"
			 " environment named: " name t)
		    (pearlbreak)))
	  ; Successfully found the variable.
	  (and varcell
	       (setq oldvarval (cdr varcell))
	       (rplacd varcell val)))
	 ( t (msg t "SETV: " var " is not a variable." t)
	     (pearlbreak)))
   (and (equivclassp oldvarval)
	(mapc (funl (newvar) (cond ((dtpr newvar)	    ; a local var cell.
				    (and (eq (cdr newvar) oldvarval)
					 (rplacd newvar val)))
				   ( t ; otherwise a global var's name.
				       (and (eq (eval newvar) oldvarval)
					    (set newvar val)))))
	      (cdr oldvarval)))
   val))

; Get the value of a local variable.   Look in the same places as
;    SETV above but return nil if not found.
(df *var* (l)
  (let ((var (car l)))
       (getvalofequivorvar
	  (cdr (or (and (structurep *currentstructure*)
			(or (assq var (getalist *currentstructure*))
			    (assq var (getalistcp *currentstructure*))))
		   (and (structurep *currentpearlstructure*)
			(or (assq var (getalist *currentpearlstructure*))
			    (assq var
				  (getalistcp *currentpearlstructure*))))
		   (and *blockstack*
			(assq var (cdar *blockstack*))))))))

; Get the value of a global variable.
(df *global* (l)
  (getvalofequivorvar
     (eval (car l))))

; Declare a variable to be GLOBAL by entering it on the *GLOBALLIST*
;    and PEARL-unbinding it.
(df global (l)
  (let ((variable (car l)))
       (set variable (punbound))
       (push variable *globallist*)
       variable))
 
; PEARL-unbind a global variable. ("unbindvars" does the local variables
;    in an entire structure (see match.l)).
(df unbind (l)
  (let ((var (car l)))
       (cond ((memq var *globallist*)
	      (set var (punbound)))
	     ( t (set var (punbound))
		 (and *warn*
		      (msg t "UNBIND: Warning: " var
			   " is not a global variable but unbound it anyway."
			   t))))))

; Determine if the variable is GLOBAL, i.e., on the *GLOBALLIST*
(de globalp (variable)
  (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
;    with b:<name>.
 
(df block (l)
  (let ((name (car l))
	varlist
	alist)
       (cond ((reallitatom name) (setq varlist (cadr l)))
	     ( t  (setq varlist name)
		  (setq name 'unnamedblock)))
       (setq alist
	     (nconc (ncons (cons nil (punbound)))  ; Cell for Frozen vars.
		    (mapcar (funl (varname) (cons varname (punbound)))
			    varlist)
		    (cond (*blockstack* (cdar *blockstack*))
			  ( t nil))))
       (and name
	    (set name alist))
       ; Create a special cons cell, point b:<name> at it and push it.
       (push (set (blockatom name)
		  (cons name alist))
	     *blockstack*)
       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.
(df endblock (l)
  (let ((name (car l)))
       (and (null name)
	    (setq name 'unnamedblock))
       (cond ((not *blockstack*)
	      (msg t "ENDBLOCK: No blocks to end")
	      (msg ", not even named: " name t)
	      (pearlbreak))
	     ((or (eq name '*)
		  (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: "
		      (caar *blockstack*) t)
		 (pearlbreak)))))

; (ENDANYBLOCKS <name>) ends all blocks back through the block
;    with name <name>.
; If <name> is * then end all blocks.
; If <name> is nil then end all blocks back through the
;    last unnamed block.
(df endanyblocks (l)
  (let ((name (car l))
	(block *blockstack*))
       (cond ((not *blockstack*)    nil)
	     ((eq name '*)       (setq *blockstack* nil))
	     ((null (while (and block
				(neq (caar block) name))
			   (setq block (cdr block))))
	      (msg t "ENDANYBLOCKS: No currently open block named "
		   name " to end blocks back to." t)
	      (pearlbreak))
	     ( t (setq *blockstack* (pop block))
		 (caar *blockstack*)))
       t))

; (ENDALLBLOCKS <name>) ends any open blocks, regardless of name.
(de endallblocks ()
  (setq *blockstack* nil)
  t)

; (SETBLOCK <blockname>) changes the current scope to that of
;      <blockname>, BUT doesn't allow ending former blocks!
(df setblock (l)
  (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)
		 (pearlbreak)))))
 
; 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.
	rest
	currentblock)
       ; While there are more variables to process, and we haven't reached
       ;     a block, add either to "unboundalist" or "boundalist".
       (while (and oldalist
		   (reallitatom (caar oldalist)))
	      (setq rest (cdr oldalist))
	      (cond ((eq (cdar oldalist) (punbound))
		     (tconc unboundalist (car oldalist)))
		    ( t (setq boundalist (rplacd oldalist boundalist))))
	      (setq oldalist rest))
       (and oldalist
	    (rplaca unboundalist
		    (nconc (car unboundalist)
			   oldalist))) ; pointer to the enclosing blocks.
       ; Store new lists.
       (putalist (car unboundalist) struct)
       (putalistcp boundalist struct)
       ; Process blocks one at a time.
       (while oldalist
	      (setq currentblock oldalist)
	      (setq oldalist (cdr oldalist))
	      (setq unboundalist (ncons nil))
	      (setq boundalist (caar currentblock))
	      (while (and oldalist
			  (reallitatom (caar oldalist)))
		     (setq rest (cdr oldalist))
		     (cond ((eq (cdar oldalist) (punbound))
			    (tconc unboundalist (car oldalist)))
			   ( t (setq boundalist (rplacd oldalist boundalist))))
		     (setq oldalist rest))
	      (and oldalist
		   (rplaca unboundalist
			   (nconc (car unboundalist)
				  oldalist))) ; pointer to the enclosing blocks.
	      ; store frozen vars.
	      (rplaca (car currentblock) boundalist)
	      (rplacd currentblock (car unboundalist)))
       t))
 
; 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))
	rest)
       (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))))
	      (setq oldalist rest))
       (and oldalist
	    (rplaca unboundalist
		    (nconc (car unboundalist)
			   oldalist))) ; pointer to the enclosing blocks.
       (putalist (car unboundalist) struct)
       (putalistcp boundalist struct)
       t))
 
(df freezeblock (blockname)
  (let (block
	oldalist
	unboundalist
	boundalist
	rest)
       (cond ((and (boundp (blockatom (car blockname)))
		   (setq block (eval (blockatom (car blockname))))
		   (blockp block)))
	     ( t (msg t "FREEZEBLOCK: " blockname
		      " is not the name of a block." t)
		 (pearlbreak)))
       (setq oldalist (cddr block))
       (setq unboundalist (ncons nil))
       (setq boundalist (caadr block))
       (while (and oldalist
		   (reallitatom (caar oldalist)))
	      (setq rest (cdr oldalist))
	      (cond ((eq (cdar oldalist) (punbound))
		     (tconc unboundalist (car oldalist)))
		    ( t (setq boundalist (rplacd oldalist boundalist))))
	      (setq oldalist rest))
       (and oldalist
	    (rplaca unboundalist
		    (nconc (car unboundalist)
			   oldalist))) ; pointer to the enclosing blocks.
       (rplaca (cadr block) boundalist) ; store frozen vars.
       (rplacd (cdr block) (car unboundalist))
       t))
 
(dm findnextblockstart (none) ; But expects ALIST
  '(while (and alist
	       (reallitatom (caar alist)))
	  (setq alist (cdr alist))))
 
; This is for JUST THE STRUCT.
(de thawstruct (struct)
  (let ((alist (getalist struct)))
       (putalist (nconc (getalistcp struct) alist) struct)
       (putalistcp nil struct)
       t))
 
; 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)
       (putalistcp nil struct)
       (while (findnextblockstart)
	      (rplacd alist (nconc (caar alist) (cdr alist)))
	      (rplaca (car alist) nil))
       t))
 
; This is for JUST ONE BLOCK.
(df thawblock (blockname)
  (let (alist
	block)
       (cond ((and (boundp (blockatom (car blockname)))
		   (setq block (eval (blockatom (car blockname))))
		   (blockp block))
	      block)
	     ( t (msg t "THAWBLOCK: " blockname
		      " is not the name of a block." t)
		 (pearlbreak)))
       (setq alist (cddr block))
       (rplacd (cdr block) (nconc (caadr block) alist))
       (rplaca (cadr block) nil)
       t))


; vi: set lisp:
Commit	Line	Data
6cbecd82 C	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: