;;;   EXTBAS			-*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;;   ****************************************************************
;;;   *** MacLISP **** EXTended datatype scheme, BASic functions *****
;;;   ****************************************************************
;;;   ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;;   ****************************************************************

(herald EXTBAS /39)


(eval-when (eval compile)
  (or (get 'SUBLOAD 'VERSION)
      (load '((lisp) subload)))
  (subload EXTMAC)
  (subload DEFSETF)
 )


;; Be careful about circular dependencies!  Luckily this one is minor,
;;  and can be patched, if necessary.  (EXTEND has some SETFs in it.)
;; DEFSETF -> DEFVST -> EXTEND -> EXTMAC -> DEFSETF

(defsetf SI:XREF ((() h n) val) () `(SI:XSET ,h ,n ,val))


;; Used by typical NIL-compatibility functions
(defun SI:NON-NEG-FIXNUMP (n) (and (fixnump n) (>= N 0)))
;; Used by extend conser error checking
(defun SI:MAX-EXTEND-SIZEP (n) (and (fixnump n) (>= N 0) (< n 510.)))




;;;; Regular DEFUNitions of XREF, XSET, MAKE-EXTEND, EXTEND-LENGTH etc.

;;; SOURCE-TRAN's for XREF, XSET, MAKE-EXTEND, EXTEND-LENGTH etc.
;;;  come in from exthuk file
(eval-when (eval compile load)
  (if (status feature COMPLR)
      (subload EXTHUK))
)

;; Pass the buck to the CXR function on error checking for these guys.
(defun SI:XREF (h n) 
  (subrcall T #,(get 'CXR 'SUBR) (+ #.si:extend-q-overhead n) h))
(defun SI:XSET (h n val) 
  (subrcall T #,(get 'RPLACX 'SUBR) (+ #.si:extend-q-overhead n) h val))

(defun SI:MAKE-EXTEND (n clss)
  (if (or (or (not (fixnump n)) (< n 0) (> n 510.))
	  (not (classp clss)))
      (cond ((fboundp 'SI:CHECK-TYPER)
	      (check-type n #'SI:MAX-EXTEND-SIZEP 'SI:MAKE-EXTEND)
	      (check-type clss #'CLASSP 'SI:MAKE-EXTEND))
	    ('T (error '|Bad args to SI:MAKE-EXTEND| (list n clss)))))
   ;;Note that this must be open-compiled, either because it has a
   ;; MACRO definition, or a SOURCE-TRANS property (from EXTHUK file).
  (si:make-extend n clss))

(defun SI:make-random-extend (n &optional clss)
  (si:make-extend n clss))


(defun SI:EXTEND-LENGTH (x) 
  (if (and *RSET (not (extendp x)))
      (cond ((fboundp 'SI:CHECK-TYPER) 
	      (check-type x #'EXTENDP 'SI:EXTEND-LENGTH))
	    ('T (error '|Not an EXTEND| x))))
   ;;Note that this must be open-compiled, either because it has a
   ;; MACRO definition, or a SOURCE-TRANS property (from EXTHUK file).
  (si:extend-length x))

(let ((x (getl 'SI:EXTEND-LENGTH '(EXPR SUBR))))
  (putprop 'EXTEND-LENGTH (cadr x) (car x)))

(defun SI:EXTEND n 
  (let ((size (1- n)) 
	(clss (if (>= n 1) (arg 1))))
    (declare (fixnum size))
    (do ((obj (si:make-extend size clss))
	 (i 0 (1+ i)))
	((>= i size) obj)
      (declare (fixnum i))
        ;;(ARG 1) is class obj, (ARG 2) is first elt
      (si:xset obj i (arg (+ i 2))))))