(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "LISP")

(il:filecreated "29-Oct-86 21:54:36" il:{eris}<lispcore>sources>defstruct.\;10
 55510  

      il:|changes| il:|to:|  (il:functions structure-pointer-slots build-copier-type-check 
                                    declare-structure ensure-consistent-ps assign-field-descriptors 
                                    defstruct assign-structure-representation defstruct-parse-options
                                    )
                             (il:structures ps)
                             (il:vars il:defstructcoms)
                             (il:variables %default-structure-include)

      il:|previous| il:|date:| "24-Oct-86 15:47:06" il:{eris}<nuyens>zebra>defstruct.\;32)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:defstructcoms)

(il:rpaqq il:defstructcoms
 ((il:* il:|;;;| "Implementation of defstruct")
                            (il:* il:|;;;| "public interface ")
                            (il:functions defstruct)
                            (il:p (setf (macro-function 'il:defstruct)
                                        nil))
                            (il:define-types il:structures)
                            (il:* il:|;;;| "top-level ")
                            (il:files il:defstruct-run-time)
                            (il:functions declare-structure)
                            (il:* il:|;;;| "parsing code")
                            (il:structures ps parsed-slot)
                            (il:functions assign-slot-accessor remove-documentation 
                                   record-documentation ensure-valid-type parse-slot 
                                   defstruct-parse-options ensure-consistent-ps ps-number-of-slots 
                                   ps-type-specifier)
                            (il:variables %default-defstruct-type %default-slot-type 
                                   %default-structure-include %defstruct-options %no-constructor 
                                   %defstruct-consp-options)
                            (il:* il:|;;;| "slot resolution code")
                            (il:functions assign-slot-offset resolve-slots add-name-slot 
                                   insert-included-slot merge-slots name-slot 
                                   add-initial-offset-slots)
                            (il:* il:|;;;| "data layout code")
                            (il:functions pack-datatype-fieldspecs assign-structure-representation 
                                   define-structure-type defstruct-slot-to-datatype-fieldspec 
                                   %structure-type-to-fieldspec assign-field-descriptors 
                                   structure-pointer-slots)
                            (il:* il:|;;;| "accessors and setfs")
                            (il:functions define-accessors pslot-internal-accessor define-setfs 
                                   setf-name)
                            (il:* il:|;;;| "constructor definition code")
                            (il:functions define-constructors define-boa-constructor argument-names 
                                   boa-arg-list-with-initial-values boa-slot-setfs find-slot 
                                   raw-constructor build-constructor-arglist 
                                   build-constructor-slot-setfs boa-constructor-p 
                                   default-constructor-name)
                            (il:* il:|;;;| "predicate")
                            (il:functions construct-predicate ps-name-slot-position 
                                   default-predicate-name function-defining-form)
                            (il:* il:|;;;| "copiers")
                            (il:functions define-copiers build-copier-slot-setfs 
                                   build-copier-type-check)
                            (il:* il:|;;;| "print functions")
                            (il:variables %default-print-function)
                            (il:* il:|;;;| "internal stuff.")
                            (il:setfs il:ffetchfield)
                            (il:* il:|;;;| "utilities")
                            (il:functions safe-type-expand defstruct-assert-subtypep)
                            (il:* il:|;;;| "file properties")
                            (il:prop il:filetype il:defstruct)
                            (il:prop il:makefile-environment il:defstruct)))



(il:* il:|;;;| "Implementation of defstruct")





(il:* il:|;;;| "public interface ")


(il:defdefiner (defstruct
 (:name (lambda (whole)
                                        (let ((name-and-options (second whole)))
                                             (if (consp name-and-options)
                                                 (car name-and-options)
                                                 name-and-options)))))
   il:structures (name &rest slot-descriptions)
         (let* ((ps (defstruct-parse-options name))
                (slot-descriptions (remove-documentation ps slot-descriptions)))
               (resolve-slots slot-descriptions ps)
               `(progn ,@(declare-structure ps))))

(setf (macro-function 'il:defstruct)
      nil)
(il:def-define-type il:structures
 "Common Lisp structures" )




(il:* il:|;;;| "top-level ")


(il:filesload il:defstruct-run-time)
(defun declare-structure
 (ps) "accomplishes all the work of declaring a structure."
   
                                               (il:* il:|;;| 

                                         "maybe should purge some fields of the ps here to be gc'ed?")

   `((eval-when (eval compile load)
            (setf (parsed-structure ',(ps-name ps))
                  ',ps))
     ,@(record-documentation ps)
     ,@(assign-structure-representation ps)
     ,@(define-structure-type ps)
     ,@(construct-predicate ps)
     ,@(define-accessors ps)
     ,@(define-setfs ps)
     ,@(define-constructors ps)
     ,@(define-copiers ps)))




(il:* il:|;;;| "parsing code")


(defstruct (ps
 (:type list)
               :named) "contains the parsed information for a SINGLE structure type"
   (name name)
   (standard-constructor)
   (all-slot-names)
   (type %default-defstruct-type)
   (vector-type)
   (include nil)
   (conc-name (xcl:pack (list name '-)))
   (constructors %no-constructor)
   (predicate nil)
   (print-function)
   (copier (xcl:pack (list 'copy- name)))
   (named nil)
   (initial-offset 0)
   (local-slots nil)
   (all-slots)
   (included-slots)
   (documentation-string)
   (field-specifiers)
   (pointer-descriptors))

(defstruct (parsed-slot
 (:conc-name pslot-)
                        (:type list)) "describes a single slot in a structure" (name nil :type symbol
                                                                                     )
                                                                               (initial-value nil)
                                                                               (type 
                                                                                   %default-slot-type
                                                                                     )
                                                                               (read-only nil)
                                                                               field-descriptor 
                                                                               accessor)

(defun assign-slot-accessor
 (slot conc-name) "assigns the accessor name to a slot"
   (if (pslot-accessor slot)
       (setf (pslot-accessor slot)
             (xcl:pack* conc-name (pslot-name slot)))))

(defun remove-documentation
 (ps slot-descriptions) "records it if there is any documentation string."
   (let ((doc? (car slot-descriptions)))
        (cond
           ((stringp doc?)
                        (il:* il:|;;| 

                                                  " save it and return the rest of the slots.")

            (setf (ps-documentation-string ps)
                  doc?)
            (rest slot-descriptions))
           (t 
                                    (il:* il:|;;| 

                                                  "no doc string, return the whole thing.")

              slot-descriptions))))

(defun record-documentation
 (ps) 
                               "returns a form which saves the documentation string for a structure."
   (let ((parsed-docstring (ps-documentation-string ps)))
        (if parsed-docstring `((setf (documentation ',(ps-name ps) 'structure)
                                     ,parsed-docstring)))))

(defun ensure-valid-type
 (type-form) "bogus right now" type-form)

(defun parse-slot
 (description &optional (generate-accessor t)) 
    "takes a slot description from the defstruct body or included slots and returns a parsed version"
   (let* ((description (il:mklist description))
          (slot (make-parsed-slot)))
         (il:destructuring-bind (name initial-value . slot-options)
                description
                (if (symbolp name)
                    (setf (pslot-name slot)
                          name)
                    (error "Slot name not symbol: ~S" name))
                (setf (pslot-initial-value slot)
                      initial-value)
              (il:* il:|;;| "some variant of PCL's keyword-bind would be easier here, but it's incapable of producing reasonable error msgs for the user.  Maybe later.")

                (il:for
 option-pair il:on
 slot-options il:by
 (cddr option-pair)
                   il:do
 (case (car option-pair)
                               (:type (setf (pslot-type slot)
                                            (ensure-valid-type (cadr option-pair))))
                               (:read-only (setf (pslot-read-only slot)
                                                 (and (cadr option-pair)
                                                      t)))
                               (otherwise (if (keywordp initial-value)
                                              (error 
                                            "Initial value must be specified to use slot options. ~S" 
                                                     description)
                                              (error "Illegal slot option ~S in slot ~S" (car 
                                                                                          option-pair
                                                                                              )
                                                     name)))))
                (if generate-accessor (setf (pslot-accessor slot)
                                            t)))
         slot))

(defun defstruct-parse-options
 (name&options) 
                                  "returns a structure representing the options in a defstruct call."
   (let* ((options (il:mklist name&options))
          (name (pop options))
          (ps (make-ps :name name)))
         (dolist (option options)
                (cond
                   ((listp option)
                    (il:destructuring-bind
                     (option-keyword option-value . further-arguments)
                     option
                     (let ((argument-provided (cdr option)))
                          (case option-keyword (:conc-name 

                                                  (il:* il:|;;| 

    "if the option is specified, but the option value is nil, then use the empty string as conc-name")

                                                      (setf (ps-conc-name ps)
                                                            (or option-value "")))
                                (:constructor 
    (il:* il:|;;| 

                "multiple constructors are allowed.  If NIL is provided, then define no constructor.")

                                       (cond
                                          ((and argument-provided (not option-value))

                                                  (il:* il:|;;| 

                                     "NIL was specified.  Record that no constructor is to be built.")

                                           (setf (ps-constructors ps)
                                                 nil))
                                          ((eq (ps-constructors ps)
                                               '%%no-constructor)

                                                  (il:* il:|;;| 

                            "this is the first constructor specified.  Make the field be a list now.")

                                           (setf (ps-constructors ps)
                                                 (list (if further-arguments (cdr option)
                                                           option-value))))
                                          (t 
     (il:* il:|;;| 

                                                 "just push another one on the list of constructors.")

                                             (push (if further-arguments (cdr option)
                                                       option-value)
                                                   (ps-constructors ps)))))
                                (:copier                     (il:* il:|;;| 

             "if the argument is specified (even if it is nil), use it.  Otherwise use the default %" 

                                                             copy-% " form already in the ps.")

                                       (if argument-provided (setf (ps-copier ps)
                                                                   option-value)))
                                (:predicate (if argument-provided (setf (ps-predicate ps)
                                                                        option-value)))
                                (:include (setf (ps-include ps)
                                                option-value)(il:* il:|;;| 

                                                        "if there are any included slots record them")

                                       (setf (ps-included-slots ps)
                                             (cddr option)))
                                (:print-function (cond
                                                    ((and argument-provided (null option-value))
                                                             (il:* il:|;;| "extension to CLtL, if NIL is specified as the defprint, then the internal print function is specified.")

                                                     (setf (ps-print-function ps)
                                                           'il:\\print-using-address))
                                                    (argument-provided (setf (ps-print-function
                                                                              ps)
                                                                             option-value))))
                                (:type (setf (ps-type ps)
                                             (cond
                                                ((eq option-value 'list)
                                                 'list)
                                                ((eq option-value 'vector)
                                                             (il:* il:\; 

                                                             "default the vector type to t")

                                                 (setf (ps-vector-type ps)
                                                       t)
                                                 'vector)
                                                ((and (consp option-value)
                                                      (eq (car option-value)
                                                          'vector))
                                                 (setf (ps-vector-type ps)
                                                       (il:%get-canonical-cml-type (cadr option-value
                                                                                         )))
                                                 'vector)
                                                (t (error 
                                           "the specified :type is not list or subtype of vector: ~S" 
                                                          option-value)))))
                                (:initial-offset (if (not (or t 
                                                             (il:* il:|;;| "fix typep first!!!")

                                                              (typep option-value
                                                                     '(integer 0 *))))
                                                     (error 
                                                   ":initial-offset isn't a non-negative integer: ~S" 
                                                            option-value))
                                       (setf (ps-initial-offset ps)
                                             option-value))
                                (otherwise (error "Bad option to defstruct: ~S." option))))))
                   (t (case option (:named (setf (ps-named ps)
                                                 t))
                            (otherwise (if (member option %%defstruct-consp-options)
                                           (error 
                                          "defstruct option ~s must be in parentheses with its value" 
                                                  option)
                                           (error "Bad option to defstruct: ~S." option)))))))
         (ensure-consistent-ps ps)
         ps))

(defun ensure-consistent-ps
 (ps) 
       "accomplishes the consistency checks that can't occur until all the options have been parsed."
   (cond
      ((ps-print-function ps)
       (if (not (eq (ps-type ps)
                    %default-defstruct-type))
           (error "A print-function can't be specified for structures of type ~s" (ps-type ps))))
      (t (let ((include (ps-include ps)))
              (cond
                 (include 
                        (il:* il:|;;| 

                                                  "CLtL is silent, but we inherit print-functions")

                        (setf (ps-print-function ps)
                              (ps-print-function (parsed-structure include))))
                 (t 
                              (il:* il:|;;| 

                                                  "otherwise, use the default #s style printer")

                    (setf (ps-print-function ps)
                          %default-print-function))))))
   (cond
      ((and (eq (ps-type ps)
                'vector)
            (eq (ps-named ps)
                t))
                               (il:* il:|;;| 

                     "check that the vector type can actually hold the symbol required for the name.")

       (defstruct-assert-subtypep 'symbol (ps-vector-type ps)
              ("vector of ~S cannot contain the symbol required for the :named options" (
                                                                                       ps-vector-type
                                                                                         ps)))))
   (cond
      ((ps-include ps)
       (let* ((include (ps-include ps))
              (included-pstructure (parsed-structure include)))

                                                  (il:* il:|;;| "ensure that the user is not suicidal.  If a structure includes itself, a *very* tight ucode loop will  occur in the instancep opcode.")

             (if (eq include (ps-name ps))
                 (error "You probably don't want ~S to include ~S." include include))

                                                  (il:* il:|;;| 

                                                  "ensure that the included structure is loaded in.")

             (or (parsed-structure include t)
                 (error "Included structure ~s is unknown" include))

                                                  (il:* il:|;;| 

                                           "make sure the type of the included structure is the same")

             (if (or (il:neq (ps-type included-pstructure)
                            (ps-type ps))
                     (il:neq (ps-vector-type included-pstructure)
                            (ps-vector-type ps)))
                 (error "~s must be same type as included structure ~s" (ps-name ps)
                        include)))))
   (cond
      ((not (ps-predicate ps))
                    (il:* il:|;;| 

          "there is no predicate.  If this structure is type datatype or named, use the default name")

       (cond
          ((or (eq (ps-type ps)
                   'datatype)
               (ps-named ps))
           (setf (ps-predicate ps)
                 (default-predicate-name (ps-name ps)))))))
   (cond
      ((eq (ps-constructors ps)
           %no-constructor)
                       (il:* il:|;;| 

                                          "There were no constructors specified.  Default the value.")

       (setf (ps-constructors ps)
             `(,(default-constructor-name (ps-name ps)))))))

(defun ps-number-of-slots
 (ps) "the number of slots in an instance of this structure"
   (length (ps-all-slots ps)))

(defun ps-type-specifier
 (ps) "returns list, vector, or (vector foo)"
   (ecase (ps-type ps)
          (list 'list)
          (vector (let ((element-type (ps-vector-type ps)))
                       (if (il:neq element-type t)
                           `(vector ,element-type)
                           'vector)))))

(defvar %default-defstruct-type
 'datatype "The type of structures when no :type option is specified"
   )

(defvar %default-slot-type
 't "the type of any slot which does not specifiy a :type option" )

(defconstant %default-structure-include
 "datatype included by every structure" 'structure-object)

(defparameter %defstruct-options
 '(:conc-name :constructor :copier :predicate :include 
                                         :print-function :type :initial-offset :named) )

(defconstant %no-constructor
 ':none "the value which says that no constructor was specified." )

(defparameter %defstruct-consp-options
 (remove ':named %defstruct-options) )




(il:* il:|;;;| "slot resolution code")


(defun assign-slot-offset
 (ps) "assigns the offsets for each slot for type vector and list."
   (let* ((name (ps-name ps))
          (slots (ps-all-slots ps)))
         (ecase (ps-type ps)
                ((vector list)
                    (il:* il:|;;| 

                                                  "the field descriptor is just the offset.")

                 (il:for
 i il:from
 0 il:as
 slot il:in
 slots il:do
 (setf (pslot-field-descriptor
                                                                         slot)
                                                                        i))))))

(defun resolve-slots
 (local-slot-descriptions ps) "combines the slot descriptions from the defstruct call with the included slot-descriptions from supers and the :includes option, and installs the decription in the parsed-structure"
   (setf (ps-local-slots ps)
         (mapcar #'parse-slot local-slot-descriptions))
   (setf (ps-included-slots ps)
         (mapcar #'parse-slot (ps-included-slots ps)))
   (if (ps-named ps)
       (add-name-slot ps))
   (if (il:neq 0 (ps-initial-offset ps))
       (add-initial-offset-slots ps))
             (il:* il:|;;| 

     "since adding name and initial offset slots can change local or included slots, bind them here.")

   (let ((local-slots (ps-local-slots ps))
         (included-slots (ps-included-slots ps))
         (includes (ps-include ps)))
        (cond
           (includes (let ((super-slots (copy-list (ps-all-slots (parsed-structure includes)))))

                                                  (il:* il:|;;| "update the super-slots according to the included-slots, then make all-slots be (append merged-slots local-slots)")

                          (setf (ps-all-slots ps)
                                (nconc (merge-slots included-slots super-slots ps)
                                       local-slots))))
           (t (if included-slots (error "Can't include slots when ~s includes no structure."
                                        (ps-name ps)))

                                                  (il:* il:|;;| 

                                                  "no included slots, so the local-slots are it.")

              (setf (ps-all-slots ps)
                    local-slots)))
        (setf (ps-local-slots ps)
              local-slots))
                       (il:* il:|;;| "now that all slots (included, super, local and filler) have been included, we can create accessor names.")

   (let ((conc-name (ps-conc-name ps)))
        (dolist (slot (ps-all-slots ps))
               (assign-slot-accessor slot conc-name)))

                                                  (il:* il:|;;| 

                     "we can also record slot-names for the default-structure-printer and inspector.")

   (setf (ps-all-slot-names ps)
         (mapcar #'pslot-name (ps-all-slots ps))))

(defun add-name-slot
 (ps) "adds the slot representing the name pseudo-slot." (assert (ps-named ps))
                                                                             (push (name-slot ps)
                                                                                   (ps-local-slots
                                                                                    ps)))

(defun insert-included-slot
 (new-slot super-slots ps) 
                        "replaces the slot in super-slots that corresponds to new-slot with new-slot"
   (flet ((same-slot (slot1 slot2)
                 (eq (pslot-name slot1)
                     (pslot-name slot2))))
         (let* ((tail (member new-slot super-slots :test #'same-slot))
                (old-slot (car tail)))
               (if (not tail)
                   (error "included slot ~S not present in included structure ~S" (pslot-name 
                                                                                         new-slot)
                          (ps-include ps)))
            (il:* il:|;;| " verify the inclusion rules.")

               (if (and (pslot-read-only old-slot)
                        (not (pslot-read-only new-slot)))
                   (error "included slot ~s must be read-only.  It is in included structure ~S"
                          (pslot-name new-slot)
                          (ps-include ps)))
               (defstruct-assert-subtypep (pslot-type new-slot)
                      (pslot-type old-slot)
                      ("Included slot ~S's type ~s is not a subtype of original slot type ~s"
                       (pslot-name new-slot)
                       (pslot-type new-slot)
                       (pslot-type old-slot)))
     (il:* il:|;;| "finally, we can replace the slot")

               (rplaca tail new-slot))))

(defun merge-slots
 (included-slots super-slots ps) "takes the included-slots, and the local slots, then merges them with the slots from the super that aren't shadowed."
   
                                               (il:* il:|;;| 

  "go through the slots from the super and replace the super's def with the overriding included-slot")

   (dolist (new-slot included-slots)
          (insert-included-slot new-slot super-slots ps))
   super-slots)

(defun name-slot
 (ps) "returns a parsed-slot representing the 'name' field of a structure"
   (parse-slot `(,(make-symbol "name") ',(ps-name ps) :read-only t) nil))

(defun add-initial-offset-slots
 (ps) 
                              "adds parsed-slots to the local-slots to represent the initial offset."
   (setf (ps-local-slots ps)
         (nconc (make-list (ps-initial-offset ps)
                       :initial-element
                       (parse-slot '(nil nil :read-only t) nil))
                (ps-local-slots ps))))




(il:* il:|;;;| "data layout code")


(defun pack-datatype-fieldspecs
 (field-specs) "dummy" field-specs)

(defun assign-structure-representation
 (ps) 
                  "Determines the descriptors and returns a form to create the datatype at loadtime."
   (case (ps-type ps)
         ((vector list)
                           (il:* il:|;;| "just assign the the field descriptors (offsets).  No run-time declaration is needed since the representation is known (list and vector)")

          (assign-slot-offset ps))
         (datatype (let* ((local-field-specs (mapcar #'defstruct-slot-to-datatype-fieldspec
                                                    (ps-local-slots ps)))
                          (super-field-specs (if (ps-include ps)
                                                 (ps-field-specifiers (parsed-structure (ps-include
                                                                                         ps)))))
                          (all-field-specs (pack-datatype-fieldspecs (append super-field-specs 
                                                                            local-field-specs)))
                          (structure-name (ps-name ps)))
                         (setf (ps-field-specifiers ps)
                               all-field-specs)
                         (il:destructuring-bind (length . field-descriptors)
                                (il:translate.datatype structure-name all-field-specs)
                                (assign-field-descriptors ps field-descriptors)

                                                  (il:* il:|;;| "save the descriptors? No, even though the ones in the dtd are for the current world, not the crosscompiling world.  They are recomputed each redeclaration by TRANSLATE.DATATYPE")

                                `((si::%structure-declare-datatype ',structure-name
                                         ',all-field-specs
                                         ',field-descriptors
                                         ,length
                                         ',(or (ps-include ps)
                                               %default-structure-include))))))))

(defun define-structure-type
 (ps) "adds the structure to the common lisp type system with deftype."
   (if (eq (ps-type ps)
           'datatype)
       (let ((name (ps-name ps)))
            `((deftype (il:\\\,
 name) nil '(il:datatype ,name))
))))

(defun defstruct-slot-to-datatype-fieldspec
 (slot) 
                             "given a parsed-slot returns a datatype fieldspec that will contain it."
   (%structure-type-to-fieldspec (pslot-type slot)))

(defun %structure-type-to-fieldspec
 (elementtype) 
(il:* il:|;;;| 

                  "Returns the most specific InterLisp type descriptor which will hold a given type.")

   
                                               (il:* il:|;;;| "Note: This function accepts only a limited subset of the Common Lisp type specifiers: T FLOAT SINGLE-FLOAT FIXNUM BIT (MOD n) (UNSIGNED-BYTE n) INTEGER (INTEGER low high) IL:XPOINTER DOUBLE-IL:POINTER")

   (case elementtype ((string-char t)
                      'il:pointer)
         (fixnum 'il:signedword)
         (integer 'il:fixp)
         (bit '(il:bits 1))
         (il:xpointer elementtype)
         ((single-float float)
          'il:floatp)
         (otherwise (cond
                       ((eq (car (listp elementtype))
                            'datatype)
            (il:* il:|;;| 

                                                  "include the known faves, otherwise t.")

                        (case (cadr elementtype)
                              (floatp 'floatp)
                              (otherwise 'il:pointer)))
                       ((and (eq (car (listp elementtype))
                                 'integer)
                             (null (cdddr elementtype))
                             (il:fixp (cadr elementtype))
                             (il:fixp (caddr elementtype))
                             (il:ilessp (cadr elementtype)
                                    (caddr elementtype)))
    (il:* il:\; "(INTEGER low high)")

                        (let* ((low (cadr elementtype))
                               (high (caddr elementtype))
                               (range (- high low)))

                                                  (il:* il:\; 

                                         "Type simplification should probably be done somewhere else")

                              (cond
                                 ((il:ieqp low 0)
     (il:* il:\; "(INTEGER 0 high) => (MOD nbits)")

                                  (%structure-type-to-fieldspec `(mod ,(il:add1 range))))
                                 ((and (il:igeq low il:min.fixp)
                                       (il:ileq high il:max.fixp))

                                                  (il:* il:\; 

                                                  "(INTEGER >= MIN.FIXP <= MAX.FIXP) == FIXNUM")

                                  'il:fixp)
                                 (t 'il:pointer))))
                       ((equal elementtype '(simple-vector * fixnum))
                        'il:pointer)
                       (t (let ((expander (il:type-expander elementtype)))
                               (if expander (%structure-type-to-fieldspec (il:type-expand elementtype 
                                                                                 expander))
                                   'il:pointer)))))))

(defun assign-field-descriptors
 (ps field-descriptors) 
                             "assigns the field descriptors for accessing each slot of the structure"
   (assert (eq (ps-type ps)
               'datatype))
   (il:for
 f il:in
 field-descriptors il:as
 slot il:in
 (ps-all-slots ps)
      il:do
 (setf (pslot-field-descriptor slot)
                  f))
                             (il:* il:|;;| "DON'T record where the pointer fields are for the circle printer.  it will do this when it needs them.")


                                                  (il:* il:|;;| "(setf (ps-pointer-descriptors ps) (mapcan #'(lambda (descriptor) (case (caddr descriptor) ((il:pointer il:fullpointer il:xpointer il:fullxpointer) (list descriptor)))) field-descriptors))")

   )

(defun structure-pointer-slots
 (structure-name) 
  (il:* il:|;;| 

                                        "record where the pointer fields are for the circle printer.")

   (let ((ps (parsed-structure structure-name)))
        (or (ps-pointer-descriptors ps)
            (setf (ps-pointer-descriptors ps)
                  (mapcan #'(lambda (descriptor)
                                   (case (caddr descriptor)
                                         ((il:pointer il:fullpointer il:xpointer il:fullxpointer)
                                          (list descriptor)))) (mapcar #'pslot-field-descriptor
                                                                      (ps-all-slots ps)))))))




(il:* il:|;;;| "accessors and setfs")


(defun define-accessors
 (ps) "returns the forms that when evaluated, define the accessors"
   (let ((arg-name (ps-name ps))
         (structure-type (ps-type ps)))
           (il:* il:|;;| 

                 "the arg-name must be the structure name, since it is already in the raw-accessors.")

        (mapcan #'(lambda (slot)
                         (let ((accessor (pslot-accessor slot)))
                              (if accessor `((,(function-defining-form ps 'accessors)
                                              ,accessor
                                              (,arg-name)
                                              ,(pslot-internal-accessor slot arg-name structure-type)
                                              ))))) (ps-all-slots ps))))

(defun pslot-internal-accessor
 (slot argument structure-type &optional (no-type-check nil)) 
                                                    "returns a form which fetches slot from argument"
   (ecase structure-type (datatype `(,(if no-type-check 'il:ffetchfield 'il:fetchfield)
                                     ',(pslot-field-descriptor slot)
                                     ,argument))
          (list `(nth ,(pslot-field-descriptor slot) ,argument))
          (vector `(svref ,argument ,(pslot-field-descriptor slot)))))

(defun define-setfs
 (ps) "returns the forms that when evaluated, define the setf's for the slots."
   (let ((arg-name (ps-name ps))
         (structure-type (ps-type ps)))
           (il:* il:|;;| "map over the slots, and for any slot which is not read-only, generate a defsetf and a function definition for the setter.")

        (mapcan #'(lambda (slot)
                         (let* ((accessor (pslot-accessor slot))
                                (setf-function (setf-name accessor)))

                                                  (il:* il:|;;| 

       "function-defining-form decides whether or not the accessors should be defun, definline, etc.")

                               (if (not (pslot-read-only slot))
                                   `((defsetf (il:\\\,
 accessor) ,setf-function )

                                     (,(function-defining-form ps 'setfs) ,setf-function
                                            (,arg-name value)
                                            (setf ,(pslot-internal-accessor slot arg-name 
                                                          structure-type) value)))))) (ps-all-slots
                                                                                       ps))))

(defun setf-name
 (accessor-name) "produces the name of the setf function for this accessor"
   (xcl:pack (list '%%setf- accessor-name)))




(il:* il:|;;;| "constructor definition code")


(defun define-constructors
 (ps) "returns the forms that when evaluated, define the constructors"
   (let* ((constructors (ps-constructors ps))
          (slots (ps-all-slots ps))
          (result-arg (ps-name ps))
          (all-boas? (every #'boa-constructor-p constructors)))
         (cond
            (all-boas? 
                           (il:* il:|;;| 

                                                  "don't bother building the arglist etc.")

                   (mapcar #'(lambda (constructor)
                                    (define-boa-constructor constructor ps)) constructors))
            (t (let ((argument-list (build-constructor-arglist slots))
                     (slot-setfs (build-constructor-slot-setfs slots ps)))
                    (il:for
 constructor il:in
 constructors
                       il:collect
 (cond
                                     ((boa-constructor-p constructor)
                                      (define-boa-constructor constructor ps))
                                     (t 
          (il:* il:|;;| 

                     "keep the name of a standard constructor, if any, so that the #s form can work.")

                                        (setf (ps-standard-constructor ps)
                                              constructor)

                                                  (il:* il:|;;| 

            "since we just built the object we're setting fields of, we don't need to type check it.")

                                        `(,(function-defining-form ps 'constructor)
                                          ,constructor
                                          (&key ,@argument-list)
                                          (let ((,result-arg ,(raw-constructor ps)))
                                               ,@slot-setfs
                                               ,result-arg))))))))))

(defun define-boa-constructor
 (name&arglist ps) (let* ((constructor-name (car name&arglist))
                                                       (arglist (cadr name&arglist))
                                                       (new-argument-list (
                                                                     boa-arg-list-with-initial-values
                                                                           arglist ps))
                                                       (result-arg (ps-name ps))
                                                       (slot-setfs (boa-slot-setfs result-arg
                                                                          (argument-names arglist)
                                                                          ps)))
                                                      `(,(function-defining-form ps 'boa-constructor)
                                                        ,constructor-name
                                                        ,new-argument-list
                                                        (let ((,result-arg ,(raw-constructor ps)))
                                                             ,@slot-setfs
                                                             ,result-arg))))

(defun argument-names
 (arg-list) (mapcan #'(lambda (arg)
                                                  (cond
                                                     ((consp arg)
                                                      (list (car arg)))
                                                     ((member arg lambda-list-keywords)
                                                      nil)
                                                     (t (list arg)))) arg-list))

(defun boa-arg-list-with-initial-values
 (arg-list ps)
   (let ((new-arg-list (copy-tree arg-list))
         (slots (ps-all-slots ps)))
               (il:* il:|;;| 

                         "for all the args from &optional up to &rest or &aux get the default value.")

        (il:for
 arg-tail il:on
 (cdr (member '&optional new-arg-list))
           il:do
 (cond
                    ((member (car arg-tail)
                            lambda-list-keywords)
 (il:* il:|;;| 

                                          "we have found an ampersand arg, we're done the optionals.")

                     (return))
                    (t (let ((optional (car arg-tail)))
                            (setf (car arg-tail)
                                  (cond
                                     ((member optional '(&rest &aux))

                                                  (il:* il:|;;| 

                                                 "we have hit the end of the optionals, just return.")

                                      (return))
                                     ((member optional lambda-list-keywords)

                                                             (il:* il:|;;| "illegal keyword here")

                                      (error 
                                            "~S cannot appear in a BOA constructor as it does in ~S." 
                                             optional arg-list))
                                     ((symbolp optional)
                                      `(,optional ,(pslot-initial-value (find-slot optional slots))))
                                     ((and (consp optional)
                                           (cdr optional))

                                                  (il:* il:|;;| 

                                                  "already a default just leave it alone")

                                      optional)
                                     ((consp optional)
                                      `(,(car optional) ,(pslot-initial-value (find-slot (car 
                                                                                             optional
                                                                                              )
                                                                                     slots))))))))))
        new-arg-list))

(defun boa-slot-setfs
 (result-arg slot-names ps)
   (let ((slots (ps-all-slots ps))
         (structure-type (ps-type ps)))
        (mapcar #'(lambda (name)
                         (let ((slot (find-slot name slots)))
                              `(setf ,(pslot-internal-accessor slot result-arg structure-type t)
                                     ,name))) slot-names)))

(defun find-slot
 (name slots &optional (dont-error nil)) (dolist (slot slots (or dont-error
                                                                                 (error 
                                                                                 "slot ~s not found." 
                                                                                        name)))
                                                                (if (eq name (pslot-name slot))
                                                                    (return slot))))

(defun raw-constructor
 (ps) 
                    "returns a form which will make an instance of this structure w/o initialisation"
   (ecase (ps-type ps)
          (datatype `(il:ncreate ',(ps-name ps)))
          (list `(make-list ,(ps-number-of-slots ps)))
          (vector `(make-array '(,(ps-number-of-slots ps)) :element-type ',(ps-vector-type ps)))))

(defun build-constructor-arglist
 (slots) 
                                 "gathers the keywords and initial-values for (non BOA) constructors"
   (mapcan #'(lambda (slot)
                    (let ((init-form (pslot-initial-value slot))
                          (arg-name (pslot-name slot)))
                         (cond
                            ((not (pslot-accessor slot))

                                                  (il:* il:|;;| 

                "this is an invisible slot (name, initial-offset, etc.) don't generate a keyword arg")

                             nil)
                            (init-form 
           (il:* il:|;;| 

                                                  "specify an initial value for the keyword arg")

                                   `((,arg-name ,init-form)))
                            (t `(,arg-name))))) slots))

(defun build-constructor-slot-setfs
 (slots ps) 
                                        "builds the setfs that initialize the slots in a constructor"
   (let ((structure-type (ps-type ps))
         (object-name (ps-name ps)))
        (mapcar #'(lambda (slot)
                         (cond
                            ((not (pslot-accessor slot))

                                                  (il:* il:|;;| 

                                           "invisible slot, so generate a setf to it's initial-value")

                             `(setf ,(pslot-internal-accessor slot object-name structure-type t)
                                    ,(pslot-initial-value slot)))
                            (t (let ((keyword-arg-name (pslot-name slot)))

                                                  (il:* il:|;;| 

                    " since slots can be read-only, we setf the raw accessor, not the slot accessor.")


                                                  (il:* il:|;;| "Also, since we built the object in which we are setting fields, we use the internal-accessor without typecheck")

                                    `(setf ,(pslot-internal-accessor slot object-name structure-type 
                                                   t) ,keyword-arg-name))))) slots)))

(defun boa-constructor-p
 (constructor) 
                                "returns t if the constructor is a By Order of Arguments constructor"
   (consp constructor))

(defun default-constructor-name
 (structure-name) (xcl:pack (list 'make- structure-name)))




(il:* il:|;;;| "predicate")


(defun construct-predicate
 (ps) "returns a list of the forms (if any) defining the predicate for ps"
   (let ((predicate (ps-predicate ps)))
        (if predicate
            (let ((predicate-body
                   (case (ps-type ps)
                         (datatype 
               (il:* il:|;;| 

                                               "for datatypes, always create a predicate.  Use typep")

                                `(typep object ',(ps-name ps)))
                         (otherwise 
              (il:* il:|;;| 

                                      "vectors and lists can only have a predicate if they are named")

                                (if (not (ps-named ps))
                                    (error 
                             "The predicate ~s may not be specified for ~s because it is not :name'd" 
                                           predicate (ps-name ps)))
                                `(and (typep object 'sequence)
                                      (eq (elt (the ,(ps-type-specifier ps) object)
                                               ,(ps-name-slot-position ps))
                                          ',(ps-name ps)))))))
                 `((,(function-defining-form ps 'predicate) ,predicate (object)
                          ,predicate-body))))))

(defun ps-name-slot-position
 (ps) "returns the offset of the name slot for ps."
   (let* ((include (ps-include ps))
          (super-slots (and include (ps-all-slots (parsed-structure include)))))
         (+ (ps-initial-offset ps)
            (length super-slots))))

(defun default-predicate-name
 (structure-name) (xcl:pack (list structure-name '-p)))

(defun function-defining-form
 (ps context) 
                       "dummy definition for now, for deciding if a function should be inline or not"
   'defun)




(il:* il:|;;;| "copiers")


(defun define-copiers
 (ps) "returns the form that when evaluated, defines the copier"
   (let ((copier (ps-copier ps))
         (result-arg 'new)
         (from-arg (ps-name ps)))
        (if copier (multiple-value-bind (from-arg-type-check type-check-slots?)
                          (build-copier-type-check ps from-arg)
                          (let ((slot-setfs (build-copier-slot-setfs (ps-all-slots ps)
                                                   (ps-type ps)
                                                   from-arg result-arg type-check-slots?)))

                                                  (il:* il:|;;| 

            "Since we just built the object we're setting fields of, we don't need to type check it.")

                               `((,(function-defining-form ps 'copiers)
                                  ,(ps-copier ps)
                                  (,from-arg)
                                  ,@from-arg-type-check
                                  (let ((,result-arg ,(raw-constructor ps)))
                                       ,@slot-setfs
                                       ,result-arg))))))))

(defun build-copier-slot-setfs
 (slots structure-type from-argument to-argument type-check-slots?) 
                                               "constructs the forms that copy each individual slot."
   
                                               (il:* il:|;;| 

                                                  "build a series of forms that look like")


                                                  (il:* il:|;;| 

                                           "(setf (structure-slot to-arg) (structure-slot from-arg))")

   (mapcar #'(lambda (slot)
                    `(setf ,(pslot-internal-accessor slot to-argument structure-type t)
                           ,(pslot-internal-accessor slot from-argument structure-type t))) slots))

(defun build-copier-type-check
 (ps from-arg) "constructs the type checking form at the beginning of the copier and decides whether individual slots need to be type-checked."
   (cond
      ((eq (ps-type ps)
           'datatype)
                             (il:* il:|;;| "If something is a datatype type check the from-arg once at the beginning.  Don't check the individual accesses.")

       (values `((check-type ,from-arg ,(ps-name ps))) nil))
      ((ps-predicate ps)
                          (il:* il:|;;| 

                                         "if the structure has a predicate ,then call the predicate.")

       (values `((or (,(ps-predicate ps) ,from-arg)
                     (error ,(format nil "Arg not ~s: ~~S" (ps-name ps)) ,from-arg))) nil))
      (t 
                                         (il:* il:|;;| "Otherwise, just use the type-checked slot access, so that at least the argument is assured to be a vector/list.")

         (values nil t))))




(il:* il:|;;;| "print functions")


(defvar %default-print-function
 'default-structure-printer 
                                          "print function used when none is specified in a defstruct"
   )




(il:* il:|;;;| "internal stuff.")


(defsetf il:ffetchfield
 il:replacefield)




(il:* il:|;;;| "utilities")


(defun safe-type-expand
 (type-form) (let ((type-expander (type-expander type-form)))
                                         (if type-expander (type-expand type-form type-expander)
                                             type-form)))

(defmacro defstruct-assert-subtypep
 (type1 type2 (error-string . error-args) . cerror-actions) 
     "provides an interface for places where the implementor isn't sure that subtypep can be trusted"
   (let ((error-string (or error-string "~S is not a subtype of ~S"))
         (error-args (or error-args (list type1 type2))))
        `(multiple-value-bind (subtype? certain?)
                (subtypep ,type1 ,type2)
                (cond
                   (subtype? 
                                (il:* il:\; "it's ok, continue")

                          t)
                   (certain? 
                       (il:* il:\; "subtypep says it sure, so blow up")

                          (funcall #'error ,error-string ,@error-args))
                   (t 
                            (il:* il:\; 

                                                  "subtypep isn't sure, so raise a continuable error")

                      (funcall #'cerror "Assume subtypep should return t"
                             ,(format nil "Perhaps, ~a" error-string)
                             ,@error-args)
                      ,@cerror-actions t)))))




(il:* il:|;;;| "file properties")



(il:putprops il:defstruct il:filetype
 compile-file)

(il:putprops il:defstruct il:makefile-environment
 (:readtable "XCL" :package "LISP"))
(il:putprops il:defstruct il:copyright ("Xerox Corporation" 1986))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop