(FILECREATED " 8-Apr-86 22:04:58" {ERIS}<LISPCORE>CML>LAB>CMLSTRUCT.;4 17595
changes to: (FNS DEFSTRUCT.TRANSLATE \CMLSTRUCT.CLTYPE.TO.ILTYPE)
(VARS CMLSTRUCTCOMS)
(PROPS (DEFSTRUCT USERRECORDTYPE))
previous date: "25-Mar-86 12:15:37" {ERIS}<LISPCORE>CML>LAB>CMLSTRUCT.;1)
(* 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)
DEFSTRUCT)
(P (MOVD (QUOTE RECORD)
(QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT))))
(DEFINEQ
(DEFSTRUCT.TRANSLATE
[LAMBDA (TAIL) (* gbn " 8-Apr-86 22:02")
(LET* ((name&options (CAR TAIL))
(slotdescrs (CDR TAIL))
options
(doc (AND (STRINGP (CAR slotdescrs))
(pop slotdescrs)))
class
(name (COND
((LISTP name&options)
(CAR name&options))
(T name&options)))
includes initialization (slots)
(slotnames)
(slotfns)
(initialization)
(includes)
(conc-name (CONCAT name "-"))
(constructors)
(predicate (PACK* name "-P"))
(print-function (FUNCTION DEFAULT-STRUCTURE-PRINTER))
(copier (PACK* "COPY-" name))
named NAMED type)
[COND
((LISTP name&options)
(for option in (SETQ options (CDR name&options))
do (COND
[(LISTP option)
(SELECTQ (CAR option)
(:CLASS (SETQ class (CADR option))
NIL)
(:CONSTRUCTOR (push constructors (CDR option)))
(:CONC-NAME (SETQ conc-name (OR (CADR option)
"")))
(:INCLUDE (push includes (CADR 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
(HELP ":INITIAL-OFFSET unimplemented for DEFSTRUCT"))
(SHOULDNT (CONCAT option "bad option"]
(T (SELECTQ option
(:NAMED (SETQ NAMED T))
(ERROR "DEFSTRUCT declaration error " option]
(if includes
then (if (AND (EQ class (QUOTE LIST-CLASS))
(NULL (CDR includes)))
then (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)))
else (HELP "Can't fake includes yet")))
[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]
(BQUOTE
((, (SELECTQ class
((NIL STRUCTURE)
(QUOTE DATATYPE))
(LIST-CLASS (if NAMED
then (QUOTE TYPERECORD)
else (QUOTE RECORD)))
(VECTOR (QUOTE ARRAYRECORD))
(HELP))
, name , (SELECTQ class
(LIST-CLASS slotnames)
(PROGN 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 (AND (EQ stream T)
(SETQ stream (
TTYDISPLAYSTREAM
)))
(APPLY* (FUNCTION (\,
print-function
))
x stream 0)
(QUOTE (""]
.,
[for constructor in [OR constructors (LIST (LIST (PACK* "MAKE-" name]
collect
(if (CDR constructor)
then [BQUOTE (DEFUN (\, (CAR constructor))
(\, (CADR constructor))
(create (\, name)
(\,@(for x in (CADR constructor)
join (COND
((FMEMB x (QUOTE (&KEY &OPTIONAL &REST))
)
NIL)
((LISTP x)
(LIST (CAR x)
(QUOTE ←)
(CAR x)))
(T (LIST x (QUOTE ←)
x]
else (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]
.,
(for slot in slotnames bind conc setfconc
join (BQUOTE ((DEFUN (\, (SETQ conc (PACK* conc-name slot)))
(object)
(fetch ((\, name)
(\, slot))
object))
(DECLARE: EVAL@COMPILE [PUTPROP (QUOTE (\, conc))
(QUOTE DMACRO)
(QUOTE ((obj)
(fetch ((\, name)
(\, slot))
obj]
[PUTPROP [QUOTE (\, (SETQ setfconc (PACK* "SETF-" conc]
(QUOTE DMACRO)
(QUOTE ((obj value)
(replace ((\, name)
(\, slot))
obj value]
(DEFSETF (\, conc)
(\, setfconc])
(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) (* 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])
)
(PUTPROPS DEFSTRUCT USERRECORDTYPE [LAMBDA (L)
(LET [(DE (DEFSTRUCT.TRANSLATE (CDR L]
(RESETVARS ((FILEPKGFLG))
(MAPC (CDR DE)
(QUOTE EVAL)))
(CAR DE])
(MOVD (QUOTE RECORD)
(QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT)
(PUTPROPS CMLSTRUCT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (793 17019 (DEFSTRUCT.TRANSLATE 803 . 12824) (DEFAULT-STRUCTURE-PRINTER 12826 . 13437) (
\CMLSTRUCT.CLTYPE.TO.ILTYPE 13439 . 17017)))))
STOP