[unix-history] / usr / lib / lisp / array.l

;;
;; array.l				-[Tue Jul  5 23:51:48 1983 by layer]-
;;
;; maclisp compatible array package.  This implements maclisp
;; compatible arrays.
;;
;; features of the new package:
;; Most array will be notype arrays.  This is because they are the most 
;; efficient in Franz.  What used to be fixnum and flonums arrays are
;; now fixnum-block and flonum-block arrays.
;; The array access functions are more specialized and much faster now.
;; The array access functions have different semantics.  Now they are
;; responsible for both accessing and storing in an array.
;; When an access function is asked to access a value, it will be given
;; the subscripts already evaluated and the array object.  These will
;; be stacked, so the array access function should be a lexpr to read them.
;; When an access function is asked to store a value that value will be
;; the first argument, the subscripts will follow and finally there will
;; be the array object.  
;; It is up to the access function to determine if it is being asked to
;; store or retrieve a value, and this determination will probably
;; be made by looking at the number of arguments.


(setq rcs-array-
   "$Header: array.l 1.5 83/07/05 23:51:58 layer Exp $")

(declare (special gcdisable)
   (macros t))

(def array
  (macro ($lis$)
	 `(*array ',(cadr $lis$) ',(caddr $lis$) ,@(cdddr $lis$))))

(def *array
  (lexpr (nargs)
	   (prog (name type rtype dims size tname numdims)

		 (cond ((lessp (setq numdims (- nargs 2)) 1)
			(error "no bounds to array declaration ")))

		 (setq name  (arg 1)
		       type  (arg 2)
		       rtype (cond ((memq type '(t nil fixnum flonum))
				    'value)
				   ((eq type 'fixnum-block)
				    'fixnum)
				   ((eq type 'flonum-block)
				    'flonum)
				   (t (error "array: bad type: " type)))
		       dims  (do ((i nargs (1- i))
				  (res nil (cons (arg i) res)))
				 ((eq i 2) res))

		       size  (apply 'times dims))

		 (cond ((null type) (setq type 'unmarked_array)))

		 ; we disable gc during the next calculation since
		 ; the data returned from small-segment is unprotected
		 ; and a gc would cause its data to be put on the 
		 ; free list.
		 (let ((gcdisable t))
		      (setq tname
			    (marray (small-segment rtype size)
				    (cond ((eq rtype 'value)
					   (cond ((eq numdims 1) 
						  (getd 'arrac-oneD))
						 ((eq numdims 2) 
						  (getd 'arrac-twoD))
						 (t (getd 'arrac-nD))))
					  (t (getd 'arrac-nD)))
				    (cons type dims)
				    size
				    (sizeof rtype))))
		 ; if type is fixnum or flonum
		 ; we must intialize to 0 or 0.0
		 (cond ((or (and (eq 'fixnum type)
				 (setq rtype 0))
			    (and (eq 'flonum type)
				 (setq rtype 0.0))
			    (and (or (status feature 68k)
				     (status feature for-68k))
				 (progn (setq rtype nil) t)))
			(do ((i size))
			    ((zerop i))
			    (set (arrayref tname (setq i (1- i))) rtype))))

		 (cond (name (putd name tname)))
		 (return tname))))

(defmacro arraycall (type array &rest indexes)
  `(funcall ,array ,@indexes))

;--- array-type :: return type of array
;
(defun array-type (arr)
   (cond ((not (arrayp arr)) (error "array-type: non array passed " arr))
	 (t (car (getaux arr)))))

; this is used by the old array scheme.  Keep this around until
; everything is recompiled

(defun ev-arraycall (type array indexes)
  (apply array indexes))


;;;---- array access functions.

; we first define a macro to evaluate a value cell.  In compiled code cdr
; is the fastest way to do this, in interpreted code the type checker 
; would not let us use cdr so we have to use eval.
(eval-when (compile)
  (defmacro value-eval (x) `(cdr ,x))  ; one level of indirection
  (defmacro simple-arrayref (arr ind) `(offset-cxr ,ind (getdata ,arr))))

(eval-when (eval)
  (defun value-eval (x) (eval x))
  (defun simple-arrayref (arr ind) (arrayref arr ind)))

;- one dimensional
(defun arrac-oneD n
  (cond ((eq n 2) (value-eval (simple-arrayref (arg 2) (arg 1))))
	((eq n 3) (set (simple-arrayref (arg 3) (arg 2)) (arg 1)))
	(t (error " wrong number of subscripts to array: " (arg n)))))

(defun arrac-twoD n
  (let ((aux (getaux (arg n))))
       (cond ((eq n 3)
	      (value-eval (simple-arrayref
			     (arg n)
			     (+ (* (arg 1) (caddr aux)) (arg 2)))))
	     ((eq n 4)
	      (set (simple-arrayref (arg n)
				    (+ (* (arg 2) (caddr aux)) (arg 3))) 
		   (arg 1)))
	     (t (error " wrong number of subscripts to array: " (arg n))))))

;-- n dimensional array access function.  
(defun arrac-nD n
  (let ((aux (getaux (arg n)))
	firstsub subs
	store
	(index 0))

       (setq subs (length (cdr aux)))
       (cond ((eq n (1+ subs))
	      (setq firstsub 1))
	     ((eq n (+ 2 subs))
	      (setq firstsub 2 store t))
	     (t (error "wrong number of subscripts to array: " (arg n))))

       (setq index (arg firstsub))
       (do ((bounds (cddr aux) (cdr bounds))
	    (i firstsub))
	   ((null bounds))
	   (setq index (+ (* index (car bounds)) (arg (setq i (1+ i))))))

       (setq subs (arrayref (arg n) index))	; get cell requested
       (cond ((memq (car aux) '(fixnum-block flonum-block))
	      (cond (store (replace subs (arg 1)))
		    (t (cpy1 subs))))
	     (t (cond (store (set subs (arg 1)))
		      (t (value-eval subs)))))))


(defmacro store ( (arrname . indexes) value)
 (do ((fnd))
     (nil)
   (cond ((eq 'funcall arrname)
	  (return `(funcall ,(car indexes) ,value . ,(cdr indexes))))
	 ((eq 'apply arrname)
	  (return `(apply ,(car indexes) (cons ,value ,@(cdr indexes)))))
	 ((eq 'arraycall arrname)
	  (return `(funcall ,(cadr indexes) ,value ,@(cddr indexes))))
	 ((arrayp arrname)
	  (return `(funcall ',arrname ,value ,@indexes))))
   (setq fnd (getd arrname))
   (cond ((or (and (dtpr fnd) (eq 'macro (car fnd)))
	      (and (bcdp fnd) (eq 'macro (getdisc fnd))))
	  (setq fnd (apply arrname (cons arrname indexes)))
	  (setq arrname (car fnd)
		indexes (cdr fnd)))
	 (t (return `(,arrname ,value . ,indexes))))))

;-- storeintern  -  there may be residual calls to storeintern from 
; old code, we handle it here.  this routine can be eliminated when
; code is recompiled

(defun storeintern (arrnam value indexes)
  (apply arrnam (cons value indexes)))

;--- small segment storage allocators.

; this function allocates segments of storage and attempt to use the whole
; block instead of throwing away what isnt used
;

(declare (special gcdisable))

(defun small-segment (type n)
  (prog (lastseg retv elementsize itemsperpage-1 gcdisable tmp)
	(setq gcdisable t) 	; its not a good idea to gc while we are
				; handling pointers to things segment returns.
	(desetq (elementsize . itemsperpage-1) (get 'segment-sizes type))
	(cond ((null elementsize) (error "small-segment: bad type " type)))
	(setq lastseg (get 'segment-types type))
	(cond ((and lastseg (not (lessp (car lastseg) n))))
	      (t ; must allocate a block of storage, want to the least number of
		 ; pages which includes n elements
		 ; there are elementsize elements per page, and 
		 ; itemsperpage-1 is the number of elements on a page minus 1 
		 (setq retv (boole 4 
				   (+ n itemsperpage-1) 
				   itemsperpage-1))  ; 4 is x & ~y
		 (setq lastseg (cons retv (maknum (segment type retv))))))
	(setq retv (cdr lastseg))
	(rplaca lastseg (- (car lastseg) n))
	(rplacd lastseg (+ (cdr lastseg) (* elementsize n)))
	(cond ((greaterp (car lastseg) 0)
	       (putprop 'segment-types lastseg type)
	       (cond ((null (setq tmp (get 'segment-arrays type)))
		      (putprop 'segment-arrays 
			       (setq tmp (marray nil nil nil nil nil))
			       type)))
	       (putdata tmp (fake (cdr lastseg)))
	       (putlength tmp (car lastseg))
	       (putdelta tmp elementsize))
	      (t  ; remove all counters since we no longer have any space
		  ; left and we can't have a zero length array
		  (remprop 'segment-types type)
		  (remprop 'segment-arrays type)))
	(return (fake retv))))

; data base for small-segment
(putprop 'segment-sizes '( 4 . 127) 'value)
(putprop 'segment-sizes '( 4 . 127) 'fixnum)
(putprop 'segment-sizes '( 8 . 63)  'flonum)


(def arraydims (lambda (arg) (cond ((symbolp arg) (getaux (getd arg)))
				   ((arrayp arg) (getaux arg))
				   (t (break '"non array arg to arraydims")))))

; fill array from list or array

(def fillarray
  (lambda (arr lis)
	  (prog (maxv typept)
		(cond ((symbolp arr) (setq arr (getd arr))))

		(cond ((symbolp lis)
		       (setq lis (getd lis))
		       (return (fillarrayarray arr lis)))

		      ((arrayp lis) (return (fillarrayarray arr lis))))

		(setq maxv (1- (getlength arr))
		      typept (cond ((memq (car (getaux arr))
					  '(t fixnum flonum unmarked_array))
				    t)
				   (t nil)))
		(do ((ls lis)
		     (i 0 (1+ i)))
		    ((>& i maxv))

		    (cond (typept (set (arrayref arr i) (car ls)))
			  (t (replace (arrayref arr i) (car ls))))

		    (cond ((cdr ls) (setq ls (cdr ls))))))))

(def fillarrayarray
  (lambda (arrto arrfrom)
	  (prog (maxv)
		(setq maxv (1- (min (getlength arrto)
				      (getlength arrfrom))))
		(do ((i 0 (1+ i)))
		    ((>& i maxv))
		    (replace (arrayref arrto i) (arrayref arrfrom i))))))

(def listarray
  (lexpr (n)
	 (prog (arr size typ ret newv)
	       (setq arr (arg 1))
	       (cond ((arrayp arr))
		     ((and (symbolp arr) (arrayp (setq arr (getd arr)))))
		     (t (error "Non array to listarray " arr)))
	       (setq size (cond ((eq n 2) (arg 2))
				(t (apply '* (cdr (arraydims arr))))))
	       (setq typ (car (getaux arr)))
	       (cond ((memq typ '(t fixnum flonum unmarked_array))
		      (setq typ t))
		     (t (setq typ nil)))
	       (do ((i (1- size) (1- i)))
		   ((lessp i 0))
		   (setq newv (arrayref arr i))
		   (setq ret (cons (cond (typ (eval newv))
					 (t (cpy1 newv)))
				   ret)))
	       (return ret))))
Commit	Line	Data
5ffa1c4c C	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))))