(FILECREATED " 5-Oct-84 12:16:00" {ERIS}<LISPCORE>LIBRARY>MESATYPES.;3 12697
changes to: (VARS MESATYPESCOMS)
previous date: "18-Apr-84 21:15:31" {ERIS}<LISPCORE>LIBRARY>MESATYPES.;2)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MESATYPESCOMS)
(RPAQQ MESATYPESCOMS ((* Defines three new record types: MESATYPE, MESARECORD, and MESAARAY. Also
provides a number of macros to manipulate objects of these record types.
None of this package need be present in the compiled version of a client
package.)
(* Public stuff)
(MACROS MESASIZE MESASETQ MESAEQUAL FMESAELT MESAELT MESASETA)
(PROP ARGNAMES MESASIZE MESASETQ MESAEQUAL FMESAELT MESAELT MESASETA)
(* Private stuff)
(INITVARS (\MESATYPES (HASHARRAY 20)))
(P (pushnew CLISPRECORDTYPES (QUOTE MESATYPE))
(pushnew CLISPRECORDTYPES (QUOTE MESARECORD))
(pushnew CLISPRECORDTYPES (QUOTE MESAARRAY))
(MOVD (QUOTE RECORD)
(QUOTE MESATYPE))
(MOVD (QUOTE RECORD)
(QUOTE MESARECORD))
(MOVD (QUOTE RECORD)
(QUOTE MESAARRAY)))
(PROP USERRECORDTYPE MESATYPE MESARECORD MESAARRAY)
(FNS MESATYPEFN MESARECORDFN MesaRecordFields MesaRecordSubblock
MesaRecordCreateMethod MESAARRAYFN MesaArrayOffsets MesaArrayFindOffset
RemoveLast)))
(* Defines three new record types: MESATYPE, MESARECORD, and MESAARAY. Also provides a number
of macros to manipulate objects of these record types. None of this package need be present in
the compiled version of a client package.)
(* Public stuff)
(DECLARE: EVAL@COMPILE
(PUTPROPS MESASIZE MACRO [args (PROG ((recordName (CAR args)))
(* Returns the size of record recordName)
(RETURN (EVAL (BQUOTE (INDEXF (fetch (, recordName
THISISTHELASTFIELD)
of T])
(PUTPROPS MESASETQ MACRO [args (PROG ((a (CAR args))
(b (CADR args))
(type (CADDR args)))
(* Copies the contents of "b" into "a" Returns a. Should be used to translate statement of the form "a ← b;"
when a and b are neither numbers nor pointers. A safer (ie, more correct) way to do this would be to say
"(foreach field f in type st f has both a fetch and a replace method do (replace (type f) of a with (fetch (type f) of b)))")
(RETURN (BQUOTE (\BLT , a , b (MESASIZE , type])
(PUTPROPS MESAEQUAL MACRO [args (PROG ((a (CAR args))
(b (CADR args))
(type (CADDR args)))
(* Compares a and b for equality, where a and b are
instances of record type. a and b can be multiple words
long.)
(RETURN (BQUOTE (for word from 0
to (SUB1 (MESASIZE , type))
always (EQ (\GETBASE , a word)
(\GETBASE , b word])
(PUTPROPS FMESAELT MACRO [args
(PROG ((array (CAR args))
(arrayType (CADR args))
(indexes (CDDR args))
indexRangeList indexOffsetList)
(* Returns a pointer to the indicated element of array. Unsafe, because it returns a pointer to the middle of the
structure, which would confuse the garbage collector if you held onto the element pointer longer than the array
pointer.)
[SETQ indexRangeList (EVAL (BQUOTE (fetch (, arrayType INDEXLIST) of T]
[SETQ indexOffsetList (EVAL (BQUOTE (fetch (, arrayType OFFSETLIST) of T]
(RETURN (LIST (QUOTE \ADDBASE)
array
(CONS (QUOTE IPLUS)
(for index in indexes as indexRange in indexRangeList
as offset in indexOffsetList
collect (BQUOTE ([OPENLAMBDA
(index)
(OR (AND (ILEQ , (CAR indexRange)
index)
(ILEQ index , (CDR indexRange)))
(ERROR (QUOTE indexOutOfRange)))
(ITIMES , offset (IDIFFERENCE
index , (CAR indexRange]
, index])
(PUTPROPS MESAELT MACRO [args (PROG ((arrayType (CADR args))
elementType)
(* Returns the selected element of the array. Copies it into a freshly allocated box to avoid returning a pointer to
the middle of the structure, which might confuse the garbage collector.)
[SETQ elementType (EVAL (BQUOTE (fetch (, arrayType ELEMENTTYPE)
of T]
(RETURN (BQUOTE (MESASETQ (create , elementType)
,
(CONS (QUOTE FMESAELT)
args)
, elementType])
(PUTPROPS MESASETA MACRO [args (PROG ((eltArgs (RemoveLast args))
(arrayType (CADR args))
(newValue (CAR (LAST args)))
elementType) (* Replaces the index'th element of array, provided
that array is a contiguous run of objects of type
elementType)
[SETQ elementType (EVAL (BQUOTE (fetch (, arrayType ELEMENTTYPE)
of T]
(RETURN (BQUOTE (MESASETQ , (CONS (QUOTE FMESAELT)
eltArgs)
, newValue , elementType])
)
(PUTPROPS MESASIZE ARGNAMES (recordName))
(PUTPROPS MESASETQ ARGNAMES (a b type))
(PUTPROPS MESAEQUAL ARGNAMES (a b type))
(PUTPROPS FMESAELT ARGNAMES (array arrayType index1 ... indexn))
(PUTPROPS MESAELT ARGNAMES (array arrayType index1 ... indexn))
(PUTPROPS MESASETA ARGNAMES (array arrayType index1 ... indexn newValue))
(* Private stuff)
(RPAQ? \MESATYPES (HASHARRAY 20))
(pushnew CLISPRECORDTYPES (QUOTE MESATYPE))
(pushnew CLISPRECORDTYPES (QUOTE MESARECORD))
(pushnew CLISPRECORDTYPES (QUOTE MESAARRAY))
(MOVD (QUOTE RECORD)
(QUOTE MESATYPE))
(MOVD (QUOTE RECORD)
(QUOTE MESARECORD))
(MOVD (QUOTE RECORD)
(QUOTE MESAARRAY))
(PUTPROPS MESATYPE USERRECORDTYPE MESATYPEFN)
(PUTPROPS MESARECORD USERRECORDTYPE MESARECORDFN)
(PUTPROPS MESAARRAY USERRECORDTYPE MESAARRAYFN)
(DEFINEQ
(MESATYPEFN
[LAMBDA (typeDecl) (* hts: "24-Mar-84 19:46")
(PROG ((typeName (CADR typeDecl))
(isType (CADDR typeDecl))
(rest (CDDDR typeDecl)))
(RETURN (NCONC (LIST (QUOTE MESARECORD)
typeName
(LIST (CONS (QUOTE DATA)
isType)))
rest])
(MESARECORDFN
[LAMBDA (recordDecl) (* edited: "31-Mar-84 16:34")
(* Translates a MESARECORD declaration into a
BLOCKRECORD.)
(* For each multi-word (gt 2) field, creates a special fetch method that returns a pointer to the beginning of the
field, and a replace method that uses \BLT to copy over the entire field. This is done by replacing the fieldname
with fieldnameSTARTOFTHISFIELD and making the fetch method for fieldname be a LOCF on fieldnameSTARTOFTHISFIELD)
(* Note that a field can be declared to be a multi-word field by saying either (fieldname N WORD) or
(fieldname mumble), where mumble is a previously defined MESARECORD.)
(* Also includes a CREATE method for the type. if the user has not already done so. (Uses \ALLOCBLOCK.
The messy-looking arithmetic is because MESASIZE returns the size of a record in words, and \ALLOCBLOCK's arg
specifies the # of pointer cells (2 words each) to allocate))
(PROG ((recordName (CADR recordDecl))
(fieldDeclarations (CADDR recordDecl))
(subblocks (CONS))
(rest (CDDDR recordDecl)))
(RETURN (PROG1 (NCONC [LIST (QUOTE BLOCKRECORD)
recordName
(NCONC (MesaRecordFields fieldDeclarations)
(LIST (QUOTE (THISISTHELASTFIELD WORD]
(CAR subblocks)
(MesaRecordCreateMethod recordName rest)
rest)
(PUTHASH recordName T \MESATYPES) (* Record that recordName is a new MESARECORD)
])
(MesaRecordFields
[LAMBDA (fieldDeclarations) (* hts: "29-Mar-84 18:04")
(for field in fieldDeclarations collect (if [AND (CAR field)
(OR (GETHASH (CADR field)
\MESATYPES)
(AND (EQ (CADDR field)
(QUOTE WORD))
(FIXP (CADR field))
(IGREATERP (CADR field)
2]
then (TCONC subblocks (MesaRecordSubblock recordName
field))
(LIST (PACK* (CAR field)
(QUOTE STARTOFTHISFIELD))
[OR (FIXP (CADR field))
(EVAL (BQUOTE (MESASIZE ,
(CADR field]
(QUOTE WORD))
else field])
(MesaRecordSubblock
[LAMBDA (recordName fieldDeclaration) (* hts: "29-Mar-84 18:05")
(* Returns the appropriate accessfn declaration to make
fieldDeclaration a multi-word subblock.)
(PROG ((fieldName (CAR fieldDeclaration))
(fieldSize (CADR fieldDeclaration)))
[OR (FIXP fieldSize)
(SETQ fieldSize (EVAL (BQUOTE (MESASIZE , fieldSize]
(RETURN (LIST (QUOTE ACCESSFNS)
(LIST fieldName (LIST (QUOTE LOCF)
(LIST (QUOTE fetch)
(LIST recordName (PACK* fieldName (QUOTE
STARTOFTHISFIELD)))
(QUOTE of)
(QUOTE DATUM)))
(LIST (QUOTE PROGN)
(LIST (QUOTE \BLT)
(LIST (QUOTE fetch)
(LIST recordName fieldName)
(QUOTE of)
(QUOTE DATUM))
(QUOTE NEWVALUE)
fieldSize)
(QUOTE NEWVALUE])
(MesaRecordCreateMethod
[LAMBDA (recordName rest) (* edited: "31-Mar-84 16:31")
(* Returns a create method for the type, if the user has
not already done so.)
(if (for thing in rest thereis (EQ (QUOTE CREATE)
(CAR thing)))
then NIL
else (LIST (BQUOTE (CREATE (\ALLOCBLOCK (LRSH (ADD1 (MESASIZE , recordName))
1])
(MESAARRAYFN
[LAMBDA (arrayDecl) (* hts: "18-Apr-84 14:21")
(PROG ((arrayName (CADR arrayDecl))
(indexDeclarations (CADDR arrayDecl))
(elementType (CADDDR arrayDecl))
(rest (CDDDDR arrayDecl))
arrayOffsets)
[SETQ indexDeclarations (for indexDecl in indexDeclarations
collect (CONS (EVAL (CAR indexDecl))
(EVAL (CADR indexDecl]
(* Evaluate arraybounds so that they can be expressions
rather than integers.)
(SETQ arrayOffsets (MesaArrayOffsets indexDeclarations elementType))
(RETURN (APPEND [BQUOTE (MESARECORD , arrayName ((DATA , (MesaArrayFindOffset
indexDeclarations
arrayOffsets
elementType)
WORD))
(ACCESSFNS ((INDEXLIST (QUOTE , indexDeclarations))
(OFFSETLIST (QUOTE , arrayOffsets))
(ELEMENTTYPE (QUOTE , elementType]
rest])
(MesaArrayOffsets
[LAMBDA (indexDeclarations elementType) (* hts: "24-Mar-84 20:15")
(if (NULL indexDeclarations)
then NIL
else (PROG ((restOfOffsets (MesaArrayOffsets (CDR indexDeclarations)
elementType)))
(RETURN (CONS (MesaArrayFindOffset (CDR indexDeclarations)
restOfOffsets elementType)
restOfOffsets])
(MesaArrayFindOffset
[LAMBDA (indexDeclarations arrayOffsets elementType) (* hts: "18-Apr-84 14:29")
(if indexDeclarations
then (ITIMES (ADD1 (IDIFFERENCE (CDAR indexDeclarations)
(CAAR indexDeclarations)))
(CAR arrayOffsets))
else (EVAL (BQUOTE (MESASIZE , elementType])
(RemoveLast
[LAMBDA (list) (* hts: "26-Mar-84 00:04")
(PROG ((newList (COPY list))
length)
(SETQ length (LENGTH newList))
(if (ILEQ length 1)
then (RETURN NIL)
else (RPLACD (FNTH newList (SUB1 length)))
(RETURN newList])
)
(PUTPROPS MESATYPES COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (6382 12617 (MESATYPEFN 6392 . 6729) (MESARECORDFN 6731 . 8364) (MesaRecordFields 8366
. 9074) (MesaRecordSubblock 9076 . 10012) (MesaRecordCreateMethod 10014 . 10510) (MESAARRAYFN 10512
. 11551) (MesaArrayOffsets 11553 . 11960) (MesaArrayFindOffset 11962 . 12284) (RemoveLast 12286 .
12615)))))
STOP