;;; -*- cold-load:t; Mode:Common-Lisp; Package:SI; Base:10 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985-1989 Texas Instruments Incorporated.  All rights reserved.

;;; PHD 1/22/87 Changes parse-array-options and its caller to conform to Rel2.
;;; These variables are used by the internals of defstruct
;;; 5/31/88 clm for phd - Fixed Stanford bug report (spr 8238).  Removing the NREVERSE
;;; at the end will cause the code to be generated in the right order (structure definition 
;;; first, then constructors, accessors...).			

(defmacro using-defstruct-special-variables ()
  `(declare (special
	      name
	      size
	      include 
	      size-macro 
	      constructors  
	      print-function  
	      print 
	      default-pointer 
	      size-symbol 
	      callable-accessors  
	      property 
	      initial-offset  
	      named-found 
	      type 
	      subtype 
	      conc-name 
	      alterant 
	      named-p  
	      predicate  
	      copier
	      but-first
	      slot-alist
	      type-description
	      callable-constructors
	      clispp
	      returns
	      function-parent-declaration))) 

(defmacro with-defstruct-bindings (&body body)
  `(let (     name size
	      include 
	      size-macro 
	      constructors  
	      print-function  
	      print 
	      default-pointer 
	      size-symbol 
	      callable-accessors  
	      property 
	      initial-offset  
	      named-found 
	      type 
	      subtype 
	      conc-name 
	      alterant 
	      named-p  
	      predicate  
	      copier
	      but-first
	      slot-alist
	      type-description
	      callable-constructors
	      clispp
	      returns
	      function-parent-declaration)
     (using-defstruct-special-variables)
     ,@body))
(defconstant defstruct-empty '%defstruct-empty%)
;;;If you mung the the ordering af any of the slots in this structure,
;;;be sure to change the version slot and the definition of the function
;;;get-defstruct-description.  Munging the defstruct-slot-description 
;;;structure should also cause you to change the version "number" in this
;;;manner.
(eval-when (eval compile load)
(defstruct (defstruct-description
             (:type list)
             (:default-pointer description)
             )
  (version 'one)
  type
  dummy ;used to be the displace function
  slot-alist                                    ;of form (var-1 slot-desc-1 var-2 ...)
  named-p
  constructors
  (default-pointer nil)
  (but-first nil)
  size
  (property-alist nil)
  name
;;; The Lisp machine microcode knows the index of this slot,
;;; for TYPEP-STRUCTURE-OR-FLAVOR.
  include
  (initial-offset 0)
  (eval-when '(eval compile load))
  alterant
  (conc-name nil)
  (callable-accessors t)
  (size-macro nil)
  (size-symbol nil)
  (predicate nil)
  (copier nil)
  (print nil)
  (CALLABLE-CONSTRUCTORS NIL)                   ;defaults to T for clisp
  (SUBTYPE NIL)
  )

(defstruct (defstruct-slot-description
             (:type list)
             (:default-pointer slot-description))

  number ;slot number, the first one starts at 0, no matter if there are included slots or not.
  (ppss nil)
  (init-code defstruct-empty)
  (type defstruct-empty)	
  (property-alist nil)
  ref-macro-name
  DOCUMENTATION
  (READ-ONLY NIL)
  name-slot-p	  ;t if it is a dummy slot to store the name of the structure.
  )

(defstruct (defstruct-type-description
	     (:type list))
  named-p
  subtype-p
  accessor-code
  (ref-no-args 1) 
  (cons-expander 'make-callable-constructor)
  cons-flavor
  (cons-keywords nil)
  (named-type nil)
  (overhead 0)
  (defstruct-expander nil)
  (predicate nil)
  (copier nil)
  (DEFSTRUCT-KEYWORDS NIL)
  bare-constructor
  (macro-cons-expander 'structure-macro-cons)
  (boa-cons-expander 'make-boa-constructor)
  (macro-constructor nil)
  DOCUMENTATION
  (element-type t)
  (compatible-types-for-include nil)
  )


(defmacro emptyp (slot) `(eq ,slot defstruct-empty))

(defmacro fill-defstruct-option (slot  &optional default)
  `(if (null (emptyp value)) (setf ,slot value) ,@(if default `((setf ,slot ,default)) nil)))

(defmacro defstruct-putprop-compile-time (sym val ind)
  `(push `(defdecl ,,sym ,,ind ,,val) returns))

(defmacro defstruct-putprop (sym val ind)
  `(push `(defprop ,,sym ,,val ,,ind) returns))

(defun create-symbol (&rest args) (intern (apply #'string-append args)))

(defmacro defstruct-error (&rest msg&args)
  `(error ,@msg&args)) 
);; end of eval-when


(defun get-defstruct-description (name)
  (let ((description (getdecl name 'defstruct-description)))
    (cond ((null description)
           (defstruct-error
             "A structure with this name: ~S has not been defined" name))
          ((not (eq (defstruct-description-version) 'one))
           (error "The internal description of this structure ~S is
 incompatible with the currently loaded version of DEFSTRUCT,
 you will need to recompile its definition"
                  name))
          (t description))))

(defun defstruct-get-type-description (type)
  (using-defstruct-special-variables)
  (let ((description (get type 'defstruct-type-description)))
    (cond ((null description)
           (defstruct-error
             "A structure type with this name: ~S has not been defined" type))
          (t description))))

(defun get-defstruct-property-value (name key &optional (property property))
  (declare (special property))
  (declare (ignore name))
  (cdr (assoc key property :test #'eq))) 
	

(defmacro global:defstruct (name-and-options &rest slot-options)
  (with-defstruct-bindings
    (setf clispp nil)
    (defstruct-1 name-and-options slot-options)))

(defmacro cli:defstruct (name-and-options &rest slot-options)
  (with-defstruct-bindings
    (setf clispp t)
    (defstruct-1 name-and-options slot-options)))

;;  3/18/89 DNG - Add call to MAKE-CLASS-DEFINITION for CLOS.
(defun defstruct-1 (name-and-options slot-options)
  (using-defstruct-special-variables)
  (let (doc)
    (parse-defstruct-options  name-and-options)
    (process-type-option)
    (when include (process-include))
    (setf doc (and (stringp (car slot-options)) (pop slot-options)))
    (parse-slot-name-and-options slot-options)
     ;;; check the subtype along with the slot-alist type declaration
    (setf subtype (structure-element-type ))
    (create-function-parent-declaration)
    (make-callable-accessors)
    (make-predicate)
    (make-copier)
    (when size-symbol (push `(defconstant ,size-symbol ',size) returns))
    (make-size-macro)
    (push `(eval-when (load eval) (record-source-file-name ',name 'defstruct)) returns)
    ;;PHD 9/10/86 Fix bug, the documentation is now cleared if there is no documentation.
    (push `(setf (documentation ',name 'structure) ,doc) returns)
    (make-constructors)
    (make-alterant)
    (make-class-definition) ; make CLOS class object
    (build-structure-description)
    (make-printer))
  `(progn
     ,@returns         ;;7/6/88 clm for phd - removed call to nreverse
     ',name))

(unless (fboundp 'make-class-definition) ; dummy definition until CLOS is loaded
  (setf (symbol-function 'make-class-definition) #'ignore))

(defun defstruct-set-defaults ( name )
  (using-defstruct-special-variables)
  ;; first set dialect independent stuff
  (setq 	include  nil
	size-macro nil
	constructors  defstruct-empty
	print-function  nil
	print nil
	default-pointer nil
	size-symbol nil
	callable-accessors t 
	property nil
	initial-offset 0 
	named-found nil
;        type defstruct-empty
	subtype defstruct-empty
	but-first nil
	)

  (setq	conc-name (if clispp (string-append name "-") "")
	alterant (if clispp nil (create-symbol "ALTER-" name))
	named-p  (if clispp defstruct-empty nil)
	predicate  (if clispp  defstruct-empty nil)
	copier  (if clispp (create-symbol "COPY-" name) nil)
	callable-constructors (if clispp t nil)
	type (if clispp 'common-lisp-structure ':array)
	))

;;;PHD 3/19/87 allow for :conc-name to appear without value :conc-name <=> (:conc-name #.(string-append name "-"))
;;;AB for PHD 6/23/87 Fixed :copier option for Zetalisp.
;;;AB for PHD 6/23/87 Fixed :predicate option for Zetalisp.
;;;CLM for PHD 2/22/88 Fixed :alterant option for case where option given without argument.
(defun parse-defstruct-options  (name-and-options  &aux key value ds-options)
  (using-defstruct-special-variables)
  (if (atom name-and-options)
      (setq name name-and-options
	    ds-options ())
      (setq name (car name-and-options)
	    ds-options (rest name-and-options)))
  (defstruct-set-defaults name)
  (do ((options ds-options (cdr options)))
      ((endp options))
    (if (listp (car options))
	(progn
	  (setf key (caar options))
	  (setf value (if (cddar options)
			  (cdar options)
			  (if (cdar options)
			      (cadar options)
			      defstruct-empty))))
	(progn
	  (setf key (car options))
	  (setf value defstruct-empty)))
    (unless (keywordp key)
      (error "~S: bad option to defstruct (it must be a keyword)" key))
    (case key
	  (:default-pointer (fill-defstruct-option default-pointer name))
	  (:named (unless (emptyp value)
		    (error ":Named option does not take a value for defstruct ~S" name))
		 (setf named-p t))
	  (:conc-name
	   (fill-defstruct-option conc-name (string-append name "-")))
	  (:print
	   (fill-defstruct-option print
        	  (error ":print option requires a value for defstruct ~S" name)))
	  (:print-function
	   (fill-defstruct-option print-function
		  (error ":print-function option requires a value for defstruct ~S" name)))
	  (:include
	   (fill-defstruct-option include
		  (error ":include option requires a value for defstruct ~S" name))
	   (when (atom include) (setf include (list include))))
	  (:predicate
	   (fill-defstruct-option predicate defstruct-empty))	;PHD
	  (:constructor
	   (if (null value)
	       (fill-defstruct-option constructors)
	       (unless (emptyp value)
		 (if (emptyp constructors ) (setf constructors nil))
		 (push (if (atom (cddr (car options)))
			   (cadr (car options))
			   (cdr (car options)))
		       constructors))))
	  (:copier (fill-defstruct-option copier (create-symbol "COPY-" name)))	;PHD
	  (:alterant (fill-defstruct-option alterant (create-symbol "ALTER-" name)));phd
	  (:but-first
	   (fill-defstruct-option but-first
		 (error ":but-first option requires a value for defstruct ~S" name)))
	  (:size-symbol (fill-defstruct-option size-symbol(create-symbol name "-SIZE")))
	  (:size-macro (fill-defstruct-option size-macro (create-symbol name "-SIZE")))
	  (:callable-accessors (fill-defstruct-option callable-accessors t))
	  (:callable-constructors (fill-defstruct-option callable-constructors t))
	  (:property (when (emptyp value)
			 (error ":property option requires a value for defstruct ~S" name))
		     (push (cons value (if (cddr (car options)) (caddr (car options)) t))
			   property))
	  (:initial-offset
	   (when (or (emptyp value)
	      		     (not (integerp value)))
	     (error ":initial-offset option requires an integer argument for defstruct ~S" name))
	   (fill-defstruct-option initial-offset))
	  (:type (setq type (if (atom value)
				value
				(car value)))
		 (when (consp value) 
		     (setf subtype (if (eq (car-safe (second value)) 'quote)
				       (second (second value))
				       (second value)))))
	  (t (if (get key 'defstruct-type-description) ;; that can be a type.
		 (setf type key)
		 (push (cons key (if (emptyp value) t value))
		       property)))
	  )))




(defun parse-slot-name-and-options (slots )
  ;;; This function assumes that the included structure option and the
  ;;; initial-offset keyword has been processed the starting index must be right
  (using-defstruct-special-variables)
  (flet ((process-keywords (keywords slot)
			   (do ((keywords keywords (cddr keywords)))
			       ((null keywords))
			     (case (car keywords)
				   (:read-only
				    (if (cadr keywords)	; ...until proven wrong
					(setf (defstruct-slot-description-read-only slot) (cadr keywords))))
				   (:type
				    (setf (defstruct-slot-description-type slot) (cadr keywords)))
				   (:documentation 
				    (setf (defstruct-slot-description-documentation slot)(cadr keywords)))
				   (t
				    (error "~S: Unknown slot option for Defstruct"
					   (car keywords)))))))
    (let ((start-index (defstruct-starting-index)))
      ;; take care of the dummy name slot if necessary
      (when (and (<= 1 (defstruct-type-description-overhead type-description))
		 (not (defstruct-type-description-named-p type-description)))
	;; We do have a dummy slot
	(setf slot-alist (nconc slot-alist
				(list 
				(cons
				  (gentemp "slot-name")
				  (make-defstruct-slot-description
				  :number (name-offset)
				  :init-code `',name
				  :type 'symbol
				  :read-only t
				  :name-slot-p t))))))
      (do ((slots slots (cdr slots))
	   (index start-index  (1+ index))
	   (result nil )
	   slot)
	  ((endp slots) (progn
			  (setf size index)
			  (setf slot-alist (nconc slot-alist (nreverse result)))))
	(cond ((symbolp (car slots))
	       (push (cons (car slots) (make-defstruct-slot-description :number index))
		     result))
	      ((listp (car slots))
	       (cond ((symbolp (caar slots))
		      (push (cons (caar slots) (setf slot
						     (make-defstruct-slot-description
						       :number index
						       :init-code (cadar slots))))
			    result)
		      (process-keywords (cddar slots) slot))
		     ((consp (caar slots))
		      ;; Case of byte slots
		      (do ((slots (car slots) (cdr slots)))
			  ((endp slots))
			(unless (symbolp (first (car slots)))
			  (error "~S: Bad slot name for defstruct" (first (car slots))))
			(push (cons (caar slots )
				    (setf slot (make-defstruct-slot-description
						 :number index
						 :init-code (if (>= (length (car slots )) 3)
								(third (car slots))
								defstruct-empty)
						 
						 :ppss;  (second (car slots))    )))
					   	 (if (not (numberp (second (car slots))))   
							   (eval1 (second (car slots)))
							   (second (car slots))))))
			      result)
			(process-keywords (cdddar slots) slot)))
		     (t (error "~S: Bad thing in slot for DefStruct" (car slots)))))
	      (t (error "~S: Bad thing in slot list for DefStruct" (car slots))))))))

;;;PHD 7/8/86 Fixed starting index for named-structures with overhead like :named-array.
;;;Since we can include only compatible types if the structure has an offset, then the included
;;;one must have the same, and it needs to be accounted for only once.

(defun defstruct-starting-index ()
  (using-defstruct-special-variables)
  (+ initial-offset
     (if include
	 (+ (defstruct-description-size (get-defstruct-description (car include)))
	    (if (defstruct-type-description-named-p type-description)
		0
		(defstruct-type-description-overhead type-description)))
	 (defstruct-type-description-overhead type-description))))

(defun name-offset ()
  ;; Used only for non named-structures  named-p => nil.
  (using-defstruct-special-variables)
  (+ initial-offset
     (if include (defstruct-description-size (get-defstruct-description (car include)))
	 0)))
  


;;;Things to do: when type is (vector subtype) and :named check that subtype is supertype of symbol.
;;;It does not hurt to check that subtype is allowed.
(defun process-include ()
  (using-defstruct-special-variables)
  (let ((included-structure
	  (get-defstruct-description (car include))))
    (when (null included-structure)
      (error "included defstruct not found ~S" include))
    (unless (or (eq type (defstruct-description-type included-structure))
		(member (defstruct-description-type included-structure)
			(defstruct-type-description-compatible-types-for-include type-description)
			:test #'eq))
      (error "included  structure type is not of the same type ~S" type ))
    (setf slot-alist
	  (if (or (atom include) (null (cdr include)))
	      ;;Must preserve the old slot structure but copy just the minimum
	      (mapcar #'(lambda (x) (copy-list x))
		      (defstruct-description-slot-alist included-structure))
	      (let ((slot-alist)
		    list
		    new-slot)
		(declare (special slot-alist))
		;;parse these new slots
		(parse-slot-name-and-options (cdr include))
		;; merge the two slot-alist
		(dolist (included-slot (defstruct-description-slot-alist included-structure))
		  (if (setf new-slot (assoc (car included-slot) slot-alist :test #'eq))
		      (progn
			(setf (defstruct-slot-description-number (cdr new-slot))
			      (defstruct-slot-description-number (cdr included-slot)))
			;; should check the read-only stuff.
			(unless (eq (defstruct-slot-description-ppss (cdr new-slot))
				    (defstruct-slot-description-ppss (cdr included-slot)))
			  (error "Slot ~S is not compatible with its included structure in ~S"
				 (car new-slot) name))
			(push new-slot list)
			(setf slot-alist
			      (delete new-slot (the list slot-alist) :count 1 :test #'eq)))
		      (push (copy-list included-slot) list)))
		(unless (null slot-alist)
		  (error "Bad Include option in defstruct ~S" name))
		(nreverse list))))))

(defun process-type-option ()
  (using-defstruct-special-variables)
  (setq type-description (defstruct-get-type-description type))
  (if (emptyp named-p )
      (setf named-p  ;; Get the default from the type.
	    (defstruct-type-description-named-p type-description))
      ;; Named-p can have an effect on the type.
      (if named-p
	  (let ((new-type (defstruct-type-description-named-type type-description)))
	    (unless new-type (error "This defstruct type:~S cannot be named" type ))
	    (setf type new-type)
	    (setf type-description (defstruct-get-type-description type)))))
  (setf named-p (defstruct-type-description-named-p type-description))
    ;;; Check the subtype.
    (unless (or (emptyp subtype) (defstruct-type-description-subtype-p type-description))
      (error "The defstruct type ~S does not accept a subtype option" type))
   )

(defun supertype (x y)
  ;; returns the most general type
  (cond ((subtypep x y) y)
	((subtypep y x) x)
	(t t)))

;;AB 8/3/87.  For PHD.  Do type inferencing correctly. [SPR 6025]
(defun structure-element-type ()
  (using-defstruct-special-variables)
  (if (emptyp subtype)
      (do* ((slots slot-alist (cdr slots))
	    (tmp (defstruct-slot-description-type (cdar slots)) (defstruct-slot-description-type (cdar slots)))
	    (slot-type nil)
	    (any-declared nil))
	   ((null slots) (if any-declared slot-type defstruct-empty))
	(setf slot-type (supertype slot-type
				   (if (emptyp tmp)
				       t tmp)))
	(unless (emptyp tmp)
	  (setf any-declared t)))
      (do* ((slots slot-alist (cdr slots))
	    (tmp (defstruct-slot-description-type (cdar slots)) (defstruct-slot-description-type (cdar slots))))
	   ((null slots) subtype)
	(when (and (not (emptyp tmp))
		   (disjoint-typep tmp subtype))
	  (error "Slot type declarations ~s clash with structure type (~S ~s) " tmp type subtype)))))


(defun create-function-parent-declaration ()
 (using-defstruct-special-variables)
 (setf function-parent-declaration `(declare (function-parent ,name)
					     (unspecial ,name))	;Just in case name was special
       ))
  



(defun make-predicate ()
  (using-defstruct-special-variables)
  (let ((predicate-code (defstruct-type-description-predicate type-description )))
    (when (and (emptyp predicate) predicate-code)
      (setf predicate (create-symbol name "-P")))
    (when (and predicate (not (emptyp predicate)))
      (if predicate-code
	  (push (funcall predicate-code) returns)
	  (error "Defstruct type ~S does not accept predicate option in structure ~S" type name)))))

(defun make-size-macro ()
  (using-defstruct-special-variables)
  (when size-macro
    (push `(defmacro ,size-macro ()
       ,function-parent-declaration
       ',size)
	  returns)))

(defun make-copier ()
  (using-defstruct-special-variables)
  (if copier
      (let ((code (defstruct-type-description-copier type-description)))
	(if code (push (funcall code) returns)
	    (push `(defun ,copier (s)
		     ,function-parent-declaration
		     (copy-object s))
		  returns)))))

;;PHD 2/27/87 Clean-up named-structure-invoke when there is no print-function.
(defun make-printer ()
  ;;;General philosophy on the :print option is to not bother the
  ;;;user if printing cannot be controlled.
  (using-defstruct-special-variables)
  (if print-function
      (let ((structure (make-symbol "STRUCTURE"))
	    (stream (make-symbol "STREAM"))
	    (depth (make-symbol "DEPTH")))
	(push
	  `(defun (:property ,name named-structure-invoke) (op &rest args)
	     (case op
	       (:print-self
		(let ((,structure (car args))
		      (,stream (cadr args))
		      (,depth (caddr args)))
		;; the above "ignore" is for old callers who passed *print-escape*
		(if print-readably
		    (print-not-readable ,structure)	;not always right... Sigh
		    (funcall (function ,print-function) ,structure ,stream ,depth))))
	       (:which-operations '(:print-self))))
	  returns))
      (if print
	  (let ((stream (make-symbol "STREAM")))
	    (push 
	      `(defun (:property ,name named-structure-invoke) (op  &rest args)
		 (case op
		   (:print-self
		    (let ((,name (car args)) (,stream (cadr args)))
		      (if print-readably (print-not-readable ,name)
			  (format ,stream ,@print))))
		   (:which-operations '(:print-self))))
	      returns))
	  (progn 
	    (push `(eval-when (compile)
		     (putdecl ',name () 'named-structure-invoke))
		  returns)
	    (push `(eval-when (load eval)
		     (remprop ',name  'named-structure-invoke))
		  returns)))))


(defmacro read-only-slot-setf-method (&whole form ignore)
  ;;PHD 9/10/86 defined to fix bug #98.
  (declare (ignore ignore))
  (ferror 'sys:unknown-setf-reference
	  "The structure slot accessed by ~S has been declared read-only" (first form))
  (values))

;;;PHD 3/6/87 Fixed read-only slots.
;;;clm for DNG 03/06/89 Avoid generating a THE using the argument name in the type. [SPR 9150]
(defun make-callable-accessors ()
  (using-defstruct-special-variables)
  ;; first get the accessor code
  (let ((code (defstruct-type-description-accessor-code type-description))
	(n-args (defstruct-type-description-ref-no-args type-description)) arglist junkpart)
    ;; come up with the arglist
    (setf junkpart
	  (if (> n-args 1)
	      (mapcar #'(lambda (x)
			  x
			  (gentemp))
		      (make-list (1- n-args)))
	      ()))
    (setf arglist
	  `(,@junkpart ,@(if default-pointer
			     `(&optional (,name ,default-pointer))
			     `(,name))))
    (dolist (slot slot-alist)
      (let* ((doc (defstruct-slot-description-documentation (rest slot)))
	     (n (defstruct-slot-description-number (rest slot)))
	     (ref
	       (apply code n (append (if but-first
					 `((,but-first ,name))
					 (list name))
				     junkpart)))
	     (ppss (defstruct-slot-description-ppss (rest slot)))
	     (accessor (if conc-name
			   (create-symbol conc-name (first slot))
			   (first slot))))
	;; store accessor name in the slot-alist
	(setf (defstruct-slot-description-ref-macro-name (rest slot)) accessor)
	;; Check if it conflicts with a included one:
	(unless (or (defstruct-slot-description-name-slot-p (rest slot))
		    ;;don't create accessors for name-slots.
		  (and include
		     (eq accessor
			 (defstruct-slot-description-ref-macro-name
			   (cdr
			     (assoc (car slot)
				    (defstruct-description-slot-alist (get-defstruct-description
									(car include)))
				    :test #'eq))))))
	  ;; store accessor name in the slot-alist
	  (setf (defstruct-slot-description-ref-macro-name (rest slot)) accessor)

	  ;;; phd 11/20/85 clears the setf method property
	  (progn
	    (push `(eval-when (compile) (putdecl ',accessor () 'setf-method)) returns)
	    (push `(eval-when (load eval) (remprop ',accessor 'setf-method)) returns))
	  (if (defstruct-slot-description-read-only (rest slot))
	      (defstruct-putprop-compile-time accessor #'read-only-slot-setf-method  'setf-method))
	  (push
	    `(defsubst ,accessor ,arglist
	       ,@(if doc
		     `(,doc)
		     ())
	       ,function-parent-declaration
	       ,(if (null ppss)
		    (let ((slot-type (defstruct-slot-description-type (rest slot))))
		      (if (or (emptyp slot-type)
			      (eq slot-type name) ; SUBST-EXPAND would replace the type with the argument name.
			      (and (consp slot-type) (member name slot-type :test #'eq)))
			  ref
			`(the ,slot-type ,ref)))
		  `(ldb ,ppss ,ref)))
	    returns))))
    returns)) 
	      
	  
(defun build-structure-description ()
  ;; Build the structure after defstruct has been parsed.
  (using-defstruct-special-variables)
  (let ((description
	  (make-defstruct-description
	    :type type
	    :slot-alist slot-alist 
	    :named-p named-p
	    :constructors constructors
	    :default-pointer default-pointer
	    :but-first but-first
	    :size size
	    :property-alist property
	    :name           name
	    :include  include 
	    :initial-offset initial-offset
	    :conc-name conc-name
	    :callable-accessors callable-accessors
	    :size-macro size-macro
	    :size-symbol size-symbol
	    :predicate predicate
	    :copier copier
	    :alterant alterant
	    :print (or print-function print)      
	    :callable-constructors callable-constructors
	    :subtype subtype)))
    (defstruct-putprop-compile-time name description 'defstruct-description)))


(defmacro set-slot (code structure number value &optional ppss)
  (if ppss
      ``(if (null ,,ppss)
	    (setf ,(funcall ,code ,number ,structure ) ,,value)
	    (progn
	      (when (null ,(funcall ,code ,number ,structure ))
		(setf ,(funcall ,code ,number ,structure ) 0))
	      (setf (ldb ,,ppss
			 ,(funcall ,code ,number ,structure ))
		    ,,value)))
      ``(setf ,(funcall ,code ,number ,structure ) ,,value)))


(defun parse-array-options-for-defstruct (type name size element-type &key subtype make-array)
  (declare (ignore size))
  ;; PHD 12/1/86 Fixed :element-type and :subtype options when they are non quoted.
  ;; in charge of mixing the subtype and make-array options to come up
  ;; with the element-type of the array
  (macrolet ((check-defined ()
			    '(progn 
			       (unless (and (emptyp element-type)
					    (null type-already-defined ))
				 (error "There is too many options defining the type of the structure ~S" name))
			       (setf type-already-defined t))))
    (let* ((type-description (defstruct-get-type-description type))
	   (default-element-type (defstruct-type-description-element-type type-description))
	   (non-constant-type nil)
	   (type-already-defined nil)
	   (special-type nil) tmp)
      (when (eq 'quote (car make-array))
	(setf make-array (second make-array)))
      (setf make-array (copy-list make-array))
      (when subtype
	(check-defined)
	(if (eq 'quote (car-safe subtype))
	    (progn
	      (setf subtype (second subtype))
	      (when (and (symbolp subtype)
			 (setf tmp (position (find-symbol  subtype pkg-keyword-package)
					     (the list array-type-keywords)
					     :test #'eq)))
		;; get the corresponding element-type
		(setf subtype
		      (or (car (rassoc (nth tmp array-types) array-element-type-alist :test #'eq)) t))
		(when (eq subtype '* )
		  (setf special-type (nth tmp array-types)))))
	    (setf non-constant-type t)))
      (when (setf tmp (getf make-array :type))
	(check-defined)
	(remf make-array :type)
	(if (eq 'quote (car-safe tmp))
	    (progn
	      (setf subtype
		    (or (car (rassoc (second tmp) array-element-type-alist :test #'eq)) t))
	      (when (eq subtype '* )
		(setf special-type tmp )))
	    (setf special-type tmp 
		  non-constant-type t)))
      (when (setf tmp (getf make-array :subtype))
	(check-defined)
	(remf make-array :subtype)
	(if (eq 'quote (car-safe tmp ))
	    (setf subtype (second tmp))
	    (progn (setf non-constant-type t)
		   (setf subtype tmp))))
      (when (setf tmp (getf make-array :element-type))
	(check-defined)
	(remf make-array :element-type)
	(if (eq 'quote (car-safe tmp ))
	    (setf subtype (second tmp))
	    (progn (setf non-constant-type t)
		   (setf subtype tmp))))
      (setf element-type (or subtype default-element-type))
      (if (or non-constant-type special-type)
	  (unless (and (defstruct-type-description-subtype-p type-description)
		       (subtypep  t default-element-type))
	    (error "Slot type declarations clash with structure definition for structure ~S" name))
	  (unless (and (subtypep element-type default-element-type)
		       (or (defstruct-type-description-subtype-p type-description)
			   (subtypep default-element-type element-type)))
	    (error "Slot type declarations clash with structure definition for structure ~S" name)))
      (values (or special-type (if non-constant-type  
				   element-type
				   `(quote ,element-type))) make-array (not (null special-type))))))
    
(defun make-constructors ()
  (using-defstruct-special-variables)
  (if (emptyp constructors ) (setf constructors `(,(create-symbol "MAKE-" name))))
  (dolist (constructor constructors)
    (cond ((atom constructor)
	   (if callable-constructors
	       (funcall (defstruct-type-description-cons-expander type-description) constructor)
	       (make-macro-constructor constructor)))
	  (t (funcall (defstruct-type-description-boa-cons-expander type-description)constructor)))))

(defun make-alterant ()
  (using-defstruct-special-variables)
  (if alterant (make-alterant-macro  alterant)))

(defun check-for-byte-slots (slot-alist)
  (dolist (slot slot-alist )
    (if (defstruct-slot-description-ppss (cdr slot))
	(return t))))

(defun collect-slot-defaults (slot-alist)
  (mapcan #'(lambda (x)
	      (if (or (emptyp (defstruct-slot-description-init-code (cdr x)))
		      (defstruct-slot-description-name-slot-p (cdr x))) ;filter out dummy slot for name.
		  nil
		  (list 
		    (cons (intern (symbol-name (car x)) 'keyword)
			  (cons (defstruct-slot-description-init-code (cdr x))
				(cons (defstruct-slot-description-number (cdr x))
				      (defstruct-slot-description-ppss (cdr x))))))))
	  slot-alist))

(defun make-macro-constructor (constructor)
  (using-defstruct-special-variables)
  (push
    `(defmacro ,constructor (&rest inits)
       ,function-parent-declaration
       (funcall ',(defstruct-type-description-macro-cons-expander type-description) 
		inits ',name ',size
		',slot-alist
		',type ,(if (emptyp subtype)
			    'defstruct-empty
			    `',subtype)
		',(name-offset)
		',property))
    returns))



(defun structure-macro-cons (init-values name size slot-alist type subtype name-offset properties)
 ;;function that the macro will call to generate the code.
  (let* ((type-description (defstruct-get-type-description type))
	 (code (defstruct-type-description-accessor-code type-description))
	 keys
	 init-code slots-done
	 val
	 (cons-keywords (defstruct-type-description-cons-keywords type-description))
	 (inits (copy-list init-values))
	 )
        (declare (special inits slots-done))
    (do ((slot slot-alist (if noppss (cdr slot) slot))
	 slot-number produced-code slot-value
	 slot-description noppss)
	((null slot)
	 (do ((init-s inits (cddr init-s)))
	     ((null init-s ))
	   (if (member (car init-s) cons-keywords :test #'eq)
	       (progn
		 (push (second init-s) keys)
		 (push (car init-s) keys))
	       (unless (member (car init-s) slots-done :test #'string-equal)
		 (error "unknown defstruct keyword ~S" (car init-s))))))
      (setf slot-description (cdar slot))
      (setf slot-number (defstruct-slot-description-number slot-description))
      (if (defstruct-slot-description-ppss slot-description)
	  (progn
	    (multiple-value-setq  (produced-code slot)
				  (combine-ppss-slots slot slot-number))
	    (push (set-slot code 'structure
				  slot-number
				  produced-code )init-code)
	    (setf noppss nil))
	  (progn (unless (emptyp (setf slot-value (get-slot-value (car slot) defstruct-empty)))
		   (push (set-slot code 'structure
				   slot-number
				   slot-value) init-code))
		 (setf noppss t))))
    ;;take care of the defstruct keywords
    (dolist (key (defstruct-type-description-defstruct-keywords type-description))
      (unless (getf keys key)
       ;; already specified in the arguments of the macro
	(when (setf val (get-defstruct-property-value name key properties))
	  (push val keys)
	  (push key keys))))
    `(let ((structure
	    ,(apply (defstruct-type-description-bare-constructor type-description) name size
		    subtype name-offset keys)))
       ,@init-code
       structure))) 

(defun fixnum-macro-cons (args name size slot-alist type subtype name-offset properties)
  ;;function used to generate the macro-constructor for :fixnum 
  (declare (ignore name size type subtype properties name-offset ))
  (let ((inits (copy-list args))
	slot-description slot-number)
    (declare (special inits))
    (setf slot-description (cdar slot-alist))
    (setf slot-number (defstruct-slot-description-number slot-description))
    (if (defstruct-slot-description-ppss slot-description)
	(values (combine-ppss-slots slot-alist slot-number))
	(get-slot-value (car slot-alist) 0))))
    
(defun list-macro-cons  (args name size slot-alist type subtype name-offset properties)
  ;;function that the macro will call to generate the code.
  (declare (ignore subtype properties name-offset ))
  (let* ((inits (copy-list args))
	 (type-description(defstruct-get-type-description type))
	  produced-code slots-done
	  (list-of-values (make-list size))
	 )
    (declare (special inits slots-done))
    ;; we have to come up with the list of values and then pass it to the macro-constructor
    (do ((slot slot-alist (if noppss (cdr slot) slot))
	 slot-number 
	 slot-description noppss)
	((null slot)
	 (when inits
	   (do ((init inits (cddr init)))
	       ((null init))
	     (unless (member (car init) slots-done :test #'string-equal)
	       (error "these arguments are not recognized by the constructor of ~S" name))))
	 (funcall (defstruct-type-description-macro-constructor
				    type-description) name
				     list-of-values 
				     ))
      (setf slot-description (cdar slot))
      (setf slot-number (defstruct-slot-description-number slot-description))
      (if (defstruct-slot-description-ppss slot-description)
	  (progn
	    (multiple-value-setq  (produced-code slot)
				  (combine-ppss-slots slot slot-number))
	    (setf (nth slot-number list-of-values) produced-code)
	    (setf noppss nil))
	  (progn (setf (nth  slot-number list-of-values) (get-slot-value (car slot)))
		 (setf noppss t))))))

(defun combine-ppss-slots (slot-alist slot-number)
  (if (and slot-alist
	   (=  (defstruct-slot-description-number (cdar slot-alist))
	       slot-number))
      (multiple-value-bind (code new-slot-alist)
	  (combine-ppss-slots (cdr slot-alist) slot-number)
	(values 
	  `(dpb ,(get-slot-value (car slot-alist) 0) ,(defstruct-slot-description-ppss (cdar slot-alist))
		,code)
	  new-slot-alist))
      (values 0 slot-alist)))


(defun get-slot-value (slot &optional default)
  (declare (special inits slots-done))
  (do ((init inits (cddr init)))
      ((null init) (if (emptyp (defstruct-slot-description-init-code (cdr slot)))
		       default
		       (defstruct-slot-description-init-code (cdr slot))))
    (if (string-equal (car slot) (car init))
	(return(prog1 (cadr init)
		      (push (car init) slots-done)
		      (remf inits (car init)))))))
    
  
(defun make-boa-constructor (constructor)
  (using-defstruct-special-variables)
  (do ((arglist (cadr constructor) (cdr arglist))
       (code (defstruct-type-description-accessor-code type-description))
       (slot-done nil)
       (slot-defaults (collect-slot-defaults slot-alist))
       (conditional-setslot nil nil)
       produced-code
       optional-flag
       aux-flag
       keys
       val)
      ((null arglist)
       ;;take care of the defstruct keywords
       (dolist (key (defstruct-type-description-defstruct-keywords type-description))
	 (unless (get key keys)
	  ;; already specified in the arguments of the macro
	   (when (setf val (get-defstruct-property-value name key))
	     (push val keys)
	     (push key keys))))
       ;;; put a inline declaration if the callable-constructors is nil
       (when (null callable-constructors)
	 (push `(proclaim '(inline ,(car constructor))) returns))
       (push
	`(defun ,(car constructor) ,(cadr constructor)
	   (declare (function-parent ,name))
	   (let ((structure
		  ,(apply (defstruct-type-description-bare-constructor type-description) name
			  size subtype (name-offset) keys)))
	     ,@(and (and (not (defstruct-type-description-named-p type-description) )
			 (<= 1 (defstruct-type-description-overhead type-description)))
		    (mapcan #'(lambda (x)
				;;Filter out dummy slots used for structure names.
				(if (defstruct-slot-description-name-slot-p (cdr x))
				    (list (set-slot code 'structure
						    (defstruct-slot-description-number (cdr x))
						    (defstruct-slot-description-init-code (cdr x))))
				    nil))
			    slot-alist))
	     ,@(do ((defaults slot-defaults (cdr defaults)))
		   ((null defaults)
		    produced-code)
		 (unless (member (caar defaults) slot-done :test #'eq)
		   (push
		    (if (check-for-byte-slots slot-alist)
		      (if (null (cdddar defaults))
			(set-slot code 'structure (caddar defaults) (cadar defaults))
			(set-slot code 'structure (caddar defaults) (cadar defaults)
			   (cdddar defaults)))
		      (set-slot code 'structure (caddar defaults) (cadar defaults)))
		    produced-code)))
	     structure))
	returns))
    (let* ((arg (car arglist))
	   (mostarg (if (atom arg)
		      arg
		      (car arg)))
	   slot-description)
      (if (not (member arg '(&optional &rest &aux) :test #'eq))
	(if (setq slot-description (cdr (assoc mostarg slot-alist :test #'eq)))
	  (progn
	    (when (and optional-flag (eq mostarg arg))
	      (if (not (emptyp (defstruct-slot-description-init-code slot-description)))
	       ;; a default value is added to the arglist
		(setf (car arglist)
		      (setf arg
			    (list mostarg
				  (defstruct-slot-description-init-code slot-description))))
		(progn
		  (setf (car arglist)
			(setf arg (list mostarg () (create-symbol mostarg "-SUPPLIED-P"))))
		  (setf conditional-setslot t))))
	    (unless (and aux-flag (eq mostarg arg))
	     ;; if an arg is an aux without default , the corresponding slot will never be initialized.
	      (push
	       (if conditional-setslot
		 `(when ,(third arg)
		    ,(if (null (defstruct-slot-description-ppss slot-description))
		       (set-slot code 'structure
			  (defstruct-slot-description-number slot-description) mostarg)
		       (set-slot code 'structure
			  (defstruct-slot-description-number slot-description) mostarg
			  (defstruct-slot-description-ppss slot-description))))
		 (if (null (defstruct-slot-description-ppss slot-description))
		   (set-slot code 'structure
		      (defstruct-slot-description-number slot-description) mostarg)
		   (set-slot code 'structure
		      (defstruct-slot-description-number slot-description) mostarg
		      (defstruct-slot-description-ppss slot-description))))
	       produced-code))
	    (when slot-defaults
	      (push (intern (symbol-name mostarg) 'keyword) slot-done)))
	  (error "~S: Not a known slot name." mostarg))
	(progn
	  (setf optional-flag (eq arg '&optional))
	  (setf aux-flag (eq arg '&aux))))))) 


;;CLM for PHD 5/19/88 Allow for allow-other-keys T (SPR 8167).
(defun make-callable-constructor (cons-name)
  (using-defstruct-special-variables)
  ;;figure out the element type
  (let ((slot-defaults (collect-slot-defaults slot-alist))
	(code (defstruct-type-description-accessor-code type-description))
	keys val (missing (gensym)))
    ;;take care of the defstruct keywords
    (dolist (key (defstruct-type-description-defstruct-keywords type-description))
      (unless (get key keys) ;; already specified in the arguments of the macro
	(when (setf val (get-defstruct-property-value name key))
	  (push val keys) (push key keys))))
    (push `(defun ,cons-name (&rest inits)
	     (declare (function-parent ,name))
	     (do ((inits inits (cddr inits))
		  (structure ,(apply (defstruct-type-description-bare-constructor
					 type-description)
				       name size
				       subtype (name-offset) keys
				       ))
		  (allow-other-keys-p nil)
		  (allow-other-keys nil)
		  ,@(if slot-defaults '(slot-done) nil))
		 ((null inits)
		  ,@(and (and (not (defstruct-type-description-named-p type-description) )
			     (<= 1 (defstruct-type-description-overhead type-description)))
			(mapcan #'(lambda (x)
				    ;;Filter out dummy slots used for structure names.
				    (if (defstruct-slot-description-name-slot-p (cdr x))
					(list (set-slot code 'structure
							(defstruct-slot-description-number (cdr x))
							(defstruct-slot-description-init-code (cdr x))))
					nil))
				slot-alist))
		  ,@(if slot-defaults
			(do ((defaults slot-defaults (cdr defaults)) (produced-code '(structure)))
			    ((null defaults ) produced-code)
			  (push
			    `(unless (member ,(caar defaults) slot-done :test #'eq)
			       ,(if (check-for-byte-slots slot-alist)
				    (if (null (cdddar defaults))
					(set-slot code 'structure (caddar defaults ) (cadar defaults))
					(set-slot code 'structure (caddar defaults )(cadar defaults)
						  (cdddar defaults )))
				    (set-slot code 'structure (caddar defaults ) (cadar defaults))
				    ))
			    produced-code))
			'(structure)))
	       (let ((slot-number
		       (cdr (assoc (car inits)
				  ',(mapcan
				      #'(lambda (x)
					  ;;Filter out dummy slots used for structure names.
					  (if (defstruct-slot-description-name-slot-p (cdr x))
					      nil
					      (list (cons (intern (symbol-name (car x)) 'keyword)
							  (cons (defstruct-slot-description-number (cdr x))
								(defstruct-slot-description-ppss (cdr x)))))))
				      slot-alist)
				  :test #'eq))))
		 (if slot-number
		     (progn 
		       ,(if (check-for-byte-slots slot-alist)
			    (set-slot code 'structure '(car slot-number) '(second inits) '(cdr slot-number))
			    #| `(if (null (cdr (slot-number)))
			   (setf ,(funcall code '(car slot-number) 'structure) (second inits))
			   (progn
			     (when (null ,(funcall code '(car slot-number) 'structure))
			       (setf ,(funcall code '(car slot-number) 'structure) 0))
			     (setf (ldb (cdr slot-number ) ,(funcall code '(car slot-number) 'structure))
				   (second inits)))) |#
			    (set-slot code 'structure '(car slot-number) '(second inits) ))
		       #| `(setf ,(funcall code '(car slot-number) 'structure) (second inits))) |#
		       ,@(if slot-defaults `((push (car inits) slot-done)) nil))
		     (or allow-other-keys
			 (and (eq (car inits) :allow-other-keys)
			      (progn (unless  allow-other-keys-p
				       (setf allow-other-keys (cadr inits))
				       (setf allow-other-keys-p t))
				     t))
			 (and (null allow-other-keys-p)
			      (let ((p (getf inits  :allow-other-keys ',missing)))
				(when (neq p ',missing)
				  (setf  allow-other-keys-p t)
				  (setf allow-other-keys p))))
			 (error "unknown slot keyword ~S for structure ~S" (car inits) ',name))))))
	  returns)))
	   

(defun make-alterant-macro (alterant)
  (using-defstruct-special-variables)
  (push
    `(defmacro ,alterant( structure &rest slots-and-forms)
       (declare (function-parent ,name))
       (alterant-expander 
		structure slots-and-forms ',name 
		',slot-alist
		',type ',but-first ))
    returns))

;;PHD 3/19/87 Fixed ppss code generation.
(defun alterant-expander (structure slots-and-forms name  slot-alist type but-first)
  (let* ((type-description(defstruct-get-type-description type))
         (code (defstruct-type-description-accessor-code type-description))
	 (struct-name (gensym )))
    (multiple-value-bind (binding-list alist)
	(generate-binding-list slots-and-forms slot-alist name)
      ;; sort the list by slot number so the ppss are slose together
      (setf alist (sort alist #'(lambda (x y) (< (defstruct-slot-description-number (cdr x))
						    (defstruct-slot-description-number (cdr y))))
			:key #'car))
      (do ((alist alist (if noppss (cdr alist) alist))
	   produced-code noppss exp number)
	  ((null alist)
	   `(let ((,struct-name ,(if but-first `(,but-first ,structure ) structure))
	     ,@binding-list)
	 ,@produced-code))
	(setf number (defstruct-slot-description-number (cdaar alist)))
	(if (defstruct-slot-description-ppss (cdaar alist))
	    (progn
	      (multiple-value-setq  (exp alist)
				    (combine-ppss-slots-for-alterant
				      alist
				      number
				      (funcall code number struct-name)))
	      (push (set-slot code struct-name number exp) produced-code)
	      (setf noppss nil))
	    (progn (push (set-slot code struct-name
				   number
				   (cdar alist ))
			 produced-code)
		   (setf noppss t)))))))
    
(defun generate-binding-list (slots-and-forms slot-alist name)
  (do ((slots-and-forms slots-and-forms (cddr slots-and-forms))
       (sym (gensym) (gensym)) binding-list alist slot)
      ((null slots-and-forms)(values binding-list alist))
   (if (setf slot (assoc (first slots-and-forms ) slot-alist :test #'string-equal))
       (push (cons slot  sym) alist)
       (error "This keyword: ~S is not a valid slot name for structure ~S" (first slots-and-forms) name))
   (push (list sym (second slots-and-forms)) binding-list)))

(defun combine-ppss-slots-for-alterant (alist slot-number place)
  (if (AND  alist (=  (defstruct-slot-description-number (cdaar alist))
		      slot-number))
      (multiple-value-bind (code new-alist)
	  (combine-ppss-slots-for-alterant  (cdr alist) slot-number place)
	(values 
	  `(dpb ,(cdar alist) ,(defstruct-slot-description-ppss (cdaar alist))
		,code)
	  new-alist))
      (values place alist)))       


;;; Type description code, 

;;; For the constructor-code, think about macro and BOA.
(eval-when (compile eval load)
(defmacro defpredicate ((arg) form)
  (declare (special code type-name))
  (let ((fnname (create-symbol type-name (gentemp "-PREDICATE-GENERATOR" ))))
    (push `(defun ,fnname ()
	     (using-defstruct-special-variables)
	     (let ((,arg ',arg))
	       `(defun ,predicate (,,arg)
		  ,function-parent-declaration
		  ,,form)))
	  code)
  `',fnname))

(defmacro defaccessor-code ( arglist (n) &body form)
  (declare (special code type-name))
  (let ((fnname (create-symbol type-name (gentemp "-ACCESSOR-CODE" ))))
    (push `(defun ,fnname (,n ,@arglist )
	       (using-defstruct-special-variables)
		    ,@form)
	  code)
    `',fnname))

(defmacro defcopier ((arg) form)
  (declare (special code type-name))
  (let ((fnname (create-symbol type-name (gentemp "-COPIER-GENERATOR" ))))
    (push `(defun ,fnname ()
	       (using-defstruct-special-variables)
	       (let ((,arg ',arg))
		 `(defun ,copier (,,arg)
		    ,function-parent-declaration
		    ,,form)))
	  code)
    `',fnname))

(defmacro defconstructor (arglist &body body)
  (declare (special code type-name))
  (let ((fnname (create-symbol type-name (gentemp "-CONSTRUCTOR-")) ))
    (push `(defun ,fnname ,arglist ,@body)
	  code)
    `',fnname))
)
(defmacro defstruct-define-type ( name &rest options)
  (let ((type-name name)
	(code nil))
    (declare (special code type-name))
    (setf options (mapcar #'(lambda (x) `',(eval1 x)) options))
    `(progn 
       ,@code
       (setf (get ',name 'defstruct-type-description) (make-defstruct-type-description ,@options)))))

(defstruct-define-type common-lisp-structure
  :named-p t
  :named-type 'common-lisp-structure
  :predicate (defpredicate (object)
	       `(typep ,object  ',name))
  :copier (defcopier (object)
	     `(make-array ,size 
			  :named-structure-symbol  ',name
			  :leader-length 2
			  :element-type ',(if (emptyp subtype) t subtype)
			  :initial-contents ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
			`(make-array ,size :element-type ',(if (emptyp element-type) t element-type)
				     :named-structure-symbol ',name
				     :leader-length 2)))

;;;12/01/87 CLM for PHD: fix for SPR 6888, :named-vector unknown by release 3.
;;;For Rel2.1 compatibility.
(setf (get  :named-vector 'defstruct-type-description) 
      (get 'common-lisp-structure 'defstruct-type-description))
(setf (get  :named-typed-array 'defstruct-type-description) 
      (get 'common-lisp-structure 'defstruct-type-description))

(defstruct-define-type list
  :named-p nil
  :named-type 'named-list
  :compatible-types-for-include '(named-list)
  :predicate nil 
  :copier (defcopier (object)
	     `(copy-list ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(nth  ,n ,s))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name element-type))
			`(make-list ,size))
  :macro-cons-expander 'list-macro-cons
  :macro-constructor (defconstructor (name list-of-values )
		       (declare (ignore name))
		       `(list ,@list-of-values)))

(defstruct-define-type named-list
  :overhead 1
  :subtype-p nil 
  :named-p nil ;; Common Lisp will not know about the name being a type.
  :compatible-types-for-include '(list)
  :named-type 'named-list
  :predicate (defpredicate (object )
			   `(and (listp ,object) (eq (nth ,(name-offset) ,object ) ',name)))
  :copier (defcopier (object)
	     `(copy-list ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(nth  ,n ,s))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name element-type))
			`(make-list ,size))
  :macro-cons-expander 'list-macro-cons
  :macro-constructor (defconstructor (name list-of-values )
		       (declare (ignore name ))
		       `(list  ,@List-of-values)))
(defstruct-define-type :list
  :named-p nil
  :named-type ':named-list
  :predicate nil
  :copier (defcopier (object)
	     `(copy-list ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(nth  ,n ,s))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name element-type))
			`(make-list ,size))
  :macro-cons-expander 'list-macro-cons
  :macro-constructor (defconstructor (name list-of-values)
		       (declare (ignore name ))
		       `(list ,@list-of-values)))

(defstruct-define-type :named-list
  :overhead 1
  :subtype-p nil 
  :named-p nil
  :named-type ':named-list
  :predicate (defpredicate (object )
			   `(and (listp ,object) (eq (first ,object ) ',name)))
  :copier (defcopier (object)
	     `(copy-list ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(nth  ,n ,s))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name element-type))
			`(make-list ,size))
  :macro-cons-expander 'list-macro-cons
  :macro-constructor (defconstructor (name list-of-values )
		       (declare (ignore name))
		       `(list ,@List-of-values)))

(defstruct-define-type vector
  :named-p nil
  :named-type 'named-vector
  :compatible-types-for-include '(named-vector)
  :subtype-p t
  :predicate nil
  :copier (defcopier (object)
	     `(make-array ,size :element-type ',(if (emptyp subtype) t subtype)
			  :initial-contents ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(svref   ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name))
		      `(make-array ,size :element-type ',(if (emptyp element-type) t element-type))))

(defstruct-define-type named-vector
  :overhead 1
  :named-p nil
  :compatible-types-for-include '(vector)
  :subtype-p t
  :named-type 'named-vector
  :predicate (defpredicate (object )
			   `(and (vectorp ,object) (eq (svref ,object ,(name-offset) ) ',name)))
  :copier (defcopier (object)
	     `(make-array ',size :initial-contents  ,object
			  :element-type t ))
  :accessor-code (defaccessor-code (s) (n)
		   `(svref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name))
		      `(make-array ,size :element-type ',(if (emptyp element-type) t element-type))))

;; define some list* accessors 
(defsubst list*-accessor (l n size)
  (if (< n (1- size))
      (nth n l)
      (nthcdr n l)))

(defsubst list*-modifier (l n size val)
  (if (< n (1- size))
      (setf (nth n l) val)
      (setf (nthcdr n l) val)))

(defsetf list*-accessor list*-modifier)

;; in order to do locf of the accessor, a setf-expand needs to be there.

(defun (:property list*-accessor setf-expand) (accessor)
  (let ((l (second accessor))
	(n (third accessor))
	(size (fourth accessor)))
    (if (< n (1- size))
      `(nth ,n ,l)
      `(nthcdr ,n ,l))))  

(defstruct-define-type :list*
  :named-p nil
  :named-type nil
  :predicate nil
  :copier (defcopier (object)
	     `(copy-list ,object))
  :accessor-code (defaccessor-code (s) (n)
		   `(list*-accessor ,s ,n ,size))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type &rest ignore)
		      (declare (ignore name element-type))
			`(make-list ,(1- size)))
  :macro-cons-expander 'list-macro-cons
  :macro-constructor (defconstructor (name list-of-values)
		       (declare (ignore name))
		       `(list* ,@list-of-values)))

#|(defstruct-define-type :list*
  (:cons (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(list* ,.(if (null arg)
		 (make-list (defstruct-description-size))
		 arg)))
  (:ref (n description arg)
    (let ((size (1- (defstruct-description-size))))
      `(list*-accessor ,arg ,n ,size)))

  (:defstruct (description)
    (and (defstruct-description-include)
	 (defstruct-error
	   "Structure of type :LIST* cannot include another"
	   (defstruct-description-name)))
    nil)
  (:copier (description name)
    (do ((l `(x) (cons `(prog1 (car x) (setq x (cdr x))) l))
	 (i (defstruct-description-size) (1- i)))
	((<= i 1)
	 `(defun ,name (x)
	    (list* ,@l)))))) |#


(defstruct-define-type :array
  :overhead 0
  :named-p nil
  :subtype-p t
  :named-type :named-array
  :predicate nil
  :cons-keywords '(:subtype :make-array)
  :defstruct-keywords '(:subtype :make-array)
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type ignore &key subtype  make-array)
		      (multiple-value-bind (el-type options typep)
			 (parse-array-options-for-defstruct ':array name size element-type
							     :subtype subtype
							     :make-array make-array) 
		      `(make-array ,size ,(if typep :type :element-type) ,el-type 
				   ,@options)))
  :copier (defcopier (object)
		     `(copy-object ,object)))


(defstruct-define-type :named-array
  :overhead 1
  :named-p t
  :subtype-p nil
  :cons-keywords '(:subtype :make-array)
  :defstruct-keywords '(:subtype :make-array)
  :named-type :named-array
  :predicate (defpredicate (object)
			   `(typep ,object ',name))
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type ignore &key subtype  make-array)
		      (multiple-value-bind (el-type options typep)
			 (parse-array-options-for-defstruct ':named-array name size element-type
							     :subtype subtype
							     :make-array make-array) 
		      `(make-array ,size ,(if typep :type :element-type) ,el-type
				   :named-structure-symbol ',name
				   ,@options)))
  :copier (defcopier (object)
		     `(copy-object ,object)))



(defstruct-define-type :fixnum-array
  :overhead 0
  :named-p nil
  :subtype-p nil
  :cons-keywords '(:make-array)
  :defstruct-keywords '(:make-array)
  :element-type 'fixnum
  :named-type :named-fixnum-array
  :predicate nil 
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type ignore &key make-array)
		      (declare (ignore element-type))
		      (multiple-value-bind (el-type options typep)
			  (parse-array-options-for-defstruct ':fixnum-array name size defstruct-empty
							     :make-array make-array)
			el-type typep ;ignored
		      `(make-array ,size :element-type 'fixnum ,@options)))
  :copier (defcopier (object)
		     `(copy-object ,object)))


(defstruct-define-type :named-fixnum-array
  :overhead 0
  :named-p t
  :subtype-p nil
  :cons-keywords '(:make-array)
  :defstruct-keywords '(:make-array)
  :element-type 'fixnum
  :named-type :named-fixnum-array
  :predicate (defpredicate (object)
			   `(typep ,object ',name))
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type ignore &key make-array)
		      (declare (ignore element-type))
		      (multiple-value-bind (el-type options)
			  (parse-array-options-for-defstruct ':name-fixnum-array name size defstruct-empty
							     :make-array make-array)
			el-type ;ignored
			`(make-array ,size :element-type 'fixnum
				   :leader-length 2
				  :named-structure-symbol ',name
				  ,@options)))
  :copier (defcopier (object)
		     `(copy-object ,object)))


(defstruct-define-type :flonum-array
  :overhead 0
  :named-p nil
  :subtype-p nil
  :cons-keywords '(:make-array)
  :defstruct-keywords '(:make-array)
  :element-type 'single-float
  :named-type :named-flonum-array
  :predicate nil 
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type ignore &key make-array)
		      (declare (ignore element-type))
		      (multiple-value-bind (el-type options)
			  (parse-array-options-for-defstruct ':flonum-array name size defstruct-empty
							     :make-array make-array)
			el-type ;ignored
		      `(make-array ,size :element-type 'flonum ,@options)))
  :copier (defcopier (object)
		     `(copy-object ,object)))

(defstruct-define-type :named-flonum-array
  :overhead 0
  :named-p t
  :subtype-p nil
  :cons-keywords '(:make-array)
  :defstruct-keywords '(:make-array)
  :element-type 'single-float
  :named-type :named-flonum-array
  :predicate (defpredicate (object)
			   `(typep ,object ',name))
  :accessor-code (defaccessor-code (s) (n)
		   `(aref ,s ,n))
  :ref-no-args 1
  :bare-constructor (defconstructor (name size element-type ignore &key make-array)
		      (declare (ignore element-type))
		      (multiple-value-bind (el-type options)
			  (parse-array-options-for-defstruct ':named-flonum-array name size defstruct-empty
							     :make-array make-array)
			el-type ;ignored
			`(make-array ,size :element-type 'flonum
				   :leader-length 2
				  :named-structure-symbol ',name
				  ,@options)))
  :copier (defcopier (object)
		     `(copy-object ,object)))


(defstruct-define-type :array-leader
  :overhead 0
  :named-type :named-array-leader
  :subtype-p t
  :CONS-KEYWORDS '(:make-array :SUBTYPE)
  :DEFSTRUCT-KEYWORDS '(:MAKE-ARRAY :SUBTYPE)
  :bare-constructor (defconstructor (name size element-type ignore &key make-array subtype)
		      (declare (ignore element-type))
		      (multiple-value-bind (el-type options typep)
			  (parse-array-options-for-defstruct ':array-leader name size defstruct-empty
							     :subtype subtype :make-array make-array)
			`(make-array ,(or (prog1 (getf options :dimensions)
						 (remf options :dimensions))
					  (prog1 
					    (getf options :length )
					    (remf options :length))
					  0)
				     ,(if typep :type :element-type) ,el-type
				     :leader-length ,size 
				     ,@options)))
		
  :accessor-code (defaccessor-code (s) (n)
		   `(array-leader ,s ,n)))

(defstruct-define-type :named-array-leader
  :named-p t
  :overhead 1
  :named-type :named-array-leader
  :subtype-p t
  :CONS-KEYWORDS '(:make-array :SUBTYPE)
  :DEFSTRUCT-KEYWORDS '(:MAKE-ARRAY :SUBTYPE)
  :bare-constructor (defconstructor (name size element-type ignore &key make-array subtype)
		      (declare (ignore element-type))
		      (multiple-value-bind (el-type options typep)
			  (parse-array-options-for-defstruct ':named-array-leader name size defstruct-empty
							     :subtype subtype :make-array make-array)
			`(make-array ,(or (prog1 (getf options :dimensions)
						 (remf options :dimensions))
					  (prog1 
					    (getf options :length )
					    (remf options :length))
					  0)
				     ,(if typep :type :element-type) ,el-type
				     :leader-length ,size :named-structure-symbol ',name
				     ,@options)))
		
  :accessor-code (defaccessor-code (s) (n)
		   `(array-leader ,s (if (= 1 ,n) 0 ,n)))
  :predicate (defpredicate (s)
		 `(typep s ',name)))



(defstruct-define-type :grouped-array
  :CONS-KEYWORDS '(:make-array :times :SUBTYPE)
  :DEFSTRUCT-KEYWORDS '(:MAKE-ARRAY :TIMES :SUBTYPE)
  :subtype-p t
  :ref-no-args 2
  :bare-constructor (defconstructor (name size element-type ignore &key subtype make-array times)
		      (multiple-value-bind (el-type options typep)
			  (parse-array-options-for-defstruct ':grouped-array name size element-type
							     :subtype subtype :make-array make-array)
			`(make-array (* ,size ,(or times 1))
				     ,(if typep :type :element-type) ,el-type
				     ,@options)))
  :accessor-code (defaccessor-code (&optional s (index 0) )(n)
				   `(aref ,s (+ ,n ,index))))

(defstruct-define-type :fixnum
  :named-p nil
  :copier (defcopier (object ) object)
  :macro-cons-expander 'fixnum-macro-cons
  :bare-constructor (defconstructor (name size element-type ignore)
		      (declare (ignore element-type))
		       (and (neq size 1)
			    (error "defstruct ~S  of type :fixnum must have only one element" name))
		       0)
  :accessor-code (defaccessor-code (s) (n)
		   (declare (ignore n))
		   s))




(defstruct-define-type :tree
  :named-p nil
  :accessor-code (defaccessor-code (s) (n)
    (do ((a s)
	 (loc-size size)
	 (tem))
	(nil)
      (cond ((= loc-size 1) (return a))
	    ((< n (setq tem (truncate loc-size 2)))
	     (setq a `(car ,a))
	     (setq loc-size tem))
	    (t (setq a `(cdr ,a))
	       (setq loc-size (- loc-size tem))
	       (setq n (- n tem))))))
  :copier (defcopier (object ) `(copy-tree ,object))
  :bare-constructor (defconstructor (name size element-type ignore )
		      (declare (ignore element-type))
		      (or (neq size 0)
			  (error "defstruct ~S of type TREE cannot be empty" name))
		      (error 
			"constructor for structure ~S of type TREE cannot be callable, 
 use (:callable-constructors nil ) option"
			name)
		      (make-tree-for-defstruct (make-list size :initial-element nil) size))
  :macro-cons-expander 'list-macro-cons
  :macro-constructor (defconstructor (name list-of-values)
		       (declare (ignore name))
		       (make-tree-for-defstruct list-of-values (length list-of-values )))) 



(defun make-tree-for-defstruct (arg n)
  (cond ((= n 1) (car arg))
	((= n 2) `(cons ,(car arg) ,(cadr arg)))
	(t (do ((a (cdr arg) (cdr a))
		(m (truncate n 2))
		(nn (1- (truncate n 2)) (1- nn)))
	       ((zerop nn)
		`(cons ,(make-tree-for-defstruct arg m)
		       ,(make-tree-for-defstruct a (- n m))))))))




(defvar *defstruct-examine&deposit-arg*)

(defun defstruct-examine (*defstruct-examine&deposit-arg*
			  name slot-name)
  (eval1 (list (defstruct-slot-description-ref-macro-name
		(defstruct-examine&deposit-find-slot-description
		  name slot-name))
	      '*defstruct-examine&deposit-arg*)))


(defvar *defstruct-examine&deposit-val*)

(defun defstruct-deposit (*defstruct-examine&deposit-val*
			  *defstruct-examine&deposit-arg*
			  name slot-name)
  (eval1 (list 'setf
	      (list (defstruct-slot-description-ref-macro-name
		     (defstruct-examine&deposit-find-slot-description
		       name slot-name))
		    '*defstruct-examine&deposit-arg*)
	      '*defstruct-examine&deposit-val*)))

(defun defstruct-get-locative (*defstruct-examine&deposit-arg*
			       name slot-name)
  (let ((slot-description (defstruct-examine&deposit-find-slot-description
			    name slot-name)))
    (or (null (defstruct-slot-description-ppss))
	(defstruct-error
	  "You cannot get a locative to a byte field"
	  slot-name 'in name))
    (eval1 (list 'locf
		(list (defstruct-slot-description-ref-macro-name)
		      '*defstruct-examine&deposit-arg*)))))

(defun defstruct-examine&deposit-find-slot-description (name slot-name)
  (let ((description (get-defstruct-description name)))
    (let ((slot-description
	   (cdr
	    (or (assoc slot-name (defstruct-description-slot-alist) :test #'eq)
	       (defstruct-error "No such slot ~S in this structure ~S" slot-name  name))))
	  (type-description
	   (or (get (defstruct-description-type) 'defstruct-type-description)
	      (defstruct-error "Undefined defstruct type ~S" (defstruct-description-type)))))
      (or (= (defstruct-type-description-ref-no-args type-description ) 1)
	 (defstruct-error
	  "defstruct-examine and defstruct-deposit cannot handle structures of this type ~S"
	  (defstruct-description-type)))
      slot-description))) 

(DEFUN DESCRIBE-DEFSTRUCT-DESCRIPTION (NAME)
  (DESCRIBE-DEFSTRUCT (GET-DEFSTRUCT-DESCRIPTION NAME) 'DEFSTRUCT-DESCRIPTION))

;; clm for DNG 02/01/89 - added documentation string for DEFSTRUCT
(setf (documentation 'defstruct)
      "Define a named structure data type.  Syntax:
\(DEFSTRUCT name-and-options [ doc-string ] { slot-description }*)
name-and-options ::= name | (name {structure-option}*)
structure-option ::= (:CONC-NAME prefix) | (:CONSTRUCTOR symbol) | 
  (:COPIER symbol) | (:PREDICATE symbol) | (:INCLUDE structure-name) | 
  (:PRINT-FUNCTION (LAMBDA (instance stream depth) ...)) | 
  (:TYPE {VECTOR | LIST}) | :NAMED | (:INITIAL-OFFSET integer)
slot-description ::= slot-name | (slot-name init-form {slot-option}*)
slot-option ::= :TYPE type-specifier | :READ-ONLY boolean | :DOCUMENTATION string
Refer to the manual for additional esoteric or non-standard options.")

(setf (documentation 'zlc:defstruct) (documentation 'defstruct))


(pushnew ':DEFSTRUCT *features*) ; added 12/10/87 by DNG