(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