(FILECREATED "15-Jan-86 16:20:29" {ERIS}<LISPCORE>LIBRARY>CMLSTRUCT.;16 11776
changes to: (FNS \CMLSTRUCT.CLTYPE.TO.ILTYPE DEFSTRUCT.TRANSLATE)
previous date: "10-Jan-86 02:43:22" {ERIS}<LISPCORE>LIBRARY>CMLSTRUCT.;14)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSTRUCTCOMS)
(RPAQQ CMLSTRUCTCOMS ((FNS DEFSTRUCT.TRANSLATE DEFAULT-STRUCTURE-PRINTER
\CMLSTRUCT.CLTYPE.TO.ILTYPE)
(PROP (USERRECORDTYPE MACRO)
DEFSTRUCT)
(P (MOVD (QUOTE RECORD)
(QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT))))
(DEFINEQ
(DEFSTRUCT.TRANSLATE
[LAMBDA (TAIL) (* raf "13-Jan-86 18:13")
(LET* ((name&options (CAR TAIL))
(slotdescrs (CDR TAIL))
options
(doc (AND (STRINGP (CAR slotdescrs))
(pop slotdescrs)))
type
(name (COND
((LISTP name&options)
(CAR name&options))
(T name&options)))
(slots)
(slotnames)
(slotfns)
(initialization)
(includes)
(conc-name (CONCAT name "-"))
(constructor)
(predicate (PACK* name "-P"))
(print-function (FUNCTION DEFAULT-STRUCTURE-PRINTER))
(copier (PACK* "COPY-" name))
named)
[if (LISTP name&options)
then (for option in (SETQ options (CDR name&options))
do (COND
((LISTP option)
(SELECTQ (CAR option)
(:CONSTRUCTOR (SETQ constructor (CDR option)))
(:CONC-NAME (SETQ conc-name (CADR option)))
(:INCLUDE (SETQ includes (CDR option)))
(:COPIER (SETQ copier (CADR option)))
(:PRINT-FUNCTION (SETQ print-function (CADR option)))
(:PREDICATE (SETQ predicate (CADR option)))
[:TYPE (SETQ type (OR (CAR (CADR option))
(CADR option]
(:INITIAL-OFFSET (HELP
":INITIAL-OFFSET unimplemented for DEFSTRUCT"))
(ERROR "Unknown DEFSTRUCT option: " option)))
(T (SELECTQ option
(:NAMED (SETQ named T))
(ERROR "DEFSTRUCT declaration error " option]
[if includes
then (if (NEQ type (QUOTE LIST))
then (ERROR ":INCLUDE only implemented for :TYPE LIST, given " type))
(* * merge the included defstruct with the slotdescrs)
(LET* ((includename (CAR includes))
(includeslotdescrs (CDR includes)))
(bind slotname includedescr for x
in (CDDR (OR (RECLOOK includename)
(ERROR "Undefined structure in :INCLUDE "
includename)))
eachtime (SETQ slotname (OR (CAR (LISTP x))
x))
(SETQ includedescr (OR (OR (FMEMB slotname
includeslotdescrs)
slotname)
(FASSOC slotname
includeslotdescrs)))
do (push slotdescrs (OR includedescr x))
(* redeclaration takes precedence)]
(* * create the record fields)
[bind slotname options for x in slotdescrs
eachtime (SETQ slotname (OR (CAR (LISTP x))
x))
(SETQ options (CDDR (LISTP x)))
do
(push slotnames slotname)
(* * make slot accessor and settor fns and dmacros)
[pushlist
slotfns
(LET (conc setfconc)
(BQUOTE ((DEFUN (\, (SETQ conc (PACK* conc-name slotname)))
(object)
(fetch ((\, name)
(\, slotname))
of object))
(DECLARE:
EVAL@COMPILE
[PUTPROP (QUOTE (\, conc))
(QUOTE DMACRO)
(QUOTE ((obj)
(fetch ((\, name)
(\, slotname))
of obj]
(\,@ (if (CADR (MEMB (QUOTE :READ-ONLY)
options))
then NIL
else (BQUOTE ([PUTPROP [QUOTE (\, (SETQ setfconc
(PACK* "SETF-"
conc]
(QUOTE DMACRO)
(QUOTE
((obj value)
(replace ((\, name)
(\, slotname))
obj value]
(DEFSETF (\, conc)
(\, setfconc]
(* * include this init form so that create will initialize, although we do it in our constructor as well)
[if (CDR (LISTP x))
then (pushlist initialization (BQUOTE ((\, slotname)←
(\, (CADR (LISTP x]
(* * make the field definition)
(bind (type ← (QUOTE POINTER)) for option on (CDDR (LISTP x))
by (CDDR option) do (SELECTQ (CAR option)
[:TYPE (SETQ type (
\CMLSTRUCT.CLTYPE.TO.ILTYPE
(CADR option]
(:READ-ONLY
(* Handled in settor building section))
(ERROR "Bad DEFSTRUCT slot " x))
finally (push slots (LIST slotname type]
[if (EQ type (QUOTE LIST))
then (* This is a hack to keep the record package from
attempting to destructure a slot description)
(SETQ slots (for x in slots collect (CAR x]
[OR constructor (SETQ constructor (LIST (PACK* "MAKE-" name]
(BQUOTE (((\, (SELECTQ type
(NIL (QUOTE DATATYPE))
(LIST (if named
then (QUOTE TYPERECORD)
else (QUOTE RECORD)))
(VECTOR (QUOTE ARRAYRECORD))
(ERROR "Unknown DEFSTRUCT :TYPE option " type)))
(\, name)
(\, slots)
(\,@ initialization))
(\,@ slotfns)
[\,@ (AND predicate (BQUOTE ((DEFUN , predicate (obj)
(type? , name obj]
[\,@ (AND copier (BQUOTE ((DEFUN , copier (obj)
(create (\, name) using obj]
[\,@ (AND print-function
(BQUOTE ((DEFPRINT (QUOTE (\, name))
(FUNCTION (LAMBDA (x stream)
(COND
(stream (APPLY*
(FUNCTION (\,
print-function))
x stream 0)
(QUOTE (""]
(\, (if (CDR constructor)
then (* By Order of Argument constructor function)
[BQUOTE (DEFUN (\, (CAR constructor))
(\, (CADR constructor))
(create (\, name)
(\,@ (for x in slotnames
join (LIST x (QUOTE
←)
x]
else (* slots named by keywords constructor)
(BQUOTE (DEFUN (\, (CAR constructor))
[&KEY (\,@ (for x in slotdescrs
collect
(if (NLISTP x)
then x
else (LIST (CAR x)
(CADR x]
(create (\, name)
(\,@ (for x in slotnames
join (LIST x (QUOTE ←)
x])
(DEFAULT-STRUCTURE-PRINTER
(CL:LAMBDA (STRUC STREAM LEVEL) (* raf "20-Dec-85 16:53")
(LET ((TYPE (TYPENAME STRUC)))
(PRIN1 \CML.READPREFIX STREAM)
(PRIN1 (QUOTE S)
STREAM)
(PRIN1 "(" STREAM)
(PRIN2 TYPE STREAM)
(for FIELD in (RECORDFIELDNAMES TYPE) as DESCRIPTOR in (GETDESCRIPTORS TYPE)
do (PRIN1 " " STREAM)
(PRIN2 FIELD STREAM)
(PRIN1 " " STREAM)
(PRIN2 (FETCHFIELD DESCRIPTOR STRUC)
STREAM))
(PRIN1 ")" STREAM))))
(\CMLSTRUCT.CLTYPE.TO.ILTYPE
[LAMBDA (ELEMENTTYPE) (* raf "15-Jan-86 16:13")
(* * 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))
(if (AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE MOD))
(NULL (CDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(ILESSP 1 (CADR ELEMENTTYPE)))
then (* (MOD n) is converted to the next higher enclosing
type.)
(LET ((MOD# (CADR ELEMENTTYPE)))
(if (ILEQ MOD# (LLSH 1 BITSPERWORD))
then [BQUOTE (BITS (\, (INTEGERLENGTH (SUB1 MOD#]
elseif (ILEQ MOD# MAX.FIXP)
then (QUOTE FIXP)
else (QUOTE POINTER)))
elseif (AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE UNSIGNED-BYTE))
(NULL (CDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(ILESSP 0 (CADR ELEMENTTYPE)))
then (* (UNSIGNED.BYTE n) is converted to the next higher
enclosing type.)
(LET ((#BITS (CADR ELEMENTTYPE)))
(if (ILEQ #BITS BITSPERWORD)
then (BQUOTE (BITS (\, #BITS)))
elseif (ILEQ #BITS (CONSTANT (INTEGERLENGTH MAX.FIXP)))
then (QUOTE FIXP)
else (QUOTE POINTER)))
elseif (AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE INTEGER))
(NULL (CDDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(FIXP (CADDR ELEMENTTYPE))
(ILESSP (CADR ELEMENTTYPE)
(CADDR ELEMENTTYPE)))
then (* (INTEGER low high))
(LET* ((LOW (CADR ELEMENTTYPE))
(HIGH (CADDR ELEMENTTYPE))
(RANGE (IDIFFERENCE HIGH LOW)))
(* Type simplification should probably be done
somewhere else)
(if (IEQP LOW 0)
then (* (INTEGER 0 high) => (MOD nbits))
[\CMLSTRUCT.CLTYPE.TO.ILTYPE (BQUOTE
(MOD , (ADD1 RANGE]
elseif (AND (IGEQ LOW MIN.FIXP)
(ILEQ HIGH MAX.FIXP))
then (* (INTEGER >= MIN.FIXP <= MAX.FIXP) == FIXNUM)
(QUOTE FIXP)
else (QUOTE POINTER)))
elseif (FMEMB ELEMENTTYPE (USERDATATYPES))
then (QUOTE POINTER)
else (ERROR "Bad type specifier" ELEMENTTYPE])
)
(PUTPROPS DEFSTRUCT USERRECORDTYPE [LAMBDA (L)
(LET [(DE (DEFSTRUCT.TRANSLATE (CDR L]
(RESETVARS ((FILEPKGFLG))
(MAPC (CDR DE)
(QUOTE EVAL)))
(CAR DE])
(PUTPROPS DEFSTRUCT MACRO (DEFMACRO (&REST tail)
(DEFSTRUCT.TRANSLATE tail)))
(MOVD (QUOTE RECORD)
(QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT)
(PUTPROPS CMLSTRUCT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (614 11305 (DEFSTRUCT.TRANSLATE 624 . 7465) (DEFAULT-STRUCTURE-PRINTER 7467 . 8078) (
\CMLSTRUCT.CLTYPE.TO.ILTYPE 8080 . 11303)))))
STOP