(in-package "PCL")

#+kcl (import '(system:structurep))
#+lucid (import '(system:structurep system:structure-type))

(eval-when (compile)
(setq *defclass-times* '(compile load eval))
(setq *defmethod-times* '(compile load eval))
)

(defclass structure-class (pcl-class)
  ((direct-slots
    :initform ()
    :accessor class-direct-slots)
   (slots
    :initform ()
    :accessor class-slots)))

(defvar *the-class-structure-class* (find-class 'structure-class))

(eval-when (compile load eval)

;;; cache.lisp ---------------
;;;
;;;  NIL              means nothing so far, no actual arg info has NILs
;;;                   in the metatype
;;;  CLASS            seen all sorts of metaclasses
;;;                   (specifically, more than one of the next 4 values)
;;;  T                means everything so far is the class T
;;;  STANDARD-CLASS   seen only standard classes
;;;  BUILT-IN-CLASS   seen only built in classes
;;;  STRUCTURE-CLASS  seen only structure classes
;;;  
(defun raise-metatype (metatype new-specializer)
  (let ((standard  (find-class 'standard-class))
	(fsc       (find-class 'funcallable-standard-class))
	(structure (find-class 'structure-class))
	(built-in  (find-class 'built-in-class)))
    (flet ((specializer->metatype (x)
	     (let ((meta-specializer 
		     (if (eq *boot-state* 'complete)
			 (class-of (specializer-class x))
			 (class-of x))))
	       (cond ((eq x *the-class-t*) t)
		     ((*subtypep meta-specializer standard)  'standard-instance)
		     ((*subtypep meta-specializer fsc)       'standard-instance)
		     ((*subtypep meta-specializer structure) 'structure-instance)
		     ((*subtypep meta-specializer built-in)  'built-in-instance)
		     (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)."
			       new-specializer meta-specializer))))))
      ;;
      ;; We implement the following table.  The notation is
      ;; that X and Y are distinct meta specializer names.
      ;; 
      ;;   NIL    <anything>    ===>  <anything>
      ;;    X      X            ===>      X
      ;;    X      Y            ===>    CLASS
      ;;    
      (let ((new-metatype (specializer->metatype new-specializer)))
	(cond ((null metatype) new-metatype)
	      ((eq metatype new-metatype) new-metatype)
	      (t 'class))))))

(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
    (with-lap-registers ((arg t))
      (ecase metatype
	(standard-instance
	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
	    (flatten-lap
	      (opcode :move (operand :arg argument) arg)
	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
	      (opcode :go miss-label)
	      (opcode :label get-fsc-inst-wrapper)
	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
	      (and slot
		   (opcode :move (operand :fsc-slots arg) slot))
	      (opcode :go exit-emit-fetch-wrapper)
	      (opcode :label get-std-inst-wrapper)
	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
	      (and slot
		   (opcode :move (operand :std-slots arg) slot))
	      (opcode :label exit-emit-fetch-wrapper))))
	(class
	  (when slot (error "Can't do a slot reg for this metatype."))
	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
	    (flatten-lap
	      (opcode :move (operand :arg argument) arg)
	      (opcode :std-instance-p arg get-std-inst-wrapper)
	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
	      (opcode :go exit-emit-fetch-wrapper)
	      (opcode :label get-fsc-inst-wrapper)
	      (opcode :move (operand :fsc-wrapper arg) dest)
	      (opcode :go exit-emit-fetch-wrapper)
	      (opcode :label get-std-inst-wrapper)
	      (opcode :move (operand :std-wrapper arg) dest)
	      (opcode :label exit-emit-fetch-wrapper))))
	((built-in-instance structure-instance)
	  (when slot (error "Can't do a slot reg for this metatype."))
	  (let ()
	    (flatten-lap
	      (opcode :move (operand :arg argument) arg)
	      (opcode :std-instance-p arg miss-label)
	      (opcode :fsc-instance-p arg miss-label)
	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest))))))))


;;; lap.lisp ---------------

;KCL's eval-when works strangely
(eval-when (compile)
(eval '(defoperand :built-in-or-structure-wrapper (:reg)))
)

(defoperand :built-in-or-structure-wrapper (:reg))

;;; plap.lisp ---------------


(defun lap-opcode (opcode)    
  (lap-case opcode
    (:move (from to)
     `(setf ,(lap-operand to) ,(lap-operand from)))
      
    ((:eq :neq :fix=) (arg1 arg2 label)
     `(when ,(lap-operands (ecase (car opcode)
			     (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=))
			   arg1
			   arg2)
	(go ,label)))

    ((:izerop) (arg label)
     `(when ,(lap-operands 'RUNTIME\ IZEROP arg)
	(go ,label)))

    (:std-instance-p (from label)
     `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label)))
    (:fsc-instance-p (from label)
     `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label)))
    (:built-in-instance-p (from label)
     (declare (ignore from))
     `(when ,t (go ,label)))			                ;***
    (:structure-instance-p (from label)
     `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label)))	;***
    
    (:jmp (fn)
     (if (eq *lap-args* 'lap-in-lisp)
	 (error "Can't do a :JMP in LAP-IN-LISP.")
	 `(return
	    ,(if *lap-rest-p*
		 `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
		 `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*)))))

    (:return (value)
     `(return ,(lap-operand value)))
      
    (:label (label) label)
    (:go   (label)  `(go ,label))

    (:exit-lap-in-lisp () `(go exit-lap-in-lisp))
    
    (:break ()      `(break))
    (:beep  ()      #+Genera`(zl:beep))
    (:print (val)   (lap-operands 'print val))
    ))

(defun lap-operand (operand)
  (lap-case operand
    (:reg (n) (lap-reg n))
    (:cdr (reg) (lap-operands 'cdr reg))
    ((:cvar :arg) (name) name)
    (:constant (c) `',c)
    ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper
      :built-in-or-structure-wrapper :std-slots :fsc-slots)
     (x)
     (lap-operands (ecase (car operand)
		     (:std-wrapper       'RUNTIME\ STD-WRAPPER)
		     (:fsc-wrapper       'RUNTIME\ FSC-WRAPPER)
		     (:built-in-wrapper  'RUNTIME\ BUILT-IN-WRAPPER)
		     (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER)
		     (:built-in-or-structure-wrapper
		                         'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER)
		     (:std-slots         'RUNTIME\ STD-SLOTS)
		     (:fsc-slots         'RUNTIME\ FSC-SLOTS))
		   x))
    
     
    (:i1+     (index)         (lap-operands 'RUNTIME\ I1+ index))
    (:i+      (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2))
    (:i-      (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2))
    (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2))
    (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2))
    
    (:iref    (vector index)       (lap-operands 'RUNTIME\ IREF vector index))
    (:iset    (vector index value) (lap-operands 'RUNTIME\ ISET vector index value))

    (:cref   (vector i)       `(RUNTIME\ SVREF ,(lap-operand vector) ,i))
    (:lisp-variable (symbol) symbol)
    (:lisp          (form)   form)
    ))

(defmacro RUNTIME\ STRUCTURE-WRAPPER (x)
  `(structure-wrapper ,x))

(defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x)
  `(built-in-or-structure-wrapper ,x))

(defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x)
  `(structure-instance-p ,x))
)

;;; quadlap.lisp ---------------

#+(and excl sun4)
(in-package :compiler)

#+(and excl sun4)
(eval-when (compile load eval)
(defun excl-gen-quads (laps)
  ;; generate quads from the lap
  (dolist (lap laps)
    (if* *debug-sparc* then (format t ">> ~a~%" lap))
    (block again
      (let ((opcode (car lap))
	    (op1    (cadr lap))
	    (op2    (caddr lap)))
	(case opcode
	  (:move
	   ; can be either simple (both args registers)
	   ; or one arg can be complex and the other simple
	   (case (car op2)
	     (:iref
	      ;; assume that this is a lisp store
	      (warn "assuming lisp store in ~s" lap)
	      (let (op1-treg)
		(if* (not (vector-preg-p (cadr op2)))
		   then ; must offset before store
			(error "must use vector register in ~s" lap)
		   else (setq op1-treg (get-treg-of (cadr op2))))
				       
				      
		
		(qe set :u (list op1-treg
				 (get-treg-of (caddr op2))
				 (get-treg-of op1))
		    :arg :lisp)
		(return-from again)))
	     (:cdr
	      ;; it certainly is a lisp stoer
	      (let (op1-treg const-reg)
		(setq op1-treg (get-treg-of (cadr op2)))
	        (setq const-reg (new-reg))
		(qe const :arg (mdparam 'md-cons-cdr-adj) 
		    :d (list const-reg))
				       
				      
		
		(qe set :u (list op1-treg
				 const-reg
				 (get-treg-of op1))
		    :arg :lisp)
		(return-from again))))
	 
	   ; the 'to'address is simple, the from address may not be
	 
	   (let ((index1 (index-p op1))
		 (index2 (index-p op2))
		 (vector1 (vector-preg-p op1))
		 (vector2 (vector-preg-p op2)))
	     (ecase (car op1)
	       ((:reg :cvar :arg :constant :lisp-symbol)
		(qe move 
		    :u (list (get-treg-of op1 op2))
		    :d (list (get-treg-of op2))))
	       (:std-wrapper
		(qe-slot-access (cadr op1) 
				(+ (* 1 4)
				   (comp::mdparam 'md-svector-data0-adj))
				op2))
	       (:std-slots
		(qe-slot-access (cadr op1) 
				(+ (* 2 4)
				   (comp::mdparam 'md-svector-data0-adj))
				op2))
	       (:fsc-wrapper
		(qe-slot-access (cadr op1) 
				(+ (* (- 15 1) 4)
				   (comp::mdparam 'md-function-const0-adj))
				op2))
	       (:fsc-slots
		(qe-slot-access (cadr op1) 
				(+ (* (- 15 2) 4)
				   (comp::mdparam 'md-function-const0-adj))
				op2))
	       ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper)
		(qe call :arg 'pcl::built-in-or-structure-wrapper
		    :u (list (get-treg-of (cadr op1)))
		    :d (list (get-treg-of op2))))
	       (:other-wrapper
		(warn "do other-wrapper"))
	       ((:i+ :i- :ilogand :ilogxor)
		(qe arith :arg (cdr (assoc (car op1) 
					   '((:i+ . :+)
					     (:i- . :-)
					     (:ilogand . :logand)
					     (:ilogxor . :logxor))
					   :test #'eq))
		    :u (list (get-treg-of (cadr op1))
			     (get-treg-of (caddr op1)))
		    :d (list (get-treg-of op2))))
	       (:i1+
		(let ((const-reg (new-reg)))
		  (qe const :arg 4 ; an index value of 1
		      :d (list const-reg))
		  (qe arith :arg :+
		      :u (list const-reg
			       (get-treg-of (cadr op1)))
		      :d (list (get-treg-of op2)))))
		      
	       ((:iref :cref)
		(let (op1-treg)
		  (if* (not (vector-preg-p (cadr op1)))
		     then ; must offset before store
			  (error "must use vector register in ~s" lap)
		     else (setq op1-treg (get-treg-of (cadr op1))))
				       
		  (qe ref :u (list op1-treg
				   (get-treg-of (caddr op1) op2))
		      :d (list (get-treg-of op2))
		      :arg :long)))
	       (:cdr
		(let ((const-reg (new-reg)))
		  (qe const :arg (mdparam 'md-cons-cdr-adj)
		      :d (list const-reg))
		  (qe ref :arg :long
		      :u (list (get-treg-of (cadr op1))
			       const-reg)
		      :d (list (get-treg-of op2))))))
	     (if* (not (eq index1 index2))
		then (let ((shiftamt (new-reg)))
		       (qe const :arg 1 :d (list shiftamt))
		       (if* (and index1 (not index2))
			  then ; converting from index to non-index
			       (qe lsl :u (list (get-treg-of op2) shiftamt)
				   :d (list (get-treg-of op2)))
			elseif (and (not index1) index2)
			       ; converting to an index
			  then (qe lsr :u (list (get-treg-of op2) shiftamt)
				   :d (list (get-treg-of op2)))))
	      elseif (and vector2 (not vector1))
		then ; add vector offset
		     (let ((tempreg (new-reg))
			   (vreg (get-treg-of op2)))
		       (qe const :arg (mdparam 'md-svector-data0-adj)
			   :d (list tempreg))
		       (qe arith :arg :+ :u (list vreg tempreg)
			   :d (list vreg))))))
	  (:fix=
	   (let (tr1 tr2)
	     (if* (index-p op1)
		then (setq tr1 (get-treg-of op1))
		     (if* (not (index-p op2))
			then (setq tr2 (gen-index-treg op2))
			else (setq tr2 (get-treg-of op2)))
	      elseif (index-p op2)
		then ; assert: op1 isn't an index treg
		     (setq tr1 (gen-index-treg op1))
		     (setq tr2 (get-treg-of op2))
		else (setq tr1 (get-treg-of op1)
			   tr2 (get-treg-of op2)))
	   
		   
		   
	     (qe bcc :u (list tr1 tr2)
		 :arg (cadddr lap)
		 :arg2 :eq )))
	  ((:eq :neq :fix=)
	   (if* (not (eq (index-p op1) (index-p op2)))
	      then (error "non matching operands indexwise in: ~s" lap))
	   (qe bcc :u (list (get-treg-of op1)
			    (get-treg-of op2))
	       :arg (cadddr lap)
	       :arg2 (cdr (assoc opcode '((:eq . :eq)
					  (:neq . :ne))
				 :test #'eq))))
	  (:izerop 
	   (qe bcc :u (list (get-treg-of op1)
			    *zero-treg*)
	       :arg (caddr lap)
	       :arg2 :eq))
	  (:std-instance-p
	   (let ((treg (get-treg-of op1))
		 (tempreg (new-reg))
		 (temp2reg (new-reg))
		 (offsetreg (new-reg))
		 (nope (pc-genlab)))
	     (qe typecheck :u (list treg)
		 :arg nope
		 :arg2 '(not structure))
	     (qe const :arg 'pcl::std-instance :d (list tempreg))
	     (qe const :arg (mdparam 'md-svector-data0-adj) 
		 :d (list offsetreg))
	     (qe ref :u (list treg offsetreg) 
		 :d (list temp2reg)
		 :arg :long)
	     (qe bcc :arg2 :eq :u (list tempreg temp2reg)
		 :arg (caddr lap))
	     (qe label :arg nope)))
	  
	  (:fsc-instance-p
	   (let ((treg (get-treg-of op1))
		 (nope (pc-genlab))
		 (offsetreg (new-reg))
		 (tempreg (new-reg))
		 (checkreg (new-reg)))
	     (qe typecheck :u (list treg)
		 :arg nope
		 :arg2 '(not compiled-function))
	     (qe const :arg (mdparam 'md-function-flags-adj)
		 :d (list offsetreg))
	     (qe ref :u (list treg offsetreg) :d (list tempreg)
		 :arg :ubyte)
	     (qe const :arg pcl::funcallable-instance-flag-bit
		 :d (list checkreg))
	     (qe bcc :u (list checkreg tempreg)
		 :arg (caddr lap)
		 :arg2 :bit-and)
	     (qe label :arg nope)))
	  (:built-in-instance-p
	   ; always true
	   (qe bra :arg (caddr lap)))
	  (:jmp
	   (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1))))
	  (:structure-instance-p
	   ; always true
	   (qe bra :arg (caddr lap)))
	  
	  (:return
	    (let (op-treg)
	      (if* (index-p op1)
		 then ; convert to lisp before returning
		      (let ((shiftamt (new-reg)))
			(setq op-treg (new-reg))
			(qe const :arg 1 :d (list shiftamt))
			(qe lsl :u (list (get-treg-of op1) shiftamt)
			    :d (list op-treg)))
		 else (setq op-treg (get-treg-of op1)))

	      (qe move :u (list op-treg) :d *mv-treg-target*)
	      (qe return :u *mv-treg-target*)))

	  (:go
	   (qe bra :arg (cadr lap)))
	   
	  (:label 
	   (qe label :arg (cadr lap)))
	     
	   
	   
	  (t (warn "ignoring ~s" lap)))))))
)

#+(and excl sun4)
(in-package :pcl)


(eval-when (compile load eval)

;;; braid.lisp ---------------

(defvar *built-in-or-structure-wrapper-table*
  (make-hash-table :test 'eq))

(defmacro built-in-or-structure-wrapper (x)
  (once-only (x)
    `(or (gethash (type-of ,x) *built-in-or-structure-wrapper-table*)
         (built-in-or-structure-wrapper1 ,x))))

#+lucid (defvar *structure-type* nil)
#+lucid (defvar *structure-length* nil)

(defun built-in-or-structure-wrapper1 (x)
  (let ((type (type-of x)))
    (setf (gethash type *built-in-or-structure-wrapper-table*)
	  (or (and (structurep x)
		   (let* (#+lucid (*structure-type* type)
			  #+lucid (*structure-length* (system::structure-length x type))
			  (class (find-class type nil)))
		     (and class (class-wrapper class))))
	      (built-in-wrapper-of x)))))

(defun wrapper-of (x) 
  (or (and (std-instance-p x)
	   (std-instance-wrapper x))
      (and (fsc-instance-p x)
	   (fsc-instance-wrapper x))
      (built-in-or-structure-wrapper x)))

;;; ---------------

(defmethod inform-type-system-about-class ((class structure-class) name)
  nil)

(defvar *the-class-structure-object* nil)

(defmethod shared-initialize :after
	   ((class structure-class)
	    slot-names
	    &key (direct-superclasses nil direct-superclasses-p)
	         (slots nil slots-p)
		 direct-slots direct-default-initargs)
  (declare (ignore slot-names direct-slots direct-default-initargs))
  (when direct-superclasses-p
    (setf (slot-value class 'direct-superclasses)
	  (or direct-superclasses
	      (and (not (eq (class-name class) 'structure-object))
		   (list *the-class-structure-object*)))))
  (when slots-p
    (setf (slot-value class 'slots)
	  (mapcar #'(lambda (pl) (make-direct-slotd class pl)) slots))
  (add-direct-subclasses class direct-superclasses)
  (setf (slot-value class 'class-precedence-list)
	(compute-std-cpl class (class-direct-superclasses class)))
  (unless (slot-value class 'wrapper) 
    (setf (slot-value class 'wrapper) (make-wrapper class)))))

(defmethod direct-slot-definition-class ((class structure-class) initargs)
  (declare (ignore initargs))
  (find-class 'standard-effective-slot-definition))

(defmethod reinitialize-instance :before ((class structure-class)
					  &key direct-superclasses
					       direct-slots
					       direct-default-initargs)
  (declare (ignore direct-default-initargs))
  (remove-direct-subclasses class (class-direct-superclasses class)))

(defmethod reinitialize-instance :after ((class structure-class)
					 &rest initargs
					 &key)
  (map-dependents class
		  #'(lambda (dependent)
		      (apply #'update-dependent class dependent initargs))))

(defmethod finalize-inheritance ((class structure-class))
  nil) ; always finalized

)

;;; ---------------

(defclass structure-object (t)
  ()
  (:metaclass structure-class))

(eval-when (compile load eval)
(setq *the-class-structure-object* (find-class 'structure-object))

(defstruct structure-object)
)

(defun structure-wrapper (x)
  (class-wrapper (find-class (structure-type x))))

;;; macros.lisp ---------------

(defun find-class (symbol &optional (errorp t) environment)
  (declare (ignore environment))
  (or (gethash symbol *find-class*)
      (find-structure-class symbol nil)
      (cond ((null errorp) nil)
	    ((legal-class-name-p symbol)
	     (error "No class named: ~S." symbol))
	    (t
	     (error "~S is not a legal class name." symbol)))))

(defvar find-structure-class nil)

(defun find-structure-class (symbol &optional (errorp t) environment)
  (declare (ignore environment))
  (if (structure-type-p symbol)
      (unless (eq find-structure-class symbol)
	(let ((find-structure-class symbol))
	  (ensure-class symbol
			:metaclass 'structure-class
			:name symbol
			:direct-superclasses
			(when (structure-type-included-type-name symbol)
			  (list (structure-type-included-type-name symbol)))
			:slots
			(mapcar #'(lambda (slotd)
				    `(:name ,(structure-slotd-name slotd)
				      :readers (,(structure-slotd-reader slotd))
				      :writers ,(when (structure-slotd-writer slotd)
						  `(,(structure-slotd-writer slotd)))))
				(structure-type-slot-description-list symbol)))))
      (cond ((null errorp) nil)
	    ((legal-class-name-p symbol)
	     (error "No structure class named: ~S." symbol))
	    (t
	     (error "~S is not a legal structure class name." symbol)))))

;;; slots.lisp ---------------

(defmethod slot-value-using-class ((class structure-class)
                                   (object structure-object)
                                   (slotd standard-effective-slot-definition))
  (let ((readers (slotd-readers slotd)))
    (unless readers (error "No readers for this slot"))
    (let* ((reader (first readers))
	   (function (symbol-function reader)))
      (when (fsc-instance-p function)
	(error "Something is wrong: defstruct readers are not generic functions"))
      (funcall function object))))

(defmethod (setf slot-value-using-class)
	   (new-value (class structure-class)
		      (object structure-object)
		      (slotd standard-effective-slot-definition))
  (let ((writers (slotd-writers slotd)))
    (unless writers (error "The slot ~S is read-only." (slotd-name slotd)))
    (let* ((writer (first writers))
	   (function (if (symbolp writer)
			 (symbol-function writer)
			 (gdefinition writer))))
      (when (fsc-instance-p function)
	(error "Something is wrong: defstruct writers are not generic functions"))
      (funcall function new-value object))))

(defmethod slot-boundp-using-class
	   ((class structure-class) 
	    (object structure-object)
	    (slotd standard-effective-slot-definition))
  t)

(defmethod slot-makunbound-using-class
	   ((class structure-class)
	    (object structure-object)
	    (slotd standard-effective-slot-definition))
  (error "Structure slots can't be unbound"))

;;; vector.lisp --------------

(defun can-optimize-access (var required-parameters env)
  (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))
	 (parameter-or-nil (car (memq (or rebound? var) required-parameters))))
    (and parameter-or-nil
	 (let* ((class-name (caddr (variable-declaration 'class parameter-or-nil env)))
		(class (find-class class-name nil)))
	   (if (and class (memq *the-class-structure-object* (class-precedence-list class)))
	       (cons parameter-or-nil class)
	       parameter-or-nil)))))

(defun optimize-slot-value (slots parameter form)
  (destructuring-bind (ignore ignore slot-name-form)
		      form
    (let ((slot-name (eval slot-name-form)))
      (optimize-instance-access slots :read parameter slot-name nil))))

(defun optimize-set-slot-value (slots parameter form)
  (destructuring-bind (ignore ignore slot-name-form new-value)
		      form
    (let ((slot-name (eval slot-name-form)))
      (optimize-instance-access slots :write parameter slot-name new-value))))

(defun optimize-slot-boundp (slots parameter form)
  (destructuring-bind (ignore ignore slot-name-form new-value)
		      form
    (let ((slot-name (eval slot-name-form)))
      (optimize-instance-access slots :boundp parameter slot-name new-value))))

;;;
;;; The <slots> argument is an alist, the CAR of each entry is the name of
;;; a required parameter to the function.  The alist is in order, so the
;;; position of an entry in the alist corresponds to the argument's position
;;; in the lambda list.
;;; 
(defun optimize-instance-access (slots read/write parameter slot-name new-value)
  (if (consp parameter)
      (let ((parameter (car parameter))
	    (class (cdr parameter)))
	(let ((slotd (find-slot-definition class slot-name)))
	  (ecase read/write
	    (:read
	     `(,(car (slotd-readers slotd)) ,parameter))
	    (:write
	     (let ((writer (car (slotd-writers slotd))))
	       (if (consp writer)
		   `(setf (,(cadr writer) ,parameter) ,new-value)
		   `(,writer ,new-value ,parameter))))
	    (:boundp
	     'T))))
      (let* ((parameter-entry (assq parameter slots))
	     (slot-entry      (assq slot-name (cdr parameter-entry)))
	     (position (position parameter-entry slots)))
	(unless parameter-entry
	  (error "Internal error in slot optimization."))
	(unless slot-entry
	  (setq slot-entry (list slot-name))
	  (push slot-entry (cdr parameter-entry)))
	(ecase read/write
	  (:read
	   (let ((form (list 'instance-read ''.PV-OFFSET. parameter position 
			     `',slot-name)))
	     (push form (cdr slot-entry))
	     form))
	  (:write
	   (let ((form (list 'instance-write ''.PV-OFFSET. parameter position 
			     `',slot-name '.new-value.)))
	     (push form (cdr slot-entry))
	     `(let ((.new-value. ,new-value)) ,form)))
	  (:boundp
	   (let ((form (list 'instance-boundp ''.PV-OFFSET. parameter position 
			     `',slot-name)))
	     (push form (cdr slot-entry))
	     form))))))

;;; --------------

;Low level functions for structures

;Functions on arbitrary objects
; structurep
; structure-instance-p ; excludes std-instance
; structure-type
;Functions on symbols naming structures
; structure-type-p ; Excludes structures types created with the :type option
; structure-type-included-type-name
; structure-type-slot-description-list ; all slots, not just direct slots
;Functions on slot-descriptions (returned by the function above)
; structure-slotd-name        [symbol]
; structure-slotd-reader      [symbol]
; structure-slotd-writer      [symbol or list or null]
      

#+kcl
(progn

(import 'si:structurep)  

(si:define-compiler-macro structure-instance-p (x)
  (once-only (x)
    `(and (si:structurep ,x)
          (not (eq (si:%structure-name ,x) 'std-instance)))))

(defun structure-type (x)
  (and (si:structurep x)
       (si:%structure-name x)))

(si:define-compiler-macro structure-type (x)
  (once-only (x)
    `(and (si:structurep ,x)
          (si:%structure-name ,x))))

(defun structure-type-p (type)
  (let (#+akcl(s-data nil))
    (and (symbolp type)
	 #+akcl (setq s-data (get type 'si::s-data))
	 #-akcl (get type 'si::is-a-structure)
	 (null #+akcl (si::s-data-type s-data)
	       #-akcl (get type 'si::structure-type)))))

(defun structure-type-included-type-name (type)
  #+akcl (si::s-data-included (get type 'si::s-data))
  #-akcl (get type 'si::structure-include))

(defun structure-type-slot-description-list (type)
  (mapcan #'(lambda (slotd)
	      (when (and slotd (car slotd))
		(let ((offset (fifth slotd)))
		  (let ((reader #'(lambda (x)
				    #+akcl (si:structure-ref1 x offset)
				    #-akcl (si:structure-ref x type offset)))
			(writer #'(lambda (v x)
				    (si:structure-set x type offset v))))
		    #+turbo-closure (si:turbo-closure reader)
		    #+turbo-closure (si:turbo-closure writer)
		    (let ((reader-sym (make-symbol (format nil "SLOT~D" offset)))
			  (writer-sym (make-symbol (format nil "SET-SLOT~D" offset)))
			  (slot-name (first slotd))
			  (read-only-p (fourth slotd)))
		      (setf (symbol-function reader-sym) reader)
		      (setf (symbol-function writer-sym) writer)
		      (list (list slot-name
				  reader-sym
				  (and (not read-only-p) writer-sym))))))))
	  #+akcl (si::s-data-slot-descriptions (get type 'si::s-data))
	  #-akcl (get type 'si::structure-slot-descriptions)))

(defun structure-slotd-name (slotd)
  (first slotd))

(defun structure-slotd-reader (slotd)
  (second slotd))

(defun structure-slotd-writer (slotd)
  (third slotd))

)

#+lucid
(progn

(import '(system:structurep system:structure-type))

(defun structure-instance-p (x)
  (and (structurep x)
       (not (eq 'std-instance (system:structure-type x)))))

(defun structure-type-p (type)
  (let ((s-data (gethash type lucid::*defstructs*)))
    (or (and s-data (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
	(eq *structure-type* type))))

(defun structure-type-included-type-name (type)
  (let ((s-data (gethash type lucid::*defstructs*)))
    (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this

(defun structure-type-slot-description-list (type)
  (let ((s-data (gethash type lucid::*defstructs*)))
    (if s-data
	(map 'list
	     #'(lambda (slotd)
		 (let ((slot-name (system:structure-ref slotd 0 'lucid::defstruct-slot))
		       (position (system:structure-ref slotd 1 'lucid::defstruct-slot))
		       (accessor (system:structure-ref slotd 2 'lucid::defstruct-slot))
		       (read-only-p (system:structure-ref slotd 5 'lucid::defstruct-slot)))
		   (unless read-only-p
		     (setf (gdefinition `(setf ,accessor))
			   #'(lambda (v x)
			       (setf (system:structure-ref x position type) v))))
		   (list slot-name accessor (unless read-only-p `(setf ,accessor)))))
	     (structure-ref s-data 7 'defstruct))	; slots  - Fix this
	(let ((result (make-list *structure-length*)))
	  (dotimes (i *structure-length* result)
	    (let* ((name (format nil "SLOT~D" i))
		   (slot-name (intern name (or (symbol-package type) *package*)))
		   (reader (make-symbol name)))
	      (setf (symbol-function reader)
		    #'(lambda (x)
			(system:structure-ref x i type)))
	      (setf (elt result i) (list slot-name reader nil))))))))

(defun structure-slotd-name (slotd)
  (first slotd))

(defun structure-slotd-reader (slotd)
  (second slotd))

(defun structure-slotd-writer (slotd)
  (third slotd))

)