(FILECREATED "25-Mar-86 12:11:18" {ERIS}<LISPCORE>CML>LAB>NEWDEFSTRUCT.;1 33571
changes to: (VARS NEWDEFSTRUCTCOMS)
(RECORDS DEFSTRUCT-SLOT-DESCRIPTION DEFSTRUCT-DESCRIPTION)
(PROPS (SYMBOL-FUNCTION SETFN)
(CDR SETFN)
(CAR SETFN))
(FNS SETF-CDR SETF-CAR DEFAULT-STRUCTURE-PRINT VECTOR-SUB-PREDICATE
LIST-SUB-PREDICATE STRUCTURE-PREDICATE DEFINE-PREDICATE DEFINE-COPIER
DEFINE-BOA-CONSTRUCTORS DEFINE-CONSTRUCTOR DEFINE-SETTERS DEFINE-ACCESSORS
CONCAT-STUFF CONCAT-PNAMES* CONCAT-PNAMES PARSE-SLOT-DESCRIPTIONS
PARSE-NAME-AND-OPTIONS PRINT-DEFSTRUCT-SLOT-DESCRIPTION DSD-NAME
MAKE-DEFSTRUCT-SLOT-DESCRIPTION COPY-DEFSTRUCT-SLOT-DESCRIPTION
DEFSTRUCT-SLOT-DESCRIPTION-P MAKE-DEFSTRUCT-DESCRIPTION
COPY-DEFSTRUCT-DESCRIPTION DEFSTRUCT-DESCRIPTION-P))
(PRETTYCOMPRINT NEWDEFSTRUCTCOMS)
(RPAQQ NEWDEFSTRUCTCOMS
((RECORDS DEFSTRUCT-DESCRIPTION DEFSTRUCT-SLOT-DESCRIPTION)
(PROP SETFN CAR CDR SYMBOL-FUNCTION)
(FNS CONCAT-STUFF COPY-DEFSTRUCT-DESCRIPTION COPY-DEFSTRUCT-SLOT-DESCRIPTION
DEFAULT-STRUCTURE-PRINT DEFSTRUCT-DESCRIPTION-P DEFSTRUCT-SLOT-DESCRIPTION-P DSD-NAME
DEFINE-ACCESSORS CONCAT-PNAMES CONCAT-PNAMES* DEFINE-BOA-CONSTRUCTORS DEFINE-CONSTRUCTOR
DEFINE-COPIER DEFINE-PREDICATE DEFINE-SETTERS LIST-SUB-PREDICATE
MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION PARSE-NAME-AND-OPTIONS
PARSE-SLOT-DESCRIPTIONS PRINT-DEFSTRUCT-SLOT-DESCRIPTION SETF-CAR SETF-CDR
STRUCTURE-PREDICATE VECTOR-SUB-PREDICATE)))
[DECLARE: EVAL@COMPILE
(DATATYPE DEFSTRUCT-DESCRIPTION ((LENGTH POINTER)
(OFFSET POINTER)
(NAMED POINTER)
(LISP-TYPE POINTER)
(TYPE POINTER)
(PRINT-FUNCTION POINTER)
(INCLUDES POINTER)
(INCLUDE POINTER)
(PREDICATE POINTER)
(COPIER POINTER)
(BOA-CONSTRUCTORS POINTER)
(CONSTRUCTOR POINTER)
(CONC-NAME POINTER)
(SLOTS POINTER)
(DOC POINTER)
(NAME POINTER)
(ORIGINAL-FORM POINTER))
INCLUDES ← NIL)
(DATATYPE DEFSTRUCT-SLOT-DESCRIPTION ((READ-ONLY POINTER)
(TYPE POINTER)
(DEFAULT POINTER)
(ACCESSOR POINTER)
(INDEX POINTER)
(%%NAME POINTER)))
]
(/DECLAREDATATYPE (QUOTE DEFSTRUCT-DESCRIPTION)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((DEFSTRUCT-DESCRIPTION 0 POINTER)
(DEFSTRUCT-DESCRIPTION 2 POINTER)
(DEFSTRUCT-DESCRIPTION 4 POINTER)
(DEFSTRUCT-DESCRIPTION 6 POINTER)
(DEFSTRUCT-DESCRIPTION 8 POINTER)
(DEFSTRUCT-DESCRIPTION 10 POINTER)
(DEFSTRUCT-DESCRIPTION 12 POINTER)
(DEFSTRUCT-DESCRIPTION 14 POINTER)
(DEFSTRUCT-DESCRIPTION 16 POINTER)
(DEFSTRUCT-DESCRIPTION 18 POINTER)
(DEFSTRUCT-DESCRIPTION 20 POINTER)
(DEFSTRUCT-DESCRIPTION 22 POINTER)
(DEFSTRUCT-DESCRIPTION 24 POINTER)
(DEFSTRUCT-DESCRIPTION 26 POINTER)
(DEFSTRUCT-DESCRIPTION 28 POINTER)
(DEFSTRUCT-DESCRIPTION 30 POINTER)
(DEFSTRUCT-DESCRIPTION 32 POINTER)))
(QUOTE 34))
(/DECLAREDATATYPE (QUOTE DEFSTRUCT-SLOT-DESCRIPTION)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((DEFSTRUCT-SLOT-DESCRIPTION 0 POINTER)
(DEFSTRUCT-SLOT-DESCRIPTION 2 POINTER)
(DEFSTRUCT-SLOT-DESCRIPTION 4 POINTER)
(DEFSTRUCT-SLOT-DESCRIPTION 6 POINTER)
(DEFSTRUCT-SLOT-DESCRIPTION 8 POINTER)
(DEFSTRUCT-SLOT-DESCRIPTION 10 POINTER)))
(QUOTE 12))
(PUTPROPS CAR SETFN SETF-CAR)
(PUTPROPS CDR SETFN SETF-CDR)
(PUTPROPS SYMBOL-FUNCTION SETFN PUTD)
(DEFINEQ
(CONCAT-STUFF
[CL:LAMBDA (THING1 THING2)
(LET ((*PRINT-CASE* :UPCASE))
(INTERN (CONCATENATE (QUOTE SIMPLE-STRING)
(PRINC-TO-STRING THING1)
(PRINC-TO-STRING THING2])
(COPY-DEFSTRUCT-DESCRIPTION
(CL:LAMBDA (obj)
(create DEFSTRUCT-DESCRIPTION using obj)))
(COPY-DEFSTRUCT-SLOT-DESCRIPTION
(CL:LAMBDA (obj)
(create DEFSTRUCT-SLOT-DESCRIPTION using obj)))
(DEFAULT-STRUCTURE-PRINT
(CL:LAMBDA (STRUCTURE STREAM DEPTH)
(CL:DECLARE (IGNORE DEPTH))
(WRITE-STRING "#S(" STREAM)
(PRIN1 (SVREF STRUCTURE 0)
STREAM)
(CL:DO ((INDEX 1 (1+ INDEX))
(CL:LENGTH (CL:LENGTH STRUCTURE))
(SLOTS (DD-SLOTS (GET (SVREF STRUCTURE 0)
(QUOTE %%STRUCTURE-DEFINITION)))
(CDR SLOTS)))
((OR (= INDEX CL:LENGTH)
(AND *PRINT-LENGTH* (= INDEX *PRINT-LENGTH*)))
(CL:IF (= INDEX CL:LENGTH)
(WRITE-STRING ")" STREAM)
(WRITE-STRING "...)" STREAM)))
(WRITE-CHAR |\SPACE STREAM)
(PRIN1 (DSD-NAME (CAR SLOTS))
STREAM)
(WRITE-CHAR |\SPACE STREAM)
(PRIN1 (SVREF STRUCTURE INDEX)
STREAM))))
(DEFSTRUCT-DESCRIPTION-P
(CL:LAMBDA (obj)
(type? DEFSTRUCT-DESCRIPTION obj)))
(DEFSTRUCT-SLOT-DESCRIPTION-P
(CL:LAMBDA (obj)
(type? DEFSTRUCT-SLOT-DESCRIPTION obj)))
(DSD-NAME
[CL:LAMBDA (DSD)
(INTERN (STRING (DSD-%%NAME DSD))
(SYMBOL-PACKAGE (DSD-ACCESSOR DSD])
(DEFINE-ACCESSORS
[CL:LAMBDA (DEFSTRUCT)
(CL:DO
((SLOTS (DD-SLOTS DEFSTRUCT)
(CDR SLOTS))
(STUFF (QUOTE NIL))
(TYPE (DD-LISP-TYPE DEFSTRUCT)))
((NULL SLOTS)
STUFF)
(LET* ((SLOT (CAR SLOTS))
(NAME (DSD-ACCESSOR SLOT))
(INDEX (DSD-INDEX SLOT)))
(CL:PUSH
[CL:IF (AND (EQ TYPE (QUOTE SIMPLE-VECTOR))
(< INDEX NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
[BQUOTE (PROGN [SETF (SYMBOL-FUNCTION (QUOTE (\, NAME)))
(SYMBOL-FUNCTION (QUOTE (\, (SVREF BUILT-IN-ACCESSORS INDEX]
(EVAL-WHEN (CL:COMPILE LOAD EVAL)
(SETF (GET (QUOTE (\, NAME))
(QUOTE COMPILER::CLC-TRANSFORMS))
(QUOTE ((\, (SVREF BUILT-IN-X-ACCESSORS INDEX]
(BQUOTE (PROGN (DEFUN (\, NAME)
(STRUCTURE)
(CL:ELT (THE (\, TYPE)
STRUCTURE)
(\, INDEX)))
(EVAL-WHEN (CL:COMPILE LOAD EVAL)
(COMPILER::DEFTRANSFORM
(\, NAME)
(\, (CONCAT-PNAMES* (QUOTE X-)
NAME))
(STRUCTURE)
(BQUOTE (CL:ELT (THE (\, (QUOTE (\, TYPE)))
(\, STRUCTURE))
(\, (QUOTE (\, INDEX]
STUFF])
(CONCAT-PNAMES
(CL:LAMBDA (NAME1 NAME2)
(CL:IF NAME1 (INTERN (CONCATENATE (QUOTE SIMPLE-STRING)
(SYMBOL-NAME NAME1)
(SYMBOL-NAME NAME2)))
NAME2)))
(CONCAT-PNAMES*
(CL:LAMBDA (NAME1 NAME2)
(CL:IF NAME1 (MAKE-SYMBOL (CONCATENATE (QUOTE SIMPLE-STRING)
(SYMBOL-NAME NAME1)
(SYMBOL-NAME NAME2)))
NAME2)))
(DEFINE-BOA-CONSTRUCTORS
[CL:LAMBDA (DEFSTRUCT)
(CL:DO*
((BOAS (DD-BOA-CONSTRUCTORS DEFSTRUCT)
(CDR BOAS))
(NAME (CAR (CAR BOAS))
(CAR (CAR BOAS)))
[ARGS (COPY-LIST (CADR (CAR BOAS)))
(COPY-LIST (CADR (CAR BOAS]
(SLOTS (DD-SLOTS DEFSTRUCT)
(DD-SLOTS DEFSTRUCT))
(SLOTS-IN-ARGLIST (QUOTE NIL)
(QUOTE NIL))
(DEFUNS (QUOTE NIL)))
((NULL BOAS)
DEFUNS)
[CL:DO ((ARGS ARGS (CDR ARGS))
(ARG-KIND (QUOTE REQUIRED)))
((NULL ARGS))
(LET ((ARG (CAR ARGS)))
(CL:IF (CL:ATOM ARG)
[CL:IF (MEMQ ARG (QUOTE (&OPTIONAL &REST &AUX)))
(CL:SETQ ARG-KIND ARG)
(CASE ARG-KIND ((REQUIRED &REST &AUX)
(CL:PUSH ARG SLOTS-IN-ARGLIST))
(&OPTIONAL (CL:PUSH ARG SLOTS-IN-ARGLIST)
(RPLACA ARGS (LIST ARG
(DSD-DEFAULT
(CL:FIND ARG SLOTS :KEY
(FUNCTION DSD-NAME]
(CL:PUSH (CAR ARG)
SLOTS-IN-ARGLIST]
(LET ((INITIAL-CRUFT (MAKE-LIST (DD-OFFSET DEFSTRUCT)))
(THING (CL:MAPCAR [FUNCTION (CL:LAMBDA (SLOT)
(CL:IF (MEMQ (DSD-NAME SLOT)
SLOTS-IN-ARGLIST)
(DSD-NAME SLOT)
(DSD-DEFAULT SLOT]
SLOTS)))
(CL:PUSH
[BQUOTE
(DEFUN
(\, NAME)
(\, ARGS)
(\,
(CL:IF
(EQ (DD-TYPE DEFSTRUCT)
(QUOTE LIST))
(BQUOTE (LIST [\,@(CL:IF (DD-NAMED DEFSTRUCT)
(BQUOTE ((QUOTE (\, (DD-NAME DEFSTRUCT]
(\,@ INITIAL-CRUFT)
(\,@ THING)))
(CL:IF (DD-NAMED DEFSTRUCT)
[BQUOTE (STRUCTURIFY (VECTOR (QUOTE (\, (DD-NAME DEFSTRUCT)))
(\,@ INITIAL-CRUFT)
(\,@ THING]
(CL:IF (EQ (DD-TYPE DEFSTRUCT)
(QUOTE VECTOR))
(BQUOTE (VECTOR (\,@ INITIAL-CRUFT)
(\,@ THING)))
(CL:DO ((THINGS THING (CDR THINGS))
(INDEX 0 (1+ INDEX))
(SETS (QUOTE NIL))
(TEMP (GENSYM)))
[(NULL THINGS)
(BQUOTE (LET [((\, TEMP)
(MAKE-ARRAY (\, (DD-LENGTH DEFSTRUCT))
:ELEMENT-TYPE
(QUOTE (\, (CADR (DD-LISP-TYPE DEFSTRUCT]
(\,@ SETS)
(\, TEMP]
(CL:PUSH [BQUOTE (SETF (AREF (\, TEMP)
INDEX)
(\, (CAR THINGS]
SETS]
DEFUNS])
(DEFINE-CONSTRUCTOR
[CL:LAMBDA (DEFSTRUCT)
(LET ((NAME (DD-CONSTRUCTOR DEFSTRUCT)))
(CL:WHEN
NAME
(LET* ((INITIAL-CRUFT (MAKE-LIST (DD-OFFSET DEFSTRUCT)))
(SLOTS (DD-SLOTS DEFSTRUCT))
(ARG-NAMES (CL:MAPCAR (FUNCTION DSD-NAME)
SLOTS))
(ARGS (CL:MAPCAR [FUNCTION (CL:LAMBDA (SLOT)
(BQUOTE ((\, (DSD-NAME SLOT))
(\, (DSD-DEFAULT SLOT]
SLOTS)))
(BQUOTE
((DEFUN
(\, NAME)
(&KEY (\,@ ARGS))
(\,
(CL:IF
(EQ (DD-TYPE DEFSTRUCT)
(QUOTE LIST))
(BQUOTE (LIST [\,@(CL:IF (DD-NAMED DEFSTRUCT)
(BQUOTE ((QUOTE (\, (DD-NAME DEFSTRUCT]
(\,@ INITIAL-CRUFT)
(\,@ ARG-NAMES)))
(CL:IF
(DD-NAMED DEFSTRUCT)
[BQUOTE (STRUCTURIFY (VECTOR (QUOTE (\, (DD-NAME DEFSTRUCT)))
(\,@ INITIAL-CRUFT)
(\,@ ARG-NAMES]
(CL:IF (EQ (DD-TYPE DEFSTRUCT)
(QUOTE VECTOR))
(BQUOTE (VECTOR (\,@ INITIAL-CRUFT)
(\,@ ARG-NAMES)))
(CL:DO ((SLUTS SLOTS (CDR SLUTS))
(SETS (QUOTE NIL))
(TEMP (GENSYM)))
[(NULL SLUTS)
(BQUOTE (LET [((\, TEMP)
(MAKE-ARRAY (\, (DD-LENGTH DEFSTRUCT))
:ELEMENT-TYPE
(QUOTE (\, (CADR (DD-LISP-TYPE DEFSTRUCT]
(\,@ SETS)
(\, TEMP]
(LET ((SLOT (CAR SLUTS)))
(CL:PUSH [BQUOTE (SETF (AREF (\, TEMP)
(\, (DSD-INDEX SLOT)))
(\, (DSD-NAME SLOT]
SETS])
(DEFINE-COPIER
[CL:LAMBDA (DEFSTRUCT)
(CL:IF (DD-COPIER DEFSTRUCT)
(COND
[(AND (EQ (DD-LISP-TYPE DEFSTRUCT)
(QUOTE SIMPLE-VECTOR))
(DD-NAMED DEFSTRUCT))
(BQUOTE ((SETF [SYMBOL-FUNCTION (QUOTE (\, (DD-COPIER DEFSTRUCT]
(SYMBOL-FUNCTION (QUOTE BUILT-IN-COPIER]
[(EQ (DD-LISP-TYPE DEFSTRUCT)
(QUOTE LIST))
(BQUOTE ((SETF [SYMBOL-FUNCTION (QUOTE (\, (DD-COPIER DEFSTRUCT]
(SYMBOL-FUNCTION (QUOTE COPY-LIST]
(T (BQUOTE ((DEFUN (\, (DD-COPIER DEFSTRUCT))
(STRUCTURE)
(COPY-SEQ (THE (\, (DD-LISP-TYPE DEFSTRUCT))
STRUCTURE])
(DEFINE-PREDICATE
[CL:LAMBDA (DEFSTRUCT)
(LET ((NAME (DD-NAME DEFSTRUCT))
(PRED (DD-PREDICATE DEFSTRUCT)))
(CL:WHEN (AND PRED (DD-NAMED DEFSTRUCT))
(BQUOTE ([PROCLAIM (QUOTE (INLINE (\, PRED]
(DEFUN (\, PRED)
(OBJECT)
(TYPEP OBJECT (QUOTE (\, NAME])
(DEFINE-SETTERS
[CL:LAMBDA (DEFSTRUCT)
(CL:DO
((SLOTS (DD-SLOTS DEFSTRUCT)
(CDR SLOTS))
(STUFF (QUOTE NIL))
(TYPE (DD-LISP-TYPE DEFSTRUCT)))
((NULL SLOTS)
STUFF)
(LET* ((SLOT (CAR SLOTS))
(NAME (CONCAT-PNAMES* (QUOTE SET-)
(DSD-ACCESSOR SLOT)))
(INDEX (DSD-INDEX SLOT)))
(CL:UNLESS
(DSD-READ-ONLY SLOT)
(CL:PUSH
[CL:IF
(AND (EQ TYPE (QUOTE SIMPLE-VECTOR))
(< INDEX NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
[BQUOTE (DEFSETF (\, (DSD-ACCESSOR SLOT))
(\, (SVREF BUILT-IN-SETTERS INDEX]
(BQUOTE (PROGN (DEFUN (\, NAME)
(STRUCTURE NEW-VALUE)
(SETF (CL:ELT (THE (\, TYPE)
STRUCTURE)
(\, INDEX))
NEW-VALUE))
[EVAL-WHEN (CL:COMPILE LOAD EVAL)
(COMPILER::DEFTRANSFORM
(\, NAME)
(\, (CONCAT-PNAMES* (QUOTE X-)
NAME))
(STRUCTURE NEW-VALUE)
(BQUOTE (SETF [CL:ELT (THE (\, (QUOTE (\, TYPE)))
(\, STRUCTURE))
(\, (QUOTE (\, INDEX]
(\, NEW-VALUE]
(DEFSETF (\, (DSD-ACCESSOR SLOT))
(\, NAME]
STUFF])
(LIST-SUB-PREDICATE
[CL:LAMBDA (OBJECT TYPE)
(LET ((OBJ-NAME (CAR OBJECT)))
(AND (SYMBOLP OBJ-NAME)
(LET [(DD (GET OBJ-NAME (QUOTE %%STRUCTURE-DEFINITION]
(AND DD (NOT (NULL (MEMQ TYPE (DD-INCLUDES DD])
(MAKE-DEFSTRUCT-DESCRIPTION
(CL:LAMBDA (&KEY NAME DOC SLOTS CONC-NAME CONSTRUCTOR BOA-CONSTRUCTORS COPIER PREDICATE INCLUDE
(INCLUDES NIL)
PRINT-FUNCTION TYPE LISP-TYPE NAMED OFFSET LENGTH ORIGINAL-FORM)
(* gbn
"13-Mar-86 16:16")
(create DEFSTRUCT-DESCRIPTION
LENGTH ← LENGTH
OFFSET ← OFFSET
NAMED ← NAMED
LISP-TYPE ← LISP-TYPE
TYPE ← TYPE
PRINT-FUNCTION ← PRINT-FUNCTION
INCLUDES ← INCLUDES
INCLUDE ← INCLUDE
PREDICATE ← PREDICATE
COPIER ← COPIER
BOA-CONSTRUCTORS ← BOA-CONSTRUCTORS
CONSTRUCTOR ← CONSTRUCTOR
CONC-NAME ← CONC-NAME
SLOTS ← SLOTS
DOC ← DOC
NAME ← NAME
ORIGINAL-FORM ← ORIGINAL-FORM)))
(MAKE-DEFSTRUCT-SLOT-DESCRIPTION
(CL:LAMBDA (&KEY %%NAME INDEX ACCESSOR DEFAULT TYPE READ-ONLY)
(create DEFSTRUCT-SLOT-DESCRIPTION
READ-ONLY ← READ-ONLY
TYPE ← TYPE
DEFAULT ← DEFAULT
ACCESSOR ← ACCESSOR
INDEX ← INDEX
%%NAME ← %%NAME)))
(PARSE-NAME-AND-OPTIONS
[CL:LAMBDA (NAME-AND-OPTIONS ORIGINAL-FORM) (* gbn
"13-Mar-86 16:13")
(CL:IF (CL:ATOM NAME-AND-OPTIONS)
(CL:SETQ NAME-AND-OPTIONS (LIST NAME-AND-OPTIONS)))
(CL:DO* ((OPTIONS (CDR NAME-AND-OPTIONS)
(CDR OPTIONS))
(NAME (CAR NAME-AND-OPTIONS))
(PRINT-FUNCTION (QUOTE DEFAULT-STRUCTURE-PRINT))
(CONC-NAME (CONCAT-PNAMES NAME (QUOTE -)))
(CONSTRUCTOR (CONCAT-PNAMES (QUOTE MAKE-)
NAME))
(SAW-CONSTRUCTOR)
(BOA-CONSTRUCTORS (QUOTE NIL))
(COPIER (CONCAT-PNAMES (QUOTE COPY-)
NAME))
(PREDICATE (CONCAT-PNAMES NAME (QUOTE -P)))
(INCLUDE)
(SAW-TYPE)
(TYPE (QUOTE VECTOR))
(SAW-NAMED)
(OFFSET 0))
((NULL OPTIONS)
(MAKE-DEFSTRUCT-DESCRIPTION :NAME NAME :ORIGINAL-FORM ORIGINAL-FORM :CONC-NAME CONC-NAME
:CONSTRUCTOR CONSTRUCTOR :BOA-CONSTRUCTORS BOA-CONSTRUCTORS :COPIER COPIER
:PREDICATE PREDICATE :INCLUDE INCLUDE :PRINT-FUNCTION PRINT-FUNCTION :TYPE TYPE
:LISP-TYPE (COND
((EQ TYPE (QUOTE VECTOR))
(QUOTE SIMPLE-VECTOR))
((EQ TYPE (QUOTE LIST))
(QUOTE LIST))
((AND (CL:LISTP TYPE)
(EQ (CAR TYPE)
(QUOTE VECTOR)))
(CONS (QUOTE SIMPLE-ARRAY)
(CDR TYPE)))
(T (CL:ERROR "~S is a bad :TYPE for Defstruct." TYPE)))
:NAMED
(CL:IF SAW-TYPE SAW-NAMED T)
:OFFSET OFFSET))
(CL:IF (CL:ATOM (CAR OPTIONS))
[CASE (CAR OPTIONS)
(:CONSTRUCTOR (CL:SETQ SAW-CONSTRUCTOR T CONSTRUCTOR (CONCAT-PNAMES
(QUOTE MAKE-)
NAME)))
(:COPIER)
(:PREDICATE)
(:NAMED (CL:SETQ SAW-NAMED T))
(T (CL:ERROR "The Defstruct option ~S cannot be used with 0 arguments."
(CAR OPTIONS]
(LET ((OPTION (CAAR OPTIONS))
(ARGS (CDAR OPTIONS)))
(CASE OPTION (:CONC-NAME (CL:SETQ CONC-NAME (CAR ARGS)))
[:CONSTRUCTOR (COND
((CDR ARGS)
(CL:UNLESS SAW-CONSTRUCTOR (CL:SETQ CONSTRUCTOR NIL))
(CL:PUSH ARGS BOA-CONSTRUCTORS))
(T (CL:SETQ CONSTRUCTOR (CAR ARGS]
(:COPIER (CL:SETQ COPIER (CAR ARGS)))
(:PREDICATE (CL:SETQ PREDICATE (CAR ARGS)))
(:INCLUDE (CL:SETQ INCLUDE ARGS))
(:PRINT-FUNCTION (CL:SETQ PRINT-FUNCTION (CAR ARGS)))
(:TYPE (CL:SETQ SAW-TYPE T TYPE (CAR ARGS)))
(:NAMED (CL:ERROR "The Defstruct option :NAMED takes no arguments."))
(:INITIAL-OFFSET (CL:SETQ OFFSET (CAR ARGS)))
(T (CL:ERROR "~S is an unknown Defstruct option." OPTION])
(PARSE-SLOT-DESCRIPTIONS
[CL:LAMBDA (DEFSTRUCT SLOTS)
(CL:WHEN (STRINGP (CAR SLOTS))
(SETF (DD-DOC DEFSTRUCT)
(CAR SLOTS))
(CL:SETQ SLOTS (CDR SLOTS)))
[CL:WHEN (DD-INCLUDE DEFSTRUCT)
(LET* [(INCLUDED-NAME (CAR (DD-INCLUDE DEFSTRUCT)))
[INCLUDED-THING (OR (GET INCLUDED-NAME (QUOTE %%STRUCTURE-DEFINITION-IN-COMPILER))
(GET INCLUDED-NAME (QUOTE %%STRUCTURE-DEFINITION]
(MODIFIED-SLOTS (CDR (DD-INCLUDE DEFSTRUCT]
(CL:UNLESS INCLUDED-THING (CL:ERROR
"Cannot find description of structure ~S to use for inclusion."
INCLUDED-NAME))
(SETF (DD-INCLUDES DEFSTRUCT)
(CONS (DD-NAME INCLUDED-THING)
(DD-INCLUDES INCLUDED-THING)))
(SETF (DD-OFFSET DEFSTRUCT)
(DD-OFFSET INCLUDED-THING))
(CL:DO* ((ISLOTS (CL:MAPCAR [FUNCTION (CL:LAMBDA (SLOT)
(BQUOTE ((\, (DSD-NAME SLOT))
(\, (DSD-DEFAULT SLOT))
:TYPE
(\, (DSD-TYPE SLOT))
:READ-ONLY
(\, (DSD-READ-ONLY SLOT]
(DD-SLOTS INCLUDED-THING)))
(ISLOTS* ISLOTS (CDR ISLOTS*)))
((NULL ISLOTS*)
(CL:SETQ SLOTS (NCONC ISLOTS SLOTS)))
(LET* [(ISLOT (CAR ISLOTS*))
(MODIFIEE (CL:FIND (CAR ISLOT)
MODIFIED-SLOTS :KEY [FUNCTION (CL:LAMBDA (X)
(CL:IF (CL:ATOM
X)
X
(CAR X]
:TEST
(FUNCTION STRING=]
(CL:WHEN MODIFIEE
(COND
((SYMBOLP MODIFIEE)
(SETF (CADR ISLOT)
NIL))
((CL:LISTP MODIFIEE)
(SETF (CADR ISLOT)
(CADR MODIFIEE))
(CL:WHEN (CDDR MODIFIEE)
(CL:DO ((OPTIONS (CDDR MODIFIEE)
(CDDR OPTIONS)))
((NULL OPTIONS))
(CASE (CAR OPTIONS)
(:TYPE (SETF (CADDDR ISLOT)
(CADR OPTIONS)))
(:READ-ONLY (SETF (CADR (CDDDDR ISLOT))
(CADR OPTIONS)))
(T (CL:ERROR
"Bad option in included slot spec: ~S."
(CAR OPTIONS]
(CL:DO ((SLOTS SLOTS (CDR SLOTS))
(INDEX (+ (DD-OFFSET DEFSTRUCT)
(CL:IF (DD-NAMED DEFSTRUCT)
1 0))
(1+ INDEX))
(DESCRIPTIONS (QUOTE NIL)))
((NULL SLOTS)
(SETF (DD-LENGTH DEFSTRUCT)
INDEX)
(SETF (DD-SLOTS DEFSTRUCT)
(CL:NREVERSE DESCRIPTIONS)))
(LET ((SLOT (CAR SLOTS)))
(CL:PUSH [CL:IF (CL:ATOM SLOT)
(LET ((NAME SLOT))
(MAKE-DEFSTRUCT-SLOT-DESCRIPTION :%%NAME (STRING NAME)
:INDEX INDEX :ACCESSOR (CONCAT-PNAMES (DD-CONC-NAME
DEFSTRUCT)
NAME)
:TYPE T))
(CL:DO ((OPTIONS (CDDR SLOT)
(CDDR OPTIONS))
(NAME (CAR SLOT))
(DEFAULT (CADR SLOT))
(TYPE T)
(READ-ONLY NIL))
((NULL OPTIONS)
(MAKE-DEFSTRUCT-SLOT-DESCRIPTION :%%NAME (STRING NAME)
:INDEX INDEX :ACCESSOR (CONCAT-PNAMES (DD-CONC-NAME
DEFSTRUCT)
NAME)
:DEFAULT DEFAULT :TYPE TYPE :READ-ONLY READ-ONLY))
(CASE (CAR OPTIONS)
(:TYPE (CL:SETQ TYPE (CADR OPTIONS)))
(:READ-ONLY (CL:SETQ READ-ONLY (CADR OPTIONS]
DESCRIPTIONS])
(PRINT-DEFSTRUCT-SLOT-DESCRIPTION
(CL:LAMBDA (STRUCTURE STREAM DEPTH)
(CL:DECLARE (IGNORE DEPTH))
(FORMAT STREAM "#<Defstruct-Slot-Description for ~S>" (DSD-NAME STRUCTURE))))
(SETF-CAR
[LAMBDA (X Y) (* gbn
"13-Mar-86 15:55")
(RPLACA X Y)
Y])
(SETF-CDR
[LAMBDA (X Y) (* gbn
"13-Mar-86 15:55")
(RPLACD X Y)
Y])
(STRUCTURE-PREDICATE
[CL:LAMBDA (OBJECT TYPE)
(LET [(DEF (OR (GET TYPE (QUOTE %%STRUCTURE-DEFINITION-IN-COMPILER))
(GET TYPE (QUOTE %%STRUCTURE-DEFINITION]
(CL:IF DEF [CL:IF (EQ (DD-TYPE DEF)
(QUOTE LIST))
[BQUOTE (AND (CL:LISTP (\, OBJECT))
(OR (EQ (CAR (\, OBJECT))
(QUOTE (\, TYPE)))
(LIST-SUB-PREDICATE (\, OBJECT)
(QUOTE (\, TYPE]
(BQUOTE (AND (SIMPLE-VECTOR-P (\, OBJECT))
(TEST-STRUCTURE (\, OBJECT))
(OR (EQ (SVREF (\, OBJECT)
0)
(QUOTE (\, TYPE)))
(VECTOR-SUB-PREDICATE (\, OBJECT)
(QUOTE (\, TYPE]
(BQUOTE (STRUCTURE-TYPEP (\, OBJECT)
(QUOTE (\, TYPE])
(VECTOR-SUB-PREDICATE
[CL:LAMBDA (OBJECT TYPE)
(NOT (NULL (MEMQ TYPE (DD-INCLUDES (GET (SVREF OBJECT 0)
(QUOTE %%STRUCTURE-DEFINITION])
)
(PRETTYCOMPRINT NEWDEFSTRUCTCOMS)
(RPAQQ NEWDEFSTRUCTCOMS
[(RECORDS DEFSTRUCT-DESCRIPTION DEFSTRUCT-SLOT-DESCRIPTION)
(PROP SETFN CAR CDR SYMBOL-FUNCTION)
(FNS CONCAT-STUFF COPY-DEFSTRUCT-DESCRIPTION COPY-DEFSTRUCT-SLOT-DESCRIPTION
DEFAULT-STRUCTURE-PRINT DEFSTRUCT-DESCRIPTION-P DEFSTRUCT-SLOT-DESCRIPTION-P DSD-NAME
DEFINE-ACCESSORS CONCAT-PNAMES CONCAT-PNAMES* DEFINE-BOA-CONSTRUCTORS DEFINE-CONSTRUCTOR
DEFINE-COPIER DEFINE-PREDICATE DEFINE-SETTERS LIST-SUB-PREDICATE
MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION PARSE-NAME-AND-OPTIONS
PARSE-SLOT-DESCRIPTIONS PRINT-DEFSTRUCT-SLOT-DESCRIPTION SETF-CAR SETF-CDR
STRUCTURE-PREDICATE VECTOR-SUB-PREDICATE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
MAKE-DEFSTRUCT-SLOT-DESCRIPTION
MAKE-DEFSTRUCT-DESCRIPTION
])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MAKE-DEFSTRUCT-SLOT-DESCRIPTION MAKE-DEFSTRUCT-DESCRIPTION)
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (4805 32032 (CONCAT-STUFF 4815 . 5046) (COPY-DEFSTRUCT-DESCRIPTION 5048 . 5153) (
COPY-DEFSTRUCT-SLOT-DESCRIPTION 5155 . 5270) (DEFAULT-STRUCTURE-PRINT 5272 . 6138) (
DEFSTRUCT-DESCRIPTION-P 6140 . 6231) (DEFSTRUCT-SLOT-DESCRIPTION-P 6233 . 6334) (DSD-NAME 6336 . 6453)
(DEFINE-ACCESSORS 6455 . 8350) (CONCAT-PNAMES 8352 . 8583) (CONCAT-PNAMES* 8585 . 8832) (
DEFINE-BOA-CONSTRUCTORS 8834 . 12632) (DEFINE-CONSTRUCTOR 12634 . 15313) (DEFINE-COPIER 15315 . 16162)
(DEFINE-PREDICATE 16164 . 16547) (DEFINE-SETTERS 16549 . 18407) (LIST-SUB-PREDICATE 18409 . 18663) (
MAKE-DEFSTRUCT-DESCRIPTION 18665 . 19663) (MAKE-DEFSTRUCT-SLOT-DESCRIPTION 19665 . 19980) (
PARSE-NAME-AND-OPTIONS 19982 . 23857) (PARSE-SLOT-DESCRIPTIONS 23859 . 29991) (
PRINT-DEFSTRUCT-SLOT-DESCRIPTION 29993 . 30186) (SETF-CAR 30188 . 30411) (SETF-CDR 30413 . 30636) (
STRUCTURE-PREDICATE 30638 . 31839) (VECTOR-SUB-PREDICATE 31841 . 32030)))))
STOP