Return to vector.l CVS log

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

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

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.