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

(IL:FILECREATED " 8-Jan-92 09:59:20" IL:|{DSK}<usr>local>lde>lispcore>sources>DEFSTRUCT.;7|
 57169  

      IL:|changes| IL:|to:|  (IL:FUNCTIONS SET-XP-PRINTER)

      IL:|previous| IL:|date:| "25-Oct-91 16:34:45" 
IL:|{DSK}<usr>local>lde>lispcore>sources>DEFSTRUCT.;3|)


; Copyright (c) 1986, 1987, 1900, 1988, 1989, 1990, 1991, 1992 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 SET-XP-PRINTER) (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 (QUOTE IL:STRUCTURES) (QUOTE IL:HASDEF) (QUOTE STRUCTURES.HASDEF) (QUOTE IL:EDITDEF) (QUOTE 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) (IL:BQUOTE (DEFSTRUCT ((IL:\\\, 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) (IL:BQUOTE (PROGN (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (PARSED-STRUCTURE (QUOTE (IL:\\\, (PS-NAME PS))) T) (QUOTE (IL:\\\, PS)))) (IL:\\\,@ (ASSIGN-STRUCTURE-REPRESENTATION PS)) (IL:\\\,@ (PROCESS-TYPE PS)) (IL:\\\,@ (PROCESS-ACCESSORS PS)) (EVAL-WHEN (EVAL COMPILE LOAD) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE (IL:\\\, (PS-NAME PS))))) (IL:\\\,@ (DEFINE-CONSTRUCTORS PS)) (IL:\\\,@ (DEFINE-COPIERS PS)) (IL:\\\,@ (RECORD-DOCUMENTATION PS)) (IL:\\\,@ (SET-XP-PRINTER 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 (QUOTE DATATYPE) "The type of structures when no :type option is specified")

(DEFVAR %DEFAULT-SLOT-TYPE (QUOTE T) "the type of any slot which does not specifiy a :type option")

(DEFCONSTANT %DEFAULT-STRUCTURE-INCLUDE (QUOTE STRUCTURE-OBJECT) "datatype included by every structure")

(DEFPARAMETER %DEFSTRUCT-OPTIONS (QUOTE (:CONC-NAME :CONSTRUCTOR :COPIER :PREDICATE :INCLUDE :PRINT-FUNCTION :TYPE :INITIAL-OFFSET :NAMED :INLINE :FAST-ACCESSORS :TEMPLATE :EXPORT)))

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

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

(DEFCONSTANT %NO-COPIER (QUOTE :NONE))

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

(DEFPARAMETER %DEFSTRUCT-EXPORT-OPTIONS (QUOTE (: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 (QUOTE 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 (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, (PS-NAME PS))) (QUOTE STRUCTURE)) (IL:\\\, 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 (QUOTE 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 (WHEN (SOME (FUNCTION (LAMBDA (X) (SUBTYPEP OPTION-VALUE X))) (QUOTE (CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE READTABLE PACKAGE PATHNAME STREAM RANDOM-STATE))) (CERROR "Include it anyway" "~a is a standard type and shouldn't be :INCLUDEd" OPTION-VALUE)) (SETF (PS-INCLUDE PS) OPTION-VALUE) (IL:* IL:|;;| "if there are any included slots record them") (SETF (PS-INCLUDED-SLOTS PS) (CDDR OPTION))) (:SYSTEM-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) (QUOTE IL:\\PRINT-USING-ADDRESS))) (ARGUMENT-PROVIDED (SETF (PS-PRINT-FUNCTION PS) OPTION-VALUE)) (T (IL:* IL:|;;| "CLtL2 - (:PRINT-FUNCTION) means use default print function regardless of inheritance") (SETF (PS-PRINT-FUNCTION PS) %DEFAULT-PRINT-FUNCTION)))) (:TYPE (SETF (PS-TYPE PS) (COND ((EQ OPTION-VALUE (QUOTE LIST)) (QUOTE LIST)) ((EQ OPTION-VALUE (QUOTE VECTOR)) (IL:* IL:\; "default the vector type to t") (SETF (PS-VECTOR-TYPE PS) T) (QUOTE VECTOR)) ((AND (CONSP OPTION-VALUE) (EQ (CAR OPTION-VALUE) (QUOTE VECTOR))) (SETF (PS-VECTOR-TYPE PS) (IL:%GET-CANONICAL-CML-TYPE (CADR OPTION-VALUE))) (QUOTE VECTOR)) (T (ERROR "the specified :type is not list or subtype of vector: ~S" OPTION-VALUE))))) (:INITIAL-OFFSET (IF (NOT (TYPEP OPTION-VALUE (QUOTE (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 (FUNCTION 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 (QUOTE (: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 (FUNCTION (LAMBDA (KEYWORD) (IF (NOT (MEMBER KEYWORD POSSIBLE-KEYWORDS :TEST (FUNCTION 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) (QUOTE 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 (QUOTE 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) (QUOTE 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 (QUOTE 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) (IL:BQUOTE ((IL:\\\, (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 (QUOTE LIST)) (VECTOR (LET ((ELEMENT-TYPE (PS-VECTOR-TYPE PS))) (IF (IL:NEQ ELEMENT-TYPE T) (IL:BQUOTE (VECTOR (IL:\\\, ELEMENT-TYPE))) (QUOTE VECTOR))))))

(DEFUN SET-XP-PRINTER (PS) (IL:* IL:\; "Edited  8-Jan-92 09:53 by jrb:") (IL:* IL:|;;| "Hang the XP::STRUCTURE-PRINTER property the new pretty-printer expects to see") (IL:* IL:|;;| "Changed property to CL::STRUCTURE-PRINTER and changed #'CL::STRUCTURE-WITH-USER-PRINTER to just 'CL::STRUCTURE-WITH-USER-PRINTER, as none of this stuff is defined until XP gets loaded WAY later in the init") (LET ((NAME (PS-NAME PS))) (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE CL::STRUCTURE-PRINTER)) (IL:\\\, (COND ((NOT (EQ (PS-PRINT-FUNCTION PS) %DEFAULT-PRINT-FUNCTION)) (QUOTE (QUOTE CL::STRUCTURE-WITH-USER-PRINTER))) ((EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE) (LET* ((CONC-NAME (STRING (PS-CONC-NAME PS))) (SLOTS (MAPCAR (FUNCTION (LAMBDA (X) (IF (CONSP X) (CAR X) X))) (PS-ALL-SLOTS PS)))) (IL:BQUOTE (FUNCTION (LAMBDA (XP OBJ) (CL::STRUCTURE-WITH-DEFAULT-PRINTER XP (QUOTE (IL:\\\, NAME)) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (SLOT) (IL:BQUOTE ((IL:\\\, (STRING SLOT)) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) CONC-NAME (STRING SLOT)))) OBJ))))) SLOTS)))))))) (T :NONE))))))))



(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 (FUNCTION PARSE-SLOT) LOCAL-SLOT-DESCRIPTIONS)) (INCLUDED-SLOTS (MAPCAR (FUNCTION 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 (FUNCTION 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 (FUNCTION 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 (FUNCTION STRING=)) (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 (FUNCTION 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 (IL:BQUOTE (SI::--STRUCTURE-NAME-SLOT-- (QUOTE (IL:\\\, (PS-NAME PS))) :READ-ONLY T)) NIL))

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

(DEFUN OFFSET-SLOT NIL (PARSE-SLOT (IL:BQUOTE ((IL:\\\, (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 (FUNCTION (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)) (IL:BQUOTE ((SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE (IL:\\\, STRUCTURE-NAME)) (QUOTE (IL:\\\, ALL-FIELD-SPECS)) (QUOTE (IL:\\\, FIELD-DESCRIPTORS)) (IL:\\\, LENGTH) (QUOTE (IL:\\\, (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 (FUNCTION (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) (QUOTE SINGLE-FLOAT)) (FIXNUM (IL:* IL:|;;| "Could be (signed-byte 32) -- but pointer representation is more efficient") T) (CHARACTER (QUOTE STRING-CHAR)) (BIT (QUOTE (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) (QUOTE IL:POINTER)) ((IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) COERCED-TYPE) ((SINGLE-FLOAT) (QUOTE IL:FLOATP)) (OTHERWISE (QUOTE IL:POINTER))) (CASE (CAR COERCED-TYPE) (UNSIGNED-BYTE (IL:BQUOTE (IL:BITS (IL:\\\, (CADR COERCED-TYPE))))) (SIGNED-BYTE (CASE (CADR COERCED-TYPE) (16 (QUOTE IL:SIGNEDWORD)) (32 (QUOTE IL:FIXP)) (OTHERWISE (QUOTE IL:POINTER)))) (MEMBER (QUOTE IL:FLAG)) (OTHERWISE (QUOTE 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) (QUOTE 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 (FUNCTION (LAMBDA (DESCRIPTOR) (CASE (CADDR DESCRIPTOR) ((IL:POINTER IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) (LIST DESCRIPTOR))))) (MAPCAR (FUNCTION 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 (QUOTE 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") (IL:BQUOTE ((IL:\\\,@ (COND ((EQ TYPE (QUOTE DATATYPE)) (IL:BQUOTE ((EVAL-WHEN (EVAL LOAD COMPILE) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE TYPE-EXPAND-STRUCTURE)))))) ((PS-NAMED PS) (IL:BQUOTE ((EVAL-WHEN (EVAL LOAD COMPILE) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE TYPE-EXPAND-NAMED-STRUCTURE)))))))) (IL:\\\,@ (WHEN PREDICATE (LET* ((INLINE (PS-INLINE PS)) (INLINE-P (AND (EQ TYPE (QUOTE DATATYPE)) (OR (EQ INLINE :ONLY) (AND (CONSP INLINE) (MEMBER :PREDICATE INLINE :TEST (FUNCTION 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)) (IL:BQUOTE ((IL:\\\,@ (IF (NOT INLINE-ONLY-P) (IL:BQUOTE ((DEFUN (IL:\\\, PREDICATE) (OBJECT) (IL:\\\, PREDICATE-BODY)))))) (IL:\\\,@ (IF INLINE-P (IL:BQUOTE ((EVAL-WHEN (EVAL LOAD COMPILE) (ESTABLISH-PREDICATE (QUOTE (IL:\\\, (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") (IL:BQUOTE (TYPEP (IL:\\\, ARG) (QUOTE (IL:\\\, (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))) (IL:BQUOTE (AND (TYPEP (IL:\\\, ARG) (QUOTE (IL:\\\, (IF (EQ TYPE (QUOTE LIST)) (QUOTE CONS) (QUOTE VECTOR))))) (EQ (IL:\\\, (IF (EQ TYPE (QUOTE LIST)) (IL:BQUOTE (NTH (IL:\\\, (PS-NAME-SLOT-POSITION PS)) (IL:\\\, ARG))) (IL:BQUOTE (AREF (IL:\\\, ARG) (IL:\\\, (PS-NAME-SLOT-POSITION PS)))))) (QUOTE (IL:\\\, (PS-NAME PS))))))))))

(DEFUN TYPE-EXPAND-STRUCTURE (TYPE-FORM) (IL:BQUOTE (:DATATYPE (IL:\\\, (CAR TYPE-FORM)))))

(DEFUN TYPE-EXPAND-NAMED-STRUCTURE (TYPE-FORM) (IL:BQUOTE (SATISFIES (IL:\\\, (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 (QUOTE 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 (IL:BQUOTE (TYPEP (IL:\\\, OBJECT) (QUOTE (IL:\\\, 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 (QUOTE (: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 (QUOTE %%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 (IL:BQUOTE ((IL:\\\, (IF NO-TYPE-CHECK (QUOTE IL:FFETCHFIELD) (QUOTE IL:FETCHFIELD))) (QUOTE (IL:\\\, (PSLOT-FIELD-DESCRIPTOR SLOT))) (IL:\\\, ARGUMENT)))) (LIST (IL:BQUOTE (NTH (IL:\\\, (PSLOT-FIELD-DESCRIPTOR SLOT)) (IL:\\\, ARGUMENT)))) (VECTOR (IL:BQUOTE (AREF (IL:\\\, ARGUMENT) (IL:\\\, (PSLOT-FIELD-DESCRIPTOR SLOT)))))))

(DEFUN PROCESS-ACCESSORS (PS) (IF (NOT (EQ (PS-INLINE PS) :ONLY)) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (IL:BQUOTE ((ESTABLISH-ACCESSORS (QUOTE (IL:\\\, (PS-NAME PS)))))) (IL:BQUOTE ((EVAL-WHEN (EVAL) (ESTABLISH-ACCESSORS (QUOTE (IL:\\\, (PS-NAME PS))))) (EVAL-WHEN (LOAD) (IL:\\\,@ (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 (FUNCTION (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 (FUNCTION (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. ") (IL:BQUOTE ((DEFUN (IL:\\\, ACCESSOR) ((IL:\\\, NAME)) (IL:\\\, (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)) (QUOTE 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 (IL:BQUOTE ((IL:\\\, (IF FAST-ACCESSSOR-P (QUOTE IL:FREPLACEFIELD) (QUOTE IL:REPLACEFIELD))) (QUOTE (IL:\\\, DESCRIPTOR)) (IL:\\\, DATUM) (IL:\\\, NEW-VALUE)))) (LIST (IL:BQUOTE (SETF (NTH (IL:\\\, DESCRIPTOR) (IL:\\\, DATUM)) (IL:\\\, NEW-VALUE)))) (VECTOR (MACROLET ((SIMPLE-P (X) (IL:BQUOTE (OR (SYMBOLP (IL:\\\, X)) (CONSTANTP (IL:\\\, X)))))) (IF (AND (SIMPLE-P DATUM) (SIMPLE-P NEW-VALUE)) (IL:BQUOTE (XCL:ASET (IL:\\\, NEW-VALUE) (IL:\\\, DATUM) (IL:\\\, DESCRIPTOR))) (LET ((D (GENSYM)) (V (GENSYM))) (IL:BQUOTE (LET (((IL:\\\, D) (IL:\\\, DATUM)) ((IL:\\\, V) (IL:\\\, NEW-VALUE))) (XCL:ASET (IL:\\\, V) (IL:\\\, D) (IL:\\\, 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) (FUNCTION (LAMBDA (LIST) (NTH OFFSET LIST))))

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

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

(DEFUN %MAKE-BIT-ACCESSOR (TYPE WORD-OFFSET OFFSET SIZE) (IF TYPE (FUNCTION (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))))) (FUNCTION (LAMBDA (OBJECT) (LDB (BYTE SIZE OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))))

(DEFUN %MAKE-FLAG-ACCESSOR (TYPE WORD-OFFSET OFFSET) (IF TYPE (FUNCTION (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))))))) (FUNCTION (LAMBDA (OBJECT) (NOT (EQ 0 (LDB (BYTE 1 OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))))))

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

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

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

(DEFUN %MAKE-FLOAT-ACCESSOR (TYPE OFFSET) (IF TYPE (FUNCTION (LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEFLOATP OBJECT OFFSET)))) (FUNCTION (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 (FUNCTION 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 (FUNCTION (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.") (IL:BQUOTE (DEFUN (IL:\\\, CONSTRUCTOR) (&KEY (IL:\\\,@ ARGUMENT-LIST)) (LET (((IL:\\\, RESULT-ARG) (IL:\\\, (RAW-CONSTRUCTOR PS)))) (IL:\\\,@ SLOT-SETFS) (IL:\\\, 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))) (IL:BQUOTE (DEFUN (IL:\\\, CONSTRUCTOR-NAME) (IL:\\\, NEW-ARGUMENT-LIST) (LET (((IL:\\\, RESULT-ARG) (IL:\\\, (RAW-CONSTRUCTOR PS)))) (IL:\\\,@ SLOT-SETFS) (IL:\\\, RESULT-ARG))))))

(DEFUN ARGUMENT-NAMES (ARG-LIST) (MAPCAN (FUNCTION (LAMBDA (ARG) (COND ((CONSP ARG) (IF (CONSP (CAR ARG)) (LIST (CONS (CADR (CAR ARG)) (CDR 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)) (LEGAL-KEYWORDS (QUOTE (&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX))) ARG-TAIL ARG-HEAD) (IL:* IL:|;;| "Munch through the argument list, generating the slightly munged BOA argument list.  First pop off the mandatory arguments") (SETQ ARG-TAIL NEW-ARG-LIST) (FLET ((MORE-TO-DO NIL (AND ARG-TAIL (NOT (MEMBER (CAR ARG-TAIL) LEGAL-KEYWORDS :TEST (FUNCTION EQ))))) (BUILD-ARG (OLD-ARG KEY?) (SETF (CAR ARG-TAIL) (COND ((SYMBOLP OLD-ARG) (LET ((IVF (PSLOT-INITIAL-VALUE (FIND-SLOT OLD-ARG SLOTS)))) (IF IVF (IL:BQUOTE ((IL:\\\, OLD-ARG) (IL:\\\, IVF))) (IL:BQUOTE ((IL:\\\, OLD-ARG) NIL (IL:\\\, (IL:GENSYM))))))) ((CONSP OLD-ARG) (IF (CDR OLD-ARG) OLD-ARG (IL:* IL:\; "already a default") (LET ((IVF (PSLOT-INITIAL-VALUE (FIND-SLOT (IF (AND KEY? (CONSP (CAR OLD-ARG))) (SECOND (CAR OLD-ARG)) (CAR OLD-ARG)) SLOTS)))) (IF IVF (IL:BQUOTE ((IL:\\\, (CAR OLD-ARG)) (IL:\\\, IVF))) (IL:BQUOTE ((IL:\\\, (CAR OLD-ARG)) NIL (IL:\\\, (IL:GENSYM)))))))))))) (IL:WHILE (MORE-TO-DO) IL:DO (POP ARG-TAIL)) (IL:* IL:|;;| "Then chew on the seperate argument classes") (IL:WHILE ARG-TAIL IL:DO (CASE (SETQ ARG-HEAD (POP ARG-TAIL)) (&OPTIONAL (IL:WHILE (MORE-TO-DO) IL:DO (BUILD-ARG (CAR ARG-TAIL) NIL) (POP ARG-TAIL))) (&KEY (IL:WHILE (MORE-TO-DO) IL:DO (BUILD-ARG (CAR ARG-TAIL) T) (POP ARG-TAIL))) (&ALLOW-OTHER-KEYS) (&REST (POP ARG-TAIL)) (&AUX (IL:WHILE (MORE-TO-DO) IL:DO (POP ARG-TAIL))) (OTHERWISE (ERROR "~S cannot appear in a BOA constructor as it does in ~S." ARG-HEAD ARG-LIST))))) 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 (FUNCTION EQ))) (XCL:COLLECT (IF SLOT-ARGUMENT (LET ((SUPPLIED-P (CADDR SLOT-ARGUMENT))) (IF SUPPLIED-P (IL:BQUOTE (IF (IL:\\\, SUPPLIED-P) (SETF (IL:\\\, SLOT-PLACE) (IL:\\\, SLOT-NAME)))) (IL:BQUOTE (SETF (IL:\\\, SLOT-PLACE) (IL:\\\, SLOT-NAME))))) (IL:BQUOTE (SETF (IL:\\\, SLOT-PLACE) (IL:\\\, (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:BQUOTE (IL:NCREATE (QUOTE (IL:\\\, (PS-NAME PS)))))) (LIST (IL:BQUOTE (MAKE-LIST (IL:\\\, (PS-NUMBER-OF-SLOTS PS))))) (VECTOR (IL:BQUOTE (MAKE-ARRAY (QUOTE ((IL:\\\, (PS-NUMBER-OF-SLOTS PS)))) :ELEMENT-TYPE (QUOTE (IL:\\\, (PS-VECTOR-TYPE PS))))))))

(DEFUN BUILD-CONSTRUCTOR-ARGLIST (SLOTS) (IL:* IL:|;;| "Gathers the keywords and initial-values for (non BOA) constructors") (MAPCAN (FUNCTION (LAMBDA (SLOT) (LET* ((INIT-FORM (PSLOT-INITIAL-VALUE SLOT)) (ARG-NAME (PSLOT-NAME SLOT)) (KEYWORD-PAIR (IL:BQUOTE ((IL:\\\, (VALUES (INTERN (SYMBOL-NAME ARG-NAME) (QUOTE KEYWORD)))) (IL:\\\, (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") (IL:BQUOTE (((IL:\\\, KEYWORD-PAIR) (IL:\\\, INIT-FORM))))) (T (IL:BQUOTE (((IL:\\\, KEYWORD-PAIR) NIL (IL:\\\, (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 (FUNCTION (LAMBDA (SLOT) (COND ((NOT (PSLOT-ACCESSOR SLOT)) (IL:* IL:|;;| "invisible slot, so generate a setf to it's initial-value") (IL:BQUOTE (SETF (IL:\\\, (ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T)) (IL:\\\, (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 (IL:BQUOTE (SETF (IL:\\\, (ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T)) (IL:\\\, KEYWORD-VAR-NAME))) (IL:BQUOTE (IF (IL:\\\, (CADDR ARGUMENT)) (SETF (IL:\\\, (ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T)) (IL:\\\, 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 (QUOTE 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 (QUOTE 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.") (IL:BQUOTE ((DEFUN (IL:\\\, (PS-COPIER PS)) ((IL:\\\, FROM-ARG)) (IL:\\\,@ FROM-ARG-TYPE-CHECK) (LET (((IL:\\\, RESULT-ARG) (IL:\\\, (RAW-CONSTRUCTOR PS)))) (IL:\\\,@ SLOT-SETFS) (IL:\\\, 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 (FUNCTION (LAMBDA (SLOT) (IL:BQUOTE (SETF (IL:\\\, (ACCESSOR-BODY SLOT TO-ARGUMENT STRUCTURE-TYPE T)) (IL:\\\, (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) (QUOTE DATATYPE)) (IL:* IL:|;;| "If something is a datatype type check the from-arg once at the beginning.  Don't check the individual accesses.") (VALUES (IL:BQUOTE ((CHECK-TYPE (IL:\\\, FROM-ARG) (IL:\\\, (PS-NAME PS))))) NIL)) ((PS-PREDICATE PS) (IL:* IL:|;;| "if the structure has a predicate ,then call the predicate.") (VALUES (IL:BQUOTE ((OR ((IL:\\\, (PS-PREDICATE PS)) (IL:\\\, FROM-ARG)) (ERROR (IL:\\\, (FORMAT NIL "Arg not ~s: ~~S" (PS-NAME PS))) (IL:\\\, 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 (QUOTE 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)))) (IL:BQUOTE (MULTIPLE-VALUE-BIND (SUBTYPE? CERTAIN?) (SUBTYPEP (IL:\\\, TYPE1) (IL:\\\, TYPE2)) (COND (SUBTYPE? (IL:* IL:\; "it's ok, continue") T) (CERTAIN? (IL:* IL:\; "subtypep says it sure, so blow up") (ERROR (IL:\\\, ERROR-STRING) (IL:\\\,@ ERROR-ARGS))) (T (IL:* IL:\; "subtypep isn't sure, so raise a continuable error") (CERROR "Assume subtypep should return t" (IL:\\\, (FORMAT NIL "Perhaps, ~a" ERROR-STRING)) (IL:\\\,@ ERROR-ARGS)) (IL:\\\,@ CERROR-ACTIONS) T))))))



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



(DEFUN STRUCTURE-OBJECT-P (OBJECT) (TYPEP OBJECT (QUOTE 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))) (QUOTE STRUCTURE-OBJECT-INSPECT-FETCHFN) (QUOTE STRUCTURE-OBJECT-INSPECT-STOREFN) (QUOTE STRUCTURE-OBJECT-PROPCOMMANDFN) NIL NIL (LET ((XCL:*PRINT-STRUCTURE* NIL)) (CONCATENATE (QUOTE STRING) (PRINC-TO-STRING STRUCTURE) " Inspector")) NIL WHERE (QUOTE 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 (IL:BQUOTE (SETF ((IL:\\\, (PSLOT-ACCESSOR PROPERTY)) (QUOTE (IL:\\\, OBJECT))) (QUOTE (IL:\\\, NEWVALUE))))) (IL:REPLACEFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY) OBJECT NEWVALUE)))

(DEFUN STRUCTURE-OBJECT-PROPCOMMANDFN (PROPERTY DATUM INSPECTOR-WINDOW) (IF (AND (TYPEP DATUM (QUOTE 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 (QUOTE FOUND) (MAPHASH (FUNCTION (LAMBDA (KEY PS) (IF (OR (AND (CONSP (PS-CONSTRUCTORS PS)) (MEMBER SYMBOL (PS-CONSTRUCTORS PS) :TEST (FUNCTION 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 (QUOTE FOUND) KEY)))) *PARSED-DEFSTRUCTS*)))

(DEFUN STRUCTURE-FUNCTIONS (STRUCTURE-NAME) (LET ((PS (PARSED-STRUCTURE STRUCTURE-NAME))) (IL:BQUOTE ((IL:\\\,@ (PS-CONSTRUCTORS PS)) (IL:\\\,. (LET ((PREDICATE (PS-PREDICATE PS))) (IF PREDICATE (LIST PREDICATE)))) (IL:\\\,. (LET ((COPIER (PS-COPIER PS))) (IF COPIER (LIST COPIER)))) (IL:\\\,. (MAPCAN (FUNCTION (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 (STRUCTURE-FUNCTION-P NAME) (IL:GETDEF NAME (QUOTE IL:STRUCTURES) (QUOTE IL:CURRENT) (QUOTE (IL:NODWIM IL:NOCOPY IL:NOERROR IL:HASDEF)))))

(DEFUN STRUCTURES.EDITDEF (NAME TYPE SOURCE EDITCOMS OPTIONS) "From accessor function or structure name, edit the structure." (IL:* IL:\; "Edited by TT (8-June-90 : solution for AR#11127)") (IF (PARSED-STRUCTURE NAME T) (IL:DEFAULT.EDITDEF NAME (QUOTE IL:STRUCTURES) SOURCE EDITCOMS OPTIONS) (LET ((STRUCTURE-NAME (STRUCTURE-FUNCTION-P NAME))) (IL:* IL:\; "Accessor functions are identified as structures, edit the structure instead.") (IF STRUCTURE-NAME (IL:DEFAULT.EDITDEF STRUCTURE-NAME (QUOTE IL:STRUCTURES) SOURCE EDITCOMS OPTIONS) (IL:DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))) NAME)

(IL:FILEPKGTYPE (QUOTE IL:STRUCTURES) (QUOTE IL:HASDEF) (QUOTE STRUCTURES.HASDEF) (QUOTE IL:EDITDEF) (QUOTE 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 1991
 1992))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP