(FILECREATED " 2-Jul-84 16:30:12" {ERIS}<LISPCORE>SOURCES>DTDECLARE.;5 20092  

      changes to:  (FNS DECLAREDATATYPE)

      previous date: " 7-Jun-84 17:45:26" {ERIS}<LISPCORE>SOURCES>DTDECLARE.;3)


(* Copyright (c) 1981, 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)

(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 TRANSLATE.LOCF.EXPAND))
		      (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))       (* lmm " 2-Jul-84 16:20")
                                                             (* Assigns fields with in a block of storage for a data 
							     type.)
    [COND
      [FLG (COND
	     ((EQ FLG (QUOTE ARRAY))
	       (ERROR (QUOTE ARRAYBLOCK)
		      "not implemented in Interlisp-D"]
      (T (COND
	   ((OR (NOT TYPENAME)
		(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 (ZEROP (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"]

          (* (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
	    (TYPENAME (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)                                        (* lmm " 7-Jun-84 14:23")
    (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 ([OPENLAMBDA (D)
							  (MAKEFLOATNUMBER
							    (\GETBASE D , (fetch fdOffset
									     of DESCRIPTOR))
							    (\GETBASE D ,
								      (ADD1 (fetch fdOffset
									       of DESCRIPTOR]
					      , DATUM)))
			     (FIXP (BQUOTE ([OPENLAMBDA (D)
							(\MAKENUMBER (\GETBASE D ,
									       (fetch fdOffset
										  of DESCRIPTOR))
								     (\GETBASE D ,
									       (ADD1 (fetch fdOffset
											of DESCRIPTOR]
					    , DATUM)))
			     (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 " 7-Jun-84 14:26")
                                                             (* 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 (\PUTFIXP (\ADDBASE , DATUM , OFFSET)
							   , NEWVALUE)))
				   (SWAPPEDFIXP (BQUOTE (\PUTSWAPPEDFIXP (\ADDBASE , DATUM , OFFSET)
									 , NEWVALUE)))
				   (FLOATP (BQUOTE (PutFloat (\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
					      (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)                                   (* hts: " 4-Jun-84 15:45")
    (DECLARE (GLOBALVARS CLISPARRAY))
    (PROG ((FORM (MKPROGN ARGS))
	   NEWFORM OFFSET SPEC)                              (* The DWIMIFY should convert a record access into some 
							     kind of fetch.)
      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)
				   ((ZEROP OFFSET)
				     (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 (SETQ NEWFORM (TRANSLATE.LOCF.EXPAND
								    FORM))
								then (SETQ FORM NEWFORM)
								     T)))
				      (LIST (QUOTE \ADDBASE)
					    FORM OFFSET]
		   (COND
		     ((SETQ FORM (TRANSLATE.LOCF.EXPAND FORM))
		       (GO RETRY]
          (ERROR "LOCF Can't figure out this argument" ARGS)
          (RETURN (QUOTE IGNOREMACRO])

(TRANSLATE.LOCF.EXPAND
  [LAMBDA (FORM)                                             (* hts: " 4-Jun-84 15:45")
    (COND
      ((GETHASH FORM CLISPARRAY))
      ((GETPROP (CAR FORM)
		(QUOTE CLISPWORD))
	(DWIMIFY FORM T)
	(GETHASH FORM CLISPARRAY))
      ((NEQ FORM (SETQ FORM (EXPANDMACRO FORM T)))           (* Be sure any macros are expanded)
	FORM])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(PUTPROPS DTDECLARE COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1160 9234 (/DECLAREDATATYPE 1170 . 2022) (DECLAREDATATYPE 2024 . 7816) (\REUSETO 7818
 . 8212) (\TYPEGLOBALVARIABLE 8214 . 9232)) (9235 10113 (BitFieldMask 9245 . 9367) (BitFieldShift 9369
 . 9530) (BitFieldShiftedMask 9532 . 9772) (MakeBitField 9774 . 9902) (BitFieldWidth 9904 . 10011) (
BitFieldFirst 10013 . 10111)) (11147 17079 (COMPILEDFETCHFIELD 11157 . 13611) (COMPILEDREPLACEFIELD 
13613 . 16112) (COMPILEDTYPENAMEP 16114 . 16582) (COMPILEDNCREATE 16584 . 17077)) (17735 19944 (
TRANSLATE.LOCF 17745 . 19575) (TRANSLATE.LOCF.EXPAND 19577 . 19942)))))
STOP