![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to scopy.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 scopy.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; scopy.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Functions for copying structures in various ways.
3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4: ; Copyright (c) 1983 , The Regents of the University of California.
5: ; All rights reserved.
6: ; Authors: Joseph Faletti and Michael Deering.
7:
8: ; Internal slot processor of SCOPY.
9: (dm scopyslot (none)
10: '(progn
11: (setq slotvalue (getslotvalue slotnum oldvalblock))
12: (selectq (setq valuetype (getslotvaluetype slotnum oldvalblock))
13: (CONSTANT (setq slotvalue (insidescopy slotvalue)))
14: (LOCAL (and (equivclassp (cdr slotvalue))
15: (progn
16: (setq oldvarcell (cdr slotvalue))
17: (setq slotvalue (cons (car slotvalue) (punbound)))))
18: (cond ((eq *any*conscell* slotvalue) nil)
19: ; Bound variable.
20: ((neq (cdr slotvalue) (punbound))
21: (setq valuetype 'CONSTANT)
22: (setq slotvalue (insidescopy (cdr slotvalue))))
23: ; Test for previously seen unbound variable.
24: ((setq newvarcell
25: (assq (car slotvalue)
26: (getalist *currenttopcopy*)))
27: (setq slotvalue newvarcell))
28: ; Otherwise it is a new unbound variable.
29: ( t (setq slotvalue
30: (addalist (car slotvalue)
31: *currenttopcopy*))
32: (and (equivclassp oldvarcell)
33: (progn
34: (rplacd slotvalue oldvarcell)
35: (rplacd oldvarcell
36: (cons slotvalue
37: (cdr oldvarcell))))))))
38: (ADJUNCT (setq oldvarcell (cdr slotvalue))
39: (setq slotvalue (insidescopy (car slotvalue)))
40: (cond ((eq *any*conscell* oldvarcell)
41: (setq slotvalue (cons slotvalue *any*conscell*)))
42: ((atom oldvarcell)
43: (setq slotvalue (cons slotvalue oldvarcell)))
44: ; Used to throw away bound adjunct variables.
45: ;((neq (cdr oldvarcell) (punbound))
46: ; (setq valuetype 'CONSTANT)
47: ; (setq slotvalue (insidescopy (car slotvalue)))
48: ; )
49: ; Test for previously seen variable.
50: ((setq newvarcell
51: (assq (car oldvarcell)
52: (getalist *currenttopcopy*)))
53: (setq slotvalue (cons slotvalue newvarcell)))
54: ; Otherwise it is a new variable.
55: ( t (setq newvarcell
56: (addalist (car oldvarcell)
57: *currenttopcopy*))
58: (setq slotvalue (cons slotvalue newvarcell)))))
59: (GLOBAL nil))
60: (putslotvaluetype slotnum valuetype valblock)
61: (putslotvalue slotnum slotvalue valblock)
62: (putpred slotnum (copy (getpred slotnum oldvalblock)) valblock)
63: (putslothooks slotnum (copy (getslothooks slotnum oldvalblock)) valblock)))
64:
65:
66: ; Internal item processor of SCOPY.
67: (de insidescopy (item)
68: (let
69: (defblock valblock length slotvalue valuetype oldvalblock
70: oldvarcell newvarcell abbrev)
71: (cond ((null item) nil)
72: ((numberp item) item) ; Integer
73: ((dtpr item) ; Lisp or Setof
74: (mapcar (function insidescopy) item))
75: ((psymbolp item) item) ; Symbol
76: ((atom item) item) ; Lisp Atom
77: ; Otherwise, an instance of a structure
78: ((structurep item)
79: (cond ((setq valblock (cdr (assq item *scopieditems*))) valblock)
80: ( t (setq oldvalblock item)
81: (setq defblock (getdefinition oldvalblock))
82: (setq valblock
83: (allocval (setq length (getstructlength defblock))))
84: (puttypetag '*pearlinst* valblock)
85: (push (cons item valblock) *scopieditems*)
86: (cond (*toplevelp*
87: (setq *currenttopcopy* valblock)
88: (setq *currentpearlstructure* valblock)
89: (initbothalists valblock)
90: (setq *currenttopalists* (getbothalists valblock))
91: ; Include the current environment in
92: ; the variable assoc-list.
93: (and *blockstack*
94: (putalist (cdar *blockstack*) valblock))
95: (setq *toplevelp* nil))
96: ( t (putbothalists *currenttopalists* valblock)))
97:
98: (putdef defblock valblock)
99: (and (setq abbrev (getabbrev oldvalblock))
100: ; Make new abbrev and store struct in abbrev.
101: (setq abbrev (eval `(newsym ,abbrev)))
102: (set abbrev valblock)
103: ; and abbrev in struct.
104: (putabbrev abbrev valblock))
105: (for slotnum 1 length
106: (scopyslot))
107: valblock))))))
108:
109: ; Copy a structure. Bound variables are replaced by their values.
110: ; Unbound variables are installed as new local variables in the
111: ; copy, subject to overruling by the current open blocks.
112: (de scopy (item)
113: (setq *scopieditems* nil)
114: (setq *toplevelp* t)
115: (insidescopy item))
116:
117:
118:
119: ; Internal slot processor of PATTERNIZE.
120: (dm patternizeslot (none)
121: '(progn
122: (setq slotvalue (getslotvalue slotnum oldvalblock))
123: (selectq (setq valuetype (getslotvaluetype slotnum oldvalblock))
124: (CONSTANT (setq slotvalue (insidepatternize slotvalue)))
125: (LOCAL (cond ((eq *any*conscell* slotvalue) nil)
126: ; Bound variable.
127: ((and (neq (cdr slotvalue) (punbound))
128: (not (equivclassp (cdr slotvalue))))
129: (setq valuetype 'CONSTANT)
130: (setq slotvalue (insidepatternize (cdr slotvalue))))
131: ; Otherwise it is an unbound variable to
132: ; be replaced by ?*any*.
133: ( t (setq slotvalue *any*conscell*))))
134: (ADJUNCT (setq slotvalue (insidepatternize (car slotvalue)))
135: (setq valuetype 'CONSTANT))
136: (GLOBAL nil))
137: (putslotvaluetype slotnum valuetype valblock)
138: (putslotvalue slotnum slotvalue valblock)
139: (putpred slotnum (copy (getpred slotnum oldvalblock)) valblock)
140: (putslothooks slotnum (copy (getslothooks slotnum oldvalblock)) valblock)))
141:
142: ; Internal item processor of PATTERNIZE.
143: (de insidepatternize (item)
144: (let
145: (defblock valblock length slotvalue valuetype oldvalblock abbrev)
146: (cond ((null item) nil)
147: ((numberp item) item) ; Integer
148: ((dtpr item) ; Setof
149: (mapcar (function insidepatternize) item))
150: ((psymbolp item) item) ; Symbol
151: ((atom item) item) ; Lisp Atom
152: ; Otherwise, an instance of a structure
153: ((structurep item)
154: (cond ((setq valblock (cdr (assq item *scopieditems*))) valblock)
155: ( t (setq oldvalblock item)
156: (setq defblock (getdefinition oldvalblock))
157: (setq valblock
158: (allocval (setq length (getstructlength defblock))))
159: (puttypetag '*pearlinst* valblock)
160: (push (cons item valblock) *scopieditems*)
161: (cond (*toplevelp*
162: (setq *currenttopcopy* valblock)
163: (setq *currentpearlstructure* valblock)
164: (initbothalists valblock)
165: (setq *currenttopalists* (getbothalists valblock))
166: ; Include the current environment in
167: ; the variable assoc-list.
168: (and *blockstack*
169: (putalist (cdar *blockstack*) valblock))
170: (setq *toplevelp* nil))
171: ( t (putbothalists *currenttopalists* valblock)))
172:
173: (putdef defblock valblock)
174: (and (setq abbrev (getabbrev oldvalblock))
175: ; Make new abbrev and store struct in abbrev.
176: (setq abbrev (eval `(newsym ,abbrev)))
177: (set abbrev valblock)
178: ; and abbrev in struct.
179: (putabbrev abbrev valblock))
180: (for slotnum 1 length
181: (patternizeslot))
182: valblock))))))
183:
184: ; Do an scopy but replace all local variables with ?*any*.
185: (de patternize (item)
186: (setq *scopieditems* nil)
187: (setq *toplevelp* t)
188: (insidepatternize item))
189:
190: ; Internal environment Scopy.
191: ; Do an scopy of <item> as if it were a recursive call within
192: ; an scopy of <outer>.
193: (de intscopy (item outer)
194: (let
195: (defblock valblock length slotvalue valuetype oldvalblock
196: newvarcell oldvarcell abbrev)
197: (setq *scopieditems* nil)
198: (cond ((null item) nil)
199: ((numberp item) item) ; Integer
200: ((dtpr item) ; Lisp or Setof
201: (mapcar (function insidescopy) item))
202: ((psymbolp item) item) ; Symbol
203: ((atom item) item) ; Lisp Atom
204: ; Otherwise, an instance of a structure
205: ((structurep item)
206: (setq oldvalblock item)
207: (setq defblock (getdefinition oldvalblock))
208: (setq valblock (allocval (setq length (getstructlength defblock))))
209: (puttypetag '*pearlinst* valblock)
210: (push (cons item valblock) *scopieditems*)
211: (initbothalists valblock)
212: (setq *currenttopcopy* outer)
213: (setq *currentpearlstructure* outer)
214: (setq *toplevelp* nil)
215: (putdef defblock valblock)
216: (and (setq abbrev (getabbrev oldvalblock))
217: ; Make new abbrev and store struct in abbrev.
218: (setq abbrev (eval `(newsym ,abbrev)))
219: (set abbrev valblock)
220: ; and abbrev in struct.
221: (putabbrev abbrev valblock))
222: (for slotnum 1 length
223: (scopyslot))
224: valblock))))
225:
226: ; Internal slot processor of VARREPLACE
227: (dm varreplaceslot (none)
228: '(progn
229: (setq slotvalue (getslotvalue slotnum item))
230: (selectq (setq valuetype (getslotvaluetype slotnum item))
231: (CONSTANT (insidevarreplace slotvalue))
232: (LOCAL (cond ((eq *any*conscell* slotvalue) nil)
233: ; Bound variable, so replace with value.
234: ((and (neq (cdr slotvalue) (punbound))
235: (not (equivclassp (cdr slotvalue))))
236: (putslotvaluetype slotnum 'CONSTANT item)
237: ; Should the value be varreplaced like this?
238: (putslotvalue slotnum
239: (insidevarreplace (cdr slotvalue))
240: item))
241: ; Otherwise an unbound variable.
242: ( t nil)))
243: (ADJUNCT (insidevarreplace (car slotvalue)))
244: (GLOBAL (and (neq (setq slotvalue (eval slotvalue)) (punbound))
245: (not (equivclassp slotvalue))
246: (progn (putslotvaluetype slotnum 'CONSTANT item)
247: (putslotvalue slotnum
248: (insidevarreplace slotvalue)
249: item)))))))
250:
251: ; Internal item processor of VARREPLACE
252: (de insidevarreplace (item)
253: (let
254: (length slotvalue valuetype)
255: (cond ((null item) nil)
256: ((numberp item) item) ; Integer
257: ((dtpr item) ; Lisp or Setof
258: (mapcar (function insidevarreplace) item))
259: ((psymbolp item) item) ; Symbol
260: ((atom item) item) ; Lisp Atom
261: ; Otherwise, an instance of a structure
262: ((structurep item)
263: (cond ((memq item *scopieditems*) item)
264: ( t (setq length (getstructlength (getdefinition item)))
265: (cond (*toplevelp*
266: (setq *currentpearlstructure* item)
267: (setq *toplevelp* nil)))
268: (push item *scopieditems*)
269: (for slotnum 1 length
270: (varreplaceslot))
271: item))))))
272:
273: ; Go through a structure replacing bound variables by their values.
274: (de varreplace (item)
275: (setq *scopieditems* nil)
276: (setq *toplevelp* t)
277: (insidevarreplace item))
278:
279:
280: ; Merge ITEM2 into ITEM1 by copying all bound slots of ITEM2 into
281: ; any unfrozen slots of ITEM1.
282: (de smerge (item1 item2)
283: (let ((defblock1 (getdefinition item1))
284: (defblock2 (getdefinition item2)))
285: (and (neq defblock1 defblock2)
286: (not (memq defblock1 (getexpansionlist defblock2)))
287: (progn (msg t "SMERGE: Values not mergeable: " item2
288: t " and " item1)
289: (pearlbreak)))
290: (prog (length oldvalue potential result newitem1 newitem2)
291: ; unbind all non-frozen vars first.
292: (mapc (funl (cell) (rplacd cell (punbound))) (getalist item1))
293: (setq length (getstructlength defblock2))
294: (setq result (punbound))
295: (dobasehooks2< '<smerge *runsmergehooks*)
296: (for slotnum 1 length
297: (setq potential (getvalue slotnum item2))
298: (setq oldvalue (getvalue slotnum item1))
299: (and (pboundp potential)
300: (not (pboundp oldvalue))
301: (progn (putslotvalue slotnum potential item1)
302: (putslotvaluetype slotnum 'CONSTANT item1))))
303: (setq result item1)
304: (dobasehooks2> '>smerge *runsmergehooks*)
305: (return result))))
306:
307:
308: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.