(FILECREATED " 1-Sep-85 23:36:57" {ERIS}<LISPCORE>LIBRARY>CMLDEFSTRUCT.;8 44158
changes to: (MACROS MAKE-BUILT-IN-SLOT-FROBBERS DEFSTRUCT STRUCTURIFY TEST-STRUCTURE)
(VARS CMLDEFSTRUCTCOMS)
(FNS \GET-0 \GET-1 \GET-2 \GET-3 \GET-4 \GET-5 \GET-6 \GET-7 \GET-8 \GET-9 \GET-10
\GET-11 \GET-12 \GET-13 \GET-14 \GET-15 \GET-16 \GET-17 \GET-18 \GET-19
\SET-0 \SET-1 \SET-2 \SET-3 \SET-4 \SET-5 \SET-6 \SET-7 \SET-8 \SET-9 \SET-10
\SET-11 \SET-12 \SET-13 \SET-14 \SET-15 \SET-16 \SET-17 \SET-18 \SET-19
DEFINE-ACCESSORS DEFINE-SETTERS DEFSTRUCT.EXPANDER DD-LENGTH SETF-DD-LENGTH
PARSE-NAME-AND-OPTIONS SETF-DD-NAME SETF-DD-DOC SETF-DD-SLOTS
SETF-DD-CONC-NAME SETF-DD-CONSTRUCTOR SETF-DD-BOA-CONSTRUCTORS SETF-DD-COPIER
SETF-DD-PREDICATE SETF-DD-INCLUDE SETF-DD-INCLUDED-BY SETF-DD-PRINT-FUNCTION
SETF-DD-TYPE SETF-DD-LISP-TYPE SETF-DD-NAMED SETF-DD-OFFSET SETF-DD-CL:LENGTH
SETF-DSD-NAME SETF-DSD-INDEX SETF-DSD-ACCESSOR SETF-DSD-DEFAULT SETF-DSD-TYPE
SETF-DSD-READ-ONLY PARSE-SLOT-DESCRIPTIONS CONCAT-PNAMES
DEFINE-BOA-CONSTRUCTORS DEFAULT-STRUCTURE-PRINT DEFINE-CONSTRUCTOR DSD-NAME
DSD-INDEX DSD-ACCESSOR DSD-DEFAULT DSD-TYPE DSD-READ-ONLY DD-NAME DD-DOC
DD-SLOTS DD-CONC-NAME DD-CONSTRUCTOR DD-BOA-CONSTRUCTORS DD-COPIER
DD-PREDICATE DD-INCLUDE DD-INCLUDED-BY DD-PRINT-FUNCTION DD-TYPE DD-LISP-TYPE
DD-NAMED DD-OFFSET DD-CL:LENGTH PRINT-DEFSTRUCT-DESCRIPTION
PRINT-DEFSTRUCT-SLOT-DESCRIPTION CONCAT-PNAMES* CONCAT-STUFF
COMPILER::NOTE-ARGS BUILT-IN-COPIER DEFINE-COPIER DEFINE-PREDICATE)
(PROPS (DEFSTRUCT USERRECORDTYPE))
(RECORDS DEFSTRUCT-DESCRIPTION DEFSTRUCT-SLOT-DESCRIPTION)
previous date: " 1-Sep-85 22:36:53" {ERIS}<LISPCORE>LIBRARY>CMLDEFSTRUCT.;7)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLDEFSTRUCTCOMS)
(RPAQQ CMLDEFSTRUCTCOMS ((* * Chapter 19.0 DEFSTRUCT. *)
(MACROS STRUCTURIFY TEST-STRUCTURE MAKE-BUILT-IN-SLOT-FROBBERS)
(CONSTANTS (NUMBER-OF-BUILT-IN-SLOT-FROBBERS 20))
(FNS \GET-0 \GET-1 \GET-2 \GET-3 \GET-4 \GET-5 \GET-6 \GET-7 \GET-8 \GET-9 \GET-10 \GET-11
\GET-12 \GET-13 \GET-14 \GET-15 \GET-16 \GET-17 \GET-18 \GET-19)
(FNS \SET-0 \SET-1 \SET-2 \SET-3 \SET-4 \SET-5 \SET-6 \SET-7 \SET-8 \SET-9 \SET-10 \SET-11
\SET-12 \SET-13 \SET-14 \SET-15 \SET-16 \SET-17 \SET-18 \SET-19)
(INITVARS (BUILT-IN-ACCESSORS (MAKE-ARRAY NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
(BUILT-IN-SETTERS (MAKE-ARRAY NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
(BUILT-IN-X-ACCESSORS (MAKE-ARRAY NUMBER-OF-BUILT-IN-SLOT-FROBBERS)))
(RECORDS DEFSTRUCT-DESCRIPTION)
(FNS DD-NAME DD-DOC DD-SLOTS DD-CONC-NAME DD-CONSTRUCTOR DD-BOA-CONSTRUCTORS DD-COPIER
DD-PREDICATE DD-INCLUDE DD-INCLUDED-BY DD-PRINT-FUNCTION DD-TYPE DD-LISP-TYPE DD-NAMED
DD-OFFSET DD-LENGTH)
(FNS SETF-DD-NAME SETF-DD-DOC SETF-DD-SLOTS SETF-DD-CONC-NAME SETF-DD-CONSTRUCTOR
SETF-DD-BOA-CONSTRUCTORS SETF-DD-COPIER SETF-DD-PREDICATE SETF-DD-INCLUDE
SETF-DD-INCLUDED-BY SETF-DD-PRINT-FUNCTION SETF-DD-TYPE SETF-DD-LISP-TYPE SETF-DD-NAMED
SETF-DD-OFFSET SETF-DD-LENGTH)
(RECORDS DEFSTRUCT-SLOT-DESCRIPTION)
(FNS DSD-NAME DSD-INDEX DSD-ACCESSOR DSD-DEFAULT DSD-TYPE DSD-READ-ONLY)
(FNS SETF-DSD-NAME SETF-DSD-INDEX SETF-DSD-ACCESSOR SETF-DSD-DEFAULT SETF-DSD-TYPE
SETF-DSD-READ-ONLY)
(FNS DEFSTRUCT.EXPANDER PRINT-DEFSTRUCT-DESCRIPTION PRINT-DEFSTRUCT-SLOT-DESCRIPTION
PARSE-NAME-AND-OPTIONS PARSE-SLOT-DESCRIPTIONS CONCAT-PNAMES CONCAT-PNAMES* CONCAT-STUFF
COMPILER::NOTE-ARGS BUILT-IN-COPIER DEFINE-ACCESSORS DEFINE-SETTERS DEFINE-CONSTRUCTOR
DEFINE-BOA-CONSTRUCTORS DEFINE-COPIER DEFINE-PREDICATE DEFAULT-STRUCTURE-PRINT)
(MACROS DEFSTRUCT)
(PROPS (DEFSTRUCT USERRECORDTYPE))
(P (MOVD (QUOTE RECORD)
(QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT)
(* (MAKE-BUILT-IN-SLOT-FROBBERS)))))
(* * Chapter 19.0 DEFSTRUCT. *)
(DECLARE: EVAL@COMPILE
(DEFMACRO STRUCTURIFY (STRUCTURE)
"Frobs a vector to turn it into a named structure. Returns the vector."
(BQUOTE (\PRIMITIVE SET-VECTOR-SUBTYPE (\, STRUCTURE)
1)))
(DEFMACRO TEST-STRUCTURE (OBJECT)
"Returns T if the given object is a named structure, Nil otherwise."
(BQUOTE (= (\PRIMITIVE GET-VECTOR-SUBTYPE (\, OBJECT))
1)))
(DEFMACRO MAKE-BUILT-IN-SLOT-FROBBERS NIL
(CL:DO ((I 0 (1+ I))
(THEM NIL))
((= I NUMBER-OF-BUILT-IN-SLOT-FROBBERS)
(BQUOTE (PROGN (\,@ THEM))))
(LET ((ACCESSOR (CONCAT-STUFF (QUOTE \GET-)
I))
(X-ACCESSOR (CONCAT-STUFF (QUOTE \X-GET-)
I))
(SETTER (CONCAT-STUFF (QUOTE \SET-)
I))
(X-SETTER (CONCAT-STUFF (QUOTE \X-SET-)
I)))
(CL:PUSH (BQUOTE (PROGN (DEFUN (\, ACCESSOR)
(X)
(SVREF X (\, I)))
(SETF (SVREF BUILT-IN-ACCESSORS (\, I))
(QUOTE (\, ACCESSOR)))
(COMPILER::DEFTRANSFORM
(\, ACCESSOR)
(\, X-ACCESSOR)
(X)
(BQUOTE (SVREF (\, X)
(\, (QUOTE (\, I))))))
(SETF (SVREF BUILT-IN-X-ACCESSORS (\, I))
(QUOTE (\, X-ACCESSOR)))
(DEFUN (\, SETTER)
(X Y)
(SETF (SVREF X (\, I))
Y))
(SETF (SVREF BUILT-IN-SETTERS (\, I))
(QUOTE (\, SETTER)))
(COMPILER::DEFTRANSFORM
(\, SETTER)
(\, X-SETTER)
(X Y)
(BQUOTE (SETF (SVREF (\, X)
(\, (QUOTE (\, I))))
(\, Y))))))
THEM))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ NUMBER-OF-BUILT-IN-SLOT-FROBBERS 20)
(CONSTANTS (NUMBER-OF-BUILT-IN-SLOT-FROBBERS 20))
)
(DEFINEQ
(\GET-0
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 0)))
(\GET-1
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 1)))
(\GET-2
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 2)))
(\GET-3
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 3)))
(\GET-4
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 4)))
(\GET-5
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 5)))
(\GET-6
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 6)))
(\GET-7
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 7)))
(\GET-8
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 8)))
(\GET-9
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 9)))
(\GET-10
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 10)))
(\GET-11
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 11)))
(\GET-12
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 12)))
(\GET-13
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 13)))
(\GET-14
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 14)))
(\GET-15
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 15)))
(\GET-16
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 16)))
(\GET-17
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 17)))
(\GET-18
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 18)))
(\GET-19
(LAMBDA (X) (* kbr: " 1-Sep-85 23:24")
(\GETBASEPTR X 19)))
)
(DEFINEQ
(\SET-0
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 0 Y)))
(\SET-1
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 1 Y)))
(\SET-2
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 2 Y)))
(\SET-3
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 3 Y)))
(\SET-4
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 4 Y)))
(\SET-5
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 5 Y)))
(\SET-6
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 6 Y)))
(\SET-7
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 7 Y)))
(\SET-8
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 8 Y)))
(\SET-9
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 9 Y)))
(\SET-10
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 10 Y)))
(\SET-11
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 11 Y)))
(\SET-12
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 12 Y)))
(\SET-13
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 13 Y)))
(\SET-14
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 14 Y)))
(\SET-15
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 15 Y)))
(\SET-16
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 16 Y)))
(\SET-17
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 17 Y)))
(\SET-18
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 18 Y)))
(\SET-19
(LAMBDA (X Y) (* kbr: " 1-Sep-85 23:24")
(\PUTBASEPTR X 19 Y)))
)
(RPAQ? BUILT-IN-ACCESSORS (MAKE-ARRAY NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
(RPAQ? BUILT-IN-SETTERS (MAKE-ARRAY NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
(RPAQ? BUILT-IN-X-ACCESSORS (MAKE-ARRAY NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
[DECLARE: EVAL@COMPILE
(DEFSTRUCT (DEFSTRUCT-DESCRIPTION (:CONC-NAME DD-)
(:PRINT-FUNCTION PRINT-DEFSTRUCT-DESCRIPTION))
NAME (* " name of the structure" *)
DOC (* " documentation on the structure" *)
SLOTS (* " list of slots" *)
CONC-NAME (* " prefix for slot names" *)
CONSTRUCTOR (* " name of standard constructor function" *)
BOA-CONSTRUCTORS (* " name of by-position constructors" *)
COPIER (* " name of copying function" *)
PREDICATE (* " name of type predictate
" *)
INCLUDE (* " name of included structure" *)
INCLUDED-BY (* " names of structures including this one" *)
PRINT-FUNCTION (* " function used to print it" *)
TYPE (* " type specified" *)
LISP-TYPE (* " actual type used for implementation" *)
NAMED (* " T if named, Nil otherwise" *)
OFFSET (* " first slot's offset into implementation sequence"
*)
CL:LENGTH)
]
(/DECLAREDATATYPE (QUOTE DEFSTRUCT-DESCRIPTION)
(QUOTE (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)))
(QUOTE 32))
(DEFINEQ
(DD-NAME
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:47")
(fetch (DEFSTRUCT-DESCRIPTION NAME) of OBJECT)))
(DD-DOC
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:47")
(fetch (DEFSTRUCT-DESCRIPTION DOC) of OBJECT)))
(DD-SLOTS
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:48")
(fetch (DEFSTRUCT-DESCRIPTION SLOTS) of OBJECT)))
(DD-CONC-NAME
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:48")
(fetch (DEFSTRUCT-DESCRIPTION CONC-NAME) of OBJECT)))
(DD-CONSTRUCTOR
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:48")
(fetch (DEFSTRUCT-DESCRIPTION CONSTRUCTOR) of OBJECT)))
(DD-BOA-CONSTRUCTORS
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:48")
(fetch (DEFSTRUCT-DESCRIPTION BOA-CONSTRUCTORS) of OBJECT)))
(DD-COPIER
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:49")
(fetch (DEFSTRUCT-DESCRIPTION COPIER) of OBJECT)))
(DD-PREDICATE
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:49")
(fetch (DEFSTRUCT-DESCRIPTION PREDICATE) of OBJECT)))
(DD-INCLUDE
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:46")
(fetch (DEFSTRUCT-DESCRIPTION INCLUDE) of OBJECT)))
(DD-INCLUDED-BY
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:49")
(fetch (DEFSTRUCT-DESCRIPTION INCLUDED-BY) of OBJECT)))
(DD-PRINT-FUNCTION
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:50")
(fetch (DEFSTRUCT-DESCRIPTION PRINT-FUNCTION) of OBJECT)))
(DD-TYPE
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:50")
(fetch (DEFSTRUCT-DESCRIPTION TYPE) of OBJECT)))
(DD-LISP-TYPE
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:50")
(fetch (DEFSTRUCT-DESCRIPTION LISP-TYPE) of OBJECT)))
(DD-NAMED
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:50")
(fetch (DEFSTRUCT-DESCRIPTION NAMED) of OBJECT)))
(DD-OFFSET
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:51")
(fetch (DEFSTRUCT-DESCRIPTION OFFSET) of OBJECT)))
(DD-LENGTH
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:51")
(fetch (DEFSTRUCT-DESCRIPTION CL:LENGTH) of OBJECT)))
)
(DEFINEQ
(SETF-DD-NAME
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION NAME) of OBJECT with VALUE)))
(SETF-DD-DOC
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION DOC) of OBJECT with VALUE)))
(SETF-DD-SLOTS
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION SLOTS) of OBJECT with VALUE)))
(SETF-DD-CONC-NAME
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION CONC-NAME) of OBJECT with VALUE)))
(SETF-DD-CONSTRUCTOR
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION CONSTRUCTOR) of OBJECT with VALUE)))
(SETF-DD-BOA-CONSTRUCTORS
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION BOA-CONSTRUCTORS) of OBJECT with VALUE)))
(SETF-DD-COPIER
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION COPIER) of OBJECT with VALUE)))
(SETF-DD-PREDICATE
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION PREDICATE) of OBJECT with VALUE)))
(SETF-DD-INCLUDE
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION INCLUDE) of OBJECT with VALUE)))
(SETF-DD-INCLUDED-BY
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION INCLUDED-BY) of OBJECT with VALUE)))
(SETF-DD-PRINT-FUNCTION
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION PRINT-FUNCTION) of OBJECT with VALUE)))
(SETF-DD-TYPE
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION TYPE) of OBJECT with VALUE)))
(SETF-DD-LISP-TYPE
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION LISP-TYPE) of OBJECT with VALUE)))
(SETF-DD-NAMED
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION NAMED) of OBJECT with VALUE)))
(SETF-DD-OFFSET
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION OFFSET) of OBJECT with VALUE)))
(SETF-DD-LENGTH
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:47")
(replace (DEFSTRUCT-DESCRIPTION NAME) of OBJECT with VALUE)))
)
[DECLARE: EVAL@COMPILE
(DEFSTRUCT (DEFSTRUCT-SLOT-DESCRIPTION (:CONC-NAME DSD-)
(:PRINT-FUNCTION PRINT-DEFSTRUCT-SLOT-DESCRIPTION))
NAME (* " name of the slot" *)
INDEX (* " its position in the implementation sequence" *)
ACCESSOR (* " name of it accessor function" *)
DEFAULT (* " default value" *)
TYPE (* " declared type" *)
READ-ONLY)
]
(/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))
(DEFINEQ
(DSD-NAME
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:54")
(fetch (DEFSTRUCT-SLOT-DESCRIPTION NAME) of OBJECT)))
(DSD-INDEX
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:55")
(fetch (DEFSTRUCT-SLOT-DESCRIPTION INDEX) of OBJECT)))
(DSD-ACCESSOR
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:55")
(fetch (DEFSTRUCT-SLOT-DESCRIPTION ACCESSOR) of OBJECT)))
(DSD-DEFAULT
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:55")
(fetch (DEFSTRUCT-SLOT-DESCRIPTION DEFAULT) of OBJECT)))
(DSD-TYPE
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:56")
(fetch (DEFSTRUCT-SLOT-DESCRIPTION TYPE) of OBJECT)))
(DSD-READ-ONLY
(CL:LAMBDA (OBJECT) (* kbr: " 1-Sep-85 16:56")
(fetch (DEFSTRUCT-SLOT-DESCRIPTION READ-ONLY) of OBJECT)))
)
(DEFINEQ
(SETF-DSD-NAME
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:50")
(replace (DEFSTRUCT-SLOT-DESCRIPTION NAME) of OBJECT with VALUE)))
(SETF-DSD-INDEX
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:50")
(replace (DEFSTRUCT-SLOT-DESCRIPTION INDEX) of OBJECT with VALUE)))
(SETF-DSD-ACCESSOR
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:50")
(replace (DEFSTRUCT-SLOT-DESCRIPTION ACCESSOR) of OBJECT with VALUE)))
(SETF-DSD-DEFAULT
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:50")
(replace (DEFSTRUCT-SLOT-DESCRIPTION DEFAULT) of OBJECT with VALUE)))
(SETF-DSD-TYPE
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:50")
(replace (DEFSTRUCT-SLOT-DESCRIPTION TYPE) of OBJECT with VALUE)))
(SETF-DSD-READ-ONLY
(LAMBDA (OBJECT VALUE) (* kbr: " 1-Sep-85 20:50")
(replace (DEFSTRUCT-SLOT-DESCRIPTION READ-ONLY) of OBJECT with VALUE)))
)
(DEFINEQ
(DEFSTRUCT.EXPANDER
(CL:LAMBDA (NAME-AND-OPTIONS SLOT-DESCRIPTIONS) (* kbr: " 1-Sep-85 22:33")
(LET* ((DEFSTRUCT (PARSE-NAME-AND-OPTIONS NAME-AND-OPTIONS))
(NAME (DD-NAME DEFSTRUCT)))
(PARSE-SLOT-DESCRIPTIONS DEFSTRUCT SLOT-DESCRIPTIONS)
(BQUOTE (PROGN (\,@ (DEFINE-ACCESSORS DEFSTRUCT))
(\,@ (DEFINE-SETTERS DEFSTRUCT))
(\,@ (DEFINE-CONSTRUCTOR DEFSTRUCT))
(\,@ (DEFINE-BOA-CONSTRUCTORS DEFSTRUCT))
(\,@ (DEFINE-COPIER DEFSTRUCT))
(\,@ (DEFINE-PREDICATE DEFSTRUCT))
(\,@ (COND
((DD-INCLUDE DEFSTRUCT)
(BQUOTE ((PUSH (DD-INCLUDED-BY
(GET (QUOTE (\, (CAR (DD-INCLUDE DEFSTRUCT))))
(QUOTE \STRUCTURE-DEFINITION)))
(QUOTE (\, NAME))))))
(T NIL)))
(\,@ (COND
((DD-DOC DEFSTRUCT)
(BQUOTE ((SETF (GET (QUOTE (\, NAME))
(QUOTE \STRUCT-DOCUMENTATION))
(QUOTE (\, (DD-DOC DEFSTRUCT)))))))
(T NIL)))
(EVAL-WHEN (LOAD)
(SETF (GET (QUOTE (\, NAME))
(QUOTE \STRUCTURE-DEFINITION))
(QUOTE (\, DEFSTRUCT))))
(EVAL-WHEN (CL:COMPILE EVAL)
(LET ((OLD (GET (QUOTE (\, NAME))
(QUOTE \STRUCTURE-DEFINITION)))
(NEW (COPY-DEFSTRUCT-DESCRIPTION (QUOTE (\, DEFSTRUCT)))))
(SETF (DD-INCLUDED-BY NEW)
(COND
(OLD (DD-INCLUDED-BY OLD))
(T NIL)))
(SETF (GET (QUOTE (\, NAME))
(QUOTE \STRUCTURE-DEFINITION))
NEW)))
(QUOTE (\, NAME)))))))
(PRINT-DEFSTRUCT-DESCRIPTION
(CL:LAMBDA (STRUCTURE STREAM DEPTH)
(CL:DECLARE (IGNORE DEPTH))
(FORMAT STREAM "#<Defstruct-Description for ~S>" (DD-NAME STRUCTURE))))
(PRINT-DEFSTRUCT-SLOT-DESCRIPTION
(CL:LAMBDA (STRUCTURE STREAM DEPTH)
(CL:DECLARE (IGNORE DEPTH))
(FORMAT STREAM "#<Defstruct-Slot-Description for ~S>" (DSD-NAME STRUCTURE))))
(PARSE-NAME-AND-OPTIONS
(CL:LAMBDA (NAME-AND-OPTIONS) (* kbr: " 1-Sep-85 22:32")
(COND
((CL:ATOM NAME-AND-OPTIONS)
(SETQ NAME-AND-OPTIONS (LIST NAME-AND-OPTIONS)))
(T NIL))
(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 :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 (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
(COND
(SAW-TYPE SAW-NAMED)
(T T))
:OFFSET OFFSET))
(COND
((CL:ATOM (CAR OPTIONS))
(CASE (CAR OPTIONS)
(:CONSTRUCTOR (SETQ SAW-CONSTRUCTOR T)
(SETQ CONSTRUCTOR (CONCAT-PNAMES (QUOTE MAKE-)
NAME)))
(:COPIER)
(:PREDICATE)
(:NAMED (SETQ SAW-NAMED T))
(T (CL:ERROR "The Defstruct option ~S cannot be used with 0 arguments."
(CAR OPTIONS)))))
(T (LET ((OPTION (CAAR OPTIONS))
(ARGS (CDAR OPTIONS)))
(CASE OPTION (:CONC-NAME (SETQ CONC-NAME (CAR ARGS)))
(:CONSTRUCTOR (COND
((CDR ARGS)
(COND
((NOT SAW-CONSTRUCTOR)
(SETQ CONSTRUCTOR NIL)))
(PUSH BOA-CONSTRUCTORS ARGS))
(T (SETQ CONSTRUCTOR (CAR ARGS)))))
(:COPIER (SETQ COPIER (CAR ARGS)))
(:PREDICATE (SETQ PREDICATE (CAR ARGS)))
(:INCLUDE (SETQ INCLUDE ARGS))
(:PRINT-FUNCTION (SETQ PRINT-FUNCTION (CAR ARGS)))
(:TYPE (SETQ SAW-TYPE T)
(SETQ TYPE (CAR ARGS)))
(:NAMED (CL:ERROR "The Defstruct option :NAMED takes no arguments."))
(:INITIAL-OFFSET (SETQ OFFSET (CAR ARGS)))
(T (CL:ERROR "~S is an unknown Defstruct option." OPTION)))))))))
(PARSE-SLOT-DESCRIPTIONS
(CL:LAMBDA (DEFSTRUCT SLOTS) (* kbr: " 1-Sep-85 21:59")
(*
" First strip off any doc string and stash it in the Defstruct." *)
(COND
((STRINGP (CAR SLOTS))
(SETF (DD-DOC DEFSTRUCT)
(CAR SLOTS))
(SETQ SLOTS (CDR SLOTS)))) (*
" Then include stuff. We add unparsed items to the start of the Slots." *)
(COND
((DD-INCLUDE DEFSTRUCT)
(LET ((INCLUDED-THING (GET (CAR (DD-INCLUDE DEFSTRUCT))
(QUOTE \STRUCTURE-DEFINITION)))
(MODIFIED-SLOTS (CDR (DD-INCLUDE DEFSTRUCT))))
(COND
((NOT INCLUDED-THING)
(CL:ERROR "Cannot find description of structure ~S to use for inclusion."
(CAR (DD-INCLUDE DEFSTRUCT)))))
(SETF (DD-OFFSET DEFSTRUCT)
(DD-OFFSET INCLUDED-THING))
(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*)
(SETQ SLOTS (NCONC ISLOTS SLOTS)))
(LET* ((ISLOT (CAR ISLOTS*))
(MODIFIEE (CL:FIND (CAR ISLOT)
MODIFIED-SLOTS :KEY (FUNCTION (CL:LAMBDA (X)
(COND
((CL:ATOM X)
X)
(T (CAR X)))))
:TEST
(FUNCTION STRING=))))
(COND
(MODIFIEE (COND
((SYMBOLP MODIFIEE) (* " If it's just a symbol, nilify the default."
*)
(SETF (CADR ISLOT)
NIL))
((LISTP MODIFIEE) (* " If it's a list, parse new defaults and options."
*)
(SETF (CADR ISLOT)
(CADR MODIFIEE))
(COND
((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))))))))))))))))
(*
" Finally parse the slots into Slot-Description objects." *)
(CL:DO ((SLOTS SLOTS (CDR SLOTS))
(INDEX (+ (DD-OFFSET DEFSTRUCT)
(COND
((DD-NAMED DEFSTRUCT)
1)
(T 0)))
(1+ INDEX))
(DESCRIPTIONS (QUOTE NIL)))
((NULL SLOTS)
(SETF (DD-LENGTH DEFSTRUCT)
INDEX)
(SETF (DD-SLOTS DEFSTRUCT)
(CL:NREVERSE DESCRIPTIONS)))
(LET ((SLOT (CAR SLOTS)))
(push DESCRIPTIONS (COND
((CL:ATOM SLOT)
(LET ((NAME SLOT))
(MAKE-DEFSTRUCT-SLOT-DESCRIPTION :NAME NAME :INDEX INDEX :ACCESSOR
(CONCAT-PNAMES (DD-CONC-NAME
DEFSTRUCT)
NAME)
:TYPE T)))
(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 NAME :INDEX INDEX :ACCESSOR
(CONCAT-PNAMES (DD-CONC-NAME
DEFSTRUCT)
NAME)
:DEFAULT DEFAULT :TYPE TYPE
:READ-ONLY READ-ONLY))
(CASE (CAR OPTIONS)
(:TYPE (SETQ TYPE (CADR OPTIONS)))
(:READ-ONLY (SETQ READ-ONLY (CADR OPTIONS))))))))))))
(CONCAT-PNAMES
(CL:LAMBDA (NAME1 NAME2) (* kbr: " 1-Sep-85 21:54")
(COND
(NAME1 (INTERN (CONCATENATE (QUOTE SIMPLE-STRING)
(SYMBOL-NAME NAME1)
(SYMBOL-NAME NAME2))))
(T NAME2))))
(CONCAT-PNAMES*
(CL:LAMBDA (NAME1 NAME2)
(COND
(NAME1 (MAKE-SYMBOL (CONCATENATE (QUOTE SIMPLE-STRING)
(SYMBOL-NAME NAME1)
(SYMBOL-NAME NAME2))))
(T NAME2))))
(CONCAT-STUFF
(CL:LAMBDA (THING1 THING2)
(INTERN (CONCATENATE (QUOTE SIMPLE-STRING)
(PRINC-TO-STRING THING1)
(PRINC-TO-STRING THING2)))))
(COMPILER::NOTE-ARGS
(CL:LAMBDA (IG1 IG2 IG3 IG4)
(CL:DECLARE (IGNORE IG1 IG2 IG3 IG4))))
(BUILT-IN-COPIER
(CL:LAMBDA (OLD)
(CL:DECLARE (SIMPLE-VECTOR OLD))
(DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OLD))
(NEW (MAKE-ARRAY CL:LENGTH)))
((= INDEX CL:LENGTH)
(STRUCTURIFY NEW))
(SETF (SVREF NEW INDEX)
(SVREF OLD INDEX)))))
(DEFINE-ACCESSORS
(CL:LAMBDA (DEFSTRUCT) (* kbr: " 1-Sep-85 23:31")
(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)))
(push
STUFF
(COND
((AND (EQ TYPE (QUOTE SIMPLE-VECTOR))
(< INDEX NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
(BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (\, NAME)))
(SYMBOL-FUNCTION (QUOTE (\, (AREF BUILT-IN-ACCESSORS INDEX)))))
(EVAL-WHEN (CL:COMPILE LOAD EVAL)
(SETF (GET (QUOTE (\, NAME))
(QUOTE COMPILER::CLC-TRANSFORMS))
(QUOTE ((\, (AREF BUILT-IN-X-ACCESSORS INDEX))))))))
)
(T (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))))))))))))))))
(DEFINE-SETTERS
(CL:LAMBDA (DEFSTRUCT) (* kbr: " 1-Sep-85 23:32")
(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)))
(COND
((NOT (DSD-READ-ONLY SLOT))
(push
STUFF
(COND
((AND (EQ TYPE (QUOTE SIMPLE-VECTOR))
(< INDEX NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
(BQUOTE (DEFSETF (\, (DSD-ACCESSOR SLOT))
(\, (AREF BUILT-IN-SETTERS INDEX)))))
(T
(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)))))))))))))
(DEFINE-CONSTRUCTOR
(CL:LAMBDA (DEFSTRUCT) (* kbr: " 1-Sep-85 20:54")
(LET ((NAME (DD-CONSTRUCTOR DEFSTRUCT)))
(COND
(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))
(\,
(COND
((EQ (DD-TYPE DEFSTRUCT)
(QUOTE LIST))
(BQUOTE (LIST (\,@ (COND
((DD-NAMED DEFSTRUCT)
(BQUOTE ((QUOTE (\, (DD-NAME DEFSTRUCT))))))
(T NIL)))
(\,@ INITIAL-CRUFT)
(\,@ ARG-NAMES))))
(T
(COND
((DD-NAMED DEFSTRUCT)
(BQUOTE (STRUCTURIFY (VECTOR (QUOTE (\, (DD-NAME DEFSTRUCT)))
(\,@ INITIAL-CRUFT)
(\,@ ARG-NAMES)))))
(T
(COND
((EQ (DD-TYPE DEFSTRUCT)
(QUOTE VECTOR))
(BQUOTE (VECTOR (\,@ INITIAL-CRUFT)
(\,@ ARG-NAMES))))
(T
(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)))
(PUSH SETS (BQUOTE (SETF (AREF (\, TEMP)
(\, (DSD-INDEX SLOT)))
(\, (DSD-NAME SLOT))))))))))))))
)))))))))
(DEFINE-BOA-CONSTRUCTORS
(CL:LAMBDA (DEFSTRUCT) (* kbr: " 1-Sep-85 21:57")
(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) (*
" Find the slots in the arglist and hack the defaultless optionals." *)
(CL:DO ((ARGS ARGS (CDR ARGS))
(ARG-KIND (QUOTE REQUIRED)))
((NULL ARGS))
(LET ((ARG (CAR ARGS)))
(COND
((CL:ATOM ARG)
(COND
((MEMQ ARG (QUOTE (&OPTIONAL &REST &AUX)))
(SETQ ARG-KIND ARG))
(T (CASE ARG-KIND ((REQUIRED &REST &AUX)
(PUSH SLOTS-IN-ARGLIST ARG))
(&OPTIONAL (PUSH SLOTS-IN-ARGLIST ARG)
(RPLACA ARGS (LIST ARG
(DSD-DEFAULT
(CL:FIND ARG SLOTS :KEY
(FUNCTION DSD-NAME))))))))))
(T (PUSH SLOTS-IN-ARGLIST (CAR ARG))))))
(*
" Then make a list that can be used with a (list ...) or (vector ...)." *)
(LET ((INITIAL-CRUFT (MAKE-LIST (DD-OFFSET DEFSTRUCT)))
(THING (CL:MAPCAR (FUNCTION (CL:LAMBDA (SLOT)
(COND
((MEMQ (DSD-NAME SLOT)
SLOTS-IN-ARGLIST)
(DSD-NAME SLOT))
(T (DSD-DEFAULT SLOT)))))
SLOTS)))
(PUSH
DEFUNS
(BQUOTE
(DEFUN
(\, NAME)
(\, ARGS)
(\,
(COND
((EQ (DD-TYPE DEFSTRUCT)
(QUOTE LIST))
(BQUOTE (LIST (\,@ (COND
((DD-NAMED DEFSTRUCT)
(BQUOTE ((QUOTE (\, (DD-NAME DEFSTRUCT))))))
(T NIL)))
(\,@ INITIAL-CRUFT)
(\,@ THING))))
(T
(COND
((DD-NAMED DEFSTRUCT)
(BQUOTE (STRUCTURIFY (VECTOR (QUOTE (\, (DD-NAME DEFSTRUCT)))
(\,@ INITIAL-CRUFT)
(\,@ THING)))))
(T
(COND
((EQ (DD-TYPE DEFSTRUCT)
(QUOTE VECTOR))
(BQUOTE (VECTOR (\,@ INITIAL-CRUFT)
(\,@ THING))))
(T (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))))
(PUSH SETS (BQUOTE (SETF (AREF (\, TEMP)
INDEX)
(\, (CAR THINGS))))))))))))))))))))
(DEFINE-COPIER
(CL:LAMBDA (DEFSTRUCT)
(COND
((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))))))))
(T NIL))))
(DEFINE-PREDICATE
(CL:LAMBDA (DEFSTRUCT)
(COND
((AND (DD-PREDICATE DEFSTRUCT)
(DD-NAMED DEFSTRUCT))
(BQUOTE
((DEFUN
(\, (DD-PREDICATE DEFSTRUCT))
(OBJECT)
(\, (COND
((EQ (DD-TYPE DEFSTRUCT)
(QUOTE LIST))
(BQUOTE (AND (LISTP OBJECT)
(OR (EQ (CAR OBJECT)
(QUOTE (\, (DD-NAME DEFSTRUCT))))
(MEMQ (CAR OBJECT)
(DD-INCLUDED-BY (GET (QUOTE (\, (DD-NAME DEFSTRUCT)))
(QUOTE \STRUCTURE-DEFINITION))))))))
(T (BQUOTE (AND (SIMPLE-VECTOR-P OBJECT)
(TEST-STRUCTURE OBJECT)
(OR (EQ (SVREF OBJECT 0)
(QUOTE (\, (DD-NAME DEFSTRUCT))))
(COND
((MEMQ (SVREF OBJECT 0)
(DD-INCLUDED-BY (GET (QUOTE (\, (DD-NAME DEFSTRUCT)))
(QUOTE \STRUCTURE-DEFINITION))))
T)
(T NIL)))))))))))))))
(DEFAULT-STRUCTURE-PRINT
(CL:LAMBDA (STRUCTURE STREAM DEPTH) (* kbr: " 1-Sep-85 22:00")
(CL:DECLARE (IGNORE DEPTH))
(WRITE-STRING "#S(" STREAM)
(CL: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*)))
(COND
((= INDEX CL:LENGTH)
(WRITE-STRING ")" STREAM))
(T (WRITE-STRING "...)" STREAM))))
(WRITE-CHAR |\SPACE STREAM)
(CL:PRIN1 (DSD-NAME (CAR SLOTS))
STREAM)
(WRITE-CHAR |\SPACE STREAM)
(CL:PRIN1 (SVREF STRUCTURE INDEX)
STREAM))))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO DEFSTRUCT (NAME-AND-OPTIONS &REST SLOT-DESCRIPTIONS)
(DEFSTRUCT.EXPANDER NAME-AND-OPTIONS SLOT-DESCRIPTIONS))
)
(PUTPROPS DEFSTRUCT USERRECORDTYPE (LAMBDA (DEF)
(LET ((DE (DEFSTRUCT.EXPANDER (CADR DEF)
(CDDR DEF)))
(BREAK1 NIL T))
(RESETVARS ((FILEPKGFLG))
(MAPC (CDR DE)
(QUOTE EVAL)))
(CAR DE))))
(MOVD (QUOTE RECORD)
(QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT)
(* (MAKE-BUILT-IN-SLOT-FROBBERS))
(PUTPROPS CMLDEFSTRUCT COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5656 8346 (\GET-0 5666 . 5797) (\GET-1 5799 . 5930) (\GET-2 5932 . 6063) (\GET-3 6065
. 6196) (\GET-4 6198 . 6329) (\GET-5 6331 . 6462) (\GET-6 6464 . 6595) (\GET-7 6597 . 6728) (\GET-8
6730 . 6861) (\GET-9 6863 . 6994) (\GET-10 6996 . 7129) (\GET-11 7131 . 7264) (\GET-12 7266 . 7399) (
\GET-13 7401 . 7534) (\GET-14 7536 . 7669) (\GET-15 7671 . 7804) (\GET-16 7806 . 7939) (\GET-17 7941
. 8074) (\GET-18 8076 . 8209) (\GET-19 8211 . 8344)) (8347 11077 (\SET-0 8357 . 8490) (\SET-1 8492 .
8625) (\SET-2 8627 . 8760) (\SET-3 8762 . 8895) (\SET-4 8897 . 9030) (\SET-5 9032 . 9165) (\SET-6 9167
. 9300) (\SET-7 9302 . 9435) (\SET-8 9437 . 9570) (\SET-9 9572 . 9705) (\SET-10 9707 . 9842) (\SET-11
9844 . 9979) (\SET-12 9981 . 10116) (\SET-13 10118 . 10253) (\SET-14 10255 . 10390) (\SET-15 10392 .
10527) (\SET-16 10529 . 10664) (\SET-17 10666 . 10801) (\SET-18 10803 . 10938) (\SET-19 10940 . 11075)
) (13768 16575 (DD-NAME 13778 . 13943) (DD-DOC 13945 . 14108) (DD-SLOTS 14110 . 14277) (DD-CONC-NAME
14279 . 14454) (DD-CONSTRUCTOR 14456 . 14635) (DD-BOA-CONSTRUCTORS 14637 . 14826) (DD-COPIER 14828 .
14997) (DD-PREDICATE 14999 . 15174) (DD-INCLUDE 15176 . 15347) (DD-INCLUDED-BY 15349 . 15528) (
DD-PRINT-FUNCTION 15530 . 15715) (DD-TYPE 15717 . 15882) (DD-LISP-TYPE 15884 . 16059) (DD-NAMED 16061
. 16228) (DD-OFFSET 16230 . 16399) (DD-LENGTH 16401 . 16573)) (16576 19730 (SETF-DD-NAME 16586 .
16773) (SETF-DD-DOC 16775 . 16960) (SETF-DD-SLOTS 16962 . 17151) (SETF-DD-CONC-NAME 17153 . 17350) (
SETF-DD-CONSTRUCTOR 17352 . 17553) (SETF-DD-BOA-CONSTRUCTORS 17555 . 17766) (SETF-DD-COPIER 17768 .
17959) (SETF-DD-PREDICATE 17961 . 18158) (SETF-DD-INCLUDE 18160 . 18353) (SETF-DD-INCLUDED-BY 18355 .
18556) (SETF-DD-PRINT-FUNCTION 18558 . 18765) (SETF-DD-TYPE 18767 . 18954) (SETF-DD-LISP-TYPE 18956 .
19153) (SETF-DD-NAMED 19155 . 19344) (SETF-DD-OFFSET 19346 . 19537) (SETF-DD-LENGTH 19539 . 19728)) (
20754 21828 (DSD-NAME 20764 . 20935) (DSD-INDEX 20937 . 21110) (DSD-ACCESSOR 21112 . 21291) (
DSD-DEFAULT 21293 . 21470) (DSD-TYPE 21472 . 21643) (DSD-READ-ONLY 21645 . 21826)) (21829 23035 (
SETF-DSD-NAME 21839 . 22032) (SETF-DSD-INDEX 22034 . 22229) (SETF-DSD-ACCESSOR 22231 . 22432) (
SETF-DSD-DEFAULT 22434 . 22633) (SETF-DSD-TYPE 22635 . 22828) (SETF-DSD-READ-ONLY 22830 . 23033)) (
23036 43560 (DEFSTRUCT.EXPANDER 23046 . 24741) (PRINT-DEFSTRUCT-DESCRIPTION 24743 . 24933) (
PRINT-DEFSTRUCT-SLOT-DESCRIPTION 24935 . 25132) (PARSE-NAME-AND-OPTIONS 25134 . 27931) (
PARSE-SLOT-DESCRIPTIONS 27933 . 31905) (CONCAT-PNAMES 31907 . 32181) (CONCAT-PNAMES* 32183 . 32408) (
CONCAT-STUFF 32410 . 32573) (COMPILER::NOTE-ARGS 32575 . 32678) (BUILT-IN-COPIER 32680 . 32996) (
DEFINE-ACCESSORS 32998 . 34442) (DEFINE-SETTERS 34444 . 35857) (DEFINE-CONSTRUCTOR 35859 . 37776) (
DEFINE-BOA-CONSTRUCTORS 37778 . 40928) (DEFINE-COPIER 40930 . 41699) (DEFINE-PREDICATE 41701 . 42707)
(DEFAULT-STRUCTURE-PRINT 42709 . 43558)))))
STOP