![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vars.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl|
Return to vars.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl |
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.