(FILECREATED "14-Oct-86 16:44:37" {ERIS}<LISPCORE>SOURCES>CMLSTRUCT.;7 22797
changes to: (FUNCTIONS DEFSTRUCT)
previous date: "19-Sep-86 18:42:44" {ERIS}<LISPCORE>SOURCES>CMLSTRUCT.;6)
(* "
Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLSTRUCTCOMS)
(RPAQQ CMLSTRUCTCOMS [(* ;;; "this is the baby defstruct used to bootstrap PCL")
(FUNCTIONS SLOT-NAME)
(FNS DEFAULT-STRUCTURE-PRINTER LOCAL-SLOT-LIST \DEFPRINT.DEFSTRUCT.DEFAULT
\CMLSTRUCT.CLTYPE.TO.ILTYPE SLOT-LIST SUBSTITUTE-SLOTS
STRUCTURE-CONSTRUCTOR CREATE-STRUCTURE CONSTRUCTOR-DEFUN)
(DEFINE-TYPES STRUCTURES)
(SETFS INCLUDED-STRUCTURE)
(FNS INCLUDED-STRUCTURE)
(FUNCTIONS DEFSTRUCT)
(PROP FILETYPE CMLSTRUCT)
(OPTIMIZERS STRUCTURE-CONSTRUCTOR)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR SUBSTITUTE-SLOTS
SLOT-LIST LOCAL-SLOT-LIST DEFAULT-STRUCTURE-PRINTER])
(* ;;; "this is the baby defstruct used to bootstrap PCL")
(DEFMACRO SLOT-NAME (SLOT-DESC) (BQUOTE (CL:IF (CL:ATOM (\, SLOT-DESC))
(\, SLOT-DESC)
(CAR (\, SLOT-DESC)))))
(DEFINEQ
(DEFAULT-STRUCTURE-PRINTER
(CL:LAMBDA (STRUC STREAM LEVEL) (* lmm " 9-May-86 18:03")
(\DEFPRINT.DEFSTRUCT.DEFAULT STRUC STREAM)))
(LOCAL-SLOT-LIST
[CL:LAMBDA (NAME) (* gbn " 6-Jul-86 18:20")
(COPY (GET NAME (QUOTE %%LOCAL-SLOT-NAMES])
(\DEFPRINT.DEFSTRUCT.DEFAULT
[LAMBDA (STRUC STREAM) (* amd "16-May-86 12:00")
(LET ((TYPE (TYPENAME STRUC)))
(\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
(PRIN3 "S(" STREAM)
(PRIN2 TYPE STREAM)
(LET [(*PRINT-LEVEL* (AND *PRINT-LEVEL* (SUB1 *PRINT-LEVEL*]
(DECLARE (SPECVARS *PRINT-LEVEL*))
(for FIELD in (SLOT-LIST TYPE) as DESCRIPTOR in (GETDESCRIPTORS TYPE)
do (PRIN1 " " STREAM)
(PRIN2 (SLOT-NAME FIELD)
STREAM)
(PRIN1 " " STREAM)
(PRIN2 (FETCHFIELD DESCRIPTOR STRUC)
STREAM)))
(PRIN1 ")" STREAM)
T])
(\CMLSTRUCT.CLTYPE.TO.ILTYPE
[LAMBDA (ELEMENTTYPE) (* kbr: " 7-Apr-86 11:22")
(* * Returns the most specific InterLisp type descriptor which will hold a
given type.)
(* * 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) XPOINTER DOUBLE-POINTER)
(SELECTQ ELEMENTTYPE
((STRING-CHAR T)
(QUOTE POINTER))
(FIXNUM (QUOTE SIGNEDWORD))
(INTEGER (QUOTE FIXP))
(BIT (QUOTE (BITS 1)))
(XPOINTER ELEMENTTYPE)
((SINGLE-FLOAT FLOAT)
(QUOTE FLOATP))
(COND
[(AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE MOD))
(NULL (CDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(ILESSP 1 (CADR ELEMENTTYPE))) (* (MOD n) is converted to the next
higher enclosing type.)
(LET ((MOD# (CADR ELEMENTTYPE)))
(COND
[(ILEQ MOD# (LLSH 1 BITSPERWORD))
(BQUOTE (BITS (\, (INTEGERLENGTH (SUB1 MOD#]
((ILEQ MOD# MAX.FIXP)
(QUOTE FIXP))
(T (QUOTE POINTER]
[(AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE UNSIGNED-BYTE))
(NULL (CDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(ILESSP 0 (CADR ELEMENTTYPE))) (* (UNSIGNED.BYTE n) is converted to
the next higher enclosing type.)
(LET ((#BITS (CADR ELEMENTTYPE)))
(COND
[(ILEQ #BITS BITSPERWORD)
(BQUOTE (BITS (\, #BITS]
((ILEQ #BITS (CONSTANT (INTEGERLENGTH MAX.FIXP)))
(QUOTE FIXP))
(T (QUOTE POINTER]
[(AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE INTEGER))
(NULL (CDDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(FIXP (CADDR ELEMENTTYPE))
(ILESSP (CADR ELEMENTTYPE)
(CADDR ELEMENTTYPE))) (* (INTEGER low high))
(LET* ((LOW (CADR ELEMENTTYPE))
(HIGH (CADDR ELEMENTTYPE))
(RANGE (IDIFFERENCE HIGH LOW))) (* Type simplification should probably
be done somewhere else)
(COND
[(IEQP LOW 0) (* (INTEGER 0 high) =>
(MOD nbits))
(\CMLSTRUCT.CLTYPE.TO.ILTYPE (BQUOTE (MOD , (ADD1 RANGE]
((AND (IGEQ LOW MIN.FIXP)
(ILEQ HIGH MAX.FIXP)) (* (INTEGER >= MIN.FIXP <= MAX.FIXP)
== FIXNUM)
(QUOTE FIXP))
(T (QUOTE POINTER]
((EQUAL ELEMENTTYPE (QUOTE (SIMPLE-VECTOR CL:* FIXNUM)))
(QUOTE POINTER))
((FMEMB ELEMENTTYPE (USERDATATYPES))
(QUOTE POINTER))
(T (ERROR "Bad type specifier" ELEMENTTYPE])
(SLOT-LIST
[CL:LAMBDA (NAME) (* amd "16-May-86 12:03")
(COPY (GET NAME (QUOTE %%SLOT-DESCRIPTIONS])
(SUBSTITUTE-SLOTS
[CL:LAMBDA (NEWSLOTS OLDSLOTS) (* amd "16-May-86 12:11")
(if (NULL NEWSLOTS)
then OLDSLOTS
else (for OLDSLOT in OLDSLOTS collect (OR (for NEWSLOT in NEWSLOTS
thereis (AND (EQ (SLOT-NAME OLDSLOT)
(SLOT-NAME NEWSLOT))
NEWSLOT))
OLDSLOT])
(STRUCTURE-CONSTRUCTOR
(CL:LAMBDA (STRUCTURE-NAME) (* edited: " 9-May-86 11:50")
(GET STRUCTURE-NAME (QUOTE STRUCTURE-CONSTRUCTOR))))
(CREATE-STRUCTURE
[CL:LAMBDA (STRUCTURE-FORM) (* gbn "28-Apr-86 17:32")
(APPLY (STRUCTURE-CONSTRUCTOR (CAR STRUCTURE-FORM))
(for TAIL on (CDR STRUCTURE-FORM) by (CDDR TAIL)
join (LIST (MAKE-KEYWORD (CAR TAIL))
(CADR TAIL])
(CONSTRUCTOR-DEFUN
[LAMBDA (X SLOT-DESCRIPTIONS NAME) (* gbn "17-Jun-86 18:35")
(LET [(KEYS (for X in SLOT-DESCRIPTIONS collect (if (NLISTP X)
then X
else (LIST (CAR X)
(CADR X]
(BQUOTE (DEFUN (\, X) ((\,@ (AND KEYS (BQUOTE (&KEY (\,@ KEYS))))))
(create (\, NAME)
(\,@ (for x in SLOT-DESCRIPTIONS join (LIST (SLOT-NAME x)
(QUOTE ←)
(SLOT-NAME x))))))
])
)
(DEF-DEFINE-TYPE STRUCTURES "Common Lisp structures" )
(DEFSETF INCLUDED-STRUCTURE (STRUCT) (INCLUDED)
(BQUOTE (PUT (\, STRUCT)
(QUOTE %%%%INCLUDED-STRUCTURE)
(\, INCLUDED))))
(DEFINEQ
(INCLUDED-STRUCTURE
[LAMBDA (STRUCT) (* gbn "17-Jun-86 18:02")
(GET STRUCT (QUOTE %%%%INCLUDED-STRUCTURE])
)
(DEFDEFINER DEFSTRUCT
STRUCTURES
(NAME &REST SLOT-DESCRIPTIONS)
(LET
((OPTIONS (COND
((LISTP NAME)
(PROG1 (CDR NAME)
(SETQ NAME (CAR NAME)))))))
(LET
((DOC (AND (STRINGP (CAR SLOT-DESCRIPTIONS))
(pop SLOT-DESCRIPTIONS)))
CLASS
(DEFAULT-CLASS (QUOTE STRUCTURE-CLASS))
(SLOTFNS)
(SLOT-NAMES)
(LOCAL-SLOT-NAMES)
(INITIALIZATION)
(INCLUDES)
(CONC-NAME (CONCAT NAME "-"))
(CONSTRUCTORS)
(PREDICATE (XCL:PACK* NAME "-P"))
(PRINT-FUNCTION (FUNCTION DEFAULT-STRUCTURE-PRINTER))
(COPIER (XCL:PACK* "COPY-" NAME))
(SLOT-LOCATIONS)
SIMPLE-CONSTRUCTOR NAMED TYPE)
(for OPTION in OPTIONS do (COND
((LISTP OPTION)
(CASE (CAR OPTION)
(:CLASS (SETQ CLASS (CADR OPTION)))
(:CONSTRUCTOR (CL:PUSH (CDR OPTION)
CONSTRUCTORS))
(:CONC-NAME (SETQ CONC-NAME (OR (CADR OPTION)
"")))
(:INCLUDE (OR INCLUDES (SETQ INCLUDES (CDR OPTION))))
(:COPIER (SETQ COPIER (CADR OPTION)))
(:PRINT-FUNCTION (SETQ PRINT-FUNCTION (CADR OPTION)))
(:PREDICATE (SETQ PREDICATE (CADR OPTION)))
(:TYPE (SETQ CLASS (PACK* (CADR OPTION)
"-CLASS")))
(:INITIAL-OFFSET (CL:ERROR
":INITIAL-OFFSET unimplemented for DEFSTRUCT"
))
(OTHERWISE (CL:ERROR "Bad option to defstruct: ~S." OPTION))
))
(T (CASE OPTION (:NAMED (SETQ NAMED T))
(OTHERWISE (CL:ERROR "Bad option to defstruct: ~S." OPTION
))))))
(CL:IF (NOT CLASS)
(CL:SETQ CLASS DEFAULT-CLASS))
(for S in SLOT-DESCRIPTIONS do (CL:PUSH (SLOT-NAME S)
LOCAL-SLOT-NAMES))
(* ;
"There should be a check here to ensure that only the same type is included")
(SETQ SLOT-LOCATIONS (for S in LOCAL-SLOT-NAMES collect (CONS S NAME)))
(* ;
"now build up a list of slots together with the structure that they are directly inherited from.")
(if INCLUDES
then (DESTRUCTURING-BIND (INCL-NAME &REST INCL-SLOT-DESCS)
INCLUDES (* ;; "(LET ((INCLUDED-DEF (GETDEF INCL-NAME (QUOTE STRUCTURES)))) (CL:IF (NOT INCLUDED-DEF) (CL:ERROR `~A can not be included because it has no structure definition' INCL-NAME)) (* ; `insure that the included structure has the right type') (LET ((SUPER-CLASS (CADR (CL:ASSOC (QUOTE :TYPE) (MKLIST (CADR INCLUDED-DEF)))))) (CL:SETQ SUPER-CLASS (CL:IF SUPER-CLASS (PACK* SUPER-CLASS `-CLASS') DEFAULT-CLASS)) (CL:IF (NOT (EQ SUPER-CLASS CLASS)) (CL:ERROR `Can't include ~A because it is not of type ~A' INCLUDES CLASS))))")
(CL:UNLESS (STRUCTURE-CONSTRUCTOR INCL-NAME)
(CL:ERROR "~A can not be included because it has no structure definition"
INCL-NAME)) (* ;;
"Ensure that the included structure has the right type")
(CL:UNLESS (EQ (GET INCL-NAME (QUOTE %%STRUCTURE-CLASS))
CLASS)
(CL:ERROR "Can't include ~A because it is not of type ~A" INCLUDES CLASS)
)
(SETQ SLOT-DESCRIPTIONS (CONCATENATE (QUOTE LIST)
(SUBSTITUTE-SLOTS INCL-SLOT-DESCS (SLOT-LIST
INCL-NAME))
SLOT-DESCRIPTIONS))
(SELECTQ CLASS
(LIST-CLASS NIL)
(STRUCTURE-CLASS
(DESTRUCTURING-BIND (INCL-NAME &REST INCL-SLOT-DESCS)
INCLUDES
(push INITIALIZATION (BQUOTE (INCLUDES (\, INCL-NAME))))
(* ;
"now build up a list of slots together with the structure that they are directly inherited from.")
(for (SUPER ← INCL-NAME) by (INCLUDED-STRUCTURE SUPER)
while SUPER do (for S in (LOCAL-SLOT-LIST SUPER)
do (CL:PUSH (CONS S SUPER)
SLOT-LOCATIONS)))))
(CL:ERROR ":INCLUDE is not supported for type ~A" CLASS))))
(for X in (REVERSE SLOT-DESCRIPTIONS) do (CL:PUSH (SLOT-NAME X)
SLOT-NAMES)
(CL:WHEN (CADR (LISTP X))
(pushlist INITIALIZATION
(BQUOTE ((\, (SLOT-NAME X))←
(\, (CADR X)))))))
(* ;;;
"make slot accessor and settor fns and dmacros")
(* ;; "(USERRECLST (LIST (BQUOTE ((\, (SELECTQ CLASS ((NIL STRUCTURE) (QUOTE DATATYPE)) (LIST-CLASS (if NAMED then (QUOTE TYPERECORD) else (QUOTE RECORD))) (VECTOR (QUOTE ARRAYRECORD)) (CL:ERROR `Illegal type: ~S in DEFSTRUCT.' CLASS))) (\, NAME) (\, SLOT-NAMES) (\,@ INITIALIZATION)))))")
(PROGN
(for SLOT-DESC in SLOT-DESCRIPTIONS
do (DESTRUCTURING-BIND
(SLOT-NAME SLOT-INIT &KEY READ-ONLY &ALLOW-OTHER-KEYS)
(MKLIST SLOT-DESC)
(LET ((ACCESSOR (XCL:PACK* CONC-NAME SLOT-NAME))
(SLOT-LOCATION (SELECTQ CLASS
(LIST-CLASS NAME)
(STRUCTURE-CLASS
(OR (CDR (CL:ASSOC SLOT-NAME SLOT-LOCATIONS))
(CL:ERROR "slot-location unknown inside defstruct: ~A"
SLOT-NAME)))
(CL:ERROR ":INCLUDE is not supported for type ~A" CLASS))))
(pushlist SLOTFNS
(BQUOTE ((DEFUN (\, ACCESSOR) (OBJECT) (fetch ((\, SLOT-LOCATION)
(\, SLOT-NAME)) of OBJECT))
(\,@ (CL:UNLESS READ-ONLY
(LET ((SETTER (XCL:PACK* "setf-" ACCESSOR)))
(BQUOTE ((DEFUN (\, SETTER) (OBJECT VALUE)
(replace ((\, SLOT-LOCATION)
(\, SLOT-NAME))
OBJECT VALUE))
(DEFSETF (\, ACCESSOR) (\, SETTER) )
)))))))))))
(push USERRECLST (BQUOTE ((\, (SELECTQ CLASS
(STRUCTURE-CLASS
(QUOTE DATATYPE))
(LIST-CLASS (if NAMED
then (QUOTE TYPERECORD)
else (QUOTE RECORD)))
(VECTOR (QUOTE ARRAYRECORD))
(CL:ERROR "Illegal type: ~S in DEFSTRUCT." CLASS)))
(\, NAME)
(\, SLOT-NAMES)
(\,@ INITIALIZATION))))
(BQUOTE
(PROGN
(\,@ SLOTFNS)
(\,@ (CASE CLASS (LIST-CLASS (* ; "do nothing, no predicate is defined")
NIL)
(STRUCTURE-CLASS (BQUOTE ((DEFUN (\, PREDICATE) (OBJECT)
(\INSTANCE-P OBJECT (QUOTE (\, NAME))))
)))
(OTHERWISE (BQUOTE ((DEFUN (\, PREDICATE) (OBJECT) (type? (\, NAME)
OBJECT))
)))))
(\,@ (AND COPIER (BQUOTE ((DEFUN (\, COPIER) (OBJECT) (create (\, NAME) using OBJECT))
))))
(\,@ (AND PRINT-FUNCTION
(BQUOTE ((DEFPRINT (QUOTE (\, NAME))
(\, (if (EQ PRINT-FUNCTION (QUOTE DEFAULT-STRUCTURE-PRINTER))
then (QUOTE (FUNCTION \DEFPRINT.DEFSTRUCT.DEFAULT))
else (BQUOTE (FUNCTION (LAMBDA (X STREAM)
(APPLY* (FUNCTION (\, PRINT-FUNCTION
))
X STREAM 0)
T))))))))))
(\,@
(for CONSTRUCTOR in CONSTRUCTORS
collect
(if (CDR CONSTRUCTOR)
then (DESTRUCTURING-BIND
(CONSTRUCTOR-NAME CONSTRUCTOR-ARGS)
CONSTRUCTOR
(BQUOTE (DEFUN (\, CONSTRUCTOR-NAME) (\, CONSTRUCTOR-ARGS)
(create (\, NAME)
(\,@ (for x in CONSTRUCTOR-ARGS
join (COND
((FMEMB x (QUOTE (&KEY &OPTIONAL &REST)))
NIL)
((LISTP x)
(LIST (CAR x)
(QUOTE ←)
(CAR x)))
(T (LIST x (QUOTE ←)
x)))))))
))
else (CONSTRUCTOR-DEFUN (SETQ SIMPLE-CONSTRUCTOR (CAR CONSTRUCTOR))
SLOT-DESCRIPTIONS NAME))
finally (OR SIMPLE-CONSTRUCTOR (push $$VAL (CONSTRUCTOR-DEFUN
(SETQ SIMPLE-CONSTRUCTOR
(if CONSTRUCTORS
then (XCL:PACK (LIST "%%internal-make-"
NAME)
(SYMBOL-PACKAGE NAME))
else (XCL:PACK* "MAKE-" NAME)))
SLOT-DESCRIPTIONS NAME)))))
(\,@ (CL:IF INCLUDES (BQUOTE ((SETF (INCLUDED-STRUCTURE (QUOTE (\, NAME)))
(QUOTE (\, INCLUDES)))))))
(PUTPROP (QUOTE (\, NAME))
(QUOTE STRUCTURE-CONSTRUCTOR)
(QUOTE (\, SIMPLE-CONSTRUCTOR)))
(PUTPROP (QUOTE (\, NAME))
(QUOTE %%STRUCTURE-CLASS)
(QUOTE (\, CLASS)))
(PUTPROP (QUOTE (\, NAME))
(QUOTE %%SLOT-DESCRIPTIONS)
(QUOTE (\, SLOT-DESCRIPTIONS)))
(PUTPROP (QUOTE (\, NAME))
(QUOTE %%LOCAL-SLOT-NAMES)
(QUOTE (\, LOCAL-SLOT-NAMES)))
(\,@ (APPLY* (QUOTE RECORDALLOCATIONS)
NAME))))))))
(PUTPROPS CMLSTRUCT FILETYPE COMPILE-FILE)
(DEFOPTIMIZER STRUCTURE-CONSTRUCTOR (STRUCTURE-NAME) (BQUOTE (GETPROP (\, STRUCTURE-NAME)
(QUOTE STRUCTURE-CONSTRUCTOR))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR SUBSTITUTE-SLOTS SLOT-LIST LOCAL-SLOT-LIST
DEFAULT-STRUCTURE-PRINTER)
)
(PUTPROPS CMLSTRUCT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1653 8577 (DEFAULT-STRUCTURE-PRINTER 1663 . 1846) (LOCAL-SLOT-LIST 1848 . 2016) (
\DEFPRINT.DEFSTRUCT.DEFAULT 2018 . 2847) (\CMLSTRUCT.CLTYPE.TO.ILTYPE 2849 . 6427) (SLOT-LIST 6429 .
6592) (SUBSTITUTE-SLOTS 6594 . 7209) (STRUCTURE-CONSTRUCTOR 7211 . 7398) (CREATE-STRUCTURE 7400 . 7761
) (CONSTRUCTOR-DEFUN 7763 . 8575)) (8901 9079 (INCLUDED-STRUCTURE 8911 . 9077)))))
STOP