;; array.l -[Tue Jul 5 23:51:48 1983 by layer]-
;; maclisp compatible array package. This implements maclisp
;; 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
;; 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.
"$Header: array.l 1.5 83/07/05 23:51:58 layer Exp $")
(declare (special gcdisable)
`(*array ',(cadr $lis$) ',(caddr $lis$) ,@(cdddr $lis$))))
(prog (name type rtype dims size tname numdims)
(cond ((lessp (setq numdims (- nargs 2)) 1)
(error "no bounds to array declaration ")))
rtype (cond ((memq type '(t nil fixnum flonum))
(t (error "array: bad type: " type)))
dims (do ((i nargs (1- i))
(res nil (cons (arg i) 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
(marray (small-segment rtype size)
; if type is fixnum or flonum
; we must intialize to 0 or 0.0
(cond ((or (and (eq 'fixnum type)
(and (or (status feature 68k)
(status feature for-68k))
(progn (setq rtype nil) t)))
(set (arrayref tname (setq i (1- i))) rtype))))
(cond (name (putd name tname)))
(defmacro arraycall (type array &rest indexes)
`(funcall ,array ,@indexes))
;--- array-type :: return type of array
(cond ((not (arrayp arr)) (error "array-type: non array passed " arr))
; this is used by the old array scheme. Keep this around until
; everything is recompiled
(defun ev-arraycall (type 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.
(defmacro value-eval (x) `(cdr ,x)) ; one level of indirection
(defmacro simple-arrayref (arr ind) `(offset-cxr ,ind (getdata ,arr))))
(defun value-eval (x) (eval x))
(defun simple-arrayref (arr ind) (arrayref arr ind)))
(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)))))
(let ((aux (getaux (arg n))))
(value-eval (simple-arrayref
(+ (* (arg 1) (caddr aux)) (arg 2)))))
(set (simple-arrayref (arg n)
(+ (* (arg 2) (caddr aux)) (arg 3)))
(t (error " wrong number of subscripts to array: " (arg n))))))
;-- n dimensional array access function.
(let ((aux (getaux (arg n)))
(setq subs (length (cdr aux)))
(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))
(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 (cond (store (set subs (arg 1)))
(t (value-eval subs)))))))
(defmacro store ( (arrname . indexes) value)
(cond ((eq 'funcall arrname)
(return `(funcall ,(car indexes) ,value . ,(cdr indexes))))
(return `(apply ,(car indexes) (cons ,value ,@(cdr indexes)))))
(return `(funcall ,(cadr indexes) ,value ,@(cddr indexes))))
(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)))
(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
(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
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)))
(setq tmp (marray nil nil nil nil nil))
(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)))
; 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
(cond ((symbolp arr) (setq arr (getd arr))))
(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))
(cond (typept (set (arrayref arr i) (car ls)))
(t (replace (arrayref arr i) (car ls))))
(cond ((cdr ls) (setq ls (cdr ls))))))))
(setq maxv (1- (min (getlength arrto)
(replace (arrayref arrto i) (arrayref arrfrom i))))))
(prog (arr size typ ret newv)
((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))
(do ((i (1- size) (1- i)))
(setq newv (arrayref arr i))
(setq ret (cons (cond (typ (eval newv))