;;;   EXTHUK			-*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;;   ****************************************************************
;;;   *** MACLISP **** EXTended datatype scheme, compiler helper *****
;;;   ****************************************************************
;;;   ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;;   ****************************************************************

(herald EXTHUK /33)

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

(declare #.`(SPECIAL ,.si:extstr-setup-classes))

(defvar SI:SKELETAL-CLASSES () "At least it wont be unbound in Old lisps")

(declare (own-symbol SI:XREF SI:XSET SI:EXTEND-LENGTH 
		     SI:EXTEND SI:MAKE-EXTEND))



(eval-when (eval compile load)
   ;;COMPLR should already have MACAID pre-loaded
(defun SI:INDEX+2-EXAMINE (h n &aux cnstntp)
   ;;A helper function for running the SI:XREF/SI:XSET macroexpansions
   ;;Presumes that arguments 'h' and 'n' have already been macroexpanded
   ;;Also needs the function 'si:evaluate-number?' from SRCTRN file
  (cond ((setq cnstntp (si:evaluate-number? n))
	   ;;Constant numerical index
	 (+ #.si:extend-q-overhead cnstntp))
	((or (|constant-p/|| h) 
	     (and (not (|side-effectsp/|| n)) 
		  (not (|side-effectsp/|| h))))
	 `(+ #.si:extend-q-overhead ,n))))
)

(defun SI:XSTUFF-expander (x)
 (values 
  (caseq (car x)
    ((SI:XREF SI:XSET)
      (if (< (length x) (if (eq (car x) 'SI:XREF) 3 4))
	  (error "Wrong no args -- source-tran-expander" x))
      (let ((h (macroexpand (cadr x)))
	    (n (macroexpand (caddr x)))
	    tmp)
	(cond ((setq tmp (si:index+2-examine h n))
	        (if (eq (car x) 'SI:XREF) 
		    `(CXR ,tmp ,h) 
		    `(RPLACX ,tmp ,h ,(cadddr x))))
	      ((let* ((htmp (si:gen-local-var () "EX"))
		      (ntmp (si:gen-local-var () "I"))
		      (indx `(+ #.si:extend-q-overhead ,ntmp))
		      (body (if (eq (car x) 'SI:XREF) 
				`(CXR ,indx ,htmp)
				`(RPLACX ,indx ,htmp ,(cadddr x)))))
		 `((LAMBDA (,htmp ,ntmp) 
		     (DECLARE (FIXNUM ,ntmp))
		     ,body)
		   ,h ,n))))))
    ((SI:MAKE-EXTEND SI:MAKE-RANDOM-EXTEND) 
       ;; This function MUST be open-compilable so that the 
       ;;  output of DEFVST doesn't require the whole world!
      (let ((size (cadr x))
	    (clss (caddr x))
	    (v (si:gen-local-var () "EX")))
	`(LET ((,v (MAKHUNK (+ ,size #.si:extend-q-overhead))))
	   (SETF #%(SI:EXTEND-CLASS-OF ,v) ,clss)
	   (SETF #%(SI:EXTEND-MARKER-OF ,v) '**SELF-EVAL**) 
	   ,v)))
    ((EXTEND-LENGTH SI:EXTEND-LENGTH)
      `(- (HUNKSIZE ,(cadr x)) #.si:extend-q-overhead))
    (SI:EXTEND  `(HUNK '**SELF-EVAL** ,@(cddr x) ,(cadr x)))
    (T (+internal-lossage 'SI:XSTUFF-expander 'SI:XSTUFF-expander x)))
  'T))


(let (z)
  (mapc #'(lambda (x)
	    (or (memq #'SI:XSTUFF-expander (setq z (get x 'SOURCE-TRANS)))
		(putprop x (cons #'SI:XSTUFF-expander z) 'SOURCE-TRANS)))
	'(SI:XREF SI:XSET SI:EXTEND-LENGTH EXTEND-LENGTH 
	  SI:MAKE-EXTEND SI:MAKE-RANDOM-EXTEND SI:EXTEND)))
 



;;Watch out for bootstrapping problems if SI:CLASS-INSTANCE-SIZE should 
;;  ever change, or if ever EXTSTR-USERATOMS-HOOK is to be applicable
;;  to objects other than hunks

(defun EXTSTR-USERATOMS-HOOK (obj)
  (declare (special SI:SKELETAL-CLASSES))
  (cond ((not (hunkp obj)) () )		;all EXTENDs are hunks!!
	((and (eq (si:extend-marker-of obj) SI:CLASS-MARKER)
	      (= (hunksize obj) 
		 #.(+ si:class-instance-size si:extend-q-overhead))
	      (if (fboundp 'CLASSP) 
		  (and (classp obj)
		       (memq (si:class-name obj) '#.si:extstr-setup-classes))
		  #.`(OR ,.(mapcar #'(lambda (x) `(EQ OBJ ,x)) 
				   si:extstr-setup-classes))))
	   ;;Special case for referencing class objects
	 `((GET ',(si:class-name obj) 'CLASS)))
	((and SI:SKELETAL-CLASSES (assq obj SI:SKELETAL-CLASSES))
	   ;; Do we ever really want to get ourselves in this predicament?
	  (let ((frob (assq obj SI:SKELETAL-CLASSES)))
	    `((OR (GET ',(si:class-name obj) 'CLASS)
		  (AND (GET 'EXTSTR 'VERSION)
		       (SI:DEFCLASS*-2 ',(si:class-name obj)
				       ',(si:class-typep obj)
				       ',(si:class-var obj)
				       ',(cadr frob)))))))
	((and (fboundp 'EXTENDP) (extendp obj)) (send obj 'USERATOMS-HOOK))))

(and (boundp 'USERATOMS-HOOKS)
     (or (memq 'EXTSTR-USERATOMS-HOOK USERATOMS-HOOKS)
	 (push 'EXTSTR-USERATOMS-HOOK USERATOMS-HOOKS)))