add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
355
CLTL2/DEFSTRUCT-RUN-TIME
Normal file
355
CLTL2/DEFSTRUCT-RUN-TIME
Normal file
@@ -0,0 +1,355 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
|
||||
(IL:FILECREATED "18-Oct-93 15:27:40"
|
||||
"{Pele:mv:envos}<LispCore>Sources>CLTL2>DEFSTRUCT-RUN-TIME.;2" 15658
|
||||
|
||||
IL:|previous| IL:|date:| "29-Aug-91 17:01:45"
|
||||
"{Pele:mv:envos}<LispCore>Sources>CLTL2>DEFSTRUCT-RUN-TIME.;1")
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990, 1991, 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; observes *print-circle* and XCL:*PRINT-STRUCTURE* from here, too.")
|
||||
|
||||
(LET (LABEL (FIRST-TIME? T))
|
||||
(WHEN IL:*PRINT-CIRCLE-HASHTABLE*
|
||||
(MULTIPLE-VALUE-SETQ (LABEL FIRST-TIME?)
|
||||
(IL:PRINT-CIRCLE-LOOKUP OBJECT)))
|
||||
(WHEN LABEL
|
||||
|
||||
(IL:* IL:|;;| "this guy needs to be flagged for circle-printing")
|
||||
|
||||
(IL:PRIN3 LABEL STREAM))
|
||||
(WHEN (OR (NOT LABEL)
|
||||
FIRST-TIME?)
|
||||
(FUNCALL (OR (PS-PRINT-FUNCTION (PARSED-STRUCTURE (TYPE-OF OBJECT)))
|
||||
%DEFAULT-PRINT-FUNCTION)
|
||||
OBJECT STREAM (OR DEPTH 0)))
|
||||
T))
|
||||
|
||||
(DEFUN DEFAULT-STRUCTURE-PRINTER (STRUC STREAM &OPTIONAL (PRINT-LEVEL 0))
|
||||
(IF (NOT XCL:*PRINT-STRUCTURE*)
|
||||
(IL:\\PRINT-USING-ADDRESS STRUC STREAM 0)
|
||||
(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))
|
||||
(TYPE (IL:TYPENAME STRUC)))
|
||||
(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 1991
|
||||
1993))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
Reference in New Issue
Block a user