Return to array.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/array.l, revision 1.1

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.