![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vector.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to vector.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-vector-
2: "$Header: vector.l 1.5 83/07/30 15:35:51 layer Exp $")
3:
4: ;; vector handling functions -[Sun Jun 19 15:09:14 1983 by jkf]-
5: ;; [also contains closure functions]
6: ;;
7: ;; preliminary. this is subject to change at any moment.
8: ;; Don't use the functions in this file!! --jkf
9: ;;
10: ;; contains functions:
11: ;; vector{,i-byte,i-word,i-long} : create and initialize
12: ;; vref{,i-byte,i-word,i-long} : reference
13: ;; vset{,i-byte,i-word,i-long} : set
14: ;; vsize -- must write
15: ;; vsize-word
16: ;; vsize-byte
17: ;;
18: ;; references external functions
19: ;; new-vector{,i-byte,i-word,i-long
20: ;;
21: ;; references internal functions:
22: ;; int:vref 'vect 'index 'class
23: ;; int:vset 'vect 'index 'value 'class
24: ;; int:vsize 'vect
25:
26: ;--- vector
27: ; call is (vector elmt0 elmt1 ... elmtn)
28: ; creates an n-1 size vector and initializes
29: ;
30: (defmacro vector-macro (create class)
31: `(let ((vec (,create n)))
32: (do ((from n to)
33: (to (1- n) (1- to)))
34: ((< to 0))
35: (int:vset vec to (arg from) ,class))
36: vec))
37:
38: (defun vector n (vector-macro new-vector 3))
39: (defun vectori-byte n (vector-macro new-vectori-byte 0))
40: (defun vectori-word n (vector-macro new-vectori-word 1))
41: (defun vectori-long n (vector-macro new-vectori-long 2))
42:
43: ;--- vref
44: ; refernces an element of a vector
45: ; (vref 'vect 'index)
46: ;
47: (defmacro vref-macro (vector index predicate limit class)
48: `(cond ((not (,predicate ,vector))
49: ,(cond ((eq predicate 'vector)
50: `(error "vref: non vector argument " ,vector))
51: (t `(error "vref: non vectori argument " ,vector))))
52: ((not (fixp ,index))
53: (error "vref: non fixnum index " ,index))
54: ((or (< ,index 0) (not (< ,index ,limit)))
55: (error "vref: index out of range " ,index ,vector))
56: (t (int:vref ,vector ,index ,class))))
57:
58: (defun vref (vect ind)
59: (vref-macro vect ind vectorp (vsize vect) 3))
60:
61: (defun vrefi-byte (vect ind)
62: (vref-macro vect ind vectorip (vsize-byte vect) 0))
63: (defun vrefi-word (vect ind)
64: (vref-macro vect ind vectorip (vsize-word vect) 1))
65: (defun vrefi-long (vect ind)
66: (vref-macro vect ind vectorip (vsize vect) 2))
67:
68:
69: ;--- vset
70: ; use:
71: ; (vset 'vector 'index 'value)
72: ;
73: (defmacro vset-macro (vector index value predicate limit class)
74: `(cond ((not (,predicate ,vector))
75: ,(cond ((eq predicate 'vector)
76: `(error "vset: non vector argument " ,vector))
77: (t `(error "vset: non vectori argument " ,vector))))
78: ((not (fixp ,index))
79: (error "vset: non fixnum index " ,index))
80: ((or (<& ,index 0) (not (<& ,index ,limit)))
81: (error "vset: index out of range " ,index ,vector))
82: (t (int:vset ,vector ,index ,value ,class))))
83:
84: (defun vset (vect ind val)
85: (vset-macro vect ind val vectorp (vsize vect) 3))
86:
87: (defun vseti-byte (vect ind val)
88: (vset-macro vect ind val vectorip (vsize-byte vect) 0))
89:
90: (defun vseti-word (vect ind val)
91: (vset-macro vect ind val vectorip (vsize-word vect) 1))
92:
93: (defun vseti-long (vect ind val)
94: (vset-macro vect ind val vectorip (vsize vect) 2))
95:
96:
97: ;;; vector sizes
98:
99: ;--- vsize :: size of vector viewed as vector of longwords
100: ;
101: (defun vsize (vector)
102: (if (or (vectorp vector) (vectorip vector))
103: then (int:vsize vector 2)
104: else (error "vsize: non vector argument " vector)))
105:
106: (defun vsize-word (vectori)
107: (if (vectorip vectori)
108: then (int:vsize vectori 1)
109: else (error "vsize-word: non vectori argument " vectori)))
110:
111: (defun vsize-byte (vectori)
112: (if (vectorip vectori)
113: then (int:vsize vectori 0)
114: else (error "vsize-byte: non vectori argument " vectori)))
115:
116: ;; vector property list functions
117: ;;
118: (defun vget (vector ind)
119: (let ((x (vprop vector)))
120: (if (dtpr x)
121: then (get x ind))))
122:
123: ;--- vputprop :: store value, indicator pair on property list
124: ; if a non-dtpr is already there, make it the car of the list
125: ;
126: (defun vputprop (vector value ind)
127: (let ((x (vprop vector)))
128: (if (not (dtpr x))
129: then (setq x (ncons x))
130: (vsetprop vector x))
131: (putprop x value ind)))
132:
133:
134: ;; closures
135: ;
136: ;- closures are implemented in terms of vectors so we'll store the
137: ; code here for now
138: ; a closure is a vector with leader field eq to 'closure'
139: ; the 0th element of a closure vector is the functional form
140: ; to funcall
141: ; then the elements go in triplets
142: ; 1 is the symbol name
143: ; either
144: ; 2 is nil 2 is a pointer to a vector
145: ; 3 is the saved value 3 is a fixnum index into the vector
146: ; ^ ^
147: ; |---- the simple case |-- when we are sharing a value
148: ; slot, this points to the
149: ; value slot
150: ;
151: ; the size of the vector tells the number of variables.
152: ;
153:
154: ;--- closure :: make a closure
155: ; form (closure 'l_vars 'g_fcn)
156: ; l_vars is a list of symbols
157: ; g_fcn is a functional form, either a symbol or a lambda expression
158: ; alist is a list of what has been already stored so far.
159: ; it will always be non nil, so we can nconc to it to return values.
160: ;
161: (defun make-fclosure-with-alist (vars fcn alist)
162: (cond ((not (or (null vars) (dtpr vars)))
163: (error "fclosure: vars list has a bad form " vars)))
164:
165: (let ((vect (new-vector (1+ (length vars)) nil 'fclosure)))
166: (do ((xx vars (cdr xx))
167: (val)
168: (sym)
169: (i 1 (1+ i)))
170: ((null xx)
171: (setf (vref vect 0) fcn) ; store the function to call
172: vect)
173: (setq sym (car xx))
174: (cond ((not (symbolp sym))
175: (error "fclosure: non symbol in var list " sym)))
176:
177: ; don't allow the variable nil to be closed over
178: (cond ((null sym)
179: (error "fclosure: you can't close over nil " vars)))
180:
181: ; if the fclosure variable has already been given slot, use
182: ; it, else make a new one
183: (cond ((null (setq val (assq sym alist)))
184: ; if the variable is bound use it's current value,
185: ; else use nil
186: (cond ((setq val (boundp sym))
187: (setq val (cdr val))))
188: ; generate a new closure variable object
189: (setq val (cons sym (cons val (copyint* 0))))
190: ; remember this value for later fclosures
191: (nconc alist (list val))))
192: (setf (vref vect i) val))))
193:
194:
195:
196: ;--- fclosure :: generate a simple fclosure
197: ;
198: (defun fclosure (vars func)
199: (make-fclosure-with-alist vars func (list nil)))
200:
201: (defun fclosure-list n
202: (cond ((not (evenp n))
203: (error "fclosure-alist: not given an even number of arguments: "
204: (listify n))))
205: (do ((i 1 (+ i 2))
206: (alist (list nil))
207: (res))
208: ((> i n) (nreverse res))
209: (push (make-fclosure-with-alist (arg i) (arg (1+ i)) alist) res)))
210:
211: (defun fclosurep (fclosure)
212: (and (vectorp fclosure)
213: (eq 'fclosure (vprop fclosure))))
214: (defun fclosure-alist (fclosure)
215: (cond ((fclosurep fclosure)
216: (do ((xx 1 (1+ xx))
217: (lim (vsize fclosure))
218: (val)
219: (res))
220: ((not (< xx lim))
221: res)
222: (setq val (vref fclosure xx))
223: (push (cons (car val) (cadr val)) res)))
224: (t (error "fclosure-alist: non fclosure argument: " fclosure))))
225:
226:
227:
228: (defun fclosure-function (fclosure)
229: (and (fclosurep fclosure)
230: (vref fclosure 0)))
231:
232: (defun vector-dump (vect)
233: (let (size)
234: (msg "size = " (setq size (vsize vect)) ", prop= " (vprop vect) N)
235: (do ((ii 0 (1+ ii)))
236: ((not (< ii size)))
237: (msg ii ": " (vref vect ii) N ))))
238:
239:
240: ;--- symeval-in-fclosure :: determine the value of a symbol
241: ; with respect to an fclosure.
242: ;
243: (defun symeval-in-fclosure (fclosure symbol)
244: (cond ((not (fclosurep fclosure))
245: (error "set-in-fclosure: non fclosure first argument: " fclosure))
246: (t (do ((xx 1 (1+ xx))
247: (val)
248: (lim (vsize fclosure)))
249: ((not (< xx lim))
250: (error "symeval-in-fclosure: variable not found" symbol))
251: (setq val (vref fclosure xx))
252: (cond ((eq symbol (car val))
253: (return (int:fclosure-stack-stuff val))))))))
254:
255: ;--- set-in-fclosure :: set the value of a symbol in an fclosure
256: ;
257: (defun set-in-fclosure (fclosure symbol value)
258: (cond ((not (fclosurep fclosure))
259: (error "set-in-fclosure: non fclosure first argument: " fclosure))
260: (t (do ((xx 1 (1+ xx))
261: (val)
262: (lim (vsize fclosure)))
263: ((not (< xx lim))
264: (error "set-in-fclosure: variable not found" symbol))
265: (setq val (vref fclosure xx))
266: (cond ((eq symbol (car val))
267: (return (int:fclosure-stack-stuff val value))))))))
268:
269: (defmacro let-fclosed (vars function)
270: `(let ,vars (fclosure ',(mapcar #'(lambda (x) (if (atom x) x (car x))) vars)
271: ,function)))
272:
273:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.