;; -*- Mode:LISP; Package:UA; Base:8 -*-
;;;     MICRO ASSEMBLER  FOR CADR

;TO COMPILE OR RUN ON THE LISP MACHINE, USE THE PACKAGE DEFINITION IN LCADR;UA PKG

(IF-FOR-LISPM		;These not used here anymore, but needed to read in QCOM.
 (DEFMACRO LOGLDB (PTR VAL) `(LDB ,PTR ,VAL)))
(IF-FOR-LISPM
 (DEFMACRO LOGDPB (NEWVAL PTR VAL) `(DPB ,NEWVAL ,PTR ,VAL)))

;SYMBOLS IN CONS-LAP:
; A SYMBOL IN CONS-LAP HAS AS ITS VALUE A PROGRAM!
;  THE PROGRAM IS EVALUATED BY RECURSIVE CALLS TO CONS-LAP-EVAL.
;  IF THE ARGUMENT TO CONS-LAP-EVAL IS NUMERIC, IT IS RETURNED AS THE VALUE.
;  IF NIL, THIS SPECIFIES THE NULL VALUE.
;  IF A SYMBOL, ITS VALUE IS RUN AS A PROGRAM AND RETURNED.
;  IF A LIST, CAR OF THE LISP IS THE FUNCTION AND THE REST OF THE LIST
;   ARGUMENTS, LISP STYLE.  UNLESS OTHERWISE NOTED BELOW, ALL FUNCTIONS
;   EVALUATE THEIR ARGS (LISP STYLE) AND ACTUALLY DO SOMETHING ONLY
;   AFTER THE EVALUATION OF THEIR ARGUMENTS HAS FINISHED.

;AVAILABLE FUNCTIONS:
; FUNCTIONS OF ONE ARGUMENT
;  SPECIFERS OF LOCALITY: A-MEM, M-MEM, I-MEM, D-MEM.
;	RETURN VALUE INDICATING THAT THEIR ARGUMENT CORRESPONDS TO AN
;	ADDRESS IN THE SPECIFIED MEMORY.
;  CONDITIONALS:  DESTINATION-P, SOURCE-P, DISPATCH-INSTRUCTION-P, JUMP-INSTRUCTION-P 
;       ALU-INSTRUCTION-P, BYTE-INSTRUCTION-P. EVALUATE AND RETURN ARGUMENT
;       ONLY IF SPECIFIED CONDITION TRUE (NAMELY: ASSEMBLING A DESTINATION FIELD,
;	A SOURCE FIELD, OR THE TYPE OF INSTRUCTION INDICATED). RETURN NIL
;	IF CONDITION FALSE. 
;  NEGATION: NOT. MUST BE NESTED WITH ONE OF THE CONDITIONALS ABOVE AS IS
;	(NOT (DESTINATION (...))).
;  OR. RETURNS FIRST NON-NIL VALUE LIKE LISP OR.
;  PLUS. COMBINES THE VALUES / PROPERTIES REPRESENTED BY ALL ITS ARGUMENTS.
;       USED TO BE TWO ARGS ONLY, NOW TAKES ANY NUMBER OF ARGS.
;  DIFFERENCE.  LIKEWISE.
;  INSTRUCTION-TYPE FORCE: FORCE-DISPATCH, FORCE-JUMP, FORCE-ALU, FORCE-BYTE.
;       FORCE-DISPATCH-OR-BYTE, FORCE-ALU-OR-BYTE.
;  DEFAULT-CONDITION.  DEFAULT-BTYE. IF DISPATCH IS FORCED, RETURN NIL.
;	OTHERWISE FORCE BYTE.
;  BYTE-FIELD <BITS BITS-OVER>. DEFAULTS BYTE-INSTRUCTION.  ERROR IF OTHER THAN
;	BYTE INSTRUCTION OR DISPATCH INSTRUCTION (OR IF A ONE BIT FIELD,
;	JUMP INSTRUCTION).  ASSEMBLES THE RIGHT THING
;	TO REFERENCE BYTE, AS PER WHAT INSTRUCTION TYPE IS.
;  LISP-BYTE <%% FORM BYTE SPECIFIER>.  SIMILIAR TO BYTE-FIELD, BUT BYTE DESCRIPTION IS 
;	OBTAINED BY EVAL ING ARGUMENT AND INTERPRETING IT AS A BYTE SPECIFIER.
;       I.E. PPSS WHERE PP GIVES POSITION AND SS GIVES SIZE A LA PDP-10 
;	BYTE INSTRUCTION.
;  ALL-BUT-LISP-BYTE <%% FORM BYTE SPECIFIER>.  SIMILAR, BUT ADDRESSES BITS NOT IN
;	<BYTE>.  <BYTE> MUST BE EITHER LEFT OR RIGHT ADJUSTED IN 32. BITS.
;  BYTE-MASK <SYMBOLIC BYTE SPECIFIER>.  ARG CAN BE SYMBOL OR COMPOSITION OF
;	OPS AND SYMBOLS SPECIFYING A BYTE (IE CONTAINING SOMEWHERE IN THERE
;	A BYTE-FIELD OR LISP-BYTE OPERATION).  THIS IS DUG OUT BY BYTE-MASK
;	AND IS RETURNS THE VALUE OF ALL 1'S IN THE SPECIFIED BYTE.
;  BYTE-VALUE <SYMBOLIC BYTE SPECIFIER> <VALUE TO STORE IN BYTE>
;	RETURNS A VALUE OF THE SPECIFIED NUMBER IN THE SPECIFIED BYTE.
;	FOR CONVENIENCE, THE VALUE MAY BE EITHER A CONS-LAP SYMBOL OR A LISP SYMBOL.
;  FIELDS: (FIELD <FIELD NAME> <VALUE>).  NOTATION IS MADE THAT <FIELD NAME>
;	HAS BEEN SPECIFIED.  THE VALUE IS OBTAINED AS FOLLOWS:  THE PROGRAM
;	ASSOCIATED WITH <FIELD NAME> AS A SYMBOL IS RUN AND ITS VALUE MULTIPLIED
;	BY <VALUE> (THIS IS DONE RATHER THAN SHIFTING SO BIGNUMS WORK CONVIENTLY).
;	ADDITIONALLY, IF A CONS-LAP-ADDITIVE-CONSTANT
;	PROPERTY IS PRESENT ON <FIELD NAME> IT WILL BE ADDED IN AFTER MULTIPLING.
;	ANY PROPERTIES SPECIFIED IN THE	RUNNING OF <FIELD NAME> STICK.
;  I-ARG.  ASSEMBLES ITS ARGUMENT INTO THE IMMEDIATE ARGUMENT FIELD OF A DISPATCH
;	INSTRUCTION.
;  ((ARG-CALL ADR) .. ) OR ((ARG-JUMP ADR) .. ).  ASSEMBLES A DISPATCH INSTRUCTION
;       WHICH DISPATCHES ON ZERO BITS TO A D-MEM ENTRY WHICH DOES A CALL (OR JUMP)
;	TO ADR.  USE IF IT IS DESIRED TO SUPPLY AN I-ARG ON AN UNCONDITIONAL
;	CALL (OR JUMP).  ((ARG-CALL-XCT-NEXT ADR) .. ) AND ((ARG-JUMP-XCT-NEXT ADR) ..)
;	ARE ALSO AVAILABLE.
;  EVAL <ARG>.  CALLS LISP EVAL ON ARG AND RETURNS (NUMERIC HOPEFULLY) VALUE.
;  LOC <ARG> SETS LOCATION COUNTER TO <ARG>.
;  MODULO <ARG> SETS LOCATION COUNTER TO BE ON A MOD <ARG> BOUNDARY.
; The following group provide communication between an assembly and microcompiled
;    code or other assemblies which may be added to it.
;  MC-LINKAGE <list of symbols>.  The values of these symbols are made available
;       to the micro-compiled-code loader and to the incremental mode of the assembler.
;	A and M memory symbols with values less than 40 are automatically 
;       MC-LINKAGEifyed.
;  MC-LINKAGE sym.  Useful primarily in incrmental assemblies.  Expands to value
;	given sym in either current or previous
;      assembly.  Includes appropriate memory.
;  MC-ENTRY-ADR <microcoded-function>  allowable only in incremental assembly.
;	evaluates to I-MEM address of entry to <function> in JUMP-ADDRESS field.
;  MISC-ENTRY-ADR <misc-instruction>   allowable only in incremental assembly.
;       evaluates to I-MEM address of entry to <misc-instruction> in JUMP-ADDRESS field.
;  MC-LINKAGE-VALUE <memory> <symbol>  useful primarily in incremental assemblies.
;       <memory> must be one of NUMBER, I-MEM, D-MEM, A-MEM, M-MEM.  <symbol> must
;       have been assigned a value with the MC-LINKAGE operation (either in the
;       current assembly, or a previous one to which this assembly is being added).
;       Evaluates to the value in the appropriate memory.

;  INSTRUCTIONS FOR ASSEMBLING VALUES FOR USE WITH OA REGISTER.  (RECALL? THAT
;	THE OA "REGISTER" IS THE HACK WHEREBY THE NEXT MICRO-INSTRUCTION GETS
;	IOR-ED WITH DATA PRODUCED BY THIS ONE).
;    OA-LOW-CONTEXT OA-HIGH-CONTEXT <I-MEM STORAGE-WORD>.  ASSEMBLES <I-MEM STORAGE
;	WORD> AND RETURN EITHER HI OR LOW PART AS NUMBER FOR USE WITH DESTINATIONS
;	OA-REG-HI OR OA-REG-LOW.
; SYMBOLS MAY BE EITHER ON THE SYMTAB OR ON THE PROPERTY LIST UNDER THE INDICATOR
;  CONS-LAP-SYM.

;THE TYPE OF INSTRUCTION THAT GETS ASSEMBLED IN A GIVEN STORAGE WORD IS DETERMINED
;AS FOLLOWS:
;  FIRST THERE IS A DEFAULT, ALU-INSTRUCTION.  IT IS OVERRIDDEN BY ANY OTHER SPECIFIER.
;	THIS IS THE ONLY SPECIFIER THAT
;	CAN BE "OUT-OF-HARMONY" WITH ANY OTHER PRESENT SPECIFIER WITHOUT CAUSING AN 
;	ERROR. 
;  IF A DESTINATION IS PRESENT, INSTRUCTION MUST BE ALU-INSTRUCTION OR BYTE-INSTRUCTION.
;  IF AN I-MEM CONTEXT SYMBOL IS PRESENT, INSTRUCTION MUST BE JUMP-INSTRUCTION.
;  IF A D-MEM CONTEXT SYMBOL IS PRESENT, INSTRUCTION MUST BE DISPATCH-INSTRUCTION.
;  IF BOTH A M-MEM AND A A-MEM SYMBOL ARE PRESENT, INSTRUCTION MUST BE ALU-INSTRUCTION
;	OR BYTE-INSTRUCTION.
;  INSTRUCTION CAN BE FORCED BY A FORCE-INSTRUCTION PROPERTY ON ANY SYMBOL IN THE
;	WORD.
;  TWO A-MEM OR TWO M-MEM SYMBOLS IN ONE INSTRUCTION IS AN ERROR.

;ONCE INSTRUCTION TYPE IS DETERMINED, A CHECK IS MADE TO SEE THAT ALL NECESSARY
; FIELDS IN IT HAVE BEEN SPECIFIED, AND DEFAULTS SUPPLIED FOR VARIOUS OPTIONAL
; FIELDS AND MODES IF THEY WERE NOT SPECIFIED.

;RANDOM CONVENTIONS --
; LOCATION TAGS ARE DEFINED AS FIELDS. IE (FIELD JUMP-ADDRESS-MULTIPLIER NNN)
; FOR SYMBOLS IN I-MEM. (A-SOURCE-MULTIPLIER, M-SOURCE-MULTIPLIER, AND 
; DISPATCH-ADDRESS-MULTIPLIER ARE THE CORRESPONDING FIELDS FOR A-MEM, M-MEM,
; AND D-MEM RESPECTIVELY).  THUS, WHEN NORMALLY EVALUATED, THEY HAVE
; THEIR VALUES IN THESE "PLACES".  THIS IS THE RIGHT THING EXCEPT FOR THESE
; CASES: 1)  DESTINATIONS.  CONVERT-VALUE-TO-DESTINATION COMPUTES AN APPROPRIATE
;		"SHIFT"
;	 2)  LOCALITY D-MEM.  CONS-LAP-PASS2 DOES THE RIGHT THING.  THIS INVOLVES
;		SHIFTING THE I-MEM ADR BACK TO THE LOW PART AND MOVING THE RPN
;		BITS UP (FROM THEIR NORMAL POSITION IN A JUMP INSTRUCTION).
; OTHER FEATURES/CROCKS
;   WHEN A BYTE-FIELD OPERATION IS ENCOUNTERED BY CONS-LAP-EVAL,
;	THE INSTRUCTION CONTEXT IS FORCED TO BYTE IF IT HAS NOT ALREADY
;	BEEN COMPLETELY SPECIFIED.  THEN THE BYTE REFERENCE IS ASSEMBLED
;	IN THE MANNER APPROPRIATE TO THE INSTRUCTION CONTEXT.
;   THE SR-BIT IS STORED INVERTED (SO THAT IT WILL OFF FOR NORMAL LDB).
;	CONS-LAP-DEFAULT-AND-BUGGER REVERSES SR-BIT IF IT'S A BYTE INSTRUCTION
;   THE HARDWARE IMPLEMENTS A LEFT ROTATE FOR THE M-ROTATE FIELD.  The is the
;       "right thing" for DPB and SELECTIVE-DEPOSIT, but LDB, DISPATCH, and 
;       JUMP-IF-BIT-SET need to be 32-reflected (IE ( 32. - M-ROTATE) MOD 32.) 
;       This is done by CONS-LAP-DEFAULT-AND-BUGGER.
;	CODE USING THE OA-REGISTER FEATURE TO MODIFY BYTE TYPE INSTRUCTIONS
;	MUST BE AWARE OF THIS.
;  TO PUT THE ADDRESS OF A MICRO CODE LOCATION INTO A CONSTANT IN A OR M
;	MEMORY, USE THE KLUDGEY CONSTRUCTION (I-MEM-LOC <TAG>).
;  SIMILARLY, A-MEM-LOC, M-MEM-LOC, D-MEM-LOC PSEUDO-OPS EXIST.

;   OPERATION OF THE ARG-CALL, ETC, FEATURE IN DISPATCH INSTRUCTIONS.
;	SOMETIMES IT IS DESIRABLE TO USE A DISPATCH INSTRUCTION WHEN
;	REALLY ONLY AN UNCONDITIONAL TRANSFER (CALL, ETC) IS DESIRED
;	IN ORDER TO BE ABLE TO LOAD THE DISPATCH-CONSTANT REGISTER IN THE
;	SAME INSTRUCTION.  IT WOULD BE A PAIN TO HAVE TO DEFINE A ONE REGISTER
;	DISPATCH TABLE, ETC IN THIS CASE.  SO THE ASSEMBLER PROVIDES A FEATURE
;	WHEREBY ARG-CALL, ARG-JUMP, ARG-CALL-XCT-NEXT, AND ARG-JUMP-XCT-NEXT
;	ARE SPECIALLY RECOGNIZED.  USING THESE PSEUDO-OPS, THE INSTRUCTION
;	MAY BE WRITTEN AS "NORMAL" AND THE ASSEMBLER WILL TAKE CARE OF
;	ALLOCATING A D-MEM LOCATION AND MOVING THE RPN BITS AND I-MEM JUMP ADDRESS
;	BITS THERE.  THIS D-MEM LOCATION IS AUTOMATICALLY PLUGGED INTO THE
;	DISPATCH OFFSET.
;   ON A NORMAL PDP-10 STYLE LOAD BYTE, THE A-MEM ADDRESS MUST CONTAIN 0
;	FOR CORRECT OPERATION.  A-MEM
;	LOCATION 2 IS CHOSEN TO CONTAIN ZERO, AND LOCATION 3 TO CONTAIN -1,
;	MAKING A CONVENIENT PAIR FOR DOING SIGN-EXTENSION.  THE A-MEM ADDRESS
;	OF A LOAD-BYTE INSTRUCTION WILL BE DEFAULTED TO 2 IF NOT SPECIFIED.

;ENTRY POINTS INTO MICRO-CODE FROM MACRO-CODE, ETC:
;   THE MICRO-CODE-SYMBOL AREA CONTAINS ALL (INITIAL) ENTRY POINTS INTO
;  MICRO-CODE.  THE FIRST 600 Q'S OF MICRO-CODE-SYMBOL AREA GIVE THE CONTROL-MEMORY
;  TRANSFER ADDRESSES FOR MACRO-CODE MISC-INSTRUCTIONS 200-777.  FOLLOWING THAT
;  ARE OTHER ENTRY POINTS, MOSTLY FOR MICRO-COMPILED RUNTIME ROUTINES, ETC.
;  THESE LAST ARE NOT REFERENCED DYNAMICALLY, BUT JUST BY LOADERS, ETC.
;   THE MICRO-CODE-SYMBOL AREA IS COMPLETELY DETERMINED BY CONSLP UNDER CONTROL
;  OF THE (MISC-INST-ENTRY <NAME>) PSEUDO-OPERATION.
;     (MISC-INST-ENTRY <NAME>) DECLARES THAT THE CURRENT LOCATION IS THE ENTRY POINT 
;	WHEN <NAME> IS EXECUTED AS A MACRO-INSTRUCTION. CONSLP LOOKS ON THE PROPERTY
;	LIST OF <NAME> TO FIND THE QLVAL PROPERTY (WHICH HAD BETTER BE THERE OR ERROR).
;	THESE QLVAL COME FROM LISPM;DEFMIC. CONSLP THEN ARRANGES FOR . TO APPEAR
;	IN THE APPROPRIATE LOCATION OF MICRO-CODE-SYMBOL AREA.
; IN ADDITION, (MICRO-CODE-ILLEGAL-ENTRY-HERE), ENCOUNTERED AT ANY TIME, FILLS
;	ALL UNUSED ENTRIES OF MICRO-CODE-SYMBOL AREA WITH THE CURRENT LOCATION.
;	(IT IS OK IF SOME OF THEM LATER GET STORED OVER WITH OTHER STUFF...)
;THE MC-LINKAGE PSEUDO-OP IS THE OTHER MECHANISM (BESIDE MISC-INST-ENTRY)
;  BY WHICH LINKAGE INFO CAN BE "COUPLED OUT" AND USED BY MICROCOMPILED ROUTINES.
;  USAGE IS (MC-LINKAGE <SYM> ..)  THE LOCATION WITHIN MEMORY OF SYM IS ADDED TO
;  MC-LINKAGE-ALIST, AND THAT IS WRITTEN AS PART OF THE ASSEMBLER STATE.  IF
;  SYM IS A LIST, CAR IS THE MICROCOMPILED NAME, CADR THE CONSLP NAME.

;THE ERROR TABLE:
; THE PSEUDO-OP (ERROR-TABLE FOO BAR BAZ...)
; WILL ADD THE LINE (LOC FOO BAR BAZ...) TO THE ERROR TABLE, WHERE LOC IS
; THE ADDRESS OF THE PRECEEDING I-MEM INSTRUCTION.  THE ERROR TABLE IS
; AN OUTPUT FILE, UCONS TABLE, WHICH CAN BE READ IN TO LISP.  IT CONTAINS
; A SETQ OF MICROCODE-ERROR-TABLE TO A LIST OF ERROR TABLE ENTRIES,
; AND A SETQ OF MICROCODE-ERROR-TABLE-VERSION TO THE SOURCE FILE VERSION
; NUMBER, WHICH CAN BE COMPARED AGAINST %MICROCODE-VERSION-NUMBER.

(DECLARE (SPECIAL DESTINATION-CONTEXT LOCALITY I-MEM-LOC D-MEM-LOC
	   A-MEM-CREVICE-LIST A-CONSTANT-LOC M-CONSTANT-LOC
	   CONSLP-INPUT CONSLP-OUTPUT
	   VERSION-NUMBER      ;Numeric value of FN2 for this file
	   BASE-VERSION-NUMBER ;NIL or, if incremental assembly, version this to augment.
           A-MEM-LOC M-MEM-LOC D-MEM-FREE-BLOCKS FIELD-INDICATORS COMBINED-VALUE 
	   COMBINED-INDICATORS INSTRUCTION-CONTEXT IN-DISPATCH-BLOCK 
	   DISPATCH-BLOCK-LIMIT DISPATCH-ARM DISPATCH-CONSTANT M-CONSTANT-LIST 
	   A-CONSTANT-LIST A-CONSTANT-BASE M-CONSTANT-BASE CONS-LAP-LAST-SYM 
	   A-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST
	   I-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST 
	   CONS-LAP-WDS-SINCE-LAST-SYM CONS-LAP-SAVED-SYMTAB SR-BIT 
	   ARG-CALL-LIST CURRENT-WORD  
	   MC-LINKAGE-ALIST
	   COLD-LOAD-AREA-SIZES PAGE-SIZE CONS-LAP-PASS2 MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
	   CONS-LAP-INIT-STATE   ;If this non-null, current assembly is incremental
			         ; from this saved state.
	   CURRENT-ASSEMBLY-MICRO-ENTRIES   ;List, ea element, (<type> <name> <adr>),
	 				    ; in incremental assembly
	   CURRENT-ASSEMBLY-TABLE	    ;Error table
	   CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
	   CURRENT-ASSEMBLY-DEFMICS
))

(DEFVAR FILE-TRUENAMES-LISTIFIED NIL)

(DEFVAR CONS-LAP-INSIDE-COMMENT NIL
  "T in microassembly means we have seen a (BEGIN-COMMENT)
 and are ignoring thru next (END-COMMENT).")

;THE ARG CALL LIST IS AN ASSOCIATION LIST WHERE THE KEY IS THE I-MEM LOCATION
;AT WHICH AN ((ARG-CALL) ..) TYPE INSTRUCTION HAS APPEARED, AND THE VALUE
;IS THE D-MEM LOCATION THAT HAS BEEN ALLOCATED TO IT.


;ARRAYS WHICH RECEIVE THE OUTPUT OF THE ASSEMBLY
(DEFVAR I-MEM)
(DEFVAR A-MEM)
(DEFVAR D-MEM)
(DEFVAR MICRO-CODE-SYMBOL-IMAGE)

(DEFUN CONS-LAP-BARF (A B C)
  (TERPRI)
  (PRIN1 (LIST CONS-LAP-LAST-SYM CONS-LAP-WDS-SINCE-LAST-SYM))
  (PRIN1 (LIST A B C))
  (COND ((NOT (EQ C 'WARN))(BREAK "FOO"))))

(DEFUN CONS-LAP-INITIALIZE (INIT-STATE) 
  (PROG (TEM) 
	(CONS-LAP-INIT-LOCS-FROM-STATE INIT-STATE)
	(SETQ BASE-VERSION-NUMBER (GETF INIT-STATE 'VERSION-NUMBER))
	(SETQ A-MEM-CREVICE-LIST NIL)
	(SETQ D-MEM-FREE-BLOCKS 
	      (COPYTREE (GETF INIT-STATE 'D-MEM-FREE-BLOCKS
			      '(NIL (4000 . 0)))))	;A BLOCK OF 4000 STARTING AT 0
	(ALLREMPROP 'CONS-LAP-USER-SYMBOL)
	(SETQ M-CONSTANT-LIST			;DUMMY UP SLOTS FOR USAGE COUNT AND LAST
	      (COND ((SETQ TEM (GETF INIT-STATE 'M-CONSTANT-LIST))  ;USE
		     (MAPCAR (FUNCTION (LAMBDA (X)
					 (APPEND X '(100000 NIL) NIL)))
			     TEM))
		    (T NIL)))
	(SETQ A-CONSTANT-LIST
	      (COND ((SETQ TEM (GETF INIT-STATE 'A-CONSTANT-LIST))
		     (MAPCAR (FUNCTION (LAMBDA (X)
					 (APPEND X '(100000 NIL) NIL)))
			     TEM))
		    (T NIL)))
	(SETQ A-CONSTANT-BASE NIL)		;SEE CONS-LAP-LOC-MODULO
	(SETQ M-CONSTANT-BASE NIL)
	(SETQ A-MEMORY-RANGE-LIST NIL)
	(SETQ M-MEMORY-RANGE-LIST NIL)
	(SETQ I-MEMORY-RANGE-LIST NIL)
	(SETQ D-MEMORY-RANGE-LIST NIL)
	(SETQ CURRENT-ASSEMBLY-MICRO-ENTRIES NIL)
	(SETQ CURRENT-ASSEMBLY-TABLE NIL)
  ;do not initialize current-assembly-defmics here computed during readin phase
	(SETQ CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
	      (GETF INIT-STATE 'HIGHEST-MISC-ENTRY 0))
	(SETQ MC-LINKAGE-ALIST (GETF INIT-STATE 'MC-LINKAGE-ALIST))
	(DOLIST (E MC-LINKAGE-ALIST)
	  (COND ((AND (MEMQ (CADR E) '(A M))
		      (< (CADDR E) 40))
		 (CONS-LAP-DEFINE-LINKAGE-SYMBOL (CAR E)))))
	(CONS-LAP-ALLOCATE-ARRAYS)
	(ALLREMPROP 'CONS-LAP-B-PTR)
))

(DEFUN ALLREMPROP (**INDICATOR**)
  (DECLARE (SPECIAL **INDICATOR**))
  (MAPATOMS (FUNCTION (LAMBDA (X) (REMPROP X **INDICATOR**)))))

(DEFUN MAKE-ASSEMBLER-STATE-LIST NIL 
  (LIST 'I-MEM-LOC I-MEM-LOC 'D-MEM-LOC D-MEM-LOC 'A-MEM-LOC A-MEM-LOC
	'M-MEM-LOC M-MEM-LOC 
	'A-CONSTANT-LOC A-CONSTANT-LOC 'A-CONSTANT-BASE A-CONSTANT-BASE
	'M-CONSTANT-LOC M-CONSTANT-LOC 'M-CONSTANT-BASE M-CONSTANT-BASE 
	'D-MEM-FREE-BLOCKS D-MEM-FREE-BLOCKS 
	'M-CONSTANT-LIST (MAKE-CONSTANT-LIST M-CONSTANT-LIST)
	'A-CONSTANT-LIST (MAKE-CONSTANT-LIST A-CONSTANT-LIST)
	'MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
	(COND ((BOUNDP 'MICRO-CODE-SYMBOL-TABLE-FILL-VALUE)
	       MICRO-CODE-SYMBOL-TABLE-FILL-VALUE)
	      (T NIL))
	'A-MEMORY-RANGE-LIST A-MEMORY-RANGE-LIST
	'M-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST
	'I-MEMORY-RANGE-LIST I-MEMORY-RANGE-LIST
	'D-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
	'MC-LINKAGE-ALIST MC-LINKAGE-ALIST
	'MICRO-ENTRIES CURRENT-ASSEMBLY-MICRO-ENTRIES
	'HIGHEST-MISC-ENTRY CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
	'VERSION-NUMBER VERSION-NUMBER
	'BASE-VERSION-NUMBER BASE-VERSION-NUMBER	;nil or version number this
							; loads into.
	'FILE-TRUENAMES-LISTIFIED FILE-TRUENAMES-LISTIFIED
	))

(DEFUN CONS-LAP-ALLOCATE-ARRAYS NIL 
  (SETQ I-MEM (MAKE-ARRAY SI:SIZE-OF-HARDWARE-CONTROL-MEMORY)
	A-MEM (MAKE-ARRAY 2000)
	D-MEM (MAKE-ARRAY 4000))
  (SETQ MICRO-CODE-SYMBOL-IMAGE (MAKE-ARRAY MICRO-CODE-SYMBOL-AREA-SIZE)))

(DEFUN CONS-LAP-INIT-LOCS-FROM-STATE (INIT-STATE) 
  (PROG (TEM) 
	(SETQ I-MEM-LOC (GETF INIT-STATE 'I-MEM-LOC 0))
	(SETQ D-MEM-LOC (GETF INIT-STATE 'D-MEM-LOC 0))
	(SETQ A-MEM-LOC (COND ((SETQ TEM (GETF INIT-STATE 'A-MEM-LOC))
			       (MAX TEM (GETF INIT-STATE 'A-CONSTANT-LOC 0)))
			      (T 0)))
	(SETQ M-MEM-LOC (COND ((SETQ TEM (GETF INIT-STATE 'M-MEM-LOC))
			       (MAX TEM (GETF INIT-STATE 'M-CONSTANT-LOC 0)))
			      (T 0)))
))

(DEFVAR PATHNAME-DEFAULTS)

;IF INIT-STATE NON-NIL, ITS REPRESENTS A PREVIOUS ASSEMBLY
; IS TO BE AUGMENTED BY THE CURRENT ASSEMBLY.
;--- see ASSEMBLE-SYSTEM below which is the new interface to this stuff..
(DEFUN ASSEMBLE (&OPTIONAL FN INIT-STATE DONT-RE-READ &AUX INPUT-FILE INPUT-TRUENAME)
  (PKG-BIND "UA"			;Put user typein into our package during assembly
    (COND ((NOT (BOUNDP 'PATHNAME-DEFAULTS))
	   (SETQ PATHNAME-DEFAULTS (FS:MAKE-PATHNAME-DEFAULTS))
	   (FS:SET-DEFAULT-PATHNAME "SYS: UCADR; UCADR LISP >" PATHNAME-DEFAULTS)))
    (COND ((NULL FN)
	   (FORMAT T "~&Enter input file name (default ~A): "
		   (FS:DEFAULT-PATHNAME PATHNAME-DEFAULTS))
	   (SETQ FN (READLINE))))
    (SETQ INPUT-FILE (FS:MERGE-AND-SET-PATHNAME-DEFAULTS FN PATHNAME-DEFAULTS))
    (SETQ CONSLP-INPUT
	  (SETQ CONSLP-OUTPUT (INTERN (STRING-UPCASE (FUNCALL INPUT-FILE ':NAME)))))
    (SETQ INPUT-TRUENAME (FUNCALL INPUT-FILE ':TRUENAME)
	  VERSION-NUMBER (FUNCALL INPUT-TRUENAME ':VERSION))
    (LET ((TIME (TIME))
	  (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
	  (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (COND ((AND DONT-RE-READ (BOUNDP CONSLP-INPUT))
	     (FORMAT T "~&Ucode already read in.~%"))
	    ((OR INIT-STATE		;Use regular reader for incremental assembly
		 (NOT (FBOUNDP 'READ-UCODE)))
	     (FORMAT T "Reading ~A~%" INPUT-TRUENAME)
	     (SETQ CURRENT-ASSEMBLY-DEFMICS NIL)
	     (READFILE INPUT-FILE "UA"))
	    (T
	     (FORMAT T "Reading ~A with fast reader~%" INPUT-TRUENAME)
	     (SETQ CURRENT-ASSEMBLY-DEFMICS NIL)
	     (READ-UCODE INPUT-FILE)))
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (FORMAT T "~&Read-in time ~D:~D, ~D disk reads, ~D disk writes~%"
	      (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))
    (DOLIST (X CURRENT-ASSEMBLY-DEFMICS)	;process UA-DEFMICs read
      (APPLY (FUNCTION UA-DO-DEFMIC) X))
    (LET ((TIME (TIME))
	  (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
	  (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (FORMAT T "~&Begin Assembly~%")
      (CONS-LAP (SYMEVAL CONSLP-INPUT) INIT-STATE)
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (COND ((NULL INIT-STATE)		;dont write on incremental assembly
	     (WRITE-VARIOUS-OUTPUTS INPUT-FILE)))
      (FORMAT T "~&Assembly time ~D:~D, ~D disk reads, ~D disk writes~%"
	      (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))))


(DEFUN WRITE-VARIOUS-OUTPUTS-SYSTEM (OUTPUT-GENERIC-PATHNAME)
  (COND	((Y-OR-N-P "WRITE-MCR? ")
	 (WRITE-MCR-FILE (FUNCALL OUTPUT-GENERIC-PATHNAME
				  ':NEW-TYPE
				  "MCR")
			 BASE-VERSION-NUMBER)
	 (WRITE-TBL-FILE (FUNCALL OUTPUT-GENERIC-PATHNAME
				  ':NEW-TYPE
				  "LOCS"))
	 (WRITE-ERROR-TABLE (FUNCALL OUTPUT-GENERIC-PATHNAME
				     ':NEW-TYPE
				     "TBL")))))

;obsolete now.  see write-various-outputs-system
(DEFUN WRITE-VARIOUS-OUTPUTS (INPUT-FILE)
  ;; Binary for the main microcode lives on another directory.
  ;; Allow the user to type the name of the translated file explicitly.
  (LET ((INPUT-FILE-1 INPUT-FILE))
    (OR (EQUAL (FUNCALL INPUT-FILE-1 ':HOST) "SYS")
	(SETQ INPUT-FILE-1 (FUNCALL (FS:DEFAULT-PATHNAME PATHNAME-DEFAULTS "SYS")
				    ':BACK-TRANSLATED-PATHNAME INPUT-FILE-1)))
    (AND (EQUAL (FUNCALL INPUT-FILE-1 ':DIRECTORY) "UCADR")
	 (SETQ INPUT-FILE (FUNCALL INPUT-FILE-1 ':NEW-DIRECTORY "UBIN"))))
  (SETQ CONSLP-OUTPUT-PATHNAME (FUNCALL INPUT-FILE ':NEW-PATHNAME
					':NAME (STRING CONSLP-OUTPUT)
					':TYPE ':UNSPECIFIC ':VERSION ':UNSPECIFIC))
  (COND	((Y-OR-N-P "WRITE-MCR? ")
	 (WRITE-MCR BASE-VERSION-NUMBER)
	 (WRITE-TBL-FILE (FUNCALL CONSLP-OUTPUT-PATHNAME
				  ':NEW-PATHNAME ':TYPE "LOCS"
				  ':VERSION VERSION-NUMBER))
	 (WRITE-ERROR-TABLE (FUNCALL CONSLP-OUTPUT-PATHNAME
				     ':NEW-TYPE-AND-VERSION
				     "TBL" VERSION-NUMBER)))))

;somewhat fake interface to make-system.  Main advantage is it allows UCADR file to be split.
;sample DEFSYSTEM looks like:
(COMMENT 
  (SI:DEFINE-SIMPLE-TRANSFORMATION :MICRO-ASSEMBLE UA:MICRO-ASSEMBLE-SYSTEM-TOP-LEVEL
     UA:FILE-TEST-ALWAYS ("LISP") ("MCR")
     NIL NIL T)	;LOAD like

  (SI:DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *FILES-TO-MICRO-ASSEMBLE* NIL)

  (DEFSYSTEM UCODE
    (:NAME "Ucode")
    (:PACKAGE "UA")
    (:MICRO-ASSEMBLE ("sys:ucadr;test1" "sys:ucadr;test2")))
  )  ;end comment
 ;note the transformation definition must be in effect when the DEFSYSTEM is evaluated.

(DEFMACRO (:USE-FAST-READER SI:DEFSYSTEM-MACRO) (T-OR-NIL)
  (PUTPROP (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-DEFINED*)) T-OR-NIL 'FAST-READ-SWITCH)
  NIL)

(DEFMACRO (:OUTPUT-PATHNAME SI:DEFSYSTEM-MACRO) (PATHNAME)
  (PUTPROP (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-DEFINED*)) PATHNAME 'OUTPUT-PATHSTRING)
  NIL)

(DECLARE (SPECIAL SI:*FILES-TO-MICRO-ASSEMBLE*))

(DEFUN MICRO-ASSEMBLE-SYSTEM-TOP-LEVEL (INFILE OUTFILE)
 ;  (FORMAT T "~% infile : ~s outfile: ~s" INFILE OUTFILE)
  OUTFILE  ;We don't have an output file for each input file anyway.
  (COND ((NULL SI:*FILES-TO-MICRO-ASSEMBLE*)
	 (PUSH `(MICRO-ASSEMBLE-SYSTEM-DO-IT)
	       SI:*MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER*)))
  (SETQ SI:*FILES-TO-MICRO-ASSEMBLE*
	(NCONC SI:*FILES-TO-MICRO-ASSEMBLE* (LIST INFILE))))

(DEFUN MICRO-ASSEMBLE-SYSTEM-DO-IT ()
  ;(FORMAT T "~%micro-assemble-do-it ~s" SI:*FILES-TO-MICRO-ASSEMBLE*)
  (LET* ((FILE-TRUENAMES (MAPCAR #'(LAMBDA (X) (FUNCALL X ':TRUENAME))
				 SI:*FILES-TO-MICRO-ASSEMBLE*))
	 (FILE-TRUENAMES-LISTIFIED (MAPCAR #'(LAMBDA (X) (LISTIFY-PATHNAME X))
					   FILE-TRUENAMES))
	 (OUTPUT-PATHSTRING (GET (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-MADE*))
				 'OUTPUT-PATHSTRING))
	 (OUTPUT-GENERIC-PATHNAME (FS:PARSE-PATHNAME OUTPUT-PATHSTRING))
	 (OUTPUT-MCR-PATHNAME (FUNCALL OUTPUT-GENERIC-PATHNAME ':NEW-TYPE "MCR"))
	 (PROBE (PROBEF OUTPUT-MCR-PATHNAME))
	 (OUTPUT-OLD-TRUENAME (FUNCALL PROBE ':TRUENAME))
	 (OLD-VERSION-NUMBER (FUNCALL OUTPUT-OLD-TRUENAME ':VERSION)))
    (SETQ VERSION-NUMBER (1+ OLD-VERSION-NUMBER))
    (SETQ OUTPUT-GENERIC-PATHNAME (FUNCALL OUTPUT-GENERIC-PATHNAME
					   ':NEW-VERSION VERSION-NUMBER))
    (FORMAT T "~%Output will be version ~D" VERSION-NUMBER)
    (ASSEMBLE-SYSTEM OUTPUT-GENERIC-PATHNAME
		     FILE-TRUENAMES NIL NIL
		     (GET (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-MADE*))
			  'FAST-READ-SWITCH))))

(DEFUN LISTIFY-PATHNAME (PATHNAME)
  (LIST (FUNCALL (FUNCALL PATHNAME ':HOST) ':NAME)
	(FUNCALL PATHNAME ':DEVICE)
	(FUNCALL PATHNAME ':NAME)
	(FUNCALL PATHNAME ':TYPE)
	(FUNCALL PATHNAME ':VERSION)))

;IF INIT-STATE NON-NIL, ITS REPRESENTS A PREVIOUS ASSEMBLY
; IS TO BE AUGMENTED BY THE CURRENT ASSEMBLY.
(DEFUN ASSEMBLE-SYSTEM (OUTPUT-GENERIC-PATHNAME
			FILE-TRUENAMES INIT-STATE RE-READ USE-FAST-READER)
  (PKG-BIND "UA"			;Put user typein into our package during assembly
    (LET ((TIME (TIME))
	  (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
	  (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (DOLIST (FILE-TRUENAME FILE-TRUENAMES)
	   ;read in S-exp if necessary.  Also save DEFMICSs on property list of TRUENAME.
	(ASSEMBLE-READ-FILE FILE-TRUENAME USE-FAST-READER RE-READ))
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (FORMAT T "~&Read-in time ~D:~D, ~D disk reads, ~D disk writes~%"
	      (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))
    (DOLIST (FILE-TRUENAME FILE-TRUENAMES)
      (DOLIST (X (FUNCALL FILE-TRUENAME ':GET 'DEFMICS))	;process UA-DEFMICs
	(APPLY (FUNCTION UA-DO-DEFMIC) X)))
    (LET ((TIME (TIME))
	  (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
	  (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (FORMAT T "~&Begin Assembly~%")
      (CONS-LAP-INITIALIZE INIT-STATE)
      (CONS-LAP-SYSTEM FILE-TRUENAMES INIT-STATE)
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (COND ((NULL INIT-STATE)		;dont write on incremental assembly
	     (WRITE-VARIOUS-OUTPUTS-SYSTEM OUTPUT-GENERIC-PATHNAME)))
      (FORMAT T "~&Assembly time ~D:~D, ~D disk reads, ~D disk writes~%"
	      (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
	      (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))))

(DEFUN ASSEMBLE-READ-FILE (FILE-TRUENAME USE-FAST-READER RE-READ)
  (COND ((OR RE-READ
	     (NULL (FUNCALL FILE-TRUENAME ':GET 'UA-SEXP)))
	 (LET ((CURRENT-ASSEMBLY-DEFMICS NIL)
	       (NAME (INTERN (STRING-UPCASE (FUNCALL FILE-TRUENAME ':NAME)))))
	   (MAKUNBOUND NAME)
	   (COND (USE-FAST-READER
		  (FORMAT T "~%Reading ~A with fast reader" FILE-TRUENAME)
		  (READ-UCODE FILE-TRUENAME))
		 (T
		  (FORMAT T "~%Reading ~A" FILE-TRUENAME)
		  (READFILE FILE-TRUENAME "UA")))
	   (IF (NOT (BOUNDP NAME))
	       (FERROR NIL "~%Reading ~s failed to set the symbol ~s" FILE-TRUENAME NAME))
	   (FUNCALL FILE-TRUENAME ':PUTPROP (SYMEVAL NAME) 'UA-SEXP)
	   (FUNCALL FILE-TRUENAME ':PUTPROP CURRENT-ASSEMBLY-DEFMICS 'DEFMICS)))
	(T (FORMAT T "~%Already read ~S" FILE-TRUENAME))))
      
(DEFUN CONS-LAP-SYSTEM (FILE-TRUENAMES CONS-LAP-INIT-STATE)
  (PROG (;I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC M-CONSTANT-LOC A-CONSTANT-LOC ;USE TOP LEVEL
	 ;M-CONSTANT-LIST A-CONSTANT-LIST M-CONSTANT-BASE A-CONSTANT-BASE  ;BINDINGS FOR THESE
	 ;D-MEM-FREE-BLOCKS MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
         ;A-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST I-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
         ;CURRENT-ASSEMBLY-MICRO-ENTRIES CURRENT-ASSEMBLY-TABLE CURRENT-ASSEMBLY-DEFMICS 
	 ;CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
	 ;MC-LINKAGE-ALIST
         INITIAL-A-MEM-LOC INITIAL-M-MEM-LOC INITIAL-I-MEM-LOC INITIAL-D-MEM-FREE-BLOCKS
	 LOCALITY 
         IN-DISPATCH-BLOCK CONS-LAP-LAST-SYM CONS-LAP-WDS-SINCE-LAST-SYM 
	 DISPATCH-BLOCK-LIMIT DISPATCH-ARM CONS-LAP-PASS2
         DISPATCH-CONSTANT ARG-CALL-LIST CONS-LAP-INSIDE-COMMENT)
	(SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
	(SETQ INITIAL-A-MEM-LOC A-MEM-LOC INITIAL-M-MEM-LOC M-MEM-LOC
	      INITIAL-I-MEM-LOC I-MEM-LOC)
	(SETQ INITIAL-D-MEM-FREE-BLOCKS (COPYTREE D-MEM-FREE-BLOCKS))
	(DOLIST (*UA-TRUENAME* FILE-TRUENAMES)
	  (LET ((BEG-I-MEM-LOC I-MEM-LOC))
	    (DOLIST (S (FUNCALL *UA-TRUENAME* ':GET 'UA-SEXP))
	      (CONS-LAP-PASS1 S))
	    (WHEN CONS-LAP-INSIDE-COMMENT
	      (CONS-LAP-BARF *UA-TRUENAME* "Ends inside a (BEGIN-COMMENT)" 'BARF))
	    (FORMAT T "~%file ~A assembled into ~D. I-MEM locs"
		    *UA-TRUENAME* (- I-MEM-LOC BEG-I-MEM-LOC))))
	(SETQ M-CONSTANT-LOC (SETQ M-CONSTANT-BASE M-MEM-LOC))
	(SETQ A-CONSTANT-LOC (SETQ A-CONSTANT-BASE A-MEM-LOC))
	(SETQ CONS-LAP-LAST-SYM NIL)
	(SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
	(SETQ CONS-LAP-PASS2 T)
	(CONS-LAP-INIT-LOCS-FROM-STATE CONS-LAP-INIT-STATE)
	(DOLIST (*UA-TRUENAME* FILE-TRUENAMES)
	  (DOLIST (S (FUNCALL *UA-TRUENAME* ':GET 'UA-SEXP))
	    (CONS-LAP-PASS2 S))
	  (WHEN CONS-LAP-INSIDE-COMMENT
	    (CONS-LAP-BARF *UA-TRUENAME* "Ends inside a (BEGIN-COMMENT)" 'BARF)))
	(COND ((NOT (= M-MEM-LOC M-CONSTANT-BASE))
	       (CONS-LAP-BARF (LIST M-MEM-LOC M-CONSTANT-BASE) 'CLD-M-MEM 'BARF)))
	(COND ((NOT (= A-MEM-LOC A-CONSTANT-BASE))
	       (CONS-LAP-BARF (LIST A-MEM-LOC A-CONSTANT-BASE) 'CLD-A-MEM 'BARF)))
	(SETQ LOCALITY 'M-MEM)
	(CONS-LAP-STORE-CONSTANT-LIST A-MEM
				      M-CONSTANT-LIST)  ;THIS STORES
			;THE COMPLETE LIST (INCLUDING THOSE FROM PREVIOUS ASSEMBLY)
			;BUT I GUESS THATS OK.
	(SETQ LOCALITY 'A-MEM)
	(CONS-LAP-STORE-CONSTANT-LIST A-MEM
				      A-CONSTANT-LIST)
	(SETQ A-MEMORY-RANGE-LIST (CONS (LIST INITIAL-A-MEM-LOC
					      (- (MAX A-MEM-LOC A-CONSTANT-LOC)
						 INITIAL-A-MEM-LOC))
					A-MEMORY-RANGE-LIST))
	(SETQ M-MEMORY-RANGE-LIST (CONS (LIST INITIAL-M-MEM-LOC
					      (- (MAX M-MEM-LOC M-CONSTANT-LOC)
						 INITIAL-M-MEM-LOC))
					M-MEMORY-RANGE-LIST))
	(SETQ I-MEMORY-RANGE-LIST (CONS (LIST INITIAL-I-MEM-LOC
					      (- I-MEM-LOC INITIAL-I-MEM-LOC))
					I-MEMORY-RANGE-LIST))
	(LET ((TEM (FIND-D-MEM-RANGES-USED
		      (CDR INITIAL-D-MEM-FREE-BLOCKS)
		      (CDR D-MEM-FREE-BLOCKS))))
	  (COND (TEM (SETQ D-MEMORY-RANGE-LIST (APPEND TEM D-MEMORY-RANGE-LIST)))))
	(RETURN "Now do (WRITE-VARIOUS-OUTPUTS) and//or (CONS-DUMP-MEMORIES)")))

(DEFUN FILE-TEST-ALWAYS (F1 F2) F1 F2 T)

;This is used in reading in the DEFMIC file.
;Only sets up the QLVAL property, not the QINTCMP property and not the function lists. 
(defun defmic (&quote name opcode arglist lisp-function-p &optional no-qintcmp
	       &aux function-name instruction-name)
  (if (atom name)
      (setq function-name name instruction-name name)
    (setq function-name (car name) instruction-name (cdr name)))
  (putprop instruction-name opcode 'qlval))

;This one obsolete, see CONS-LAP-SYSTEM.
(DEFUN CONS-LAP (U-PROG &OPTIONAL CONS-LAP-INIT-STATE)
  (PROG (;I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC M-CONSTANT-LOC A-CONSTANT-LOC ;USE TOP LEVEL
	 ;M-CONSTANT-LIST A-CONSTANT-LIST M-CONSTANT-BASE A-CONSTANT-BASE  ;BINDINGS FOR THESE
	 ;D-MEM-FREE-BLOCKS MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
         ;A-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST I-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
         ;CURRENT-ASSEMBLY-MICRO-ENTRIES CURRENT-ASSEMBLY-TABLE CURRENT-ASSEMBLY-DEFMICS 
	 ;CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
	 ;MC-LINKAGE-ALIST
         INITIAL-A-MEM-LOC INITIAL-M-MEM-LOC INITIAL-I-MEM-LOC INITIAL-D-MEM-FREE-BLOCKS
	 LOCALITY 
         IN-DISPATCH-BLOCK CONS-LAP-LAST-SYM CONS-LAP-WDS-SINCE-LAST-SYM 
	 DISPATCH-BLOCK-LIMIT T1 DISPATCH-ARM CONS-LAP-PASS2
         DISPATCH-CONSTANT ARG-CALL-LIST)
	(SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
	(CONS-LAP-INITIALIZE CONS-LAP-INIT-STATE)
	(SETQ INITIAL-A-MEM-LOC A-MEM-LOC INITIAL-M-MEM-LOC M-MEM-LOC
	      INITIAL-I-MEM-LOC I-MEM-LOC)
	(SETQ INITIAL-D-MEM-FREE-BLOCKS (COPYTREE D-MEM-FREE-BLOCKS))
 	(SETQ T1 U-PROG)
L1	(COND ((NULL T1) (GO L2)))
	(CONS-LAP-PASS1 (CAR T1))
	(SETQ T1 (CDR T1))
	(GO L1)
L2	(SETQ M-CONSTANT-LOC (SETQ M-CONSTANT-BASE M-MEM-LOC))
	(SETQ A-CONSTANT-LOC (SETQ A-CONSTANT-BASE A-MEM-LOC))
	(SETQ CONS-LAP-LAST-SYM NIL)
	(SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
	(SETQ CONS-LAP-PASS2 T)
	(CONS-LAP-INIT-LOCS-FROM-STATE CONS-LAP-INIT-STATE)
	(SETQ T1 U-PROG)
L3	(COND ((NULL T1) (GO L4)))
	(CONS-LAP-PASS2 (CAR T1))
	(SETQ T1 (CDR T1))
	(GO L3)
L4	(COND ((NOT (= M-MEM-LOC M-CONSTANT-BASE))
	       (CONS-LAP-BARF (LIST M-MEM-LOC M-CONSTANT-BASE) 'CLD-M-MEM 'BARF)))
	(COND ((NOT (= A-MEM-LOC A-CONSTANT-BASE))
	       (CONS-LAP-BARF (LIST A-MEM-LOC A-CONSTANT-BASE) 'CLD-A-MEM 'BARF)))
	(SETQ LOCALITY 'M-MEM)
	(CONS-LAP-STORE-CONSTANT-LIST A-MEM
				      M-CONSTANT-LIST)  ;THIS STORES
			;THE COMPLETE LIST (INCLUDING THOSE FROM PREVIOUS ASSEMBLY)
			;BUT I GUESS THATS OK.
	(SETQ LOCALITY 'A-MEM)
	(CONS-LAP-STORE-CONSTANT-LIST A-MEM
				      A-CONSTANT-LIST)
	(SETQ A-MEMORY-RANGE-LIST (CONS (LIST INITIAL-A-MEM-LOC
					      (- (MAX A-MEM-LOC A-CONSTANT-LOC)
						 INITIAL-A-MEM-LOC))
					A-MEMORY-RANGE-LIST))
	(SETQ M-MEMORY-RANGE-LIST (CONS (LIST INITIAL-M-MEM-LOC
					      (- (MAX M-MEM-LOC M-CONSTANT-LOC)
						 INITIAL-M-MEM-LOC))
					M-MEMORY-RANGE-LIST))
	(SETQ I-MEMORY-RANGE-LIST (CONS (LIST INITIAL-I-MEM-LOC
					      (- I-MEM-LOC INITIAL-I-MEM-LOC))
					I-MEMORY-RANGE-LIST))
	(LET ((TEM (FIND-D-MEM-RANGES-USED
		      (CDR INITIAL-D-MEM-FREE-BLOCKS)
		      (CDR D-MEM-FREE-BLOCKS))))
	  (COND (TEM (SETQ D-MEMORY-RANGE-LIST (APPEND TEM D-MEMORY-RANGE-LIST)))))
	(RETURN "Now do (WRITE-VARIOUS-OUTPUTS) and//or (CONS-DUMP-MEMORIES)")))

(DEFUN WRITE-ERROR-TABLE (FN)
  (WITH-OPEN-FILE (OUTPUT-FILE FN '(:OUT :BLOCK))
    (PRINT `(SETQ MICROCODE-ERROR-TABLE-VERSION-NUMBER
		  ,VERSION-NUMBER)
	   OUTPUT-FILE)
    (TERPRI OUTPUT-FILE)
    (PRINC "(SETQ MICROCODE-ERROR-TABLE '(" OUTPUT-FILE)
    (DOLIST (I CURRENT-ASSEMBLY-TABLE)
      (PRINT I OUTPUT-FILE))
    (PRINC "))" OUTPUT-FILE)
    (TERPRI OUTPUT-FILE)))

(DEFUN WRITE-TBL-FILE (FN)
  (WITH-OPEN-FILE (OUTPUT-FILE FN '(:OUT))
    (PRINT 'LOCATIONS-USED OUTPUT-FILE)
    (PRINT (LIST 'A-MEM (MAX A-MEM-LOC A-CONSTANT-LOC)) OUTPUT-FILE)
    (PRINT (LIST 'M-MEM (MAX M-MEM-LOC M-CONSTANT-LOC)) OUTPUT-FILE)
    (PRINT (LIST 'I-MEM I-MEM-LOC) OUTPUT-FILE)
    (PRINT (LIST 'D-MEM (- 4000 (GET-D-MEM-FREE-LOCS (CDR D-MEM-FREE-BLOCKS))))
	   OUTPUT-FILE)
    (TERPRI OUTPUT-FILE))
  FN)

;For each old free block, determine what part of it has been used and
; make a list of those ranges.
(DEFUN FIND-D-MEM-RANGES-USED (OLD-FREE-BLOCKS NEW-FREE-BLOCKS)
  (PROG (ANS SA LEN NEW-SA NEW-LEN)
     L  (COND ((NULL OLD-FREE-BLOCKS) (RETURN ANS)))
        (SETQ SA (CDAR OLD-FREE-BLOCKS) LEN (CAAR OLD-FREE-BLOCKS))
     L1 (MULTIPLE-VALUE (NEW-SA NEW-LEN)
	  (FIND-NEXT-FREE-BLOCK-HIGHER-OR-EQUAL SA NEW-FREE-BLOCKS))
	(COND ((NULL NEW-SA)
	       (SETQ ANS (CONS (LIST SA LEN) ANS))    ;EVIDENTLY, BLOCK MUST BE USED NOW
	       (GO X1))
	      ((NOT (= SA NEW-SA))
	       (SETQ ANS (CONS (LIST SA (MIN LEN (- NEW-SA SA)))  ;PART (OR ALL) BLOCK USED
			       ANS))))
	(SETQ LEN (- LEN (- (+ NEW-SA NEW-LEN) SA)))    ;ADVANCE TO ABOVE THAT ONE
	(COND ((<= LEN 0) (GO X1))
	      (T (SETQ SA (+ NEW-SA NEW-LEN))
		 (GO L1)))
     X1 (SETQ OLD-FREE-BLOCKS (CDR OLD-FREE-BLOCKS))
	(GO L)))

(DEFUN FIND-NEXT-FREE-BLOCK-HIGHER-OR-EQUAL (SA FREE-BLOCKS)
  (PROG (ANS)
     L  (COND ((NULL FREE-BLOCKS)
	       (COND ((NULL ANS) (RETURN NIL))
		     (T (RETURN (CDR ANS) (CAR ANS)))))
	      ((AND (>= (CDAR FREE-BLOCKS) SA)
		    (OR (NULL ANS)
			(< (CDAR FREE-BLOCKS) (CDR ANS))))
	       (SETQ ANS (CAR FREE-BLOCKS))))
        (SETQ FREE-BLOCKS (CDR FREE-BLOCKS))
	(GO L)))

(DEFUN GET-D-MEM-FREE-LOCS (X)
  (COND ((NULL X) 0)
        (T (+ (CAAR X) (GET-D-MEM-FREE-LOCS (CDR X))))))

(DEFUN CONS-LAP-STORE-CONSTANT-LIST (MEM L)
  (PROG NIL 
 L	(COND ((NULL L) (RETURN NIL)))
	(STORE (ARRAYCALL NIL MEM (CADAR L)) (CAAR L))
	(SETQ L (CDR L))
	(GO L)))

;CONSTANT LISTS.
;A LIST OF LISTS.  CAR IS VALUE OF CONSTANT, CADR IS ADDRESS, CADDR IS #USERS, CADDDR IS 
;	LAST PC TO USE IT.

; ARG IS A-CONSTANT-LIST OR M-CONSTANT-LIST
(DEFUN CONS-LAP-REPORT-CONSTANTS-USAGE (L)
  (SETQ L (SORT (COPYLIST L) (FUNCTION (LAMBDA (X Y) (< (CADDR X) (CADDR Y))))))
  (TERPRI)
  (PRINC "#USES	VALUE	USEPC")
  (DO L L (CDR L) (NULL L)
    (PRINT (CADDR (CAR L)))
    (TYO 11)
    (PRIN1 (CAAR L))
    (TYO 11)
    (PRIN1 (CADDDR (CAR L))))
  (TERPRI))

(DEFUN CONS-LAP-PASS1 (WD) 
  (PROG (CURRENT-WORD)
	(SETQ CURRENT-WORD WD)			;FOR DEBUGGING
	(COND (CONS-LAP-INSIDE-COMMENT
	       (WHEN (EQUAL WD '(END-COMMENT))
		 (SETQ CONS-LAP-INSIDE-COMMENT NIL))
	       (RETURN NIL))
	      ((ATOM WD)
	       (SETQ CONS-LAP-LAST-SYM WD)
	       (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
	       (CONS-LAP-DEFSYM 
		 WD 
		 (LIST LOCALITY 
		       (CONS 'FIELD 
			     (COND ((EQ LOCALITY 'I-MEM)
				    (LIST 'JUMP-ADDRESS-MULTIPLIER I-MEM-LOC))
				   ((EQ LOCALITY 'A-MEM) 
				    (LIST 'A-SOURCE-MULTIPLIER A-MEM-LOC))
				   ((EQ LOCALITY 'M-MEM) 
				    (LIST 'M-SOURCE-MULTIPLIER M-MEM-LOC))
				   ((EQ LOCALITY 'D-MEM) 
				    (LIST 'DISPATCH-ADDRESS-MULTIPLIER D-MEM-LOC))
				   (T (CONS-LAP-BARF LOCALITY 
						     'BAD-LOCALITY 
						     'BARF))) )) )
	       (COND ((OR (EQ LOCALITY 'M-MEM)		;automatically MC-LINKAGEify
			  (AND (EQ LOCALITY 'A-MEM)	; accumulator type frobs.
			       (< A-MEM-LOC 40)))
		      (CONS-LAP-MC-LINKAGE-STORE WD))))
	      ((EQ (CAR WD) 'BEGIN-COMMENT)
	       (SETQ CONS-LAP-INSIDE-COMMENT T))
	      ((EQ (CAR WD) 'DEF-DATA-FIELD)
		(DEF-DATA-FIELD (CADR WD) 
				(CONS-LAP-ARG-EVAL (CADDR WD))
				(CONS-LAP-ARG-EVAL (CADDDR WD))))
	      ((EQ (CAR WD) 'DEF-BIT-FIELD-IN-REG)
		(DEF-BIT-FIELD-IN-REG (CADR WD)
				      (CONS-LAP-ARG-EVAL (CADDR WD))
				      (CONS-LAP-ARG-EVAL (CADDDR WD))
				      (CAR (CDDDDR WD))))
	      ((EQ (CAR WD) 'ASSIGN)
		(CONS-LAP-DEFSYM (CADR WD)
				 (CADDR WD)))
	      ((EQ (CAR WD) 'ASSIGN-EVAL)
		(CONS-LAP-DEFSYM (CADR WD)
				 (CONS-LAP-ARG-EVAL (CADDR WD))))
	      ((EQ (CAR WD) 'DEF-NEXT-BIT)
		(DEF-NEXT-FIELD (CADR WD) 1 (CADDR WD)))
	      ((EQ (CAR WD) 'RESET-BIT-POINTER)
		(RESET-BIT-POINTER (CADR WD)))
	      ((EQ (CAR WD) 'DEF-NEXT-FIELD)
		(DEF-NEXT-FIELD (CADR WD) 
				(CONS-LAP-ARG-EVAL (CADDR WD))
				(CADDDR WD)))
	      ((EQ (CAR WD) 'LOCALITY)
		(SETQ LOCALITY (CADR WD))
		(COND ((NOT (MEMQ LOCALITY '(M-MEM A-MEM D-MEM I-MEM)))
			(CONS-LAP-BARF LOCALITY 'BAD-LOCALITY 'BARF))))
	      ((EQ (CAR WD) 'START-DISPATCH)
		(COND ((NOT (EQ LOCALITY 'D-MEM))
			(CONS-LAP-BARF LOCALITY 'BAD-START-DISPATCH 'BARF)))
		(COND (IN-DISPATCH-BLOCK 
			(CONS-LAP-BARF WD 'ALREADY-IN-DISPATCH 'DATA)))
		(SETQ D-MEM-LOC (FIND-D-MEM-SPACE (EXPT 2 (CADR WD))))
		(SETQ IN-DISPATCH-BLOCK T))
	      ((EQ (CAR WD) 'END-DISPATCH)
		(COND ((NULL IN-DISPATCH-BLOCK)
			(CONS-LAP-BARF WD 'NOT-IN-DISPATCH-BLOCK 'DATA)))
		(COND ((> D-MEM-LOC DISPATCH-BLOCK-LIMIT)
			(CONS-LAP-BARF D-MEM-LOC  
				       'DISPATCH-BLOCK-OVERFLOW 
				       'DATA))
		      ((NOT (= D-MEM-LOC DISPATCH-BLOCK-LIMIT))
			(CONS-LAP-BARF (LIST D-MEM-LOC DISPATCH-BLOCK-LIMIT)
			      'DISPATCH-BLOCK-UNDERFLOW 
			      'WARN)))
		(SETQ IN-DISPATCH-BLOCK NIL))
	      ((MEMQ (CAR WD) '(LOC MODULO))
		(CONS-LAP-LOC-MODULO WD))
	      ((EQ (CAR WD) 'REPEAT)
		(CONS-LAP-REPEAT-1 (CONS-LAP-ARG-EVAL (CADR WD))
				   (CDDR WD)))
	      ((MEMQ (CAR WD) '(MISC-INST-ENTRY MC-LINKAGE MC-LINKAGE-VALUE
				MICRO-CODE-ILLEGAL-ENTRY-HERE ERROR-TABLE
				MC-ENTRY-ADR MISC-ENTRY-ADR))
		(GO X))
	      ((EQ (CAR WD) 'COMMENT))
	      ((EQ (CAR WD) 'IF)
	       (COND ((EVAL (CADR WD))
		      (CONS-LAP-PASS1 (CADDR WD)))
		     (T (MAPC (FUNCTION CONS-LAP-PASS1) (CDDDR WD)))))
	      (T (CONS-LAP-PASS1-WD WD)
		 (GO W1)))
X	(RETURN NIL)
W1	(SETQ CONS-LAP-WDS-SINCE-LAST-SYM (1+ CONS-LAP-WDS-SINCE-LAST-SYM))
	(COND ((EQ LOCALITY 'A-MEM)
		(SETQ A-MEM-LOC (1+ A-MEM-LOC)))
	      ((EQ LOCALITY 'M-MEM)
		(SETQ M-MEM-LOC (1+ M-MEM-LOC)))
	      ((EQ LOCALITY 'D-MEM)
		(COND ((NOT IN-DISPATCH-BLOCK)
			(CONS-LAP-BARF WD 'STORAGE-WD-NOT-IN-DISPATCH-BLOCK 'DATA)))
		(SETQ D-MEM-LOC (1+ D-MEM-LOC)))
	      ((EQ LOCALITY 'I-MEM)
		(SETQ I-MEM-LOC (1+ I-MEM-LOC)))
	      (T (CONS-LAP-BARF WD 'STORAGE-WD-IN-BAD-LOCALITY 'DATA)))
	(RETURN NIL)))

(DEFUN CONS-LAP-LOC-MODULO (WD)
   ((LAMBDA (POINT ITEM)
	(AND (EQ (CAR WD) 'MODULO)
	     (SETQ ITEM (* ITEM (CEILING (SYMEVAL POINT) ITEM))))
	(AND (< ITEM (SYMEVAL POINT))
	     (CONS-LAP-BARF WD 'BACKWARDS 'DATA))
	(AND (EQ LOCALITY 'D-MEM)
	     (CONS-LAP-D-MEM-LOC ITEM))
	(AND (NULL A-CONSTANT-BASE)	;ON PASS 1
	     (EQ LOCALITY 'A-MEM)	;KLUDGE TO USE SKIPPED AREA FOR CONSTANTS
	     (DO I A-MEM-LOC (1+ I) (= I ITEM)
		(OR (< I 40)
		    (SETQ A-MEM-CREVICE-LIST (CONS I A-MEM-CREVICE-LIST)))))
	(SET POINT ITEM))
     (CDR (ASSQ LOCALITY '((A-MEM . A-MEM-LOC)
			   (M-MEM . M-MEM-LOC)
			   (D-MEM . D-MEM-LOC)
			   (I-MEM . I-MEM-LOC))))
     (CADR WD)))

;ALLOCATE ONE D-MEM WORD AT A SPECIFIC ADDRESS
(DEFUN CONS-LAP-D-MEM-LOC (L)
  (OR CONS-LAP-PASS2
      (DO ((BL D-MEM-FREE-BLOCKS (CDR BL))
	   (TEM))
	  ((NULL (CDR BL)) (BREAK "CONS-LAP-D-MEM-LOC"))
	(SETQ TEM (CADR BL))				;A BLOCK
	(COND ((AND (NOT (< L (CDR TEM)))		;IF LOC IS IN THIS BLOCK
		    (< L (+ (CDR TEM) (CAR TEM))))
	       (RPLACD BL (CDDR BL))			;PATCH OUT THIS BLOCK
	       (CONS-LAP-D-MEM-LOC-SPLITUP BL (CDR TEM) L)	;INSTALL BLOCKS BEFORE LOC
	       (CONS-LAP-D-MEM-LOC-SPLITUP BL (1+ L)	;INSTALL BLOCKS AFTER LOC
					   (+ (CAR TEM) (CDR TEM)))
	       (RETURN NIL)))))
  (SETQ D-MEM-LOC L
	IN-DISPATCH-BLOCK T
        DISPATCH-CONSTANT 0	;DONT ADD ANYTHING TO THIS ONE.
	DISPATCH-BLOCK-LIMIT (1+ L)))

;SPLIT UP INTO POWER OF 2 BLOCKS
;******* KNOWS THAT D MEM IS 4000 LOCATIONS *******
(DEFUN CONS-LAP-D-MEM-LOC-SPLITUP (BL LOW HIGH)
  (DECLARE (FIXNUM LOW HIGH))
  (PROG (BLOCKSIZE)
    (DECLARE (FIXNUM BLOCKSIZE))
RCR (COND ((= LOW HIGH) (RETURN NIL)))
		 ;COMPUTE LARGEST POWER OF 2 BLOCK STARTING AT LOW
    (SETQ BLOCKSIZE (BOOLE 1 (+ 4000 LOW) (- 4000 LOW)))
A   (COND ((> (+ LOW BLOCKSIZE) HIGH)
	   (SETQ BLOCKSIZE (TRUNCATE BLOCKSIZE 2))
	   (GO A)))
    (RPLACD BL (CONS (CONS BLOCKSIZE LOW) (CDR BL)))	;PUT IN THIS BLOCK
    (SETQ BL (CDR BL)	;DO THE REMAINDER
	  LOW (+ LOW BLOCKSIZE))
    (GO RCR)))

(DEFUN CONS-LAP-REPEAT-1 (COUNT LST)
 (PROG (ORPCNT RPCNT)
        (SETQ ORPCNT (CONS-LAP-SYMEVAL 'REPEAT-COUNT))
	(SETQ RPCNT 0)
L	(COND ((ZEROP COUNT)
	       (CONS-LAP-SET 'REPEAT-COUNT ORPCNT)
	       (RETURN NIL)))
	(CONS-LAP-SET 'REPEAT-COUNT RPCNT)
	(MAPC (FUNCTION (LAMBDA (X) (CONS-LAP-PASS1 (COND ((ATOM X) (LIST X))
							  (T X)))))
	      LST)
	(SETQ COUNT (1- COUNT))
	(SETQ RPCNT (1+ RPCNT))
	(GO L)))

(DEFUN CONS-LAP-PASS1-WD (WD)
  (PROG () 
 L 	(COND ((ATOM WD) (RETURN NIL))
	      ((ATOM (CAR WD)))			;FLUSH
	      ((MEMQ (CAAR WD)
		     '(ARG-CALL ARG-JUMP ARG-CALL-XCT-NEXT ARG-JUMP-XCT-NEXT))
		(SETQ ARG-CALL-LIST 
			(CONS (CONS I-MEM-LOC (FIND-D-MEM-SPACE 1))
			      ARG-CALL-LIST)))
	      ((MEMQ (CAAR WD) '(OA-LOW-CONTEXT OA-HI-CONTEXT))
		(CONS-LAP-PASS1-WD (CDAR WD))))
	(SETQ WD (CDR WD))
	(GO L)))

(DEFUN FIND-D-MEM-SPACE (L)
  (PROG (B P S)
  L0	(SETQ S 20000)	;SIZE OF BEST BLOCK TO SPLIT SO FAR
	(SETQ P D-MEM-FREE-BLOCKS)
  L	(COND ((NULL (CDR P)) (GO S))
	      ((= L (CAADR P))
		(GO X))
	      ((AND (> (CAADR P) L)
		    (< (CAADR P) S))
		(SETQ B P)
		(SETQ S (CAADR P))))
	(SETQ P (CDR P))
	(GO L)
  X	(SETQ B (CADR P))
	(RPLACD P (CDDR P))
	(SETQ DISPATCH-BLOCK-LIMIT (+ (CAR B) (CDR B)))
	(RETURN (CDR B))
  S	(COND ((NULL B)
		(CONS-LAP-BARF L 'OUT-OF-D-MEM 'BARF)))
	(RPLACA (CADR B) (LSH S -1))
	(RPLACD D-MEM-FREE-BLOCKS 
		(CONS (CONS (LSH S -1)
			    (+ (LSH S -1) (CDADR B)))
		      (CDR D-MEM-FREE-BLOCKS)))
	(SETQ B NIL)
	(GO L0) ))

(DEFUN CONS-LAP-DEFSYM (SYM VAL)
  (PROG (TM) 
	(COND ((SETQ TM (CONS-LAP-SYMEVAL SYM))
		(COND ((NOT (EQUAL VAL TM))
			(CONS-LAP-BARF (LIST VAL TM) 'MULT-DEF-SYM 'DATA))))
	      (T (PUTPROP SYM VAL 'CONS-LAP-USER-SYMBOL)))
	(RETURN NIL)))

(DEFUN CONS-LAP-SET (SYM VAL)
  (PUTPROP SYM VAL 'CONS-LAP-USER-SYMBOL))

(DEFUN CONS-LAP-SYMEVAL (SYM)
  (OR (GET SYM 'CONS-LAP-SYM) (GET SYM 'CONS-LAP-USER-SYMBOL)))

(DEFUN CONS-LAP-LISP-SYMEVAL (SYM)
  (OR (BOUNDP SYM) (FERROR NIL "Unbound Lisp Variable ~s" SYM))
  (SYMEVAL SYM))

(DEFUN DEF-DATA-FIELD (SYM BITS BITS-OVER)
  (PROG ()
	(CONS-LAP-DEFSYM SYM 
	  (LIST 'M-MEM (LIST 'BYTE-FIELD BITS BITS-OVER))) 
	(RETURN NIL)))

(DEFUN DEF-BIT-FIELD-IN-REG (SYM BITS BITS-OVER REG)
  (PROG ()
	(CONS-LAP-DEFSYM SYM 
	  (LIST 'PLUS 
		(LIST 'BYTE-FIELD BITS BITS-OVER)
		REG))
	(RETURN NIL)))


(DEFUN RESET-BIT-POINTER (SYM)
  (PROG () 
	(PUTPROP SYM 0 'CONS-LAP-B-PTR)))

(DEFUN DEF-NEXT-FIELD (SYM BITS IN-SYM)
  (PROG (B-PTR IN-SYM-V N-B-PTR)
	(COND ((NOT (ATOM IN-SYM))
		(CONS-LAP-BARF IN-SYM 'BAD-NEXT-FIELD 'DATA)
		(RETURN NIL)))
	(SETQ B-PTR (COND ((GET IN-SYM 'CONS-LAP-B-PTR))
			  (T '0)))
	(COND ((NULL (SETQ IN-SYM-V (CONS-LAP-SYMEVAL IN-SYM)))
		(CONS-LAP-BARF IN-SYM 'UNDEF-IN-DEF-NEXT-FIELD 'DATA)
		(RETURN NIL)))
	(COND ((> (SETQ N-B-PTR (+ BITS B-PTR)) 32.)
		(CONS-LAP-BARF IN-SYM 'OUT-OF-BITS 'DATA)
		(RETURN NIL)))
	(CONS-LAP-DEFSYM SYM (LIST 'PLUS (LIST 'BYTE-FIELD BITS B-PTR)
				   IN-SYM-V))
	(PUTPROP IN-SYM N-B-PTR 'CONS-LAP-B-PTR)
))

(DEFUN CONS-LAP-PASS2 (WD)
  (PROG (V)
	(COND (CONS-LAP-INSIDE-COMMENT
	       (WHEN (EQUAL WD '(END-COMMENT))
		 (SETQ CONS-LAP-INSIDE-COMMENT NIL))
	       (RETURN NIL))
	      ((ATOM WD)
	       (SETQ CONS-LAP-LAST-SYM WD)
	       (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
	       (COND ((AND DISPATCH-ARM 
			   (EQ LOCALITY 'D-MEM))
		      (SETQ D-MEM-LOC (LDB 1413 (CONS-LAP-ARG-EVAL WD)))
		      (SETQ DISPATCH-ARM NIL))
		     ((NOT (EQUAL 
			    (CONS-LAP-SYMEVAL WD)
			    (LIST LOCALITY 
				  (CONS 'FIELD 
					(COND ((EQ LOCALITY 'I-MEM)
					       (LIST 'JUMP-ADDRESS-MULTIPLIER I-MEM-LOC))
					      ((EQ LOCALITY 'A-MEM) 
					       (LIST 'A-SOURCE-MULTIPLIER A-MEM-LOC))
					      ((EQ LOCALITY 'M-MEM) 
					       (LIST 'M-SOURCE-MULTIPLIER M-MEM-LOC))
					      ((EQ LOCALITY 'D-MEM) 
					       (LIST 'DISPATCH-ADDRESS-MULTIPLIER D-MEM-LOC))
					      (T (CONS-LAP-BARF LOCALITY 
								'BAD-LOCALITY 
								'BARF))) )) ))
		      (CONS-LAP-BARF WD 'DEF-DFRS-ON-PASS2 'BARF))))
	      ((EQ (CAR WD) 'BEGIN-COMMENT)
	       (SETQ CONS-LAP-INSIDE-COMMENT T))
	      ((MEMQ (CAR WD) '(DEF-DATA-FIELD ASSIGN ASSIGN-EVAL DEF-NEXT-BIT 
					       RESET-BIT-POINTER 
					       DEF-NEXT-FIELD END-DISPATCH 
					       DEF-BIT-FIELD-IN-REG)))
	      ((EQ (CAR WD) 'LOCALITY)
	       (SETQ LOCALITY (CADR WD)))
	      ((EQ (CAR WD) 'START-DISPATCH)
	       (SETQ DISPATCH-CONSTANT (COND ((CONS-LAP-ARG-EVAL (CADDR WD)))
					     (T 0)))
	       (SETQ DISPATCH-ARM T))	;SET D-MEM-LOC TO NEXT D-MEM SYMBOL ENCOUNTERED
	      				;ERROR IF STORAGE WORD BEFORE THAT.
	      ((MEMQ (CAR WD) '(LOC MODULO))
	       (CONS-LAP-LOC-MODULO WD))
	      ((EQ (CAR WD) 'REPEAT)
	       (CONS-LAP-REPEAT-2 (CONS-LAP-ARG-EVAL (CADR WD))
				  (CDDR WD)))
	      ((EQ (CAR WD) 'MISC-INST-ENTRY)
	       (LET ((OPCODE (GET (CADR WD) 'QLVAL)))
		 (COND ((NULL OPCODE)
			(CONS-LAP-BARF (CADR WD) 'NO-UCODE-ENTRY-INDEX 'WARN))
		       (T
			 (SETQ CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
			       (MAX OPCODE CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY))
			 (COND ((NULL CONS-LAP-INIT-STATE)
				(SETF (AREF MICRO-CODE-SYMBOL-IMAGE (- OPCODE 200))
				      I-MEM-LOC))
			       (T (SETQ CURRENT-ASSEMBLY-MICRO-ENTRIES;in incremental assembly
					(CONS (LIST 'MISC-INST-ENTRY (CADR WD) I-MEM-LOC)
					      CURRENT-ASSEMBLY-MICRO-ENTRIES))))))))
	      ((EQ (CAR WD) 'MICRO-CODE-ILLEGAL-ENTRY-HERE)
	       (SETQ MICRO-CODE-SYMBOL-TABLE-FILL-VALUE I-MEM-LOC)
	       (CONS-LAP-WIPE-SYMBOL-VECTOR I-MEM-LOC))
	      ((AND (EQ (CAR WD) 'MC-LINKAGE)
		    (LISTP (CADR WD)))
	       (MAPC (FUNCTION CONS-LAP-MC-LINKAGE-STORE) (CADR WD)))
	      ((EQ (CAR WD) 'ERROR-TABLE)
	       (SETQ CURRENT-ASSEMBLY-TABLE
		     (NCONC CURRENT-ASSEMBLY-TABLE
			    (LIST (CONS (1- I-MEM-LOC) (CDR WD))))))
	      ((EQ (CAR WD) 'COMMENT))
	      ((EQ (CAR WD) 'IF)
	       (COND ((EVAL (CADR WD))
		      (CONS-LAP-PASS2 (CADDR WD)))
		     (T (MAPC (FUNCTION CONS-LAP-PASS2) (CDDDR WD)))))
	      (T (GO W1)))
     X	(RETURN NIL)
     W1	(SETQ CONS-LAP-WDS-SINCE-LAST-SYM (1+ CONS-LAP-WDS-SINCE-LAST-SYM))
	(COND (DISPATCH-ARM 
	       (CONS-LAP-BARF WD 'STORAGE-WD-IN-UNLOCATED-DISPATCH-BLOCK 'DATA)))
	(SETQ V (CONS-WORD-EVAL WD))
	(COND ((EQ LOCALITY 'A-MEM)
	       (COND ((>= A-MEM-LOC (ARRAY-ACTIVE-LENGTH A-MEM))
		      (CONS-LAP-BARF A-MEM-LOC 'A-MEM-OVERFLOW 'DATA))
		     ((>= A-MEM-LOC 40)		;The rest is really m-memory.
		      (SETF (AREF A-MEM A-MEM-LOC) V)))
	       (SETQ A-MEM-LOC (1+ A-MEM-LOC)))
	      ((EQ LOCALITY 'M-MEM)
	       (COND ((< M-MEM-LOC 40)
		      (SETF (AREF A-MEM M-MEM-LOC) V))
		     (T (CONS-LAP-BARF M-MEM-LOC 'M-MEM-OVERFLOW 'DATA)))
	       (SETQ M-MEM-LOC (1+ M-MEM-LOC)))
	      ((EQ LOCALITY 'D-MEM)
	       (SETQ V (+ V DISPATCH-CONSTANT))	;CONSTANT FOR ENTIRE BLOCK
	       (SETQ V (+ (LSH (LDB 703 V) 14.)	;RPN BITS FROM JUMP
			  (LDB 1416 V)))		;PC FROM JUMP
	       (SETF (AREF D-MEM D-MEM-LOC) V)
	       (SETQ D-MEM-LOC (1+ D-MEM-LOC)))
	      ((EQ LOCALITY 'I-MEM)
	       (IF ( I-MEM-LOC (ARRAY-ACTIVE-LENGTH I-MEM))
		   (CONS-LAP-BARF I-MEM-LOC 'I-MEM-OVERFLOW 'DATA)
		 (SETF (AREF I-MEM I-MEM-LOC) V))
	       (SETQ I-MEM-LOC (1+ I-MEM-LOC)))
	      (T (CONS-LAP-BARF WD 'STORAGE-WD-IN-BAD-LOCALITY 'DATA)))
	(RETURN NIL)
	))

;add symbol to MC-LINKAGE-ALIST
(DEFUN CONS-LAP-MC-LINKAGE-STORE (ELEM)
  (PROG (MC-SYM CONSLP-SYM VAL TEM TYPE)
	(COND ((ATOM ELEM)
	       (SETQ MC-SYM ELEM CONSLP-SYM ELEM))
	      (T (SETQ MC-SYM (CAR ELEM) CONSLP-SYM (CADR ELEM))))
  	(SETQ VAL (GET CONSLP-SYM 'CONS-LAP-USER-SYMBOL))
    L	(COND ((NULL VAL) (RETURN NIL))
	      ((NUMBERP VAL))
	      ((ATOM VAL)
		(SETQ VAL (CONS-LAP-SYMEVAL VAL))
		(SETQ TYPE 'N)
		(GO L))
             ((AND (SETQ TEM (ASSQ (CAR VAL) 
			'( (I-MEM JUMP-ADDRESS-MULTIPLIER I)
                           (D-MEM DISPATCH-ADDRESS-MULTIPLIER D)
                           (A-MEM A-SOURCE-MULTIPLIER A)
                           (M-MEM M-SOURCE-MULTIPLIER M))))
                   (EQ (CAADR VAL) 'FIELD)
                   (EQ (CADADR VAL) (CADR TEM)))
              (SETQ VAL (CADDR (CADR VAL)))
	      (SETQ TYPE (CADDR TEM)))
	     (T (RETURN NIL)))
        (SETQ MC-LINKAGE-ALIST (CONS (LIST MC-SYM TYPE VAL) MC-LINKAGE-ALIST))
	))



;define MC-LINKAGE symbol as regular symbol
(DEFUN CONS-LAP-DEFINE-LINKAGE-SYMBOL (SYMBOL)
  (CONS-LAP-DEFSYM SYMBOL (CONS-LAP-MC-LINKAGE SYMBOL)))

;(MC-LINKAGE <SYMBOL>)
(DEFUN CONS-LAP-MC-LINKAGE (SYMBOL)
  (PROG (TEM V MULT MEM)
	(COND ((NULL (SETQ TEM (ASS (FUNCTION STRING-EQUAL) SYMBOL MC-LINKAGE-ALIST)))
	       (FERROR NIL "~%Undefined MC-LINKAGE symbol ~S" SYMBOL)))
	(SETQ MEM (STRING (CADR TEM)) V (CADDR TEM))
	(COND ((STRING-EQUAL MEM "N") (GO X))
	      ((SETQ TEM (ASS (FUNCTION STRING-EQUAL) MEM
			      '( ("I" JUMP-ADDRESS-MULTIPLIER I-MEM)
				("D" DISPATCH-ADDRESS-MULTIPLIER D-MEM)
				("A" A-SOURCE-MULTIPLIER A-MEM)
				("M" M-SOURCE-MULTIPLIER M-MEM))))
	       (SETQ MULT (CADR TEM) MEM (CADDR TEM)))
	      (T (FERROR NIL "~%Unknown memory name ~S" MEM)))
	(SETQ V `(,MEM (FIELD ,MULT ,V)))
    X   (RETURN V)
))

;(MC-LINKAGE-VALUE <MEMORY> <SYMBOL>)
(DEFUN CONS-LAP-MC-LINKAGE-VALUE (MEMORY SYMBOL)
  (PROG (V MULT)
	(COND ((NULL (SETQ V (ASS (FUNCTION STRING-EQUAL) SYMBOL MC-LINKAGE-ALIST)))
	       (FERROR NIL "~%Undefined MC-LINKAGE symbol ~S" SYMBOL)))
	(SETQ V (CADDR V))
	(COND ((STRING-EQUAL MEMORY "NUMBER") (GO X))
	      ((SETQ MULT (ASS (FUNCTION STRING-EQUAL) MEMORY
			       '( ("I-MEM" . JUMP-ADDRESS-MULTIPLIER)
				  ("D-MEM" . DISPATCH-ADDRESS-MULTIPLIER)
				  ("A-MEM" . A-SOURCE-MULTIPLIER)
				  ("M-MEM" . M-SOURCE-MULTIPLIER))))
	       (SETQ MULT (CDR MULT)))
	      (T (FERROR NIL "~%Unknown memory name ~S" MEMORY)))
	(SETQ V `(FIELD ,MULT ,V))
    X   (RETURN V)
))

(DEFUN CONS-LAP-WIPE-SYMBOL-VECTOR (QUAN)
  (PROG (IDX END-TEST)
	(SETQ IDX 0)
	(SETQ END-TEST (ARRAY-LENGTH MICRO-CODE-SYMBOL-IMAGE))
     L	(COND ((NOT (< IDX END-TEST))
	       (RETURN T))
	      ((NULL (AREF MICRO-CODE-SYMBOL-IMAGE IDX))
	       (SETF (AREF MICRO-CODE-SYMBOL-IMAGE IDX) QUAN)))
	(SETQ IDX (1+ IDX))
	(GO L)))

(DEFUN CONS-LAP-REPEAT-2 (COUNT LST)
  (PROG (ORPCNT RPCNT)
	(SETQ ORPCNT (CONS-LAP-SYMEVAL 'REPEAT-COUNT))
	(SETQ RPCNT 0)
     L	(COND ((ZEROP COUNT)
	       (CONS-LAP-SET 'REPEAT-COUNT ORPCNT)
	       (RETURN NIL)))
	(CONS-LAP-SET 'REPEAT-COUNT RPCNT)
	(MAPC (FUNCTION (LAMBDA (X) (CONS-LAP-PASS2 (COND ((ATOM X) (LIST X))
							  (T X)))))
	      LST)
	(SETQ COUNT (1- COUNT))
	(SETQ RPCNT (1+ RPCNT))
	(GO L)))

(DEFUN CONS-WORD-EVAL (WD)
  (PROG (COMBINED-VALUE COMBINED-INDICATORS DESTINATION-CONTEXT 
			INSTRUCTION-CONTEXT FIELD-INDICATORS FIELD-VALUE TEM TEM1 TEM2 
			DESTINATION-INDICATORS CURRENT-WORD)
	(SETQ COMBINED-VALUE 0)		;CAUTION! COMBINED-VALUE CAN BE A BIGNUM
	(SETQ CURRENT-WORD WD)		;SO CAN SEE IT WHEN STUFF COMPILED
	(SETQ INSTRUCTION-CONTEXT 'INSTRUCTION)
     L	(SETQ FIELD-INDICATORS NIL)
	(COND ((NULL WD) (RETURN 
			  (CONS-LAP-DEFAULT-AND-BUGGER 
			   INSTRUCTION-CONTEXT 
			   COMBINED-VALUE
			   COMBINED-INDICATORS 
			   DESTINATION-INDICATORS)))
	      ((NUMBERP (CAR WD))
	       (SETQ FIELD-VALUE (CAR WD)))
	      ((ATOM (CAR WD))
	       (SETQ FIELD-VALUE (CONS-LAP-SYM-RUN (CAR WD))))
	      ((EQ (CAAR WD) 'M-CONSTANT)
	       (SETQ FIELD-VALUE (CONS-M-CONSTANT (CADAR WD))))
	      ((EQ (CAAR WD) 'A-CONSTANT)
	       (SETQ FIELD-VALUE (CONS-A-CONSTANT (CADAR WD))))
	      ((SETQ TEM 
		     (ASSQ (CAAR WD) 
			   '((ARG-CALL . 3_14.)		     ;P-BIT N-BIT
			     (ARG-JUMP . 1_14.)		     ;N-BIT
			     (ARG-CALL-XCT-NEXT . 2_14.)     ;P-BIT
			     (ARG-JUMP-XCT-NEXT . 0_14.) ))) ; NONE
	       (SETQ TEM1 (CONS-LAP-ARG-EVAL (CADAR WD))) ;TAG
	       (SETQ TEM2 (ASSOC I-MEM-LOC ARG-CALL-LIST))
	       (COND ((NULL TEM2) 
		      (CONS-LAP-BARF I-MEM-LOC 
				     'NO-D-MEM-RESERVED-FOR-ARG-CALL 
				     'BARF)))
	       (SETF (AREF D-MEM (CDR TEM2))
		     (+ (CDR TEM) (LDB 1416 TEM1)))
	       (CONS-GET-NEW-CONTEXT 'FORCE-DISPATCH)
	       (ADD-FIELD-INDICATORS 'D-MEM)
	       (SETQ FIELD-VALUE (* (CDR TEM2) 1_12.)))
	      ((MEMQ (CAAR WD) '(BYTE-FIELD LISP-BYTE ALL-BUT-LISP-BYTE 
					    FIELD BYTE-MASK BYTE-VALUE PLUS DIFFERENCE 
					    OA-HIGH-CONTEXT OA-LOW-CONTEXT EVAL I-ARG
					    I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC
					    MC-LINKAGE MC-LINKAGE-VALUE
					    MC-ENTRY-ADR MISC-ENTRY-ADR))
	       (SETQ FIELD-VALUE (CONS-LAP-EVAL (CAR WD))))
	      (T
	       (CONS-GET-NEW-CONTEXT 'FORCE-ALU-OR-BYTE)
	       (SETQ FIELD-VALUE (CONS-DESTINATION (CAR WD)))
	       
	       (SETQ FIELD-VALUE 
		     (CONVERT-VALUE-TO-DESTINATION FIELD-VALUE FIELD-INDICATORS))
	       (SETQ DESTINATION-INDICATORS FIELD-INDICATORS)
	       (SETQ FIELD-INDICATORS NIL)) )
	(SETQ COMBINED-VALUE (PLUS COMBINED-VALUE FIELD-VALUE))
;	(PRINT (LIST (CAR WD) FIELD-VALUE FIELD-INDICATORS))
	(SETQ COMBINED-INDICATORS (MERGE-INDICATORS 
				   FIELD-INDICATORS COMBINED-INDICATORS))
	(SETQ WD (CDR WD))
	(GO L)
	))

(DEFUN CONS-LAP-DEFAULT-AND-BUGGER 
         (INSTRUCTION-CONTEXT COMBINED-VALUE COMBINED-INDICATORS DESTINATION-INDICATORS)
  (PROG (T1 T2 INST)
;	(PRINT (LIST INSTRUCTION-CONTEXT 
;		     COMBINED-VALUE 
;		     COMBINED-INDICATORS 
;		     DESTINATION-INDICATORS))
	(COND ((NOT (EQ LOCALITY 'I-MEM))
	       (GO X))
	      ((MEMQ INSTRUCTION-CONTEXT '(FORCE-ALU FORCE-ALU-OR-BYTE INSTRUCTION))
	       (GO ALU))
	      ((EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH)
	       (GO DISPATCH))
	      ((EQ INSTRUCTION-CONTEXT 'FORCE-BYTE)
	       (GO BYTE))
	      ((EQ INSTRUCTION-CONTEXT 'FORCE-JUMP)
	       (GO JUMP))
	      (T (CONS-LAP-BARF (LIST INSTRUCTION-CONTEXT 
				      COMBINED-VALUE COMBINED-INDICATORS
				      DESTINATION-INDICATORS)
				'BAD-INSTRUCTION-TYPE
				'WARN)
		 (GO X)))
    ALU (COND ((NULL (MEMQ 'ALU-OUTPUT-BUS-SELECTOR-MULTIPLIER 	;DEFAULT OUTPUT BUS
			   COMBINED-INDICATORS))		;SELECTOR IF NOT SPECD
	       (SETQ COMBINED-VALUE (PLUS COMBINED-VALUE 1_12.))))
	(COND ((MEMQ 'ALU-OP COMBINED-INDICATORS)
	       (GO ALU-1)))
	(SETQ T1 (MEMQ 'A-MEM COMBINED-INDICATORS))		;DEFAULT ALU OP IF NOT
	(SETQ T2 (MEMQL '(M-MEM FUNCTION-SOURCE) COMBINED-INDICATORS))	;SPECD
	(COND ((AND T1 T2)			;(ALU MUST BE ACTING AS A SELECTOR)
	       (CONS-LAP-BARF COMBINED-INDICATORS 
			      'ALU-INST-ADRS-A-AND-M-WITHOUT-ALU-OP 
			      'WARN))
	      (T1 (SETQ COMBINED-VALUE 
			(PLUS COMBINED-VALUE 5_3)))	;SETA
	      (T2 (SETQ COMBINED-VALUE 
			(PLUS COMBINED-VALUE 3_3)))	;SETM
	      (T  (SETQ COMBINED-VALUE 
			(PLUS COMBINED-VALUE 0_3))))	;NEITHER SPECD? SETZ I GUESS
     ALU-1
       (GO X)
     BYTE
       (COND ((NULL (MEMQ 'A-MEM COMBINED-INDICATORS))	;DEFAULT A-MEM ADR TO
	      (SETQ COMBINED-VALUE 			;A-ZERO IF NOT SUPPLIED,
		    (PLUS COMBINED-VALUE 2_32.)))) ;THIS RIGHT FOR BOTH LDB AND DPB
       (SETQ INST 600000000000000)			;BYTE INST
       (SETQ T1 (LDB 1401 COMBINED-VALUE))	;GET SR-BIT
       (SETQ COMBINED-VALUE (DPB (- 1 T1) ;STORE IT BACK COMPLEMENTED
				    1401 COMBINED-VALUE))
       (COND ((> (LDB 1402 COMBINED-VALUE) 1)
	      (GO X1)))	;DONT BUGGER DPB OR SEL DEPOS
     M-ROTATE-BUGGER				;32. REFLECT M-ROTATE FIELD
       (SETQ T1 (LOGAND 6037 COMBINED-VALUE))	;GOBBLE MISC FCTN
       ;AND M-ROTATE
     M-ROTATE-BUGGER-1
       (SETQ T1 (LOGAND 37 T1))
       (SETQ T2 (LOGAND 37 (- 40 T1)))
       (SETQ COMBINED-VALUE (PLUS COMBINED-VALUE (- T2 T1)))
     X1	(SETQ COMBINED-VALUE (PLUS COMBINED-VALUE INST))
     X	(RETURN COMBINED-VALUE)
     DISPATCH 
       (SETQ INST 1400000000000000)	;DISPATCH INSTRUCTION PLUS I-LONG
       ;(SETQ INST 400000000000000)	;JUST DISPATCH INSTRUCTION
       (GO M-ROTATE-BUGGER)
     JUMP 
       (SETQ INST 200000000000000)
       (SETQ T1 (LOGAND 6077 COMBINED-VALUE))
       (COND ((> (LOGAND T1 77) 37) (GO X1)))	;TEST-CONDITION, DONT HACK
       (GO M-ROTATE-BUGGER-1)		;RANDOMLY SAVE A BIGNUM OP
       ))

;CONSTANT LISTS.
;A LIST OF LISTS.  CAR IS VALUE OF CONSTANT, CADR IS ADDRESS, CADDR IS #USERS, CADDDR IS 
;	LAST PC TO USE IT.

(DEFUN CONS-M-CONSTANT (C)
  (PROG (TEM V)
	(SETQ V (CONS-LAP-ARG-EVAL C))
	(COND ((= V 0) 
		(SETQ TEM 2))	;M LOCN 2 ALWAYS HAS 0
	      ((OR (= V 37777777777) (= V -1))
	       (SETQ TEM 3))	;M LOCN 3 ALWAYS HAS -1 (TO 32 BITS)
	      ((SETQ TEM (ASSOC V M-CONSTANT-LIST))
	        (RPLACA (CDDR TEM) (1+ (CADDR TEM)))
		(RPLACA (CDDDR TEM) CONS-LAP-LAST-SYM)
		(SETQ TEM (CADR TEM)))
	      (T
		(SETQ TEM M-CONSTANT-LOC M-CONSTANT-LOC (1+ M-CONSTANT-LOC))
		(SETQ M-CONSTANT-LIST (CONS (LIST V TEM 1 CONS-LAP-LAST-SYM) M-CONSTANT-LIST))))
	(OR (< TEM 40) (CONS-LAP-BARF (LIST TEM C) 'M-CONST-ADDR-OOB 'BARF))
	(ADD-FIELD-INDICATORS 'M-MEM)
	(RETURN (DPB TEM 3205 0)) ))

(DEFUN CONS-A-CONSTANT (C)
  (PROG (TEM V)
	(SETQ V (CONS-LAP-ARG-EVAL C))
	(COND ((= V 0) 
		(SETQ TEM 2))	;A LOCN 2 ALWAYS HAS 0
	      ((OR (= V 37777777777) (= V -1))
	       (SETQ TEM 3))	;A LOCN 3 ALWAYS HAS -1 (TO 32 BITS)
	      ((SETQ TEM (ASSOC V A-CONSTANT-LIST))
	        (RPLACA (CDDR TEM) (1+ (CADDR TEM)))
		(RPLACA (CDDDR TEM) CONS-LAP-LAST-SYM)
		(SETQ TEM (CADR TEM)))
	      ((SETQ TEM (ASSOC V M-CONSTANT-LIST))	;A=M!!
	        (RPLACA (CDDR TEM) (1+ (CADDR TEM)))
		(RPLACA (CDDDR TEM) CONS-LAP-LAST-SYM)
		(SETQ TEM (CADR TEM)))
	      ((NOT (NULL A-MEM-CREVICE-LIST))	;TRY TO FILL IN CREVICES IN MEMORY
		(SETQ TEM (CAR A-MEM-CREVICE-LIST))
		(SETQ A-MEM-CREVICE-LIST (CDR A-MEM-CREVICE-LIST))
		(SETQ A-CONSTANT-LIST (CONS (LIST V TEM 1 CONS-LAP-LAST-SYM) A-CONSTANT-LIST)))
	      (T
		(SETQ TEM A-CONSTANT-LOC A-CONSTANT-LOC (1+ A-CONSTANT-LOC))
		(SETQ A-CONSTANT-LIST (CONS (LIST V TEM 1 CONS-LAP-LAST-SYM)
					    A-CONSTANT-LIST))))
	(OR (< TEM 2000) (CONS-LAP-BARF (LIST TEM C) 'A-CONST-ADDR-OOB 'BARF))
	(ADD-FIELD-INDICATORS 'A-MEM)
	(RETURN (DPB TEM 4012 0)) ))

(DEFUN CONVERT-VALUE-TO-DESTINATION (VALUE INDICATORS)
  (PROG (V)
	(SETQ V (LDB 0012 VALUE))	;GOBBLE BYTE INFO, IF ANY (HOPE HOPE)
	(COND ((MEMQ 'A-MEM INDICATORS)
	       (COND ((MEMQL '(M-MEM FUNCTION-DESTINATION) INDICATORS)
		      (CONS-LAP-BARF (LIST VALUE INDICATORS) 'BAD-DESTINATION 'DATA)))
	       (SETQ V (+ V (DPB (LDB 4012 VALUE) 1612 0))))
	      ((MEMQ 'M-MEM INDICATORS)
	       (SETQ V (+ V (DPB (LDB 3206 VALUE) 1606 0)))))
	(COND ((MEMQ 'FUNCTION-DESTINATION INDICATORS)
	       (SETQ V (+ V (LOGAND 37_19. VALUE)))))
	(COND ((MEMQL '(A-MEM) INDICATORS)
	       (SETQ V (+ V 1_25.))))
	(RETURN V)
))

(DEFUN MERGE-INDICATORS (A B) (MERGE A B))

(DEFUN MERGE (A B)
  (PROG NIL 
	(COND ((NULL B) (RETURN A)))
  L	(COND ((NULL A) (RETURN B))
	      ((NOT (MEMQ (CAR A) B))
		(SETQ B (CONS (CAR A) B))))
	(SETQ A (CDR A))
	(GO L)))

(DEFUN CONS-DESTINATION (X)
  (PROG (DESTINATION-CONTEXT V)
	(SETQ V 0)
	(SETQ DESTINATION-CONTEXT 'DESTINATION)
	(COND ((NULL (CDR X))	;SAVE A PLUS IN COMMON CASE..
		(RETURN (CONS-LAP-SYM-RUN (CAR X)))))
L	(COND ((NULL X) (RETURN V)))
	(SETQ V (PLUS V (CONS-LAP-SYM-RUN (CAR X))))
	(SETQ X (CDR X))
	(GO L)
))

(DEFUN CONS-LAP-SYM-RUN (SYM)
  (PROG (TEM)
	(COND ((NULL (SETQ TEM (CONS-LAP-SYMEVAL SYM)))
		(CONS-LAP-BARF SYM 'UNDEFINED-SYM 'WARN)
		(RETURN 0))
	      (T (RETURN (CONS-LAP-EVAL TEM))))))

(DEFUN CONS-LAP-ARG-EVAL (ARG)
  (PROG (COMBINED-VALUE COMBINED-INDICATORS DESTINATION-CONTEXT 
         INSTRUCTION-CONTEXT FIELD-INDICATORS)
	(SETQ INSTRUCTION-CONTEXT 'INSTRUCTION)
	(RETURN (CONS-LAP-EVAL ARG))))

(DEFUN CONS-LAP-EVAL (EXP)      ;EXP A SYMBOL "PROGRAM".
				;RETURNS EITHER A NUMBERIC VALUE OR NIL, AND
				;MAY HAVE THE SIDE EFFECT OF MODIFING 
				;INSTRUCTION-CONTEXT AND/OR FIELD-INDICATORS

  (PROG (VAL V V1 V2 TEM)
L	(COND ((NULL EXP) (GO X))
	      ((NUMBERP EXP)
		(SETQ V EXP)
		(GO C-V))
	      ((ATOM EXP) 
		(SETQ V (CONS-LAP-SYM-RUN EXP))
		(GO C-V))
	      ((MEMQ (CAR EXP) '(A-MEM M-MEM I-MEM D-MEM))
		(GO L2))
	      ((EQ (CAR EXP) 'SOURCE-P) (GO S-P))
	      ((EQ (CAR EXP) 'DESTINATION-P) (GO D-P))
	      ((MEMQ (CAR EXP) '(FORCE-DISPATCH FORCE-JUMP FORCE-ALU FORCE-BYTE 
			FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE))
		(CONS-GET-NEW-CONTEXT (CAR EXP))
		(GO L2))
	      ((SETQ TEM (ASSQ (CAR EXP) '( (DISPATCH-INSTRUCTION-P . FORCE-DISPATCH)
		(BYTE-INSTRUCTION-P . FORCE-BYTE) (JUMP-INSTRUCTION-P . FORCE-JUMP)
		(ALU-INSTRUCTION-P . FORCE-ALU))))
		(GO I-P))
	      ((EQ (CAR EXP) 'NOT)
		(GO N1))
	      ((EQ (CAR EXP) 'OR)
		(GO OR-1))
	      ((SETQ V (ASSQ (CAR EXP)
			     '((I-MEM-LOC . I-MEM) (D-MEM-LOC . D-MEM)
			       (A-MEM-LOC . A-MEM) (M-MEM-LOC . M-MEM))))
		(SETQ TEM (CONS-LAP-SYMEVAL (CADR EXP)))
		(OR (EQ (CAR TEM) (CDR V))
		    (CONS-LAP-BARF EXP 'LOSES 'DATA))
		(SETQ V (CADDR (CADR TEM)))
		(GO C-V))
	      ((EQ (CAR EXP) 'FIELD)
		(SETQ TEM (CONS-LAP-SYM-RUN (CADR EXP)))
		(SETQ V (TIMES (CONS-LAP-EVAL (CADDR EXP)) TEM))
		(COND ((SETQ TEM (GET (CADR EXP) 'CONS-LAP-ADDITIVE-CONSTANT))
			(SETQ V (PLUS V TEM))))
		(ADD-FIELD-INDICATORS (CADR EXP))
		(GO C-V))
	      ((EQ (CAR EXP) 'PLUS)
		(SETQ V (CONS-LAP-EVAL (CADR EXP)))
		(DO L (CDDR EXP) (CDR L) (NULL L)
		  (SETQ V (PLUS V (CONS-LAP-EVAL (CAR L)))))
		(GO C-V))
	      ((EQ (CAR EXP) 'DIFFERENCE)
		(SETQ V (DIFFERENCE (CONS-LAP-EVAL (CADR EXP))
				    (CONS-LAP-EVAL (CADDR EXP))))
		(GO C-V))
	      ((EQ (CAR EXP) 'BYTE-FIELD)
		(COND ((MEMQ INSTRUCTION-CONTEXT '(INSTRUCTION FORCE-DISPATCH-OR-BYTE 
							FORCE-ALU-OR-BYTE))
			(CONS-GET-NEW-CONTEXT 'FORCE-BYTE)))
		(SETQ V1 (CONS-LAP-EVAL (CADR EXP)) V2 (CONS-LAP-EVAL (CADDR EXP)))
		(COND ((EQ INSTRUCTION-CONTEXT 'FORCE-BYTE)
		       (AND (> V1 32.) (CONS-LAP-BARF (CADR EXP)
						      'BYTE-SIZE-GREATER-THAN-32
						      'DATA))
		       (AND (ZEROP V1) (SETQ V1 1))	;BYTE SIZE 0, DOING OA HACKERY, USE 1-1
		       (SETQ V (+ (* 1_5. (1- V1)) V2))) ;1- BYTE SIZE, MROT NOT BUGGERED YET
		      ((EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH)
			(AND (> V1 7) (CONS-LAP-BARF (CADR EXP)
						     'DISPATCH-BYTE-SIZE-GREATER-THAN-7
						     'DATA))
			(SETQ V (+ (* 1_5. V1) V2)))
		      ((EQ INSTRUCTION-CONTEXT 'FORCE-JUMP)
			(COND ((NOT (= 1 V1))
				(CONS-LAP-BARF (CADR EXP) 
						'CAN-ONLY-TEST-ONE-BIT-FIELD-WITH-JUMP 
						 'DATA)))
			(SETQ V V2))
		      (T (CONS-LAP-BARF INSTRUCTION-CONTEXT 
					'BYTE-FIELD-IN-BAD-CONTEXT 
					'DATA)))
		(GO C-V))
	      ((EQ (CAR EXP) 'LISP-BYTE)
		(SETQ V (CONS-LAP-EVAL (CONVERT-LISP-BYTE (CADR EXP))))
		(GO C-V))
	      ((EQ (CAR EXP) 'ALL-BUT-LISP-BYTE)
		(SETQ V (CONS-LAP-EVAL (CONVERT-ALL-BUT-LISP-BYTE (CADR EXP))))
		(GO C-V))
	      ((EQ (CAR EXP) 'BYTE-MASK)
		(SETQ V (CONS-LAP-GET-BYTE-VALUE (CADR EXP) -1))
		(GO C-V))
	      ((EQ (CAR EXP) 'BYTE-VALUE)
		(SETQ V (CONS-LAP-GET-BYTE-VALUE (CADR EXP) (CADDR EXP)))
		(GO C-V))
	      ((EQ (CAR EXP) 'EVAL)
		(SETQ V (EVAL (CADR EXP)))
		(GO C-V))
	      ((EQ (CAR EXP) 'I-ARG)
		(SETQ V (DPB (CONS-LAP-EVAL (CADR EXP))
				4012 
				0))
		(GO C-V))
	      ((EQ (CAR EXP) 'OA-HIGH-CONTEXT)
		(SETQ V (LDB 3226 (CONS-WORD-EVAL (CADR EXP)))) ;ALL ABOVE 26. BITS
		(GO C-V))
	      ((EQ (CAR EXP) 'OA-LOW-CONTEXT)
		;  (SETQ V (LDB 0032 (CONS-WORD-EVAL (CADR EXP)))) ;LOW 26. BITS
		   (SETQ V (LET ((TEM-V (CONS-WORD-EVAL (CADR EXP))))  ;RESULT OF LDB CANT BE
			     (DPB (LDB 2703 TEM-V) 2703 (LDB 0027 TEM-V)))) ;BIGNUM FOR NOW.
		(GO C-V))
	      ((AND (EQ (CAR EXP) 'MC-LINKAGE)
		    (SYMBOLP (CADR EXP)))
	       (SETQ V (CONS-LAP-EVAL (CONS-LAP-MC-LINKAGE (CADR EXP))))
	       (GO C-V))
	      ((EQ (CAR EXP) 'MC-LINKAGE-VALUE)
	       (SETQ V (CONS-LAP-EVAL (CONS-LAP-MC-LINKAGE-VALUE (CADR EXP) (CADDR EXP))))
	       (GO C-V))
	      ((AND CONS-LAP-INIT-STATE		;incremental assembly
		    (EQ (CAR EXP) 'MC-ENTRY-ADR))
	       (COND ((NOT (= (%DATA-TYPE
				(SETQ TEM (CAR (FUNCTION-CELL-LOCATION (CADR EXP)))))
			      DTP-U-ENTRY))
		(FERROR NIL "mc-entry-adr not DTP-U-ENTRY")))
	       (SETQ V (CONS-LAP-EVAL
			 `(I-MEM (FIELD JUMP-ADDRESS-MULTIPLIER
					,(AR-1 (FUNCTION SYS:MICRO-CODE-SYMBOL-AREA)
					       (AR-1 (FUNCTION SYS:MICRO-CODE-ENTRY-AREA)
						     (%POINTER TEM)))))))
	       (GO C-V))
	      ((AND CONS-LAP-INIT-STATE		;incremental assembly
		    (EQ (CAR EXP) 'MISC-ENTRY-ADR))
	       (SETQ V (CONS-LAP-EVAL
			 `(I-MEM (FIELD JUMP-ADDRESS-MULTIPLIER
					,(AR-1 (FUNCTION SYS:MICRO-CODE-SYMBOL-AREA)
					       (- (GET (CADR EXP) 'QLVAL) 200))))))
	       (GO C-V))
	      (T (CONS-LAP-BARF EXP 'UNRECGONIZED-OP 'DATA)
		 (GO X)))
OR-2	(COND ((NULL (CDR (SETQ EXP (CDR EXP))))
		(GO X)))				;ALL NIL
OR-1	(SETQ TEM (CONS-LAP-EVAL (CADR EXP)))
	(COND ((NULL TEM) (GO OR-2)))	;THAT ONE EVALUATED TO NIL
MERGE-V	(COND ((NULL VAL) (SETQ VAL TEM))
	      (T (SETQ VAL (PLUS VAL TEM))))
	(GO X)
N1	(SETQ TEM (CONS-LAP-EVAL (LIST (CAADR EXP) 1)))
	(COND ((= TEM 1) (GO X))   ;THAT CONDITION TRUE, THIS FALSE
	      (T (SETQ EXP (CADR EXP))	;THAT CONDITION FALSE, THIS TRUE
		 (GO L1)))
D-P	(COND (DESTINATION-CONTEXT (GO L1)))
	(GO X)
S-P	(COND (DESTINATION-CONTEXT (GO X)))
	(GO L1)

L2	(ADD-FIELD-INDICATORS (CAR EXP))
L1	(SETQ EXP (CADR EXP))
	(GO L)
I-P	(COND ((EQ (CDR TEM) INSTRUCTION-CONTEXT)
		(GO L1))		;CONDITION TRUE
	      ((EQ INSTRUCTION-CONTEXT 'INSTRUCTION)
		(CONS-LAP-BARF EXP 'UNDETERMINED-CONDITION 'WARN)))
	(GO X)		;CONDITION FALSE
C-V	(COND ((NULL VAL) (SETQ VAL 0)))
	(COND ((NULL V)
	       (CONS-LAP-BARF EXP 'EVALUATED-TO-NIL 'DATA))
	      (T (SETQ VAL (PLUS VAL V))))
X	(RETURN VAL) ))

(DEFUN CONVERT-LISP-BYTE (X)  ;CONVERT LISP-BYTE TO CORRESPONDING BYTE-FIELD
  (PROG (TEM)
	(SETQ TEM (EVAL X))
	(RETURN (LIST 'BYTE-FIELD (LOGAND TEM 77) 
				  (LDB 0606 TEM)
))))

(DEFUN CONVERT-ALL-BUT-LISP-BYTE (X)	;ADDRESS ALL BITS NOT IN BYTE. BYTE MUST BE
  (PROG (TEM BITS OVER)			;LEFT OR RIGHT ADJUSTED IN 32. BITS
	(SETQ TEM (EVAL X))
	(SETQ BITS (LOGAND TEM 77) OVER (LDB 0606 TEM))
	(COND ((= 0 OVER)
		(SETQ OVER BITS)
		(SETQ BITS (- 32. BITS)))
	      ((= 32. (+ BITS OVER))
		(SETQ BITS (- 32. BITS))
		(SETQ OVER 0))
	      (T (CONS-LAP-BARF X 'ALL-BUT-BYTE-NOT-LEFT-OR-RIGHT-ADJUSTED 'DATA)))
	(RETURN (LIST 'BYTE-FIELD BITS OVER))))

(DEFUN CONS-LAP-GET-BYTE-VALUE (EXP VAL);"EVALUATE" EXP SIMILIAR TO CONS-LAP-EVAL
  (PROG (TEM)				;BUT RETURN NIL FOR ANYTHING BUT BYTE-FIELD,
	(COND ((NUMBERP VAL))		;FOR WHICH RETURN VAL IN FIELD OF BYTE
	      ((NOT (ATOM VAL))
	       (SETQ VAL (CONS-LAP-ARG-EVAL VAL)))
	      ((SETQ TEM (CONS-LAP-SYMEVAL VAL))
	       (SETQ VAL TEM))
	      ((SETQ VAL (CONS-LAP-LISP-SYMEVAL VAL))))
	(COND ((NULL EXP) (RETURN NIL))
	      ((NUMBERP EXP)
		(RETURN (CONS-LAP-GET-BYTE-VALUE (CONVERT-LISP-BYTE EXP) VAL)))
	      ((ATOM EXP)
		(RETURN (CONS-LAP-GET-BYTE-VALUE
			  (OR (CONS-LAP-SYMEVAL EXP) (CONS-LAP-LISP-SYMEVAL EXP)) VAL)))
	      ((MEMQ (CAR EXP) '(M-MEM FORCE-DISPATCH FORCE-BYTE FORCE-DISPATCH-OR-BYTE 
				 FORCE-ALU-OR-BYTE))
		(RETURN (CONS-LAP-GET-BYTE-VALUE (CADR EXP) VAL)))
	      ((MEMQ (CAR EXP) '(A-MEM I-MEM D-MEM SOURCE-P DESTINATION-P FORCE-JUMP
				FORCE-ALU NOT OR FIELD EVAL))
		(RETURN NIL))
	      ((EQ (CAR EXP) 'PLUS)
		(RETURN (DO L (CDR EXP) (CDR L) (NULL L)
			  (AND (SETQ TEM (CONS-LAP-GET-BYTE-VALUE (CAR L) VAL))
			       (RETURN TEM)))))
	      ((EQ (CAR EXP) 'LISP-BYTE)
		(RETURN (CONS-LAP-GET-BYTE-VALUE (CONVERT-LISP-BYTE (CADR EXP)) VAL)))
	      ((EQ (CAR EXP) 'BYTE-FIELD)
		(RETURN (DPB VAL (+ (LSH (CADDR EXP) 6) (CADR EXP)) 0)))
	      (T (CONS-LAP-BARF EXP 'CONS-LAP-GET-BYTE-VALUE 'WARN)))
))

(DEFUN ADD-FIELD-INDICATORS (X)
  (PROG NIL 
	(COND ((AND DESTINATION-CONTEXT   ;BETTER NOT PUT IN MORE THAN ONE OF THESE
		    (MEMQ X '(A-MEM M-MEM I-MEM D-MEM))  ;SINCE GOING TO DIVIDE IT OUT.
		    (MEMQL '(A-MEM M-MEM I-MEM D-MEM) FIELD-INDICATORS))
		(GO E1)))
	(COND ((EQ X 'A-MEM)
		(GO X))
	      ((EQ X 'M-MEM)
		(GO X))
	      ((EQ X 'I-MEM)
		(GO ADD-I))
	      ((EQ X 'D-MEM)
		(GO ADD-D))
	      ((EQ X 'FORCE-DISPATCH)
		(GO F-D))
	      ((EQ X 'FORCE-BYTE)
		(GO F-B))
	      ((EQ X 'FORCE-ALU)
		(GO F-A))
	      ((EQ X 'FORCE-JUMP)
		(GO F-J)))
   X	(COND ((NOT (MEMQ X FIELD-INDICATORS))
		(SETQ FIELD-INDICATORS (CONS X FIELD-INDICATORS))))
	(RETURN NIL)
 F-B	(COND ((MEMQL '(I-MEM D-MEM) COMBINED-INDICATORS)
		(GO E1)))
	(GO X)
 F-A	(COND ((OR (MEMQ INSTRUCTION-CONTEXT '(FORCE-DISPATCH FORCE-JUMP))
		   (MEMQL '(I-MEM D-MEM) COMBINED-INDICATORS))
		(GO E1)))
	(GO X)
 F-J 
 ADD-I	(COND ((MEMQ INSTRUCTION-CONTEXT '(FORCE-DISPATCH FORCE-BYTE FORCE-ALU))
		(GO E1)))
	(GO X)
 F-D 
 ADD-D	(COND ((OR (MEMQ INSTRUCTION-CONTEXT '(FORCE-JUMP FORCE-BYTE FORCE-ALU))
		   (MEMQL '(I-MEM) COMBINED-INDICATORS))  ;A-MEM OK NOW IF WRITING DRAM
		(GO E1)))
	(GO X)
  E1	(CONS-LAP-BARF (LIST X FIELD-INDICATORS COMBINED-INDICATORS)
	      'INDICATOR-CONFLICT 
	      'DATA)
	(RETURN NIL)
))

(DEFUN MEMQL (A B)
  (PROG NIL 
L	(COND ((NULL A) (RETURN NIL))
	      ((MEMQ (CAR A) B) (RETURN A)))
	(SETQ A (CDR A))
	(GO L)))

(DEFUN CONS-GET-NEW-CONTEXT (NEW-CONTEXT)
  (PROG NIL
	(COND ((ATOM NEW-CONTEXT) 
		(RETURN (CONS-GET-NEW-CONTEXT-1 NEW-CONTEXT))))
L	(COND ((NULL NEW-CONTEXT) (RETURN T))
	      (T (CONS-GET-NEW-CONTEXT-1 (CAR NEW-CONTEXT))))
	(SETQ NEW-CONTEXT (CDR NEW-CONTEXT))
	(GO L)))

(DEFUN CONS-GET-NEW-CONTEXT-1 (NEW)
  (PROG NIL 
	(COND ((OR (EQ INSTRUCTION-CONTEXT NEW)
		   (NOT (MEMQ NEW '(FORCE-DISPATCH FORCE-JUMP FORCE-ALU FORCE-BYTE 
			FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE))))
		(RETURN NIL))
	      ((EQ INSTRUCTION-CONTEXT 'INSTRUCTION)
		(GO N1))
	      ((AND (EQ INSTRUCTION-CONTEXT 'FORCE-BYTE)
		    (MEMQ NEW '(FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE)))
		(RETURN NIL))
	      ((AND (EQ INSTRUCTION-CONTEXT 'FORCE-ALU)
		    (EQ NEW 'FORCE-ALU-OR-BYTE))
		(RETURN NIL))
	      ((AND (EQ NEW 'FORCE-BYTE)
		    (MEMQ INSTRUCTION-CONTEXT
			  '(FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE)))
		(GO N1))
	      ((AND (EQ NEW 'FORCE-ALU)
		    (EQ INSTRUCTION-CONTEXT 'FORCE-ALU-OR-BYTE))
		(GO N1))
	      ((OR (AND (EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH-OR-BYTE)
			(EQ NEW 'FORCE-ALU-OR-BYTE))
		   (AND (EQ NEW 'FORCE-ALU-OR-BYTE)
			(EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH-OR-BYTE)))
		(SETQ NEW 'FORCE-BYTE)
		(GO N1)))
	(CONS-LAP-BARF (LIST INSTRUCTION-CONTEXT NEW) 'CONFLICTING-CONTEXT 'DATA)
	(RETURN NIL)
  N1	(SETQ INSTRUCTION-CONTEXT NEW)
	(RETURN T)
))