(setq rcs-vector-
   "$Header: vector.l 1.5 83/07/30 15:35:51 layer Exp $")

;; vector handling functions	-[Sun Jun 19 15:09:14 1983 by jkf]-
;; [also contains closure functions]
;;
;; preliminary.  this is subject to change at any moment.
;; Don't use the functions in this file!!	--jkf
;;
;; contains functions:
;;  vector{,i-byte,i-word,i-long}   : create and initialize
;;  vref{,i-byte,i-word,i-long}	 : reference
;;  vset{,i-byte,i-word,i-long}	 : set
;;  vsize	-- must write
;;  vsize-word
;;  vsize-byte 
;;
;; references external functions
;;  new-vector{,i-byte,i-word,i-long
;;
;; references internal functions:
;;  int:vref 'vect 'index 'class
;;  int:vset 'vect 'index 'value 'class
;;  int:vsize 'vect

;--- vector
;  call is (vector elmt0 elmt1 ... elmtn)
; creates an n-1 size vector and initializes
;
(defmacro vector-macro (create class)
   `(let ((vec (,create n)))
      (do ((from n to)
	   (to (1- n) (1- to)))
	  ((< to 0))
	  (int:vset vec to (arg from) ,class))
      vec))

(defun vector n (vector-macro new-vector 3))
(defun vectori-byte n (vector-macro new-vectori-byte 0))
(defun vectori-word n (vector-macro new-vectori-word 1))
(defun vectori-long n (vector-macro new-vectori-long 2))

;--- vref
; refernces an element of a vector
;   (vref 'vect 'index)
;
(defmacro vref-macro (vector index predicate limit class)
   `(cond ((not (,predicate ,vector))
	  ,(cond ((eq predicate 'vector)
		  `(error "vref: non vector argument " ,vector))
		 (t `(error "vref: non vectori argument " ,vector))))
	 ((not (fixp ,index))
	  (error "vref: non fixnum index " ,index))
	 ((or (< ,index 0) (not (< ,index ,limit)))
	  (error "vref: index out of range " ,index ,vector))
	 (t (int:vref ,vector ,index ,class))))

(defun vref (vect ind)
   (vref-macro vect ind vectorp (vsize vect) 3))

(defun vrefi-byte (vect ind)
   (vref-macro vect ind vectorip (vsize-byte vect) 0))
(defun vrefi-word (vect ind)
   (vref-macro vect ind vectorip (vsize-word vect) 1))
(defun vrefi-long (vect ind)
   (vref-macro vect ind vectorip (vsize vect) 2))


;--- vset
; use:
;	(vset 'vector 'index 'value)
;
(defmacro vset-macro (vector index value predicate limit class)
   `(cond ((not (,predicate ,vector))
	  ,(cond ((eq predicate 'vector)
		  `(error "vset: non vector argument " ,vector))
		 (t `(error "vset: non vectori argument " ,vector))))
	 ((not (fixp ,index))
	  (error "vset: non fixnum index " ,index))
	 ((or (<& ,index 0) (not (<& ,index ,limit)))
	  (error "vset: index out of range " ,index ,vector))
	 (t (int:vset ,vector ,index ,value ,class))))

(defun vset (vect ind val)
   (vset-macro vect ind val vectorp (vsize vect) 3))

(defun vseti-byte (vect ind val)
   (vset-macro vect ind val vectorip (vsize-byte vect) 0))

(defun vseti-word (vect ind val)
   (vset-macro vect ind val vectorip (vsize-word vect) 1))

(defun vseti-long (vect ind val)
   (vset-macro vect ind val vectorip  (vsize vect) 2))


;;; vector sizes

;--- vsize :: size of vector viewed as vector of longwords
;
(defun vsize (vector)
   (if (or (vectorp vector) (vectorip vector))
      then (int:vsize vector 2)
      else (error "vsize: non vector argument " vector)))

(defun vsize-word (vectori)
   (if (vectorip vectori)
      then (int:vsize vectori 1)
      else (error "vsize-word: non vectori argument " vectori)))

(defun vsize-byte (vectori)
   (if (vectorip vectori)
      then (int:vsize vectori 0)
      else (error "vsize-byte: non vectori argument " vectori)))

;; vector property list functions
;;
(defun vget (vector ind)
   (let ((x (vprop vector)))
      (if (dtpr x)
	 then (get x ind))))

;--- vputprop :: store value, indicator pair on property list
; if a non-dtpr is already there,  make it the car of the list
;
(defun vputprop (vector value ind)
   (let ((x (vprop vector)))
      (if (not (dtpr x))	
	 then (setq x (ncons x))
	      (vsetprop vector x))
      (putprop x value ind)))

	     
;; closures
;
;- closures are implemented in terms of vectors so we'll store the
; code here for now
;  a closure is a vector with leader field eq to 'closure'
; the 0th element of a closure vector is the functional form
; to funcall
; then the elements go in triplets
;			1 is the symbol name
;			    either
;	2 is nil 			2 is a pointer to a vector
;	3 is the saved value		3 is a fixnum index into the vector
;	 ^				   ^
;	 |---- the simple case		   |-- when we are sharing a value
;					       slot, this points to the
;					       value slot
;
; the size of the vector tells the number of variables.
;

;--- closure :: make a closure
; form (closure 'l_vars 'g_fcn)
; l_vars is a list of symbols
; g_fcn is a functional form, either a symbol or a lambda expression
; alist is a list of what has been already stored so far.
;   it will always be non nil, so we can nconc to it to return values.
;
(defun make-fclosure-with-alist (vars fcn alist)
   (cond ((not (or (null vars) (dtpr vars)))
	  (error "fclosure: vars list has a bad form " vars)))
   
   (let ((vect (new-vector (1+ (length vars)) nil 'fclosure)))
      (do ((xx vars (cdr xx))
	   (val)
	   (sym)
	   (i 1 (1+ i)))
	  ((null xx)
	   (setf (vref vect 0) fcn)	; store the function to call
	   vect)
	  (setq sym (car xx))
	  (cond ((not (symbolp sym))
		 (error "fclosure: non symbol in var list " sym)))

	  ; don't allow the variable nil to be closed over
	  (cond ((null sym)
		 (error "fclosure: you can't close over nil " vars)))

	  ; if the fclosure variable has already been given slot, use
	  ; it, else make a new one
	  (cond ((null (setq val (assq sym alist)))
		   ; if the variable is bound use it's current value,
		   ; else use nil
		   (cond ((setq val (boundp sym))
			  (setq val (cdr val))))
		   ; generate a new closure variable object
		   (setq val (cons sym (cons val (copyint* 0))))
		   ; remember this value for later fclosures
		   (nconc alist (list val))))
	  (setf (vref vect i) val))))
   


;--- fclosure :: generate a simple fclosure
; 
(defun fclosure (vars func)
   (make-fclosure-with-alist vars func (list nil)))

(defun fclosure-list n
   (cond ((not (evenp n))
	  (error "fclosure-alist: not given an even number of arguments: "
		 (listify n))))
   (do ((i 1 (+ i 2))
	(alist (list nil))
	(res))
       ((> i n) (nreverse res))
       (push (make-fclosure-with-alist (arg i) (arg (1+ i)) alist) res)))

(defun fclosurep (fclosure)
   (and (vectorp fclosure)
	(eq 'fclosure (vprop fclosure))))
(defun fclosure-alist (fclosure)
   (cond ((fclosurep fclosure)
	  (do ((xx 1 (1+ xx))
	       (lim  (vsize fclosure))
	       (val)
	       (res))
	      ((not (< xx lim))
	       res)
	      (setq val (vref fclosure xx))
	      (push (cons (car val) (cadr val)) res)))
	 (t (error "fclosure-alist: non fclosure argument: " fclosure))))



(defun fclosure-function (fclosure)
   (and (fclosurep fclosure)
	(vref fclosure 0)))

(defun vector-dump (vect)
   (let (size)
      (msg "size = " (setq size (vsize vect)) ", prop= " (vprop vect) N)
      (do ((ii 0 (1+ ii)))
	  ((not (< ii size)))
	  (msg ii ": " (vref vect ii) N ))))
   
	
;--- symeval-in-fclosure :: determine the value of a symbol
;   with respect to an fclosure.
;
(defun symeval-in-fclosure (fclosure symbol)
  (cond ((not (fclosurep fclosure))
	 (error "set-in-fclosure: non fclosure first argument: " fclosure))
	(t (do ((xx 1 (1+ xx))
		(val)
		(lim (vsize fclosure)))
	       ((not (< xx lim))
		(error "symeval-in-fclosure: variable not found" symbol))
	       (setq val (vref fclosure xx))
	       (cond ((eq symbol (car val))
		      (return (int:fclosure-stack-stuff val))))))))

;--- set-in-fclosure :: set the value of a symbol in an fclosure
;
(defun set-in-fclosure (fclosure symbol value)
  (cond ((not (fclosurep fclosure))
	 (error "set-in-fclosure: non fclosure first argument: " fclosure))
	(t (do ((xx 1 (1+ xx))
		(val)
		(lim (vsize fclosure)))
	       ((not (< xx lim))
		(error "set-in-fclosure: variable not found" symbol))
	       (setq val (vref fclosure xx))
	       (cond ((eq symbol (car val))
		      (return (int:fclosure-stack-stuff val value))))))))

(defmacro let-fclosed (vars function)
  `(let ,vars (fclosure ',(mapcar #'(lambda (x) (if (atom x) x (car x))) vars)
			,function)))