(FILECREATED "26-Sep-86 18:58:37" {ERIS}<LISPCORE>SOURCES>DTDECLARE.;18 30432
changes to: (FNS COMPILEDTYPENAMEP)
(MACROS TYPENAMEP)
(VARS DTDECLARECOMS)
previous date: "16-Jul-86 23:21:18" {ERIS}<LISPCORE>SOURCES>DTDECLARE.;17)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DTDECLARECOMS)
(RPAQQ DTDECLARECOMS ((* declaring DATATYPES - part of ABC too)
(FNS /DECLAREDATATYPE DECLAREDATATYPE TRANSLATE.DATATYPE \REUSETO
\TYPEGLOBALVARIABLE)
(FNS BitFieldMask BitFieldShift BitFieldShiftedMask MakeBitField BitFieldWidth
BitFieldFirst)
(PROP DMACRO FETCHFIELD FFETCHFIELD REPLACEFIELD FREPLACEFIELD REPLACEFIELDVAL
FREPLACEFIELDVAL NCREATE \DTEST \TESTBITS)
(FNS COMPILEDFETCHFIELD COMPILEDREPLACEFIELD COMPILEDTYPENAMEP COMPILEDNCREATE)
(* ;; "AFTER ONE SYSTEM RECOMPILE FROM SEP 16, REMOVE COMPILEDTYPENAMEP")
(DECLARE: DONTCOPY (EXPORT (RECORDS FldDsc)))
(VARS DATATYPEFIELDTYPES)
(COMS (* Macros which convert a record access form into an address-generating
form)
(MACROS LOCF INDEXF)
(FNS TRANSLATE.LOCF))
(LOCALVARS . T)))
(* declaring DATATYPES - part of ABC too)
(DEFINEQ
(/DECLAREDATATYPE
[LAMBDA (TYPENAME FIELDSPECS DLIST LEN SUPERTYPE) (* bvm: " 4-Jun-86 12:23")
[AND LISPXHIST TYPENAME (UNDOSAVE (LIST (QUOTE /DECLAREDATATYPE)
TYPENAME
(GETFIELDSPECS TYPENAME)
NIL NIL (GETSUPERTYPE TYPENAME]
(MULTIPLE-VALUE-BIND (DLIST REDECLARED)
(DECLAREDATATYPE TYPENAME FIELDSPECS DLIST LEN SUPERTYPE)
(COND
(REDECLARED (LISPXPRINT (LIST (QUOTE datatype)
TYPENAME
(QUOTE redeclared))
T T)))
DLIST])
(DECLAREDATATYPE
[LAMBDA (TYPENAME FIELDSPECS DLIST LENGTH SUPERTYPE) (* bvm: " 9-Jul-86 11:57")
(* "this is called twice when declaring records; once where the DLIST and LENGTH hasn't been computed, and another time when it has.")
[LET [(SUPERSPECS (COND
(SUPERTYPE (GETFIELDSPECS SUPERTYPE](* maybe an error if supertype doesn't
exist?)
(SETQ FIELDSPECS (APPEND SUPERSPECS FIELDSPECS))
(COND
((AND FIELDSPECS (OR (NOT DLIST)
(NOT LENGTH))) (* the AND is an optimization --
do we really need to compute DLIST?)
(SETQ DLIST (TRANSLATE.DATATYPE TYPENAME FIELDSPECS))
(SETQ LENGTH (pop DLIST]
(OR (AND TYPENAME (LITATOM TYPENAME))
(LISPERROR "ILLEGAL ARG" TYPENAME))
(LET [(PTRS (for P in DLIST when (SELECTQ (fetch fdType of P)
((POINTER FULLPOINTER)
T)
NIL) collect (fetch fdOffset of P]
(MULTIPLE-VALUE-BIND (TYPENUM REDECLARED)
(\ASSIGNDATATYPE1 TYPENAME DLIST LENGTH FIELDSPECS PTRS SUPERTYPE)
(SETTOPVAL (\TYPEGLOBALVARIABLE TYPENAME T)
TYPENUM)
(VALUES DLIST REDECLARED])
(TRANSLATE.DATATYPE
[LAMBDA (TYPENAME FIELDSPECS) (* DECLARATIONS: (RECORD SPEC
(N LEN . FD)))
(DECLARE (SPECVARS TYPENAME UNUSED BIT OFFSET FD)) (* lmm "13-Mar-85 16:48")
(COND
((NULL TYPENAME))
((OR (NOT (LITATOM TYPENAME))
(EQ TYPENAME (QUOTE **DEALLOC**)))
(ERROR "Invalid type name" TYPENAME)))
(PROG ((N 0)
UNUSED
(OFFSET 0)
(BIT 0)
DLIST REUSE LEN FD)
[SETQ DLIST (for S in FIELDSPECS
collect (create SPEC
N ← (add N 1)
LEN ← (SELECTQ S
((POINTER XPOINTER)
24)
((FIXP FLOATP SWAPPEDFIXP FULLPOINTER
SWAPPEDXPOINTER FULLXPOINTER)
BITSPERCELL)
(FLAG (SETQQ S FLAGBITS)
1)
(BYTE (SETQQ S BITS)
BITSPERBYTE)
(WORD (SETQQ S BITS)
BITSPERWORD)
(SIGNEDWORD (SETQQ S SIGNEDBITS)
BITSPERWORD)
(SELECTQ (CAR (LISTP S))
((BITS FLAGBITS SIGNEDBITS)
(PROG1 (CADR S)
(SETQ S (CAR S))))
(ERROR "invalid field spec: " S)))
FD ← (create FldDsc
fdTypeName ← TYPENAME
fdType ← S
fdOffset ← NIL]
[for S in DLIST
do
(replace fdOffset of (SETQ FD (fetch FD of S))
with
(SELECTQ (fetch fdType of FD)
((POINTER XPOINTER)
(COND
([AND TYPENAME
(find X in UNUSED
suchthat (AND (EQ 0 (LOGAND (CAR X)
1))
(IGEQ (CADDR X)
8)
(EQ (IPLUS (CADR X)
(CADDR X))
BITSPERWORD)
(find Y in UNUSED
suchthat (AND (EQ (CAR Y)
(ADD1 (CAR X)))
(EQ (CADDR Y)
BITSPERWORD]
(* unused 24 bit quantity)
(* this case not implemented yet)
))
(COND
((IGREATERP BIT 8) (* Less than 8 bits left in this word)
(\REUSETO BITSPERWORD)))
(COND
((ODDP OFFSET WORDSPERCELL) (* not on double word boundary)
(\REUSETO BITSPERWORD)))
[COND
((NEQ BIT 8)
(\REUSETO 8 (EQ BIT 0]
(SETQ BIT 0)
(PROG1 OFFSET (add OFFSET WORDSPERCELL)))
((FIXP SWAPPEDFIXP FLOATP SWAPPEDXPOINTER)
(* 32 bit quantities)
(COND
((NEQ BIT 0)
(\REUSETO BITSPERWORD)))
(PROG1 OFFSET (add OFFSET WORDSPERCELL)))
((FULLPOINTER FULLXPOINTER) (* 32 bit doubleword-aligned
quantities)
(COND
((NEQ BIT 0)
(\REUSETO BITSPERWORD)))
(COND
((ODDP OFFSET WORDSPERCELL)
(\REUSETO BITSPERWORD)))
(PROG1 OFFSET (add OFFSET WORDSPERCELL)))
((BITS FLAGBITS SIGNEDBITS)
(SETQ LEN (fetch LEN of S))
[COND
([AND TYPENAME (SETQ REUSE (find X in UNUSED
suchthat (ILEQ LEN (CADDR X]
(RPLACA (CDDR REUSE)
(IDIFFERENCE (CAR (CDDR REUSE))
LEN))
(replace fdType of FD with (CONS (fetch fdType of FD)
(MakeBitField (CADR REUSE)
LEN)))
(add (CADR REUSE)
LEN)
(CAR REUSE))
((IGREATERP LEN BITSPERWORD) (* more than 1 word -
Must right justify first word)
(SETQ LEN (IDIFFERENCE LEN BITSPERWORD))
(COND
((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT))
(\REUSETO BITSPERWORD)))
[COND
((NEQ (IDIFFERENCE BITSPERWORD BIT)
LEN)
(\REUSETO (IDIFFERENCE BITSPERWORD LEN]
(replace fdType of FD with (CONS (QUOTE LONGBITS)
(MakeBitField BIT LEN)))
(SETQ BIT 0)
(PROG1 OFFSET (add OFFSET 2)))
(T (COND
((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT))
(\REUSETO BITSPERWORD)))
(replace fdType of FD with (CONS (fetch fdType of FD)
(MakeBitField BIT LEN)))
(add BIT LEN)
(PROG1 OFFSET (COND
((EQ BIT BITSPERWORD)
(SETQ BIT 0)
(add OFFSET 1])
(SHOULDNT]
[COND
(TYPENAME (COND
((NEQ BIT 0)
(\REUSETO BITSPERWORD)))
(while (ODDP OFFSET WORDSPERCELL) do (add OFFSET 1))
(COND
((IGREATERP OFFSET \MDSIncrement)
(ERROR TYPENAME "DATATYPE TOO BIG"]
(RETURN (CONS OFFSET (MAPCAR DLIST (FUNCTION (LAMBDA (X)
(fetch FD of X])
(\REUSETO
[LAMBDA (N FLG) (* lmm " 2-SEP-80 15:11")
(SETQ N (IDIFFERENCE N BIT))
[COND
((NEQ N 0)
(COND
((AND (NULL TYPENAME)
(NOT FLG))
(ERROR "Block/datatype field not alligned properly" FD)))
(push UNUSED (LIST OFFSET BIT N]
(add BIT N)
(COND
((EQ BIT 16)
(SETQ BIT 0)
(add OFFSET 1])
(\TYPEGLOBALVARIABLE
[LAMBDA (TYPENAME VARFLG) (* bvm: " 9-Jul-86 11:57")
(* * "Returns a constant or a variable that contains the datatype number of TYPENAME. It is used when compiling type tests and assigning datatypes. If TYPENAME is a system type, it returns the number. Otherwise it creates a variable name and puts it on GLOBALVARS.
This is a kludge that will go away when we have type resolution at load time.
If VARFLG is true, always returns a var, rather than a system constant. This is another kludge for backward compatibility.")
(OR (AND (NOT VARFLG)
(for ENTRY in \BUILT-IN-SYSTEM-TYPES as I from 1 when (EQ TYPENAME (CAR ENTRY))
do (RETURN I)))
(LET ((VAR (PACK* "" TYPENAME "TYPE#"))) (*
"Need to create unique variable. strategy is to put ↑d ↑c on front.")
(COND
([NOT (OR (FMEMB VAR GLOBALVARS)
(GETPROP VAR (QUOTE GLOBALVAR]
(PUTPROP VAR (QUOTE GLOBALVAR)
T)))
VAR])
)
(DEFINEQ
(BitFieldMask
[LAMBDA (FD) (* lmm "24-FEB-81 13:41")
(SUB1 (LLSH 1 (BitFieldWidth FD])
(BitFieldShift
[LAMBDA (FD) (* lmm "21-JAN-80 01:14")
(IDIFFERENCE 16 (IPLUS (BitFieldFirst FD)
(BitFieldWidth FD])
(BitFieldShiftedMask
[LAMBDA (FD) (* lmm "10-FEB-80 12:00")
(IDIFFERENCE (LLSH 1 (IDIFFERENCE 16 (BitFieldFirst FD)))
(LLSH 1 (IDIFFERENCE 16 (IPLUS (BitFieldFirst FD)
(BitFieldWidth FD])
(MakeBitField
[LAMBDA (first width) (* lmm "20-JAN-80 23:52")
(LOGOR (LLSH first 4)
(SUB1 width])
(BitFieldWidth
[LAMBDA (FD) (* lmm "21-JAN-80 01:14")
(ADD1 (LOGAND FD 15])
(BitFieldFirst
[LAMBDA (FD) (* lmm "21-JAN-80 01:13")
(LRSH FD 4])
)
(PUTPROPS FETCHFIELD DMACRO (X (COMPILEDFETCHFIELD X)))
(PUTPROPS FFETCHFIELD DMACRO (X (COMPILEDFETCHFIELD X T)))
(PUTPROPS REPLACEFIELD DMACRO (X (COMPILEDREPLACEFIELD X)))
(PUTPROPS FREPLACEFIELD DMACRO (X (COMPILEDREPLACEFIELD X T)))
(PUTPROPS REPLACEFIELDVAL DMACRO (OPENLAMBDA (DESCRIPTOR DATUM NEWVALUE)
(PROG1 DATUM (REPLACEFIELD DESCRIPTOR DATUM NEWVALUE))))
(PUTPROPS FREPLACEFIELDVAL DMACRO (OPENLAMBDA (DESCRIPTOR DATUM NEWVALUE)
(PROG1 DATUM (FREPLACEFIELD DESCRIPTOR DATUM NEWVALUE))))
(PUTPROPS NCREATE DMACRO (X (COMPILEDNCREATE X)))
(PUTPROPS \DTEST DMACRO (X (COND ((AND (EQ (CAADR X)
(QUOTE QUOTE))
(LITATOM (CADR (CADR X))))
(LIST (LIST (QUOTE OPCODES)
(QUOTE DTEST)
0
(CONS (QUOTE ATOM)
(CADR (CADR X))))
(CAR X)))
(T (QUOTE IGNOREMACRO)))))
(PUTPROPS \TESTBITS DMACRO ((X N FD)
(NEQ 0 (\GETBITS X N FD))))
(DEFINEQ
(COMPILEDFETCHFIELD
[LAMBDA (X FASTFLG) (* lmm "19-Dec-84 16:10")
(COND
((EQ (CAR (LISTP (CAR X)))
(QUOTE QUOTE))
([LAMBDA (DESCRIPTOR DATUM)
(PROG (TYPENAME)
[COND
((AND (NOT FASTFLG)
(SETQ TYPENAME (fetch fdTypeName of DESCRIPTOR)))
(SETQ DATUM (LIST (FUNCTION \DTEST)
DATUM
(KWOTE TYPENAME]
(RETURN
(SELECTQ (fetch fdType of DESCRIPTOR)
((POINTER XPOINTER FULLPOINTER FULLXPOINTER)
(LIST (QUOTE \GETBASEPTR)
DATUM
(fetch fdOffset of DESCRIPTOR)))
(SWAPPEDXPOINTER
(BQUOTE ([OPENLAMBDA (D)
(\VAG2 (\GETBASE D %, (ADD1 (fetch fdOffset of DESCRIPTOR)
))
(\GETBASE D %, (fetch fdOffset of DESCRIPTOR]
%, DATUM)))
(FLOATP (BQUOTE (\GETBASEFLOATP %, DATUM %, (fetch fdOffset of DESCRIPTOR))))
(FIXP (BQUOTE (\GETBASEFIXP %, DATUM %, (fetch fdOffset of DESCRIPTOR))))
(SWAPPEDFIXP (BQUOTE ([OPENLAMBDA (D)
(\MAKENUMBER (\GETBASE D %,
(ADD1 (fetch fdOffset
of DESCRIPTOR)))
(\GETBASE D %, (fetch fdOffset of
DESCRIPTOR
]
%, DATUM)))
(PROG ((FT (fetch fdType of DESCRIPTOR))
(OFF (fetch fdOffset of DESCRIPTOR)))
(RETURN (SELECTQ (CAR FT)
(BITS (LIST (QUOTE \GETBITS)
DATUM OFF (CDR FT)))
(SIGNEDBITS [BQUOTE (SIGNED (\GETBITS %, DATUM %, OFF %,
(CDR FT))
%,
(BitFieldWidth (CDR FT])
(FLAGBITS (LIST (QUOTE \TESTBITS)
DATUM OFF (CDR FT)))
(LONGBITS (BQUOTE ([OPENLAMBDA (D)
(\MAKENUMBER (\GETBITS D %, OFF %,
(CDR FT))
(\GETBASE D %, (ADD1 OFF]
%, DATUM)))
(SHOULDNT]
(CADAR X)
(CADR X)))
(T (QUOTE IGNOREMACRO])
(COMPILEDREPLACEFIELD
[LAMBDA (X FASTFLG RPLVALFLG) (* lmm "19-Dec-84 16:12")
(* compile code for replacing field
values. Goes to great length to ensure
that the coerced value is returned)
(COND
((EQ (CAR (LISTP (CAR X)))
(QUOTE QUOTE))
([LAMBDA (DESCRIPTOR DATUM NEWVALUE)
(PROG ((TYPENAME (fetch fdTypeName of DESCRIPTOR))
(FT (fetch fdType of DESCRIPTOR))
(OFFSET (fetch fdOffset of DESCRIPTOR)))
[COND
((AND (NOT FASTFLG)
TYPENAME)
(SETQ DATUM (LIST (FUNCTION \DTEST)
DATUM
(KWOTE TYPENAME]
(RETURN (SELECTQ FT
((POINTER FULLPOINTER)
(LIST (FUNCTION \RPLPTR)
DATUM OFFSET NEWVALUE))
(XPOINTER (LIST (FUNCTION PUTBASEPTRX)
DATUM OFFSET NEWVALUE))
(FULLXPOINTER (LIST (QUOTE \PUTBASEPTR)
DATUM OFFSET NEWVALUE))
(SWAPPEDXPOINTER
(BQUOTE ((OPENLAMBDA (D R)
(\PUTBASE D %, OFFSET (\LOLOC R))
(\PUTBASE D %, (ADD1 OFFSET)
(\HILOC R))
R)
%, DATUM %, NEWVALUE)))
(FIXP (BQUOTE (\PUTBASEFIXP %, DATUM %, OFFSET %, NEWVALUE)))
(SWAPPEDFIXP (BQUOTE (\PUTSWAPPEDFIXP (\ADDBASE %, DATUM %, OFFSET)
%, NEWVALUE)))
(FLOATP (BQUOTE (\PUTBASEFLOATP %, DATUM %, OFFSET %, NEWVALUE)))
(SELECTQ (CAR FT)
(BITS (LIST (QUOTE \PUTBITS)
DATUM OFFSET (CDR FT)
NEWVALUE))
(LONGBITS (LIST (SUBPAIR (QUOTE (OFFSET FT))
(LIST OFFSET (CDR FT))
(QUOTE (OPENLAMBDA (D V)
(\PUTBITS D OFFSET FT
(\HINUM V))
(\PUTBASE D (ADD1 OFFSET)
(\LONUM V))
V)))
DATUM NEWVALUE))
(SIGNEDBITS [BQUOTE (SIGNED [\PUTBITS %, DATUM %, OFFSET %,
(CDR FT)
(UNSIGNED %, NEWVALUE %,
(BitFieldWidth
(CDR FT]
%,
(BitFieldWidth (CDR FT])
(FLAGBITS (BQUOTE (NEQ (\PUTBITS %, DATUM %, OFFSET %, (CDR FT)
(COND
(%, NEWVALUE %, (BitFieldMask
(CDR FT)))
(T 0)))
0)))
(RETURN (QUOTE IGNOREMACRO]
(CADAR X)
(CADR X)
(CADDR X)))
(T (QUOTE IGNOREMACRO])
(COMPILEDTYPENAMEP
(LAMBDA (X) (* lmm "15-MAY-80 07:41")
(PROG ((TNAME (CADR X)))
(RETURN (CONS (QUOTE EQ)
(COND
((AND (EQ (CAR TNAME)
(QUOTE QUOTE))
(NOT (FMEMB (CADR TNAME)
(QUOTE (CCODEP HARRAYP ARRAYP)))))
(LIST (LIST (QUOTE NTYPX)
(CAR X))
(\TYPEGLOBALVARIABLE (CADR TNAME))))
(T (CONS (LIST (QUOTE TYPENAME)
(CAR X))
(CDR X)))))))))
(COMPILEDNCREATE
[LAMBDA (X) (* lmm " 9-DEC-81 11:20")
(* compiles code for NCREATEs.
Exists to eliminate the call to
\TYPENUMBERFROMNAME.)
(COND
[(EQ (CAR (LISTP (CAR X)))
(QUOTE QUOTE))
(COND
[(NULL (CADR X))
(LIST (QUOTE CREATECELL)
(\TYPEGLOBALVARIABLE (CADAR X]
(T (LIST (QUOTE NCREATE2)
(\TYPEGLOBALVARIABLE (CADAR X))
(CADR X]
(T (QUOTE IGNOREMACRO])
)
(* ;; "AFTER ONE SYSTEM RECOMPILE FROM SEP 16, REMOVE COMPILEDTYPENAMEP")
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(RECORD FldDsc (fdTypeName fdOffset fdType))
]
(* END EXPORTED DEFINITIONS)
)
(RPAQQ DATATYPEFIELDTYPES ((FLOATP 0.0)
(FIXP 0)
(SWAPPEDFIXP 0)
(POINTER NIL)
(XPOINTER NIL)
(FULLPOINTER NIL)
(FULLXPOINTER NIL)
(SWAPPEDXPOINTER NIL)
(FLAG NIL)
(BYTE 0)
(WORD 0)
(SIGNEDWORD 0)))
(* Macros which convert a record access form into an address-generating form)
(DECLARE: EVAL@COMPILE
(PUTPROPS LOCF DMACRO (X (TRANSLATE.LOCF X)))
(PUTPROPS INDEXF DMACRO (X (TRANSLATE.LOCF X T)))
)
(DEFINEQ
(TRANSLATE.LOCF
[LAMBDA (ARGS INDEXONLY) (* lmm " 1-May-86 04:39")
(DECLARE (GLOBALVARS CLISPARRAY))
(PROG ((FORM (MKPROGN ARGS))
NEWFORM OFFSET SPEC)
RETRY
[SELECTQ (CAR (LISTP FORM))
(PROGN (COND
((NOT (CDDR FORM)) (* get rid of extra PROGN's inserted
by record package)
(SETQ FORM (CADR FORM))
(GO RETRY))))
((FETCHFIELD FFETCHFIELD)
[COND
((AND (SETQ OFFSET (LISTP (CADR FORM)))
(EQ (CAR OFFSET)
(QUOTE QUOTE))
[SETQ OFFSET (CADR (SETQ SPEC (CADR OFFSET]
(FIXP OFFSET))
(RETURN (COND
(INDEXONLY OFFSET)
((EQ OFFSET 0)
(CADDR FORM))
(T (SETQ FORM (CADDR FORM))(* loop in order to merge \ADDBASEs.
Should actually be done by compiler
optimization, but apparently that is
currently broken)
[repeatwhile (SELECTQ (CAR (LISTP FORM))
(PROGN (COND
((NULL (CDDR FORM))
(SETQ FORM (CADR FORM))
T)))
((ADDBASE \ADDBASE)
(COND
((FIXP (CADDR FORM))
(add OFFSET (CADDR FORM))
(SETQ FORM (CADR FORM))
T)))
(COND
((NEQ (SETQ NEWFORM (MACROEXPAND-1 FORM))
FORM)
(SETQ FORM NEWFORM)
T]
(LIST (QUOTE \ADDBASE)
FORM OFFSET])
(COND
((NEQ FORM (SETQ FORM (MACROEXPAND-1 FORM)))
(GO RETRY]
(ERROR "LOCF Can't figure out this argument" ARGS)
(RETURN (QUOTE IGNOREMACRO])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS DTDECLARE COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1584 14065 (/DECLAREDATATYPE 1594 . 2349) (DECLAREDATATYPE 2351 . 3952) (
TRANSLATE.DATATYPE 3954 . 12409) (\REUSETO 12411 . 12869) (\TYPEGLOBALVARIABLE 12871 . 14063)) (14066
15208 (BitFieldMask 14076 . 14230) (BitFieldShift 14232 . 14446) (BitFieldShiftedMask 14448 . 14764) (
MakeBitField 14766 . 14933) (BitFieldWidth 14935 . 15074) (BitFieldFirst 15076 . 15206)) (16570 26258
(COMPILEDFETCHFIELD 16580 . 20183) (COMPILEDREPLACEFIELD 20185 . 24706) (COMPILEDTYPENAMEP 24708 .
25502) (COMPILEDNCREATE 25504 . 26256)) (27218 30274 (TRANSLATE.LOCF 27228 . 30272)))))
STOP