(FILECREATED "29-May-86 00:14:18" {ERIS}<LISPCORE>EVAL>CMLSTRUCT.;4 20494
changes to: (FUNCTIONS DEFSTRUCT)
previous date: "28-May-86 17:14:01" {ERIS}<LISPCORE>EVAL>CMLSTRUCT.;2)
(* 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 \DEFPRINT.DEFSTRUCT.DEFAULT
\CMLSTRUCT.CLTYPE.TO.ILTYPE SLOT-LIST SUBSTITUTE-SLOTS
STRUCTURE-CONSTRUCTOR CREATE-STRUCTURE CONSTRUCTOR-DEFUN)
(DEFINE-TYPES STRUCTURES)
(FUNCTIONS DEFSTRUCT)
(PROP FILETYPE CMLSTRUCT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR SUBSTITUTE-SLOTS
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)))
(\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) (* amd "19-May-86 12:27")
(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))))))
(\, (MACROEXPAND-1 (BQUOTE (create (\, NAME)
(\,@ (for x in SLOT-DESCRIPTIONS
join (LIST (SLOT-NAME x)
(QUOTE ←)
(SLOT-NAME x)))))))))
])
)
(DEF-DEFINE-TYPE STRUCTURES "Common Lisp structures" )
(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
(SLOTFNS)
(SLOT-NAMES)
(INITIALIZATION)
(INCLUDES)
(CONC-NAME (CONCAT NAME "-"))
(CONSTRUCTORS)
(PREDICATE (PACK* NAME "-P"))
(PRINT-FUNCTION (FUNCTION DEFAULT-STRUCTURE-PRINTER))
(COPIER (PACK* "COPY-" NAME))
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))))))
(if INCLUDES then (if (EQ CLASS (QUOTE LIST-CLASS))
then
(DESTRUCTURING-BIND (INCL-NAME &REST INCL-SLOT-DESCS)
INCLUDES
(SETQ SLOT-DESCRIPTIONS (CONCATENATE (QUOTE LIST)
(SUBSTITUTE-SLOTS
INCL-SLOT-DESCS
(SLOT-LIST INCL-NAME))
SLOT-DESCRIPTIONS)))
else
(CL:ERROR ":INCLUDE is only implemented for :TYPE LIST.")))
(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)
(RESETVARS ((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))))))
(for
SLOT-DESC in SLOT-DESCRIPTIONS do
(DESTRUCTURING-BIND
(SLOT-NAME SLOT-INIT &KEY READ-ONLY &ALLOW-OTHER-KEYS)
(MKLIST SLOT-DESC)
(LET ((ACCESSOR (PACK* CONC-NAME SLOT-NAME)))
(pushlist
SLOTFNS
(BQUOTE
((DEFUN (\, ACCESSOR) (OBJECT)
(\, (MACROEXPAND-1 (BQUOTE (fetch ((\, NAME)
(\, SLOT-NAME))
of OBJECT)))))
(\,@
(CL:UNLESS
READ-ONLY
(LET ((SETTER (PACK* "setf-" ACCESSOR)))
(BQUOTE ((DEFUN (\, SETTER) (OBJECT VALUE)
(\, (MACROEXPAND-1 (BQUOTE (REPLACE
((\, NAME)
(\, SLOT-NAME))
OBJECT VALUE)))))
(DEFSETF (\, ACCESSOR) (\, SETTER) )
)))))))))))
(RETURN
(BQUOTE
(PROGN
(\,@ SLOTFNS)
(\,@ (AND PREDICATE (NEQ CLASS (QUOTE LIST-CLASS))
(BQUOTE ((DEFUN (\, PREDICATE) (OBJECT)
(\, (MACROEXPAND-1 (BQUOTE (type? (\, NAME)
OBJECT)))))
))))
(\,@ (AND COPIER (BQUOTE ((DEFUN (\, COPIER) (OBJECT)
(\, (MACROEXPAND-1 (BQUOTE
(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)
(\,
(MACROEXPAND-1
(BQUOTE
(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 (PACK*
"%%internal-make-"
NAME)
else
(PACK* "MAKE-" NAME)))
SLOT-DESCRIPTIONS NAME)))))
(PUTPROP (QUOTE (\, NAME))
(QUOTE STRUCTURE-CONSTRUCTOR)
(QUOTE (\, SIMPLE-CONSTRUCTOR)))
(PUTPROP (QUOTE (\, NAME))
(QUOTE %%SLOT-DESCRIPTIONS)
(QUOTE (\, SLOT-DESCRIPTIONS)))
(\,@ (APPLY* (QUOTE RECORDALLOCATIONS)
NAME)))))))))
(PUTPROPS CMLSTRUCT FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR SUBSTITUTE-SLOTS SLOT-LIST
DEFAULT-STRUCTURE-PRINTER)
)
(PUTPROPS CMLSTRUCT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1447 8294 (DEFAULT-STRUCTURE-PRINTER 1457 . 1635) (\DEFPRINT.DEFSTRUCT.DEFAULT 1637 .
2466) (\CMLSTRUCT.CLTYPE.TO.ILTYPE 2468 . 6046) (SLOT-LIST 6048 . 6206) (SUBSTITUTE-SLOTS 6208 . 6796)
(STRUCTURE-CONSTRUCTOR 6798 . 6980) (CREATE-STRUCTURE 6982 . 7355) (CONSTRUCTOR-DEFUN 7357 . 8292))))
)
STOP