(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file vector
   "$Header: vector.l,v 1.11 83/11/22 10:13:48 jkf Exp $")

;;; ----	v e c t o r			vector referencing
;;;
;;;				-[Fri Nov 11 22:35:50 1983 by jkf]-


(defun cc-vset ()
   ;;  Set a vector created via 'vector'.
   (d-vset 'lisp))

(defun cc-vref ()
   ;;  Reference a vector created via 'vector'.
   (d-vref 'lisp))

(defun cc-vseti-byte ()
   ;;  Set a vector created via 'vectori-byte'.
   (d-vset 'byte))

(defun cc-vrefi-byte ()
   ;;  Reference a vector created via 'vectori-byte'.
   (d-vref 'byte))

(defun cc-vseti-word ()
   ;;  Set a vector created via 'vectori-word'.
   (d-vset 'word))

(defun cc-vrefi-word ()
   ;;  Reference a vector created via 'vectori-word'.
   (d-vref 'word))

(defun cc-vseti-long ()
   ;;  Set a vector created via 'vectori-long'.
   (d-vset 'long))

(defun cc-vrefi-long ()
   ;;  Reference a vector created via 'vectori-long'.
   (d-vref 'long))

;--- d-vset :: handle all types of vset's
(defun d-vset (type)
   ;;  Generic vector store.  Type is either 'lisp', 'byte', 'word',
   ;; or 'long'.
   (let ((vect (cadr v-form))
	 (index (caddr v-form))
	 (val (cadddr v-form))
	 (vect-addr) (index-addr)
	 (vect-val) (fetchval)
	 (temp) (size)
	 (vec-reg #+for-vax 'r0 #+for-68k 'a0)
	 (val-reg #+for-vax 'r1 #+for-68k 'd1)
	 (index-reg '#.fixnum-reg)
	 (temp-reg #+for-vax 'r4 #+for-68k 'd0)
	 (temp-areg #+for-vax 'bogus! #+for-68k 'a1)
	 (oklab (d-genlab))
	 (needlowcheck t))		; t if must check lower index bounds

       #+for-68k (d-regused '#.fixnum-reg)
       (makecomment `(doing vec set type ,type))
       (if (fixp index)
	   then (if (<& index 0)
		    then (comp-err "vector index less than 0 " v-form))
		(setq needlowcheck nil))

       ; Compute the value to be stored...
       ;
       ; If we are doing an immediate vector, then get the value
       ; instead of the boxed fixnum (in the case of byte), or
       ; word/long.
       (if (null (eq 'lisp type)) then (setq val `(cdr ,val)))

       (if (null (setq vect-val (d-simple val)))
	   then (let ((g-loc val-reg) g-cc g-ret)
		    (d-exp val))
		(setq vect-val val-reg)
	   else (setq vect-val (e-cvt vect-val)))

       ; make sure that we are not going to clobber val-reg...
       (if (not (and (d-simple vect) (d-simple index)))
	   then ; val-reg could be clobbered when we do the
		; fetching of the vector or index values
		(setq fetchval t)
		(e-move vect-val (e-cvt 'stack)))

       ; Compute the index...
       ;
       (if (setq index-addr (d-simple index))
	   then (let ((g-loc vec-reg) g-cc g-ret)
		    (d-exp vect))
		(setq vect-addr vec-reg)	; the vector op is in vec-reg
		; we really want the cdr of index (the actual number).
		; if we can do that simply, great.  otherwise we
		; bring the index into index-reg and then do the cdr ourselves
		(if (setq temp (d-simple `(cdr ,index)))
		    then (d-move temp index-reg)
		    else (d-move index-addr index-reg)
			 #+for-vax
			 (e-move `(0 ,index-reg) index-reg)
			 #+for-68k
			 (progn
			     (e-move index-reg 'a5)
			     (e-move '(0 a5) index-reg)))
		(setq index-addr index-reg)
	   else ; the index isn't computable simply, so we must
		; stack the vector location to keep it safe
		(let ((g-loc 'stack) g-cc g-ret)
		    (d-exp vect))
		(push nil g-locs)
		(incr g-loccnt)
		; compute index's value into index-reg
		(d-fixnumexp index)
		; now put vector address into vec-reg
		(d-move 'unstack vec-reg)
		(decr g-loccnt)
		(pop g-locs)
		(setq vect-addr vec-reg
		      index-addr index-reg)
		; must be sure that the cc's reflect the value of index-reg
		(e-tst index-reg))

       ;   At this point, vect-addr (always vec-reg) contains the location of
       ; the start of the vector,  index-addr (always index-reg) contains
       ; the index value.
       ;   The condition codes reflect the value of the index.
       ; First we insure that the index is non negative
       ; test must use a jmp in case the object file is large
       ;
       (if needlowcheck
	   then (e-write2 #+for-vax 'jgeq #+for-68k 'jpl oklab)
		(e-write2 'jmp 'vecindexerr)
		(e-label oklab)
		(setq oklab (d-genlab)))
       ;; now, we compare against the size of the vector
       ;; the size of the vector is in bytes, we may want to shift this
       ;; to reflect the size in words or longwords, depending on the
       ;; type of reference
       (if (eq type 'byte)
	   then ; can compare right away
		(e-cmp index-addr `(-8 ,vect-addr))
	   else ; shift size into temp-reg
		(setq size (if (eq type 'word) then 1 else 2))
		#+for-vax
		    (e-write4 'ashl (concat '$- size)
			      `(-8 ,vect-addr) temp-reg)
		#+for-68k
		(progn
		    (e-move `(-8 ,vect-addr) temp-reg)
		    (e-write3 'asrl `($ ,size) temp-reg))
		(e-cmp index-addr temp-reg)
		(d-clearreg temp-reg))
       ;; size is the number of objects, the index is 0 based so
       ;; it must be less than the vector size
       (e-write2 #+for-vax 'jlss #+for-68k 'jmi oklab)
       (e-write2 'jmp 'vecindexerr)
       (e-label oklab)

       (if fetchval
	   then ; unstack the value to store...
		(e-move (e-cvt 'unstack) val-reg)
		(setq vect-val val-reg))

       ;; if we get here then the access is in bounds
       (if (eq type 'lisp)
	   then #+for-vax
		(e-move vect-val `(0 ,vect-addr ,index-addr))
		#+for-68k
		(progn
		    (e-move index-addr temp-reg)
		    (e-write3 'asll '($ 2) temp-reg)
		    (e-add vect-addr temp-reg)
		    (e-move temp-reg temp-areg)
		    (e-move vect-val `(0 ,temp-areg)))
		(if g-loc (e-move vect-val (e-cvt g-loc)))
		(if g-cc then (d-handlecc))
	   else (setq temp (cadr (assq type '((byte movb)
					      (word movw)
					      (long movl)))))
		#+for-vax
		(e-write3 temp vect-val `(0 ,vect-addr ,index-addr))
		#+for-68k
		(progn
		    (e-move index-addr temp-reg)
		    (caseq type
			(word (e-write3 'asll '($ 1) temp-reg))
			(long (e-write3 'asll '($ 2) temp-reg)))
		    (e-write3 'lea `(% 0 ,vec-reg ,temp-reg) temp-areg)
		    (if (eq type 'long)
			then (e-write3 temp vect-val `(0 ,temp-areg))
			else (e-move vect-val 'd1)
			     (e-write3 temp 'd1 `(0 ,temp-areg))))
		(if g-loc
		    then (if (eq type 'byte)
			     then ; all bytes values are within the fixnum
				  ; range, we convert them to immediate
				  ; fixum with ease.
				  #+for-vax
				  (progn
				      (e-write4 'ashl '($ 2)
						index-reg index-reg)
				      (e-write3 'movab
						`(5120 ,index-reg)
						(e-cvt g-loc)))
				  #+for-68k
				  (progn
				      (e-move index-reg temp-reg)
				      (e-write3 'asll '($ 2) temp-reg)
				      (e-move temp-reg temp-areg)
				      (e-move
						(e-cvt '(fixnum 0))
						temp-reg)
				      (e-write3 'lea
						`(% 0 ,temp-areg ,temp-reg)
						temp-areg)
				      (e-move
						temp-areg
						(e-cvt g-loc)))
			     else ; must convert the hard way
				  (e-call-qnewint)
				  (d-clearreg)
				  (if (not (eq g-loc 'reg))
				      then (d-move 'reg g-loc)))
			 ; result is always non nil
			 (if (car g-cc) then (e-goto (car g-cc)))
		 elseif (car g-cc) then (e-goto (car g-cc))))
       (d-vectorindexcode)))

;--- d-vref :: handle all types of vref's
(defun d-vref (type)
   ;;  Generic vector reference.  Type is either 'lisp', 'byte', 'word',
   ;; or 'long'.
   (let ((vect (cadr v-form))
	 (index (caddr v-form))
	 (vect-addr) (index-addr) (temp) (size)
	 (vec-reg #+for-vax 'r0 #+for-68k 'a0)
	 (index-reg '#.fixnum-reg)
	 (temp-reg #+for-vax 'r4 #+for-68k 'd0)
	 (temp-areg #+for-vax 'rX #+for-68k 'a1)
	 (oklab (d-genlab))
	 (needlowcheck t))  ; t if must check lower index bounds

       #+for-68k (d-regused '#.fixnum-reg)
       (makecomment `(doing vec ref type ,type))
       (if (fixp index)
	   then (if (<& index 0)
		    then (comp-err "vector index less than 0 " v-form))
		(setq needlowcheck nil))

       (if (setq index-addr (d-simple index))
	   then (let ((g-loc vec-reg) g-cc g-ret)
		    (d-exp vect))
		(setq vect-addr vec-reg)	; the vector op is in vec-reg
		; we really want the cdr of index (the actual number).
		; if we can do that simply, great.  otherwise we
		; bring the index into index-reg and then do the cdr ourselves
		(if (setq temp (d-simple `(cdr ,index)))
		    then (d-move temp index-reg)
		    else (d-move index-addr index-reg)
			 #+for-vax
			 (e-move `(0 ,index-reg) index-reg)
			 #+for-68k
			 (progn
			     (e-move index-reg 'a5)
			     (e-move '(0 a5) index-reg)))
		(setq index-addr index-reg)
	   else ; the index isn't computable simply, so we must
		; stack the vector location to keep it safe
		(let ((g-loc 'stack) g-cc g-ret)
		    (d-exp vect))
		(push nil g-locs)
		(incr g-loccnt)
		; compute index's value into index-reg
		(d-fixnumexp index)
		; now put vector address into vec-reg
		(d-move 'unstack vec-reg)
		(decr g-loccnt)
		(pop g-locs)
		(setq vect-addr vec-reg
		      index-addr index-reg)
		; must be sure that the cc's reflect the value of index-reg
		(e-tst index-reg))
       
       ; at this point, vect-addr (always vec-reg) contains the location of
       ; the start of the vector,  index-addr (always index-reg) contains
       ; the index value.  the condition codes reflect the value of
       ; the index
       ; First we insure that the index is non negative
       ; test must use a jmp in case the object file is large
       (if needlowcheck
	   then (e-write2 #+for-vax 'jgeq #+for-68k 'jpl oklab)
		(e-write2 'jmp 'vecindexerr)
		(e-label oklab)
		(setq oklab (d-genlab)))

       ; now, we compare against the size of the vector
       ; the size of the vector is in bytes, we may want to shift this
       ; to reflect the size in words or longwords, depending on the
       ; type of reference
       (if (eq type 'byte)
	   then ; can compare right away
		(e-cmp index-addr `(-8 ,vect-addr))
	   else ; shift size into temp-reg
		(setq size (if (eq type 'word) then 1 else 2))
		#+for-vax
		(e-write4 'ashl (concat '$- size) `(-8 ,vect-addr) temp-reg)
		#+for-68k
		(progn
		    (e-move `(-8 ,vect-addr) temp-reg)
		    (e-write3 'asrl `($ ,size) temp-reg))
		(e-cmp index-addr temp-reg)
		(d-clearreg temp-reg))
       ; size is the number of objects, the index is 0 based so
       ; it must be less than the vector size
       (e-write2 #+for-vax 'jlss #+for-68k 'jmi oklab)
       (e-write2 'jmp 'vecindexerr)
       (e-label oklab)

       ;; if we get here then the access is in bounds
       (if g-loc
	   then ; we care about the value.
		; if the value is one of the fixnum types, then we
		; move the value to index-reg so it can be fixnum converted
		(if (eq type 'lisp)
		    then #+for-vax
			 (e-move `(0 ,vect-addr ,index-addr)
				   (e-cvt g-loc))
			 #+for-68k
			 (progn
			     (e-move index-addr temp-reg)
			     (e-write3 'asll '($ 2) temp-reg)
			     (e-add vect-addr temp-reg)
			     (e-move temp-reg temp-areg)
			     (e-move `(0 ,temp-areg) (e-cvt g-loc)))
			 (if g-cc then (d-handlecc))
		    else #+for-vax
			 (progn
			     (setq temp (cadr (assq type '((byte cvtbl)
							   (word cvtwl)
							   (long movl)))))
			     (e-write3 temp
				       `(0 ,vect-addr ,index-addr)
				       index-reg))
			 #+for-68k
			 (progn
			     (setq temp
				   (cadr (assq type '((byte movb)
						      (word movw)
						      (long movl)))))
			     (caseq type
				    (word (e-write3 'asll '($ 1) index-reg))
				    (long (e-write3 'asll '($ 2) index-reg)))
			     (e-write3 'lea `(% 0 ,vec-reg ,index-reg)
				       temp-areg)
			     (if (memq type '(byte word))
				 then (e-write2 'clrl index-reg))
			     (e-write3 temp `(0 ,temp-areg) index-reg))
			 (if (eq type 'byte)
			     then ; all bytes values are within the fixnum
				  ; range, we convert them to immediate
				  ; fixum with ease.
				  #+for-vax
				  (progn
				      (e-write4 'ashl '($ 2)
						index-reg index-reg)
				      (e-write3 'movab
						`(5120 ,index-reg)
						(e-cvt g-loc)))
				  #+for-68k
				  (progn
				      (e-write3 'asll '($ 2) index-reg)
				      (e-move index-reg temp-areg)
				      (e-move
						'($ _nilatom+0x1400)
						temp-reg)
				      (e-write3 'lea
						`(% 0 ,temp-areg ,temp-reg)
						temp-areg)
				      (e-move
						temp-areg
						(e-cvt g-loc)))
			     else ; must convert the hard way
				  (e-call-qnewint)
				  (d-clearreg)
				  (if (not (eq g-loc 'reg))
				      then (d-move 'reg g-loc)))
			 ; result is always non nil
			 (if (car g-cc) then (e-goto (car g-cc))))
	elseif g-cc
	     ; we dont care about the value, just whether it nil
	   then (if (eq type 'lisp)
		    then #+for-vax
			 (e-tst `(0 ,vect-addr ,index-addr))
			 #+for-68k
			 (progn
			     (e-move index-addr temp-reg)
			     (e-write3 'asll '($ 2) temp-reg)
			     (e-add vect-addr temp-reg)
			     (e-move temp-reg temp-areg)
			     (e-cmpnil `(0 ,temp-areg)))
			 (d-handlecc)
		    else ; if fixnum, then it is always true
			 (if (car g-cc) then (e-goto (car g-cc)))))
       (d-vectorindexcode)))

;--- d-vectorindexcode :: put out code to call the vector range error.
; At this point the vector is in r0, the index an immediate fixnum in r5
; we call the function int:vector-range-error with two arguments, the
; vector and the index.
;
(defun d-vectorindexcode ()
   (if (null g-didvectorcode)
      then (let ((afterlab (d-genlab)))
	      (e-goto afterlab)
	      (e-label 'vecindexerr)
	      (d-move #+for-vax 'r0 #+for-68k 'a0 'stack)
	      (e-call-qnewint)
	      (d-move 'reg 'stack)
	      (d-calltran 'int:vector-range-error 2)
	      ; never returns
	      (e-label afterlab))
	   (setq g-didvectorcode t)))


;------------------------ vector access functions

;--- cc-vectorp :: check for vectorness
;
(defun cc-vectorp nil
  (d-typesimp (cadr v-form) #.(immed-const 18)))

;--- cc-vectorip :: check for vectoriness
;
(defun cc-vectorip nil
  (d-typesimp (cadr v-form) #.(immed-const 19)))

;--- c-vsize :: extract vsize
;
(defun c-vsize nil
   (d-vectorsize (cadr v-form) '2))

(defun c-vsize-byte nil
   (d-vectorsize (cadr v-form) '0))

(defun c-vsize-word nil
   (d-vectorsize (cadr v-form) '1))

(defun d-vectorsize (form shift)
   (let ((g-loc #+for-vax 'reg #+for-68k 'a0)
	 g-cc
	 g-ret)
       (d-exp form))
   ; get size into `fixnum-reg' for fixnum boxing
   (if (zerop shift)
       then (e-move '(-8 #+for-vax r0 #+for-68k a0) '#.fixnum-reg)
       else #+for-vax
	    (e-write4 'ashl (concat '$- shift) '(-8 r0) '#.fixnum-reg)
	    #+for-68k
	    (progn
		(e-move '(-8 a0) '#.fixnum-reg)
		(e-write3 'asrl `($ ,shift) '#.fixnum-reg)))
   (e-call-qnewint))