(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 4-Jan-93 18:09:50" IL:|{DSK}lde>lispcore>sources>DEFSTRUCT-RUN-TIME.;2| 16909 IL:|previous| IL:|date:| "16-May-90 15:32:24" IL:|{DSK}lde>lispcore>sources>DEFSTRUCT-RUN-TIME.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DEFSTRUCT-RUN-TIMECOMS) (IL:RPAQQ IL:DEFSTRUCT-RUN-TIMECOMS ((IL:COMS (IL:* IL:|;;| "Remembering parsed structures") (IL:VARIABLES *PARSED-DEFSTRUCTS*) (IL:FUNCTIONS PARSED-STRUCTURE SET-PARSED-STRUCTURE) (IL:SETFS PARSED-STRUCTURE)) (IL:COMS (IL:* IL:|;;| "Declaring storage for structures") (IL:FUNCTIONS SI::%STRUCTURE-DECLARE-DATATYPE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:* IL:|;;|  "This defines the root of the defstruct type hierarchy.") (IL:P (IL:\\ASSIGNDATATYPE1 'STRUCTURE-OBJECT NIL 0)))) (IL:COMS (IL:* IL:|;;| "Support for setf expansions etc") (IL:VARIABLES *DEFSTRUCT-INFO-CACHE*) (IL:FUNCTIONS ESTABLISH-SETFS-AND-OPTIMIZERS ESTABLISH-PREDICATE) (IL:FUNCTIONS GET-PS-FROM-ACCESSOR GET-PS-FROM-PREDICATE GET-SLOT-DESCRIPTOR-FROM-PS) (IL:FUNCTIONS CACHE-SETF-INFO)) (IL:COMS (IL:* IL:|;;| "defstruct IO") (IL:VARIABLES XCL:*PRINT-STRUCTURE*) (IL:FUNCTIONS PRINT-STRUCTURE-INSTANCE DEFAULT-STRUCTURE-PRINTER STRUCTURE-SLOT-NAMES ) (IL:* IL:|;;| "For reading") (IL:FUNCTIONS IL:CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:DEFSTRUCT-RUN-TIME) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (IL:* IL:|;;| "Remembering parsed structures") (DEFVAR *PARSED-DEFSTRUCTS* (IL:HASHARRAY 100) (IL:* IL:|;;| "All declared structures") ) (DEFMACRO PARSED-STRUCTURE (NAME &OPTIONAL (NO-ERROR NIL)) (IL:* IL:|;;| "Returns the parsed-structure corresponding to name") (COND (NO-ERROR `(IL:GETHASH ,NAME *PARSED-DEFSTRUCTS*)) (T `(OR (IL:GETHASH ,NAME *PARSED-DEFSTRUCTS*) (ERROR "~s is not a defined structure" ,NAME))))) (DEFUN SET-PARSED-STRUCTURE (NAME PS &OPTIONAL (EXTRA NIL EXTRA-P)) (IL:* IL:|;;| "SETF method for CL::PARSED-STRUCTURE. Extra arg is because CL::PARSED-STRUCTURE takes an optional, which we ignore here, but that pushes the new value over one.") (WHEN EXTRA-P (SETQ PS EXTRA)) (IL:PUTHASH NAME PS *PARSED-DEFSTRUCTS*)) (DEFSETF PARSED-STRUCTURE SET-PARSED-STRUCTURE) (IL:* IL:|;;| "Declaring storage for structures") (DEFUN SI::%STRUCTURE-DECLARE-DATATYPE (NAME FIELD-SPECIFICATIONS FIELD-DESCRIPTORS WORD-LENGTH SUPERTYPE) (IL:* IL:|;;;| "analagous to declare-datatype, but does not prepend the supers descriptors. You must include all descs.") (IL:* IL:|;;;| "N.B. descriptions and specs are for ALL slots, not just local-slots.") (IL:* IL:|;;| "field-specifications is a list of the form '(pointer pointer (bits 3) (bits 5) word fixp). See p. 8.21 IRM") (IL:* IL:|;;| "field-descriptors is the list returned from translate.datatype when given the above FIELD-SPECIFICATIONS. They are legal to pass to fetchfield.") (IL:* IL:|;;| "word-length is the car of the result of translate.datatype.") (IL:* IL:|;;| "supertype is the typename of the supertype.") (IF (NOT (AND (SYMBOLP NAME) (IL:SMALLPOSP WORD-LENGTH))) (ERROR "Illegal arguments: ~s ~s" NAME WORD-LENGTH)) (LET ((REFERENCE-COUNTED-POINTERS (MAPCAN #'(LAMBDA (DESCRIPTOR) (CASE (CADDR DESCRIPTOR) ((IL:POINTER IL:FULLPOINTER) (LIST (CADR DESCRIPTOR))))) FIELD-DESCRIPTORS))) (MULTIPLE-VALUE-BIND (TYPE-NUMBER REDECLARED?) (IL:\\ASSIGNDATATYPE1 NAME FIELD-DESCRIPTORS WORD-LENGTH FIELD-SPECIFICATIONS REFERENCE-COUNTED-POINTERS SUPERTYPE) (IL:* IL:|;;| "set the magic global to the allocated type number") (IL:SETTOPVAL (IL:\\TYPEGLOBALVARIABLE NAME T) TYPE-NUMBER) (VALUES FIELD-DESCRIPTORS REDECLARED?)))) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:\\ASSIGNDATATYPE1 'STRUCTURE-OBJECT NIL 0) ) (IL:* IL:|;;| "Support for setf expansions etc") (DEFVAR *DEFSTRUCT-INFO-CACHE* (IL:HASHARRAY 100) (IL:* IL:|;;| "Used to cache slots and predicates") ) (DEFUN ESTABLISH-SETFS-AND-OPTIMIZERS (PS-NAME) (IL:* IL:|;;| "Caches shared setf expanders and accessor optimizers where appropriate") (LET* ((PS (PARSED-STRUCTURE PS-NAME)) (INLINE (PS-INLINE PS))) (MAPC #'(LAMBDA (SLOT) (IL:* IL:|;;|  "function-defining-form decides whether or not the accessors should be defun, definline, etc.") (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))) (WHEN ACCESSOR (REMHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*) (IF (NOT (PSLOT-READ-ONLY SLOT)) (IL:* IL:|;;|  "install the setf method expander that is shared for all accessors") (SET-SHARED-SETF-INVERSE ACCESSOR 'DEFSTRUCT-SHARED-SETF-EXPANDER)) (COND ((EQ INLINE :ONLY) (SETF (MACRO-FUNCTION ACCESSOR) 'DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER)) ((MEMBER :ACCESSOR INLINE :TEST #'EQ) (SETF (GET ACCESSOR 'COMPILER:OPTIMIZER-LIST) (LIST 'DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER))) (T (REMPROP ACCESSOR 'COMPILER:OPTIMIZER-LIST)))))) (PS-ALL-SLOTS PS)))) (DEFUN ESTABLISH-PREDICATE (PS-NAME) (IL:* IL:|;;| "Establishes a shared a shared optimizer for a defstruct predicate") (LET* ((PS (PARSED-STRUCTURE PS-NAME)) (PREDICATE (PS-PREDICATE PS))) (REMHASH PREDICATE *DEFSTRUCT-INFO-CACHE*) (IF (EQ (PS-INLINE PS) :ONLY) (SETF (MACRO-FUNCTION PREDICATE) 'DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER) (SETF (GET PREDICATE 'COMPILER:OPTIMIZER-LIST) (LIST 'DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER))))) (DEFUN GET-PS-FROM-ACCESSOR (ACCESSOR &OPTIONAL (NO-ERROR-P NIL)) (OR (CATCH 'FIND-PS (MAPHASH #'(LAMBDA (KEY VALUE) (DOLIST (SLOT (PS-ALL-SLOTS VALUE) NIL) (IF (EQ ACCESSOR (PSLOT-ACCESSOR SLOT)) (THROW 'FIND-PS VALUE)))) *PARSED-DEFSTRUCTS*)) (IF (NULL NO-ERROR-P) (ERROR "No such slot: ~s" ACCESSOR)))) (DEFUN GET-PS-FROM-PREDICATE (PREDICATE &OPTIONAL (NO-ERROR-P NIL)) (OR (CATCH 'FIND-PS (MAPHASH #'(LAMBDA (KEY VALUE) (IF (EQ PREDICATE (PS-PREDICATE VALUE)) (THROW 'FIND-PS VALUE))) *PARSED-DEFSTRUCTS*)) (IF (NULL NO-ERROR-P) (ERROR "No such predicate: ~s" PREDICATE)))) (DEFUN GET-SLOT-DESCRIPTOR-FROM-PS (ACCESSOR PS &OPTIONAL (NO-ERROR-P NIL)) (OR (DOLIST (SLOT (PS-ALL-SLOTS PS) NIL) (IF (EQ ACCESSOR (PSLOT-ACCESSOR SLOT)) (RETURN SLOT))) (IF (NULL NO-ERROR-P) (ERROR "No such slot: ~s" ACCESSOR)))) (DEFUN CACHE-SETF-INFO (PS-NAME) (IL:* IL:|;;| "For compatability with the old defstruct") (LET ((PS (PARSED-STRUCTURE PS-NAME))) (MAPC #'(LAMBDA (SLOT) (IL:* IL:|;;|  "function-defining-form decides whether or not the accessors should be defun, definline, etc.") (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))) (WHEN ACCESSOR (REMHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*) (IF (NOT (PSLOT-READ-ONLY SLOT)) (IL:* IL:|;;|  "install the setf method expander that is shared for all accessors") (SET-SHARED-SETF-INVERSE ACCESSOR 'DEFSTRUCT-SHARED-SETF-EXPANDER))))) (PS-ALL-SLOTS PS)))) (IL:* IL:|;;| "defstruct IO") (DEFVAR XCL:*PRINT-STRUCTURE* T "Flag indicating whether the contents of structures are to be printed.") (DEFUN PRINT-STRUCTURE-INSTANCE (OBJECT STREAM DEPTH) (IL:* IL:|;;| "Looks up the print function for the structure instance and calls it") (FUNCALL (OR (PS-PRINT-FUNCTION (PARSED-STRUCTURE (TYPE-OF OBJECT))) %DEFAULT-PRINT-FUNCTION) OBJECT STREAM (OR DEPTH 0))) (DEFUN DEFAULT-STRUCTURE-PRINTER (STRUC STREAM &OPTIONAL (PRINT-LEVEL 0)) (IF (NOT XCL:*PRINT-STRUCTURE*) (IL:\\PRINT-USING-ADDRESS STRUC STREAM 0) (LET ((TYPE (IL:TYPENAME STRUC)) LABEL (FIRST-TIME? T)) (WHEN IL:*PRINT-CIRCLE-HASHTABLE* (IL:* IL:|;;| "only true if *print-circle* is true and the structure is circular.") (MULTIPLE-VALUE-SETQ (LABEL FIRST-TIME?) (IL:PRINT-CIRCLE-LOOKUP STRUC))) (IL:* IL:|;;| "(cl:format t \"label: ~S firsttime ~S~%\" label first-time?)") (WHEN LABEL (IL:* IL:|;;| "this guy needs to be flagged for circle-printing") (IL:PRIN3 LABEL STREAM)) (WHEN (OR (NOT LABEL) FIRST-TIME?) (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (1- *PRINT-LEVEL*)))) (IF (OR (AND *PRINT-LEVEL* (<= *PRINT-LEVEL* PRINT-LEVEL)) (AND *PRINT-LENGTH* (<= *PRINT-LENGTH* 0))) (IL:\\ELIDE.PRINT.ELEMENT STREAM) (LET ((LENGTHSOFAR (IF *PRINT-LENGTH* 0))) (IL:\\OUTCHAR STREAM (IL:|fetch| (READTABLEP IL:HASHMACROCHAR) IL:|of| *READTABLE*) ) (WRITE-STRING "S(" STREAM) (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR) *PRINT-LENGTH*)) (IL:\\ELIDE.PRINT.TAIL STREAM T) (PROGN (IF *PRINT-ESCAPE* (PRIN1 TYPE STREAM) (PRINC TYPE STREAM)) (DO ((FIELD (STRUCTURE-SLOT-NAMES TYPE) (CDR FIELD)) (DESCRIPTOR (IL:GETDESCRIPTORS TYPE) (CDR DESCRIPTOR))) ((NULL FIELD)) (WHEN (EQ (CAR FIELD) 'SI::--STRUCTURE-DUMMY-SLOT--) (GO SKIP)) (IL:\\OUTCHAR STREAM (IL:CONSTANT (CHAR-CODE #\Space))) (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR) *PRINT-LENGTH*)) (PROGN (IL:\\ELIDE.PRINT.TAIL STREAM T) (RETURN NIL)) (PROGN (PRINC (CAR FIELD) STREAM) (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR) *PRINT-LENGTH*)) (PROGN (IL:\\ELIDE.PRINT.TAIL STREAM T) (RETURN NIL)) (PROGN (IL:\\OUTCHAR STREAM (IL:CONSTANT (CHAR-CODE #\Space))) (IL:\\PRINDATUM (IL:FETCHFIELD (CAR DESCRIPTOR ) STRUC) STREAM (1+ PRINT-LEVEL)))))) SKIP))) (WRITE-STRING ")" STREAM))))) T))) (DEFUN STRUCTURE-SLOT-NAMES (STRUCTURE-NAME &OPTIONAL (DONT-COPY NIL)) (LET* ((PS (PARSED-STRUCTURE STRUCTURE-NAME)) NAMES) (SETQ NAMES (PS-ALL-SLOT-NAMES PS)) (IF DONT-COPY NAMES (COPY-LIST NAMES)))) (IL:* IL:|;;| "For reading") (DEFUN IL:CREATE-STRUCTURE (STRUCTURE-FORM) (APPLY (STRUCTURE-CONSTRUCTOR (CAR STRUCTURE-FORM)) (XCL:WITH-COLLECTION (DO ((TAIL (CDR STRUCTURE-FORM) (CDDR TAIL))) ((NULL TAIL)) (XCL:COLLECT (IL:MAKE-KEYWORD (CAR TAIL))) (XCL:COLLECT (CADR TAIL)))))) (DEFUN STRUCTURE-CONSTRUCTOR (STRUCTURE-NAME) (OR (GET STRUCTURE-NAME 'IL:STRUCTURE-CONSTRUCTOR) (LET* ((PS (PARSED-STRUCTURE STRUCTURE-NAME)) (CONSTRUCTOR (PS-STANDARD-CONSTRUCTOR PS))) (OR CONSTRUCTOR (ERROR "~S is a structure with no standard constructor." (PS-NAME PS)))) )) (IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993) ) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP