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

(IL:FILECREATED " 4-Jan-93 18:04:53" IL:|{DSK}<python>lde>lispcore>sources>DEFSTRUCT.;2|
 83865  

      IL:|previous| IL:|date:| "11-Jun-92 14:44:30" IL:|{DSK}<python>lde>lispcore>sources>DEFSTRUCT.;1|
)


; Copyright (c) 1986, 1987, 1900, 1988, 1989, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:DEFSTRUCTCOMS)

(IL:RPAQQ IL:DEFSTRUCTCOMS
 (

(IL:* IL:|;;;| "Implementation of Structure facilities of Commmon Lisp.  (Chapter 19 of CLtL).")


                                

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


                                (IL:DEFINE-TYPES IL:STRUCTURES)
                                (IL:FUNCTIONS DEFSTRUCT)
                                

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


                                (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:FILES 
                                                                                IL:DEFSTRUCT-RUN-TIME
                                                                                ))
                                

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


                                (IL:VARIABLES %DEFAULT-DEFSTRUCT-TYPE %DEFAULT-SLOT-TYPE 
                                       %DEFAULT-STRUCTURE-INCLUDE %DEFSTRUCT-OPTIONS %NO-CONSTRUCTOR
                                       %NO-PREDICATE %NO-COPIER %DEFSTRUCT-CONSP-OPTIONS 
                                       %DEFSTRUCT-EXPORT-OPTIONS)
                                (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:* IL:|;;;| "slot resolution code")


                                (IL:FUNCTIONS ASSIGN-SLOT-OFFSET RESOLVE-SLOTS INSERT-INCLUDED-SLOT 
                                       MERGE-SLOTS NAME-SLOT DUMMY-SLOT OFFSET-SLOT)
                                

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


                                (IL:FUNCTIONS ASSIGN-STRUCTURE-REPRESENTATION COERCE-TYPE 
                                       %STRUCTURE-TYPE-TO-FIELDSPEC ASSIGN-FIELD-DESCRIPTORS 
                                       STRUCTURE-POINTER-SLOTS)
                                

(IL:* IL:|;;;| "type system hooks")


                                (IL:FUNCTIONS PROCESS-TYPE PREDICATE-BODY TYPE-EXPAND-STRUCTURE 
                                       TYPE-EXPAND-NAMED-STRUCTURE PS-NAME-SLOT-POSITION 
                                       DEFAULT-PREDICATE-NAME DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER 
                                       CACHE-PREDICATE-INFO)
                                (IL:VARIABLES %FUNCTION-DEFINING-FORM-KEYWORDS)
                                

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


                                (IL:FUNCTIONS SETF-NAME)
                                (IL:FUNCTIONS ACCESSOR-BODY PROCESS-ACCESSORS ESTABLISH-ACCESSORS 
                                       DEFINE-ACCESSORS DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER 
                                       DEFSTRUCT-SHARED-SETF-EXPANDER CACHE-SLOT-INFO)
                                (IL:FUNCTIONS %MAKE-ACCESSOR-CLOSURE %MAKE-LIST-ACCESSOR 
                                       %MAKE-ARRAY-ACCESSOR %MAKE-POINTER-ACCESSOR %MAKE-BIT-ACCESSOR
                                       %MAKE-FLAG-ACCESSOR %MAKE-WORD-ACCESSOR %MAKE-FIXP-ACCESSOR 
                                       %MAKE-SMALL-FIXP-ACCESSOR %MAKE-FLOAT-ACCESSOR)
                                

(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:|;;;| "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 DEFSTRUCT-ASSERT-SUBTYPEP)
                                

(IL:* IL:|;;;| "inspecting structures")


                                (IL:FUNCTIONS STRUCTURE-OBJECT-P INSPECT-STRUCTURE-OBJECT 
                                       STRUCTURE-OBJECT-INSPECT-FETCHFN 
                                       STRUCTURE-OBJECT-INSPECT-PROPPRINTFN 
                                       STRUCTURE-OBJECT-INSPECT-STOREFN 
                                       STRUCTURE-OBJECT-PROPCOMMANDFN)
                                
                                (IL:* IL:|;;| 

                          "Defined last so functions required to load a defstruct are loaded first")


                                (IL:STRUCTURES PS PARSED-SLOT)
                                
                                (IL:* IL:|;;| 

                     "Mapping between names of generated functions and their associated structures")


                                (IL:FUNCTIONS STRUCTURE-FUNCTION-P STRUCTURE-FUNCTIONS)
                                

(IL:* IL:|;;;| "Editing structures")


                                (IL:FUNCTIONS STRUCTURES.HASDEF STRUCTURES.EDITDEF)
                                (IL:P (IL:FILEPKGTYPE 'IL:STRUCTURES 'IL:HASDEF 'STRUCTURES.HASDEF
                                             'IL:EDITDEF
                                             'STRUCTURES.EDITDEF))
                                (IL:ADDVARS (IL:SHADOW-TYPES (IL:STRUCTURES IL:FNS)))
                                (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD
                                       (IL:ADDVARS (IL:INSPECTMACROS ((IL:FUNCTION STRUCTURE-OBJECT-P
                                                                             )
                                                                          . INSPECT-STRUCTURE-OBJECT)
                                                          )))
                                

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


                                (IL:PROP IL:FILETYPE IL:DEFSTRUCT)
                                (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:DEFSTRUCT)))



(IL:* IL:|;;;| "Implementation of Structure facilities of Commmon Lisp.  (Chapter 19 of CLtL).")





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



(XCL:DEF-DEFINE-TYPE IL:STRUCTURES
 "Common Lisp structures")

(XCL:DEFDEFINER (DEFSTRUCT
 (:NAME (LAMBDA (WHOLE)
                                             (LET ((NAME-AND-OPTIONS (SECOND WHOLE)))
                                                  (IF (CONSP NAME-AND-OPTIONS)
                                                      (CAR NAME-AND-OPTIONS)
                                                      NAME-AND-OPTIONS))))
                               (:PROTOTYPE (LAMBDA (NAME)
                                                  (AND (SYMBOLP NAME)
                                                       `(DEFSTRUCT (,NAME (":option" "value"))
                                                           "documentation string"
                                                           ("slot-name" "initial-value")))))) 
   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 (EVAL-WHEN (EVAL COMPILE LOAD)
                        (SETF (PARSED-STRUCTURE ',(PS-NAME PS)
                                     T)
                              ',PS))
                 ,@(ASSIGN-STRUCTURE-REPRESENTATION
 PS)
                 ,@(PROCESS-TYPE
 PS)
                 ,@(PROCESS-ACCESSORS
 PS)
                 (EVAL-WHEN (EVAL COMPILE LOAD)
                        (ESTABLISH-SETFS-AND-OPTIMIZERS ',(PS-NAME PS)))
                 ,@(DEFINE-CONSTRUCTORS
 PS)
                 ,@(DEFINE-COPIERS
 PS)
                 ,@(RECORD-DOCUMENTATION
 PS))))



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


(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 

(IL:FILESLOAD IL:DEFSTRUCT-RUN-TIME)
)



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



(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
 'STRUCTURE-OBJECT "datatype included by every structure")

(DEFPARAMETER %DEFSTRUCT-OPTIONS

   '(:CONC-NAME :CONSTRUCTOR :COPIER :PREDICATE :INCLUDE :PRINT-FUNCTION :TYPE :INITIAL-OFFSET :NAMED
           :INLINE :FAST-ACCESSORS :TEMPLATE :EXPORT))

(DEFCONSTANT %NO-CONSTRUCTOR
 ':NONE "the value which says that no constructor was specified.")

(DEFCONSTANT %NO-PREDICATE
 ':NONE "the value which says that no constructor was specified")

(DEFCONSTANT %NO-COPIER
 ':NONE)

(DEFPARAMETER %DEFSTRUCT-CONSP-OPTIONS
 (REMOVE ':NAMED %DEFSTRUCT-OPTIONS))

(DEFPARAMETER %DEFSTRUCT-EXPORT-OPTIONS
 '(:ACCESSOR :CONSTRUCTOR :PREDICATE :COPIER))

(DEFUN ASSIGN-SLOT-ACCESSOR
 (SLOT CONC-NAME)

   (IL:* IL:|;;| "assigns the accessor name to a slot")


   (IF (PSLOT-ACCESSOR SLOT)
       (SETF (PSLOT-ACCESSOR SLOT)
             (VALUES (INTERN (CONCATENATE 'STRING (STRING CONC-NAME)
                                    (STRING (PSLOT-NAME SLOT))))))))

(DEFUN REMOVE-DOCUMENTATION
 (PS SLOT-DESCRIPTIONS)

   (IL:* IL:|;;| "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)

   (IL:* IL:|;;| "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)

   (IL:* IL:|;;| "Bogus right now ")


   TYPE-FORM)

(DEFUN PARSE-SLOT
 (DESCRIPTION &OPTIONAL (GENERATE-ACCESSOR T))

   (IL:* IL:|;;| 

 "Takes a slot description from the defstruct body or included slots and returns a parsed version")


   (LET* ((DESCRIPTION (IF (CONSP DESCRIPTION)
                           DESCRIPTION
                           (LIST DESCRIPTION)))
          (SLOT (MAKE-PARSED-SLOT)))
         (XCL:DESTRUCTURING-BIND (NAME &OPTIONAL INITIAL-VALUE &REST 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.")


                (DO ((OPTION-PAIR SLOT-OPTIONS (CDDR OPTION-PAIR)))
                    ((NULL OPTION-PAIR))
                  (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)

   (IL:* IL:|;;| "Returns a structure representing the options in a defstruct call.")


   (LET* ((OPTIONS (IF (LISTP NAME&OPTIONS)
                       NAME&OPTIONS
                       (LIST NAME&OPTIONS)))
          (NAME (POP OPTIONS))
          (PS (MAKE-PS :NAME NAME :CONC-NAME (CONCATENATE 'STRING (STRING NAME)
                                                    "-"))))
         (DOLIST (OPTION OPTIONS)
             (COND
                ((LISTP OPTION)
                 (XCL:DESTRUCTURING-BIND (OPTION-KEYWORD &OPTIONAL (OPTION-VALUE NIL 
                                                                          ARGUMENT-PROVIDED)
                                                &REST FURTHER-ARGUMENTS)
                        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
                                  ((NOT OPTION-VALUE)
                                   (IF ARGUMENT-PROVIDED

                                       (IL:* IL:|;;| 

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


                                       (SETF (PS-CONSTRUCTORS PS)
                                             NIL)

                                       (IL:* IL:|;;| "otherwise, it as though the option weren't specified (p. 312 cltl) so leave the default value there.")


                                       ))
                                  ((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 (TYPEP OPTION-VALUE '(INTEGER 0 *)))
                                   (ERROR ":initial-offset isn't a non-negative integer: ~S" 
                                          OPTION-VALUE))
                               (SETF (PS-INITIAL-OFFSET PS)
                                     OPTION-VALUE))
                            (:INLINE 

                               (IL:* IL:|;;| 

                  "Is one or both of  :accessor, and  :predicate or t, which is equivalent to both")


                               (IL:* IL:|;;| "Default is '(:accessor :predicate) ")


                               (IL:* IL:|;;| 

                "option (:inline :only) implies no funcallable accessors or predicate is generated")


                               (IF ARGUMENT-PROVIDED
                                   (SETF (PS-INLINE PS)
                                         OPTION-VALUE)))
                            (:FAST-ACCESSORS 

                               (IL:* IL:|;;| 

                             "Is either t or nil,  t implying no type checks for all accessors")


                               (IF ARGUMENT-PROVIDED
                                   (SETF (PS-FAST-ACCESSORS PS)
                                         OPTION-VALUE)))
                            (:TEMPLATE 

                               (IL:* IL:|;;| "Is either t or nil -- t  implying type datatype, no copier, predicate, print-function or constructors, and fast accessors, and no new datatype declared.")


                               (IF ARGUMENT-PROVIDED
                                   (SETF (PS-TEMPLATE PS)
                                         OPTION-VALUE)))
                            (:EXPORT 

                               (IL:* IL:|;;| "Edited by TT(13-June-90) Export Option is added for DEFSTRUCT(Medley 1.2). The Specified functions(ex. :constructor, :copier...) will be exported.")


                               (IF FURTHER-ARGUMENTS
                                   (ERROR "The specified export functions is not list or atom : ~S"
                                          (CONS :EXPORT (CONS OPTION-VALUE FURTHER-ARGUMENTS)))
                                   (IF ARGUMENT-PROVIDED
                                       (SETF (PS-EXPORT PS)
                                             OPTION-VALUE)
                                       (SETF (PS-EXPORT PS)
                                             T))))
                            (OTHERWISE (ERROR "Bad option to defstruct: ~S." OPTION)))))
                (T (CASE OPTION
                       (:NAMED (SETF (PS-NAMED PS)
                                     T))
                       (OTHERWISE (IF (MEMBER OPTION %DEFSTRUCT-CONSP-OPTIONS :TEST #'EQ)
                                      (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)

   (IL:* IL:|;;| 

 "Accomplishes the consistency checks that can't occur until all the options have been parsed.")


   (IF (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 defined.")


             (IF (OR (NULL INCLUDED-PSTRUCTURE)
                     (PS-TEMPLATE INCLUDED-PSTRUCTURE))
                 (ERROR "Included structure ~s is unknown or not instantiated." INCLUDE))

             (IL:* IL:|;;| "make sure the type of the included structure is the same")


             (IF (OR (NOT (EQ (PS-TYPE INCLUDED-PSTRUCTURE)
                              (PS-TYPE PS)))
                     (NOT (EQ (PS-VECTOR-TYPE INCLUDED-PSTRUCTURE)
                              (PS-VECTOR-TYPE PS))))
                 (ERROR "~s must be same type as included structure ~s" (PS-NAME PS)
                        INCLUDE))))
   (LET ((INLINE (PS-INLINE PS))
         (POSSIBLE-KEYWORDS '(:ACCESSOR :PREDICATE)))
        (CASE INLINE
            ((T) 

               (IL:* IL:|;;| 

 "this is the default case, so make the default be that only the accessors, predicates are inline.")


               (SETF (PS-INLINE PS)
                     POSSIBLE-KEYWORDS))
            ((NIL :ONLY) )
            (OTHERWISE (MAPCAR #'(LAMBDA (KEYWORD)
                                        (IF (NOT (MEMBER KEYWORD POSSIBLE-KEYWORDS :TEST #'EQ))
                                            (ERROR "~s must be one of ~s." KEYWORD POSSIBLE-KEYWORDS)
                                            ))
                              (IF (CONSP INLINE)
                                  INLINE
                                  (SETF (PS-INLINE PS)
                                        (LIST INLINE)))))))
   (COND
      ((PS-TEMPLATE PS)
       (IF (NOT (EQ (PS-TYPE PS)
                    %DEFAULT-DEFSTRUCT-TYPE))
           (ERROR "Templated defstructs may not be of type: ~s" (PS-TYPE PS)))
       (IF (OR (NOT (EQ (PS-CONSTRUCTORS PS)
                        %NO-CONSTRUCTOR))
               (NOT (EQ (PS-PREDICATE PS)
                        %NO-PREDICATE))
               (NOT (EQ (PS-COPIER PS)
                        %NO-COPIER))
               (PS-PRINT-FUNCTION PS))
           (ERROR 
               "Templated defstructs may not have constructors predicates copiers or print functions"
                  )))
      (T (IF (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)))
             (LET ((INCLUDE (PS-INCLUDE PS)))
                  (IF INCLUDE

                      (IL:* IL:|;;| "CLtL is silent, but we inherit print-functions")


                      (SETF (PS-PRINT-FUNCTION PS)
                            (PS-PRINT-FUNCTION (PARSED-STRUCTURE INCLUDE)))

                      (IL:* IL:|;;| "otherwise, use the default #s style printer")


                      (SETF (PS-PRINT-FUNCTION PS)
                            %DEFAULT-PRINT-FUNCTION))))
         (IF (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))))
         (IF (EQ (PS-PREDICATE PS)
                 %NO-PREDICATE)

             (IL:* IL:|;;| "there is no predicate. (Note that this is not a null check.  If this field is NIL the user explicitly gave NIL as the predicate.)  ")


             (IF (OR (EQ (PS-TYPE PS)
                         'DATATYPE)
                     (PS-NAMED PS))

                 (IL:* IL:|;;| "If this structure is type datatype or named, use the default name")


                 (SETF (PS-PREDICATE PS)
                       (DEFAULT-PREDICATE-NAME
 (PS-NAME PS)))

                 (IL:* IL:|;;| "now set it to NIL to signal no predicate to the predicate builder.")


                 (SETF (PS-PREDICATE PS)
                       NIL)))
         (IF (EQ (PS-COPIER PS)
                 %NO-COPIER)

             (IL:* IL:|;;| "Note that this is not a null check.  If this field is NIL the user explicitly gave NIL as the copier  ")


             (SETF (PS-COPIER PS)
                   (INTERN (CONCATENATE 'STRING "COPY-" (STRING (PS-NAME PS))))))
         (LET ((EXPORTNAMES (PS-EXPORT PS)))

              (IL:* IL:|;;| "If export-slot is nil, functions will not be exported. otherwise, export the specified functions.[Edited by TT (13-June-90)")


              (AND EXPORTNAMES (OR (EQ EXPORTNAMES T)
                                   (AND (NOT (LISTP EXPORTNAMES))
                                        (NOT (SETF (PS-EXPORT PS)
                                                   (SETQ EXPORTNAMES (LIST EXPORTNAMES)))))
                                   (DOLIST (EXPORTNAME EXPORTNAMES T)
                                       (OR (MEMBER EXPORTNAME %DEFSTRUCT-EXPORT-OPTIONS)
                                           (ERROR "~S is not valid option keyword for :EXPORT" 
                                                  EXPORTNAME))))))
         (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)))))



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



(DEFUN ASSIGN-SLOT-OFFSET
 (PS)

   (IL:* IL:|;;| "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.")


                (DO ((I 0 (1+ I))
                     (SLOT SLOTS (CDR SLOT)))
                    ((NULL SLOT))
                  (SETF (PSLOT-FIELD-DESCRIPTOR (CAR SLOT))
                        I))))))

(DEFUN RESOLVE-SLOTS
 (LOCAL-SLOT-DESCRIPTIONS PS)

   (IL:* IL:|;;| "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")


   (LET ((LOCAL-SLOTS (MAPCAR #'PARSE-SLOT LOCAL-SLOT-DESCRIPTIONS))
         (INCLUDED-SLOTS (MAPCAR #'PARSE-SLOT (PS-INCLUDED-SLOTS PS)))
         (INCLUDES (PS-INCLUDE PS)))
        (WHEN (PS-NAMED PS)

            (IL:* IL:|;;| "Adds the slot representing the name pseudo-slot. ")


            (IF (NOT (PS-NAMED PS))
                (ERROR ":named not supplied for this defstruct"))
            (PUSH (NAME-SLOT
 PS)
                  LOCAL-SLOTS))
        (WHEN (NOT (EQ 0 (PS-INITIAL-OFFSET PS)))

            (IL:* IL:|;;| "Adds parsed-slots to the local-slots to represent the initial offset.")


            (SETQ LOCAL-SLOTS (NCONC (XCL:WITH-COLLECTION (DOTIMES (I (PS-INITIAL-OFFSET PS))
                                                              (XCL:COLLECT (OFFSET-SLOT
))))
                                     LOCAL-SLOTS)))
        (IF INCLUDES
            (LET ((SUPER-SLOTS 

                         (IL:* IL:|;;| "must copy the slots, since the accessor-name will be destructively modified to use the new conc-name.")


                         (MAPCAR #'COPY-PARSED-SLOT (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)))
            (PROGN (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)))
        (WHEN (AND (NULL (PS-ALL-SLOTS PS))
                   (EQ (PS-TYPE PS)
                       %DEFAULT-DEFSTRUCT-TYPE))
            (PUSH (DUMMY-SLOT
)
                  LOCAL-SLOTS)
            (SETF (PS-ALL-SLOTS PS)
                  LOCAL-SLOTS))

        (IL:* IL:|;;| "No longer require local slots to be recorded")


        (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)))

        (IL:* IL:|;;| "make sure that no slot names have been repeated (either from being explicitly listed twice in the defstruct, or using a slot name that is present in the super without using :include for the slot)")


        (DO ((SLOT-NAMES (PS-ALL-SLOT-NAMES PS)
                    (CDR SLOT-NAMES)))
            ((NULL SLOT-NAMES))
          (IF (MEMBER (CAR SLOT-NAMES)
                     (CDR SLOT-NAMES)
                     :TEST
                     #'EQ)
              (ERROR "The slot ~s is repeated in ~s." (CAR SLOT-NAMES)
                     (PS-ALL-SLOT-NAMES PS))))))

(DEFUN INSERT-INCLUDED-SLOT
 (NEW-SLOT SUPER-SLOTS PS)

   (IL:* IL:|;;| "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)

   (IL:* IL:|;;| "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)

   (IL:* IL:|;;| "Returns a parsed-slot representing the 'name' field of a structure")


   (PARSE-SLOT
 `(SI::--STRUCTURE-NAME-SLOT-- ',(PS-NAME PS)
                           :READ-ONLY T)
          NIL))

(DEFUN DUMMY-SLOT
 ()
   (PARSE-SLOT
 `(SI::--STRUCTURE-DUMMY-SLOT-- NIL :READ-ONLY T :TYPE IL:XPOINTER)
          NIL))

(DEFUN OFFSET-SLOT
 ()
   (PARSE-SLOT
 `(,(GENSYM)

                     (IL:* IL:|;;| "to make sure that names are unique, so that when the inspector works on :type list, there will be a unique name.")


                     NIL :READ-ONLY T)
          NIL))



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



(DEFUN ASSIGN-STRUCTURE-REPRESENTATION
 (PS)

   (IL:* IL:|;;| 

 "Determines the descriptors and returns a form to create the datatype at loadtime.")


   (IL:* IL:|;;| "Side effects ps.")


   (LET ((LOCAL-SLOTS (PS-LOCAL-SLOTS PS)))

        (IL:* IL:|;;| "Local slots no longer need be recorded")


        (SETF (PS-LOCAL-SLOTS PS)
              NIL)
        (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)
               NIL)
            (DATATYPE (LET* ((LOCAL-FIELD-SPECS (MAPCAR #'(LAMBDA (SLOT)
                                                                 (%STRUCTURE-TYPE-TO-FIELDSPEC

                                                                  (PSLOT-TYPE SLOT)))
                                                       LOCAL-SLOTS))
                             (SUPER-FIELD-SPECS (IF (PS-INCLUDE PS)
                                                    (PS-FIELD-SPECIFIERS (PARSED-STRUCTURE
                                                                          (PS-INCLUDE PS)))))
                             (ALL-FIELD-SPECS (APPEND SUPER-FIELD-SPECS LOCAL-FIELD-SPECS))
                             (STRUCTURE-NAME (PS-NAME PS)))
                            (SETF (PS-FIELD-SPECIFIERS PS)
                                  ALL-FIELD-SPECS)
                            (XCL:DESTRUCTURING-BIND
                             (LENGTH &REST FIELD-DESCRIPTORS)
                             (IL:TRANSLATE.DATATYPE (IF (NOT (PS-TEMPLATE PS))
                                                        STRUCTURE-NAME)
                                    ALL-FIELD-SPECS)

                             (IL:* IL:|;;| "Note that this side-effects ps")


                             (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")


                             (IF (NOT (PS-TEMPLATE PS))
                                 `((SI::%STRUCTURE-DECLARE-DATATYPE ',STRUCTURE-NAME
                                          ',ALL-FIELD-SPECS
                                          ',FIELD-DESCRIPTORS
                                          ,LENGTH
                                          ',(OR (PS-INCLUDE PS)
                                                %DEFAULT-STRUCTURE-INCLUDE))))))))))

(DEFUN COERCE-TYPE
 (ELEMENT-TYPE)

   (IL:* IL:|;;| "As in IL:%canonical-cml-type -- Returns the types (t, string-char, single-float, IL:xpointer, (unsigned-byte n) and (signed-byte n)")


   (IF (CONSP ELEMENT-TYPE)
       (CASE (CAR ELEMENT-TYPE)
           (UNSIGNED-BYTE 

              (IL:* IL:|;;| "Let the bits hang out")


              (IF (> (CADR ELEMENT-TYPE)
                     16)
                  T
                  ELEMENT-TYPE))
           (SIGNED-BYTE (IL:%GET-ENCLOSING-SIGNED-BYTE ELEMENT-TYPE))
           (MOD 

              (IL:* IL:|;;| "From cmlarray -- reduces (mod n) to (unsigned-byte m)")


              (IL:%REDUCE-MOD ELEMENT-TYPE))
           (INTEGER 

              (IL:* IL:|;;| "From cmlarray -- reduces (integer x y) to (signed-byte m)")


              (IL:%REDUCE-INTEGER ELEMENT-TYPE))
           (MEMBER (IF (AND (EQ 2 (LENGTH (CDR ELEMENT-TYPE)))
                            (EVERY #'(LAMBDA (ELT)
                                            (OR (EQ ELT T)
                                                (EQ ELT NIL)))
                                   (CDR ELEMENT-TYPE)))
                       ELEMENT-TYPE
                       T))
           (T 
              (IL:* IL:|;;| "Attempt type expansion")


              (LET ((EXPANDER (TYPE-EXPANDER (CAR ELEMENT-TYPE))))
                   (IF EXPANDER
                       (COERCE-TYPE
 (TYPE-EXPAND ELEMENT-TYPE EXPANDER))
                       T))))
       (CASE ELEMENT-TYPE
           ((T IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER SINGLE-FLOAT STRING-CHAR) ELEMENT-TYPE)
           (IL:POINTER T)
           ((FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) 'SINGLE-FLOAT)
           (FIXNUM 

              (IL:* IL:|;;| 

            "Could be (signed-byte 32) -- but pointer representation is more efficient")


              T)
           (CHARACTER 'STRING-CHAR)
           (BIT '(UNSIGNED-BYTE 1))
           (T (LET ((EXPANDER (TYPE-EXPANDER ELEMENT-TYPE)))
                   (IF EXPANDER
                       (COERCE-TYPE
 (TYPE-EXPAND ELEMENT-TYPE EXPANDER))
                       T))))))

(DEFUN %STRUCTURE-TYPE-TO-FIELDSPEC
 (ELEMENT-TYPE)

(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")


   (LET ((COERCED-TYPE (COERCE-TYPE
 ELEMENT-TYPE)))
        (IF (NOT (CONSP COERCED-TYPE))
            (CASE COERCED-TYPE
                ((T STRING-CHAR) 'IL:POINTER)
                ((IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) COERCED-TYPE)
                ((SINGLE-FLOAT) 'IL:FLOATP)
                (OTHERWISE 'IL:POINTER))
            (CASE (CAR COERCED-TYPE)
                (UNSIGNED-BYTE `(IL:BITS ,(CADR COERCED-TYPE)))
                (SIGNED-BYTE (CASE (CADR COERCED-TYPE)
                                 (16 'IL:SIGNEDWORD)
                                 (32 'IL:FIXP)
                                 (OTHERWISE 'IL:POINTER)))
                (MEMBER 'IL:FLAG)
                (OTHERWISE 'IL:POINTER)))))

(DEFUN ASSIGN-FIELD-DESCRIPTORS
 (PS FIELD-DESCRIPTORS)

   (IL:* IL:|;;| "Assigns the field descriptors for accessing each slot of the structure")


   (IF (NOT (EQ (PS-TYPE PS)
                'DATATYPE))
       (ERROR "Not a structure of type datatype"))
   (DO ((F FIELD-DESCRIPTORS (CDR F))
        (SLOT (PS-ALL-SLOTS PS)
              (CDR SLOT)))
       ((NULL F))
     (SETF (PSLOT-FIELD-DESCRIPTOR (CAR SLOT))
           (CAR 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:|;;;| "type system hooks")



(DEFUN PROCESS-TYPE
 (PS)

(IL:* IL:|;;;| 

"adds the structure to the common lisp type system and defines the predicate, if any.")


   (IF (NOT (PS-TEMPLATE PS))
       (LET*
        ((NAME (PS-NAME PS))
         (TYPE (PS-TYPE PS))
         (PREDICATE (PS-PREDICATE PS))
         (PREDICATE-BODY
 (AND PREDICATE (PREDICATE-BODY
 PS 'OBJECT)))
         (EXPORTNAME (PS-EXPORT PS)))
        (IF (AND PREDICATE (OR (EQ EXPORTNAME T)
                               (MEMBER :PREDICATE EXPORTNAME)))
            (EXPORT PREDICATE))
               (IL:* IL:\; 

                                                "Edited by TT(13-June-90) Export Option Follow up")

        `(,@(COND
               ((EQ TYPE 'DATATYPE)
                `((EVAL-WHEN (EVAL LOAD COMPILE)
                         (SETF (TYPE-EXPANDER ',NAME)
                               'TYPE-EXPAND-STRUCTURE))))
               ((PS-NAMED PS)
                `((EVAL-WHEN (EVAL LOAD COMPILE)
                         (SETF (TYPE-EXPANDER ',NAME)
                               'TYPE-EXPAND-NAMED-STRUCTURE)))))
          ,@(WHEN PREDICATE
                (LET* ((INLINE (PS-INLINE PS))
                       (INLINE-P (AND (EQ TYPE 'DATATYPE)
                                      (OR (EQ INLINE :ONLY)
                                          (AND (CONSP INLINE)
                                               (MEMBER :PREDICATE INLINE :TEST #'EQ)))))
                       (INLINE-ONLY-P (EQ INLINE :ONLY)))
                      (IF (NULL INLINE-P)

                          (IL:* IL:|;;| "Flush optimizer (a bit extreme, but also gets rid of old definline optimizers from the old defstruct")


                          (SETF (COMPILER:OPTIMIZER-LIST PREDICATE)
                                NIL))
                      `(,@(IF (NOT INLINE-ONLY-P)
                              `((DEFUN ,PREDICATE (OBJECT)
                                   ,PREDICATE-BODY)))
                        ,@(IF INLINE-P
                              `((EVAL-WHEN (EVAL LOAD COMPILE)
                                       (ESTABLISH-PREDICATE ',(PS-NAME PS))))))))))))

(DEFUN PREDICATE-BODY
 (PS ARG)
   (LET ((PREDICATE (PS-PREDICATE PS))
         (TYPE (PS-TYPE PS)))
        (CASE TYPE
            (DATATYPE 

               (IL:* IL:|;;| "for datatypes, always create a predicate.  Use typep")


               `(TYPEP ,ARG ',(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 ,ARG ',(IF (EQ TYPE 'LIST)
                                       'CONS
                                       'VECTOR))
                     (EQ ,(IF (EQ TYPE 'LIST)
                              `(NTH ,(PS-NAME-SLOT-POSITION
 PS)
                                    ,ARG)
                              `(AREF ,ARG ,(PS-NAME-SLOT-POSITION
 PS)))
                         ',(PS-NAME PS)))))))

(DEFUN TYPE-EXPAND-STRUCTURE
 (TYPE-FORM)
   `(:DATATYPE ,(CAR TYPE-FORM)))

(DEFUN TYPE-EXPAND-NAMED-STRUCTURE
 (TYPE-FORM)
   `(SATISFIES ,(PS-PREDICATE (PARSED-STRUCTURE (CAR TYPE-FORM)))))

(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)
   (VALUES (INTERN (CONCATENATE 'STRING (STRING STRUCTURE-NAME)
                          "-P"))))

(DEFUN DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER
 (FORM &OPTIONAL ENVIRONMENT CONTEXT)
   (XCL:DESTRUCTURING-BIND (PREDICATE OBJECT)
          FORM
          (LET ((NAME (GETHASH PREDICATE *DEFSTRUCT-INFO-CACHE*)))
               (IF (NULL NAME)
                   (SETQ NAME (CACHE-PREDICATE-INFO
 PREDICATE)))
               (IF NAME
                   `(TYPEP ,OBJECT ',NAME)
                   COMPILER:PASS))))

(DEFUN CACHE-PREDICATE-INFO
 (PREDICATE)

   (IL:* IL:|;;| "Establishes a shared a shared optimizer for a defstruct predicate")


   (LET ((PS (GET-PS-FROM-PREDICATE PREDICATE T)))
        (WHEN PS
            (SETF (GETHASH PREDICATE *DEFSTRUCT-INFO-CACHE*)
                  (PS-NAME PS)))))

(DEFCONSTANT %FUNCTION-DEFINING-FORM-KEYWORDS
 '(:ACCESSOR :COPIER :PREDICATE :BOA-CONSTRUCTOR 
                                                          :CONSTRUCTOR)
                                                  
                                     "all the legal contexts for function-defining-form in defstruct")



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



(DEFUN SETF-NAME
 (ACCESSOR-NAME)
   "produces the name of the setf function for this accessor"
   (XCL:PACK (LIST '%%SETF- ACCESSOR-NAME)))

(DEFUN ACCESSOR-BODY
 (SLOT ARGUMENT STRUCTURE-TYPE &OPTIONAL (NO-TYPE-CHECK NIL))

   (IL:* IL:|;;| "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 `(AREF ,ARGUMENT ,(PSLOT-FIELD-DESCRIPTOR SLOT)))))

(DEFUN PROCESS-ACCESSORS
 (PS)
   (IF (NOT (EQ (PS-INLINE PS)
                :ONLY))
       (IF COMPILER::*NEW-COMPILER-IS-EXPANDING*
           `((ESTABLISH-ACCESSORS
 ',(PS-NAME PS)))
           `((EVAL-WHEN (EVAL)
                    (ESTABLISH-ACCESSORS
 ',(PS-NAME PS)))
             (EVAL-WHEN (LOAD)
                    ,@(DEFINE-ACCESSORS
 PS))))))

(DEFUN ESTABLISH-ACCESSORS
 (PS-NAME)

   (IL:* IL:|;;| "Makes a closure for every accessor ")


   (LET* ((PS (PARSED-STRUCTURE PS-NAME))
          (STRUCTURE-TYPE (PS-TYPE PS)))
         (MAPCAN #'(LAMBDA (SLOT)
                          (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))
                                (EXPORTNAME (PS-EXPORT PS)))
                               (WHEN ACCESSOR
                                   (IF (OR (EQ EXPORTNAME T)
                                           (MEMBER :ACCESSOR EXPORTNAME))
                                       (EXPORT ACCESSOR))

                                                  (IL:* IL:\; 

                                                "Edited by TT(13-June-90) Export Option Follow up ")

                                   (SETF (SYMBOL-FUNCTION ACCESSOR)
                                         (%MAKE-ACCESSOR-CLOSURE
 SLOT STRUCTURE-TYPE)))))
                (PS-ALL-SLOTS PS))))

(DEFUN DEFINE-ACCESSORS
 (PS)

   (IL:* IL:|;;| "Returns the forms that when evaluated, define the accessors")


   (IL:* IL:|;;| "Only used by the byte compiler")


   (LET ((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))
                               (EXPORTNAME (PS-EXPORT PS)))
                              (WHEN ACCESSOR
                                  (IF (OR (EQ EXPORTNAME T)
                                          (MEMBER :ACCESSOR EXPORTNAME))
                                      (EXPORT ACCESSOR))

                                                  (IL:* IL:\; 

                                               "Edited by TT(13-June-90) Export Option follow-up. ")

                                  `((DEFUN ,ACCESSOR (,NAME)
                                       ,(ACCESSOR-BODY
 SLOT NAME STRUCTURE-TYPE))))))
               (PS-ALL-SLOTS PS))))

(DEFUN DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER
 (FORM &OPTIONAL ENVIRONMENT CONTEXT)
   (XCL:DESTRUCTURING-BIND (ACCESSOR OBJECT)
          FORM
          (LET ((SLOT-INFO (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*)))
               (IF (NULL SLOT-INFO)
                   (SETQ SLOT-INFO (CACHE-SLOT-INFO
 ACCESSOR)))
               (IF SLOT-INFO
                   (XCL:DESTRUCTURING-BIND (TYPE SLOT FAST-ACCESSORS-P)
                          SLOT-INFO
                          (ACCESSOR-BODY
 SLOT OBJECT TYPE FAST-ACCESSORS-P))
                   'COMPILER:PASS))))

(DEFINE-SHARED-SETF-MACRO DEFSTRUCT-SHARED-SETF-EXPANDER
 ACCESSOR (DATUM) (NEW-VALUE)

   (IL:* IL:|;;| "Shared setf expander for all defstruct slot accessors ")


   (LET ((SLOT-INFO (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*)))
        (WHEN (NULL SLOT-INFO)
            (SETQ SLOT-INFO (CACHE-SLOT-INFO
 ACCESSOR)))
        (XCL:DESTRUCTURING-BIND
         (TYPE SLOT FAST-ACCESSSOR-P)
         SLOT-INFO
         (LET ((DESCRIPTOR (PSLOT-FIELD-DESCRIPTOR SLOT)))
              (ECASE TYPE
                  (DATATYPE `(,(IF FAST-ACCESSSOR-P
                                   'IL:FREPLACEFIELD
                                   'IL:REPLACEFIELD)
                              ',DESCRIPTOR
                              ,DATUM
                              ,NEW-VALUE))
                  (LIST `(SETF (NTH ,DESCRIPTOR ,DATUM)
                               ,NEW-VALUE))
                  (VECTOR (MACROLET ((SIMPLE-P (X)
                                            `(OR (SYMBOLP ,X)
                                                 (CONSTANTP ,X))))
                                 (IF (AND (SIMPLE-P DATUM)
                                          (SIMPLE-P NEW-VALUE))
                                     `(XCL:ASET ,NEW-VALUE ,DATUM ,DESCRIPTOR)
                                     (LET ((D (GENSYM))
                                           (V (GENSYM)))
                                          `(LET ((,D ,DATUM)
                                                 (,V ,NEW-VALUE))
                                                (XCL:ASET ,V ,D ,DESCRIPTOR)))))))))))

(DEFUN CACHE-SLOT-INFO
 (ACCESSOR)

(IL:* IL:|;;;| "saves the internal accessors in a hash table so that setf methods can be generated at interpret/compile time.")


   (LET* ((PS (GET-PS-FROM-ACCESSOR ACCESSOR))
          (FAST-ACCESSORS (PS-FAST-ACCESSORS PS)))
         (SETF (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*)     (IL:* IL:\; 

                                                   "Make a copy of the slot to keep refcounts down")

               (LIST (PS-TYPE PS)
                     (COPY-TREE (GET-SLOT-DESCRIPTOR-FROM-PS ACCESSOR PS))
                     (AND FAST-ACCESSORS T)))))

(DEFUN %MAKE-ACCESSOR-CLOSURE
 (SLOT STRUCTURE-TYPE)
   (LET ((DESCRIPTOR (PSLOT-FIELD-DESCRIPTOR SLOT)))
        (ECASE STRUCTURE-TYPE
            (DATATYPE (XCL:DESTRUCTURING-BIND
                       (TYPENAME OFFSET FIELD-DESCRIPTOR)
                       DESCRIPTOR
                       (CASE FIELD-DESCRIPTOR
                           ((IL:POINTER IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) (

                                                                             %MAKE-POINTER-ACCESSOR

                                                                                     TYPENAME OFFSET))
                           (IL:FLOATP (%MAKE-FLOAT-ACCESSOR
 TYPENAME OFFSET))
                           (IL:FIXP (%MAKE-FIXP-ACCESSOR
 TYPENAME OFFSET))
                           (OTHERWISE 

                              (IL:* IL:|;;| "Must be a bit field")


                              (LET* ((FIELD-TYPE (CAR FIELD-DESCRIPTOR))
                                     (FIELD-ARG (CDR FIELD-DESCRIPTOR))
                                     (SIZE (1+ (LOGAND FIELD-ARG 15)))
                                     (POSITION (- 16 (+ SIZE (ASH FIELD-ARG -4)))))
                                    (ECASE FIELD-TYPE
                                        (IL:BITS (IF (EQ SIZE 16)
                                                     (%MAKE-WORD-ACCESSOR
 TYPENAME OFFSET)
                                                     (%MAKE-BIT-ACCESSOR
 TYPENAME OFFSET POSITION
                                                            SIZE)))
                                        (IL:FLAGBITS (IF (EQ SIZE 1)
                                                         (%MAKE-FLAG-ACCESSOR
 TYPENAME OFFSET 
                                                                POSITION)
                                                         (ERROR "Illegal field descriptor: ~s" 
                                                                DESCRIPTOR)))
                                        (IL:SIGNEDBITS (IF (EQ SIZE 16)
                                                           (%MAKE-SMALL-FIXP-ACCESSOR
 TYPENAME 
                                                                  OFFSET)

                                                           (IL:* IL:|;;| 

                                    "Would be better to say here \"Inconvenient field descriptor\"")


                                                           (ERROR "Illegal field descriptor: ~s" 
                                                                  DESCRIPTOR)))))))))
            (LIST (%MAKE-LIST-ACCESSOR
 DESCRIPTOR))
            (VECTOR (%MAKE-ARRAY-ACCESSOR
 DESCRIPTOR)))))

(DEFUN %MAKE-LIST-ACCESSOR
 (OFFSET)
   #'(LAMBDA (LIST)
            (NTH OFFSET LIST)))

(DEFUN %MAKE-ARRAY-ACCESSOR
 (OFFSET)
   #'(LAMBDA (VECTOR)
            (AREF VECTOR OFFSET)))

(DEFUN %MAKE-POINTER-ACCESSOR
 (TYPE OFFSET)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (IL:\\GETBASEPTR OBJECT OFFSET)))
       #'(LAMBDA (OBJECT)
                (IL:\\GETBASEPTR OBJECT OFFSET))))

(DEFUN %MAKE-BIT-ACCESSOR
 (TYPE WORD-OFFSET OFFSET SIZE)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (LDB (BYTE SIZE OFFSET)
                         (IL:\\GETBASE OBJECT WORD-OFFSET))))
       #'(LAMBDA (OBJECT)
                (LDB (BYTE SIZE OFFSET)
                     (IL:\\GETBASE OBJECT WORD-OFFSET)))))

(DEFUN %MAKE-FLAG-ACCESSOR
 (TYPE WORD-OFFSET OFFSET)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (NOT (EQ 0 (LDB (BYTE 1 OFFSET)
                                    (IL:\\GETBASE OBJECT WORD-OFFSET))))))
       #'(LAMBDA (OBJECT)
                (NOT (EQ 0 (LDB (BYTE 1 OFFSET)
                                (IL:\\GETBASE OBJECT WORD-OFFSET)))))))

(DEFUN %MAKE-WORD-ACCESSOR
 (TYPE OFFSET)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (IL:\\GETBASE OBJECT OFFSET)))
       #'(LAMBDA (OBJECT)
                (IL:\\GETBASE OBJECT OFFSET))))

(DEFUN %MAKE-FIXP-ACCESSOR
 (TYPE OFFSET)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (IL:\\GETBASEFIXP OBJECT OFFSET)))
       #'(LAMBDA (OBJECT)
                (IL:\\GETBASEFIXP OBJECT OFFSET))))

(DEFUN %MAKE-SMALL-FIXP-ACCESSOR
 (TYPE OFFSET)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (IL:\\GETBASESMALL-FIXP OBJECT OFFSET)))
       #'(LAMBDA (OBJECT)
                (IL:\\GETBASESMALL-FIXP OBJECT OFFSET))))

(DEFUN %MAKE-FLOAT-ACCESSOR
 (TYPE OFFSET)
   (IF TYPE
       #'(LAMBDA (OBJECT)
                (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE))
                    (ERROR "Arg not ~s: ~s" TYPE OBJECT)
                    (IL:\\GETBASEFLOATP OBJECT OFFSET)))
       #'(LAMBDA (OBJECT)
                (IL:\\GETBASEFLOATP OBJECT OFFSET))))



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



(DEFUN DEFINE-CONSTRUCTORS
 (PS)

   (IL:* IL:|;;| "Returns the forms that when evaluated, define the constructors")


   (IF (NOT (PS-TEMPLATE PS))
       (LET*
        ((CONSTRUCTORS (PS-CONSTRUCTORS PS))
         (SLOTS (PS-ALL-SLOTS PS))
         (RESULT-ARG (PS-NAME PS))
         (ALL-BOAS? (EVERY #'BOA-CONSTRUCTOR-P CONSTRUCTORS))
         (EXPORTNAME (PS-EXPORT PS)))
        (IF (OR (EQ EXPORTNAME T)
                (MEMBER :CONSTRUCTOR EXPORTNAME))
            (EXPORT CONSTRUCTORS))
            (IL:* IL:\; 

                                                "Edited by TT(13-June-90) Export Option Follow up")

        (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 ARGUMENT-LIST PS)))
                    (XCL:WITH-COLLECTION
                     (DOLIST (CONSTRUCTOR CONSTRUCTORS)
                         (XCL: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.")


                                            `(DEFUN ,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
 NEW-ARGUMENT-LIST)
                             PS)))
         `(DEFUN ,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 ARG))
                       ((MEMBER ARG LAMBDA-LIST-KEYWORDS)
                        NIL)
                       (T (LIST (LIST ARG :REQUIRED-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)
                                          (LET ((INTIAL-VALUE-FORM (PSLOT-INITIAL-VALUE (FIND-SLOT

                                                                                         OPTIONAL 
                                                                                         SLOTS))))
                                               (IF INTIAL-VALUE-FORM
                                                   `(,OPTIONAL ,INTIAL-VALUE-FORM)
                                                   `(,OPTIONAL NIL ,(IL:GENSYM)))))
                                         ((AND (CONSP OPTIONAL)
                                               (CDR OPTIONAL))

                                          (IL:* IL:|;;| "already a default just leave it alone")


                                          OPTIONAL)
                                         ((CONSP OPTIONAL)
                                          (LET ((INTIAL-VALUE-FORM (PSLOT-INITIAL-VALUE
                                                                    (FIND-SLOT
 (CAR OPTIONAL)
                                                                           SLOTS))))
                                               (IF INTIAL-VALUE-FORM
                                                   `(,(CAR OPTIONAL)
                                                     ,INTIAL-VALUE-FORM)
                                                   `(,(CAR OPTIONAL)
                                                     NIL
                                                     ,(IL:GENSYM)))))))))))
        NEW-ARG-LIST))

(DEFUN BOA-SLOT-SETFS
 (RESULT-ARG SLOT-NAMES PS)
   (LET ((STRUCTURE-TYPE (PS-TYPE PS)))
        (XCL:WITH-COLLECTION
         (LET (SLOT-PLACE SLOT-NAME SLOT-ARGUMENT)
              (DOLIST (SLOT (PS-ALL-SLOTS PS))
                  (SETQ SLOT-NAME (PSLOT-NAME SLOT))
                  (SETQ SLOT-PLACE (ACCESSOR-BODY
 SLOT RESULT-ARG STRUCTURE-TYPE T))
                  (SETQ SLOT-ARGUMENT (ASSOC SLOT-NAME SLOT-NAMES :TEST #'EQ))
                  (XCL:COLLECT (IF SLOT-ARGUMENT
                                   (LET ((SUPPLIED-P (CADDR SLOT-ARGUMENT)))
                                        (IF SUPPLIED-P
                                            `(IF ,SUPPLIED-P
                                                 (SETF ,SLOT-PLACE ,SLOT-NAME))
                                            `(SETF ,SLOT-PLACE ,SLOT-NAME)))
                                   `(SETF ,SLOT-PLACE ,(PSLOT-INITIAL-VALUE SLOT)))))))))

(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)

   (IL:* IL:|;;| "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)

   (IL:* IL:|;;| "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))
                           (KEYWORD-PAIR `(,(VALUES (INTERN (SYMBOL-NAME ARG-NAME)
                                                           'KEYWORD))
                                           ,(GENSYM))))
                          (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")


                                    `((,KEYWORD-PAIR ,INIT-FORM)))
                             (T `((,KEYWORD-PAIR NIL ,(GENSYM)))))))
          SLOTS))

(DEFUN BUILD-CONSTRUCTOR-SLOT-SETFS
 (SLOTS ARGUMENT-LIST PS)

   (IL:* IL:|;;| "Builds the setfs that initialize the slots in a constructor")


   (LET ((STRUCTURE-TYPE (PS-TYPE PS))
         (OBJECT-NAME (PS-NAME PS))
         (ARGUMENT-LIST ARGUMENT-LIST))

        (IL:* IL:|;;| "The argument list does not have arguments for \"invisible\" slots.")


        (MAPCAR #'(LAMBDA (SLOT)
                         (COND
                            ((NOT (PSLOT-ACCESSOR SLOT))

                             (IL:* IL:|;;| 

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


                             `(SETF ,(ACCESSOR-BODY
 SLOT OBJECT-NAME STRUCTURE-TYPE T)
                                    ,(PSLOT-INITIAL-VALUE SLOT)))
                            (T (LET* ((ARGUMENT (POP ARGUMENT-LIST))
                                      (KEYWORD-VAR-NAME (CADAR ARGUMENT))
                                      (INITIAL-VALUE-FORM (CADR ARGUMENT)))

                                     (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")


                                     (IF INITIAL-VALUE-FORM
                                         `(SETF ,(ACCESSOR-BODY
 SLOT OBJECT-NAME STRUCTURE-TYPE T
                                                        )
                                                ,KEYWORD-VAR-NAME)
                                         `(IF ,(CADDR ARGUMENT)
                                              (SETF ,(ACCESSOR-BODY
 SLOT OBJECT-NAME 
                                                            STRUCTURE-TYPE T)
                                                    ,KEYWORD-VAR-NAME)))))))
               SLOTS)))

(DEFUN BOA-CONSTRUCTOR-P
 (CONSTRUCTOR)

   (IL:* IL:|;;| "Returns t if the constructor is a By Order of Arguments constructor")


   (CONSP CONSTRUCTOR))

(DEFUN DEFAULT-CONSTRUCTOR-NAME
 (STRUCTURE-NAME)
   (VALUES (INTERN (CONCATENATE 'STRING "MAKE-" (STRING STRUCTURE-NAME)))))



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



(DEFUN DEFINE-COPIERS
 (PS)

   (IL:* IL:|;;| "Returns the form that when evaluated, defines the copier")


   (IF (NOT (PS-TEMPLATE PS))
       (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?))
                             (EXPORTNAME (PS-EXPORT PS)))
                            (IF (OR (EQ EXPORTNAME T)
                                    (MEMBER :COPIER EXPORTNAME))
                                (EXPORT (PS-COPIER PS)))

                                                  (IL:* IL:\; 

                                                "Edited by TT(13-June-90) Export Option follow up")


                            (IL:* IL:|;;| 

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


                            `((DEFUN ,(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 ,(ACCESSOR-BODY
 SLOT TO-ARGUMENT STRUCTURE-TYPE T)
                           ,(ACCESSOR-BODY
 SLOT FROM-ARGUMENT STRUCTURE-TYPE T)))
          SLOTS))

(DEFUN BUILD-COPIER-TYPE-CHECK
 (PS FROM-ARG)

   (IL:* IL:|;;| "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:FREPLACEFIELD)



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



(DEFMACRO DEFSTRUCT-ASSERT-SUBTYPEP
 (TYPE1 TYPE2 (ERROR-STRING . ERROR-ARGS)
                                               &REST CERROR-ACTIONS)

   (IL:* IL:|;;| 

 "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")

                          (ERROR ,ERROR-STRING ,@ERROR-ARGS))
                   (T                                        (IL:* IL:\; 

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

                      (CERROR "Assume subtypep should return t" ,(FORMAT NIL "Perhaps, ~a" 
                                                                        ERROR-STRING)
                             ,@ERROR-ARGS)
                      ,@CERROR-ACTIONS T)))))



(IL:* IL:|;;;| "inspecting structures")



(DEFUN STRUCTURE-OBJECT-P
 (OBJECT)
   (TYPEP OBJECT 'STRUCTURE-OBJECT))

(DEFUN INSPECT-STRUCTURE-OBJECT
 (STRUCTURE OBJECTTYPE WHERE)
   "calls the system facilities with the appropriate slots and functions."
   (IL:INSPECTW.CREATE STRUCTURE (PS-ALL-SLOTS (PARSED-STRUCTURE (TYPE-OF STRUCTURE)))
          'STRUCTURE-OBJECT-INSPECT-FETCHFN
          'STRUCTURE-OBJECT-INSPECT-STOREFN
          'STRUCTURE-OBJECT-PROPCOMMANDFN NIL NIL (LET ((XCL:*PRINT-STRUCTURE* NIL))
                                                       (CONCATENATE 'STRING (PRINC-TO-STRING 
                                                                                   STRUCTURE)
                                                              " Inspector"))
          NIL WHERE 'STRUCTURE-OBJECT-INSPECT-PROPPRINTFN))

(DEFUN STRUCTURE-OBJECT-INSPECT-FETCHFN
 (OBJECT PROPERTY)
   (IF (PSLOT-ACCESSOR PROPERTY)
       (FUNCALL (PSLOT-ACCESSOR PROPERTY)
              OBJECT)
       (IL:FETCHFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY)
              OBJECT)))

(DEFUN STRUCTURE-OBJECT-INSPECT-PROPPRINTFN
 (PROPERTY DATUM)
   (PSLOT-NAME PROPERTY))

(DEFUN STRUCTURE-OBJECT-INSPECT-STOREFN
 (OBJECT PROPERTY NEWVALUE)

   (IL:* IL:|;;| 

 "this effectively does (eval `(setf (,(pslot-accessor property) object) newvalue)) ")


   (IF (PSLOT-ACCESSOR PROPERTY)
       (EVAL `(SETF (,(PSLOT-ACCESSOR PROPERTY)
                     ',OBJECT)
                    ',NEWVALUE))
       (IL:REPLACEFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY)
              OBJECT NEWVALUE)))

(DEFUN STRUCTURE-OBJECT-PROPCOMMANDFN
 (PROPERTY DATUM INSPECTOR-WINDOW)
   (IF (AND (TYPEP DATUM 'STRUCTURE-OBJECT)
            (PSLOT-READ-ONLY PROPERTY))
       (IL:PROMPTPRINT "Can't set a read-only slot.")
       (IL:DEFAULT.INSPECTW.PROPCOMMANDFN PROPERTY DATUM INSPECTOR-WINDOW)))



(IL:* IL:|;;| "Defined last so functions required to load a defstruct are loaded first")



(DEFSTRUCT (PS
 (:TYPE LIST)
                   :NAMED)

(IL:* IL:|;;;| "Contains the parsed information for a SINGLE structure type")


   (IL:* IL:|;;| "most values are not defaulted here, because the defaults depend on other slot values (e.g. predicate depends on type and named.)  These defaults are installed in ensure-consistent-ps.")


   (NAME)                                                    (IL:* IL:\; 

                                                           "The name of the structure")

   (STANDARD-CONSTRUCTOR)                                    (IL:* IL:\; 

                                            "Contains the constructor to be used by the #s reader.")

   (ALL-SLOT-NAMES)                                          (IL:* IL:\; 

                                                        "The slot-name list used by the inspector.")

   (TYPE %DEFAULT-DEFSTRUCT-TYPE)                            (IL:* IL:\; 

                                                    "Is this structure a datatype, list or vector.")

   (VECTOR-TYPE)                                             (IL:* IL:\; 

                                          "If its a vector, this is the element-type of the vector")

   (INCLUDE NIL)                                             (IL:* IL:\; 

                                                           "The included structure, if any.")

   (CONC-NAME)
   (CONSTRUCTORS %NO-CONSTRUCTOR)                            (IL:* IL:\; 

  "A list of the constructors for this structure.  Boas have the argument list, not just the name.")

   (PREDICATE %NO-PREDICATE)
   (PRINT-FUNCTION)
   (COPIER %NO-COPIER)
   (NAMED NIL)
   (INITIAL-OFFSET 0)
   (LOCAL-SLOTS NIL)                                         (IL:* IL:\; 

                                   "The slot descriptors for slots present locally (not included).")

   (ALL-SLOTS)                                               (IL:* IL:\; 

                 "The list of slot descriptors for every slot present in an instance of this slot.")

   (INCLUDED-SLOTS)                                          (IL:* IL:\; 

                                                          "Slots specified in the :include option.")


   (IL:* IL:|;;| "Redundant")


   (DOCUMENTATION-STRING)

   (IL:* IL:|;;| "Unused")


   (FIELD-SPECIFIERS)                                        (IL:* IL:\; "The position of each slot in the structure.  For vectors and  list structures, it is just an offset.  For datatypes, it is a field-specifier for fetchield.")


   (IL:* IL:|;;| "Unused")


   (POINTER-DESCRIPTORS)                                     (IL:* IL:\; "the descriptors for all fields which the circle-printer must scan.  It is filled in the first time it is needed.")

   (INLINE T)                                                (IL:* IL:\; 

                      "Flag telling whether or not functions built by defstruct are inline or not.")

   (FAST-ACCESSORS NIL)                                      (IL:* IL:\; "Flag telling whether or not accessor functions should check the type of the object before slot accesses.")

   (TEMPLATE NIL)                                            (IL:* IL:\; "As in IL:BLOCKRECORD. Implies type datatype, no copier, predicate or constructors, and fast accessors. No datatype is declared for this option.")

   (EXPORT NIL)                                              (IL:* IL:\; 

                                                "EXPORT indicates  export of Structure's functions")

   )

(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)



(IL:* IL:|;;| "Mapping between names of generated functions and their associated structures")



(DEFUN STRUCTURE-FUNCTION-P
 (SYMBOL)
   (CATCH 'FOUND
       (MAPHASH #'(LAMBDA (KEY PS)
                         (IF (OR (AND (CONSP (PS-CONSTRUCTORS PS))
                                      (MEMBER SYMBOL (PS-CONSTRUCTORS PS)
                                             :TEST
                                             #'EQ))
                                 (EQ SYMBOL (PS-PREDICATE PS))
                                 (EQ SYMBOL (PS-COPIER PS))
                                 (DOLIST (SLOT (PS-ALL-SLOTS PS))
                                     (IF (EQ SYMBOL (PSLOT-ACCESSOR SLOT))
                                         (RETURN (PS-NAME PS)))))
                             (THROW 'FOUND KEY)))
              *PARSED-DEFSTRUCTS*)))

(DEFUN STRUCTURE-FUNCTIONS
 (STRUCTURE-NAME)
   (LET ((PS (PARSED-STRUCTURE STRUCTURE-NAME)))
        `(,@(PS-CONSTRUCTORS PS)
          ,.(LET ((PREDICATE (PS-PREDICATE PS)))
                 (IF PREDICATE (LIST PREDICATE)))
          ,.(LET ((COPIER (PS-COPIER PS)))
                 (IF COPIER (LIST COPIER)))
          ,.(MAPCAN #'(LAMBDA (SLOT)
                             (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)))
                                  (AND ACCESSOR (LIST ACCESSOR))))
                   (PS-ALL-SLOTS PS)))))



(IL:* IL:|;;;| "Editing structures")



(DEFUN STRUCTURES.HASDEF
 (NAME &OPTIONAL TYPE SOURCE SPELLFLG)
   (OR (IL:GETDEF NAME 'IL:STRUCTURES 'IL:CURRENT '(IL:NODWIM IL:NOCOPY IL:NOERROR IL:HASDEF))
       (STRUCTURE-FUNCTION-P
 NAME)))

(DEFUN STRUCTURES.EDITDEF
 (NAME TYPE SOURCE EDITCOMS OPTIONS)
   "From accessor function or structure name, edit the structure."
   (IF (PARSED-STRUCTURE NAME T)
       (IL:DEFAULT.EDITDEF NAME 'IL:STRUCTURES SOURCE EDITCOMS OPTIONS)
       (LET ((STRUCTURE-NAME (STRUCTURE-FUNCTION-P
 NAME)))
            (IF STRUCTURE-NAME
                (IL:DEFAULT.EDITDEF STRUCTURE-NAME 'IL:STRUCTURES SOURCE EDITCOMS OPTIONS)
                (IL:DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS))))
   NAME)

(IL:FILEPKGTYPE 'IL:STRUCTURES 'IL:HASDEF 'STRUCTURES.HASDEF 'IL:EDITDEF 'STRUCTURES.EDITDEF)

(IL:ADDTOVAR IL:SHADOW-TYPES
 (IL:STRUCTURES IL:FNS))
(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 

(IL:ADDTOVAR IL:INSPECTMACROS
 ((IL:FUNCTION STRUCTURE-OBJECT-P) . INSPECT-STRUCTURE-OBJECT))
)



(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 ("Venue & Xerox Corporation" 1986 1987 1900 1988 1989 1990 1992
 1993))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP