(FILECREATED "30-Nov-83 11:35:52" {PHYLUM}<LISPCORE>SOURCES>DTDECLARE.;16 19687
changes to: (FNS TRANSLATE.LOCF)
previous date: "13-NOV-83 07:47:45" {PHYLUM}<LISPCORE>SOURCES>DTDECLARE.;14)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT DTDECLARECOMS)
(RPAQQ DTDECLARECOMS ((* declaring DATATYPES - part of ABC too)
(FNS /DECLAREDATATYPE DECLAREDATATYPE \REUSETO \TYPEGLOBALVARIABLE)
(FNS BitFieldMask BitFieldShift BitFieldShiftedMask MakeBitField BitFieldWidth
BitFieldFirst)
(PROP DMACRO FETCHFIELD FFETCHFIELD REPLACEFIELD FREPLACEFIELD REPLACEFIELDVAL
FREPLACEFIELDVAL TYPENAMEP NCREATE \DTEST \TESTBITS)
(FNS COMPILEDFETCHFIELD COMPILEDREPLACEFIELD COMPILEDTYPENAMEP COMPILEDNCREATE)
(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 FLG) (* JonL "13-NOV-83 07:42")
(PROG ((PREV (AND TYPENAME (NOT FLG)
(GETFIELDSPECS TYPENAME)))
DLIST ONTYPX)
(AND LISPXHIST TYPENAME (UNDOSAVE (LIST (QUOTE /DECLAREDATATYPE)
TYPENAME PREV)))
(SELECTQ (SYSTEMTYPE)
(D (AND PREV (SETQ ONTYPX (\TYPENUMBERFROMNAME TYPENAME))))
NIL)
(SETQ DLIST (DECLAREDATATYPE TYPENAME FIELDSPECS FLG))
(if PREV
then (* Non-null PREV implies non-null TYPENAME)
(OR (SELECTQ (SYSTEMTYPE)
(D (IEQP ONTYPX (\TYPENUMBERFROMNAME TYPENAME)))
(EQUAL FIELDSPECS PREV))
(LISPXPRINT (LIST (QUOTE datatype)
TYPENAME
(QUOTE redeclared))
T T)))
(RETURN DLIST))))
(DECLAREDATATYPE
(LAMBDA (TYPENAME FIELDSPECS FLG) (* DECLARATIONS: (RECORD SPEC
(N LEN . FD)))
(DECLARE (SPECVARS TYPENAME UNUSED BIT OFFSET FD)) (* JonL "13-NOV-83 06:34")
(* Assigns fields with in a block of storage for a data
type.)
(if FLG
then (if (EQ FLG (QUOTE ARRAY))
then (ERROR (QUOTE ARRAYBLOCK)
"not implemented in Interlisp-D"))
else (if (OR (NOT TYPENAME)
(NOT (LITATOM TYPENAME))
(EQ TYPENAME (QUOTE **DEALLOC**)))
then (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
FULLXPOINTER)
32)
(FLAG (SETQQ S FLAGBITS)
1)
(BYTE (SETQQ S BITS)
8)
(WORD (SETQQ S BITS)
16)
(SIGNEDWORD (SETQQ S SIGNEDBITS)
16)
(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))))
(* (OR (NULL TYPENAME) (SORT DLIST (FUNCTION (LAMBDA (X Y) (IGREATERP (fetch LEN of X) (fetch LEN of Y))))))
Allocating largest fields first will give a reasonable packing)
(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 (ZEROP (LOGAND (CAR X)
1))
(IGEQ (CADDR X)
8)
(EQ (IPLUS (CADR X)
(CADDR X))
16)
(find Y in UNUSED
suchthat (AND (EQ (CAR Y)
(ADD1 (CAR X)))
(EQ (CADDR Y)
16))))))
(* unused 24 bit quantity)
(HELP)))
(COND
((IGREATERP BIT 8) (* Less than 8 bits left in this word)
(\REUSETO 16)))
(COND
((NEQ (LOGAND OFFSET 1)
0) (* not on double word boundary)
(\REUSETO 16)))
(COND
((NEQ BIT 8)
(\REUSETO 8 (EQ BIT 0))))
(SETQ BIT 0)
(PROG1 OFFSET (add OFFSET 2)))
((FIXP SWAPPEDFIXP FLOATP)
(* 32 bit quantities)
(COND
((NEQ BIT 0)
(\REUSETO 16)))
(PROG1 OFFSET (add OFFSET 2)))
((FULLPOINTER FULLXPOINTER)
(* 32 bit doubleword-aligned quantities)
(COND
((NEQ BIT 0)
(\REUSETO 16)))
(COND
((NEQ (LOGAND OFFSET 1)
0)
(HELP)
(\REUSETO 16)))
(PROG1 OFFSET (add OFFSET 2)))
((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 16) (* more than 1 word -
Must right justify first word)
(SETQ LEN (IDIFFERENCE LEN 16))
(COND
((IGREATERP LEN (IDIFFERENCE 16 BIT))
(\REUSETO 16)))
(COND
((NEQ (IDIFFERENCE 16 BIT)
LEN)
(\REUSETO (IDIFFERENCE 16 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 16 BIT))
(\REUSETO 16)))
(replace fdType of FD with (CONS (fetch fdType of FD)
(MakeBitField BIT LEN)))
(add BIT LEN)
(PROG1 OFFSET (COND
((EQ BIT 16)
(SETQ BIT 0)
(add OFFSET 1)))))))
(SHOULDNT))))
(COND
((IGREATERP OFFSET \MDSIncrement)
(ERROR TYPENAME "DATATYPE TOO BIG"))
((ILEQ OFFSET 1)
(SETQ OFFSET 2))
((NOT (ZEROP (LOGAND OFFSET 1)))
(SETQ OFFSET (ADD1 OFFSET))))
(* (AND TYPENAME (SORT DLIST (FUNCTION (LAMBDA (X Y) (ILESSP (fetch N of X) (fetch N of Y)))))))
(SETQ DLIST (MAPCAR DLIST (FUNCTION (LAMBDA (X)
(fetch FD of X)))))
(COND
((AND TYPENAME (SELECTQ (SYSTEMTYPE)
(D T)
NIL))
(SETTOPVAL (\TYPEGLOBALVARIABLE TYPENAME)
(ASSIGNDATATYPE TYPENAME DLIST OFFSET FIELDSPECS
(for P in DLIST when (SELECTQ (fetch fdType of P)
((POINTER FULLPOINTER)
T)
NIL)
collect (fetch fdOffset of P))))))
(RETURN DLIST))))
(\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) (* lmm "15-MAY-80 11:18")
(* returns a constant or a variable which contains the datatype number of TYPE. 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.)
(SELECTQ TYPENAME
(SMALLP (QUOTE \SMALLP))
(FIXP (QUOTE \FIXP))
(FLOATP (QUOTE \FLOATP))
(LITATOM (QUOTE \LITATOM))
(LISTP (QUOTE \LISTP))
(ARRAYP (QUOTE \ARRAYP))
(STRINGP (QUOTE \STRINGP))
(STACKP (QUOTE \STACKP))
(VMEMPAGEP (QUOTE \VMEMPAGEP))
(PROG ((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)))
(RETURN 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 TYPENAMEP DMACRO (X (COMPILEDTYPENAMEP X)))
(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)
(NOT (ZEROP (\GETBITS X N FD])
(DEFINEQ
(COMPILEDFETCHFIELD
[LAMBDA (X FASTFLG) (* edited: " 3-JUN-83 18:26")
(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)))
(FLOATP (LIST [LIST (QUOTE OPENLAMBDA)
(QUOTE (D))
(LIST (QUOTE MAKEFLOATNUMBER)
(LIST (QUOTE \GETBASE)
(QUOTE D)
(fetch fdOffset of DESCRIPTOR))
(LIST (QUOTE \GETBASE)
(QUOTE D)
(ADD1 (fetch fdOffset of DESCRIPTOR]
DATUM))
(FIXP (LIST [LIST (QUOTE OPENLAMBDA)
(QUOTE (D))
(LIST (QUOTE \MAKENUMBER)
(LIST (QUOTE \GETBASE)
(QUOTE D)
(fetch fdOffset of DESCRIPTOR))
(LIST (QUOTE \GETBASE)
(QUOTE D)
(ADD1 (fetch fdOffset of DESCRIPTOR]
DATUM))
(SWAPPEDFIXP (LIST [LIST (QUOTE OPENLAMBDA)
(QUOTE (D))
(LIST (QUOTE \MAKENUMBER)
(LIST (QUOTE \GETBASE)
(QUOTE D)
(ADD1 (fetch fdOffset of DESCRIPTOR)
))
(LIST (QUOTE \GETBASE)
(QUOTE 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 (LIST (QUOTE SIGNED)
(LIST (QUOTE \GETBITS)
DATUM OFF (CDR FT))
(BitFieldWidth (CDR FT]
(FLAGBITS (LIST (QUOTE \TESTBITS)
DATUM OFF (CDR FT)))
(LONGBITS
(LIST [LIST (QUOTE OPENLAMBDA)
(QUOTE (D))
(LIST (QUOTE \MAKENUMBER)
(LIST (QUOTE \GETBITS)
(QUOTE D)
OFF
(CDR FT))
(LIST (QUOTE \GETBASE)
(QUOTE D)
(ADD1 OFF]
DATUM))
(SHOULDNT]
(CADAR X)
(CADR X)))
(T (QUOTE IGNOREMACRO])
(COMPILEDREPLACEFIELD
[LAMBDA (X FASTFLG RPLVALFLG) (* edited: " 3-JUN-83 18:31")
(* 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))
(FIXP (LIST (FUNCTION \PUTFIXP)
(LIST (QUOTE \ADDBASE)
DATUM OFFSET)
NEWVALUE))
(SWAPPEDFIXP (LIST (FUNCTION \PUTSWAPPEDFIXP)
(LIST (QUOTE \ADDBASE)
DATUM OFFSET)
NEWVALUE))
(FLOATP (LIST (QUOTE PutFloat)
(LIST (QUOTE \ADDBASE)
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 (LIST (QUOTE SIGNED)
[LIST (QUOTE \PUTBITS)
DATUM OFFSET (CDR FT)
(LIST (QUOTE UNSIGNED)
NEWVALUE
(BitFieldWidth
(CDR FT]
(BitFieldWidth (CDR FT]
(FLAGBITS
(LIST (QUOTE NEQ)
(LIST (QUOTE \PUTBITS)
DATUM OFFSET (CDR FT)
(LIST (QUOTE COND)
(LIST NEWVALUE (BitFieldMask
(CDR FT)))
(LIST 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])
)
(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)
(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) (* bvm: "30-Nov-83 11:12")
(DECLARE (GLOBALVARS CLISPARRAY))
(PROG ((FORM (DWIMIFY (CONS (QUOTE PROGN)
ARGS)
T))
NEWFORM OFFSET SPEC) (* The DWIMIFY should convert a record access into some
kind of fetch.)
RETRY
[SELECTQ (CAR 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)
((ZEROP OFFSET)
(CADDR FORM))
(T (SETQ FORM (CADDR FORM))
[repeatwhile (SELECTQ (CAR (LISTP FORM))
[PROGN (COND
((NULL (CDDR FORM))
(SETQ FORM (CADR FORM]
[(ADDBASE \ADDBASE)
(COND
((FIXP (CADDR FORM))
(add OFFSET (CADDR FORM))
(SETQ FORM (CADR FORM]
(COND
([SETQ NEWFORM
(OR (GETHASH FORM CLISPARRAY)
(COND
((NEQ FORM
(SETQ NEWFORM
(EXPANDMACRO FORM T)))
(* Be sure any macros are expanded)
(DWIMIFY NEWFORM T]
(SETQ FORM NEWFORM]
(LIST (QUOTE \ADDBASE)
FORM OFFSET]
(COND
([SETQ FORM (OR (GETHASH FORM CLISPARRAY)
(COND
((NEQ FORM (SETQ FORM (EXPANDMACRO FORM T)))
(* Be sure any macros are expanded)
(DWIMIFY FORM T]
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1115 9058 (/DECLAREDATATYPE 1125 . 1977) (DECLAREDATATYPE 1979 . 7640) (\REUSETO 7642
. 8036) (\TYPEGLOBALVARIABLE 8038 . 9056)) (9059 9937 (BitFieldMask 9069 . 9191) (BitFieldShift 9193
. 9354) (BitFieldShiftedMask 9356 . 9596) (MakeBitField 9598 . 9726) (BitFieldWidth 9728 . 9835) (
BitFieldFirst 9837 . 9935)) (10971 16909 (COMPILEDFETCHFIELD 10981 . 13503) (COMPILEDREPLACEFIELD
13505 . 15942) (COMPILEDTYPENAMEP 15944 . 16412) (COMPILEDNCREATE 16414 . 16907)) (17537 19544 (
TRANSLATE.LOCF 17547 . 19542)))))
STOP