![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to array.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 array.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: ;;
2: ;; array.l -[Tue Jul 5 23:51:48 1983 by layer]-
3: ;;
4: ;; maclisp compatible array package. This implements maclisp
5: ;; compatible arrays.
6: ;;
7: ;; features of the new package:
8: ;; Most array will be notype arrays. This is because they are the most
9: ;; efficient in Franz. What used to be fixnum and flonums arrays are
10: ;; now fixnum-block and flonum-block arrays.
11: ;; The array access functions are more specialized and much faster now.
12: ;; The array access functions have different semantics. Now they are
13: ;; responsible for both accessing and storing in an array.
14: ;; When an access function is asked to access a value, it will be given
15: ;; the subscripts already evaluated and the array object. These will
16: ;; be stacked, so the array access function should be a lexpr to read them.
17: ;; When an access function is asked to store a value that value will be
18: ;; the first argument, the subscripts will follow and finally there will
19: ;; be the array object.
20: ;; It is up to the access function to determine if it is being asked to
21: ;; store or retrieve a value, and this determination will probably
22: ;; be made by looking at the number of arguments.
23:
24:
25: (setq rcs-array-
26: "$Header: array.l 1.5 83/07/05 23:51:58 layer Exp $")
27:
28: (declare (special gcdisable)
29: (macros t))
30:
31: (def array
32: (macro ($lis$)
33: `(*array ',(cadr $lis$) ',(caddr $lis$) ,@(cdddr $lis$))))
34:
35: (def *array
36: (lexpr (nargs)
37: (prog (name type rtype dims size tname numdims)
38:
39: (cond ((lessp (setq numdims (- nargs 2)) 1)
40: (error "no bounds to array declaration ")))
41:
42: (setq name (arg 1)
43: type (arg 2)
44: rtype (cond ((memq type '(t nil fixnum flonum))
45: 'value)
46: ((eq type 'fixnum-block)
47: 'fixnum)
48: ((eq type 'flonum-block)
49: 'flonum)
50: (t (error "array: bad type: " type)))
51: dims (do ((i nargs (1- i))
52: (res nil (cons (arg i) res)))
53: ((eq i 2) res))
54:
55: size (apply 'times dims))
56:
57: (cond ((null type) (setq type 'unmarked_array)))
58:
59: ; we disable gc during the next calculation since
60: ; the data returned from small-segment is unprotected
61: ; and a gc would cause its data to be put on the
62: ; free list.
63: (let ((gcdisable t))
64: (setq tname
65: (marray (small-segment rtype size)
66: (cond ((eq rtype 'value)
67: (cond ((eq numdims 1)
68: (getd 'arrac-oneD))
69: ((eq numdims 2)
70: (getd 'arrac-twoD))
71: (t (getd 'arrac-nD))))
72: (t (getd 'arrac-nD)))
73: (cons type dims)
74: size
75: (sizeof rtype))))
76: ; if type is fixnum or flonum
77: ; we must intialize to 0 or 0.0
78: (cond ((or (and (eq 'fixnum type)
79: (setq rtype 0))
80: (and (eq 'flonum type)
81: (setq rtype 0.0))
82: (and (or (status feature 68k)
83: (status feature for-68k))
84: (progn (setq rtype nil) t)))
85: (do ((i size))
86: ((zerop i))
87: (set (arrayref tname (setq i (1- i))) rtype))))
88:
89: (cond (name (putd name tname)))
90: (return tname))))
91:
92: (defmacro arraycall (type array &rest indexes)
93: `(funcall ,array ,@indexes))
94:
95: ;--- array-type :: return type of array
96: ;
97: (defun array-type (arr)
98: (cond ((not (arrayp arr)) (error "array-type: non array passed " arr))
99: (t (car (getaux arr)))))
100:
101: ; this is used by the old array scheme. Keep this around until
102: ; everything is recompiled
103:
104: (defun ev-arraycall (type array indexes)
105: (apply array indexes))
106:
107:
108: ;;;---- array access functions.
109:
110: ; we first define a macro to evaluate a value cell. In compiled code cdr
111: ; is the fastest way to do this, in interpreted code the type checker
112: ; would not let us use cdr so we have to use eval.
113: (eval-when (compile)
114: (defmacro value-eval (x) `(cdr ,x)) ; one level of indirection
115: (defmacro simple-arrayref (arr ind) `(offset-cxr ,ind (getdata ,arr))))
116:
117: (eval-when (eval)
118: (defun value-eval (x) (eval x))
119: (defun simple-arrayref (arr ind) (arrayref arr ind)))
120:
121: ;- one dimensional
122: (defun arrac-oneD n
123: (cond ((eq n 2) (value-eval (simple-arrayref (arg 2) (arg 1))))
124: ((eq n 3) (set (simple-arrayref (arg 3) (arg 2)) (arg 1)))
125: (t (error " wrong number of subscripts to array: " (arg n)))))
126:
127: (defun arrac-twoD n
128: (let ((aux (getaux (arg n))))
129: (cond ((eq n 3)
130: (value-eval (simple-arrayref
131: (arg n)
132: (+ (* (arg 1) (caddr aux)) (arg 2)))))
133: ((eq n 4)
134: (set (simple-arrayref (arg n)
135: (+ (* (arg 2) (caddr aux)) (arg 3)))
136: (arg 1)))
137: (t (error " wrong number of subscripts to array: " (arg n))))))
138:
139: ;-- n dimensional array access function.
140: (defun arrac-nD n
141: (let ((aux (getaux (arg n)))
142: firstsub subs
143: store
144: (index 0))
145:
146: (setq subs (length (cdr aux)))
147: (cond ((eq n (1+ subs))
148: (setq firstsub 1))
149: ((eq n (+ 2 subs))
150: (setq firstsub 2 store t))
151: (t (error "wrong number of subscripts to array: " (arg n))))
152:
153: (setq index (arg firstsub))
154: (do ((bounds (cddr aux) (cdr bounds))
155: (i firstsub))
156: ((null bounds))
157: (setq index (+ (* index (car bounds)) (arg (setq i (1+ i))))))
158:
159: (setq subs (arrayref (arg n) index)) ; get cell requested
160: (cond ((memq (car aux) '(fixnum-block flonum-block))
161: (cond (store (replace subs (arg 1)))
162: (t (cpy1 subs))))
163: (t (cond (store (set subs (arg 1)))
164: (t (value-eval subs)))))))
165:
166:
167: (defmacro store ( (arrname . indexes) value)
168: (do ((fnd))
169: (nil)
170: (cond ((eq 'funcall arrname)
171: (return `(funcall ,(car indexes) ,value . ,(cdr indexes))))
172: ((eq 'apply arrname)
173: (return `(apply ,(car indexes) (cons ,value ,@(cdr indexes)))))
174: ((eq 'arraycall arrname)
175: (return `(funcall ,(cadr indexes) ,value ,@(cddr indexes))))
176: ((arrayp arrname)
177: (return `(funcall ',arrname ,value ,@indexes))))
178: (setq fnd (getd arrname))
179: (cond ((or (and (dtpr fnd) (eq 'macro (car fnd)))
180: (and (bcdp fnd) (eq 'macro (getdisc fnd))))
181: (setq fnd (apply arrname (cons arrname indexes)))
182: (setq arrname (car fnd)
183: indexes (cdr fnd)))
184: (t (return `(,arrname ,value . ,indexes))))))
185:
186: ;-- storeintern - there may be residual calls to storeintern from
187: ; old code, we handle it here. this routine can be eliminated when
188: ; code is recompiled
189:
190: (defun storeintern (arrnam value indexes)
191: (apply arrnam (cons value indexes)))
192:
193: ;--- small segment storage allocators.
194:
195: ; this function allocates segments of storage and attempt to use the whole
196: ; block instead of throwing away what isnt used
197: ;
198:
199: (declare (special gcdisable))
200:
201: (defun small-segment (type n)
202: (prog (lastseg retv elementsize itemsperpage-1 gcdisable tmp)
203: (setq gcdisable t) ; its not a good idea to gc while we are
204: ; handling pointers to things segment returns.
205: (desetq (elementsize . itemsperpage-1) (get 'segment-sizes type))
206: (cond ((null elementsize) (error "small-segment: bad type " type)))
207: (setq lastseg (get 'segment-types type))
208: (cond ((and lastseg (not (lessp (car lastseg) n))))
209: (t ; must allocate a block of storage, want to the least number of
210: ; pages which includes n elements
211: ; there are elementsize elements per page, and
212: ; itemsperpage-1 is the number of elements on a page minus 1
213: (setq retv (boole 4
214: (+ n itemsperpage-1)
215: itemsperpage-1)) ; 4 is x & ~y
216: (setq lastseg (cons retv (maknum (segment type retv))))))
217: (setq retv (cdr lastseg))
218: (rplaca lastseg (- (car lastseg) n))
219: (rplacd lastseg (+ (cdr lastseg) (* elementsize n)))
220: (cond ((greaterp (car lastseg) 0)
221: (putprop 'segment-types lastseg type)
222: (cond ((null (setq tmp (get 'segment-arrays type)))
223: (putprop 'segment-arrays
224: (setq tmp (marray nil nil nil nil nil))
225: type)))
226: (putdata tmp (fake (cdr lastseg)))
227: (putlength tmp (car lastseg))
228: (putdelta tmp elementsize))
229: (t ; remove all counters since we no longer have any space
230: ; left and we can't have a zero length array
231: (remprop 'segment-types type)
232: (remprop 'segment-arrays type)))
233: (return (fake retv))))
234:
235: ; data base for small-segment
236: (putprop 'segment-sizes '( 4 . 127) 'value)
237: (putprop 'segment-sizes '( 4 . 127) 'fixnum)
238: (putprop 'segment-sizes '( 8 . 63) 'flonum)
239:
240:
241: (def arraydims (lambda (arg) (cond ((symbolp arg) (getaux (getd arg)))
242: ((arrayp arg) (getaux arg))
243: (t (break '"non array arg to arraydims")))))
244:
245: ; fill array from list or array
246:
247: (def fillarray
248: (lambda (arr lis)
249: (prog (maxv typept)
250: (cond ((symbolp arr) (setq arr (getd arr))))
251:
252: (cond ((symbolp lis)
253: (setq lis (getd lis))
254: (return (fillarrayarray arr lis)))
255:
256: ((arrayp lis) (return (fillarrayarray arr lis))))
257:
258: (setq maxv (1- (getlength arr))
259: typept (cond ((memq (car (getaux arr))
260: '(t fixnum flonum unmarked_array))
261: t)
262: (t nil)))
263: (do ((ls lis)
264: (i 0 (1+ i)))
265: ((>& i maxv))
266:
267: (cond (typept (set (arrayref arr i) (car ls)))
268: (t (replace (arrayref arr i) (car ls))))
269:
270: (cond ((cdr ls) (setq ls (cdr ls))))))))
271:
272: (def fillarrayarray
273: (lambda (arrto arrfrom)
274: (prog (maxv)
275: (setq maxv (1- (min (getlength arrto)
276: (getlength arrfrom))))
277: (do ((i 0 (1+ i)))
278: ((>& i maxv))
279: (replace (arrayref arrto i) (arrayref arrfrom i))))))
280:
281: (def listarray
282: (lexpr (n)
283: (prog (arr size typ ret newv)
284: (setq arr (arg 1))
285: (cond ((arrayp arr))
286: ((and (symbolp arr) (arrayp (setq arr (getd arr)))))
287: (t (error "Non array to listarray " arr)))
288: (setq size (cond ((eq n 2) (arg 2))
289: (t (apply '* (cdr (arraydims arr))))))
290: (setq typ (car (getaux arr)))
291: (cond ((memq typ '(t fixnum flonum unmarked_array))
292: (setq typ t))
293: (t (setq typ nil)))
294: (do ((i (1- size) (1- i)))
295: ((lessp i 0))
296: (setq newv (arrayref arr i))
297: (setq ret (cons (cond (typ (eval newv))
298: (t (cpy1 newv)))
299: ret)))
300: (return ret))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.