(FILECREATED " 1-May-86 04:42:22" {ERIS}<LISPCORE>SOURCES>DTDECLARE.;15 22683  

      changes to:  (VARS DTDECLARECOMS)
                   (FNS TRANSLATE.LOCF)

      previous date: "27-Mar-86 12:44:15" {ERIS}<LISPCORE>SOURCES>DTDECLARE.;14)


(* 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 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 DLIST LEN SUPERTYPE)			   (* lmm 
									   "13-Mar-86 14:14")
    (PROG (ONTYPX DLIST)
      	  [AND LISPXHIST TYPENAME (UNDOSAVE (LIST (QUOTE /DECLAREDATATYPE)
						  TYPENAME
						  (GETFIELDSPECS TYPENAME)
						  NIL NIL (GETSUPERTYPE TYPENAME]
      	  (SETQ ONTYPX (\TYPENUMBERFROMNAME TYPENAME))
      	  (SETQ DLIST (DECLAREDATATYPE TYPENAME FIELDSPECS DLIST LEN SUPERTYPE))
      	  (if ONTYPX
	      then 							   (* Non-null PREV 
									   implies non-null 
									   TYPENAME)
		   (OR (EQUAL ONTYPX (\TYPENUMBERFROMNAME TYPENAME))
		       (LISPXPRINT (LIST (QUOTE datatype)
					 TYPENAME
					 (QUOTE redeclared))
			      T T)))
      	  (RETURN DLIST])

(DECLAREDATATYPE
  [LAMBDA (TYPENAME FIELDSPECS DLIST LENGTH SUPERTYPE)			   (* lmm 
									   "13-Mar-86 14:31")
									   (* 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 (if SUPERTYPE
			  then (GETFIELDSPECS SUPERTYPE]		   (* maybe an error if 
									   supertype doesn't 
									   exist?)
     	 (SETQ FIELDSPECS (APPEND SUPERSPECS FIELDSPECS))
     	 (if (AND FIELDSPECS (OR (NOT DLIST)
				 (NOT LENGTH)))
	     then 							   (* 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]
     	 (SETTOPVAL (\TYPEGLOBALVARIABLE TYPENAME)
		(\ASSIGNDATATYPE1 TYPENAME DLIST LENGTH FIELDSPECS PTRS SUPERTYPE))
     DLIST])

(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)               (* 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)
                            (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])
)
(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)))
                                                      (if (NEQ (SETQ NEWFORM (MACROEXPAND-1 FORM))
                                                               FORM)
                                                          then (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 (1457 10292 (/DECLAREDATATYPE 1467 . 2196) (DECLAREDATATYPE 2198 . 3368) (
TRANSLATE.DATATYPE 3370 . 8874) (\REUSETO 8876 . 9270) (\TYPEGLOBALVARIABLE 9272 . 10290)) (10293 
11171 (BitFieldMask 10303 . 10425) (BitFieldShift 10427 . 10588) (BitFieldShiftedMask 10590 . 10830) (
MakeBitField 10832 . 10960) (BitFieldWidth 10962 . 11069) (BitFieldFirst 11071 . 11169)) (12583 18632 
(COMPILEDFETCHFIELD 12593 . 14925) (COMPILEDREPLACEFIELD 14927 . 17665) (COMPILEDTYPENAMEP 17667 . 
18135) (COMPILEDNCREATE 18137 . 18630)) (19509 22525 (TRANSLATE.LOCF 19519 . 22523)))))
STOP