(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