;;;CADR MACHINE MICROCODE		-*-MIDAS-*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;	HERE COMES A MAN
;	TO LEAD YOU TO
;	YOUR VERY OWN MACHINE! 
;		TOMMY, THE WHO

; "Microprogramming is a wasteland of time and too dependent on
;	the technology of implementation."  --Gordon Bell


(SETQ UCADR  '(

;Notes re the ERROR-TABLE pseudo-op:
;  If the error list contains the symbol CALLS-SUB, the entry serves only
;to mark an interesting item for the user on the micro-stack.  Accordingly,
;the entry should be positioned to match with whats on the stack at the time of
;the error. In particular, it should be after the following instruction in case of
;CALL-XCT-NEXT, etc.  No EHS- properties or routines are associated in this case.
;  Otherwise, the entry is intended to match with trap location saved at location
;TRAP.  In this case it should also come after an XCT-NEXT'ed instruction if there is any.
;  These entries (may well) 
;coordinate with error recovery/printout routines in LMWIN;EHR >.  So check
;EHR when making changes in the vicinity of an ERROR-TABLE which does not
;have a CALLS-SUB.  In particular, if the ERROR-TABLE entry is proceedable or to be made
;proceedable, make sure relevant quantities are all held in ACs that get saved
;(M-A, etc) as opposed to ones that dont (M-3, A-TEM1 etc).

;  To mark a point in the code to which proceed-routines may want to go,
;put an (ERROR-TABLE RESTART <name>) BEFORE the instruction.  <name> is any
;arbitrary symbol that does not conflict with any other used.

;Notes re the MC-LINKAGE pseudo-op:
; This mechanism provides linkage between microcompiled code and the main ULOAD.
;You say (MC-LINKAGE (<SYM> ..)) and the address within memory and memory of <SYM>s will
;be available to the microcompiled code loader and/or the assembler operating in incremental
;mode.  If the list element is non-atomic, CAR is the microcompiled symbol, CADR the UCADR
;symbol. Currently, this info is transferred via an entry in the assembler state written
;at the beginning of the SYM file, but it will probably be moved to the TBL file
;eventually.  All A or M memory symbols with values less than 40 are automatically
;MC-LINKAGEified.
;  As a consequence of this mechanism, all microcompiler "dependancy links"
;go through MISC-INST-ENTRYs or MC-LINKAGEs.  The main symbol table is not required.  

(MC-LINKAGE ( (T M-T) (B M-B) (R M-R) (C M-C) (TEM M-TEM) A-ZERO A-V-NIL A-V-TRUE 
	      A-DISK-RUN-LIGHT 
	      SKIP-IF-ATOM SKIP-IF-NO-ATOM
	      D-READ-EXIT-VECTOR D-WRITE-EXIT-VECTOR D-CALL-EXIT-VECTOR
	      D-SE1+ D-SE1- D-SECDR D-SECDDR D-START-LIST D-START-LIST-AREA
	      D-MMCALL D-MMCALT D-MMCALB
	      D-BNDPOP D-BNDNIL D-SETNIL D-SETZERO 
	      D-GET-LOCATIVE-TO-PDL D-GET-LOCATIVE-TO-VC D-POP-SPECPDL
	      D-UCTOM D-MMISU D-MURV D-MRNV D-MR2V D-MR3V
	      D-SUB-PP D-POP-SPECPDL-AND-SUB-PP D-DO-SPECBIND-PP-BASED
	      QMADDD QMADD QMAD QMA QMDDDD QMDDD QMDD QMD QMAAAA QMAAA QMAA
	      QMAAAD QMDDDA QMAADD QMAAD QMAADA QMDDAA QMDDA QMDDAD QMADAA QMADA
	      QMADAD QMADDA QMDADA QMDAD QMDADD QMDAAA QMDAA QMDA QMDAAD
	      QMEQL QMEQ QMLSP QMGRP
	      XTCADD XTCSUB XTCMUL XTCDIV XTCAND XTCIOR XTCXOR   ;LAST-ARG-IN-T-ENTRYs
	      XTNUMB XTLENG XTFIXP XTFLTP
	      MC-STORE-NEXT-LIST MC-STORE-LAST-LIST
	      MC-SPREAD
	      ;UCTO XMBIND 
    ;These for hand code (for now at least)
	      ARRAY-TYPE-REF-DISPATCH ARRAY-TYPE-STORE-DISPATCH
	      GAHDRA GAHDR GAHD1 DSP-ARRAY-SETUP 
	      TRAP-UNLESS-FIXNUM D-NUMARG D-FIXNUM-NUMARG2 TRAP ILLOP
	      SCONS SCONS-D SCONS-T LCONS LCONS-D LIST-OF-NILS
	      FIXGET FIXGET-1 FXGTPP FNORM 
	      FIXPACK-T FIXPACK-P FXUNPK-P-1 FXUNPK-T-2 M-T-TO-CPDL
	      SFLPACK-T SFLPACK-P SFLUNPK-P-1 SFLUNPK-T-2 
	      FLOPACK-T FLOPACK-P FLOPACK GET-FLONUM
	      FADD FSUB FMPY FDIV FEQL FGRP FLSP FMIN FMAX FSUB-REVERSE FDIV-REVERSE 
	      BNCONS BIGNUM-DPB-CLEANUP FLONUM-FIX SWAP-FLONUMS FNEG1 FNEG2
	      MPY MPY12 DIV XFALSE XTRUE
	      PGF-R PGF-W PGF-R-I PGF-W-I PGF-W-FORCE PGF-R-SB PGF-W-SB
	      D-TRANSPORT D-ADVANCE-INSTRUCTION-STREAM D-GC-WRITE-TEST
	      D-QMRCL A-IPMARK P3ZERO QMEX1
	      QBND2 QBND4
	      CONVERT-PDL-BUFFER-ADDRESS GET-PDL-BUFFER-INDEX BITBLT-DECODE-ARRAY XAR2
))

(ASSIGN-EVAL NQZUSD (EVAL (- 32. (LENGTH Q-DATA-TYPES))))	;# UNUSED DATA-TYPES
(ASSIGN-EVAL NATUSD (EVAL (- 32. (LENGTH ARRAY-TYPES))))	;# UNUSED ARRAY-TYPES
(ASSIGN-EVAL NHDUSD (EVAL (- 32. (LENGTH Q-HEADER-TYPES))))	;# UNUSED HEADER-TYPES
(ASSIGN-EVAL VERSION-NUMBER (EVAL VERSION-NUMBER)) ;MAKE SOURCE VERSION A CONSLP SYMBOL

;THESE SYMBOLS GET DEFINED SUITABLY FOR USE IN BYTE INSTRUCTIONS
;DATA LOADED WITH THESE MUST COME FROM M BUS

(DEF-DATA-FIELD Q-CDR-CODE 2 36)
(DEF-DATA-FIELD Q-FLAG-BIT 1 35)
(DEF-DATA-FIELD Q-DATA-TYPE 5 30)
(DEF-DATA-FIELD Q-DATA-TYPE-PLUS-ONE-BIT 6 27)
(DEF-DATA-FIELD Q-POINTER 30 0)
(DEF-DATA-FIELD Q-POINTER-WITHIN-PAGE 8 0)

(DEF-DATA-FIELD Q-TYPED-POINTER 35 0)	;POINTER+DATA-TYPE
(DEF-DATA-FIELD Q-ALL-BUT-TYPED-POINTER 3 35)
(DEF-DATA-FIELD Q-ALL-BUT-POINTER 10 30)
(DEF-DATA-FIELD Q-ALL-BUT-CDR-CODE 36 0)
(DEF-DATA-FIELD Q-ALL-BUT-POINTER-WITHIN-PAGE 30 8)

;Stuff for address space quantization
(DEF-DATA-FIELD VMA-QUANTUM-BYTE
	(EVAL (- 24. (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))))
	(EVAL (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))))
(DEF-DATA-FIELD ADDRESS-SPACE-MAP-WORD-INDEX-BYTE
	(EVAL (- 24. (+ (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))
			(1- (HAULONG (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))))))
	(EVAL (+ (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))
		 (1- (HAULONG (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))))))
(DEF-DATA-FIELD ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE
	(EVAL (1- (HAULONG (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))))
	(EVAL (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))))
(DEF-DATA-FIELD ADDRESS-SPACE-MAP-BYTE-MROT
	(EVAL (- 5 (1- (HAULONG %ADDRESS-SPACE-MAP-BYTE-SIZE))))
	(EVAL (1- (HAULONG %ADDRESS-SPACE-MAP-BYTE-SIZE))))

(DEF-DATA-FIELD SIGN-BIT 1 31.)
(DEF-DATA-FIELD BOXED-SIGN-BIT 1 23.)  ;SIGN OF A BOXED FIXNUM
(DEF-DATA-FIELD BOXED-NUM-EXCEPT-SIGN-BIT 23. 0)
(ASSIGN POSITIVE-SETZ 1_23.)	;Largest value that fits in a fixnum, plus one
(ASSIGN NEGATIVE-SETZ -1_23.)	;Smallest value that fits in a fixnum
(DEF-DATA-FIELD BITS-ABOVE-FIXNUM 10 30)  ;BITS NOT USED IN REPRESENTING FIXNUM.

;"INVOKE" OPS	;GIVEN TO INVOKED ROUTINE TO TELL IT WHAT IS TRYING TO BE DONE TO IT
(ASSIGN CAR-INVOKE-OP 1)
(ASSIGN CDR-INVOKE-OP 2)
(ASSIGN RPLACA-INVOKE-OP 3)
(ASSIGN RPLACD-INVOKE-OP 4)
(ASSIGN ARRAY-HEAD-INVOKE-OP 5)
(ASSIGN DATA-TYPE-INVOKE-OP 6)
(ASSIGN NILP-INVOKE-OP 7)

;EXTRA BITS ON MICRO STACK
(DEF-DATA-FIELD %%-PPBMIR 1 14.)  ;FLAGS MACRO INSTRUCTION RETURN.  WHEN SEEN SET ON
				  ;MICRO-POPJ, CAUSES INSTRUCTION STREAM HARDWARE TO
				  ;FETCH NEXT MACROINSTRUCTION (IF NECESSARY).
(DEF-DATA-FIELD %%-PPBINF 2 15.)  ;IF THESE NON-ZERO, THEY SIGNAL PRESENCE OF ADDTL INFO
 (DEF-DATA-FIELD %%-PPBMIA 1 15.)	;MICRO-TO-MICRO CALL
 (DEF-DATA-FIELD %%-PPBMAA 1 16.)	;MICRO-TO-MACRO CALL
(DEF-DATA-FIELD %%-PPBSPC 1 17.)  ;DO BBLKP (POPPING A BLOCK OFF LINEAR BINDING PDL)
		; ON EXIT FROM THIS FCTN. FCTN MUST EXIT TO CBBLKP OR MRNMV TO CAUSE
		; THIS TO GET LOOKED AT.  ALSO, VARIOUS PDL GRUBLING ROUTINES 
		; LOOK AT THIS. 

(ASSIGN *CATCH-U-CODE-ENTRY-/# 0)	;MUST KNOW ABOUT THESE WHEN GRUBBLING STACK.. 
					; NOTE U-CODE ENTRY #'S ARE NORMALLY 
					; UNCONSTRAINED AND DETERMINE ONLY POSITION
					; IN MICRO-CODE-ENTRY-AREA, ETC. 

;DESTINATION CODES
(ASSIGN D-IGNORE 0)		;IGNORE EXCEPT PUT INTO INDICATORS
(ASSIGN D-PDL 1)		;PUSH ONTO STACK
(ASSIGN D-NEXT 2)		;PUSH ONTO STACK (AS ARGUMENT FOR PENDING CALL)
(ASSIGN D-LAST 3)		;PUSH ONTO STACK AS ARGUMENT, THEN ACTIVATE PENDING CALL
(ASSIGN D-RETURN 4)		;RETURN FROM FRAME AS VALUE OF FUNCTION
;(ASSIGN D-NEXT-QUOTED 5)	;OBSOLETE
;(ASSIGN D-LAST-QUOTED 6)	;OBSOLETE
(ASSIGN D-NEXT-LIST 7)		;CONS INTO PENDING LIST
(ASSIGN D-MICRO 10)		;APPEARS ONLY IN CALL-BLOCKS.  RETURN TO MICROCODE.

;INDICES IN THE SUPPORT VECTOR
(ASSIGN SVCAPL 3)		;APPLY-LAMBDA
(ASSIGN SVCEXPT 6)		;CALL OUT FOR EXPT
(ASSIGN SVCEQL 4)		;Call out for EQUAL
(ASSIGN SVCNUM1 7)		;Call out for numeric functions of one arg.
(ASSIGN SVCNUM2 10)		;Call out for numeric functions of two args.

;;; Meter information definition
(ASSIGN METER-OVERHEAD-LENGTH 7)	;Standard overhead for a meter
(DEF-DATA-FIELD METER-LENGTH 16. 16.)	;Event number in header
(DEF-DATA-FIELD METER-EVENT-NUM 16. 0)	;Length in header


;Instructions for checking for page faults, interrupts, sequence breaks.
;One of these must appear after every instruction that starts a memory cycle.

;This one is used when referencing fixed areas that should be always wired and mapped.
;E.G. inside the page fault routines where a recursive page fault could not be allowed
(ASSIGN ILLOP-IF-PAGE-FAULT (PLUS CALL-CONDITIONAL PG-FAULT ILLOP))

;These two are what are normally used.  They check for page faults and
;interrupts (handled entirely in microcode), but not sequence breaks.
(ASSIGN CHECK-PAGE-READ (PLUS CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-R-I))
(ASSIGN CHECK-PAGE-WRITE (PLUS CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-W-I))

;This one is used when you want to be able to write a nominally read-only area,
;for instance in the transporter when it is fixing a pointer to oldspace.
;Not checking for interrupts is just to save code.
(ASSIGN CHECK-PAGE-WRITE-FORCE (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-FORCE))

;This one is used for writing an old binding of a special variable
;back into the value cell, when a binding is being unbound.
;When writing into a location forwarded to A memory,
;it means that an old EVCP is no longer current even if
;the old binding being restored is not an EVCP itself.
(ASSIGN CHECK-PAGE-WRITE-BIND (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-BIND))

;These two are used when an interrupt is not allowed, either because we
;are inside the interrupt handler, because we are retrying a cycle in
;PGF-R/PGF-W, or because we don't want to let the interrupt handler change the map.
;Note well: these should be used only for references which may need to refill
; the map, but cannot take an actual disk page fault.  If a swap-in from disk
; happens, interrupts will be allowed while waiting for the page to come in;
; however, an interrupt cannot happen after the data has been copied from
; memory into the MD if this is used instead of CHECK-PAGE-READ.
(ASSIGN CHECK-PAGE-READ-NO-INTERRUPT (PLUS CALL-CONDITIONAL PG-FAULT PGF-R))
(ASSIGN CHECK-PAGE-WRITE-NO-INTERRUPT (PLUS CALL-CONDITIONAL PG-FAULT PGF-W))
;This one is used from inside the page-fault-handler to try again after some
;progress has been made.  Point is, it must not affect A-PGF-MODE.
(ASSIGN CHECK-PAGE-WRITE-RETRY (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-1))

;These two are used when we want to allow both interrupts and sequence breaks.
;Note that the VMA had better not point to unboxed storage when these are used.
(ASSIGN CHECK-PAGE-READ-SEQUENCE-BREAK
	(PLUS CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK PGF-R-SB))
(ASSIGN CHECK-PAGE-WRITE-SEQUENCE-BREAK
	(PLUS CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK PGF-W-SB))

;These names are for use with the CALL-CONDITIONAL and JUMP-CONDITIONAL
;instructions when special circumstances dictate special handling
(ASSIGN PG-FAULT JUMP-ON-PAGE-FAULT-CONDITION)
(ASSIGN NO-PG-FAULT (PLUS JUMP-ON-PAGE-FAULT-CONDITION INVERT-JUMP-SENSE))
(ASSIGN PG-FAULT-OR-INTERRUPT JUMP-ON-PAGE-FAULT-OR-INTERRUPT-PENDING-CONDITION)
(ASSIGN NO-PG-FAULT-OR-INTERRUPT
	(PLUS JUMP-ON-PAGE-FAULT-OR-INTERRUPT-PENDING-CONDITION INVERT-JUMP-SENSE))
(ASSIGN PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK
	JUMP-ON-PAGE-FAULT-OR-INTERRUPT-PENDING-OR-SEQUENCE-BREAK-CONDITION)


(ASSIGN LOWEST-A-MEM-VIRTUAL-ADDRESS 76776000)	;MUST BE 0 MODULO SIZE OF A-MEM
(ASSIGN LOWEST-IO-SPACE-VIRTUAL-ADDRESS 77000000)  ;BEGINING OF X-BUS IO SPACE
(ASSIGN LOWEST-UNIBUS-VIRTUAL-ADDRESS 77400000)    ;END OF X-BUS, BEGINNING OF UNIBUS

(DEF-DATA-FIELD OAL-BYTL-1 5 5)		;MICRO INSTRUCTION FIELDS
(DEF-DATA-FIELD OAL-MROT 5 0)
(DEF-DATA-FIELD OAH-A-SRC 10. 6)
(DEF-DATA-FIELD OAH-M-SRC 6 0)
(DEF-DATA-FIELD OAL-DEST 12. 14.)    ;THIS DEFINITION DOES NOT WIN FOR FUNCTIONAL DESTINATIONS
(DEF-DATA-FIELD OAL-A-DEST 10. 14.)  ;USE THIS WHEN SUPPLYING AN A-MEMORY DESTINATION
(DEF-DATA-FIELD OAL-M-DEST  5. 14.)  ;USE THIS WHEN SUPPLYING AN M-MEMORY DESTINATION
(DEF-DATA-FIELD OAL-JUMP 14. 12.)
(DEF-DATA-FIELD OAL-DISP 11. 12.)
(DEF-DATA-FIELD OAL-ALUF 4 3)

(ASSIGN PDL-BUFFER-LOW-WARNING 20.)  ;MAX LENGTH BASIC FRAME + ADI
(ASSIGN PDL-BUFFER-SLOP 40.)	;NUMBER OF EXTRA WORDS TO LEAVE "UNUSED" AT END OF PDL BUFFER
				;NOT TERRIBLY WELL ACCOUNTED, BUT 40 SHOULD BE MORE THAN ENOUGH
				;NOTE THAT CRUFT PUSHED BY SGLV SHOULD BE COUNTED IN THIS
(ASSIGN PDL-BUFFER-HIGH-LIMIT ;MAX VALUE FOR M-PDL-BUFFER-ACTIVE-QS.  THIS ALLOWS MAX SIZE 
	(DIFFERENCE 2000 (PLUS 400 PDL-BUFFER-SLOP))) ;ACTIVE FRAME. 

;MODIFIERS FOR THE DISPATCH INSTRUCTION, USED TO INVOKE THE TRANSPORTER
; ((VMA-START-READ) ---)
; (CHECK-PAGE-READ)
; ...
; (DISPATCH TRANSPORT-xxx) ;IF THIS DROPS THROUGH, OLD->NEW SPACE TRANSPORTATION
;			   ; HAS BEEN DONE AND INVISIBLE POINTERS HAVE BEEN FOLLOWED.
;			   ; VMA HAS THE ADDRESS, MD HAS THE CONTENTS.
; IT IS OK TO USE POPJ-AFTER-NEXT ON THE DISPATCH INSTRUCTION.
; DON'T USE POPJ-AFTER-NEXT OR JUMP-XCT-NEXT IN THE INSTRUCTION BEFORE
; A TRANSPORT.

;THE NAMES OF SOME OF THESE SHOULD BE CHANGED....
(ASSIGN TRANSPORT (PLUS (I-ARG 1) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
(ASSIGN TRANSPORT-NO-TRAP (PLUS (I-ARG 21) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
				DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
(ASSIGN TRANSPORT-CDR (PLUS (I-ARG 32) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			    DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
(ASSIGN TRANSPORT-WRITE (PLUS (I-ARG 23) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
(ASSIGN TRANSPORT-HEADER (PLUS (I-ARG 4) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
;Saved AC's of stack groups may have funny data types in them, minimize barfage.
(ASSIGN TRANSPORT-AC (PLUS (I-ARG 20) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
(ASSIGN TRANSPORT-SCAV (PLUS (I-ARG 30) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
;The NO-EVCP ones are used by binding.  They have a separate dispatch table to
;save taking frequent useless traps on EVCP's.  Also they have to not barf at
;trap data types, such as DTP-NULL.
;NO-EVCP also used by PDL buffer refill now that its legal to have EVCPs on PDL.

(ASSIGN TRANSPORT-NO-EVCP (PLUS (I-ARG 20) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT-NO-EVCP))
(ASSIGN TRANSPORT-NO-EVCP-WRITE (PLUS (I-ARG 22) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
			DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT-NO-EVCP))
	;I-ARG BIT 0 => MAKE DTP-EXTERNAL-VALUE-CELL-POINTER INVISIBLE
	;I-ARG BIT 1 => DON'T TRANSPORT (WRITING OVER THIS Q ANYWAY, OR ONLY CHECKING CDR CODE)
	;I-ARG BIT 2 => BARF ON DTP-ONE-Q-FORWARD, DTP-EXTERNAL-VALUE-CELL-POINTER
	;I-ARG BIT 3 => ONE-Q-FORWARD NOT INVISIBLE (JUST LOOKING FOR CDR CODE)
	;I-ARG BIT 4 => CAUSES IT NOT TO BARF IF TRAP DATATYPE IS SEEN

	;LATER THESE MAY USE MULTIPLE DISPATCH TABLES RATHER THAN I-ARG'S

;(DISPATCH ADVANCE-INSTRUCTION-STREAM) TO GET NEXT HALFWORD
(ASSIGN ADVANCE-INSTRUCTION-STREAM
	(PLUS (PLUS (PLUS DISPATCH-ADVANCE-INSTRUCTION-STREAM 
			  (BYTE-FIELD 1 31.)) ;NEEDFETCH BIT
		    LOCATION-COUNTER)
	      D-ADVANCE-INSTRUCTION-STREAM))

;(GC-WRITE-TEST)
;DO THIS AFTER STARTING A WRITE.  THIS CHECKS FOR WRITING A POINTER
;TO THE EXTRA-PDL REGION, AND IF SO TRAPS, COPIES THE THING OUT,
;DOES THE WRITE OVER AGAIN, AND COMES BACK AND DOES THE DISPATCH OVER AGAIN.
;OK TO COMBINE THIS WITH POPJ-AFTER-NEXT.
(ASSIGN GC-WRITE-TEST (PLUS DISPATCH Q-DATA-TYPE-PLUS-ONE-BIT
				   DISPATCH-ON-MAP-18 DISPATCH-PUSH-OWN-ADDRESS
				   WRITE-MEMORY-DATA D-GC-WRITE-TEST))

(LOCALITY M-MEM)	;ANYTHING WHICH IT IS DESIRED TO LDB OUT OF MUST BE IN M-MEM

M-GARBAGE	(0)	;THIS REG RANDOMLY STORED IN WHEN STORING IN FUNCTION 
			;DESTINATIONS AND NOT SIMULTANEOUSLY IN M-MEM

M-PGF-TEM (0)		;TEMPORARY LOCATION USED BY PAGE FAULT HANDLER

M-ZERO	(0)		;CONSTANT 0, USED FOR LDB OPERATIONS  (MUST BE IN LOCATION 2)
M-MINUS-ONE (-1)	;CONSTANT -1, USED FOR SIGN EXTENSION (MUST BE IN LOCATION 3)

;LETTERED REGISTERS, OR "PDP-10 ACS"
;THESE ARE PRESERVED BY SEQUENCE BREAKS, INTERRUPTS, AND PAGE FAULTS, AND MARKED-THROUGH
;BY THE GARBAGE COLLECTOR.  THEY MUST ALWAYS CONTAIN TYPED DATA.  SMALL
;NUMBERS (WITH TYPE-FIELD OF 0 OR 37) ARE ACCEPTABLE BY SPECIAL DISPENSATION.

M-ZR	(0)		;..
M-A	(0)		;.. 
M-B	(0)		;.. 
M-C	(0)		;.. 
M-D	(0)		;.. 
M-E	(0)		;.. 
M-T	(0)		;..	RESULT REGISTER, PSEUDO INDICATORS
M-R	(0)		;.. 
M-Q	(0)		;.. 
M-I	(0)		;.. 
M-J	(0)		;.. 
M-S	(0)		;.. 
M-K	(0)		;..
			;SEQUENCE BREAKS ALSO SAVE VMA, AND SAVE MD
			;BY RE-READING FROM VMA ON RESUME.  THE RE-READING OF
			;MEMORY DATA MEANS THE INTERRUPT IS EFFECTIVELY
			;INSERTED -BEFORE- THE READ CYCLE.  NOTE THAT THIS
			;ORDERING ALLOWS AN EFFECTIVE READ-PAUSE-WRITE CYCLE
			;TO BE DONE JUST BY DOING A READ THEN A WRITE, EVEN
			;THOUGH AFTER EACH CYCLE IS STARTED SEQ BRKS ARE CHECKED. 

M-AP	(0)		;POINTS AT EXECUTING FRAME
			;CAUTION: M-AP HOLDS A PDL BUFFER ADDRESS
			;TO GET CORRESPONDING MEMORY ADDRESS, 
			;USE CONVERT-PDL-BUFFER-ADDRESS
			;CAUTION: M-AP MUST NOT CONTAIN ANY GARBAGE IN THE HIGH BITS. 

;"NUMBERED REGISTERS".  THESE ARE TEMPORARIES WHICH ARE NOT MARKED THROUGH
;BY THE GARBAGE COLLECTOR.  THE FULL 32-BIT VALUES OF M-1 AND M-2 ARE SAVED
;IN STACK GROUPS, HENCE PRESERVED THROUGH SEQUENCE BREAKS, BUT M-3 AND M-4
;ARE NOT.
;M-1, M-2, M-3, AND M-4 ARE USED TO HOLD UNBOXED FIXNUMS OR FLONUM MANTISSAS;
;M-1, M-2 ARE THE FIRST AND SECOND ARGUMENTS RESPECTIVELY.
;M-1, M-2, M-3, AND M-4 ARE PRESERVED BY PAGE-FAULTS,
;BUT CAUTION SHOULD BE EXERCISED, GENERALLY THESE SHOULD ONLY BE VALID OVER
;A LOCALITY OF A FEW INSTRUCTIONS.
M-1	(0)
M-2	(0)
M-3	(0)
M-4	(0)

(LOC 26)  ;%MODE-FLAGS LISP VARIABLE IS MAPPED TO THIS LOCATION, SEE QCOM
M-FLAGS			;"MACHINE STATE FLAGS"
;FIRST COME "PROCESSOR FLAGS" IE THOSE SAVED AND RESTORED OVER MACRO CALL-RETURN
  (DEF-NEXT-BIT M-QBBFL M-FLAGS)	;BIND BLOCK PUT ON SPECIAL PDL (IN MACRO-CODE)
					;BIND BLOCK "OPEN" SIGNAL TO LOW LEVEL ROUTINES
					; IN MICRO-COMPILED FCTNS
					;ALSO SET IF FRAME HAS CLOSURE BINDING-BLOCK
 (DEF-DATA-FIELD M-FLAGS-PROCESSOR-FLAGS 1 0)	;BYTE POINTER TO PROCESSOR FLAGS
 (DEF-DATA-FIELD M-FLAGS-EXCEPT-PROCESSOR-FLAGS 37 1)
;END "PROCESSOR FLAGS", BEGIN PROCESSOR "MODES"
  (DEF-NEXT-FIELD M-CAR-SYM-MODE 2 M-FLAGS)	;CAR OF SYM GIVES: 
						;  ERROR
						;  ERROR EXCEPT (CAR NIL) = NIL
						;  NIL
						;  UNUSED, WAS ONCE <P-STRING ARRAY POINTER>
  (DEF-NEXT-FIELD M-CAR-NUM-MODE 2 M-FLAGS)	;CAR OF NUMBER GIVES: 
						;  ERROR
						;  NIL
						;  "WHATEVER IT IS"
  (DEF-NEXT-FIELD M-CDR-SYM-MODE 2 M-FLAGS)	;CDR OF SYM GIVES: 
						;  ERROR
						;  ERROR EXCEPT (CDR NIL) = NIL
						;  NIL
						;  PROPERTY LIST
  (DEF-NEXT-FIELD M-CDR-NUM-MODE 2 M-FLAGS)	;CDR OF NUM GIVES: 
						;  ERROR
						;  NIL
						;  "WHATEVER IT IS"

  (DEF-NEXT-BIT M-DONT-SWAP-IN M-FLAGS)		;MAGIC FLAG FOR CREATING FRESH PAGES

  (DEF-NEXT-BIT M-TRAP-ENABLE M-FLAGS)		;1 ENABLE ERROR TRAPPING

  (DEF-NEXT-FIELD M-MAR-MODE 2 M-FLAGS)		;1 IS READ-TRAP, 2 IS WRITE-TRAP

  (DEF-NEXT-BIT M-PGF-WRITE M-FLAGS)		;1 IF CURRENT PG FAULT IS WRITING

    (DEF-BIT-FIELD-IN-REG M-FLAGS-MAR-DISP 3 11. M-FLAGS)
		;INCLUDES M-MAR-MODE AND M-PGF-WRITE

  ;FLAGS FOR CURRENT MAJOR SECTION OF CODE EXECUTING, LOOKED AT
  ;BY PAGE-FAULT AND SEQUENCE-BREAK HANDLERS
  (DEF-NEXT-BIT M-INTERRUPT-FLAG M-FLAGS)	;1 IF IN INTERRUPT HANDLER, NO PAGING PLEASE
  (DEF-NEXT-BIT M-SCAVENGE-FLAG M-FLAGS)	;1 IF IN SCAVENGER, NO SEQUENCE BREAKS
  (DEF-NEXT-BIT M-TRANSPORT-FLAG M-FLAGS)	;1 IF IN TRANSPORTER, NO SEQUENCE BREAKS
  (DEF-NEXT-BIT M-STACK-GROUP-SWITCH-FLAG M-FLAGS) ;1 IF SWITCHING SGS, NO SEQUENCE BREAKS
    (DEF-BIT-FIELD-IN-REG M-FLAGS-NO-SEQUENCE-BREAK 4 14. M-FLAGS)
	;M-INTERRUPT-FLAG, M-SCAVENGE-FLAG, M-TRANSPORT-FLAG, M-STACK-GROUP-SWITCH-FLAG
    (DEF-BIT-FIELD-IN-REG M-FLAGS-FOR-PAGE-TRACE 3 15. M-FLAGS)
	;M-SCAVENGE-FLAG, M-TRANSPORT-FLAG, M-STACK-GROUP-SWITCH-FLAG
  (DEF-NEXT-BIT M-DEFERRED-SEQUENCE-BREAK-FLAG M-FLAGS) ;1 IF WANTING TO SEQUENCE-BREAK
	;Set if want to SB and A-INHIBIT-SCHEDULING-FLAG on.
	;Checked after popping bindings (and thus maybe affecting A-INHIBIT-SCHEDULING-FLAG).
	; If appropriate, the bit is stuffed back into the hardware (at SB-REINSTATE).
  (DEF-NEXT-BIT M-METER-STACK-GROUP-ENABLE M-FLAGS)	;1 IF METERING ON FOR THIS STACK GROUP
  (DEF-NEXT-BIT M-TRAP-ON-CALLS M-FLAGS)		;1 => TRAP ON ACTIVATING STACK FRAME.

  ( (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)	;SAME STUFF ALSO IN A-FLAGS
	  (BYTE-VALUE M-CAR-SYM-MODE 1)		;INITIAL MODE STATE
	  (BYTE-VALUE M-CAR-NUM-MODE 0)
	  (BYTE-VALUE M-CDR-SYM-MODE 1)
	  (BYTE-VALUE M-CDR-NUM-MODE 0)
	  (BYTE-VALUE M-DONT-SWAP-IN 0)
	  (BYTE-VALUE M-TRAP-ENABLE 0)
	  (BYTE-VALUE M-MAR-MODE 0)
	  (BYTE-VALUE M-PGF-WRITE 0)
	  (BYTE-VALUE M-INTERRUPT-FLAG 0)
	  (BYTE-VALUE M-SCAVENGE-FLAG 0)
	  (BYTE-VALUE M-TRANSPORT-FLAG 0)
	  (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0)
	  (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)
	  (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0)))

M-PDL-BUFFER-ACTIVE-QS (0)	;HOLDS QS BETWEEN A-PDL-BUFFER-HEAD AND M-AP INCLUSIVE
				; SEE DISCUSSION ON PDL-BUFFER DUMP/REFILL

M-ERROR-SUBSTATUS  (0)	;IDENTIFING INFO WHEN TAKING ERROR.  IF NON-ZERO, THERE IS AN
			;ERROR PENDING
			;FOR NOW, AT LEAST, THIS IS ONLY USED BY FUNCTION-ENTRY ERRORS.
			;SYMBOL ASSIGNMENTS ARE UNIQUE TO EACH ERROR
  (DEF-NEXT-BIT M-QBTFA M-ERROR-SUBSTATUS)	;TOO FEW ARGS
  (DEF-NEXT-BIT M-QBTMA M-ERROR-SUBSTATUS)	;TOO MANY ARGS
  (DEF-NEXT-BIT M-QBEQTA M-ERROR-SUBSTATUS)	;ERRONEOUS QUOTED ARG
  (DEF-NEXT-BIT M-QBEEVA M-ERROR-SUBSTATUS)	;ERRONEOUS EVALUATED ARG
  (DEF-NEXT-BIT M-QBBDT M-ERROR-SUBSTATUS)	;BAD DATA TYPE
  (DEF-NEXT-BIT M-QBBQTS M-ERROR-SUBSTATUS)	;BAD QUOTE STATUS
 (RESET-BIT-POINTER M-ERROR-SUBSTATUS)

M-INST-BUFFER  (0)	;LAST MACRO INSTRUCTION Q FETCHED (2 INSTRUCTIONS)
  (DEF-BIT-FIELD-IN-REG M-INST-DEST 3 15 (PLUS M-INST-BUFFER 
				      INSTRUCTION-STREAM))
  (DEF-BIT-FIELD-IN-REG M-INST-OP 4 11 (PLUS M-INST-BUFFER 
				      INSTRUCTION-STREAM))
  (DEF-BIT-FIELD-IN-REG M-INST-ADR 11 0 (PLUS M-INST-BUFFER 
				      INSTRUCTION-STREAM))
  (DEF-BIT-FIELD-IN-REG M-INST-ADR-*2+X 12 37 (PLUS M-INST-BUFFER 
				      INSTRUCTION-STREAM))
  (DEF-BIT-FIELD-IN-REG M-INST-REGISTER 3 6 (PLUS M-INST-BUFFER 
				      INSTRUCTION-STREAM))
  (DEF-BIT-FIELD-IN-REG M-INST-DELTA 6 0 (PLUS M-INST-BUFFER 
				      INSTRUCTION-STREAM))

M-LAST-MICRO-ENTRY	(0)	;HOLDS LAST MICRO ENTRY ADDRESS TRANSFERRED TO
				;IN THE JUMP FIELD.  SOMETIMES CLOBBERED W/O JUMP? 
M-TEM	(0)		;GENERAL-PURPOSE TEMPORARY, CLOBBERED BY PAGE FAULTS
			;THIS SHOULD ONLY BE USED OVER RANGES OF A FEW INSTRUCTIONS.
(LOC 34)  ;%SEQUENCE-BREAK-SOURCE-ENABLE LISP VARIABLE MAPPED HERE, SEE QCOM.
M-SB-SOURCE-ENABLE   ;each bit controls a potential source of sequence-breaks:
  ; Note: the numeric values of these bits are known by SI:SB-ON!
  (DEF-NEXT-BIT M-SBS-CALL M-SB-SOURCE-ENABLE)	;Just the CALL key (OBSOLETE).
  (DEF-NEXT-BIT M-SBS-UNIBUS M-SB-SOURCE-ENABLE)   ;Any Unibus channel.
  (DEF-NEXT-BIT M-SBS-CHAOS M-SB-SOURCE-ENABLE) ;Any CHAOS packet received.  Its
						; unclear if you really want to set this.
  (DEF-NEXT-BIT M-SBS-CLOCK M-SB-SOURCE-ENABLE) ;The clock, derived from TV
	
   ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))

(LOC 35)	;%METER-ENABLES lisp variable is mapped here, see qcom
M-METER-ENABLES	((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	; Enables for microcode metering

(LOCALITY A-MEM)

;;; THE FIRST 32. LOCATIONS SHADOW M-MEMORY. 
;;; THE M-LOCATIONS ARE CONSIDERED PRIMARY.  THE M-LOCATION SHOULD
;;; ALWAYS BE USED IN THE DESTINATION, SINCE WRITING IN M-MEMORY CLOBBERS
;;; A-MEMORY BUT WRITING IN A-MEMORY DOESN'T CLOBBER M-MEMORY.  THE A-LOCATION
;;; CAN BE USED AS A SOURCE WHEN NECESSARY TO GET IT INTO THE CORRECT
;;; SIDE OF THE ADDER OR TO OPERATE ON TWO M-LOCATIONS IN THE SAME INSTRUCTION. 

A-GARBAGE (0)
A-PGF-TEM (0)
A-ZERO	(0)		;CONSTANT 0 USED FOR LDB OPERATIONS-- MUST BE 2
A-MINUS-ONE (-1)	;CONSTANT -1 -- MUST BE 3
A-ZR	(0)		;SEE COMMENTS ON CORRESPONDING M-LOCATIONS
A-A	(0)
A-B	(0)
A-C	(0)
A-D	(0)
A-E	(0)
A-T	(0)
A-R	(0)
A-Q	(0)
A-I	(0)
A-J	(0)
A-S	(0)
A-K	(0)
A-AP	(0)
A-1	(0)
A-2	(0)
A-3	(0)
A-4	(0)
(LOC 26)  ;MUST, OF COURSE, BE AT SAME LOCATION AS M-FLAGS
A-FLAGS
  ( (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)	;SAME STUFF ALSO IN M-FLAGS
	  (BYTE-VALUE M-CAR-SYM-MODE 1)		;INITIAL MODE STATE
	  (BYTE-VALUE M-CAR-NUM-MODE 0)
	  (BYTE-VALUE M-CDR-SYM-MODE 1)
	  (BYTE-VALUE M-CDR-NUM-MODE 0)
	  (BYTE-VALUE M-DONT-SWAP-IN 0)
	  (BYTE-VALUE M-TRAP-ENABLE 0)
	  (BYTE-VALUE M-MAR-MODE 0)
	  (BYTE-VALUE M-PGF-WRITE 0)
	  (BYTE-VALUE M-INTERRUPT-FLAG 0)
	  (BYTE-VALUE M-SCAVENGE-FLAG 0)
	  (BYTE-VALUE M-TRANSPORT-FLAG 0)
	  (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0)
	  (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)
	  (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0)))

A-PDL-BUFFER-ACTIVE-QS (0)
A-ERROR-SUBSTATUS (0)
A-INST-BUFFER (0)
A-LAST-MICRO-ENTRY (0)
A-TEM (0)
A-SB-SOURCE-ENABLE ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
A-METER-ENABLES	((BYTE-VALUE Q-DATA-TYPE DTP-FIX))

(LOC 40);SKIP OVER M-CONSTANTS

;"Q" STORAGE STARTS HERE.. IE THIS CAN "POTENTIALLY" BE RELOCATED DURING A GC

;FOLLOWING VECTOR OF A-MEM LOCATIONS ARE REFERENCED EXTERNALLY.  ORDER HERE MUST
; AGREE WITH A-MEMORY-LOCATION-NAMES IN QCOM

;A-VERSION MUST BE FIRST
A-VERSION	((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
		       VERSION-NUMBER)) ;VERSION NUMBER FROM SECOND FILE NAME OF SOURCE
A-AMCENT	(0)	;NUMBER OF ACTIVE MICRO-CODE ENTRIES
A-CNSADF	(0)	;DEFAULT AREA TO DO CONSES IN, OK IF HAS TYPE
A-NUM-CNSADF	(0)	;AREA TO DO POTENTIAL "EXTRA-PDL" CONSES IN.  CAN EITHER BE
			; THE REAL EXTRA-PDL-AREA OR REGULAR-AREA.

;"SCRATCHPAD" CONSTANTS AND MODES
;INITIALIZED FROM SCRATCHPAD-INIT-AREA ON STARTUP.

A-SCRATCH-PAD-BEG  
A-INITIAL-FEF	(0)	;POINTER TO FEF OF FUNCTION TO START UP IN
A-QTRSTKG	(0)	;POINTER TO TRAP HANDLER STACK-GROUP
A-QCSTKG	(0)	;POINTER TO CURRENT STACK-GROUP
A-QISTKG	(0)	;POINTER TO INITIAL STACK-GROUP
;A-QSSTKG is below at end of vector section.  Move it here sometime when
; both UCODE and cold-load must be changed.
A-SCRATCH-PAD-END 

;STACK-GROUP RELATED
A-SG-STATE	(0)	;SG-STATE Q OF CURRENT STACK GROUP
A-SG-PREVIOUS-STACK-GROUP (0)
A-SG-CALLING-ARGS-POINTER (0)
A-SG-CALLING-ARGS-NUMBER (0)
;A-SG-FOLLOWING-STACK-GROUP (0)

A-TRAP-MICRO-PC ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) ;PC OF (CALL TRAP) MICROINSTRUCTION

A-COUNTER-BLOCK-POINTER
		 ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)
		  (A-MEM-LOC A-COUNTER-BLOCK-BASE))
;PAGING CONTROLS

A-CHAOS-CSR-ADDRESS ((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 77772060))  ;UNIBUS 764140
A-MAR-LOW ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)	;CDR CODE MUST BE ZERO!
	   77777777)		;LOWEST ADDRESS MAR IS SET ON, WITH FIXNUM TYPE
A-MAR-HIGH ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)
	    77777776)		;HIGHEST ADDRESS MAR IS SET ON, FIXNUM TYPE (NOT +1)
				;IT'S UNCLEAR HOW THESE GET RELOCATED BY GC,
				;WILL HAVE TO FIX UP LATER.
A-SELF	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) ;LAST DTP-INSTANCE, ETC INVOKED
A-METHOD-SEARCH-POINTER			      ;POSITION IN METHOD-LIST WHERE LAST
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) ; METHOD FOUND.
A-INHIBIT-SCHEDULING-FLAG 	;IF NON-NIL, NO SEQUENCE BREAKS
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 5)
A-INHIBIT-SCAVENGING-FLAG	;IF NON-NIL, SCAVENGER DOESN'T RUN
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 5)
A-DISK-RUN-LIGHT ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 77051763)
				;LOCATION IN TV BUFFER ILLUMINATED WHEN DISK TRANSFERRING
				;THAT + 2 IS THE COMPLEMENT (FOR EASY COMPARISON)
				;THAT - 2 IS THE SCAVENGER RUN-LIGHT
A-LOADED-BAND ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
				;HIGH 24 BITS OF NAME OF BAND LOADED (FOR GREETING MSG)
;THESE TWO GET SET FROM THE LABEL
A-DISK-BLOCKS-PER-TRACK ((PLUS 17. (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
A-DISK-BLOCKS-PER-CYLINDER ((PLUS 85. (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;GC FLIP CONTROL
A-REGION-CONS-ALARM			;Counts new regions made
	((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0))
A-PAGE-CONS-ALARM			;Counts pages allocated to new regions
	((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0))
A-GC-FLIP-READY				;If non-NIL, there are no pointers to oldspace
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;NIL
A-INHIBIT-READ-ONLY			;If non-NIL, you can write in read-only
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;NIL
A-SCAVENGER-WS-ENABLE			;Controls scavenger working set feature.
	((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)  ;New scheme: lowest physical address 
   ;NOT in scavenger working set.  Note this is semi-compatible with the old T or NIL
   ;scheme: both of these will turn off WS feature since only pointer is significant.
A-METHOD-SUBROUTINE-POINTER		;CONTINUATION POINT FOR SELECT METHOD SUBROUTINE
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;RETURN OR NIL
A-QLARYH ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;POINTER TO HEADER OF LAST ARRAY REFERENCED
A-QLARYL ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;ELEMENT # OF LAST ARRAY REFERENCED 
						 ; (W/ DTP-FIX DATA-TYPE)
A-QSSTKG ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;POINTER TO SCHEDULER STACK-GROUP
A-TV-CURRENT-SHEET (0)		;CURRENTLY-SELECTED SCREEN OR SHEET
				;THIS IS THE ONE WHOSE PARAMETERS HAVE BEEN COMPUTED
				;INTO A-TV-SCREEN-BUFFER-ADDRESS, ETC.
;was called A-DISK-READ-COMPARE-ENABLES.
A-DISK-SWITCHES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)
						;Bit 0 - read-compare after reads
						;Bit 1 - read-compare after writes
						;Bit 2 - enable multiple page swapouts
						;Bit 3 - enable multiple page swapins
				;This loads as zero so COLD-BOOT won't read-compare
A-MC-CODE-EXIT-VECTOR  ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)	;Exit vector used by
				; microcompiled code to ref Q quantities.
				; Replaces MICRO-CODE-EXIT-AREA. 
A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)
				;If NON-NIL, upper and lower case letters are different
A-ZUNDERFLOW ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)	;If non-NIL, floating underflow => 0
A-GC-GENERATION-NUMBER ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)
				;Increments whenever any new oldspace is created.
				; Thus if this has changed, objects may have moved.
A-METER-GLOBAL-ENABLE
	((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0))	;T if all stack groups metered
A-METER-BUFFER-POINTER
	((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;Pointer to disk buffer (must contain 1 block)
A-METER-DISK-ADDRESS
	((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;Next disk address to write buffer out to
A-METER-DISK-COUNT
	((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;Number of disk blocks left to write out
A-CURRENTLY-PREPARED-SHEET ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)
					;Error checking for the TV:PREPARE-SHEET macro
;Variables for mouse tracking
A-MOUSE-CURSOR-STATE ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
				;0 disabled, 1 open, 2 off, 3 on
A-MOUSE-X ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;Relative to MOUSE-SCREEN
A-MOUSE-Y ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;Relative to MOUSE-SCREEN
A-MOUSE-CURSOR-X-OFFSET ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;From top-left of pattern
A-MOUSE-CURSOR-Y-OFFSET ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;to the reference point
A-MOUSE-CURSOR-WIDTH ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
A-MOUSE-CURSOR-HEIGHT ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
A-MOUSE-X-SPEED ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;100ths per second, time averaged
A-MOUSE-Y-SPEED ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))	;with time constant of 1/6 second
A-MOUSE-BUTTONS-BUFFER-IN-INDEX ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
A-MOUSE-BUTTONS-BUFFER-OUT-INDEX ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
A-MOUSE-WAKEUP ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;Set to T when move or click

;Remember higher lexical contexts for nonlocal lexical variables.
;Value is a list of pointers to stack frames.
A-LEXICAL-ENVIRONMENT ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)

;Point to an array which holds slots for the EVCPs which
;were "stored" into a-memory locations, above,
;so that closures can bind such locations.
A-AMEM-EVCP-VECTOR ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)

;Area for consing things that are not explicitly requested
;and should not go in a temporary area.
;Initialized from A-CNSADF at startup time.
A-BACKGROUND-CONS-AREA (0)

;END OF VECTOR AREA

;FOLLOWING LOCATIONS ARE GC-ABLE BUT NOT USER-REFERENCEABLE

A-V-NIL		((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)	;POINTER TO NIL
A-V-TRUE	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 5)	;POINTER TO T

A-END-Q-POINTERS ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) ;WASTE A LOCATION TO FIX FENCEPOST ERROR

;END "Q" STORAGE

;FOLLOWING ARE 32 BIT UNTYPED COUNTERS AND METERS.  ORDER MUST AGREE WITH
; QCOM.  THIS BLOCK IS POINTED TO BY A-COUNTER-BLOCK-POINTER.
A-COUNTER-BLOCK-BASE 
A-FIRST-LEVEL-MAP-RELOADS  (0)	;# FIRST LEVEL MAP RELOADS
A-SECOND-LEVEL-MAP-RELOADS (0)	;# SECOND LEVEL MAP RELOADS
A-PDL-BUFFER-READ-FAULTS   (0)	;# TOOK PGF AND DID READ FROM PDL-BUFFER
A-PDL-BUFFER-WRITE-FAULTS  (0)	;# TOOK PGF AND DID WRITE TO PDL-BUFFER
A-PDL-BUFFER-MEMORY-FAULTS (0)	;# TOOK PGF FOR PDL-BUF, BUT DATA IN MAIN MEM.
A-DISK-PAGE-READ-COUNT     (0)	;COUNT OF PAGES READ FROM DISK
A-DISK-PAGE-WRITE-COUNT    (0)	;COUNT OF PAGES WRITTEN TO DISK
A-DISK-ERROR-COUNT         (0)	;COUNT OF RECOVERABLE ERRS
A-FRESH-PAGE-COUNT 	   (0)  ;COUNT OF FRESH PAGES 
				;  GENERATED IN CORE INSTEAD OF READ FROM DISK
A-PAGE-AGE-COUNT           (0)	;NUMBER OF TIMES AGER SET AGE TRAP
A-PAGE-FLUSH-COUNT         (0)	;NUMBER OF TIMES AGE TRAP -> FLUSHABLE
A-DISK-READ-COMPARE-REWRITES (0);NUMBER OF TIMES A WRITE WAS DONE OVER BECAUSE OF EITHER
				;DISK ERROR OR R/C DIFFERENCE DURING READ COMPARE
A-DISK-RECALIBRATE-COUNT   (0)  ;DUE TO SEEK ERRORS
A-META-BITS-MAP-RELOADS    (0)  ;RELOADS TO META-BITS-ONLY STATUS
A-COUNT-CHAOS-TRANSMIT-ABORTS (0)
A-DISK-READ-COMPARE-DIFFERENCES (0) ;NUMBER OF READ-COMPARE DIFFERENCES WITHOUT
				; ACCOMPANYING READ ERROR
A-CONS-WORK-DONE (0)	;K times number of Q's consed up (not a fixnum)
A-SCAV-WORK-DONE (0)	;number of Q's cleaned by scavenger (not a fixnum)
A-TV-CLOCK-RATE (67.)	;TV frame rate divided by this to get clock, default is 1/second
A-AGING-DEPTH (0)	;Number of laps before page aged.  Don't make bigger than 3!!
A-DISK-ECC-COUNT (0)		;Count of corrected soft ECC errors
A-COUNT-FINDCORE-STEPS (0)		;Number of iterations in FINDCORE
A-COUNT-FINDCORE-EMERGENCIES (0)	;Number of times FINDCORE had to age all pages
A-DISK-READ-COMPARE-REREADS (0)	;Number of times a read was done over because of either
				;disk error or R/C difference during read compare
A-DISK-PAGE-READ-OP-COUNT (0)	;Number of read operations (counts once even if multipage)
A-DISK-PAGE-WRITE-OP-COUNT (0)	;Number of write operations (counts once even if multipage)
A-DISK-PAGE-WRITE-WAIT-COUNT (0) ;Number of times actually had to wait while a page
				;was written out in order to reclaim the core
A-DISK-PAGE-WRITE-BUSY-COUNT (0) ;Number of times had to wait while a page was
				;written out because we wanted to use the disk
A-DISK-PREPAGE-USED-COUNT (0)	;Number of prepaged pages that turned out to be wanted
A-DISK-PREPAGE-NOT-USED-COUNT (0) ;Number of prepaged pages reclaimed before used
A-DISK-ERROR-LOG-POINTER (600)	;Points to next place in disk error log to store into
				;Entries lie in 600-637 range.  Each is 4 words:
				;	clp,,cmd		(guaranteed non-zero)
				;	disk-address read back
				;	status read back
				;	ma read back
A-DISK-WAIT-TIME	(0)	;Amount of time spent in page faults
A-DISK-PAGE-WRITE-APPENDS (0)	;Pages appended to swapout operations.
A-DISK-PAGE-READ-APPENDS  (0)   ;Pages appended to swapin operations.

;END OF COUNTER AREA.

;A-MEM EXTREMELY TEMPORARY WORKING REGISTERS. 
;CLOBBERED BY BOTH PAGE FAULTS AND INTERRUPTS.
;THESE SHOULD ONLY BE USED OVER RANGES OF A FEW INSTRUCTIONS.
A-TEM1	(0)	;VERY TEMPORARY
A-TEM2	(0)	;VERY TEMPORARY
A-TEM3	(0)	;VERY TEMPORARY

;A-MEM WORKING REGISTERS FOR VARIOUS SPECIFIC SECTIONS OF THE MICROCODE.
;THESE ARE NOT PRESERVED THROUGH SEQUENCE BREAKS.
A-TRANS-TEM	(0)	;TEMPORARY USED BY TRANSPORTER
A-TRANS-MD	(0)	;..
A-TRANS-VMA	(0)	;..
A-GC-TEM	(0)	;TEMPORARY FOR GC, E.G. FREE-REGION
A-INTR-TEM1	(0)	;TEMPORARY USED BY INTERRUPT HANDLERS
A-INTR-TEM2	(0)	;..
A-INTR-VMA	(0)	;VMA SAVED HERE THROUGH INTERRUPTS
A-INTR-MD	(0)	;MD SAVED HERE THROUGH INTERRUPTS
A-INTR-A	(0)	;SAVE M-A
A-INTR-B	(0)	;SAVE M-B
A-INTR-T	(0)	;SAVE M-T
A-INTR-LOCAL-UNIBUS-MODE  (0)	;1 normal, 0 PDP11 arbitrates unibus.
A-PGF-VMA (0)	;PAGE FAULT HANDLER SAVES VMA HERE
A-PGF-WMD (0)	;PAGE FAULT HANDLER SAVES WRITE-MEMORY-DATA HERE
A-PGF-T   (0)	;PAGE FAULT HANDLER SAVES M-T HERE
A-PGF-A   (0)	;PAGE FAULT HANDLER SAVES M-A HERE
A-PGF-B   (0)	;PAGE FAULT HANDLER SAVES M-B HERE
A-PGF-MODE (0)	;PAGE FAULT HANDLER KEEPS A FLAG HERE.
A-PDLB-TEM	(0)	;TEMPORARY USED BY PDL-BUFFER LOADING/DUMPING ROUTINES
A-FARY-TEM	(0)	;TEMPORARY USED BY XFARY
A-CONS-TEM	(0)	;TEMPORARY FOR THE USE OF CONS
A-CONS-NEW-FREE-POINTER (0) ;USED BY SCAV0
A-CONS-NEW-FP-REGION (0) ;..
A-TRANS-SAVE-A (0)	;REGISTER SAVING AT TRANS-COPY
A-TRANS-SAVE-B (0)
A-TRANS-SAVE-E (0)
A-TRANS-SAVE-K (0)
A-TRANS-SAVE-S (0)
A-TRANS-SAVE-T (0)
A-TRANS-SAVE-3 (0)
A-TRANS-SAVE-4 (0)

;Chaos net
;A-CHAOS-CSR-ADDRESS moved to vector section
A-CHAOS-TRANSMIT-RETRY-COUNT (0)	;0 TRANSMIT NOT ACTIVE, ELSE NUMBER RETRIES TO GO
A-CHAOS-TRANSMIT-ABORTED (0)		;0 NORMAL, -1 DELAYING FOR A WHILE, +1 RETRYING

A-LCTYP	(0)	;LINEAR-CALL-TYPE DURING QLENTR (NORMAL, LEXPR, FEXPR, ETC)

;Scavenger

A-SCAV-PTR (0)		;Address of next Q to scavenge (with type bits from gc-pointer)
A-SCAV-COUNT (0)	;Number of Q's remaining to be scavenged in that block
A-SCAV-SKIP (0)		;Number of Q's then to be skipped to get to next object.
A-SCAV-REGION (0)	;Region number of region containing above Q's
A-SCAV-REGION-ORIGIN (0);As pure number, for updating gc-pointer
A-SCAV-PDL-BASE (0)	;0 or base address of pdl currently being scavenged
A-SCAV-SAVE-A (0)
A-SCAV-SAVE-B (0)
A-SCAV-SAVE-T (0)

;Cons cache
;This is intended to reduce overhead for heavy-consing applications,
;especially for bignum and flonum computation.
;For each representation type we remember the current region
;and the absolute free-pointer for the area most recently consed-in.
;We have a limit to which the free-pointer may advance before we must
;bypass the cache in order to do next-page and next-region processing.
;The limit is the first location of the following page, unless the free
;pointer is at a page boundary in which case the limit is the same as
;the free pointer so that we will check for running off the end of the
;region before advancing into the next page.
;Thus in normal operation we bypass the cache and do the full checking
;each time we allocate an object that crosses a page boundary or
;starts on a new page.
;The free-pointer is written back to memory each time, to avoid problems
;with warm-booting and with the scavenger.
;We still scavenge even though we are consing out of the cache, which may or 
;may not be a win (it adds to overhead but makes scav more incremental).

A-SCONS-CACHE-AREA (0)
A-SCONS-CACHE-REGION (0)
A-SCONS-CACHE-FREE-POINTER (0)
A-SCONS-CACHE-FREE-LIMIT (0)
A-SCONS-CACHE-REGION-ORIGIN (0)

A-LCONS-CACHE-AREA (0)
A-LCONS-CACHE-REGION (0)
A-LCONS-CACHE-FREE-POINTER (0)
A-LCONS-CACHE-FREE-LIMIT (0)
A-LCONS-CACHE-REGION-ORIGIN (0)

;PAGING VARIABLES AND CONSTANTS
A-PHT-INDEX-MASK (0)		;Mask for page hash table indices
A-PHT-INDEX-LIMIT (0)		;All valid PHT indices are less than this
A-FINDCORE-SCAN-POINTER (0)	;Page frame number of next page to be looked at by FINDCORE
A-AGING-SCAN-POINTER (0)	;Page frame number of next page to be looked at by AGER
A-V-PHYSICAL-PAGE-DATA-END 	;First location after last valid physical-page-data entry
			(1_31.)	;This has to be initialized to the most negative number!
A-PAGE-IN-PHT1 (0)		;Argument to PAGE-IN-MAKE-KNOWN

A-DISK-REGS-BASE (77377774)	;XBUS ADDRESS 17377774
;These two get set from the PAGE partition's descriptor in the label.
;They define the starting disk address and number of disk blocks in the PAGE partition.
;These used to be in words, but no longer.
A-DISK-OFFSET (0)
A-DISK-MAXIMUM (0)
(ASSIGN DISK-READ-COMMAND 0)
(ASSIGN DISK-WRITE-COMMAND 11)
(ASSIGN DISK-READ-COMPARE-COMMAND 10)
(ASSIGN DISK-RECALIBRATE-COMMAND 10001005)

;Status of the current disk operation in progress
A-DISK-BUSY	(0)		;Non-zero if an operation is in progress
A-DISK-READ-WRITE (0)		;Zero if Read, DISK-WRITE-COMMAND if Write
A-DISK-COMMAND	(0)		;Command register (including recovery bits)
A-DISK-CLP	(0)		;Address of command list
A-DISK-ADDRESS	(0)		;Disk address (encoded into unit/cyl/surf/sec)
A-DISK-STATUS	(0)		;Status read back
A-DISK-MA	(0)		;MA read back (last memory location referenced)
A-DISK-FINAL-ADDRESS (0)	;Disk address read back
A-DISK-ECC	(0)		;Error correction data read back
A-DISK-RETRY-STATE (0)		;Count of retries
A-DISK-DOING-READ-COMPARE (0)
A-DISK-IDLE-TIME (0)		;Time since last disk op (other than background)
A-DISK-RESERVED-FOR-USER (0)	;%DISK-OP in progress (inhibits background disk ops)

(ASSIGN DISK-SWAP-OUT-CCW-BASE 700) ;build CCW lists for swap out starting here
(ASSIGN DISK-SWAP-OUT-CCW-MAX  720) ; and not above here.
(ASSIGN DISK-SWAP-IN-CCW-BASE 740)  ;build CCW lists for swap in starting here
(ASSIGN DISK-SWAP-IN-CCW-MAX  760)  ; and not above here.

;Locations for DISK-SWAP-HANDLER
A-DISK-SWAPIN-SIZE (0)

A-DISK-SWAPIN-VIRTUAL-ADDRESS (0)
A-DISK-SWAPIN-PAGE-FRAME (0)		;physical page frame
A-DISK-SWAPIN-PHT2-BITS (0)

A-DISK-SWAP-OUT-CCW-POINTER (0)
A-DISK-SWAP-IN-CCW-POINTER (0)

A-DISK-SAVE-PGF-VMA (0)		;some of these are also used when building CCWs just
A-DISK-SAVE-PGF-WMD (0)		; before calling DISK-SWAP-HANDLER
A-DISK-SAVE-PGF-T (0)		; also near SWAPIN.
A-DISK-SAVE-PGF-A (0)
A-DISK-SAVE-PGF-B (0)
A-DISK-SAVE-1 (0)
A-DISK-SAVE-2 (0)
A-DISK-SAVE-MODE (0)		;save A-PGF-MODE

A-DISK-CYL-BEG (0)	;Typeless virtual address that lies at start of a cylinder
A-DISK-CYL-END (0)	;Typeless virtual address that lies at start of next cylinder

;PARAMETERS OF THE CURRENTLY SELECTED SCREEN (SEE TV-SELECT-SCREEN)
;NOT PRESERVED THROUGH SEQUENCE BREAKS
;A-TV-CURRENT-SHEET (0)		;CURRENTLY-SELECTED SCREEN, JUST FOR AN EFFICIENCY HACK
;ABOVE IS IN THE A-MEMORY-VARIABLES VECTOR
A-TV-SCREEN-BUFFER-ADDRESS (0)	;START ADDRESS OF BUFFER (IN VIRTUAL ADDRESS SPACE)
A-TV-SCREEN-BUFFER-END-ADDRESS (0)	;LAST BUFFER VIRTUAL ADDRESS +1
A-TV-SCREEN-LOCATIONS-PER-LINE (0)	;AMOUNT TO ADD TO ADDRESS TO GET TO NEXT RASTER LINE
A-TV-SCREEN-BUFFER-BIT-OFFSET (0)	;OFFSET IN BITS FROM A-TV-SCREEN-BUFFER-ADDRESS OF
					;REAL START OF THE TV BUFFER
A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT (0)	; (LOG2(N)) OF PIXEL SIZE,
					;IN PLACE FOR OA-REG-LOW OF MROT.
A-TV-SCREEN-WIDTH (0)		;WIDTH OF SHEET

;CLOCK BASED ON TV FRAME RATE
A-TV-CLOCK-COUNTER (0)
A-TV-REGS-BASE (77377760)	;XBUS ADDRESS 17377760
 ;IN REGISTER 0, BIT 3 IS INTERRUPT ENABLE, BIT 4 IS INTERRUPT FLAG

;AREA ORIGIN POINTERS  (THESE ARE VIRTUAL ADDRESSES)
; THESE EXIST IN A-MEMORY ONLY TO SAVE TO ENABLE THEM TO BE REFERENCED
; WITHOUT A MEMORY CYCLE.  THEY ARE IN ORDER OF AREA NUMBER, AND ARE INITIALIZED
; AT UCADR STARTUP (BEG) AND NEVER CHANGED. 
;NOTE THAT THESE POINT TO FIXED AREAS, WHICH HAVE ONE REGION, SO THAT
;CONFUSION BETWEEN AREAS AND REGIONS AT THIS LEVEL IS ALLOWED AND ENCOURAGED
A-V-RESIDENT-SYMBOL-AREA	(0)	;RESIDENT SYM AREA
A-V-SYSTEM-COMMUNICATION-AREA	(400)	;MUST BE AT LOC 400
A-V-SCRATCH-PAD-INIT-AREA	(0)	;MUST BE AT LOC 1000
A-V-MICRO-CODE-SYMBOL-AREA	(0)	;FIRST 600 LOCS ARE UCODE STARTING ADRS
					; FOR (MACRO-CODE) MISC-INST S 200-777
					;FOLLOWING ARE OTHER RANDOM UCODE ENTRIES. 
A-V-PAGE-TABLE-AREA	(0)
A-V-PHYSICAL-PAGE-DATA	(0)		;FOR EACH PAGE FRAME, -1 IF IT IS OUT OF SERVICE, OR
					; GC DATA,,PHT INDEX FOR PAGE IN IT
					; -1 IN PHT INDEX IF WIRED PAGE WITH NO PHT ENTRY
					; GC DATA=0 IF NOT IN USE
A-V-REGION-ORIGIN	(0)		;VIRTUAL ADDRESS START OF REGION
A-V-REGION-LENGTH	(0)		;NUMBER OF QS IN REGION
A-V-REGION-BITS		(0)		;VARIOUS FIELDS, SEE QCOM
A-V-ADDRESS-SPACE-MAP	(0)		;A BYTE FOR EACH ADDRESS SPACE QUANTUM, GIVING REGION#
					; OR 0 IF FREE OR FIXED-AREA.  BYTE SIZE IS
					; %ADDRESS-SPACE-MAP-BYTE-SIZE
A-V-REGION-FREE-POINTER	(0)		;RELATIVE ALLOCATION POINT.  ALLOCATION IS UPWARDS
A-V-REGION-GC-POINTER	(0)		;VARIOUS USES, MAINLY RELATIVE DIRTY/CLEAN BOUNDARY
A-V-REGION-LIST-THREAD	(0)		;NEXT REGION# IN AREA, OR 1_23. + AREA# AT END OF LIST
					; THREADS FREE REGION TABLE SLOTS
A-V-AREA-NAME		(0)		;SYMBOL WHICH NAMES AREA (NIL FOR FREE AREA#S)
A-V-AREA-REGION-LIST	(0)		;FIRST REGION# IN AREA (FREE LIST FOR FREE AREA#S)
A-V-AREA-REGION-SIZE	(0)		;RECOMMENDED SIZE FOR NEW REGIONS
A-V-AREA-MAXIMUM-SIZE	(0)		;APPROXIMATE MAXIMUM #WDS IN THIS AREA
A-V-AREA-SWAP-RECOMMENDATIONS (0)	;FIXNUM. SEE %%AREA-SWAP- SYMS.
A-V-GC-TABLE-AREA	(0)		;GARBAGE COLLECTOR TABLES
A-V-SUPPORT-ENTRY-VECTOR	(0)
A-V-CONSTANTS-AREA	(0)		;CONSTANTS PAGE (REF'ED IN ADR OF MACRO-CODE)
A-V-EXTRA-PDL-AREA (0)			;TEMPORARY NUMERIC RESULTS, SEPARATELY GC'ED
					; MUST BE RIGHT BEFORE MICRO-CODE-ENTRY-AREA
A-V-MICRO-CODE-ENTRY-AREA	(0)	;MICRO-CODE-ENTRY-AREA
A-V-MICRO-CODE-ENTRY-NAME-AREA	(0)	;PARALLEL TO PRECEDING, HAS SYMBOL WHICH IS NAME
A-V-MICRO-CODE-ENTRY-ARGS-INFO-AREA (0)	;MICRO-CODE-ENTRY-ARGS-INFO-AREA
A-V-MICRO-CODE-ENTRY-MAX-PDL-USAGE (0)	;MAXIMUM DEPTH ON PDL BEFORE MICRO TO MACRO CALL
;Following areas are not used by microcode except for XRGN
;since they are not aligned on quantum boundaries
A-V-MICRO-CODE-ENTRY-ARGLIST-AREA (0)	;VALUE FOR ARGLIST FUNCTION TO RETURN
A-V-MICRO-CODE-SYMBOL-NAME-AREA (0)	;NAMES OF MICRO-CODE-SYMBOL-AREA ENTRIES
A-V-LINEAR-PDL-AREA (0)			;MAIN PDL
A-V-LINEAR-BIND-PDL-AREA (0)		;CORRESPONDING BIND PDL
A-V-INIT-LIST-AREA (0)			;LIST CONSTANTS CREATED BY COLD LOAD
;Microcode -knows- that INIT-LIST-AREA is the last fixed area

;This location -must- immediately follow the above table of fixed areas
A-V-FIRST-UNFIXED-AREA (0)		;First address above fixed areas

A-V-MISC-BASE	(0)	;BASE OF DISPATCH TABLE FOR MISC-INST . 
			; = A-V-MICRO-CODE-SYMBOL-AREA - 200

A-IPMARK	(0)	;POINTER TO LAST OPEN CALL BLOCK ON IP STACK, (= AP IF NONE)
			; CAUTION! THIS IS A PDL-BUFFER ADDRESS NOT A VIRTUAL ONE. 
A-PDL-BUFFER-VIRTUAL-ADDRESS	(0)	;VIRTUAL ADDRESS OF "HEAD" OF PDL BUFFER
		;IE THAT LOCATION OF PDL BUFFER THAT CORRESPONDS TO LOWEST VIRTUAL MEMORY
		;LOCATION AT THE CURRENT TIME. PURE NUMBER WITH NO GARBAGE IN HIGH BITS
A-PDL-BUFFER-HEAD	(0)	;PDL BUFFER INDEX CONSIDERED TO BE THE "HEAD"
		;IE THAT LOCATION OF PDL BUFFER THAT CORRESPONDS TO LOWEST VIRTUAL 
		;MEMORY LOCATION AT THE CURRENT TIME.  PURE NUMBER, WITH NO GARBAGE IN
		;HIGH BITS. 

;UNTYPED LOCATIONS

A-LOCALP (0)		;PDL-BUFFER-INDEX OF LOCALS FOR CURRENT FRAME
			; (NOT TRUNCATED TO 10 BITS!)
A-SINF-PAD (0)		;RETURN VALUE FROM STRUCTURE-INFO
A-SINF-PDL-BASE (0)	;..

;TEMPORARIES IN FUNCTION ENTRY CODE
 ;TO SAVE SPACE, SHARED WITH *THROW TEMPORARIES

;TEMPORARIES IN *CATCH, *THROW, ETC
A-LAST-STACK-GROUP		;LAST STACK GROUP LEFT
A-CATCH-MARK	(0)	;MARK, IE, WHAT MUST BE IN FEF POINTER OF DESIRED FRAME

A-SG-TEM2            ;ANOTHER SG TEMP.
A-ARGS-LEFT		;NUMBER OF ARGS LEFT TO DO
A-CATCH-TAG	(0)	;WHAT MUST BE IN FIRST ARG POSITION OF THAT FRAME

A-SG-TEM 		;TEMPS USED BY SG-CODE.  HOLD INFO OVER SGENT MOSTLY
A-CATCH-COUNT	(0)  ;CAUSES THROWAGE TO STOP, WITH THE CURRENT ACTIVE FRAME
		     ; RETURNING TO THE PREVIOUS FRAME, IF ZERO.  IF NIL, DOESN'T APPLY.
A-SG-TEM1		; CAN'T USE PDL BUFFER FOR THESE SINCE BEING SWAPPED.
A-CATCH-ACTION  (0)  ;IF NON-NIL, CAUSES RETURN TO ERROR SG INSTEAD OF RESUMING
		     ; CURRENT SG AT CONCLUSION OF THROW.

;PAGE TRACE
A-PAGE-TRACE-PTR (0)	;0 DISABLED, ELSE ADDRESS OF NEXT 4-WORD ENTRY
A-PAGE-TRACE-START (0)	;FIRST ENTRY
A-PAGE-TRACE-END (0)	;LAST ENTRY+1 (WRAP-AROUND POINT)
A-PAGE-TRACE-VMA (0)	;TEMP: ADDRESS REFERENCED
A-PAGE-TRACE-UPC (0)	;TEMP: MICRO-PC AND SWAP-OUT FLAG

;;; Metering variables
A-METER-LENGTH	(0)			;Length of additional meter info
A-METER-EVENT	(0)			;Number of the metered even
A-METER-LOCK	(0)			;Lock during swap out of meter buffer
A-METER-START-TIME (0)			;Microsecond clock reading saved here

;CONNECTED WITH PDL-BUFFER MANAGEMENT
A-PDL-BUFFER-HIGH-WARNING  (PDL-BUFFER-HIGH-LIMIT)	;GO TO PDL-BUFFER-DUMP IF PUSH
			;FRAME AND M-PDL-BUFFER-ACTIVE-QS GREATER OR EQUAL TO THIS. 
			;NORMALLY STAYS AT PDL-BUFFER-HIGH-LIMIT, BUT WILL BE LESS
			;IF A-PDL-BUFFER-VIRTUAL-ADDRESS WITHIN 2000 OF A-QLPDLH. 
			;(THUS CAUSING XFER TO PDL-BUFFER-DUMP ON PUSH-DOWN-LIST 
			;OVERFLOW). 

A-PDL-FINAL-VMA (0)	;IN PDL DUMP, FINAL VMA TO DO, PLUS ONE
A-PDL-LOOP-COUNT (0)	;IN PDL LOAD, LOOP COUNTER FOR INNER LOOP

;PDL POINTERS AND LIMITS.  INITIALIZED BY STACK-GROUP STUFF.
;THESE ARE PURE NUMBERS WITH NO DATA TYPE.
A-QLBNDP	(0)	;BIND STACK (SPECIAL PDL) POINTER; ADDRESS OF HIGHEST VALID WORD
A-QLBNDO	(0)	;LOW LIMIT OF BINDING STACK
A-QLBNDH	(0)	;HIGH LIMIT OF BINDING STACK
A-QLBNDRH	(0)	;MAXIMUM POSSIBLE HIGH LIMIT OF BINDING STACK
			;REGULAR PDL POINTER IS IN HARDWARE PDL-BUFFER-POINTER REGISTER
A-QLPDLO	(0)	;LOW LIMIT OF REGULAR PDL
A-QLPDLH	(0)	;HIGH LIMIT OF REGULAR PDL

;;; A-memory variables for BITBLT
A-ALUF	(0)			;OA-REG-LOW for ALU function
A-BITBLT-HOR-COUNT	(0)	;Counter for horizontal loop
A-BITBLT-COUNT		(0)	;Counter for vertical loop
A-BITBLT-TEM		(0)	;Temporary in inner loop
A-BITBLT-DST-WIDTH	(0)	;Width of destination region in bits
A-BITBLT-SRC-WIDTH	(0)	;Width of source array in bits
A-BITBLT-SRC-WIDTH-WORDS (0)	;Width of source array in words
A-BITBLT-SRC-Y		(0)	;Number of rows down to start at in source
A-BITBLT-SRC-Y-OFFSET	(0)	;Same translated to word offset

;;; A-memory variables for TV-DRAW-TRIANGLE
A-TRI-X1 (0)			;X1
A-TRI-Y1 (0)			;Y1 (greatest)
A-TRI-X2 (0)			;X2
A-TRI-Y2 (0)			;Y2
A-TRI-X3 (0)			;X3
A-TRI-Y3 (0)			;Y3 (smallest)
A-TRI-Y1-ADDR (0)		;Y1 as array offset
A-TRI-Y2-ADDR (0)		;Y2
A-TRI-Y3-ADDR (0)		;Y3
A-TRI-Y-LIM (0)			;Current goal
A-TRI-DET (0)			;Determinant giving handedness of triangle
A-TRI-XLI (0)			;Increment for left hand end of line
A-TRI-XLIR (0)			;Increment for remainder
A-TRI-LY (0)			;DY for left hand point
A-TRI-XRI (0)			;Increment for right hand end of line
A-TRI-XRIR (0)			;Increment for remainder
A-TRI-RY (0)			;DY

;;; A-memory locations for TV-DRAW-LINE
A-DRAW-LINE-DRAW-FIRST-POINT (0)	;Fill in first point on line
A-DRAW-LINE-DRAW-LAST-POINT (0)		;... last point ...

;;; A-memory locations for BBOOLE
A-BOOLE-CARRY-1 (0)
A-BOOLE-CARRY-2 (0)

;;; A-memory locations used by bignum-bignum division. 31. bit numbers both.
A-BDIV-V1	(0)
A-BDIV-V2	(0)

;;; Argument to TRANS-COPY
A-TRANS-COPY-FWD-DTP (0)

;;; LOCATIONS OF THE MAIN LOOP INDEXED BY %%SG-ST-INST-DISP OF SG-CURRENT-STATE
A-MAIN-DISPATCH		((PLUS (BYTE-MASK %%-PPBMIR) (I-MEM-LOC QMLP)))
A-DEBUG-DISPATCH	((PLUS (BYTE-MASK %%-PPBMIR) (I-MEM-LOC DMLP)))
A-SINGLE-STEP-DISPATCH	((PLUS (BYTE-MASK %%-PPBMIR) (I-MEM-LOC SINGLE-STEP)))
A-SINGLE-STEP-TRAP	((PLUS (BYTE-MASK %%-PPBMIR) (I-MEM-LOC STEP-BREAK)))

A-TRAP-AP-LEVEL		((BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))

;FIRST LEVEL MAP STUFF

A-SECOND-LEVEL-MAP-REUSE-POINTER	
	(35)		;-> BLOCK OF SECOND LEVEL MAP NEXT TO BE REUSED
A-SECOND-LEVEL-MAP-REUSE-POINTER-INIT
	(0)		;-> LOWEST NUMBERED BLOCK SAFE TO REUSE
;(MODULO 40)
;A-REVERSE-FIRST-LEVEL-MAP	
;	(0)		;FOR EACH BLOCK OF SECOND LEVEL MAP, SAYS WHICH FIRST
;(REPEAT 36 (-1))	;LEVEL MAP WORD POINTS TO THIS BLOCK CURRENTLY. 
;			;IS IN FORM OF A VMA TO ADDRESS THAT 1ST LVL MAP ENTRY. 
;A-REVERSE-FIRST-LEVEL-MAP-INIT-VALUE
;	(-1)	;THIS ONE IS NEVER CHANGED (ENTRY #37)

;Variables for mouse tracking
A-MOUSE-X-FRACTION (0)	;10 bits of fractional position
A-MOUSE-Y-FRACTION (0)
A-MOUSE-CURSOR-X (0)	;Current location of cursor
A-MOUSE-CURSOR-Y (0)	; (only valid if state=3)
A-MOUSE-LAST-H1 (0)	;Last value input from hardware
A-MOUSE-LAST-H2 (0)
A-MOUSE-HARDWARE-ADDRESS (77772042)	;764104 is Y, 764106 is X
A-MOUSE-SCREEN-BUFFER-ADDRESS (0)	;Data for screen (or sheet) mouse is on
A-MOUSE-SCREEN-BUFFER-END-ADDRESS (0)
A-MOUSE-SCREEN-LOCATIONS-PER-LINE (0)
A-MOUSE-SCREEN-BUFFER-BIT-OFFSET (0)
A-MOUSE-SCREEN-WIDTH (0)
A-MOUSE-SCREEN-BUFFER-PIXEL-SIZE-MROT (0)
A-MOUSE-SCREEN (0)
A-MOUSE-SAVE-1 (0)
A-MOUSE-SAVE-2 (0)
A-MOUSE-SAVE-E (0)

;Arrays at fixed locations in A memory, used for the mouse
(ASSIGN MOUSE-CURSOR-PATTERN-AMEM-LOC 1600)	;32x32 BIT ARRAY
(ASSIGN MOUSE-BUTTONS-BUFFER-AMEM-LOC 1640)	;8 4-WORD ART-Q ENTRIES
(ASSIGN MOUSE-X-SCALE-ARRAY-AMEM-LOC 1700)	;8 2-WORD ART-Q ENTRIES
(ASSIGN MOUSE-Y-SCALE-ARRAY-AMEM-LOC 1720)	;8 2-WORD ART-Q ENTRIES

;;; DISPATCH TABLES

(LOCALITY D-MEM)

(LOC 3777) ;LAST LOCATION IN D-MEMORY MUST BE DROP THROUGH FOR TRANSPORTER TO WORK RIGHT.
	(P-BIT R-BIT)
(END-DISPATCH)

(START-DISPATCH 1 0)
;USE THIS DISPATCH WITH MULTI-UNIT INSTRUCTIONS.  FETCHES FROM MAIN MEM IF NECESSARY.
D-ADVANCE-INSTRUCTION-STREAM 
	(P-BIT R-BIT)	;DROP THRU
	(P-BIT INHIBIT-XCT-NEXT-BIT INSTRUCTION-STREAM-FETCHER)
(END-DISPATCH)

;DISPATCH ON MACRO OP CODE
;INSTRUCTION IN M-INST-BUFFER, LOCATION-COUNTER HAS ADDRESS OF NEXT INSTRUCTION.
;EFFECTIVE ADDRESS NOT PROCESSED YET, DISPATCH ON QADCM1-QADCM5 TO GET IT.
(START-DISPATCH 4 0)	;DO JUMP XCT NEXT, PUSH RETURN MANUALLY
OPDTB	(QICALL)	;0 CALL
	(QICAL0)	;1 CALL0
	(QIMOVE)	;2 MOVE
	(QICAR)		;3 CAR
	(QICDR)		;4 CDR
	(QICADR)	;5 CADR
	(QICDDR)	;6 CDDR
	(QICDAR)	;7 CDAR
	(QICAAR)	;10 CAAR
	(QIND1)		;11 ND1
	(QIND2)		;12 ND2
	(QIND3)		;13 ND3
	(QIBRN)		;14 BRANCH
	(MISC)		;15 MISC
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;16 UNUSED
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;17 UNUSED
(END-DISPATCH)

(START-DISPATCH 4 0)
;DESTINATION CODE DISPATCH, VALUE IN M-T
;EACH USE OF THIS DISPATCH TABLE MUST BE FOLLOWED BY A PUSH OF M-T WITH CDR-NEXT SET
QMDTBD	(R-BIT INHIBIT-XCT-NEXT-BIT)		;IGNORE (POPJ IMMEDIATELY)
	(R-BIT)					;TO STACK
	(R-BIT)					;TO NEXT
	(QMDDL INHIBIT-XCT-NEXT-BIT)		;TO LAST
	(QMDDR INHIBIT-XCT-NEXT-BIT)		;TO RETURN
	(ILLOP P-BIT INHIBIT-XCT-NEXT-BIT)	;TO NEXT "QUOTE =1" QUOTE BIT FEATURE LOSES
	(ILLOP P-BIT INHIBIT-XCT-NEXT-BIT)	;TO LAST "QUOTE =1"        ..
	(QMDDNL INHIBIT-XCT-NEXT-BIT)		;TO NEXT LIST
	(R-BIT INHIBIT-XCT-NEXT-BIT)		;D-MICRO, POPJ TO THE MICROCODE
(REPEAT 7 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 3 0)
;DESTINATION CODE DISPATCH FOR MISC INSTRUCTION
D-MISC-DEST
	(P-BIT R-BIT)				;IGNORE (PUSH NO RETURN ADDRESS)
	(MISC-TO-STACK)				;TO STACK
	(MISC-TO-STACK)				;TO NEXT
	(MISC-TO-LAST)				;TO LAST
	(MISC-TO-RETURN)			;TO RETURN
	(ILLOP P-BIT INHIBIT-XCT-NEXT-BIT)	;TO NEXT "QUOTE =1" QUOTE BIT FEATURE LOSES
	(ILLOP P-BIT INHIBIT-XCT-NEXT-BIT)	;TO LAST "QUOTE =1"        ..
	(MISC-TO-LIST)				;TO NEXT LIST
(END-DISPATCH)

;DISPATCH ON REG FIELD FOR COMPUTE EFF ADR, USUAL CASE.
;WILL FETCH OPERAND INTO M-T
(START-DISPATCH 3 P-BIT)  ;DOES CALL-XCT-NEXT
QADCM1	(QAFE)		;FEF
	(QAFE)		;FEF+100
	(QAFE)		;FEF+200
	(QAFE)		;FEF+300
	(QAQT)		;CONSTANTS PAGE
	(QADLOC)	;LOCAL BLOCK
	(QADARG)	;ARG POINTER
	(QADPDL)	;PDL
(END-DISPATCH)

;THIS ONE IS THE SAME EXCEPT THAT IT DOESN'T XCT-NEXT.  USEFUL MAINLY TO SPEED UP NON-DEST.
(START-DISPATCH 3 (PLUS P-BIT INHIBIT-XCT-NEXT-BIT))
QADCM5	(QAFE)		;FEF
	(QAFE)		;FEF+100
	(QAFE)		;FEF+200
	(QAFE)		;FEF+300
	(QAQT)		;CONSTANTS PAGE
	(QADLOC)	;LOCAL BLOCK
	(QADARG)	;ARG POINTER
	(QADPDL)	;PDL
(END-DISPATCH)

;THIS ONE IS THE SAME AS QADCM1 EXCEPT IT ASSUMES YOU ALREADY THE DELTA IN M-1
;IT SAVES ONE CYCLE IN THE MOVE INSTRUCTION
(START-DISPATCH 3 P-BIT)  ;DOES CALL-XCT-NEXT
QADCM4	(QAFE1)		;FEF
	(QAFE)		;FEF+100
	(QAFE)		;FEF+200
	(QAFE)		;FEF+300
	(QAQT1)		;CONSTANTS PAGE
	(QADLOC1)	;LOCAL BLOCK
	(QADARG1)	;ARG POINTER
	(QADPDL1)	;PDL
(END-DISPATCH)

(START-DISPATCH 3 0)	;DOES XCT NEXT
;DISPATCH ON REGISTER FIELD FOR STORE CYCLE, VALUE IN M-T.
;USE THIS ONE IF A READ CYCLE HASN'T BEEN DONE YET
QADCM2	(QSTFE1)	;FEF
	(QSTFE)		;FEF+100
	(QSTFE)		;FEF+200
	(QSTFE)		;FEF+300
	(P-BIT ILLOP)	;CONSTANTS PAGE (ILLEGAL)
	(QSTLOC)	;LOCAL BLOCK
	(QSTARG)	;ARGUMENT BLOCK
	(P-BIT ILLOP)	;PDL (ILLEGAL)
(END-DISPATCH)

(START-DISPATCH 3 0) ;JUMP-XCT-NEXT
;DISPATCH ON REGISTER FIELD FOR OPERATIONS WHICH REQUIRE A TRULY EFFECTIVE ADDRESS
;IN THE VMA.  IF FEF, DO THAT.  OTHERWISE, CONVERT PDL BUFFER ADDRESS.
;POPJS WITH A LOCATIVE EFF ADDR ON THE PDL.
;THIS IS ONLY USED BY THE PUSH-E INSTRUCTION.
QADCM3	(QEAFE)		;FEF
	(QEAFE)		;FEF+100
	(QEAFE)		;FEF+200
	(QEAFE)		;FEF+300
	(P-BIT ILLOP)	;CONSTANTS PAGE (ILLEGAL)
	(QVMALCL)	;LOCAL BLOCK
	(QVMAARG)	;ARGUMENT BLOCK
	(P-BIT ILLOP)	;PDL (ILLEGAL)
(END-DISPATCH)

;DISPATCH FOR GETTING EFFECTIVE ADDRESS FOR BIND.
;THIS HAS TO HAVE A SPECIAL KLUDGE FOR DOING EXACTLY ONE LEVEL
;OF INDIRECTION ON DATA IN THE FEF.
(START-DISPATCH 3 P-BIT) ;CALL-XCT-NEXT
QADCM6	(QBAFE)		;FEF
	(QBAFE)		;FEF+100
	(QBAFE)		;FEF+200
	(QBAFE)		;FEF+300
	(ILLOP)		;CONSTANTS PAGE (ILLEGAL)
	(QVMALCL)	;LOCAL BLOCK
	(QVMAARG)	;ARGUMENT BLOCK
	(ILLOP)		;PDL (ILLEGAL)
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON DATA TYPE.  DROPS THROUGH IN EITHER CASE BUT SKIPS IF ATOM. 
;AN ATOM IS ANYTHING OTHER THAN A LIST.
SKIP-IF-ATOM
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;FIX
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;LOCATIVE
	(P-BIT R-BIT 0)				;LIST -- don't skip
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;U CODE ENTRY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;FEF
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;STACK-GROUP
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;CLOSURE
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;SMALL-FLONUM
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;SELECT-METHOD
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INSTANCE-HEADER
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;ENTITY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON DATA TYPE.  DROPS THROUGH IN EITHER CASE BUT SKIPS IF NOT ATOM. 
;AN ATOM IS ANYTHING OTHER THAN A LIST.
;This exists for "symmetry" with SKIP-IF-ATOM for the microcompiler.
;Its not clear that either of these is really used enuf to justify their own
;dispatch tables.  But for now, this is the easiest thing.
SKIP-IF-NO-ATOM	
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT R-BIT 0)				;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(P-BIT R-BIT 0)				;FIX
	(P-BIT R-BIT 0)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT R-BIT 0)				;LOCATIVE
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;LIST -- skip
	(P-BIT R-BIT 0)				;U CODE ENTRY
	(P-BIT R-BIT 0)				;FEF
	(P-BIT R-BIT 0)				;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT R-BIT 0)				;STACK-GROUP
	(P-BIT R-BIT 0)				;CLOSURE
	(P-BIT R-BIT 0)				;SMALL-FLONUM
	(P-BIT R-BIT 0)				;SELECT-METHOD
	(P-BIT R-BIT 0)				;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INSTANCE-HEADER
	(P-BIT R-BIT 0)				;ENTITY
	(P-BIT R-BIT 0)				;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON DATA TYPE.  DROPS THROUGH IN EITHER CASE BUT SKIPS IF LIST.
SKIP-IF-LIST	
	(P-BIT R-BIT 0)			;TRAP
	(P-BIT R-BIT 0)			;NULL
	(P-BIT R-BIT 0)			;FREE
	(P-BIT R-BIT 0)			;SYMBOL
	(P-BIT R-BIT 0)			;SYMBOL-HEADER
	(P-BIT R-BIT 0)			;FIX
	(P-BIT R-BIT 0)			;EXTENDED NUMBER
	(P-BIT R-BIT 0)			;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT R-BIT 0)			;LOCATIVE
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;LIST
	(P-BIT R-BIT 0)			;U CODE ENTRY
	(P-BIT R-BIT 0)			;FEF
	(P-BIT R-BIT 0)			;ARRAY-POINTER
	(P-BIT R-BIT 0)			;ARRAY-HEADER
	(P-BIT R-BIT 0)			;STACK-GROUP
	(P-BIT R-BIT 0)			;CLOSURE [NOT A LIST FOR PURPOSES OF THIS]
	(P-BIT R-BIT 0)			;SMALL-FLONUM 
	(P-BIT R-BIT 0)			;SELECT-METHOD [NOT A LIST FOR PURPOSES OF THIS]
	(P-BIT R-BIT 0)			;INSTANCE [NOT A LIST FOR PURPOSES OF THIS]
	(P-BIT R-BIT 0)			;INSTANCE-HEADER [NOT A LIST FOR PURPOSES OF THIS]
	(P-BIT R-BIT 0)			;ENTITY [NOT A LIST FOR PURPOSES OF THIS]
	(P-BIT R-BIT 0)			;STACK-CLOSURE [NOT A LIST FOR PURPOSES OF THIS]
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON DATA-TYPE OF FUNCTION GETTING CALLED (AT QMRCL OR MMCALL). 
;THE FUNCTION MUST BE IN BOTH M-A AND C-PDL-BUFFER-INDEX
;M-S HAS THE ADDRESS OF THE NEW FRAME, M-R HAS THE NUMBER OF ARGUMENTS.
;JUMPS TO APPROPRIATE CODE TO CALL THAT KIND OF FUNCTION, OR INTERPRETER TRAP. 
; INHIBIT-XCT-NEXT-BIT IS OFF IF A "LEAVE" IS INDICATED. 
;  A "LEAVE" IS INDICATED UNLESS
;	(1) A LOOP AROUND TYPE OPERATION IS PLANNED, IE SYM, INVZ
;	(2) DTP-ARRAY-POINTER.  HERE A LEAVE IS UNNECESSARY BECAUSE THE LINEAR PDL STATE
;		ISNT REALLY GOING TO GET CLOBBERED. 
;THIS DISPATCH IS DESIGNED TO BE USED FROM BOTH QMRCL AND MMCALL. 

D-QMRCL	(P-BIT ILLOP)			;TRAP
	(P-BIT ILLOP)			;NULL
	(P-BIT ILLOP)			;FREE
	(P-BIT INHIBIT-XCT-NEXT-BIT QMRCL1)	;SYMBOL
	(P-BIT ILLOP)				;SYMBOL-HEADER
	(NUMBER-CALLED-AS-FUNCTION)	;FIX
	(NUMBER-CALLED-AS-FUNCTION)	;EXTENDED NUMBER
	(P-BIT ILLOP)			;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(INTP1)				;LOCATIVE
	(INTP1)				;LIST
	(QME1)				;U CODE ENTRY
	(QLENTR)			;FEF
	(INHIBIT-XCT-NEXT-BIT QARYR)	;ARRAY-POINTER
	(P-BIT ILLOP)			;ARRAY-HEADER
	(SG-CALL)			;STACK-GROUP
	(QCLS)				;CLOSURE
	(NUMBER-CALLED-AS-FUNCTION)	;SMALL-FLONUM 
	(CALL-SELECT-METHOD)		;SELECT-METHOD
	(CALL-INSTANCE)			;INSTANCE
	(P-BIT ILLOP)			;INSTANCE-HEADER
	(CALL-ENTITY)			;ENTITY
	(QCLS)				;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON DATA TYPE BEFORE TAKING CAR
;IF DROPS THROUGH, NORMAL LIST-TYPE CAR
CAR-PRE-DISPATCH 
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FREE
	(INHIBIT-XCT-NEXT-BIT QCARSY)		;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL-HEADER
	(INHIBIT-XCT-NEXT-BIT QCARNM)		;FIX
	(INHIBIT-XCT-NEXT-BIT QCARNM)		;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BODY-FORWARD
	(P-BIT R-BIT)				;LOCATIVE
	(P-BIT R-BIT)				;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE (eventually send message)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY (eventually send message)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE (eventually send message)
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON INPUT DATA TYPE WHEN TAKING CDR
;DROP THROUGH IF NORMAL LIST-TYPE CDR
CDR-PRE-DISPATCH
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FREE
	(INHIBIT-XCT-NEXT-BIT QCDRSY)		;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL-HEADER
	(INHIBIT-XCT-NEXT-BIT QCDRNM)		;FIX
	(INHIBIT-XCT-NEXT-BIT QCDRNM)		;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT QCAR3)		;LOCATIVE.  NOTE CAR!!
	(P-BIT R-BIT)				;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE (eventually send message)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY (eventually send message)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 2 0)	;MAYBE DOES XCT-NEXT
;DISPATCH ON CDR-CODE WHEN TAKING CDR
;POPJ-XCT-NEXT IF CDR-NEXT (PROBABLY MOST FREQUENT CASE)
CDR-CDR-DISPATCH 
	(INHIBIT-XCT-NEXT-BIT CDR-FULL-NODE)	;FULL-NODE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CDR NOT
	(INHIBIT-XCT-NEXT-BIT CDR-IS-NIL)	;CDR NIL
	(R-BIT)					;CDR NEXT
(END-DISPATCH)

(START-DISPATCH 2 0)
;DISPATCH ON M-CAR-SYM-MODE WHEN TAKING CAR OF SYM
CAR-SYM-DISPATCH 
	(P-BIT TRAP)	;ERROR
	(P-BIT R-BIT)	;ERROR EXCEPT (CAR NIL) = NIL
	(XFALSE)	;NIL
	(P-BIT TRAP)	;UNUSED
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON M-CAR-NUM-MODE WHEN TAKING CAR OF NUM
CAR-NUM-DISPATCH
	(P-BIT TRAP)	;ERROR
	(XFALSE)	;NIL
	(P-BIT TRAP)	;"WHATEVER IT IS"
	(P-BIT TRAP)	;ERROR
(END-DISPATCH)

(START-DISPATCH 2 0)
;DISPATCH ON M-CDR-SYM-MODE WHEN TAKING CDR OF SYM
CDR-SYM-DISPATCH
	(P-BIT TRAP)	;ERROR
	(P-BIT R-BIT)	;ERROR EXCEPT (CDR NIL) = NIL
	(R-BIT)		;NIL -> NIL
	(QCDPRP)	;PROPERTY LIST
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON M-CDR-NUM-MODE WHEN TAKING CDR OF NUM
CDR-NUM-DISPATCH 
	(P-BIT TRAP)	;ERROR
	(XFALSE)	;NIL
	(P-BIT TRAP)	;"WHATEVER IT IS"
	(P-BIT TRAP)
(END-DISPATCH)

(START-DISPATCH 2 0)	;MAYBE DOES XCT-NEXT
;DISPATCH ON CDR-CODE WHEN AT CALL-INSTANCE-2
;LOOP IF CDR-NEXT, DROP THROUGH IF CDR-NIL, OTHERWISE ERROR
D-CALL-INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FULL-NODE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CDR NOT
	(P-BIT R-BIT)				;CDR NIL
	(CALL-INSTANCE-1)			;CDR NEXT
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON DOING RPLACA OF SYMBOL
RPLACA-SYM-DISPATCH 
	(P-BIT TRAP)	;ERROR
	(P-BIT TRAP)	;ALSO ERROR IF (CAR NIL) = NIL
	(P-BIT TRAP)	;OR IF (CAR SYM) = NIL
	(P-BIT TRAP)	;"SMASH P-STRING POINTER" - NOT ALLOWED
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON DOING RPLACD OF SYM
RPLACD-SYM-DISPATCH
	(P-BIT TRAP)	;ERROR
	(P-BIT TRAP)	;ERROR
	(P-BIT TRAP)	;ERROR
	(QRDPRP)	;SMASH PROP LIST
(END-DISPATCH)

(START-DISPATCH 2 0)	;DOES XCT-NEXT
;DISPATCH ON CDR-CODE WHEN DOING RPLACD
RPLACD-CDR-DISPATCH
	(RPLACD-FULL-NODE)	;FULL NODE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CDR NOT
	(RPLACD-NEXT-NIL)	;CDR NIL
	(RPLACD-CDR-NEXT)	;CDR NEXT
(END-DISPATCH)

(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)
;DISP ON DATA TYPE OF POINTER-TO-SMASH-CONTENTS-OF WHEN DOING RPLACA
QRACDT	(P-BIT TRAP)	;TRAP
	(P-BIT TRAP)	;NULL
	(P-BIT TRAP)	;FREE
	(QRASYM)	;SYMBOL
	(P-BIT TRAP)	;SYMBOL-HEADER
	(P-BIT TRAP)	;FIX
	(P-BIT TRAP)	;EXTENDED NUMBER
	(P-BIT TRAP)	;HEADER
	(P-BIT TRAP)	;GC-FORWARD
	(P-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT TRAP)	;HEADER-FORWARD
	(P-BIT TRAP)	;BODY-FORWARD
	(QRAR3)		;LOCATIVE
	(QRAR3)		;LIST
	(P-BIT TRAP)	;U CODE ENTRY
	(P-BIT TRAP)	;FEF
	(P-BIT TRAP)	;ARRAY-POINTER
	(P-BIT TRAP)	;ARRAY-HEADER
	(P-BIT TRAP)	;STACK-GROUP
	(P-BIT TRAP)	;CLOSURE
	(P-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT TRAP)	;SELECT-METHOD
	(P-BIT TRAP)	;INSTANCE
	(P-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT TRAP)	;ENTITY
	(P-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON DATA TYPE OF POINTER-TO-SMASH-CONTENTS-OF WHEN DOING RPLACD
QRDCDT	(P-BIT TRAP)	;TRAP
	(P-BIT TRAP)	;NULL
	(P-BIT TRAP)	;FREE
	(QRDRSY)	;SYMBOL
	(P-BIT TRAP)	;SYMBOL-HEADER
	(P-BIT TRAP)	;FIX
	(P-BIT TRAP)	;EXTENDED NUMBER
	(P-BIT TRAP)	;HEADER
	(P-BIT TRAP)	;GC-FORWARD
	(P-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT TRAP)	;HEADER-FORWARD
	(P-BIT TRAP)	;BODY-FORWARD
	(QRAR3)		;LOCATIVE. NOTE CAR!!
	(QRDR3)		;LIST
	(P-BIT TRAP)	;U CODE ENTRY
	(P-BIT TRAP)	;FEF
	(P-BIT TRAP)	;ARRAY-POINTER
	(P-BIT TRAP)	;ARRAY-HEADER
	(P-BIT TRAP)	;STACK-GROUP
	(P-BIT TRAP)	;CLOSURE
	(P-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT TRAP)	;SELECT-METHOD
	(P-BIT TRAP)	;INSTANCE
	(P-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT TRAP)	;ENTITY
	(P-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 P-BIT)
;TRAP UNLESS DATA TYPE IS FIXNUM.
TRAP-UNLESS-FIXNUM
	(INHIBIT-XCT-NEXT-BIT TRAP)	;TRAP
	(INHIBIT-XCT-NEXT-BIT TRAP)	;NULL
	(INHIBIT-XCT-NEXT-BIT TRAP)	;FREE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL-HEADER
	(R-BIT)				;FIX  P-BIT AND R-BIT CAUSE DISPATCH TO BE A NO-OP
	(INHIBIT-XCT-NEXT-BIT TRAP)	;EXTENDED NUMBER - IS THIS RIGHT?
	(INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;GC-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SMALL-FLONUM 
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 P-BIT);DOES CALL-XCT-NEXT
;DISPATCH ON ARRAY TYPE WHEN REF ING ARRAY
ARRAY-TYPE-REF-DISPATCH
	(INHIBIT-XCT-NEXT-BIT TRAP)
	(QB1RY)		;BIT ARRAY
	(QB2RY)		;2 BIT ARRAY
	(QB4RY)		;4 BIT ARRAY
	(QBARY)		;8 BIT ARRAY
	(QB16RY)	;16 BIT ARRAY
	(QB32RY)	;32 BIT ARRAY
	(QQARY)		;Q ARRAY
	(QQARY)		;LIST Q ARRAY
	(QBARY)		;STRING ARRAY
	(QQARY)		;STACK-GROUP HEAD
	(QQARY)		;SPEC-PDL
	(QB16SRY)	;HALF-FIX
	(QQARY)		;REG-PDL
	(QFARY)		;FLOAT
 	(QFFARY)	;FPS-FLOAT
	(QB16RY)	;FAT-STRING
 (REPEAT NATUSD (INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 0)	;DOES XCT-NEXT
;DISPATCH ON ARRAY TYPE WHEN STORING INTO ARRAY
ARRAY-TYPE-STORE-DISPATCH
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)
	(QS1RY)		;BIT ARRAY
	(QS2RY)		;2 BIT ARRAY
	(QS4RY)		;4 BIT ARRAY
	(QSBARY)	;8 BIT ARRAY
	(QS16RY)	;16 BIT ARRAY
	(QS32RY)	;32 BIT ARRAY
	(QSQARY)	;Q ARRAY
	(QSLQRY)	;LIST Q ARRAY
	(QSBARY)	;BYTE ARRAY
	(QSQARY)	;STACK-GROUP HEAD
	(QSQARY)	;SPEC-PDL
	(QS16RY)	;HALF-FIX
	(QSQARY)	;REG-PDL
	(QSFARY)	;FLOAT
 	(QSFFARY)	;FPS-FLOAT
	(QS16RY)	;FAT-STRING
 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 (PLUS P-BIT INHIBIT-XCT-NEXT-BIT))
;DISPATCH ON ARRAY TYPE AT XFARY
ARRAY-TYPE-FILL-DISPATCH 
	(TRAP)
	(QS1RY)		;BIT ARRAY
	(QS2RY)		;2
	(QS4RY)		;4
	(QSBARY)	;8
	(QS16RY)	;16
	(QS32RY)	;32
	(QSQARY)	;Q ARRAY
	(XFALAR)	;LIST -- SPECIAL HACKERY WITH CDR CODES TO EXTEND "LIST"
	(QSBARY)	;BYTE
	(QSQARY)	;STACK-GROUP HEAD
	(QSQARY)	;SPEC-PDL
	(QS16RY)	;HALF-FIX
	(QSQARY)	;REG-PDL
	(QSFARY)	;FLOAT
	(QSFFARY)	;FPS-FLOAT
	(QS16RY)	;FAT-STRING
 (REPEAT NATUSD (TRAP))
(END-DISPATCH)

(START-DISPATCH 5 0) ;DISPATCH ON ARRAY TYPE
SKIP-IF-NUMERIC-ARRAY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ERROR
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;BIT ARRAY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;2 BIT ARRAY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;4 BIT ARRAY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;8 BIT ARRAY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;16 BIT ARRAY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;32 BIT ARRAY
	(P-BIT R-BIT)				;Q ARRAY
	(P-BIT R-BIT)				;LIST Q ARRAY
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;STRING ARRAY
	(P-BIT R-BIT)				;STACK-GROUP HEAD
	(P-BIT R-BIT)				;SPEC-PDL
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;HALF-FIX
	(P-BIT R-BIT)				;REG-PDL
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;FLOAT
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;FPS-FLOAT	
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;FAT-STRING
 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

;DISPATCH ON "DESTINATION" FIELD OF BRANCH
(START-DISPATCH 3 0)	;DOES XCT-NEXT
BRDTAB	(QBRALW)
	(QBRNL)
	(QBRNNL)
	(QBRNLP)
	(QBRNNP)
	(QBRAT)
	(QBRNAT)
	(ILLOP)
(END-DISPATCH)

;DISPATCH ON ADDITIONAL INFO TYPE AT QLEAI3
(START-DISPATCH 3 0)
D-QLEAI3
	(INHIBIT-XCT-NEXT-BIT ILLOP)	;0 ERR
	(INHIBIT-XCT-NEXT-BIT QLEAI4)	;1 MULT RET
	(INHIBIT-XCT-NEXT-BIT QLEAI4)	;2 RESTART PC
	(QLEAI2)			;3 FEXPR CALL
	(QLEAI2)			;4 LEXPR CALL
	(INHIBIT-XCT-NEXT-BIT ILLOP)	;5 ERR
	(INHIBIT-XCT-NEXT-BIT ILLOP)	;6 ERR
	(INHIBIT-XCT-NEXT-BIT ILLOP)	;7 ERR
(END-DISPATCH)

;DISPATCH ON TYPE OF ARG, ARG IS SUPPLIED
(START-DISPATCH 3 0)
QREDT1	(QBRQA)		;REQUIRED ARG
	(QBROP1)	;OPTIONAL ARG
	(QBRA)		;REST ARG
	(QBTMA2)	;AUX VAR, (HAVE REACHED END OF ARG SECT, WITH MORE ARGS)
	(QBTMA2)	;FREE,      ..
	(QBTMA2)	;INTERNAL,  ..
	(QBTMA2)	;INTERNAL-AUX,  ..
	(P-BIT ILLOP)	;UNUSED
(END-DISPATCH)

;DISPATCH ON INITIALIZING OPTION, OPT ARG HAS BEEN SUPPLIED
(START-DISPATCH 3 INHIBIT-XCT-NEXT-BIT)
QBOPNP	(QBRQA)		;NONE
	(QBRQA)		;NIL
	(QBOSP)		;INIT TO POINTER (SPACE PAST)
	(QBOSP)		;INIT TO C(POINTER) (LIKEWISE)
	(QBOASA)	;ALT STARTING ADR, START THERE TO AVOID CLOBBERING IT
	(QBRQA)		;INIT BY COMPILED CODE
	(QBOSP)		;INIT TO C(EFF ADR)
	(QBRQA)		;INIT TO SELF
(END-DISPATCH)

;DISPATCH ON TYPE OF NEXT B-D-L ENTRY AFTER ALL PRESENT ARGS HAVE BEEN PROCESSED
(START-DISPATCH 3 0)	;DOES XCT-NEXT
QBDT2	(QBTFA1)	;THIS WAS A REQUIRED ARG, BARF
	(QBOPT1)	;THIS WAS AN OPT ARG, NOT PRESENT
	(QBRA1)		;THIS WAS A REST ARG, SET IT TO NIL
	(QBDAUX)	;AUX VAR, REALLY END OF ARG PART OF B-D-L
	(QBDFRE)	;FREE,     ..
	(QBDINT)	;INTERNAL, ..
	(QBDINT)	;INTERNAL-AUX, ..
	(P-BIT ILLOP)
(END-DISPATCH)

;DISPATCH ON INTIALIZING OPTION, GOING TO INITIALIZE VARIABLE
(START-DISPATCH 3 INHIBIT-XCT-NEXT-BIT)
QBOPTT	(QBOPT3)	;NONE
	(QBOPT2)	;NIL
	(QBOPNR)	;INIT TO POINTER
	(QBOCPT)	;INIT TO C(POINTER)
	(QBOPT5)	;OPT ARG, ALT SA
			;ARG NOT PRESENT, SO LEAVE STARTING ADR ALONE 
			;AND LET CODE INIT IT
	(QBOPT3)	;INIT BY COMPILED CODE
	(QBOEFF)	;INIT TO CONTENTS OF "EFFECTIVE ADDRESS"
	(QBOPT3)	;INIT TO SELF (SAME AS NONE)
(END-DISPATCH)

;DISPATCH ON DESIRED DATA TYPE FOR ARG
(START-DISPATCH 4 0)	;DOES NXT INSTR
QBDDT	(R-BIT P-BIT)	;0 NO DATA TYPE CHECKING
	(QDTN)		;1 NUMBER
	(QDTFXN)	;2 FIXNUM
	(QDTSYM)	;3 SYMBOL
	(QDTATM)	;4 ATOM
	(QDTLST)	;5 LIST
	(QDTFRM)	;6 FRAME
(REPEAT 11 (P-BIT ILLOP))	;UNDEF CODE
(END-DISPATCH)

;DISPATCH ON DESIRED EVAL/QUOTE STATUS FOR ARG
;(START-DISPATCH 2 0)	;DOES NXT INSTR
;QBEQC	(R-BIT P-BIT)	;0 NO CHECKING
;	(QBEQE)		;1 DESIRED EVALUATED
;	(QBEQQ)		;2 DESIRED QUOTED
;	(QBEQQ)		;3 DESIRED BROKEN-OFF
;(END-DISPATCH)

;DISPATCH ON REGISTER FIELD OF EFF ADDR FOR INITIALIZING AUX VAR/OPT ARG
(START-DISPATCH 3 0)	;DOES NXT INSTR
QBOFDT	(QBFE)
	(QBFE)
	(QBFE)
	(QBFE)
	(QBQT)
	(QBDLOC)
	(QBDARG)
	(P-BIT ILLOP)	;PDL ILLEGAL
(END-DISPATCH)

(START-DISPATCH 3 0)  ;WANT XCT-NEXT
;DISPATCH ON DEST FIELD OF NON-DEST-GROUP-1 INSTRUCTIONS
;OPERAND FETCHED INTO M-T, VMA -> OPERAND
D-ND1	(ILLOP P-BIT)
	(QIADD)
	(QISUB)
	(QIMUL)
	(QIDIV)
	(QIAND)
	(QIXOR)
	(QIIOR)
(END-DISPATCH)

(START-DISPATCH 3 0)	;WANT XCT-NEXT
;DISPATCH ON DEST FIELD OF NON-DEST-GROUP-2 INSTRUCTIONS
;OPERAND FETCHED INTO M-T, VMA -> OPERAND
D-ND2	(QIEQL)
	(QIGRP)
	(QILSP)
	(QIEQ)
	(QISCDR)
	(QISCDDR)
	(QISP1)
	(QISM1)
(END-DISPATCH)

(START-DISPATCH 3 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON DEST FIELD OF NON-DEST-GROUP-3 INSTRUCTIONS
;OPERAND NOT FETCHED YET
D-ND3	(QIBND)
	(QIBNDN)
	(QIBNDP)
	(QISETN)
	(QISETZ)
	(QIPSHE)
	(QIMVM)
	(QIPOP)
(END-DISPATCH)

;DISPATCH ON RETURN STORING OPTION IN MVR
(START-DISPATCH 3 0)	;DOES NXT INSTR
D-MVR	(P-BIT ILLOP)	;ERROR
	(MVRB)		;BLOCK
	(P-BIT ILLOP)	;STORE INTO LIST
	(MVRC)		;CONS UP LIST
	(MVRIND)	;INDIRECT POINTER (OBSOLETE)
	(P-BIT ILLOP)	;ERROR
	(P-BIT ILLOP)	;ERROR
	(P-BIT ILLOP)	;ERROR
(END-DISPATCH)

(START-DISPATCH 5 P-BIT)
;TRAP UNLESS DATA TYPE IS SYM
TRAP-UNLESS-SYM
	(INHIBIT-XCT-NEXT-BIT TRAP)	;TRAP
	(INHIBIT-XCT-NEXT-BIT TRAP)	;NULL
	(INHIBIT-XCT-NEXT-BIT TRAP)	;FREE
	(R-BIT)				;SYM  P-BIT & R-BIT CAUSE DISPATCH TO BE A NO-OP
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL-HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;FIX
	(INHIBIT-XCT-NEXT-BIT TRAP)	;EXTENDED NUMBER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;GC-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SMALL-FLONUM 
	(INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 0) ;DOES XCT-NEXT UNLESS ILLOPS
;POPJ IF DATA TYPE IS NOT NUMERIC.  ONLY USED BY NUMBERP.
POPJ-IF-NOT-NUMBER 
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(R-BIT)					;NULL, POPJ
	(R-BIT)					;FREE, POPJ
	(R-BIT)					;SYM, POPJ
	(R-BIT)					;SYMBOL-HEADER, POPJ
	(P-BIT R-BIT)				;FIX, FALL-THROUGH
	(P-BIT R-BIT)				;EXTENDED NUMBER, FALL-THROUGH
	(R-BIT)					;HEADER, POPJ
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(R-BIT)					;LOCATIVE, POPJ
	(R-BIT)					;LIST, POPJ
	(R-BIT)					;U CODE ENTRY, POPJ
	(R-BIT)					;FEF, POPJ 
	(R-BIT)					;ARRAY-POINTER, POPJ
	(R-BIT)					;ARRAY-HEADER, POPJ
	(R-BIT)					;STACK-GROUP, POPJ
	(R-BIT)					;CLOSURE, POPJ
	(P-BIT R-BIT)				;SMALL-FLONUM, FALL-THROUGH
	(R-BIT)					;SELECT-METHOD, POPJ
	(R-BIT)					;INSTANCE, POPJ
	(R-BIT)					;INSTANCE-HEADER, POPJ
	(R-BIT)					;ENTITY, POPJ
	(R-BIT)					;STACK-CLOSURE, POPJ
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 5 0)  ;INHIBIT-XCT-NEXT-BIT UNLESS CANT FIGURE IT OUT 
		      ; (IE INTERPRETER TRAP)
XARGI-DISPATCH
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;TRAP
	(R-BIT)					;NULL
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;FREE
	(XARGI3 INHIBIT-XCT-NEXT-BIT)		;SYM, REPLACE WITH FCTN CELL 
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SYMBOL-HEADER	
	(R-BIT)					;FIX
	(R-BIT)					;EXTENDED NUMBER
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;HEADER
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;GC-FORWARD
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;ONE-Q-FORWARD
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;HEADER-FORWARD
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;BODY-FORWARD
	(R-BIT)					;LOCATIVE
	(R-BIT)					;LIST, (GO TO INTERPRETER)
	(XAGUE1 INHIBIT-XCT-NEXT-BIT)		;U CODE ENTRY
	(XAGM1 INHIBIT-XCT-NEXT-BIT)		;FEF, RETURN FAST OPT Q
	(XAGAR1 INHIBIT-XCT-NEXT-BIT)		;ARRAY-POINTER
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;ARRAY-HEADER
	(XAGISG INHIBIT-XCT-NEXT-BIT)		;STACK-GROUP
	(XAGICL INHIBIT-XCT-NEXT-BIT)		;CLOSURE
	(R-BIT)					;SMALL-FLONUM
	(R-BIT)					;SELECT-METHOD. CAN'T SAY WITHOUT KEY
						; SO BE CONSERVATIVE
	(R-BIT)					;INSTANCE (COULD GET FUNCTION BUT WHY BOTHER
						; SINCE IT WILL BE A SELECT-METHOD ANYWAY)
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;INSTANCE-HEADER
	(XAGICL INHIBIT-XCT-NEXT-BIT)		;ENTITY
	(XAGICL INHIBIT-XCT-NEXT-BIT)		;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT))
(END-DISPATCH)

(START-DISPATCH 6 P-BIT)	;TRANSPORTER DISPATCH ON DATA TYPE AND MAP BIT
;EITHER DROPS THROUGH (P-R) OR CALLS (P-N) MAGIC ROUTINE.
;FOR TYPES WHICH AREN'T INUMS, THE 0 CASE GOES TO TRANS-OLD TO CHECK FOR OLD-SPACE
D-TRANSPORT
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;0 TRAP
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;1 TRAP
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 NULL (TRANSPORT FOR SCAVENGER, XPCAL)
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;1 NULL
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;0 FREE
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;1 FREE
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 SYMBOL
	(R-BIT)					;1 SYMBOL
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 SYMBOL-HEADER
	(R-BIT)					;1 SYMBOL-HEADER
	(R-BIT)					;0 FIX
	(R-BIT)					;1 FIX
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 EXTENDED-NUMBER
	(R-BIT)					;1 EXTENDED-NUMBER
	(R-BIT)					;0 HEADER
	(R-BIT)					;1 HEADER
	(INHIBIT-XCT-NEXT-BIT ILLOP)		;0 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(INHIBIT-XCT-NEXT-BIT ILLOP)		;1 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(INHIBIT-XCT-NEXT-BIT TRANS-OLDP-EVCP)	;0 EXTERNAL-VALUE-CELL-POINTER
	(INHIBIT-XCT-NEXT-BIT TRANS-EVCP)	;1 EXTERNAL-VALUE-CELL-POINTER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD0)	;0 ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-OQF)	;1 ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD0)	;0 HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-HFWD)	;1 HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-BFWD)	;0 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-BFWD)	;1 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 LOCATIVE
	(R-BIT)					;1 LOCATIVE
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 LIST
	(R-BIT)					;1 LIST
	(R-BIT)					;0 U CODE ENTRY
	(R-BIT)					;1 U CODE ENTRY
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 FEF-POINTER
	(R-BIT)					;1 FEF-POINTER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 ARRAY-POINTER
	(R-BIT)					;1 ARRAY-POINTER
	(R-BIT)					;0 ARRAY-HEADER
	(R-BIT)					;1 ARRAY-HEADER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 STACK-GROUP
	(R-BIT)					;1 STACK-GROUP
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 CLOSURE
	(R-BIT)					;1 CLOSURE
	(R-BIT)					;0 SMALL-FLONUM
	(R-BIT)					;1 SMALL-FLONUM
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 SELECT-METHOD
	(R-BIT)					;1 SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 INSTANCE
	(R-BIT)					;1 INSTANCE
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 INSTANCE-HEADER
	(R-BIT)					;1 INSTANCE-HEADER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 ENTITY
	(R-BIT)					;1 ENTITY
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 STACK-CLOSURE
	(R-BIT)					;1 STACK-CLOSURE
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))

(REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
(END-DISPATCH)

(START-DISPATCH 6 P-BIT)	;TRANSPORTER DISPATCH ON DATA TYPE AND MAP BIT
;EITHER DROPS THROUGH (P-R) OR CALLS (P-N) MAGIC ROUTINE.
;FOR TYPES WHICH AREN'T INUMS, THE 0 CASE GOES TO TRANS-OLD TO CHECK FOR OLD-SPACE
D-TRANSPORT-NO-EVCP
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;0 TRAP
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;1 TRAP
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 NULL (TRANSPORT FOR SCAVENGER, XPCAL)
	(R-BIT)					;1 NULL
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;0 FREE
	(INHIBIT-XCT-NEXT-BIT TRANS-TRAP)	;1 FREE
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 SYMBOL
	(R-BIT)					;1 SYMBOL
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 SYMBOL-HEADER
	(R-BIT)					;1 SYMBOL-HEADER
	(R-BIT)					;0 FIX
	(R-BIT)					;1 FIX
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 EXTENDED-NUMBER
	(R-BIT)					;1 EXTENDED-NUMBER
	(R-BIT)					;0 HEADER
	(R-BIT)					;1 HEADER
	(INHIBIT-XCT-NEXT-BIT ILLOP)		;0 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(INHIBIT-XCT-NEXT-BIT ILLOP)		;1 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 EXTERNAL-VALUE-CELL-POINTER
	(R-BIT)					;1 EXTERNAL-VALUE-CELL-POINTER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD0)	;0 ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-OQF)	;1 ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD0)	;0 HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-HFWD)	;1 HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-BFWD)	;0 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-BFWD)	;1 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 LOCATIVE
	(R-BIT)					;1 LOCATIVE
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 LIST
	(R-BIT)					;1 LIST
	(R-BIT)					;0 U CODE ENTRY
	(R-BIT)					;1 U CODE ENTRY
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 FEF-POINTER
	(R-BIT)					;1 FEF-POINTER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 ARRAY-POINTER
	(R-BIT)					;1 ARRAY-POINTER
	(R-BIT)					;0 ARRAY-HEADER
	(R-BIT)					;1 ARRAY-HEADER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 STACK-GROUP
	(R-BIT)					;1 STACK-GROUP
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 CLOSURE
	(R-BIT)					;1 CLOSURE
	(R-BIT)					;0 SMALL-FLONUM
	(R-BIT)					;1 SMALL-FLONUM
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 SELECT-METHOD
	(R-BIT)					;1 SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 INSTANCE
	(R-BIT)					;1 INSTANCE
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 INSTANCE-HEADER
	(R-BIT)					;1 INSTANCE-HEADER
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 ENTITY
	(R-BIT)					;1 ENTITY
	(INHIBIT-XCT-NEXT-BIT TRANS-OLD)	;0 STACK-CLOSURE
	(R-BIT)					;1 STACK-CLOSURE
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
(END-DISPATCH)

;THIS FLAVOR OF TRANSPORTER DISPATCH IS FOR THE PDL-BUFFER REFILL ROUTINE,
;WHICH MUST DO SOME FIXUP BEFORE CALLING THE TRANSPORTER
;ON THE 0 CASE OF NON-INUMS, IT MAY BE OLD-SPACE
(START-DISPATCH 6 0)	;TRANSPORTER DISPATCH ON DATA TYPE AND MAP BIT
;EITHER DROPS THROUGH (P-R) OR JUMPS TO PB-TRANS
D-PB-TRANS	
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 TRAP
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;1 TRAP
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 NULL
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;1 NULL
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 FREE
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;1 FREE
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 SYMBOL
	(P-BIT R-BIT)				;1 SYMBOL
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 SYMBOL-HEADER
	(P-BIT R-BIT)				;1 SYMBOL-HEADER
	(P-BIT R-BIT)				;0 FIX
	(P-BIT R-BIT)				;1 FIX
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 EXTENDED-NUMBER
	(P-BIT R-BIT)				;1 EXTENDED-NUMBER
	(P-BIT R-BIT)				;0 HEADER
	(P-BIT R-BIT)				;1 HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;0 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;1 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 EXTERNAL-VALUE-CELL-POINTER
	(P-BIT R-BIT)				;1 EXTERNAL-VALUE-CELL-POINTER
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;1 ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;1 HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;1 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 LOCATIVE
	(P-BIT R-BIT)				;1 LOCATIVE
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 LIST
	(P-BIT R-BIT)				;1 LIST
	(P-BIT R-BIT)				;0 U CODE ENTRY
	(P-BIT R-BIT)				;1 U CODE ENTRY
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 FEF-POINTER
	(P-BIT R-BIT)				;1 FEF-POINTER
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 ARRAY-POINTER
	(P-BIT R-BIT)				;1 ARRAY-POINTER
	(P-BIT R-BIT)				;0 ARRAY-HEADER
	(P-BIT R-BIT)				;1 ARRAY-HEADER
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 STACK-GROUP
	(P-BIT R-BIT)				;1 STACK-GROUP
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 CLOSURE
	(P-BIT R-BIT)				;1 CLOSURE
	(P-BIT R-BIT)				;0 SMALL-FLONUM
	(P-BIT R-BIT)				;1 SMALL-FLONUM
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 SELECT-METHOD
	(P-BIT R-BIT)				;1 SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 INSTANCE
	(P-BIT R-BIT)				;1 INSTANCE
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 INSTANCE-HEADER
	(P-BIT R-BIT)				;1 INSTANCE-HEADER
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 ENTITY
	(P-BIT R-BIT)				;1 ENTITY
	(INHIBIT-XCT-NEXT-BIT PB-TRANS)		;0 STACK-CLOSURE
	(P-BIT R-BIT)				;1 STACK-CLOSURE
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT PB-TRANS))
 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT PB-TRANS))
(END-DISPATCH)

(START-DISPATCH 6 P-BIT)	;GC-WRITE-TEST (MAP18: 0=EXTRA-PDL, 1=NORMAL)
;EITHER DROPS THROUGH (P-R) OR CALLS (P-N) MAGIC ROUTINE.
;CURRENTLY ANYWAY, DOESN'T TRAP ON ILL DATA TYPES.  THAT WOULD NEED AN I-ARG TO SUPPRESS IT.
;DATA TYPES CURRENTLY CHECKED FOR IN EXTRA-PDL: EXTENDED-NUMBER, LOCATIVE, ARRAY
D-GC-WRITE-TEST
	(R-BIT)					;0 TRAP
	(R-BIT)					;1 TRAP
	(R-BIT)					;0 NULL
	(R-BIT)					;1 NULL
	(R-BIT)					;0 FREE
	(R-BIT)					;1 FREE
	(R-BIT)					;0 SYMBOL
	(R-BIT)					;1 SYMBOL
	(R-BIT)					;0 SYMBOL-HEADER
	(R-BIT)					;1 SYMBOL-HEADER
	(R-BIT)					;0 FIX
	(R-BIT)					;1 FIX
	(INHIBIT-XCT-NEXT-BIT EXTRA-PDL-TRAP)	;0 EXTENDED-NUMBER
	(R-BIT)					;1 EXTENDED-NUMBER
	(R-BIT)					;0 HEADER
	(R-BIT)					;1 HEADER
	(R-BIT)					;0 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(R-BIT)					;1 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
	(R-BIT)					;0 EXTERNAL-VALUE-CELL-POINTER
	(R-BIT)					;1 EXTERNAL-VALUE-CELL-POINTER
	(R-BIT)					;0 ONE-Q-FORWARD
	(R-BIT)					;1 ONE-Q-FORWARD
	(R-BIT)					;0 HEADER-FORWARD
	(R-BIT)					;1 HEADER-FORWARD
	(R-BIT)					;0 BODY-FORWARD
	(R-BIT)					;1 BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT EXTRA-PDL-TRAP)	;0 LOCATIVE
	(R-BIT)					;1 LOCATIVE
	(R-BIT)					;0 LIST
	(R-BIT)					;1 LIST
	(R-BIT)					;0 U CODE ENTRY
	(R-BIT)					;1 U CODE ENTRY
	(R-BIT)					;0 FEF-POINTER
	(R-BIT)					;1 FEF-POINTER
	(INHIBIT-XCT-NEXT-BIT EXTRA-PDL-TRAP)	;0 ARRAY-POINTER
	(R-BIT)					;1 ARRAY-POINTER
	(R-BIT)					;0 ARRAY-HEADER
	(R-BIT)					;1 ARRAY-HEADER
	(R-BIT)					;0 STACK-GROUP
	(R-BIT)					;1 STACK-GROUP
	(R-BIT)					;0 CLOSURE
	(R-BIT)					;1 CLOSURE
	(R-BIT)					;0 SMALL-FLONUM
	(R-BIT)					;1 SMALL-FLONUM
	(R-BIT)					;0 SELECT-METHOD
	(R-BIT)					;1 SELECT-METHOD
	(R-BIT)					;0 INSTANCE
	(R-BIT)					;1 INSTANCE
	(R-BIT)					;0 INSTANCE-HEADER
	(R-BIT)					;1 INSTANCE-HEADER
	(R-BIT)					;0 ENTITY
	(R-BIT)					;1 ENTITY
	(INHIBIT-XCT-NEXT-BIT STACK-CLOSURE-TRAP)	;0 STACK-CLOSURE
	(INHIBIT-XCT-NEXT-BIT STACK-CLOSURE-TRAP)	;0 STACK-CLOSURE
 (REPEAT NQZUSD (R-BIT))
 (REPEAT NQZUSD (R-BIT))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON DATA TYPE OF WORD JUST STORED FROM PDL BUFFER INTO MAIN MEMORY,
;OR RETURNED FROM A FUNCTION.
;ILLOP ON DATA TYPE WHICH SHOULDN'T HAVE BEEN THERE IN THE FIRST PLACE
D-ILLOP-IF-BAD-DATA-TYPE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT R-BIT 0)				;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL-HEADER
	(P-BIT R-BIT 0)				;FIX
	(P-BIT R-BIT 0)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT R-BIT 0)				;EXTERNAL-VALUE-CELL-POINTER this ok now.
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT R-BIT 0)				;LOCATIVE
	(P-BIT R-BIT 0)				;LIST
	(P-BIT R-BIT 0)				;U CODE ENTRY
	(P-BIT R-BIT 0)				;FEF
	(P-BIT R-BIT 0)				;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT R-BIT 0)				;STACK-GROUP
	(P-BIT R-BIT 0)				;CLOSURE
	(P-BIT R-BIT 0)				;SMALL-FLONUM 
	(P-BIT R-BIT 0)				;SELECT-METHOD
	(P-BIT R-BIT 0)				;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INSTANCE-HEADER
	(P-BIT R-BIT 0)				;ENTITY
	(P-BIT R-BIT 0)				;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;Microcompiled code support
  ;These are in dispatch mem just so can take arg in dispatch constant.
  ;Said arg is the offset into exit-vector-area.

(START-DISPATCH 0 0)
;Read Q from exit vector, leave it in MD.  Does transporting, forwarding, etc.
D-READ-EXIT-VECTOR (P-BIT INHIBIT-XCT-NEXT-BIT MC-READ-EXIT-VECTOR)
(END-DISPATCH)

(START-DISPATCH 0 0)
;Write Q from MD thru exit vector.  Does transporting, forwarding, etc.
D-WRITE-EXIT-VECTOR (P-BIT INHIBIT-XCT-NEXT-BIT MC-WRITE-EXIT-VECTOR)
(END-DISPATCH)

(START-DISPATCH 0 0)
;Open micro-macro call block to function from exit vector.
D-CALL-EXIT-VECTOR (P-BIT INHIBIT-XCT-NEXT-BIT MC-CALL-EXIT-VECTOR)
(END-DISPATCH)

;Following for support routines that take arg via DISPATCH-CONSTANT.
(START-DISPATCH 0 0)
D-SE1+	(P-BIT INHIBIT-XCT-NEXT-BIT MC-SE1+)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-SE1-	(P-BIT INHIBIT-XCT-NEXT-BIT MC-SE1-)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-SECDR (P-BIT INHIBIT-XCT-NEXT-BIT MC-SECDR)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-SECDDR (P-BIT INHIBIT-XCT-NEXT-BIT MC-SECDDR)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-START-LIST (P-BIT INHIBIT-XCT-NEXT-BIT MC-START-LIST)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-START-LIST-AREA (P-BIT INHIBIT-XCT-NEXT-BIT MC-START-LIST-AREA)
(END-DISPATCH)

;Links to routines which activate MICRO-MACRO calls
(START-DISPATCH 0 0)
D-MMCALL (P-BIT INHIBIT-XCT-NEXT-BIT MMCALL)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-MMCALT (P-BIT INHIBIT-XCT-NEXT-BIT MC-MMCALT)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-MMCALB (P-BIT INHIBIT-XCT-NEXT-BIT MC-MMCALB)
(END-DISPATCH)

;These bind special vars
(START-DISPATCH 0 0)
D-BNDPOP (P-BIT INHIBIT-XCT-NEXT-BIT MC-BNDPOP)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-BNDNIL (P-BIT INHIBIT-XCT-NEXT-BIT MC-BNDNIL)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-DO-SPECBIND-PP-BASED (P-BIT INHIBIT-XCT-NEXT-BIT MC-DO-SPECBIND-PP-BASED)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-POP-SPECPDL (P-BIT INHIBIT-XCT-NEXT-BIT MC-POP-SPECPDL)
(END-DISPATCH)

(START-DISPATCH 0 0)
D-SETZERO (P-BIT INHIBIT-XCT-NEXT-BIT MC-SETZERO)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-SETNIL (P-BIT INHIBIT-XCT-NEXT-BIT MC-SETNIL)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-GET-LOCATIVE-TO-PDL (P-BIT INHIBIT-XCT-NEXT-BIT MC-GET-LOCATIVE-TO-PDL)
(END-DISPATCH)
(START-DISPATCH 0 0)
D-GET-LOCATIVE-TO-VC (P-BIT INHIBIT-XCT-NEXT-BIT MC-GET-LOCATIVE-TO-VC)
(END-DISPATCH)

;Hairy multiple value stuff.  not really for now.
(START-DISPATCH 0 0)			    ;*CATCH open, multiple values
D-UCTOM  (P-BIT INHIBIT-XCT-NEXT-BIT MC-UCTOM)
(END-DISPATCH)
(START-DISPATCH 0 0)			    ;Prepare to make
D-MMISU  (P-BIT INHIBIT-XCT-NEXT-BIT MC-MMISU)  ; MICRO-MICRO call receiving N values
(END-DISPATCH)
(START-DISPATCH 0 0)
D-MURV	 (P-BIT INHIBIT-XCT-NEXT-BIT MC-MURV)   ;RETURN-NEXT-VALUE
(END-DISPATCH)
(START-DISPATCH 0 0)
D-MRNV   (INHIBIT-XCT-NEXT-BIT MC-MRNV)	    ;Return N values, number in M-E. Note jump.
(END-DISPATCH)
(START-DISPATCH 0 0)
D-MR2V	 (INHIBIT-XCT-NEXT-BIT MC-MR2V)	    ;Return 2 values.  Note jump.
(END-DISPATCH)
(START-DISPATCH 0 0)
D-MR3V	 (INHIBIT-XCT-NEXT-BIT MC-MR3V)	    ;Return 3 values.  Note jump.
(END-DISPATCH)

;Used to effect returns!
(START-DISPATCH 0 0)
D-SUB-PP (INHIBIT-XCT-NEXT-BIT MC-SUB-PP)	    ;Note jump.
(END-DISPATCH)
(START-DISPATCH 0 0)
D-POP-SPECPDL-AND-SUB-PP (INHIBIT-XCT-NEXT-BIT MC-POP-SPECPDL-AND-SUB-PP) ;Note jump.
(END-DISPATCH)

;;; INITIALIZATION

(LOCALITY I-MEM)

ZERO	(JUMP ZERO HALT-CONS)		;WILD TRANSFER TO ZERO

;This is location 1.  Enter here if virtual memory is valid.
BEG	((M-ZERO) SETZ)				;DON'T GET SCREWED BY CLOBBERED LOC 2@A
	(JUMP BEG0000)

;Enter here from the PROM.  Virtual memory is not valid yet.
(LOC 6)
PROM	(JUMP-NOT-EQUAL-XCT-NEXT Q-R A-ZERO PROM)    ;These 2 instructions duplicate the prom
       ((Q-R) ADD Q-R A-MINUS-ONE)
;;; Decide whether to restore virtual memory from saved band on disk, i.e.
;;; whether this is a cold boot or a warm boot.  If the keyboard has input
;;; available, and the character was RETURN (rather than RUBOUT), it's a warm boot.
	(CALL-XCT-NEXT PHYS-MEM-READ)
       ((VMA) (A-CONSTANT 17772045))		;Unibus address 764112 (KBD CSR)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 5) MD	;If keyboard is not ready,
		COLD-BOOT)			; assume we are supposed to cold-boot
	(CALL-XCT-NEXT PHYS-MEM-READ)
       ((VMA) (A-CONSTANT 17772040))		;Unibus address 764100 (KBD LOW)
	((MD) (BYTE-FIELD 6 0) MD)		;Get keycode
	(JUMP-EQUAL MD (A-CONSTANT 46) COLD-BOOT)	;This is cold-boot if key is RUBOUT
	((MD) (A-CONSTANT 46))			;Standardize mode.  Mostly, set to NORMAL speed
	(CALL-XCT-NEXT PHYS-MEM-WRITE)		;40 is PROM-DISABLE, 2 is NORMAL speed.
       ((VMA) (A-CONSTANT 17773005))		;Unibus 766012
		;drops into BEG0000
BEG0000	((M-FLAGS) (A-CONSTANT (PLUS		;RE-INITIALIZE ALL FLAGS
		(BYTE-VALUE Q-DATA-TYPE DTP-FIX)
		(BYTE-VALUE M-CAR-SYM-MODE 1)
		(BYTE-VALUE M-CAR-NUM-MODE 0)
		(BYTE-VALUE M-CDR-SYM-MODE 1)
		(BYTE-VALUE M-CDR-NUM-MODE 0)
		(BYTE-VALUE M-DONT-SWAP-IN 0)
		(BYTE-VALUE M-TRAP-ENABLE 0)	;MACROCODE WILL TURN ON TRAPS WHEN READY
		(BYTE-VALUE M-MAR-MODE 0)
		(BYTE-VALUE M-PGF-WRITE 0)
		(BYTE-VALUE M-INTERRUPT-FLAG 0)
		(BYTE-VALUE M-SCAVENGE-FLAG 0)
		(BYTE-VALUE M-TRANSPORT-FLAG 0)
		(BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0)
		(BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)
		(BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0))))
	((M-SB-SOURCE-ENABLE) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((A-TV-CURRENT-SHEET) A-V-NIL)		;Forget this cache
	((A-LEXICAL-ENVIRONMENT) A-V-NIL)	;At top level wrt lexical bindings.
	((A-AMEM-EVCP-VECTOR) A-V-NIL)		;Don't write all over memory
	((A-MOUSE-CURSOR-STATE) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;Mouse off
	((A-SCAV-COUNT) SETZ)			;Forget scavenger state
;This seems like an unnecessary waste of time:
;	((A-DISK-SWITCHES) DPB (M-CONSTANT -1)	;Read-compare writes, not reads
;		(BYTE-FIELD 1 1) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((A-INHIBIT-SCHEDULING-FLAG) A-V-TRUE)	;DISABLE SEQUENCE BREAKS
	((A-INHIBIT-SCAVENGING-FLAG) A-V-TRUE)	;GARBAGE COLLECTOR NOT TURNED ON UNTIL LATER
	((A-LCONS-CACHE-AREA) SETZ)		;Forget these caches (disk-restore...)
	((A-SCONS-CACHE-AREA) SETZ)
	((A-PAGE-TRACE-PTR) SETZ)		;SHUT OFF PAGE-TRACE
	((A-METER-GLOBAL-ENABLE) A-V-NIL)	;Turn off metering
	((A-METER-DISK-COUNT) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL RESET-MACHINE)			;Reset and turn on interrupts, set up map
	((VMA-START-READ) (A-CONSTANT 1031))	;FETCH MISCELLANEOUS SCRATCHPAD LOCS
	(ILLOP-IF-PAGE-FAULT)
	((A-AMCENT) Q-TYPED-POINTER READ-MEMORY-DATA)
	((VMA-START-READ) (A-CONSTANT 1021))
	(ILLOP-IF-PAGE-FAULT)
	((A-CNSADF) Q-TYPED-POINTER READ-MEMORY-DATA)
	((A-BACKGROUND-CONS-AREA) A-CNSADF)
	((A-NUM-CNSADF) Q-TYPED-POINTER READ-MEMORY-DATA)  ;DONT REALLY HACK EXTRA-PDL
							  ; INITIALLY.
	(CALL GET-AREA-ORIGINS)
	((M-K) SUB M-ZERO (A-CONSTANT 200))	;FIRST 200 MICRO ENTRIES ARE NOT IN TABLE
	((A-V-MISC-BASE) ADD M-K A-V-MICRO-CODE-SYMBOL-AREA)
	;; If using Marksman disk, must recalibrate after I/O reset
	(CALL DISK-RECALIBRATE)
	;; Find out where to page off of if we don't know already 
	(CALL-EQUAL A-DISK-OFFSET M-ZERO WARM-READ-LABEL)
	;; Clear the unused pages of the PHT and PPD out of the map
	((MD) DPB (M-CONSTANT -1) (BYTE-FIELD 8 0) A-V-PHYSICAL-PAGE-DATA-END)
	((MD) ADD MD (A-CONSTANT 1))		;First page above PPD
	(JUMP-GREATER-OR-EQUAL MD A-V-REGION-ORIGIN BEGCM2)
BEGCM1	((VMA-WRITE-MAP) (A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))
	(JUMP-LESS-THAN MD A-V-REGION-ORIGIN BEGCM1)
BEGCM2	((MD) A-V-PAGE-TABLE-AREA)
	((MD) ADD MD A-PHT-INDEX-LIMIT)
	(JUMP-GREATER-OR-EQUAL MD A-V-PHYSICAL-PAGE-DATA BEGCM4)
BEGCM3	((VMA-WRITE-MAP) (A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))
	(JUMP-LESS-THAN MD A-V-PHYSICAL-PAGE-DATA BEGCM3)
BEGCM4	;; Get A-INITIAL-FEF, A-QTRSTKG, A-QCSTKG, A-QISTKG
	((VMA) (BYTE-FIELD 9 0) (M-CONSTANT -1)) ;777 ;SCRATCH-PAD-INIT-AREA MINUS ONE
	((M-K) (A-CONSTANT (A-MEM-LOC A-SCRATCH-PAD-BEG))) ;FIRST A MEM LOC TO BLT INTO
BEG03	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((OA-REG-LOW) DPB M-K OAL-A-DEST A-ZERO)	;DESTINATION
	((A-GARBAGE) READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL-XCT-NEXT M-K (A-CONSTANT (A-MEM-LOC A-SCRATCH-PAD-END)) BEG03)
       ((M-K) ADD M-K (A-CONSTANT 1))
	((VMA-START-READ) A-INITIAL-FEF)	;INDIRECT
	(CHECK-PAGE-READ)
	;; Don't let garbage pointer leak through DISK-RESTORE
	;; There are a lot of these, we only get the ones that are known to cause trouble
	;; There are also the "method subroutine" and "sg calling args" guys
	((A-SELF) A-V-NIL)
	((A-SG-PREVIOUS-STACK-GROUP) A-V-NIL)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((A-INITIAL-FEF) READ-MEMORY-DATA)

	(CALL-XCT-NEXT SG-LOAD-STATIC-STATE)	;INITIALIZE PDL LIMITS ETC
       ((A-QCSTKG) A-QISTKG)			;FROM INITIAL STACK-GROUP
	((A-QLBNDP) ADD (M-CONSTANT -1) A-QLBNDO) ;INITIALIZE BINDING PDL POINTER
			; POINTS AT VALID LOCATION, OF WHICH THERE ARENT ANY YET.
	((A-PDL-BUFFER-HEAD) A-ZERO)
	((A-PDL-BUFFER-VIRTUAL-ADDRESS) A-QLPDLO)
	((PDL-BUFFER-POINTER) A-PDL-BUFFER-HEAD)
	((A-PDL-BUFFER-HIGH-WARNING) (A-CONSTANT PDL-BUFFER-HIGH-LIMIT))  ;INITAL STACK
					;HAD BETTER AT LEAST BIG ENUF FOR P.B.
	((C-PDL-BUFFER-POINTER) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;THIS GOES
					;INTO 0@P
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-A C-PDL-BUFFER-POINTER-PUSH) A-INITIAL-FEF)
	((M-K) Q-DATA-TYPE M-A)
	(CALL-NOT-EQUAL M-K (A-CONSTANT (EVAL DTP-FEF-POINTER)) ILLOP)
	((M-AP) PDL-BUFFER-POINTER)
	((M-PDL-BUFFER-ACTIVE-QS) (A-CONSTANT 4))
	((VMA-START-READ) M-A)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-J) (LISP-BYTE %%FEFH-PC) READ-MEMORY-DATA)
BEG06	(CALL-NOT-EQUAL MICRO-STACK-PNTR-AND-DATA 	;CLEAR THE MICRO STACK PNTR (TO -1)
			(A-CONSTANT (PLUS 37_24. 1 (I-MEM-LOC BEG06))) BEG06)
	((MICRO-STACK-DATA-PUSH) A-MAIN-DISPATCH)	;PUSH MAGIC RETURN
	((MD) (A-CONSTANT 6000))		;Enable Unibus interrupts
	((VMA-START-WRITE) (A-CONSTANT 77773020))  ;Unibus address 766040
	(CHECK-PAGE-WRITE)
	(JUMP-XCT-NEXT QLENX)			;CALL INITIAL FUNCTION, NEVER RETURNS
       ((M-ERROR-SUBSTATUS) M-ZERO)

GET-AREA-ORIGINS
	((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-AREA-ORIGIN-PNTR))))
	(ILLOP-IF-PAGE-FAULT)
	((VMA) SUB READ-MEMORY-DATA (A-CONSTANT 1)) ;1- ADDR OF REGION-ORIGIN TABLE
	((M-K) (A-CONSTANT (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA)))
BEG02	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((OA-REG-LOW) DPB M-K OAL-A-DEST A-ZERO)	;DESTINATION
	((A-GARBAGE) Q-POINTER READ-MEMORY-DATA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-K) ADD M-K (A-CONSTANT 1))
	(JUMP-NOT-EQUAL M-K (A-CONSTANT (A-MEM-LOC A-V-FIRST-UNFIXED-AREA)) BEG02)
	;; Now find the end of the last fixed area, which is where we can start making regions
	;; Too bad the cold-load generator didn't store this anywhere for us
	((M-K) M-A-1 M-K (A-CONSTANT (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA)))
	((VMA-START-READ) ADD M-K A-V-REGION-LENGTH)
	(ILLOP-IF-PAGE-FAULT)
	((M-K) ADD READ-MEMORY-DATA A-V-INIT-LIST-AREA)	;...the last fixed area
	;; Round up to next multiple of a quantum
	(POPJ-AFTER-NEXT (M-K) ADD M-K (A-CONSTANT (EVAL (1- %ADDRESS-SPACE-QUANTUM-SIZE))))
       ((A-V-FIRST-UNFIXED-AREA) SELECTIVE-DEPOSIT M-K
		VMA-QUANTUM-BYTE (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;;; MAIN INSTRUCTION EXECUTING LOOP

;NOTE: QMLP MUST BE AT LOC WITH BIT 1=0.  QMLP AND QMLP+1 ARE SKIPPED BY STREAM HARDWARE
; AUTOMATICALLY IF NO FETCH REQUIRED.
(MODULO 4) ;THIS CONSTRAINT IS A LITTLE MORE SEVERE THAN REALLY NECESSARY
QMLP	(CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK QMLP-P-OR-I-OR-SB)
	((M-INST-BUFFER) READ-MEMORY-DATA)
	(DISPATCH-XCT-NEXT M-INST-OP OPDTB)
   (ERROR-TABLE ILLEGAL-INSTRUCTION)
      ((MICRO-STACK-DATA-PUSH) A-MAIN-DISPATCH)	;PUT BACK RETURN FOR NEXT TIME

QMLP-P-OR-I-OR-SB
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 26.) LOCATION-COUNTER PGF-R-I)    ;Jump on no SB
;Prepare to take SB, make sure VMA doesnt point to untyped storage.
	((VMA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;Funnyness with 0@U.  0@U is not saved as part of the SG.  Instead, it is physically
;replaced with the appropriate main loop return when the SG is resumed.
;Our return is currently in 0@U, so would go away if this happened.  So we
;bugger things so the standard thing is in 0@U, which requires decrementing the PC.
	((M-GARBAGE) MICRO-STACK-DATA-POP)
	((LOCATION-COUNTER) SUB LOCATION-COUNTER (A-CONSTANT 2))
	(JUMP-XCT-NEXT SBSER)
       ((MICRO-STACK-DATA-PUSH) A-MAIN-DISPATCH)

(MODULO 4)
DMLP	(CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK DMLP-P-OR-I-OR-SB)
        ((M-INST-BUFFER) READ-MEMORY-DATA)
        ((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-TRAP-AP-LEVEL)
        (JUMP-EQUAL M-1 A-ZERO DMLP-1)	;DONT CHACK M-AP LEVEL
        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) PDL-BUFFER-POINTER)
        (JUMP-LESS-OR-EQUAL M-K A-TRAP-AP-LEVEL STEP-BREAK-1)
DMLP-1	(DISPATCH-XCT-NEXT M-INST-OP OPDTB)
       ((MICRO-STACK-DATA-PUSH) A-DEBUG-DISPATCH)

DMLP-P-OR-I-OR-SB
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 26.) LOCATION-COUNTER PGF-R-I)    ;Jump on no SB
;Prepare to take SB, make sure VMA doesnt point to untyped storage.
	((VMA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;Funnyness with 0@U.  0@U is not saved as part of the SG.  Instead, it is physically
;replaced with the appropriate main loop return when the SG is resumed.
;Our return is currently in 0@U, so would go away if this happened.  So we
;bugger things so the standard thing is in 0@U, which requires decrementing the PC.
	((M-GARBAGE) MICRO-STACK-DATA-POP)
	((LOCATION-COUNTER) SUB LOCATION-COUNTER (A-CONSTANT 2))
	(JUMP-XCT-NEXT SBSER)
       ((MICRO-STACK-DATA-PUSH) A-DEBUG-DISPATCH)

(MODULO 4)
SINGLE-STEP
	(CHECK-PAGE-READ)
        ((M-INST-BUFFER) READ-MEMORY-DATA)
	((M-1) (A-CONSTANT (EVAL SG-SINGLE-STEP-TRAP)))	;CHANGE STACK-GROUP-STATE
	((A-SG-STATE) DPB M-1 (LISP-BYTE %%SG-ST-INST-DISP) A-SG-STATE) ;TO SINGLE-STEP TRAP
        (DISPATCH-XCT-NEXT M-INST-OP OPDTB)
       ((MICRO-STACK-DATA-PUSH) A-SINGLE-STEP-TRAP)	;RETURN TO STEP-BREAK

;;; WE HAVE TO WASTE THESE INSTRUCTIONS, BECAUSE WE WANT THE MACRO PC TO BE
;;; INCREMENTED, AND IT MIGHT SKIP THE FIRST 2 INSTRUCTIONS IF IT DOESN'T DO
;;; A MEMORY CYCLE (WHICH WE DONT ACTUALLY CARE ABOUT)
(MODULO 4)
STEP-BREAK
	(CHECK-PAGE-READ)
        ((M-INST-BUFFER) READ-MEMORY-DATA)
STEP-BREAK-1
	((LOCATION-COUNTER) SUB LOCATION-COUNTER (A-CONSTANT 2)) ;instr not done yet
	((MICRO-STACK-DATA-PUSH) A-SINGLE-STEP-TRAP)        ;Mustn't have empty pdl!
	(CALL TRAP)
     (ERROR-TABLE STEP-BREAK)


INSTRUCTION-STREAM-FETCHER   ;DO FETCHES ASSOCIATED WITH MULTI-UNIT INSTUCTIONS.
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT NO-OP)
       ((M-INST-BUFFER) READ-MEMORY-DATA)

;;; THIS IS THE MISC ENTRY SMASHED IN FOR BREAKPOINTS IN FEF'S
BREAKPOINT (MISC-INST-ENTRY BPT)
	(CALL TRAP)
     (ERROR-TABLE BREAKPOINT)


;;; EFFECTIVE ADDRESS COMPUTATION ROUTINES.
;   THESE ARE ENTERED FROM QADCM1, THEY PUT THE OPERAND INTO M-T AND POPJ.
; Q-ALL-BUT-TYPED-POINTER bits should be zero.

QAFE	((M-1) M-INST-ADR)			;FULL DELTA
QAFE1	((PDL-BUFFER-INDEX) M-AP)		;0(AP) -> FEF
	((VMA-START-READ) ADD C-PDL-BUFFER-INDEX A-1)
QADR4	(CHECK-PAGE-READ)			;NOTE THAT DATA-TYPE OF VMA DOESN'T MATTER
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA) ;FOLLOW ALL INVZ
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)	;RETURN C(E) IN M-T

;GET EFFECTIVE ADDRESS, NOT PLANNING TO READ CONTENTS.  POPJ WITH EFF ADR ON PDL
;MUSTN'T TRANSPORT, NOR BARF AT TRAP, BUT MUST FOLLOW EXTERNAL VALUE CELL POINTER
QEAFE	((M-1) M-INST-ADR)			;FULL DELTA
	((PDL-BUFFER-INDEX) M-AP)		;0(AP) -> FEF
	((VMA-START-READ) ADD C-PDL-BUFFER-INDEX A-1)
	(CHECK-PAGE-READ)  
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA) ;FOLLOW ALL INVZ
       ((C-PDL-BUFFER-POINTER-PUSH) DPB VMA	;PUSH VMA AS A LOCATIVE
		Q-POINTER (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)
					    (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))

;REF LOCAL BLOCK.  CANNOT BE INVISIBLE POINTER.
;IF THIS IS EVER CHANGED TO ALLOW INVISIBLE POINTERS, GOT TO FOOL AROUND
;WITH THE QADCM3 DISPATCH AND THE THINGS THAT USE IT, AND DECIDE WHICH
;FLAVORS OF INVISIBILITY DO WHAT WITH RESPECT TO VALUE-CELL-LOCATION.
QADLOC	((M-1) M-INST-DELTA)
QADLOC1	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-INDEX) ADD M-1 A-LOCALP)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)

;REF ARGUMENT BLOCK.  CANNOT BE INVISIBLE POINTER.
QADARG	((M-1) M-INST-DELTA)
QADARG1	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-INDEX) ADD M-AP A-1 ALU-CARRY-IN-ONE) ;%LP-INITIAL-LOCAL-BLOCK-OFFSET=1
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)

;REF CONSTANTS PAGE.
QAQT	((M-1) M-INST-DELTA)
QAQT1	(JUMP-XCT-NEXT QADR4)
       ((VMA-START-READ) ADD M-1 A-V-CONSTANTS-AREA)

;REF PDL.  CANNOT BE INVISIBLE POINTER.
;WE ONLY SUPPORT (SP)+ TYPE PDL ADDRESSING (PDL 77) 
QADPDL	((M-1) M-INST-DELTA)
QADPDL1	(POPJ-AFTER-NEXT
	 (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
       (CALL-NOT-EQUAL M-1 (A-CONSTANT 77) QADPDLT)	;UNSUPPORTED ADDRESS TYPE

QADPDLT (CALL TRAP)
   (ERROR-TABLE ILLEGAL-INSTRUCTION)		;NOTE THAT PDL HAS BEEN POPPED

;;; STORE CYCLE
;   VALUE IN M-T.  A READ-TYPE EFF ADDR COMPUTATION MAY OR MAY NOT
;   HAVE TAKEN PLACE ALREADY.
;   EXITS VIA POPJ BACK TO MAIN LOOP.

QIPOP	((M-T) C-PDL-BUFFER-POINTER-POP)	;POP INST, CODE BELOW DUPLICATES STOCYC
	(DISPATCH-XCT-NEXT M-INST-REGISTER QADCM2)	;DISPATCH ON ADDRESS TYPE
       ((M-1) M-INST-DELTA)				;WITH DELTA IN M-1

QIMVM	((M-T) C-PDL-BUFFER-POINTER)			;MOVEM INSTRUCTION
STOCYC	(DISPATCH-XCT-NEXT M-INST-REGISTER QADCM2)	;DISPATCH ON ADDRESS TYPE
       ((M-1) M-INST-DELTA)				;WITH DELTA IN M-1

;STOCYC ENDS UP HERE IF USING FEF ADDRESSING.
;STORE IN FEF, NO READ CYCLE TOOK PLACE, SO MUST COMPUTE VMA AND CHECK FOR INVZ
QSTFE	((M-1) M-INST-ADR)				;FULL DELTA
QSTFE1	((PDL-BUFFER-INDEX) M-AP)			;0(AP) -> FEF
	((VMA-START-READ) ADD C-PDL-BUFFER-INDEX A-1)
	(CHECK-PAGE-READ)  
XSET2							;Entry from SET
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)	;FOLLOW ALL INVZ
		;FOLLOWING INSTRUCTION MUSTN'T POPJ-AFTER-NEXT BECAUSE
		;CANNOT START WRITE AND INSTRUCTION FETCH SIMULTANEOUSLY
	(JUMP-IF-BIT-SET Q-FLAG-BIT MD QSTFE-MONITOR)
QSTFE-M	((MD-START-WRITE) SELECTIVE-DEPOSIT
		MD Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

;Get here if FLAG-BIT set in a cell about to be written.  Find monitor function
; following the cell, and call it with args  <old-value>, <new-value>.
QSTFE-MONITOR
	(CALL-XCT-NEXT QSTFE-M)		;Complete store
       ((M-A) Q-TYPED-POINTER MD)	;Save copy of old value
	(POPJ-EQUAL M-A A-T)		;Same thing, thats all.
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;Save copy of new to return
	(CALL P3ZERO)
	((VMA-START-READ) M+1 VMA)
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) MD)
	((C-PDL-BUFFER-POINTER-PUSH) M-A)	;OLD VALUE
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;NEW VALUE
	((ARG-JUMP MMCALL) (I-ARG 2))
	(POPJ-AFTER-NEXT
	  (M-T) C-PDL-BUFFER-POINTER-POP)
       (NO-OP)

;STORE IN LOCAL BLOCK
QSTLOC	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-INDEX) ADD M-1 A-LOCALP)
       ((C-PDL-BUFFER-INDEX) M-T)

;STORE IN ARGUMENT BLOCK
QSTARG	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-INDEX) ADD M-AP A-1 ALU-CARRY-IN-ONE)
       ((C-PDL-BUFFER-INDEX) M-T)

;PUSH LOCATIVE POINTER TO ADDRESS OF LOCAL VARIABLE ONTO THE PDL
QVMALCL (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) ADD M-1 A-LOCALP)
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-POINTER-PUSH) DPB M-K Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
       (NO-OP)		;NO PASS-AROUND PATH ON PDL-BUFFER

;PUSH LOCATIVE POINTER TO ADDRESS OF ARGUMENT VARIABLE ONTO THE PDL
QVMAARG (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) ADD M-AP A-1 ALU-CARRY-IN-ONE)
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-POINTER-PUSH) DPB M-K Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
       (NO-OP)		;NO PASS-AROUND PATH ON PDL-BUFFER

;Get and set lexical variables inherited from outer contexts.
XLOAD-FROM-HIGHER-CONTEXT
	(MISC-INST-ENTRY %LOAD-FROM-HIGHER-CONTEXT)
	(CALL XLOCATE-IN-HIGHER-CONTEXT)
	(JUMP QCAR)

XSTORE-IN-HIGHER-CONTEXT
	(MISC-INST-ENTRY %STORE-IN-HIGHER-CONTEXT)
	(CALL XLOCATE-IN-HIGHER-CONTEXT)
	((M-S) M-T)
	(JUMP-XCT-NEXT QRAR1)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

XLOCATE-IN-HIGHER-CONTEXT
	(MISC-INST-ENTRY %LOCATE-IN-HIGHER-CONTEXT)
;Compute in M-T the address of a local or arg in a higher lexical context.
;Pops a word off the stack to specify where to find the local:
;  Sign bit	  0 => arg, 1 => local.
;  Next 11. bits  Number of contexts to go up (0 => immediate higher context)
;  Low 12. bits	  Number of arg or local in that context.
	((M-A) C-PDL-BUFFER-POINTER-POP)
	((M-B) (BYTE-FIELD 11. 12.) M-A)
	((M-T) A-LEXICAL-ENVIRONMENT)
XLOCATE-IN-HIGHER-CONTEXT-1
	(JUMP-EQUAL M-B A-ZERO XLOCATE-IN-HIGHER-CONTEXT-3)
	(CALL QCDR)
	(JUMP-XCT-NEXT XLOCATE-IN-HIGHER-CONTEXT-1)
       ((M-B) SUB M-B (A-CONSTANT 1))

XLOCATE-IN-HIGHER-CONTEXT-3
	(CALL QCAR)
	(CALL-EQUAL M-T A-V-NIL TRAP)
    (ERROR-TABLE ILLEGAL-INSTRUCTION)
	(JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-A XLOCATE-IN-HIGHER-CONTEXT-2)
	((VMA-START-READ) ADD M-T (EVAL %LP-ENTRY-STATE))
	(CHECK-PAGE-READ)
	((M-B) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) MD)
	((M-T) ADD M-B A-T)
	((M-T) SUB M-T (A-CONSTANT 1))
XLOCATE-IN-HIGHER-CONTEXT-2
	((M-B) (BYTE-FIELD 12. 0) M-A)
	(POPJ-AFTER-NEXT
	 (M-T) ADD M-B A-T ALU-CARRY-IN-ONE)
	((M-T) DPB M-T Q-POINTER
	       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

;;; VARIOUS TRAPS

;PUSHJ HERE FOR FATAL ERRORS, E.G. THINGS THAT CAN'T HAPPEN.
;ALSO FOR THINGS WHICH DON'T HAVE ERROR-TABLE ENTRIES YET.
  (MICRO-CODE-ILLEGAL-ENTRY-HERE)	;FILL IN UNUSED ENTRIES IN 
					; MICRO-CODE-SYMBOL-AREA
ILLOP	(POPJ HALT-CONS)		;Halt with place called from in lights

;PUSHJ HERE FOR ERRORS WHICH CAN TRAP TO MACROCODE.
;ON THE CONS MACHINE THIS USED THE OPCS, BUT WE HAVE REPUDIATED THAT PRACTICE.
;THEREFORE THIS CAN'T BE CALLED FROM THE INSTRUCTION AFTER A POPJ-AFTER-NEXT,
;AND SHOULDN'T BE CALLED FROM A CALL-XCT-NEXT UNLESS YOU MOVE THE ERROR-TABLE
;ENTRY DOWN.
TRAP	(JUMP-IF-BIT-CLEAR M-TRAP-ENABLE ILLOP)	;TURN INTO ILLOP UNLESS TRAPS ENABLED
	((M-TEM) M-FLAGS-NO-SEQUENCE-BREAK)	;TURN INTO ILLOP IF TRAP AT BAD TIME
	(JUMP-NOT-EQUAL M-TEM A-ZERO ILLOP)	;NOTE WOULD PROBABLY DIE LATER ANYWAY
	((M-TEM) A-SG-STATE)			;RECURSIVE TRAP?
	(CALL-IF-BIT-SET (LISP-BYTE %%SG-ST-PROCESSING-ERROR) M-TEM ILLOP)	;IF SO, HALT
	((A-SG-STATE) DPB (M-CONSTANT -1) (LISP-BYTE %%SG-ST-PROCESSING-ERROR) A-TEM)
	((M-TEM) MICRO-STACK-DATA-POP		;INVOLVES A LDB
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((A-TRAP-MICRO-PC) SUB M-TEM (A-CONSTANT 1))	;PRESUMED ADDRESS OF CALL
	((A-TEM3) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-QTRSTKG)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-QCSTKG)
	(CALL-EQUAL M-TEM A-TEM3 ILLOP)		;RECURSIVE ERRORS
	((A-QLBNDH) A-QLBNDRH)			;ENSURE NO SPECIAL PDL OVERFLOW STORING STATUS
						;REGULAR PDL IS PREWITHDRAWN, CAN'T OVERFLOW
	(CALL-XCT-NEXT SGLV)			;STORE CURRENT STATUS
       ((M-TEM) (A-CONSTANT (EVAL SG-STATE-AWAITING-ERROR-RECOVERY))) ;AND SWAP SPECIAL-PDL
	((A-SG-TEM) A-V-NIL)	;Transmit NIL (do not change, EH knows about this.)
	(JUMP-XCT-NEXT SG-ENTER)			;"CALL" TRAP HANDLER STACK GROUP
       ((M-A) A-QTRSTKG)

;PUSHJ HERE ON ACTIVATE INVOKE.  OPERATION TYPE FROM I-ARG.
;INVOKE-ACTIVATE
;	(CALL-XCT-NEXT TRAP)	;NO HANDLER YET
;      ((C-PDL-BUFFER-POINTER-PUSH) DPB READ-I-ARG Q-POINTER	;SAVE OP-CODE
;		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;      (ERROR-TABLE INVOKE)

;;; BASIC INSTRUCTIONS
;   OPERAND IS NOT FETCHED YET, SO FETCH IT INTO M-T, THEN
;   PRODUCE RESULT IN M-T, AND DISPATCH ON DESTINATION FIELD

QICDDR	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)		;FETCH C(E)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCDR)))	;CALL QCDR BEFORE RETURNING
	(JUMP-XCT-NEXT QIMOVE1)
       (CALL QCDR)

QICDR	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)		;FETCH C(E)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCDR)))	;CALL QCDR BEFORE RETURNING
	(DISPATCH M-INST-DEST QMDTBD)		;MAY EXECUTE NEXT INSTUCTION
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

QICADR	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)		;FETCH C(E)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCDR)))	;CALL QCDR BEFORE RETURNING
	(JUMP-XCT-NEXT QIMOVE1)
       (CALL QCAR)

QICAR	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)		;FETCH C(E)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCAR)))	;CALL QCAR BEFORE RETURNING
	(DISPATCH M-INST-DEST QMDTBD)		;MAY EXECUTE NEXT INSTUCTION
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

QICAAR	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)		;FETCH C(E)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCAR)))	;CALL QCAR BEFORE RETURNING
	(JUMP-XCT-NEXT QIMOVE1)
       (CALL QCAR)

QICDAR	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)		;FETCH C(E)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCAR)))	;CALL QCAR BEFORE RETURNING
	(JUMP-XCT-NEXT QIMOVE1)
       (CALL QCDR)

QIMOVE	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM4)
       ((M-1) M-INST-DELTA)
QIMOVE1	(DISPATCH M-INST-DEST QMDTBD)		;MAY EXECUTE NEXT INSTUCTION
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

;ALL OF THESE WANT OPERAND FETCHED.
QIND1	(DISPATCH-XCT-NEXT M-INST-DEST D-ND1)
       (DISPATCH-CALL M-INST-REGISTER QADCM5)

;ALL OF THESE WANT OPERAND FETCHED.
QIND2	(DISPATCH-XCT-NEXT M-INST-DEST D-ND2)
       (DISPATCH-CALL M-INST-REGISTER QADCM5)

;THESE DON'T WANT THEIR OPERAND FETCHED.
QIND3	(DISPATCH M-INST-DEST D-ND3)

;CALL WITH NO ARGS
QICAL0	(DISPATCH-CALL M-INST-REGISTER QADCM5)		;FETCH C(E)
	(JUMP-XCT-NEXT QMRCL)				;ACTIVATE, BUT FIRST
       (CALL CBM)					;OPEN CALL BLOCK

;CALL WITH ARGS.  JUST OPEN A CALL BLOCK.
QICALL	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM1)	;FETCH C(E)
CBM    ((M-C) M-INST-DEST)		;EVENTUAL DESTINATION
CBM0					;%OPEN-CALL-BLOCK etc. call in here
	((M-ZR) ADD PDL-BUFFER-POINTER	;Open macro-to-macro call block
		 (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH)))
	((M-TEM) SUB M-ZR A-IPMARK)	;Compute delta to prev open block
	((A-TEM1) DPB M-TEM (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-TEM) SUB M-ZR A-AP)		;Compute delta to prev active block
	((A-TEM1) DPB M-TEM (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) A-TEM1)
	((C-PDL-BUFFER-POINTER-PUSH)	;Push LPCLS Q
	    DPB M-C (LISP-BYTE %%LP-CLS-DESTINATION) A-TEM1)
;QBNEAF QBALM WOULD GO HERE IF EVER REVIVED
	((C-PDL-BUFFER-POINTER-PUSH)	;Push LPEXS Q
	    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-POINTER-PUSH)	;Push LPENS Q
	    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-AFTER-NEXT		;Push LPFEF Q
	  (C-PDL-BUFFER-POINTER-PUSH) M-T)
       ((A-IPMARK) (BYTE-FIELD 10. 0) M-ZR)	;A-IPMARK -> new open block

;;; Push a micro-to-macro call block (just the first 3 words, not the function)
;;; in the case where ADI has been pushed
P3ADI	(JUMP-XCT-NEXT P3ZER1)
       ((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (PLUS 
		(BYTE-VALUE Q-DATA-TYPE DTP-FIX)
		(BYTE-VALUE %%LP-CLS-ADI-PRESENT 1))))

;;; Push a micro-to-macro call block (just the first 3 words, not the function)
P3ZERO	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT 
		(BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
P3ZER1	((M-ZR) ADD PDL-BUFFER-POINTER	;1- because of push just done
		 (A-CONSTANT (EVAL (1- %LP-CALL-BLOCK-LENGTH))))
	((M-TEM) SUB M-ZR A-IPMARK)
	((A-TEM1) DPB M-TEM (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK)
		(A-CONSTANT (BYTE-VALUE %%LP-CLS-DESTINATION D-MICRO)))
	((M-TEM) SUB M-ZR A-AP)
	((A-TEM1) DPB M-TEM (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) A-TEM1)
	((C-PDL-BUFFER-POINTER)		;IOR with LPCLS Q already pushed
		IOR C-PDL-BUFFER-POINTER A-TEM1)
	((C-PDL-BUFFER-POINTER-PUSH)	;Push LPEXS Q
	    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-AFTER-NEXT		;Push LPENS Q
	  (C-PDL-BUFFER-POINTER-PUSH)
	    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((A-IPMARK) (BYTE-FIELD 10. 0) M-ZR)	;Caller must push LPFEF Q

;;; MISC INSTRUCTION
;;; Note that the misc function invoked might do a micro-to-macro call,
;;; upon return M-INST-BUFFER would not be set up.  Therefore we must not
;;; depend on it.  The MISC instruction works by doing something similar
;;; to a micro-to-micro call to the misc function, with a return address
;;; dependent on the destination; in the case of D-IGNORE there is no
;;; return address, it returns directly to the main instruction loop.
;;; This means that any misc instruction which can be called to D-IGNORE
;;; must not start a memory cycle in the same instruction that popjs.
;;; MISC insts must return their value in M-T, with 0 in Q-ALL-BUT-TYPED-POINTER.
MISC	((M-B) M-INST-ADR)	;GET LOW 9 BITS OF INST
	(JUMP-LESS-THAN	M-B (A-CONSTANT 200) QMSCO1)	;LIST GROUPS
	((VMA-START-READ) ADD A-V-MISC-BASE M-B)
	(CHECK-PAGE-READ)
	(DISPATCH-XCT-NEXT M-INST-DEST D-MISC-DEST)
       ((OA-REG-LOW M-LAST-MICRO-ENTRY) DPB READ-MEMORY-DATA OAL-JUMP A-ZERO)
	(JUMP 0)		;CALL EXECUTION ROUTINE

MISC-TO-STACK
	(CALL 0)		;CALL EXECUTION ROUTINE
M-T-TO-STACK
	(POPJ-AFTER-NEXT (C-PDL-BUFFER-POINTER-PUSH) Q-TYPED-POINTER M-T
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
       (NO-OP)

;LIST GROUP, ALLOCATE NUMBER OF Q'S GIVEN BY BITS 1.5-1.1 OF INSTRUCTION.
;     LISTIFY THEM, AND PUSH ON PDL THREE QS.
;	(1) POINTER TO BLOCK 
;	(2) DESTINATION FIELD OF MISC-INSTRUCTION
;	(3) ANOTHER COPY POINTER TO BLOCK.
;    THIS INTERFACES APPROPRIATELY WITH THE STORE-NEXT-LIST DESTINATION,
;	WITH THE NET EFFECT OF CREATING A N-ELEMENT LIST AND FINALLY STORING
;	A POINTER TO IT IN THE SPECIFIED DESTINATION.
;  Q'S COME FROM AREA IN A-CNSADF OR SPECIFIED AREA DEPENDING ON WHETHER 1.6 IS
;    0 OR 1 RESPECTIVELY.

QMSCO1	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 6) M-B QMSCO2)  ;JUMP ON USE DEFAULT 
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)	;AREA (IE M-B 0 - 77 )
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;LIST IN SPECD AREA
QMSCO2	(CALL-XCT-NEXT LIST-OF-NILS)		;ALLOCATE Q'S IN B IN AREA IN S, LIST SPACE
       ((M-B) (BYTE-FIELD 6 0) M-B)		;FLUSH 100 BIT
	((C-PDL-BUFFER-POINTER-PUSH M-T)	;POINTER TO ALLOCATED BLOCK
		Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	((M-C) M-INST-DEST)
	(POPJ-AFTER-NEXT 
	 (C-PDL-BUFFER-POINTER-PUSH)
	    DPB M-C Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)

;;; These are not callable with MISC instructions, only as functions.
;;; They are documented as taking an &REST argument but actually take 63 optional args.
;;; When entered, the arguments are on the stack and M-R contains the number of them.
;;; (M-AP)+1 is the first argument, (PP) is the last.
	(MISC-INST-ENTRY LIST)
XLIST	(JUMP-EQUAL M-R A-ZERO XFALSE)
	(CALL-XCT-NEXT LCONS-D)
       ((M-B) Q-POINTER M-R)
XLIST0	((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((VMA) ADD M-T A-B)
	((M-T) DPB Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
XLIST1	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	((M-B) SUB M-B (A-CONSTANT 1))
XLIST2	(POPJ-LESS-OR-EQUAL M-B A-ZERO)
	(JUMP-XCT-NEXT XLIST1)
       ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

	(MISC-INST-ENTRY LIST*)
XLISTR	(JUMP-EQUAL M-R (A-CONSTANT 1) POPTJ)
	(CALL-XCT-NEXT LCONS-D)
       ((M-B) Q-POINTER M-R)
XLISTR0	((VMA) ADD M-T A-B)
	((M-T) DPB Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR)))
	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)))
	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(JUMP-XCT-NEXT XLIST2)
       ((M-B) SUB M-B (A-CONSTANT 2))

;;; Note that these two never pop their first argument.  This doesn't matter when
;;; calling them as functions, but if you try to make a MISC-instruction interface
;;; to these you will need to be aware of that.
	(MISC-INST-ENTRY LIST-IN-AREA)
XLISTA	(JUMP-EQUAL M-R (A-CONSTANT 1) XFALSE)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1))
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	((M-B) SUB M-R (A-CONSTANT 1))
	(JUMP-XCT-NEXT XLIST0)
       (CALL LCONS)
	
	(MISC-INST-ENTRY LIST*-IN-AREA)
XLISTRA	(JUMP-EQUAL M-R (A-CONSTANT 2) POPTJ)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1))
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	((M-B) SUB M-R (A-CONSTANT 1))
	(JUMP-XCT-NEXT XLISTR0)
       (CALL LCONS)

;THESE VARIOUS CONSING ROUTINES HAD BETTER NOT CLOBBER M-C.  OTHER REGS PROBABLY OK.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS XCONS (PP 1) (PP 0))

XXCONS (MISC-INST-ENTRY XCONS)			;XCONS
	(JUMP-XCT-NEXT XXCON1)
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)	;USE DEFAULT AREA

(ERROR-TABLE DEFAULT-ARG-LOCATIONS XCONS-IN-AREA (PP 1) (PP 0) M-S)

XXCONA (MISC-INST-ENTRY XCONS-IN-AREA)		;XCONS, WITH AREA AS THIRD ARG
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XXCON1	((M-B) C-PDL-BUFFER-POINTER-POP)	;EXCH ARGS
	((M-A) C-PDL-BUFFER-POINTER-POP)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	(JUMP-XCT-NEXT QCONS)
       ((C-PDL-BUFFER-POINTER-PUSH) M-A)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS NCONS (PP 1))

XNCONS (MISC-INST-ENTRY NCONS)			;NCONS
	(JUMP-XCT-NEXT XNCON1)
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS NCONS-IN-AREA (PP 1) M-S)

XNCONA (MISC-INST-ENTRY NCONS-IN-AREA)		;NCONS, WITH AREA AS SECOND ARG
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XNCON1	(JUMP-XCT-NEXT QCONS)
       ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CONS PP PP)

XCONS (MISC-INST-ENTRY CONS)			;CONS
	((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)	;USE DEFAULT AREA
QCONS	(CALL-XCT-NEXT LCONS)			;ALLOCATE 2 Q'S, RETURN POINTER IN M-T,
       ((M-B) (A-CONSTANT 2))			;ALLOCATE FROM LIST SPACE
	((WRITE-MEMORY-DATA) DPB Q-TYPED-POINTER
		C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR)))
	((VMA-START-WRITE) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) DPB Q-TYPED-POINTER 
		C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)))
	((VMA-START-WRITE M-T) DPB M-T Q-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CONS-IN-AREA PP PP M-S)

XCONSA (MISC-INST-ENTRY CONS-IN-AREA)		;CONS, WITH AREA AS THIRD ARG
	(JUMP-XCT-NEXT QCONS)
       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)

;Assuming M-S set up with area,
;cons a single-word cell with cdr-nil,
;with contents taken from the stack.
XNCONQ	(CALL-XCT-NEXT LCONS)			;ALLOCATE 1 Q, RETURN POINTER IN M-T,
       ((M-B) (A-CONSTANT 1))			;ALLOCATE FROM LIST SPACE
	((WRITE-MEMORY-DATA) DPB Q-TYPED-POINTER 
		C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((VMA-START-WRITE M-T) DPB M-T Q-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

;;; STORAGE ALLOCATION STUFF

; CALL WITH AREA IN M-S, NUMBER OF QS DESIRED IN M-B
; NIL AND T AS AREAS WILL MEAN DEFAULT AND EXTRA-PDL, RESPECTIVELY
; OTHERWISE, M-S MUST BE A NUMBER OR A SYMBOL WHOSE VALUE IS A NUMBER.
; CALL LCONS TO ALLOCATE IN LIST SPACE, OR SCONS TO ALLOCATE IN STRUCTURE SPACE
; RETURNS RESULT IN M-T, WITH GARBAGE IN THE DATA-TYPE, YOU BETTER FIX THIS QUICK!
; THE ALLOCATED MEMORY WILL NOT BE INITIALIZED (IT WILL NORMALLY BE FILLED WITH DTP-FREE'S)
; YOU BETTER STORE HEADERS OR WHATEVER QUICK!
; SEE LIST-OF-NILS, WHICH IS LIKE LCONS BUT INITIALIZES THE STORAGE TO NIL, WITH CDR-CODES
;
; VARIOUS CALLERS REQUIRE THAT THE FOLLOWING REGISTERS BE PRESERVED:
;	M-A, M-B, M-C, M-D, M-I, M-J, M-Q, M-R, M-ZR, M-1, M-2
; THIS CAN POTENTIALLY CAUSE A STACK-GROUP SWITCH, ALSO MAY CLOBBER M-K, M-E
; WILL NOT STACK-GROUP SWITCH IF CALLED FROM THE TRANSPORTER, UNLESS TRAPPING
; FOR ILLEGAL ARGUMENT IN M-S OR M-B, WHICH WON'T HAPPEN, OR
; FOR OUT-OF-VIRTUAL-MEMORY WHICH SHOULDN'T HAPPEN AND MAY NOT WORK.

;DECODE AREA SPEC IN M-S.  RETURN FIXNUM, WITH DATA-TYPE, IN M-S.
;THIS CAN CALL TRAP OR JUMP TO IT, THUS CALLER MUST HAVE (ERROR-TABLE ARGTYP AREA M-S NIL)
;M-S MUST HAVE DATA-TYPE AND NO CDR-CODE/FLAG.
CONS-GET-AREA		(ERROR-TABLE RESTART CONS-GET-AREA)
	((M-TEM) Q-DATA-TYPE M-S)
	(CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SYMBOL)) CONS-GET-AREA-1)
	(POPJ-AFTER-NEXT DISPATCH Q-DATA-TYPE M-S TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP AREA M-S NIL CONS-GET-AREA)
       (CALL-GREATER-THAN M-S (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
						(EVAL SIZE-OF-AREA-ARRAYS)))
		TRAP)

CONS-GET-AREA-1
	((VMA-START-READ) ADD M-S (A-CONSTANT 1))	;Fetch value
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(POPJ-XCT-NEXT)
       ((M-S) Q-TYPED-POINTER READ-MEMORY-DATA)

;This entry used by number functions to cons a structure in extra-pdl 
SCONS-T	((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-NUM-CNSADF)
;This is the normal entry, area in M-S with no cdr code or flag bit
SCONS	(JUMP-NOT-EQUAL M-S A-V-NIL SCONS-N)
;This is the entry to cons in the default area
SCONS-D	((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
;At this point M-S is a fixnum, unless there is a bug or use of an obsolete feature 
SCONS-N	(CALL-LESS-OR-EQUAL M-B A-ZERO TRAP)
		(ERROR-TABLE CONS-ZERO-SIZE M-B)
	(JUMP-IF-BIT-SET M-TRANSPORT-FLAG SCONSR)	;Transporter must avoid cache
	(JUMP-NOT-EQUAL M-S A-SCONS-CACHE-AREA SCONSR)	;Jump if need full SCONS
	((M-3) ADD M-B A-SCONS-CACHE-FREE-POINTER)	;Proposed new free pointer
	(JUMP-GREATER-THAN M-3 A-SCONS-CACHE-FREE-LIMIT SCONSR)	;Jump if won't fit
	((M-T) A-SCONS-CACHE-FREE-POINTER)		;Allocate it here
	((A-SCONS-CACHE-FREE-POINTER) M-3)		;Advance free pointer
	((M-3) SUB M-3 A-SCONS-CACHE-REGION-ORIGIN)	;Exit via scavenger
	(JUMP-XCT-NEXT SCAV0)				; which will store back free pntr
       ((M-K) A-SCONS-CACHE-REGION)

SCONSR		(ERROR-TABLE RESTART SCONSR)
	(CALL CONS-GET-AREA)				;Set up M-S
    (ERROR-TABLE ARGTYP AREA M-S NIL SCONSR)
	((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST)	;Find appropriate region of the area
SCONS0	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT READ-MEMORY-DATA SCONS5)	;No region found
	((M-K) Q-POINTER READ-MEMORY-DATA)		;Get region number
SCONS2	((VMA-START-READ) ADD M-K A-V-REGION-BITS)	;Get attributes of that region
	(CHECK-PAGE-READ)
	((M-E) (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-STRUCTURE)))
	(DISPATCH (LISP-BYTE %%REGION-SPACE-TYPE) READ-MEMORY-DATA D-CONS-1)
	(DISPATCH (LISP-BYTE %%REGION-REPRESENTATION-TYPE) READ-MEMORY-DATA D-SCONS-2)
	;; Returns with M-K region, M-T allocated guy, M-3 new free pointer, M-E origin
	;; Cache this information then return via scavenger
	(JUMP-IF-BIT-SET M-TRANSPORT-FLAG SCAVT)	;Transporter must avoid cache
	((A-SCONS-CACHE-AREA) M-S)
	((A-SCONS-CACHE-REGION) M-K)
	((A-SCONS-CACHE-REGION-ORIGIN) M-E)
	((A-SCONS-CACHE-FREE-POINTER Q-R) ADD M-3 A-E)
	((M-TEM) SUB Q-R (A-CONSTANT 1))		;Location on last good page
	((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 8 0) A-TEM)	;Last loc on that page
	(JUMP-XCT-NEXT SCAV0)
       ((A-SCONS-CACHE-FREE-LIMIT) ADD M-TEM (A-CONSTANT 1))	;Page to stop before

;A copy of the above code except for List representation-type, slightly different dispatch
;This is the normal entry, area in M-S with no cdr code or flag bit
LCONS	(JUMP-NOT-EQUAL M-S A-V-NIL LCONS-N)
;This is the entry to cons in the default area
LCONS-D	((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
;At this point M-S is a fixnum, unless there is a bug or use of an obsolete feature 
LCONS-N	(CALL-LESS-OR-EQUAL M-B A-ZERO TRAP)
		(ERROR-TABLE CONS-ZERO-SIZE M-B)
	(JUMP-IF-BIT-SET M-TRANSPORT-FLAG LCONSR)	;Transporter must avoid cache
	(JUMP-NOT-EQUAL M-S A-LCONS-CACHE-AREA LCONSR)	;Jump if need full LCONS
	((M-3) ADD M-B A-LCONS-CACHE-FREE-POINTER)	;Proposed new free pointer
	(JUMP-GREATER-THAN M-3 A-LCONS-CACHE-FREE-LIMIT LCONSR)	;Jump if won't fit
	((M-T) A-LCONS-CACHE-FREE-POINTER)		;Allocate it here
	((A-LCONS-CACHE-FREE-POINTER) M-3)		;Advance free pointer
	((M-3) SUB M-3 A-LCONS-CACHE-REGION-ORIGIN)	;Exit via scavenger
	(JUMP-XCT-NEXT SCAV0)				; which will store back free pntr
       ((M-K) A-LCONS-CACHE-REGION)

LCONSR		(ERROR-TABLE RESTART LCONSR)
	(CALL CONS-GET-AREA)			;Set up M-S
    (ERROR-TABLE ARGTYP AREA M-S NIL LCONSR)
	((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST)	;Find appropriate region of the area
LCONS0	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT READ-MEMORY-DATA LCONS5)	;No region found
	((M-K) Q-POINTER READ-MEMORY-DATA)		;Get region number
LCONS2	((VMA-START-READ) ADD M-K A-V-REGION-BITS)	;Get attributes of that region
	(CHECK-PAGE-READ)
	((M-E) (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-LIST)))
	(DISPATCH (LISP-BYTE %%REGION-SPACE-TYPE) READ-MEMORY-DATA D-CONS-1)
	(DISPATCH (LISP-BYTE %%REGION-REPRESENTATION-TYPE) READ-MEMORY-DATA D-LCONS-2)
	;; Returns with M-K region, M-T allocated guy, M-3 new free pointer, M-E origin
	;; Cache this information then return via scavenger
	(JUMP-IF-BIT-SET M-TRANSPORT-FLAG SCAVT)	;Transporter must avoid cache
	((A-LCONS-CACHE-AREA) M-S)
	((A-LCONS-CACHE-REGION) M-K)
	((A-LCONS-CACHE-REGION-ORIGIN) M-E)
	((A-LCONS-CACHE-FREE-POINTER Q-R) ADD M-3 A-E)
	((M-TEM) SUB Q-R (A-CONSTANT 1))		;Location on last good page
	((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 8 0) A-TEM)	;Last loc on that page
	(JUMP-XCT-NEXT SCAV0)
       ((A-LCONS-CACHE-FREE-LIMIT) ADD M-TEM (A-CONSTANT 1))	;Page to stop before

SCONS1	(JUMP-XCT-NEXT SCONS0)			;TRY NEXT REGION
       ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)

LCONS1	(JUMP-XCT-NEXT LCONS0)			;TRY NEXT REGION
       ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)


	;This region is the right type, see if adequate free space, if so do it.
	;Called as subroutine from both SCONS and LCONS.
CONSF	((VMA-START-READ) ADD M-K A-V-REGION-LENGTH)
	(CHECK-PAGE-READ)
	((M-3) Q-POINTER READ-MEMORY-DATA)	;Length of region
	((VMA-START-READ) ADD M-K A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-READ)
	((M-T) Q-POINTER READ-MEMORY-DATA)	;Current free pointer
	((M-4) ADD M-T A-B)			;Proposed new free pointer
	(JUMP-GREATER-THAN M-4 A-3 CONSF4)	;Jump if doesn't fit, try next region
	((M-3) SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-POINTER A-4) ;New free pointer
	((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN)	;Relocate M-T
	(CHECK-PAGE-READ)
	((A-CONS-TEM) M-FLAGS)
	((M-E) Q-POINTER READ-MEMORY-DATA)	;Save region origin
	((M-T VMA-START-READ) ADD M-E A-T)	;Address of allocated stuff, garbage datatype
	((M-4) Q-POINTER-WITHIN-PAGE M-T)	;Then touch each page of allocated stuff
	(JUMP-NOT-EQUAL-XCT-NEXT M-4 A-ZERO CONSF2) ;Jump if first page not a fresh page
       ((M-4) ADD M-4 A-B)			;M-4 gives page count in hairy way
CONSF1	((M-DONT-SWAP-IN) DPB (M-CONSTANT -1) A-FLAGS)	;Create pages without disk read
CONSF2	(CHECK-PAGE-READ)			;Now take fault for previous VMA-START-READ
	((M-4) SUB M-4 (A-CONSTANT (EVAL PAGE-SIZE)))
	(POPJ-LESS-OR-EQUAL-XCT-NEXT M-4 A-ZERO)
       ((M-FLAGS) SETA A-CONS-TEM READ-MEMORY-DATA);Restore flags, complete memory cycle
	(JUMP-XCT-NEXT CONSF1)
       ((VMA-START-READ) ADD VMA (A-CONSTANT (EVAL PAGE-SIZE)))

CONSF4	((M-GARBAGE) MICRO-STACK-DATA-POP)
CONSF5	(DISPATCH (BYTE-FIELD 2 0) M-E D-CONS-NEXT-REGION)

;Trying to cons in newspace
CONS-CHECK-NEW
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR M-TRANSPORT-FLAG)
       (DISPATCH (BYTE-FIELD 2 0) M-E D-CONS-NEXT-REGION)

;Trying to cons in copyspace
CONS-CHECK-COPY
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET M-TRANSPORT-FLAG)
       (DISPATCH (BYTE-FIELD 2 0) M-E D-CONS-NEXT-REGION)

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-CONS-1	;DISPATCH ON SPACE TYPE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;0 FREE (ILLEGAL TO CONS IN)
	(INHIBIT-XCT-NEXT-BIT CONSF5)		;1 OLD (TRY NEXT REGION)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;2 NEW (ONLY IF NOT IN TRANSPORTER)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;3 NEW1 (ONLY IF NOT IN TRANSPORTER)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;4 NEW2 (ONLY IF NOT IN TRANSPORTER)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;5 NEW3 (ONLY IF NOT IN TRANSPORTER)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;6 NEW4 (ONLY IF NOT IN TRANSPORTER)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;7 NEW5 (ONLY IF NOT IN TRANSPORTER)
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;10 NEW6 (ONLY IF NOT IN TRANSPORTER)
	(P-BIT R-BIT)				;11 STATIC
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;12 FIXED (ILLEGAL TO CONS IN)
	(P-BIT R-BIT)				;13 EXTRA-PDL
	(P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-COPY) ;14 COPY (ONLY IF IN TRANSPORTER)
(REPEAT 3 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))	;UNUSED CODE (ILLEGAL TO CONS IN)
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
D-SCONS-2	;DISPATCH ON REPRESENTATION TYPE
	(SCONS1)		;0 LIST (TRY NEXT REGION)
	(P-BIT CONSF)		;1 STRUCTURE
	(P-BIT ILLOP)		;2 ILLEGAL
	(P-BIT ILLOP)		;3 ILLEGAL
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
D-LCONS-2	;DISPATCH ON REPRESENTATION TYPE
	(P-BIT CONSF)		;0 LIST
	(LCONS1)		;1 STRUCTURE (TRY NEXT REGION)
	(P-BIT ILLOP)		;2 ILLEGAL
	(P-BIT ILLOP)		;3 ILLEGAL
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
D-CONS-NEXT-REGION	;DISPATCH ON REPRESENTATION TYPE
	(LCONS1)		;0 LIST
	(SCONS1)		;1 STRUCTURE
	(P-BIT ILLOP)		;2 ILLEGAL
	(P-BIT ILLOP)		;3 ILLEGAL
(END-DISPATCH)

(LOCALITY I-MEM)

;;; Scavenger

;Here after consing something, to do scavenging and so forth.  M-E, M-K smashable.
;M-B has the number of Q'S consed, M-K has the region number.
;M-3 has the new free pointer, the free-pointer has not been updated yet, to 
;avoid attempting to scavenge the newly-allocated object, which is not yet initialized.
SCAV0	;(JUMP-IF-BIT-SET M-TRANSPORT-FLAG SCAVT) ;If in transporter, don't invoke scavenger
	((M-E) DPB M-B (BYTE-FIELD 24. 2) A-ZERO) ;4 times number of Q's consed (K=4)
	((A-CONS-WORK-DONE Q-R) ADD M-E A-CONS-WORK-DONE)
	(JUMP-LESS-THAN-XCT-NEXT Q-R A-SCAV-WORK-DONE SCAV0X)	;Return if not yet
       ((A-CONS-NEW-FREE-POINTER) M-3)				; time to scavenge
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-INHIBIT-SCAVENGING-FLAG)
	(CALL-EQUAL-XCT-NEXT M-TEM A-V-NIL SCAV2)	;Check if scavenger inhibited by user
SCAV0X ((A-CONS-NEW-FP-REGION) ADD M-K A-V-REGION-FREE-POINTER)
	((WRITE-MEMORY-DATA) A-CONS-NEW-FREE-POINTER)		;Now update free pointer
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-CONS-NEW-FP-REGION)
       (CHECK-PAGE-WRITE)

;Scavenge M-E Q's worth of stuff.  Clobber only M-E,M-K,M-3,M-4, tems
SCAV2	((MD) (A-CONSTANT -2))			;Turn on scavenger run-light
	((VMA-START-WRITE) ADD MD A-DISK-RUN-LIGHT)
	(CHECK-PAGE-WRITE)
	(JUMP-EQUAL-XCT-NEXT A-SCAV-COUNT M-ZERO SCAV3)	;Jump if no remembered scavenger state
       ((M-SCAVENGE-FLAG) DPB (M-CONSTANT -1) A-FLAGS)
;;;Continue previous scavenge.  Kludgiferous hair required for pdls since they
;;;change in size in real time, and we really have to obey the pad since various
;;;microcode routines like to push garbage off the end of the pdl.
SCAVL0	(JUMP-EQUAL M-ZERO A-SCAV-PDL-BASE SCAVL1)
	(CALL-XCT-NEXT SCAV-STRUCTURE-INFO)	;Recompute size of pdl
       ((MD) A-SCAV-PDL-BASE)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-SCAV-PTR)
	((M-TEM) SUB M-TEM A-SCAV-PDL-BASE)	;Number of Q's already done
	((M-TEM) SUB M-ZERO A-TEM)
	((A-SCAV-COUNT) ADD M-TEM A-SCAV-COUNT)	;Subtract that from total #Q's
	(JUMP-LESS-THAN M-ZERO A-SCAV-COUNT SCAVL1)
	((M-TEM) A-SCAV-COUNT)		 ;Shrunk beyond where we were
	(JUMP-XCT-NEXT SCAVL4)		 ;Move back A-SCAV-PTR so next structure will
       ((A-SCAV-PTR) ADD M-TEM A-SCAV-PTR)  ;be found. This can result in bit of double
					    ;counting on A-SCAV-WORK-DONE, but thats too
					    ;bad.
SCAVL1	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-E A-SCAV-COUNT SCAVL2)
       ((M-K) A-SCAV-COUNT)			;Get number of Q's to do this time
	((M-K) M-E)
SCAVL2	((A-SCAV-WORK-DONE) ADD M-K A-SCAV-WORK-DONE)
	((M-E) SUB M-E A-K)
SCAVL3	((VMA-START-READ) A-SCAV-PTR)		;Scavenge some Q's
	(CHECK-PAGE-READ)
	((A-SCAV-PTR) M+A+1 M-ZERO A-SCAV-PTR)
	((A-SCAV-COUNT) ADD (M-CONSTANT -1) A-SCAV-COUNT)
	(DISPATCH TRANSPORT-SCAV READ-MEMORY-DATA)
	(JUMP-GREATER-THAN-XCT-NEXT M-K (A-CONSTANT 1) SCAVL3)
       ((M-K) SUB M-K (A-CONSTANT 1))
	(JUMP-NOT-EQUAL A-SCAV-COUNT M-ZERO SCAVX) ;M-E too small to finish this object
	;;Finished this object, update region's GC-POINTER
SCAVL4	((M-TEM) A-SCAV-SKIP)
	((A-SCAV-WORK-DONE) ADD M-TEM A-SCAV-WORK-DONE) ;Unboxed Q's come for free
	((M-3) ADD M-TEM A-SCAV-PTR)
	((M-3) SUB M-3 A-SCAV-REGION-ORIGIN) ;relative
	((WRITE-MEMORY-DATA) Q-POINTER M-3 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-K) A-SCAV-REGION)
	((VMA-START-WRITE) ADD M-K A-V-REGION-GC-POINTER)
	(CHECK-PAGE-WRITE)
	;;Try to find next object to scavenge in this region
	((VMA-START-READ) ADD M-K A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-READ)
	((M-4) Q-POINTER READ-MEMORY-DATA)	;Save free pointer
	(JUMP-EQUAL M-3 A-4 SCAV3)		;This region now clean, try some others
;Here M-K has region, M-3 has gc pointer, M-4 has free pointer, as pure numbers
SCAV6	((VMA-START-READ) ADD M-K A-V-REGION-BITS)
	(CHECK-PAGE-READ)
	((A-SCAV-PTR) ADD M-3 A-SCAV-REGION-ORIGIN)
	(DISPATCH (LISP-BYTE %%REGION-REPRESENTATION-TYPE) READ-MEMORY-DATA D-SCAV6)
	(CALL-XCT-NEXT SCAV-STRUCTURE-INFO)	;Structure region
       ((MD) A-SCAV-PTR)			;Set A-SCAV-COUNT, A-SCAV-SKIP
	((A-SCAV-PDL-BASE) A-SINF-PDL-BASE)	;0 or base address of this pdl
SCAV8	(JUMP-EQUAL A-SCAV-COUNT M-ZERO SCAVL4)	;Object or region can have no boxed Q's!
	(JUMP-NOT-EQUAL-XCT-NEXT M-E A-ZERO SCAVL0)	;Go scavenge this object
       ((A-SCAV-PTR) DPB M-ZERO Q-ALL-BUT-POINTER A-SCAV-PTR) ;This must have a zero tag
	(JUMP SCAVX)				;Done for now

SCAV7	((A-SCAV-SKIP) A-ZERO)			;List region, don't worry about
	((A-SCAV-PDL-BASE) A-ZERO)		; object boundaries
	(JUMP-GREATER-THAN-XCT-NEXT M-4 A-3 SCAV9)
       ((Q-R A-SCAV-COUNT) SUB M-4 A-3)
	((A-SCAV-PTR) ADD M-4 A-SCAV-REGION-ORIGIN)
	((Q-R A-SCAV-COUNT) SUB M-3 A-4)	;Downward-consing
SCAV9	(JUMP-LESS-OR-EQUAL Q-R (A-CONSTANT 400) SCAV8)
	(JUMP-XCT-NEXT SCAV8)
       ((A-SCAV-COUNT) (A-CONSTANT 400))	;Do at most this many before updating GC-pntr

(LOCALITY D-MEM)
(START-DISPATCH 2 0) ;Dispatch on representation-type
D-SCAV6	(INHIBIT-XCT-NEXT-BIT SCAV7)		;0 list
	(P-BIT R-BIT)				;1 structure
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;2 unused
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;3 unused
(END-DISPATCH)
(LOCALITY I-MEM)

SCAV3	((M-K) A-ZERO)				;Check every region
SCAV4	((VMA-START-READ) ADD M-K A-V-REGION-BITS)
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%REGION-SCAVENGE-ENABLE) READ-MEMORY-DATA SCAV5)
	((VMA-START-READ) ADD M-K A-V-REGION-GC-POINTER)
	(CHECK-PAGE-READ)
	((M-3) Q-POINTER READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-K A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-READ)
	((M-4) Q-POINTER READ-MEMORY-DATA)	;Save free pointer
	(JUMP-EQUAL M-4 A-3 SCAV5)		;This region is clean
	((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN)
	(CHECK-PAGE-READ)
	((A-SCAV-REGION) M-K)			;Do this one
	(JUMP-XCT-NEXT SCAV6)
       ((A-SCAV-REGION-ORIGIN) Q-POINTER READ-MEMORY-DATA)

SCAV5	(JUMP-LESS-THAN-XCT-NEXT M-K (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS)) SCAV4)
       ((M-K) ADD M-K (A-CONSTANT 1))
	;;No scavenging needed anywhere, shut off the scavenger and enable flipping
	((A-GC-FLIP-READY) A-V-TRUE)
	((A-SCAV-WORK-DONE) (BYTE-FIELD 31. 0) (M-CONSTANT -1))  ;Maximum possible
SCAVX	((M-SCAVENGE-FLAG) DPB (M-CONSTANT 0) A-FLAGS)
	((MD) SETZ)
	((M-TEM) (A-CONSTANT -2))		;Turn off run light
	(POPJ-AFTER-NEXT (VMA-START-WRITE) ADD M-TEM A-DISK-RUN-LIGHT)
       (CHECK-PAGE-WRITE)			;This also makes sure VMA not pointing at gbg

;CONSing inside transporter.  If also inside scavenger, count as scavenger
;work done.  In either case, don't count as cons work done since this is not
;fresh consing but just copying, and don't invoke the scavenger.
SCAVT	((WRITE-MEMORY-DATA) M-3)	;Write back the free pointer
	((VMA-START-WRITE) ADD M-K A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-WRITE)
	(JUMP-NOT-EQUAL M-K A-SCONS-CACHE-REGION SCAVT1)	;Cache interference
	((A-SCONS-CACHE-AREA) SETZ)
SCAVT1	(JUMP-NOT-EQUAL M-K A-LCONS-CACHE-REGION SCAVT2)
	((A-LCONS-CACHE-AREA) SETZ)
SCAVT2	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR M-SCAVENGE-FLAG)
       ((A-SCAV-WORK-DONE) ADD M-B A-SCAV-WORK-DONE)

;Scavenge the specified amount or until a page fault.
XSCAV (MISC-INST-ENTRY %GC-SCAVENGE)
	((M-R) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;Amount of scav work to do
XSCAV1	((M-T) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-GC-FLIP-READY)
	(POPJ-NOT-EQUAL M-T A-V-NIL)			;Return if scavenger all done
	((M-S) A-DISK-PAGE-READ-COUNT)
	(CALL-XCT-NEXT SCAV2)				;Just do 1 single scavenge step
       ((M-E) (A-CONSTANT 1))
	(POPJ-NOT-EQUAL M-S A-DISK-PAGE-READ-COUNT)	;Return if took page fault
	(JUMP-GREATER-THAN-XCT-NEXT M-R (A-CONSTANT 1) XSCAV1)
       ((M-R) SUB M-R (A-CONSTANT 1))
	(JUMP XFALSE)					;Return if did specified # steps

;Make the scavenger forget about a particular region
;This also removes the region from the cons cache
SCVRST (MISC-INST-ENTRY %GC-SCAV-RESET)
	((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;arg 1 - region number
	((A-SCONS-CACHE-AREA) SETZ)			;Clear cons cache
	((A-LCONS-CACHE-AREA) SETZ)
	(JUMP-NOT-EQUAL M-K A-SCAV-REGION XFALSE)	;nothing if scavenger not looking here
	(JUMP-XCT-NEXT XTRUE)
       ((A-SCAV-COUNT) M-ZERO)			;Else make scavenger forget its state

;Adjust A-CONS-WORK-DONE
XGCCW (MISC-INST-ENTRY %GC-CONS-WORK)
	(CALL FXUNPK-P-1)				;M-1 gets adjustment
	((M-1) DPB M-1 (BYTE-FIELD 30. 2) A-ZERO)	;Multiply by 4
	(JUMP-XCT-NEXT XFALSE)
       ((A-CONS-WORK-DONE) ADD M-1 A-CONS-WORK-DONE)

;HERE WHEN AREA REQUIRES NEW REGION

SCONS5	(JUMP-EQUAL M-S
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (EVAL (FIND-POSITION-IN-LIST 'EXTRA-PDL-AREA AREA-LIST))))
		EXTRA-PDL-OV)			;EXTRA-PDL FULL
	((M-E) (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-STRUCTURE)))
	(JUMP-XCT-NEXT SCONS2)
       (CALL RCONS)

;LIST-TYPE EXTRA-PDLS NOT CODED.
LCONS5	((M-E) (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-LIST)))
	(JUMP-XCT-NEXT LCONS2)
       (CALL RCONS)

;HERE WHEN SCONS'ING IN EXTRA-PDL AND REGION FULL.  WE CAN GIVE UP AND
;CONS IN WORKING-STORAGE INSTEAD, OR WE CAN DECIDE TO RESET THE EXTRA-PDL
;BY COPYING OUT ANYTHING POINTED TO BY REGISTERS AND PDL-BUFFER.
EXTRA-PDL-OV
	(JUMP-LESS-OR-EQUAL M-B A-3 EXTRA-PDL-OV-0)
	(JUMP SCONS-D)			;won't fit, cons in working storage instead

;FLUSH POINTERS TO EXTRA-PDL OUT OF "MACHINE", I.E. M-ZR - M-K, A-VERSION - A-END-Q-POINTERS,
;PDL BUF, M-B, M-E, M-K, M-S, M-T HAVE INTERNAL DATA OUT OF CONS, WILL PURGE ANYWAY,
;SHOULDN'T HURT
EXTRA-PDL-OV-0
	((M-E) (A-CONSTANT (M-MEM-LOC M-ZR)))
EXTRA-PDL-OV-1
	((OA-REG-HIGH) DPB M-E OAH-M-SRC A-ZERO)
	((M-T) M-GARBAGE)  ;M-GARBAGE IS LOCATION 0@M
	(CALL EXTRA-PDL-PURGE)
	((OA-REG-LOW) DPB M-E OAL-M-DEST A-ZERO)
	((M-GARBAGE) M-T)
	(JUMP-NOT-EQUAL-XCT-NEXT M-E (A-CONSTANT (M-MEM-LOC M-J)) ;DON'T DO M-S, M-K
		EXTRA-PDL-OV-1)
       ((M-E) ADD M-E (A-CONSTANT 1))
	((M-E) (A-CONSTANT (A-MEM-LOC A-VERSION)))
EXTRA-PDL-OV-2
	((OA-REG-HIGH) DPB M-E OAH-A-SRC A-ZERO)
	((M-T) A-GARBAGE) ;A-GARBAGE IS LOCATION 0@A
	(CALL EXTRA-PDL-PURGE)
	((OA-REG-LOW) DPB M-E OAL-A-DEST A-ZERO)
	((A-GARBAGE) M-T)
	(JUMP-NOT-EQUAL-XCT-NEXT M-E (A-CONSTANT (A-MEM-LOC A-END-Q-POINTERS)) EXTRA-PDL-OV-2)
       ((M-E) ADD M-E (A-CONSTANT 1))
	((PDL-BUFFER-INDEX) A-PDL-BUFFER-HEAD)
EXTRA-PDL-OV-3
	((M-E) PDL-BUFFER-INDEX)	;Save PI
	(CALL-XCT-NEXT EXTRA-PDL-PURGE)
       ((M-T) C-PDL-BUFFER-INDEX)
	((PDL-BUFFER-INDEX) M-E)	;Restore possibly-clobbered PI
	((C-PDL-BUFFER-INDEX) M-T)
	(JUMP-NOT-EQUAL-XCT-NEXT A-E PDL-BUFFER-POINTER EXTRA-PDL-OV-3)
       ((PDL-BUFFER-INDEX) ADD M-E (A-CONSTANT 1))
	;; Now reset the extra-pdl free-pointer and try again
	((WRITE-MEMORY-DATA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-K A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-WRITE)
	(JUMP SCONS2)				;Should win this time

;;; If M-T points to extra-pdl, copy out what it points to and change it.
;;; Must protect all lettered registers, M-1, M-2.
EXTRA-PDL-PURGE
	((MD) Q-POINTER M-T	;Start with a cheap test (avoid loading map)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-LESS-THAN MD A-V-EXTRA-PDL-AREA)
	(POPJ-GREATER-OR-EQUAL MD A-V-MICRO-CODE-ENTRY-AREA)
	((MD) M-T)		;Get full ptr including data type
	((VMA) (A-CONSTANT (EVAL (+ 400 %SYS-COM-TEMPORARY))))
	(POPJ-AFTER-NEXT GC-WRITE-TEST)		;Use regular GC-WRITE-TEST mechanism
       ((M-T) MD)

;Allocate a new region for area in M-S
;Must be at least M-B words, desired representation type in M-E, other attributes from
; the area's first region, and as follows:
;Immediately after a flip, an area may have only old-space regions.
;In that case, we have to make sure we create new-space regions,
;not additional old-space regions, as we cons in that area.
;If called from the transporter, we should make copy-space rather than new-space.
;REGION-SPACE-TYPE is determined as follows:
; If called from scavenger, %REGION-SPACE-COPY
; Otherwise copy first region except canonicalize OLD and COPY into NEW
;REGION-SCAVENGE-ENABLE is determined as follows:
; For static area, it should be on and will be copied from area's first region.
; For dynamic area, it should be on for COPY and off for NEW and OLD.
;Return region number in M-K
;May bash M-E, M-T only (among lettered registers).
;Protects M-1, M-2.

RCONS	((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST)	;COMPUTE CURRENT SIZE OF AREA
	(CHECK-PAGE-READ)				;BY ADDING UP SIZES OF ALL REGIONS
	((M-4) SETZ)					;INTO M-4
	((M-K C-PDL-BUFFER-POINTER-PUSH) Q-POINTER READ-MEMORY-DATA)
RCONS0	((VMA-START-READ) ADD M-K A-V-REGION-LENGTH)	;USE TOTAL SIZE NOT ALLOCATED SIZE
	(CHECK-PAGE-READ)
	((M-4) ADD READ-MEMORY-DATA A-4)
	((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BOXED-SIGN-BIT READ-MEMORY-DATA RCONS0)
       ((M-K) Q-POINTER READ-MEMORY-DATA)
	((M-K) C-PDL-BUFFER-POINTER-POP)	;FIRST REGION IN AREA
	((VMA-START-READ) ADD M-S A-V-AREA-REGION-SIZE)
	(CHECK-PAGE-READ)
	((M-3) Q-POINTER READ-MEMORY-DATA)	;NORMAL AMOUNT TO ALLOCATE
	(JUMP-GREATER-THAN M-3 A-B RCONS1)
	((M-3) M-B)				;M-3 AMOUNT WE WANT TO ALLOCATE
RCONS1	((VMA-START-READ) ADD M-S A-V-AREA-MAXIMUM-SIZE)
	(CHECK-PAGE-READ)
	((MD) Q-POINTER READ-MEMORY-DATA)
	((M-4) Q-POINTER M-4)
	((M-4) SUB MD A-4)			;M-4 AMOUNT LEFT BEFORE OVERFLOW
	(JUMP-GREATER-OR-EQUAL M-4 A-3 RCONS2)	;JUMP IF NO OVERFLOW PROBLEM
	(JUMP-IF-BIT-SET M-TRANSPORT-FLAG RCONS2A) ;INHIBIT EMBARRASSING TRAP OUT OF TRANSP
	(CALL-GREATER-THAN M-B A-4 TRAP)
    (ERROR-TABLE AREA-OVERFLOW M-S)
	(JUMP-XCT-NEXT RCONS2)			;CONS MAXIMAL SIZE REGION
       ((M-3) M-4)
RCONS2A	((M-3) M-B)				;ALMOST OVERFLOWING, ALLOCATE LESS (WIN?)
RCONS2	((VMA-START-READ) ADD M-K A-V-REGION-BITS)	;GET BITS FOR THIS REGION
	(CHECK-PAGE-READ)			;FROM FIRST REGION IN THE AREA
	(JUMP-IF-BIT-SET-XCT-NEXT M-TRANSPORT-FLAG RCONS4)
       ((M-4) READ-MEMORY-DATA)
	((M-TEM) (LISP-BYTE %%REGION-SPACE-TYPE) M-4)
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-TEM D-RCONS)	;Check region type
	     (ERROR-TABLE RCONS-FIXED)
RCONS3 ((M-4) IOR M-4 (A-CONSTANT (BYTE-MASK %%REGION-OLDSPACE-META-BIT))) ;Not oldspace
	((M-4) DPB M-TEM (LISP-BYTE %%REGION-SPACE-TYPE) A-4)
	((VMA-START-READ) ADD M-S A-V-AREA-SWAP-RECOMMENDATIONS)
	(CHECK-PAGE-READ)
	((M-4) DPB READ-MEMORY-DATA (LISP-BYTE %%REGION-SWAPIN-QUANTUM) A-4)
	(CALL-XCT-NEXT MAKE-REGION)		;ALLOCATE A REGION OF THAT SIZE (TO M-K)
       ((M-4) DPB M-E (LISP-BYTE %%REGION-REPRESENTATION-TYPE) A-4)
	;Cons into area region list - for now we just put it at the front
	;In the case where there is more than one representation type this could be unoptimal
	((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST)
	(CHECK-PAGE-READ)
	((M-3) READ-MEMORY-DATA)		;2ND REGION
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-K Q-POINTER A-3)
	(CHECK-PAGE-WRITE)
	((WRITE-MEMORY-DATA) M-3)
	(POPJ-AFTER-NEXT
	 (VMA-START-WRITE) ADD M-K A-V-REGION-LIST-THREAD)
       (CHECK-PAGE-WRITE)

RCONS4	((M-TEM) (A-CONSTANT (EVAL %REGION-SPACE-COPY)))
	(JUMP-XCT-NEXT RCONS3)	;COPY space should always have scavenge enable
       ((M-4) DPB (M-CONSTANT -1) (LISP-BYTE %%REGION-SCAVENGE-ENABLE) A-4)

RCONS-DYNAM	;Newspace doesn't need to be scavenged
	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL %REGION-SPACE-NEW)))
       ((M-4) DPB M-ZERO (LISP-BYTE %%REGION-SCAVENGE-ENABLE) A-4)

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-RCONS	(P-BIT ILLOP)		;0 FREE
	(P-BIT RCONS-DYNAM)	;1 OLD (change into new)
	(P-BIT R-BIT)		;2 NEW (copy it)
	(P-BIT R-BIT)		;3 NEW1 (copy it)
	(P-BIT R-BIT)		;4 NEW2 (copy it)
	(P-BIT R-BIT)		;5 NEW3 (copy it)
	(P-BIT R-BIT)		;6 NEW4 (copy it)
	(P-BIT R-BIT)		;7 NEW5 (copy it)
	(P-BIT R-BIT)		;10 NEW6 (copy it)
	(P-BIT R-BIT)		;11 STATIC (copy it)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP) ;12 FIXED (not supposed to cons new regions)
	(P-BIT R-BIT)		;13 EXTRA-PDL (copy it)
	(P-BIT RCONS-DYNAM)	;14 COPY (change into new)
(REPEAT 3 (P-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; MAKE A REGION.
;;; M-3 HAS SIZE IN WORDS, M-4 HAS REGION-BITS
;;; SETS UP EVERYTHING ELSE EXCEPT REGION-LIST-THREAD, RETURNS REGION IN M-K, BASHES M-E, M-T
;;; PRESERVES M-3 AND M-4, EXCEPT M-3 IS ROUNDED UP TO THE NEXT QUANTUM BOUNDARY
MAKE-REGION
	((M-3) ADD M-3 (A-CONSTANT (EVAL (1- %ADDRESS-SPACE-QUANTUM-SIZE)))) ;Round up to
	((M-3) SELECTIVE-DEPOSIT M-3 VMA-QUANTUM-BYTE A-ZERO)		     ; quantum bound
	((A-REGION-CONS-ALARM) M+A+1 M-ZERO A-REGION-CONS-ALARM)
	((M-TEM) VMA-PAGE-ADDR-PART M-3)	;Length of region in pages
	((A-PAGE-CONS-ALARM) ADD M-TEM A-PAGE-CONS-ALARM)
	;; Search address-space-map for suitable number of consecutive zeros
	((M-T) A-V-FIRST-UNFIXED-AREA)		;Starting address
	((M-TEM) A-DISK-MAXIMUM)		;Ending address
	((M-K) DPB M-TEM VMA-PAGE-ADDR-PART (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
MAKE-REGION-1
	((M-E) ADD M-T A-3)			;End of large enough region starting here
MAKE-REGION-2	
	(CALL-GREATER-OR-EQUAL M-T A-K TRAP)	;Reached end of map, with no luck
	    (ERROR-TABLE VIRTUAL-MEMORY-OVERFLOW)
	(CALL ADDRESS-SPACE-MAP-LOOKUP)		;This could be optimized to save some mem rds?
	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO MAKE-REGION-1)
       ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE)))
	(JUMP-LESS-THAN M-T A-E MAKE-REGION-2)	;Found free space, but not big enough yet
	((M-T) SUB M-T A-3)			;Base address of free space found
	;; M-T has origin, M-3 has length, M-4 has bits.  Put region in tables.
	((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST))))
	(CHECK-PAGE-READ)
	((M-K) Q-POINTER READ-MEMORY-DATA)	;Number of new region
	(CALL-EQUAL M-K A-ZERO TRAP)		;Out of region numbers
	    (ERROR-TABLE REGION-TABLE-OVERFLOW)
	((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)	;CDR OFF OF LIST
	(CHECK-PAGE-READ)
	((WRITE-MEMORY-DATA) READ-MEMORY-DATA)	;THIS ENSURES READ CYCLE FINISHES
	((VMA-START-WRITE) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST))))
	(CHECK-PAGE-WRITE)
	;; Proceed to initialize the various tables, except list-thread which caller does.
	((WRITE-MEMORY-DATA) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-K A-V-REGION-ORIGIN)
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) Q-POINTER M-3 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-K A-V-REGION-LENGTH)
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) Q-POINTER M-4 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-K A-V-REGION-BITS)
	(CHECK-PAGE-WRITE)
	;; Set up address-space-map
	((M-E) ADD M-T A-3)			;End of region
MAKE-REGION-3
	(CALL ADDRESS-SPACE-MAP-STORE)
	((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE)))
	(JUMP-LESS-THAN M-T A-E MAKE-REGION-3)
	;; Finish setting up tables
	((WRITE-MEMORY-DATA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;FREE PTR = 0
	((VMA-START-WRITE) ADD M-K A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) ADD M-K A-V-REGION-GC-POINTER)
       (CHECK-PAGE-WRITE)

;;; SUBROUTINE TO CREATE A REGION, CALLED ONLY BY AREA-CREATOR
;;; EXISTS MAINLY BECAUSE THE MICROCODE HAS TO KNOW HOW TO DO THIS ANYWAY

XMKRG (MISC-INST-ENTRY %MAKE-REGION)
	((M-3) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;SIZE
	(CALL-XCT-NEXT MAKE-REGION)
       ((M-4) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;BITS
	(POPJ-AFTER-NEXT
	 (M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

;Given an address in M-T, look up in the address space map, return result in M-TEM
ADDRESS-SPACE-MAP-LOOKUP
	;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!)
	((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-T A-V-ADDRESS-SPACE-MAP)
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-T)	;Byte number in that word
	((M-TEM) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO)
	(POPJ-AFTER-NEXT (OA-REG-LOW) SUB (M-CONSTANT 40) A-TEM) ;40 doesn't hurt here, IORed
       ((M-TEM) (BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) READ-MEMORY-DATA)

;Given an address in M-T, store M-K into the address space map.
ADDRESS-SPACE-MAP-STORE
	;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!)
	((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-T A-V-ADDRESS-SPACE-MAP)
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-T)	;Byte number in that word
	((A-TEM1) READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT (OA-REG-LOW) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO)
       ((WRITE-MEMORY-DATA-START-WRITE) DPB M-K 
		(BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) A-TEM1)

;;; CALL THIS ROUTINE TO FREE UP A REGION, NUMBER IN M-K (MUST BE PURE NUMBER).
;;; BASHES M-A,M-B,M-D,M-E,M-K,M-T, M-1...M-2, A-TEM1...A-TEM3

XFREE-REGION (MISC-INST-ENTRY %GC-FREE-REGION)
	((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)
FREE-REGION
	((WRITE-MEMORY-DATA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-K A-V-REGION-BITS)	;Clear the REGION-BITS, = free status
	(CHECK-PAGE-WRITE)
	((M-D) DPB (M-CONSTANT -1) (BYTE-FIELD 1 31.)	;Change swap-status to Flushable
		(A-CONSTANT 2))				; and disconnect the virtual page
	(CALL-XCT-NEXT UPDATE-REGION-PHT);Note that this sets M-1 and M-2 to the region bounds
       ((MD) (A-CONSTANT (BYTE-VALUE MAP-STATUS-CODE 2))) ;Make read-only, no access, in PHT2
	;; Put region in M-K onto free region-table-entry list
	((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST))))
	(ILLOP-IF-PAGE-FAULT)
	((A-TEM2) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-K
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) A-TEM2)
	((VMA-START-WRITE) ADD M-K A-V-REGION-LIST-THREAD)
	(CHECK-PAGE-WRITE)
	;; Remove from ADDRESS-SPACE-MAP
	;; Referencing these addresses will halt in PAGE-IN-GET-MAP-BITS
	((M-T) M-1)
FREE-REGION-1
	(CALL-XCT-NEXT ADDRESS-SPACE-MAP-STORE)
       ((M-K) A-ZERO)
	((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE)))
	(JUMP-LESS-THAN M-T A-2 FREE-REGION-1)
	(POPJ-AFTER-NEXT (M-T) A-V-NIL)
       (NO-OP)

;Remove all information about the region in M-K from the page map,
;and fix the PHT entries of any swapped-in pages.
;Call with MD containing the new REGION-BITS entry for the region,
; and M-D containing A-V-NIL or the new swap-status.
;Sets M-1 and M-2 to the bounds of the region.
;Bashes M-A, M-B, M-E, M-T, tems.
UPDATE-REGION-PHT
	((M-E) (LISP-BYTE %%REGION-MAP-BITS) MD)	;Arg for XCPGS0
	((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN)	;Find virtual address range of region
	(CHECK-PAGE-READ)
	((M-1) Q-POINTER READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-K A-V-REGION-LENGTH)
	(CHECK-PAGE-READ)
	((M-2) Q-POINTER READ-MEMORY-DATA)
	((MD M-2) ADD M-1 A-2)
	;; M-1 has lowest address in region, M-2 has highest address in region +1
	;; Both are necessarily a multiple of the page size.
	;; Call XCPGS0 on each page, to fix the PHT entry (if any) and the map.
UPDATE-REGION-PHT-0
	(CALL-XCT-NEXT XCPGS0)
       ((C-PDL-BUFFER-POINTER-PUSH) SUB MD (A-CONSTANT (EVAL PAGE-SIZE)))
	(JUMP-GREATER-THAN MD A-1 UPDATE-REGION-PHT-0)
	(POPJ)

;;; SAFE ALLOCATION AND INITIALIZATION OF STRUCTURES

;(%ALLOCATE-AND-INITIALIZE <data type for return> <data type for header> <header> 
;				<value for second word> <area> <nqs>)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS %ALLOCATE-AND-INITIALIZE PP PP PP PP PP PP)

XAAI (MISC-INST-ENTRY %ALLOCATE-AND-INITIALIZE)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM-GREATER-THAN-1 PP 5)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER)	;CHECK FOR ALLOC AT LEAST 2 WORDS
	(CALL-LESS-THAN M-1 (A-CONSTANT 2) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-GREATER-THAN-1 PP 5)
	(CALL XALLB)			;ALLOCATE BLOCK, RETURN IN M-T, NO SEQUENCE BREAK
					; WHILE CRUFT IS PARTIALLY INITIALIZED.  POPS LAST ARG.
	((VMA) ADD M-T (A-CONSTANT 1))	;-> SECOND WORD
	((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-WRITE)
	((A-TEM1) C-PDL-BUFFER-POINTER-POP)	;HEADER Q (POINTER PART)
	((WRITE-MEMORY-DATA) DPB C-PDL-BUFFER-POINTER-POP	;SET DATA TYPE, ETC.
		Q-ALL-BUT-POINTER A-TEM1)
	(POPJ-AFTER-NEXT			;WRITE THE HEADER, AND
	 (VMA-START-WRITE M-T) DPB C-PDL-BUFFER-POINTER-POP	; RETURN POINTER TO BLOCK,
		Q-ALL-BUT-POINTER A-T)		; WITH CORRECT TYPE
       (CHECK-PAGE-WRITE)

;(%ALLOCATE-AND-INITIALIZE-ARRAY <header as fixnum> <index length> <leader length> 
;					<area> <nqs>)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS %ALLOCATE-AND-INITIALIZE-ARRAY PP PP PP PP PP)

XAAIA (MISC-INST-ENTRY %ALLOCATE-AND-INITIALIZE-ARRAY)
	(CALL XALLB)			;ALLOCATE BLOCK, RETURN IN M-T, NO SEQUENCE BREAK
					; WHILE CRUFT IS PARTIALLY INITIALIZED
		;XALLB ALSO FILLS IT WITH NILS, WHICH IS RIGHT EXCEPT FOR THE DATA
		;PORTION OF A NUMERIC ARRAY.  NOTE THAT THE LEADER OF ANY KIND
		;OF ARRAY WANTS TO BE FILLED WITH NILS.
	((VMA M-T) Q-POINTER M-T	;VMA -> START OF BLOCK, M-T RIGHT MAYBE
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))
	((M-E) ADD M-T A-B)		;UPPER BOUND OF STORAGE, SAME DATA-TYPE AS M-T
	((M-E) SUB M-E (A-CONSTANT 1))		;LAST LOCATION TO BE FILLED
	((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;LEADER LENGTH
	((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;INDEX LENGTH
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-LEADER-BIT)
		C-PDL-BUFFER-POINTER XAAIA1)
       ((M-2) DPB C-PDL-BUFFER-POINTER-POP	;HEADER
	    Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-HEADER)))
	((WRITE-MEMORY-DATA-START-WRITE) ADD M-C	;STORE LEADER HEADER
		(A-CONSTANT (PLUS (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE %%HEADER-TYPE-FIELD
						    %HEADER-TYPE-ARRAY-LEADER))
				  2)))
	(CHECK-PAGE-WRITE)
	((VMA M-T) ADD M-T A-C ALU-CARRY-IN-ONE)	;POINTS ONE BEFORE HEADER
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-C
		Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CHECK-PAGE-WRITE)
	((VMA M-T) ADD M-T (A-CONSTANT 1))	;POINTS TO HEADER
XAAIA1	((WRITE-MEMORY-DATA-START-WRITE) M-2)	;STORE HEADER
	(CHECK-PAGE-WRITE)
	(DISPATCH (LISP-BYTE %%ARRAY-TYPE-FIELD) M-2 SKIP-IF-NUMERIC-ARRAY)
	 (JUMP XAAIA3)				;ALREADY INITED TO NIL
	;; THIS IS A NUMERIC OR STRING ARRAY, FILL WITH ZEROS
	((WRITE-MEMORY-DATA) M-ZERO)
	(JUMP-GREATER-OR-EQUAL VMA A-E XAAIA3)	;JUMP IF ZERO-LENGTH ARRAY
XAAIA2	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN VMA A-E XAAIA2)
XAAIA3	(POPJ-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LONG-LENGTH-FLAG) M-2)
	((VMA) ADD M-T (A-CONSTANT 1))
	(POPJ-AFTER-NEXT
	 (WRITE-MEMORY-DATA-START-WRITE) DPB M-B Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (CHECK-PAGE-WRITE)

;SUBROUTINE TO THE ABOVE.  TAKES AREA AND #QS ON PDL, CALLS SCONS.
;FILLS THE THING WITH NILS
XALLB	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP NIL)
	(CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP)
       ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;ARG 2 NUMBER OF QS
  (ERROR-TABLE ARGTYP POSITIVE-FIXNUM M-B NIL)
	(CALL-XCT-NEXT SCONS)
       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;ARG 1 AREA
	(JUMP-XCT-NEXT FILL-WITH-THINGS)
       ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)

;SUBROUTINE TO CONS UP A LIST OF NILS.  ARGS LIKE LCONS.
;NOTE THAT DATA-TYPE RETURNED IN M-T IS GARBAGE.
LIST-OF-NILS
	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)

;SUBROUTINE TO CONS UP A LIST OF THINGS.  THE THING TO BE CONSED IS ON THE
;STACK.  OTHERWISE, ARGS LIKE NCONS.  NOTE THAT DATA-TYPE RETURNED IN M-T
;IS GARBAGE.
LIST-OF-THINGS
	(CALL LCONS)
FILL-WITH-THINGS
	((M-3) M-B)				;NUMBER OF CELLS TO INITIALIZE
	((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP	;CDR-NEXT
		Q-ALL-BUT-CDR-CODE (A-CONSTANT -1))
	((VMA) SUB M-T (A-CONSTANT 1))
	(JUMP-LESS-OR-EQUAL M-3 (A-CONSTANT 1) FILL-WITH-THINGS-1)
FILL-WITH-THINGS-0
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 2) FILL-WITH-THINGS-0)
       ((M-3) SUB M-3 (A-CONSTANT 1))
FILL-WITH-THINGS-1
	((WRITE-MEMORY-DATA) Q-ALL-BUT-CDR-CODE WRITE-MEMORY-DATA
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(POPJ-AFTER-NEXT (VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
       (CHECK-PAGE-WRITE)
;OK TO POPJ AND START MEM CYCLE.  USED AS MISC INSTRUCTION, BUT NOT AS REGULAR INSTRUCTION.
;AND NOT USED AS MISC INSTRUCTION TO D-IGNORE.

;;; Sub-Primitives for dissecting an object in storage.
;;; These are called by the garbage collector and also available as misc functions.

;;; Given a pointer, return the object (base pointer and data type) which contains
;;; the cell to which the pointer points.  This may not be the actual beginning
;;; of the object's storage, in the case of an array with a leader.
;;; Arg on pdl, answer in M-T.  Clobbers M-A, M-B, M-E, and page-fault-clobberable.
;;;This function could maybe be improved with some pipelining, but hair is required!

;;; Inside this routine, it is important to note that M-A and VMA usually
;;; but not always contain the same thing.  The difference has to do with
;;; forwarded structures.  Study the code.

;;; %FIND-STRUCTURE-LEADER is the same except if given an array with a leader,
;;; it returns a locative to the leader-header rather than the usual array-pointer.
;;; This gives you the actual lowest address in the structure, which is what
;;; the transporter needs.

XFSH (MISC-INST-ENTRY %FIND-STRUCTURE-HEADER)
	(JUMP-XCT-NEXT XFSH0)
       ((M-E) SETZ)

XFSL (MISC-INST-ENTRY %FIND-STRUCTURE-LEADER)
	((M-E) SETO)	
XFSH0	(CALL XRGN)				;M-A gets pointer, M-T gets region
	((VMA-START-READ) ADD M-T A-V-REGION-ORIGIN)
	(CHECK-PAGE-READ)
	(POPJ-EQUAL M-T A-V-NIL)		;Return NIL if garbage pointer input
	((M-B) Q-TYPED-POINTER READ-MEMORY-DATA)	;Origin address of region
	((VMA-START-READ) ADD M-T A-V-REGION-BITS)	;Get representation type
	(CHECK-PAGE-READ)
	(DISPATCH (LISP-BYTE %%REGION-REPRESENTATION-TYPE)
		READ-MEMORY-DATA D-FSH)

(LOCALITY D-MEM)
(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
D-FSH	(XFSHL)		;0 LIST
	(XFSHS)		;1 STRUCTURE
	(P-BIT ILLOP)	;2 NOT USED
	(P-BIT ILLOP)	;3 NOT USED
(END-DISPATCH)

(START-DISPATCH 2 0)
D-FSHL	(P-BIT R-BIT)				;0 CDR-NORMAL
	(INHIBIT-XCT-NEXT-BIT P-BIT R-BIT)	;1 CDR-ERROR
	(INHIBIT-XCT-NEXT-BIT P-BIT R-BIT)	;2 CDR-NIL
	(XFSHL)					;3 CDR-NEXT
(END-DISPATCH)

(LOCALITY I-MEM)

;%FIND-STRUCTURE-HEADER in list space
XFSHL	(JUMP-EQUAL M-A A-B XFSHL1)		;This is start of list if start of region
	((VMA-START-READ) SUB M-A (A-CONSTANT 1))	;Check preceding word
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)	;If it is forwarded, not same list
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER-FORWARD)) XFSHL1)
	(DISPATCH Q-CDR-CODE READ-MEMORY-DATA D-FSHL)	;CDR-NEXT -> search more,
       ((M-A) SUB M-A (A-CONSTANT 1))		; CDR-NORMAL -> include this one Q.
XFSHL1	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-LIST)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

;%FIND-STRUCTURE-HEADER in structure space

;This dispatch ignores data-types 0 and -1, rather than going to ILLOP,
;because they are legal in stack-group array-leaders.
(ASSIGN-EVAL NQZUSD-1 (EVAL (- 31. (LENGTH Q-DATA-TYPES))))
(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-FSHS	(XFSHS1)				;TRAP
	(XFSHS1)				;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(XFSHS1)				;SYMBOL
	(INHIBIT-XCT-NEXT-BIT XFSHSS)		;SYMBOL-HEADER
	(XFSHS1)				;FIX
	(XFSHS1)				;EXTENDED-NUMBER
	(INHIBIT-XCT-NEXT-BIT XFSHSH)		;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(XFSHS1)				;EXTERNAL-VALUE-CELL-POINTER
	(XFSHS1)				;ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT XFSHS-HFWD)	;HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT XFSHS-BFWD)	;BODY-FORWARD
	(XFSHS1)				;LOCATIVE
	(XFSHS1)				;LIST
	(XFSHS1)				;U CODE ENTRY
	(XFSHS1)				;FEF
	(XFSHS1)				;ARRAY-POINTER
	(INHIBIT-XCT-NEXT-BIT XFSHSA)		;ARRAY-HEADER
	(XFSHS1)				;STACK-GROUP
	(XFSHS1)				;CLOSURE
	(XFSHS1)				;SMALL-FLONUM 
	(XFSHS1)				;SELECT-METHOD
	(XFSHS1)				;INSTANCE
	(INHIBIT-XCT-NEXT-BIT XFSHSI)		;INSTANCE-HEADER
	(XFSHS1)				;ENTITY
	(XFSHS1)				;STACK-CLOSURE
 (REPEAT NQZUSD-1 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
	(XFSHS1)				;DATA-TYPE 37
(END-DISPATCH)

(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)	;DISPATCH ON HEADER SUBTYPE
D-FSHSH	(P-BIT ILLOP)	;%HEADER-TYPE-ERROR
	(XFSHSHF)	;%HEADER-TYPE-FEF
	(XFSHSHAL)	;%HEADER-TYPE-ARRAY-LEADER
	(P-BIT ILLOP)	;unused
	(XFSHSHN)	;%HEADER-TYPE-FLONUM
	(XFSHSHN)	;%HEADER-TYPE-COMPLEX
	(XFSHSHN)	;%HEADER-TYPE-BIGNUM
	(XFSHSHN)	;%HEADER-TYPE-RATIONAL-BIGNUM
(REPEAT NHDUSD (P-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;%FIND-STRUCTURE-HEADER in structure space
XFSHS	((VMA-START-READ) M-A)
XFSHS1	(CHECK-PAGE-READ)
	(CALL-LESS-THAN M-A A-B ILLOP)		;Dropped off top of region
	(DISPATCH Q-DATA-TYPE READ-MEMORY-DATA D-FSHS)	;Leave loop if header,
       ((M-A VMA-START-READ) SUB M-A (A-CONSTANT 1))	; or read preceding word and loop

XFSHSS	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-SYMBOL)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

;This is an array.  We may want to return a locative pointer to the leader,
;an array-pointer to the header, or a stack-group pointer to the header.
XFSHSA	(JUMP-EQUAL M-E A-ZERO XFSHA2)			;Jump if %FIND-STRUCTURE-HEADER
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) READ-MEMORY-DATA XFSHA3)
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))	;Pick up leader length
	(CHECK-PAGE-READ)
	((M-TEM) ADD READ-MEMORY-DATA (A-CONSTANT 2))	;and end up returning ptr to leader hdr
	((M-A) SUB M-A A-TEM)
	((M-A) Q-POINTER M-A)		;Prevent garbage data-type in M-A upon return
XFSHA1	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-LOCATIVE)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

;Return a pointer to the header, with data-type DTP-ARRAY-POINTER or DTP-STACK-GROUP
XFSHA2	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL (LSH ART-STACK-GROUP-HEAD ARRAY-TYPE-SHIFT)))
			XFSHSG)
XFSHA3	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-ARRAY-POINTER)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

XFSHSG	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-STACK-GROUP)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

XFSHSI	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-INSTANCE)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

XFSHS-BFWD
	((M-A VMA-START-READ) Q-POINTER READ-MEMORY-DATA)	;BODY-FORWARD -> HEADER-FORWARD
	(CHECK-PAGE-READ)
XFSHS-HFWD
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)	;HEADER-FORWARD -> new header
	(DISPATCH Q-DATA-TYPE READ-MEMORY-DATA D-FSHS)	;DISPATCH ON TYPE OF THAT HEADER,
							; M-A STILL POINTS AT OLD ONE
       (CALL ILLOP)					;SHOULDN'T XCT-NEXT, SHOULD BE HEADER!

XFSHSH	(DISPATCH (LISP-BYTE %%HEADER-TYPE-FIELD) READ-MEMORY-DATA D-FSHSH)

XFSHSHN	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

XFSHSHF	(POPJ-AFTER-NEXT (M-TEM) (A-CONSTANT (EVAL DTP-FEF-POINTER)))
       ((M-T) DPB M-TEM Q-DATA-TYPE A-A)

XFSHSHAL
	(JUMP-NOT-EQUAL M-E A-ZERO XFSHA1)	;Jump if %FIND-STRUCTURE-LEADER
	((M-TEM) (LISP-BYTE %%ARRAY-LEADER-LENGTH) READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT (M-A) ADD M-A A-TEM)	;OFFSET FROM LEADER TO HEADER
       ((M-T) Q-POINTER M-A (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))

;;; Given the address of the base of a structure, return information on its size.
;;; Note that if given the address of an array header, the leader (if any) is
;;; not counted, but if given the address of the leader, the leader is
;;; counted.  I.e. nothing before the given address is counted.
;;; In the case of an RPLACD-forwarded list, the 2 words pointed to by the
;;; forwarding-pointer are counted, and the forwarding-pointer itself isn't.
;;; Inputs:  address in MD
;;; Outputs: M-3 number of boxed Q's, M-4 number of unboxed Q's following those,
;;;	     A-SINF-PAD number of those Q's which need not be copied (pdl's only).
;;;	     A-SINF-PDL-BASE usually 0, else pointer to base of structure.
;;;		The scavenger, in its finite wisdom, uses this.
;;;		The value of this is garbage if not called from the scavenger.
;;;	     M-K map data, mainly for representation type
;;;	     M-K<31> = 1 if this is a list which ends in an rplacd-forwarding
;;; Clobbers: M-A, M-B, M-T, usual page-fault things.
;;; The type field of VMA is zero throughout this section.
;;; This routine MAY NOT call the transporter, since it is invoked by the
;;; transporter.  Otherwise the transporter's variables and flag could be
;;; clobbered, and the possibility of micro-stack overflow would arise.
;;; Note that an illegal pointer to oldspace can be left in the VMA.

;;; This entry saves M-A, M-B, M-T for the scavenger and sets A-SCAV-COUNT, A-SCAV-SKIP
SCAV-STRUCTURE-INFO
	((A-SCAV-SAVE-A) M-A)	;Shouldn't use pdl buffer since may be computing pdl size
	((A-SCAV-SAVE-B) M-B)
	((A-SCAV-SAVE-T) M-T)
	((A-SCAV-PDL-BASE) Q-POINTER MD)	;Could get moved into A-SINF-PDL-BASE
	(CALL-XCT-NEXT STRUCTURE-INFO)
       ((A-SINF-PDL-BASE) (A-CONSTANT 0))
	((A-SCAV-COUNT) SUB M-3 A-SINF-PAD)
	((A-SCAV-SKIP) ADD M-4 A-SINF-PAD)
	((M-T) A-SCAV-SAVE-T)
	(POPJ-AFTER-NEXT (M-B) A-SCAV-SAVE-B)
       ((M-A) A-SCAV-SAVE-A)

STRUCTURE-INFO
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits
	((M-K) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)	;FOR DISPATCH BELOW, AND
						; RETURNED TO CALLER.  NOTE 0 IN SIGN BIT.
	((VMA-START-READ) Q-POINTER MD)		;FETCH FIRST WORD
	(CHECK-PAGE-READ)
	((M-3) (A-CONSTANT 0))			;INITIALIZE RETURN VALUES
	((A-SINF-PAD) (A-CONSTANT 0))
	(DISPATCH-XCT-NEXT (LISP-BYTE %%REGION-REPRESENTATION-TYPE) M-K D-SINF)
       ((M-4) (A-CONSTANT 0))

(LOCALITY D-MEM)
(START-DISPATCH 2 0)
D-SINF	(SINFL)					;0 LIST
	(SINFS)					;1 STRUCTURE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;2 NOT USED
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;3 NOT USED
(END-DISPATCH)

(START-DISPATCH 2 0)
D-SINFL	(INHIBIT-XCT-NEXT-BIT SINFL1)		;0 CDR-NORMAL
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;1 CDR-ERROR
	(INHIBIT-XCT-NEXT-BIT R-BIT)		;2 CDR-NIL
	(SINFL0)				;3 CDR-NEXT
(END-DISPATCH)

(LOCALITY I-MEM)

;STRUCTURE-INFO in list space.  First word has been read, zero in M-3, M-4, A-SINF-PAD.
;There are no unboxed or pad Q's.  Scan forward through memory counting boxed Q's
;May clobber only M-3 and usual page-fault things, due to other callers.
SINFL0	(CHECK-PAGE-READ)
SINFL	((M-3) ADD M-3 (A-CONSTANT 1))		;Count this Q as part of structure
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)	;Forward ends list, but counts as 2 Q's!
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER-FORWARD)) SINFL2)
	(DISPATCH Q-CDR-CODE READ-MEMORY-DATA D-SINFL) ;Check cdr code, loop if CDR-NEXT
       ((VMA-START-READ) ADD VMA (A-CONSTANT 1))

SINFL2	((M-K) DPB (M-CONSTANT -1) (BYTE-FIELD 1 31.) A-K) ;Set sign of M-K
SINFL1	(POPJ-AFTER-NEXT (M-3) ADD M-3 (A-CONSTANT 1))
       (NO-OP)

;STRUCTURE-INFO in structure space.  First word has been read, zero in M-3, M-4, A-SINF-PAD.
SINFS	(DISPATCH Q-DATA-TYPE READ-MEMORY-DATA D-SINFS)
       ((M-3) (A-CONSTANT 5))			;Symbol is easy, make it fast case

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-SINFS	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL
	(R-BIT)					;SYMBOL-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FIX
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTENDED-NUMBER
	(INHIBIT-XCT-NEXT-BIT SINFSH)		;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(INHIBIT-XCT-NEXT-BIT SINFS-HFWD)	;HEADER-FORWARD
	(INHIBIT-XCT-NEXT-BIT SINFS-BFWD)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-POINTER
	(INHIBIT-XCT-NEXT-BIT SINFSA)		;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SMALL-FLONUM 
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;INSTANCE
	(INHIBIT-XCT-NEXT-BIT SINFSI)		;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;DTP-BODY-FORWARD - find DTP-HEADER-FORWARD, count boxed Q's between
SINFS-BFWD
	((M-TEM) Q-POINTER READ-MEMORY-DATA)	;Address of header
	((M-TEM) SUB VMA A-TEM)			;- # Q's between here and there
	(CALL-GREATER-OR-EQUAL M-TEM A-ZERO ILLOP)
	((M-3) SUB M-3 A-TEM)			;Account for them, drop into header case
	((VMA) Q-POINTER READ-MEMORY-DATA)
;DTP-HEADER-FORWARD - include all DTP-BODY-FORWARD's that point here as unboxed Q's
SINFS-HFWD
	(CALL-XCT-NEXT XRGN1)			;M-T gets region number
       ((M-A) Q-POINTER VMA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-READ) ADD M-T A-V-REGION-ORIGIN)
	(CHECK-PAGE-READ)
	((M-3) ADD M-3 (A-CONSTANT 1))		;1 boxed Q for the header
	((M-B) SUB READ-MEMORY-DATA (A-CONSTANT 1))
	((VMA-START-READ) ADD M-T A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-READ)
	((M-A) Q-POINTER M-A (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-BODY-FORWARD)))
	((M-B) ADD READ-MEMORY-DATA A-B)
	((M-B) Q-POINTER M-B)			;Last valid address in region
	((VMA) Q-POINTER M-A)			;Address of header
SINFS-HFWD-0
	(POPJ-GREATER-OR-EQUAL VMA A-B)		;Ran off top of region
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL-XCT-NEXT M-TEM A-A SINFS-HFWD-0) ;This word part of this forwarded struc
       ((M-4) ADD M-4 (A-CONSTANT 1))		;So count it and keep looping
	(POPJ-AFTER-NEXT (M-4) SUB M-4 (A-CONSTANT 1))	;Counted an extra time
       (NO-OP)

;Given a read cycle on a location which could be in oldspace,
;this subroutine substitutes for the transporter by checking for a GC-forward.
;Bashes M-TEM
SINF-TRANS
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(POPJ-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-GC-FORWARD)))
	(JUMP-XCT-NEXT SINF-TRANS)
       ((VMA-START-READ) MD)

;DTP-INSTANCE-HEADER - get size from instance-descriptor
SINFSI	(CALL-XCT-NEXT SINF-TRANS)
       ((VMA-START-READ) ADD READ-MEMORY-DATA
		(A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-SIZE)))
	(POPJ-XCT-NEXT)
       ((M-3) Q-POINTER READ-MEMORY-DATA)

;DTP-HEADER - dispatch on subtype
SINFSH	(DISPATCH (LISP-BYTE %%HEADER-TYPE-FIELD) READ-MEMORY-DATA D-SINFSH)

(LOCALITY D-MEM)
(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)	;DISPATCH ON HEADER SUBTYPE
D-SINFSH(P-BIT ILLOP)	;%HEADER-TYPE-ERROR
	(SINF-FEF)	;%HEADER-TYPE-FEF
	(SINF-AL)	;%HEADER-TYPE-ARRAY-LEADER
	(P-BIT ILLOP)	;unused
	(SINF-FLO)	;%HEADER-TYPE-FLONUM
	(P-BIT ILLOP)	;%HEADER-TYPE-COMPLEX
	(SINF-BIG)	;%HEADER-TYPE-BIGNUM
	(SINF-RAT)	;%HEADER-TYPE-RATIONAL-BIGNUM
(REPEAT NHDUSD (P-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

SINF-FLO
	(POPJ-AFTER-NEXT (M-4) (A-CONSTANT 2))	;2 unboxed Q's
       (NO-OP)	

SINF-RAT
	(POPJ-AFTER-NEXT (M-3) (A-CONSTANT 3))	;Headers and two number pointers.
       (NO-OP)

SINF-BIG
	(POPJ-AFTER-NEXT
	 (M-4) BIGNUM-HEADER-LENGTH READ-MEMORY-DATA)
       ((M-4) ADD M-4 (A-CONSTANT 1))

SINF-FEF
	((M-3) (LISP-BYTE %%FEFH-PC-IN-WORDS) READ-MEMORY-DATA)	;Number of boxed words
	((VMA-START-READ) ADD VMA (A-CONSTANT (EVAL %FEFHI-STORAGE-LENGTH)))
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT (M-4) Q-POINTER READ-MEMORY-DATA)	;Total number of words
       ((M-4) SUB M-4 A-3)			;Number of unboxed words

SINF-AL	((M-3) (LISP-BYTE %%ARRAY-LEADER-LENGTH) READ-MEMORY-DATA)  ;Add in size of leader
	((VMA-START-READ) ADD VMA A-3)		;Reference header
	(CHECK-PAGE-READ)			;And drop into SINFSA

;DTP-ARRAY-HEADER - get info on array, depending on array-type
SINFSA	((M-A) Q-POINTER READ-MEMORY-DATA)	;Copy the array header
	((M-T) (LISP-BYTE %%ARRAY-NUMBER-DIMENSIONS) M-A)
	((M-B) (LISP-BYTE %%ARRAY-INDEX-LENGTH-IF-SHORT) M-A)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LONG-LENGTH-FLAG) M-A SINFSA1)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)	
	((M-T) ADD M-T (A-CONSTANT 1))
	((M-B) Q-POINTER READ-MEMORY-DATA)	;Long index length
	((VMA) SUB VMA (A-CONSTANT 1))
SINFSA1	;; M-T # header words, M-B index length, VMA address of header, M-A header
	(JUMP-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-A SINFSA-DISPLACED)
       ((M-3) ADD M-3 A-T)			;Count array header, dimension words as boxed
	(DISPATCH (LISP-BYTE %%ARRAY-TYPE-FIELD) M-A D-SINFSA)
       ((M-3) ADD M-3 A-B)			;POPJ-XCT-NEXT if Q-type array

SINFSA-DISPLACED
	(POPJ-AFTER-NEXT (M-3) ADD M-3 A-B)	;Displaced array, pretend type is Q
       (NO-OP)

SINFSA-1B
	(POPJ-AFTER-NEXT (M-B) ADD M-B (A-CONSTANT 37))
       ((M-4) (BYTE-FIELD 19. 5) M-B)

SINFSA-2B
	(POPJ-AFTER-NEXT (M-B) ADD M-B (A-CONSTANT 17))
       ((M-4) (BYTE-FIELD 20. 4) M-B)

SINFSA-4B
	(POPJ-AFTER-NEXT (M-B) ADD M-B (A-CONSTANT 7))
       ((M-4) (BYTE-FIELD 21. 3) M-B)

SINFSA-8B
	(POPJ-AFTER-NEXT (M-B) ADD M-B (A-CONSTANT 3))
       ((M-4) (BYTE-FIELD 22. 2) M-B)

SINFSA-16B
	(POPJ-AFTER-NEXT (M-B) ADD M-B (A-CONSTANT 1))
       ((M-4) (BYTE-FIELD 23. 1) M-B)

SINFSA-32B
	(POPJ-AFTER-NEXT NO-OP)
       ((M-4) M-B)

SINFSA-FLOAT
	(POPJ-AFTER-NEXT NO-OP)
       ((M-4) ADD M-B A-B)

;;; PDL's have the magic feature that stuff after the pdl pointer is not looked at
;;; Element 0 of a pdl's array leader is its stack group
;;; We have already counted whole size of pdl into M-3, still have to get A-SINF-PAD.
SINF-REGPDL
	(JUMP-XCT-NEXT SINF-PDL)
       ((M-A) (A-CONSTANT (EVAL (+ 2 SG-REGULAR-PDL-POINTER))))

SINF-BNDPDL
	((M-A) (A-CONSTANT (EVAL (+ 2 SG-SPECIAL-PDL-POINTER))))
SINF-PDL
	((VMA-START-READ) SUB VMA (A-CONSTANT 2))	;Get stack-group which owns pdl
	(CHECK-PAGE-READ)
	((A-SINF-PDL-BASE) A-SCAV-PDL-BASE)	;Remember that this is a pdl
	(CALL-XCT-NEXT SINF-TRANS)		;That might have been an oldspace ptr, so
       ((VMA-START-READ) MD)			; check header of stack-group for gc-fwd
	((M-TEM) Q-TYPED-POINTER VMA)		;Owning stack group
	(JUMP-EQUAL M-TEM A-QCSTKG SINF-OWN-PDL) ;Currently running, ptr in different place
SINF-NOT-OWN-PDL
	((VMA-START-READ) SUB VMA A-A)		;Get appropriate pdl pointer out of sg
	(CHECK-PAGE-READ)
	;; This looks like it could be bummed, but note that pdl-ptrs can be -1
	((M-TEM) ADD READ-MEMORY-DATA (A-CONSTANT 1))	;Index of lowest invalid location
	(POPJ-AFTER-NEXT 
	 (M-TEM) Q-POINTER M-TEM)		;Clear carry
       ((A-SINF-PAD) SUB M-B A-TEM)		;Rest of array is to be skipped

SINF-OWN-PDL
	;; If in middle of switching stack groups, pdl pointers in machine are not valid.
	;; We must have been called from the transporter, and this must be the sg we're
	;; switching to, since the one we're switching from cannot be in oldspace.
	(JUMP-IF-BIT-SET M-STACK-GROUP-SWITCH-FLAG SINF-NOT-OWN-PDL)
	;; If not switching stack groups, and this is the current stack group,
	;; use the pdl pointers in the machine rather than those in memory.
	(JUMP-EQUAL M-A (A-CONSTANT (EVAL (+ 2 SG-SPECIAL-PDL-POINTER))) SINF-OWN-BND-PDL)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-PDL-BUFFER-HEAD) ;mod-2000 arithmetic
	((M-TEM) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(POPJ-AFTER-NEXT (M-TEM) SUB M-TEM A-QLPDLO)	;relative pdl ptr
       ((A-SINF-PAD) M-A-1 M-B A-TEM)		;Rest of array is to be skipped

SINF-OWN-BND-PDL
	((M-TEM) A-QLBNDP)
	(POPJ-AFTER-NEXT (M-TEM) SUB M-TEM A-QLBNDO)	;relative pdl ptr
       ((A-SINF-PAD) M-A-1 M-B A-TEM)		;Rest of array is to be skipped

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-SINFSA
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY TYPE 0 NOT USED
	(INHIBIT-XCT-NEXT-BIT SINFSA-1B)	;BIT ARRAY
	(INHIBIT-XCT-NEXT-BIT SINFSA-2B)	;2 BIT ARRAY
	(INHIBIT-XCT-NEXT-BIT SINFSA-4B)	;4 BIT ARRAY
	(INHIBIT-XCT-NEXT-BIT SINFSA-8B)	;8 BIT ARRAY
	(INHIBIT-XCT-NEXT-BIT SINFSA-16B)	;16 BIT ARRAY
	(INHIBIT-XCT-NEXT-BIT SINFSA-32B)	;32 BIT ARRAY
	(R-BIT)					;Q ARRAY
	(R-BIT)					;LIST Q ARRAY
	(INHIBIT-XCT-NEXT-BIT SINFSA-8B)	;STRING ARRAY
	(R-BIT)					;STACK-GROUP HEAD
	(SINF-BNDPDL)				;BINDING-PDL
	(INHIBIT-XCT-NEXT-BIT SINFSA-16B)	;HALF-FIX
	(SINF-REGPDL)				;REG-PDL
	(INHIBIT-XCT-NEXT-BIT SINFSA-FLOAT)	;FLOAT
	(INHIBIT-XCT-NEXT-BIT SINFSA-32B)	;FPS-FLOAT
	(INHIBIT-XCT-NEXT-BIT SINFSA-16B)	;FAT-STRING
 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; These are macrocode interfaces to STRUCTURE-INFO
XSBOXSZ (MISC-INST-ENTRY %STRUCTURE-BOXED-SIZE)
	(CALL XFSL)				;Fix bug if given an array with a leader
	(CALL-XCT-NEXT STRUCTURE-INFO)
       ((MD) Q-POINTER M-T)
	((VMA) SETZ)				;Clear possible garbage in VMA
	(POPJ-AFTER-NEXT (M-3) SUB M-3 A-SINF-PAD) ;Don't count garbage off end of pdl as boxed
       ((M-T) Q-POINTER M-3 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XSTOTSZ (MISC-INST-ENTRY %STRUCTURE-TOTAL-SIZE)
	(CALL XFSL)				;Fix bug if given an array with a leader
	(CALL-XCT-NEXT STRUCTURE-INFO)
       ((MD) Q-POINTER M-T)
	((VMA) SETZ)				;Clear possible garbage in VMA
	(POPJ-AFTER-NEXT (M-3) ADD M-3 A-4)
       ((M-T) Q-POINTER M-3 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;;; FLIPPER

;%GC-FLIP region.  Flips specified region, converting newspace to oldspace.
; Then goes over everything in the machine and makes sure it
; doesn't point to old-space.  If the region is T, all newspace and copyspace regions
; are done.
; Usually reclaim oldspace at some point before calling this function.
; To do a list of areas, just apply this to their regions one at a time, paying
; the penalty of extra checking of stuff in the machine for old-space-ptr;
; this is necessary due to problems with transporting of a list argument
; to this function, and anyway makes the microcode simpler.
XFLIP (MISC-INST-ENTRY %GC-FLIP)
	((A-GC-FLIP-READY) A-V-NIL)		;Due to creation of new old-space regions
	((A-CONS-WORK-DONE) SETZ)		;Reset work counters and make them equal
	((A-SCAV-WORK-DONE) SETZ)
	((A-TV-CURRENT-SHEET) A-V-NIL)		;Must recompute sheet data
	((A-GC-GENERATION-NUMBER) M+A+1 M-ZERO A-GC-GENERATION-NUMBER)
	((A-SCONS-CACHE-AREA) SETZ)		;Clear cache
	((A-LCONS-CACHE-AREA) SETZ)		;Clear cache
	((M-K) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Region spec
	((M-TEM) Q-DATA-TYPE M-K)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XFLIP4) ;Single region
	;Do all areas.  We do this by looking through the region-tables
	;for new-space and copy-space, since all REGION-BITS slots are guaranteed filled-in,
	;while the area tables are less structured.
	((M-K) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS)))
XFLIP1	((VMA-START-READ) ADD M-K A-V-REGION-BITS)
	(CHECK-PAGE-READ)
	((M-TEM) (LISP-BYTE %%REGION-SPACE-TYPE) READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL %REGION-SPACE-NEW)) XFLIP3)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL %REGION-SPACE-COPY)) XFLIP3)
XFLIP2	(JUMP-GREATER-THAN-XCT-NEXT M-K A-ZERO XFLIP1)
       ((M-K) SUB M-K (A-CONSTANT 1))
;Having done the flipping, now get rid of all pointers to old-space in the machine.
;"The machine" is M-ZR through M-K, A-VERSION through A-END-Q-POINTERS, pdl buffer,
;A-PDL-BUFFER-VIRTUAL-ADDRESS, A-QLBNDO, etc.
;In order to avoid bugs with storing GC-FORWARDING pointers into the pdl buffer
;and the like, we use the stack-group-switch mechanism to save the state of the machine
;then load it back with transporting.
XFLIPW	(CALL-XCT-NEXT SGLV)		;Save state, don't swap variables
       ((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 1 6) A-SG-STATE)
;Now transport the magic A-memory variables, which constitute the root of the world.
	((VMA) (A-CONSTANT (EVAL (+ 400 %SYS-COM-TEMPORARY)))) ;Pretend was read from here
	((M-E) (A-CONSTANT (A-MEM-LOC A-VERSION)))
XFLIPW2	((OA-REG-HIGH) DPB M-E OAH-A-SRC A-ZERO)
	((MD) A-GARBAGE)		;A-GARBAGE IS LOCATION 0@A
	(DISPATCH TRANSPORT-AC MD)
	((OA-REG-LOW) DPB M-E OAL-A-DEST A-ZERO)
	((A-GARBAGE) MD)
	(JUMP-NOT-EQUAL-XCT-NEXT M-E (A-CONSTANT (A-MEM-LOC A-END-Q-POINTERS)) XFLIPW2)
       ((M-E) ADD M-E (A-CONSTANT 1))
;Now restore the stack-group, which got copied back there someplace.
	(CALL SGENT)			;Restore state
	(POPJ-AFTER-NEXT (A-SG-STATE)	;Leave A-SG-STATE unchanged
		DPB M-TEM (LISP-BYTE %%SG-ST-CURRENT-STATE) A-SG-STATE)
       ((M-T) A-V-NIL)

XFLIP3	(JUMP-XCT-NEXT XFLIP2)
       (CALL XFLIP5)

XFLIP4	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XFLIPW)))
	((VMA-START-READ) ADD M-K A-V-REGION-BITS)
	(CHECK-PAGE-READ)
XFLIP5	((M-TEM) (A-CONSTANT (EVAL %REGION-SPACE-OLD)))	;Change to oldspace, clear meta bit,
	((A-TEM1) ANDCA MD				; and clear scavenge-enable
		(A-CONSTANT (PLUS (BYTE-MASK %%REGION-OLDSPACE-META-BIT)
				  (BYTE-MASK %%REGION-SCAVENGE-ENABLE))))
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-TEM (LISP-BYTE %%REGION-SPACE-TYPE) A-TEM1)
	(CHECK-PAGE-WRITE)
	(JUMP-XCT-NEXT UPDATE-REGION-PHT)	;Fix map, page table
       ((M-D) A-V-NIL)				;Don't change swap-status

;;; BRANCH INSTRUCTION

QIBRN	(DISPATCH-XCT-NEXT M-INST-DEST BRDTAB)	;DISP ON BRANCH TYPE
       ((M-B) M-INST-ADR-*2+X)			;M-B = OFFSET IN BYTES, LOW BIT INDETERMINATE
						;NOTE THAT THE LC HARDWARE IGNORES THE LOW BIT
						;AND READS IT BACK AS ZERO IN HALFWORD MODE

;HERE WHEN YOU'VE DECIDED TO BRANCH
QBRALW	(CALL-IF-BIT-SET (BYTE-FIELD 1 9) M-B QBRLZ1)  ;EXTEND SIGN IF NECESSARY
QBRLZ2	(POPJ-AFTER-NEXT			;NOTE, MUST CHANGE LC IN SAME CYCLE AS POPJ
	  (LOCATION-COUNTER) ADD LOCATION-COUNTER A-B)
       (NO-OP)					;THIS CYCLE DOES VMA<-LC, START-READ

;BRANCH DELTA NEGATIVE
QBRLZ1	(POPJ-LESS-THAN-XCT-NEXT M-B (A-CONSTANT 1776))	;RETURN TO QBRLZ2 UNLESS LONG BRANCH
       ((M-B) SELECTIVE-DEPOSIT (M-CONSTANT -1)
		(BYTE-FIELD 22. 10.) A-B)	;EXTEND SIGN
;DOUBLE-LENGTH BRANCH, LONG OFFSET IS IN SECOND HALFWORD
	(DISPATCH ADVANCE-INSTRUCTION-STREAM)
	((M-B) (BYTE-FIELD 17. 37) ;SAME TRICK AS WITH M-INST-ADR-*2+X. 
			M-INST-BUFFER INSTRUCTION-STREAM)
	(POPJ-AFTER-NEXT			;RETURN TO QBRLZ2, XCT NEXT IF EXTEND SIGN
	  POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 16.) M-B)
       ((M-B) SELECTIVE-DEPOSIT (M-CONSTANT -1)
		(BYTE-FIELD 15. 17.) A-B)

QBRNL	((M-K) Q-TYPED-POINTER M-T)		;BRANCH ON NIL
	(JUMP-EQUAL M-K A-V-NIL QBRALW)

;HERE WHEN YOU'VE DECIDED NOT TO BRANCH
QBRNOT	(POPJ-LESS-THAN M-B (A-CONSTANT 1776))	;CHECK FOR DOUBLE LENGTH INSTRUCTION
	(DISPATCH ADVANCE-INSTRUCTION-STREAM)
	(POPJ)

QBRNNL	((M-K) Q-TYPED-POINTER M-T)		;BRANCH ON NOT NIL
	(JUMP-NOT-EQUAL M-K A-V-NIL QBRALW)
	(POPJ-LESS-THAN M-B (A-CONSTANT 1776))	;CHECK FOR DOUBLE LENGTH INSTRUCTION
	(DISPATCH ADVANCE-INSTRUCTION-STREAM)   ;DUPLICATED AS MINOR SPEED BUM.
	(POPJ)

QBRAT	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-ATOM)	;BRANCH ON ATOM
	 (JUMP QBRNOT)
	(JUMP QBRALW)

QBRNAT	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-ATOM)	;BRANCH ON NOT-ATOM
	 (JUMP QBRALW)
	(JUMP QBRNOT)

QBRNLP	((M-K) Q-TYPED-POINTER M-T)		;BR NIL, POP IF NOT
	(JUMP-EQUAL M-K A-V-NIL QBRALW)
	(JUMP-XCT-NEXT QBRNOT)
       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)

QBRNNP	((M-K) Q-TYPED-POINTER M-T)		;BR NOT NIL, POP IF
	(JUMP-NOT-EQUAL M-K A-V-NIL QBRALW)
	(JUMP-XCT-NEXT QBRNOT)
       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)

;;; NON-DESTINATION GROUP 1
;   E IN VMA, C(E) IN M-T, MOSTLY EXIT BY PUTTING RESULT ON STACK

;GET TWO PDL ARGUMENTS, FIRST TO M-1, SECOND TO M-2
FXGTPP	((M-T) C-PDL-BUFFER-POINTER-POP)	;GET 2ND ARG, DROP THROUGH

;GET ADDR ARG IN M-2, PDL ARG IN M-1, ERROR UNLESS BOTH FIXNUMS
FIXGET		(ERROR-TABLE RESTART FIXGET)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		;GET PDL ARG
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 0 FIXGET)
   (ERROR-TABLE ARG-POPPED 0 PP M-T)
	((M-1) C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART FIXGET0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) Q-DATA-TYPE M-T TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM M-T 1 FIXGET0)
   (ERROR-TABLE ARG-POPPED 0 PP M-T)
FIXGET-1
	((OA-REG-HIGH) BOXED-SIGN-BIT M-T)		;SIGN EXTEND (MUNG M SOURCE)
	((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)
	(POPJ-AFTER-NEXT
	 (OA-REG-HIGH) BOXED-SIGN-BIT M-1)		;SIGN EXTEND
       ((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-1)

;;; Numeric instructions are with all of the other numeric code.

;FIXNUM EXPONENTIATION ROUTINE.
;M-3 HOLDS THE EXPONENT, AND GETS SHIFTED AND TESTED.
;M-1 HOLDS THE FIRST ARG, SQUARED N TIMES.
;M-T HOLDS THE PARTIAL PRODUCTS

(ERROR-TABLE DEFAULT-ARG-LOCATIONS ^ PP PP)

XUPARROW (MISC-INST-ENTRY ^)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 1))	;POINT TO FIRST ARG
	((M-1) SELECTIVE-DEPOSIT C-PDL-BUFFER-INDEX Q-DATA-TYPE A-ZERO)
							;GET DATA TYPE OF BASE
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XUPOUT)
							;NOT FIXNUM TRAPS TO MACRO CODE
	((M-1) SELECTIVE-DEPOSIT C-PDL-BUFFER-POINTER Q-DATA-TYPE A-ZERO) ;DITTO FOR EXPONENT
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XUPOUT)
	((M-T) C-PDL-BUFFER-POINTER)			;THE EXPONENT
	(CALL-XCT-NEXT FIXGET-1)			;UNPACK THE FIXNUMS
       ((M-1) C-PDL-BUFFER-INDEX)			;AND THE BASE
	(JUMP-LESS-THAN M-2 A-ZERO XUP6)		;FIXNUM ^ -<FIXNUM> = 0 USUALLY
	((M-TEM) (A-CONSTANT 1))			;INITIALIZE RESULT
	(JUMP-EQUAL M-2 A-ZERO XUP4)			;ANYTHING ^ 0 = 1
	((M-3) M-2)					;SAVE THE EXPONENT
XUP1	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-3 XUP2)
	(CALL-XCT-NEXT MPY)				;M-1 TIMES M-TEM TO Q-R
       ((Q-R) M-TEM)
	((M-2) SELECTIVE-DEPOSIT Q-R (BYTE-FIELD 9 23.) A-2)	;DISCARDED BITS AND SIGN
							;M-TEM IS 32 BITS, BUT FIXED BIN(23,0)
	(JUMP-EQUAL-XCT-NEXT M-2 A-ZERO XUP2)		;JUMP IF POSITIVE NO OVERFLOW
       ((M-TEM) Q-R)					;PRODUCT BACK TO M-TEM
	(JUMP-NOT-EQUAL M-2 (A-CONSTANT -1) XUPOUT)	;DROP THROUGH IF OK NEG, ELSE OVFL
XUP2	((M-3) M-3 OUTPUT-SELECTOR-RIGHTSHIFT-1)	;(SETQ M-3 (ASH M-3 -1))
	(JUMP-EQUAL M-3 A-ZERO XUP4)			;IF ZERO, RESULT IS IN M-TEM
	(CALL-XCT-NEXT MPY)				;OTHERWISE COMPUTE NEXT POWER
       ((Q-R) M-1)					;I.E. Q-R GETS M-1 TIMES M-1
	((M-2) SELECTIVE-DEPOSIT Q-R (BYTE-FIELD 9 23.) A-2)	;DISCARDED BITS AND SIGN
	(JUMP-NOT-EQUAL M-2 A-ZERO XUPOUT)		;OVERFLOW (RESULT IS ALWAYS POSITIVE)
	(JUMP-XCT-NEXT XUP1)
       ((M-1) Q-R)					;(SETQ M-1 (* M-1 M-1))

;;; RESULT IS 0 UNLESS BASE (M-1) IS 0, -1, OR 1
XUP6	((M-TEM) M-ZERO)				;Return zero perhaps
	(JUMP-GREATER-THAN M-1 (A-CONSTANT 1) XUP4)
	(JUMP-LESS-THAN M-1 (A-CONSTANT -1) XUP4)
	(CALL-EQUAL M-1 (A-CONSTANT 0) TRAP)		;0 ^ negative power is an error
	    (ERROR-TABLE DIVIDE-BY-ZERO)
	((M-TEM) M-1)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-2 XUP4)	;-1 ^ odd negative power is -1
	((M-TEM) (A-CONSTANT 1))			;-1 ^ even negative power is 1
	;drop into XUP4
;;; RETURN VALUE IN M-TEM AND POP OFF ARGUMENTS
XUP4	(POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
       ((M-T) DPB M-TEM Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;;; HERE CALL OUT TO MACRO CODE
XUPOUT	((M-A) C-PDL-BUFFER-POINTER-POP)	;The exponent
	((M-B) C-PDL-BUFFER-POINTER-POP)	;The base
	(CALL P3ZERO)				;Open micro-to-macro call
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCEXPT))	;Get fctn cell of EXPT-HELP
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the base
		Q-TYPED-POINTER M-B (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the exponent
		Q-TYPED-POINTER M-A (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-JUMP MMJCALL) (I-ARG 2))		;Call it tail-recursively

;;; NON-DESTINATION-GROUP-2
;   E IN VMA, C(E) IN M-T

;THESE COMPARE C(E) TO TOP OF STACK, POP,
; AND LEAVE T OR NIL IN M-T IN LIEUE OF SETTING INDICATORS

XMEQ (MISC-INST-ENTRY M-EQ)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMEQ					;MC-LINKAGE
QIEQ	((M-2) Q-TYPED-POINTER M-T)
	((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(JUMP-NOT-EQUAL M-1 A-2 XFALSE)
  (MISC-INST-ENTRY TRUE)
XTRUE	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)
       (NO-OP)

;Numeric comparisons are off with the rest of the numeric stuff.
;THESE MODIFY THE CONTENTS OF THEIR EFFECTIVE ADDRESS

QISCDDR	(JUMP-XCT-NEXT STOCYC)
       (CALL QMDD)		;CDDR THE ARGUMENT

QISCDR	(JUMP-XCT-NEXT STOCYC)
       (CALL QMD)		;CDR THE ARGUMENT

QISM1	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;NO PASS-AROUND PATH ON PDL BUFFER
	(JUMP-XCT-NEXT STOCYC)			;STORES BACK WITH NO ASSUMPTIONS ABOUT VMA
       (CALL X1MNS)				;M-T GETS (1- PDL)
	
QISP1	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;NO PASS-AROUND PATH ON PDL BUFFER
	(JUMP-XCT-NEXT STOCYC)			;STORES BACK WITH NO ASSUMPTIONS ABOUT VMA
       (CALL X1PLS)				;M-T GETS (1+ PDL)

;;; NON-DESTINATION-GROUP-3
;   EFFECTIVE ADDRESS NOT YET COMPUTED, M-T NOT VALID.

QIPSHE	(DISPATCH-XCT-NEXT M-INST-REGISTER QADCM3)	;EFF ADR TO PDL AND POPJ
       ((M-1) M-INST-DELTA)

QISETN	(JUMP-XCT-NEXT STOCYC)
       ((M-T) A-V-NIL)

QISETZ	(JUMP-XCT-NEXT STOCYC)
       ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

QIBNDN	(CALL QBND1)		;SAVE PRESENT BINDING
	((M-T) A-V-NIL)		;AND RE-BIND TO NIL
QIBDN1	((M-T WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-E
		Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

QIBNDP	(CALL QBND1)		;SAVE PRESENT BINDING
	(JUMP-XCT-NEXT QIBDN1)	;AND REBIND TO POP(PDL)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

XUBI  (MISC-INST-ENTRY %USING-BINDING-INSTANCES)  ;One arg, a list of binding instances.
	(JUMP-XCT-NEXT QCLS1)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)

XBIND (MISC-INST-ENTRY BIND)
	((M-T) C-PDL-BUFFER-POINTER-POP)		;ARG 2, NEW VALUE TO GIVE
   (ERROR-TABLE RESTART XBIND)
	((M-ZR) Q-DATA-TYPE C-PDL-BUFFER-POINTER)	;ARG 1, POINTER TO CELL TO BIND
	(CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) TRAP)
   (ERROR-TABLE ARGTYP LOCATIVE PP 0 XBIND)
   (ERROR-TABLE ARG-POPPED 0 PP M-T)
XBIND1	(JUMP-XCT-NEXT QIBDN1)
       (CALL QBND2)

QIBND 				;SAVE CURRENT CONTENTS, DON'T CHANGE
				;LEAVE M-E SET TO OLD CONTENTS (MAINLY FOR CDR CODE)
QBND1	(DISPATCH-CALL-XCT-NEXT M-INST-REGISTER QADCM6)	;EFF ADR TO PDL
       ((M-1) M-INST-DELTA)
QBND2	((VMA-START-READ M-B) C-PDL-BUFFER-POINTER-POP)	;FETCH CURRENT CONTENTS
	(CHECK-PAGE-READ)				;INT OK, HAVEN'T HACKED YET
;VMA and M-B have location being bound.  MD has current contents.
;Will return with old-value saved and Q-ALL-BUT-TYPED-POINTER in M-E,
;VMA and M-B updated to actual location bound (different if there is a ONE-Q-FORWARD).
QBND4	((M-1) ADD (M-CONSTANT 23.) A-QLBNDP)	;TEST P.C.E. (THIS M-CONST JUST HAPPENED TO
	((M-1) SUB M-1 A-QLBNDH)		; BE AROUND AT THE WRONG TIME).
	(CALL-IF-BIT-CLEAR BOXED-SIGN-BIT M-1 TRAP)
   (ERROR-TABLE PDL-OVERFLOW SPECIAL)		;M-1 SHOULD BE NEGATIVE AS 24-BIT QUANTITY
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)	;DON'T FOLLOW EXTERNAL-VALUE-CELL-PTR
;LOGICALLY SIMILAR CODE TO BELOW EXISTS AT QBSPCL
	((M-B) VMA)	;THIS INSTRUCTION MAKES IT FOLLOW FORWARDING POINTERS
			;AND BIND THAT FINALLY POINTED-TO CELL RATHER THAN THE
			;INTERNAL VALUE CELL.  THIS ONLY APPLIES WHEN IT IS
			;FORWARDED WITH DTP-ONE-Q-FORWARD RATHER THAN
			;DTP-EXTERNAL-VALUE-CELL-POINTER
	;M-E can be an invisible pointer, so don't save typed pointer part.
	((M-E) SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER
		 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	((M-1 WRITE-MEMORY-DATA) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-IF-BIT-SET-XCT-NEXT M-QBBFL QBND3)	 ;JUMP IF NOT FIRST IN BLOCK
       ((A-QLBNDP) ADD A-QLBNDP M-ZERO ALU-CARRY-IN-ONE) ;ADVANCE BINDING PDL PNTR
	((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1) Q-FLAG-BIT A-1)
	((M-QBBFL) DPB (M-CONSTANT -1) A-FLAGS)
QBND3	((VMA-START-WRITE) A-QLBNDP)		;STORE PREV CONTENTS
	(CHECK-PAGE-WRITE)			;HAVE INCRD A-QLBNDP, NO SEQ BRK
	((A-QLBNDP) ADD A-QLBNDP M-ZERO ALU-CARRY-IN-ONE)
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) Q-POINTER M-B	;LOCATIVE PNTR TO BOUND LOCN
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	((VMA-START-WRITE) A-QLBNDP)		;STORE POINTER TO BOUND CELL
	(CHECK-PAGE-WRITE)			;NO SEQ BRK, BIND NOT REALLY FINISHED
	(POPJ-AFTER-NEXT GC-WRITE-TEST)	;NOTE, POPJ MUST BE DELAYED BECAUSE CANNOT START WRITE
       ((VMA) M-B)		;AND INSTRUCTION FETCH SIMULTANEOUSLY.

;SPECIAL KLUDGEY ADDRESS ROUTINE FOR BIND.  ALWAYS INDIRECTS ONE LEVEL.
;RETURNS WITH ADDRESS ON PDL.
QBAFE	((M-1) M-INST-ADR)			;FULL DELTA
	((PDL-BUFFER-INDEX) M-AP)		;0(AP) -> FEF
	((VMA-START-READ) ADD C-PDL-BUFFER-INDEX A-1)
	(CHECK-PAGE-READ)  
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)	;ONLY TRANSPORT, DON'T DO INVZ
	((M-ZR) Q-DATA-TYPE READ-MEMORY-DATA)	;MAKE SURE IT WAS AN EVCP
	(POPJ-AFTER-NEXT			;AND RETURN LOCATIVE ON PDL
	 (C-PDL-BUFFER-POINTER-PUSH) DPB READ-MEMORY-DATA
		Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
			;NO PASS-AROUND PATH ON PDL-BUFFER
       (CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER)) ILLOP)

;;; DESTINATION HANDLERS
;   DATA TO STORE IN M-T

;THESE DESTINATIONS ARE NOW HANDLED BY THE INSTRUCTION FOLLOWING THE DESTINATION DISPATCH
;QMDDN		;NEXT (ARG)
;QMDDS		;STACK

;;; DESTINATION NEXT-LIST

MISC-TO-LIST
	(CALL 0)				;CALL MISC FUNCTION, DROP INTO QMDDNL
QMDDNL	((VMA-START-READ) C-PDL-BUFFER-POINTER)	;PTR TO NEXT PLACE IN LIST
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE)	;GET RANDOM BITS FROM PLACE STORING TO
	    SELECTIVE-DEPOSIT READ-MEMORY-DATA
		Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(CALL-XCT-NEXT QCDR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;CDR TO NEXT PLACE IN LIST
	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-ATOM)
	(POPJ-AFTER-NEXT			;NOT THROUGH WITH LIST
	 (C-PDL-BUFFER-POINTER-PUSH) M-T)
	(NO-OP)
	((M-C) DPB C-PDL-BUFFER-POINTER-POP	;THROUGH, GET ORIGINAL DESTINATION
		(LISP-BYTE %%LP-CLS-DESTINATION) A-ZERO)
	(JUMP-XCT-NEXT QIMOVE-EXIT)
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;POINTER TO HEAD OF LIST

;;; DESTINATION LAST

MISC-TO-LAST
	(CALL 0)				;CALL MISC FUNCTION, DROP INTO QMDDL
QMDDL	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))

;;;ACTIVATE PENDING CALL
QMRCL	(CALL-IF-BIT-SET M-TRAP-ON-CALLS TRAP)
    (ERROR-TABLE CALL-TRAP)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-IPMARK)	;COUNT ARGUMENTS
	((M-R) PDL-BUFFER-INDEX)		;M-R PASSES ARG COUNT TO CALLED FCTN
;Can someone add a comment saying what is wrong with
;just storing the result of the subtraction in M-R?
	((PDL-BUFFER-INDEX M-S) A-IPMARK)	;GET FEF POINTER POINTER
	((M-A) C-PDL-BUFFER-INDEX)		;M-A := FUNCTION TO CALL
	(DISPATCH Q-DATA-TYPE M-A D-QMRCL)	;DISPATCH ON DATA TYPE
       (CALL QLLV)				;DOES LINEAR LEAVE IF NECC.

;CONVERT PDL BUFFER ADDRESS IN M-K TO VIRTUAL ADDRESS IN M-K WITH LOCATIVE
; DATA-TYPE.  ANY REFERENCE VIRTUAL ADDRESS WHICH MAY BE IN PDL-BUFFER WILL TRAP,
; AND PAGE FAULT HANDLER WILL FIGURE OUT WHAT TO DO.

CONVERT-PDL-BUFFER-ADDRESS	
	((M-K) SUB M-K A-PDL-BUFFER-HEAD)
	(POPJ-AFTER-NEXT 
	 (M-K) DPB M-K (BYTE-FIELD 10. 0)	;ASSURE POSITIVE OFFSET IN CASE OF WRAPAROUND
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       ((M-K) ADD M-K A-PDL-BUFFER-VIRTUAL-ADDRESS)

; CONVERT VIRTUAL ADDRESS IN M-K INTO PDL-BUFFER-INDEX (ASSUMING IT REFERENCES THE CURRENT
;STACK GROUP).  NOTE THIS DOES NOT ASSURE THAT SECTION OF PDL SWAPPED IN OR ANYTHING.
;IF AND WHEN IT IS SWAPPED IN, HOWEVER, IT WILL OCUPPY THE INDICATED PDL-BUFFER ADDRESS.

GET-PDL-BUFFER-INDEX
	((M-K) SUB M-K A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(POPJ-AFTER-NEXT 
	 (M-K) ADD M-K A-PDL-BUFFER-HEAD)
       ((M-K) (BYTE-FIELD 10. 0) M-K)

;;; Calling a function of strange data-type.  Call the interpreter (APPLY-LAMBDA).

INTP1	;; Finish the frame for the interpreted function
	(CALL FINISH-ENTERED-FRAME)
	;; Get the arg-list.  Could be passed by FEXPR/LEXPR call, could be
	;; NIL, or could be a stack-list of the spread arguments.
	(JUMP-EQUAL M-R A-ZERO INTP1A)		;NO ARGS
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)	;TO VIRTUAL ADDRESS
       ((M-K) ADD A-ZERO M-AP ALU-CARRY-IN-ONE)
	((M-T) DPB M-K Q-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))	;ARG LIST PTR
INTP1B	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
	(JUMP-IF-BIT-SET (LISP-BYTE %%LP-CLS-ADI-PRESENT) C-PDL-BUFFER-INDEX INTP5) ;check ADI
INTP9	(CALL P3ZERO)					;Open micro-to-macro call block
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCAPL))	;Get function cell of APPLY-LAMBDA
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push it
	((PDL-BUFFER-INDEX) M-AP)
	((C-PDL-BUFFER-POINTER-PUSH) DPB C-PDL-BUFFER-INDEX	;Arg 1 = fcn being called
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T			;Arg 2 = arg list
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-JUMP MMJCALR) (I-ARG 2))		;Call to D-RETURN

INTP1A	(JUMP-XCT-NEXT INTP1B)
       ((M-T) A-V-NIL)			;ARG LIST IS NIL

;Sending ADI call to interpreter.  Check for LEXPR/FEXPR call.
INTP5	((PDL-BUFFER-INDEX M-I) SUB M-S (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH)))
	((M-B) PDL-BUFFER-POINTER)	;SAVE STACK POSITION OF LAST ARG (SEE INTP20)
INTP6	(DISPATCH (LISP-BYTE %%ADI-TYPE) C-PDL-BUFFER-INDEX INTP-ADI-DISPATCH)

(LOCALITY D-MEM)
(START-DISPATCH 3 INHIBIT-XCT-NEXT-BIT)
INTP-ADI-DISPATCH
	(P-BIT ILLOP)	;ERR
	(INTP7)		;MULTIPLE-VALUE-RETURN
	(INTP7)		;RESTART-PC
	(INTP20)	;FEXPR CALL
	(INTP20)	;LEXPR CALL
  (REPEAT 3 (P-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

INTP7	((PDL-BUFFER-INDEX M-I) SUB M-I (A-CONSTANT 1))
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT C-PDL-BUFFER-INDEX INTP9)
	(JUMP-XCT-NEXT INTP6)
       ((PDL-BUFFER-INDEX M-I) SUB M-I (A-CONSTANT 1))

;HERE IF LAST SLOT HAS REST ARG.
INTP20	((PDL-BUFFER-INDEX) M-B)	;SAVED PDL POSITION OF LAST ARG
	(JUMP-GREATER-THAN M-R (A-CONSTANT 1) INTP21)
	(JUMP-XCT-NEXT INTP7)		;FIRST (AND LAST) SLOT IS ALREADY LIST OF ARGS
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX) ;SO REPLACE LIST-OF-ARGS POINTER WITH IT.

;GET HERE IF FCTN WAS CALLED WITH BOTH SPREAD AND REST ARGS.  MUNGE CDR CODES
; OF LAST SPREAD ARG AND THE REST ARG TO FULL-NODE, THUS NCONC ING THEM TOGETHER.
INTP21	((C-PDL-BUFFER-INDEX) DPB C-PDL-BUFFER-INDEX Q-ALL-BUT-CDR-CODE 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR)))		;REST ARG
	((PDL-BUFFER-INDEX) SUB M-B (A-CONSTANT 1))		;TO POINT TO LAST SPREAD ARG
	(JUMP-XCT-NEXT INTP7)
       ((C-PDL-BUFFER-INDEX) DPB C-PDL-BUFFER-INDEX Q-ALL-BUT-CDR-CODE 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)))

REF-SUPPORT-VECTOR	
	((VMA-START-READ) ADD READ-I-ARG A-V-SUPPORT-ENTRY-VECTOR)
	(CHECK-PAGE-READ)
	(POPJ)

;;; This code is also duplicated at QLENTR and QME1 to save time.
;;; Make the new frame current, maintain pdl buffer, store arg count into frame.
FINISH-ENTERED-FRAME
	((PDL-BUFFER-INDEX) SUB M-S A-AP)	;Increment to M-AP (truncated to 10 bits)
	((M-PDL-BUFFER-ACTIVE-QS) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-ACTIVE-QS)
	(CALL-GREATER-THAN-XCT-NEXT M-PDL-BUFFER-ACTIVE-QS 
			   A-PDL-BUFFER-HIGH-WARNING PDL-BUFFER-DUMP)
       ((M-AP) M-S)
	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
       ((C-PDL-BUFFER-INDEX) DPB M-R (LISP-BYTE %%LP-ENS-NUM-ARGS-SUPPLIED)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;CALLING NUMBER AS FUNCTION
NUMBER-CALLED-AS-FUNCTION
	(CALL FINISH-ENTERED-FRAME)
	(CALL TRAP)
    (ERROR-TABLE NUMBER-CALLED-AS-FUNCTION M-A)

;CALLING SYMBOL AS FUNCTION
QMRCL1	((VMA-START-READ) ADD M-A		;GET FUNCTION CELL
		(A-CONSTANT 2))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((M-TEM) SUB MICRO-STACK-PNTR-AND-DATA-POP
		(A-CONSTANT 1))			;LOW 14 BITS GET ADDRESS OF QMRCL DISPATCHER
	((OA-REG-LOW) DPB M-TEM OAL-JUMP A-ZERO)
	(JUMP-XCT-NEXT 0)				;UNSKIP AND REDISPATCH
       ((C-PDL-BUFFER-INDEX M-A) READ-MEMORY-DATA)	;STORE NEW FROB TO CALL

;DON'T CALL QBND4 TO AVOID REFERENCING A-SELF VIA SLOW VIRTUAL-MEMORY PATH
BIND-SELF	;Bind SELF to M-A
	((M-TEM) ADD (M-CONSTANT 23.) A-QLBNDP)
	((M-TEM) SUB M-TEM A-QLBNDH)
	(CALL-IF-BIT-CLEAR BOXED-SIGN-BIT M-TEM TRAP)
	    (ERROR-TABLE PDL-OVERFLOW SPECIAL)
	((M-TEM WRITE-MEMORY-DATA) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-SELF)
	(JUMP-IF-BIT-SET-XCT-NEXT M-QBBFL BIND-SELF-1)
       ((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1) Q-FLAG-BIT A-TEM) ;START NEW BINDING BLOCK
	((M-QBBFL) DPB (M-CONSTANT -1) A-FLAGS)
BIND-SELF-1
	((VMA-START-WRITE) A-QLBNDP)	;STORE PREVIOUS CONTENTS
	(CHECK-PAGE-WRITE)		;NO SEQ BRK HERE
	((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	((A-SELF) M-A)
	((WRITE-MEMORY-DATA)		;LOCATIVE POINTER TO BOUND LOCATION
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)
				  LOWEST-A-MEM-VIRTUAL-ADDRESS
				  (A-MEM-LOC A-SELF))))
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-QLBNDP)
       (CHECK-PAGE-WRITE)

;Calling an instance as a function.  Bind SELF to it, bind its instance-variables
;to its value slots, then call its handler function.
CALL-INSTANCE
	(CALL BIND-SELF)
	((VMA-START-READ) M-A)		;Get instance header
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE-HEADER)) TRAP)
		(ERROR-TABLE DATA-TYPE-SCREWUP DTP-INSTANCE-HEADER)
	((M-A) VMA)			;Possibly-forwarded instance is where inst vars are
	((M-C) Q-POINTER READ-MEMORY-DATA	;Get address of instance-descriptor
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	((VMA-START-READ) ADD M-C (A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-BINDINGS)))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-T A-V-NIL CALL-INSTANCE-3)	;() => no bindings
	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (CALL TRAP)			;Other cases not implemented yet
		(ERROR-TABLE DATA-TYPE-SCREWUP %INSTANCE-DESCRIPTOR-BINDINGS)
	((M-D) Q-POINTER M-A
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER)))
;This loop depends on the fact that the bindings list is cdr-coded,
;and saves time and register-shuffling by not calling CAR and CDR.
;However, it does check to make sure that this assumption is true.
CALL-INSTANCE-1				;Bind them up
	((VMA-START-READ) M-T)		;Get locative to location to bind
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((VMA-START-READ M-B) READ-MEMORY-DATA)	;Get current binding
	(CHECK-PAGE-READ)
	((M-D) ADD M-D (A-CONSTANT 1))	;Points to next value slot
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-D A-TEM CALL-INSTANCE-2)	;Already there, avoid re-binding
	(CALL QBND4)			;Bind it up
	((WRITE-MEMORY-DATA-START-WRITE) Q-TYPED-POINTER M-D A-E)
	(CHECK-PAGE-WRITE-BIND)
CALL-INSTANCE-2
	(DISPATCH Q-CDR-CODE M-B D-CALL-INSTANCE)	;More bindings if this was CDR-NEXT
		(ERROR-TABLE DATA-TYPE-SCREWUP CDR-CODE-IN-INSTANCE-BINDINGS)
       ((M-T) ADD M-T (A-CONSTANT 1))
CALL-INSTANCE-3				;Next removes possible garbage pointer from M-T
	((VMA-START-READ M-T) ADD M-C (A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-FUNCTION)))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(JUMP-XCT-NEXT QCLS2)
       ((M-A) READ-MEMORY-DATA)

;CALLING ENTITY AS FUNCTION.  BIND SELF THEN TURN INTO CLOSURE CALL.
;DON'T CALL QBND4 TO AVOID REFERENCING A-SELF VIA SLOW VIRTUAL-MEMORY PATH
CALL-ENTITY
	(CALL BIND-SELF)
	((WRITE-MEMORY-DATA) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-METHOD-SUBROUTINE-POINTER)
	((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	((VMA-START-WRITE) A-QLBNDP)	;STORE PREVIOUS CONTENTS
	(CHECK-PAGE-WRITE)		;NO SEQ BRK HERE
	((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	((WRITE-MEMORY-DATA)		;LOCATIVE POINTER TO BOUND LOCATION
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)
				  LOWEST-A-MEM-VIRTUAL-ADDRESS
				  (A-MEM-LOC A-METHOD-SUBROUTINE-POINTER))))
	((VMA-START-WRITE) A-QLBNDP)
	(CHECK-PAGE-WRITE)
	((WRITE-MEMORY-DATA) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-METHOD-SEARCH-POINTER)
	((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	((VMA-START-WRITE) A-QLBNDP)	;STORE PREVIOUS CONTENTS
	(CHECK-PAGE-WRITE)		;NO SEQ BRK HERE
	((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	((WRITE-MEMORY-DATA)		;LOCATIVE POINTER TO BOUND LOCATION
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)
				  LOWEST-A-MEM-VIRTUAL-ADDRESS
				  (A-MEM-LOC A-METHOD-SEARCH-POINTER))))
	((VMA-START-WRITE) A-QLBNDP)
	(CHECK-PAGE-WRITE)		;DROP INTO QCLS
;CALLING CLOSURE AS FUNCTION
QCLS	(CALL-XCT-NEXT QCAR)		;SEQ BRK IS OK HERE, ISNT IT?
       ((M-T C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-A
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	((PDL-BUFFER-INDEX) M-S)
	((C-PDL-BUFFER-INDEX M-A) M-T)	;REPLACE CLOSURE WITH CLOSED FCTN
	(CALL-XCT-NEXT QCDR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)	;GET BACK CLOSURE AND CDR IT.
	(CALL QCLS1)
QCLS2	((PDL-BUFFER-INDEX) M-S)
	(DISPATCH Q-DATA-TYPE M-A D-QMRCL)
       (NO-OP)			;LEAVE, IF ANY, ALREADY DONE

QCLS1	(POPJ-EQUAL M-T A-V-NIL)	;Return if no bindings to do
	(CALL-XCT-NEXT QCAR)
       ((M-D) M-T)
	((M-B) M-T)			;Locn to bind
	(CALL-XCT-NEXT QCDR)
       ((M-T) M-D)
	(CALL-XCT-NEXT QCAR)		;Get new binding
       ((M-D) M-T)
	((VMA-START-READ) M-B)		;Get current binding
	(CHECK-PAGE-READ)
	((M-T) DPB M-T Q-POINTER        ;SWITCH DATA TYPE.. (DOING IT THIS WAY AVOIDS PROBLEMS
				        ;WITH CAR ABOVE AS WELL AS GENERALLY REDUCING 
					;PROFUSION OF FUNNY DATA TYPES)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER)))
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-T A-TEM QCLS3)	;Already there, avoid re-binding.  This saves on
					;special-pdl overflows in recursive message passing.
	(CALL QBND4)			;Bind it up
	((WRITE-MEMORY-DATA-START-WRITE) Q-TYPED-POINTER M-T A-E)
	(CHECK-PAGE-WRITE-BIND)
QCLS3	(CALL-XCT-NEXT QCDR)
       ((M-T) M-D)
	(JUMP QCLS1)


CALL-SELECT-METHOD
	(CALL-EQUAL M-R A-ZERO TRAP)	;NOT ENUF ARGS
  (ERROR-TABLE ZERO-ARGS-TO-SELECT-METHOD M-A)
	((PDL-BUFFER-INDEX) ADD M-S (A-CONSTANT 1))  ;FETCH MESSAGE KEY
	((M-C) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	((M-B) A-V-NIL)		;HOLDS CONSTANT ON M-SIDE, FOR EASY COMPARISON
	((M-T) DPB M-A Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(JUMP-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)) CSM-R)  ;RESUME
	((A-METHOD-SUBROUTINE-POINTER) A-V-NIL) ;"SUBROUTINE" CONTINUATION POINT, 
						;  OR NIL IF AT TOP LEVEL.
CSM-3	(CALL-XCT-NEXT QCAR)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
	((M-ZR) Q-DATA-TYPE M-T)		;M-T HAS ASSQ-LIST ELEMENT
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LIST)) CSM-1)   ;NOT METHOD-KEY, METHOD PAIR
	(CALL-XCT-NEXT QCAR)
       ((M-J) M-T)
	(JUMP-EQUAL M-T A-C CSM-2)		;FOUND IT
	((M-ZR) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LIST)) CSM-7)  ;ASSQ KEY A LIST, DO MEMQ ON IT
CSM-5	(CALL-XCT-NEXT QCDR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-ZR) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LIST)) CSM-3)
	(JUMP-NOT-EQUAL M-B A-METHOD-SUBROUTINE-POINTER CSM-8A)   ;IF IN SUBROUTINE, RETURN.
	(JUMP-NOT-EQUAL M-T A-V-NIL CSM-6)   ;NON-NIL TERMINATION IS SUPERCLASS POINTER.
  ; USE IT TO REPLACE DTP-SELECT-METHOD AND REINVOKE. THE TWO COMMON CASES ARE (1) THIS SYMBOL
  ; IS A SUPERCLASS POINTER AND IT'S FUNCTION CELL CONTAINS A DTP-SELECT-METHOD.  THE SEARCH
  ; WILL CONTINUE. (2)  THIS SYMBOL IS A LISP FUNCTION AND WILL GET CALLED IN THE USUAL WAY.
  ; THIS SERVES AS AN "OTHERWISE" CLAUSE.
	(CALL TRAP)			;SELECTED METHOD NOT FOUND
  (ERROR-TABLE SELECTED-METHOD-NOT-FOUND M-A M-C)

CSM-R	(JUMP-XCT-NEXT CSM-5)		    ;RESUME SEARCH AT SAVED POINT
       ((C-PDL-BUFFER-POINTER-PUSH) A-METHOD-SEARCH-POINTER)  ;PUT IT WHERE CSM-5 EXPECT IT.

CSM-7	((C-PDL-BUFFER-POINTER-PUSH) M-A)   ;ASSQ KEY A LIST, DO MEMQ ON IT
	(CALL-XCT-NEXT XMEMQ1)		    ; TAKES ARGS IN M-A, M-T
       ((M-A) M-C)
	(JUMP-EQUAL-XCT-NEXT M-T A-V-NIL CSM-5)
       ((M-A) C-PDL-BUFFER-POINTER-POP)    ;RESTORE M-A
CSM-2	((A-METHOD-SEARCH-POINTER) C-PDL-BUFFER-POINTER-POP) ;SAVE IN CASE METHOD SEARCH
							     ; IS RESUMED.
	(CALL-XCT-NEXT QCDR)		   ;FOUND DESIRED METHOD KEY.  GET ASSOC FCTN
       ((M-T) M-J)                         ; FROM ASSQ ELEMENT.
CSM-6	((PDL-BUFFER-INDEX) M-S)
	((C-PDL-BUFFER-INDEX M-A) SELECTIVE-DEPOSIT C-PDL-BUFFER-INDEX 	;CLOBBER INTO
		Q-ALL-BUT-TYPED-POINTER A-T)	; LP-FEF SLOT, REPLACING DTP-SELECT-METHOD
	(DISPATCH Q-DATA-TYPE M-A D-QMRCL)
       (NO-OP)

;GET HERE IF SELECT-METHOD LIST-ELEMENT NOT A CONS.
CSM-1	(CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) TRAP)
 (ERROR-TABLE SELECT-METHOD-GARBAGE-IN-SELECT-METHOD-LIST M-T)
   ;DO A ONE LEVEL "SUBROUTINE" CALL.  SAVE CONTINUATION POINTER IN M-B.
	(JUMP-NOT-EQUAL M-B A-METHOD-SUBROUTINE-POINTER CSM-8) ;ALREADY IN A SUBROUTINE, RETURN
	((A-METHOD-SUBROUTINE-POINTER) C-PDL-BUFFER-POINTER-POP)    ;SAVE CONTINUATION POINT.
	((VMA-START-READ) ADD M-T (A-CONSTANT 2))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((M-ZR) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) CSM-8A)  ;NO METHODS IN THIS CLASS,
								 ; IMMEDIATELY RETURN.
	(CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SELECT-METHOD)) TRAP)
 (ERROR-TABLE SELECT-METHOD-BAD-SUBROUTINE-CALL M-A)
	(JUMP-XCT-NEXT CSM-3)
       ((M-T) LDB Q-POINTER READ-MEMORY-DATA
		 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))

;HERE IF IN A SUBROUTINE, BUT DIDNT FIND IT.  RETURN FROM SUBROUTINE AND CONTINUE.
CSM-8	((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
CSM-8A	((C-PDL-BUFFER-POINTER-PUSH) A-METHOD-SUBROUTINE-POINTER)  ;PUT CONTINUATION
	(JUMP-XCT-NEXT CSM-5)				; WHERE IT IS EXPECTED.
       ((A-METHOD-SUBROUTINE-POINTER) A-V-NIL)		;AT TOP LEVEL AGAIN.

;;; Frame-leaving routines.  Save appropriate state in the call-block.

;"Micro" leave.  This is the same as the normal frame leave except that
;it checks for any micro-stack which needs to be saved; if so it is
;transferred to the special-pdl and %%LP-EXS-MICRO-STACK-SAVED is set.
;However, the top entry on the micro-stack is the return from MLLV and
;is not saved.
MLLV	((M-TEM) MICRO-STACK-POINTER)
	(JUMP-EQUAL M-TEM (A-CONSTANT 1) QLLV)	;Jump if nothing to save
	((M-2) MICRO-STACK-DATA-POP)	;Get real return off micro-stack
	((M-1) ADD (M-CONSTANT 40) A-QLBNDP)	;TEST P.C.E. (THIS M-CONST JUST HAPPENED TO
	((M-1) SUB M-1 A-QLBNDH)		; BE AROUND AT THE WRONG TIME).
	(CALL-IF-BIT-CLEAR BOXED-SIGN-BIT M-1 TRAP)
  (ERROR-TABLE PDL-OVERFLOW SPECIAL)		;M-1 should be negative as 24-bit quantity
	((M-Q) DPB (M-CONSTANT -1)	;First Q in block has flag bit
		Q-FLAG-BIT (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
MLLV1	((WRITE-MEMORY-DATA) MICRO-STACK-DATA-POP A-Q)	;Note- this involves a LDB operation
	((A-QLBNDP) ADD A-QLBNDP M-ZERO ALU-CARRY-IN-ONE) 
	((VMA-START-WRITE) A-QLBNDP)
	(CHECK-PAGE-WRITE)
	((M-TEM) MICRO-STACK-POINTER)	;Loop if not done
	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO MLLV1)
       ((M-Q) DPB (M-CONSTANT 0)	;Remaining Q's in block do not have flag bit
		Q-FLAG-BIT (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	((C-PDL-BUFFER-INDEX) IOR C-PDL-BUFFER-INDEX
		(A-CONSTANT (BYTE-MASK %%LP-EXS-MICRO-STACK-SAVED)))
	((MICRO-STACK-DATA-PUSH) M-2)	;Push back return address, drop into QLLV

;Leave a frame when we're running just macrocode, and no micro-stack needs to be saved.
;This routine saves and clears M-QBBFL, and saves the LC (even if the current frame
;is not a FEF frame; in that case it won't be looked at).
QLLV	;;*** Next 2 lines are temporary
	((M-TEM) MICRO-STACK-POINTER)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT 1) ILLOP)
	;;*** End of temporary code
	((PDL-BUFFER-INDEX) M-AP)		;Must save LC as half-word offset from FEF
	((A-TEM1) DPB C-PDL-BUFFER-INDEX (BYTE-FIELD 24. 2)
		 (A-CONSTANT 0))	;Shift 2 to align with location counter
	((M-TEM) SUB LOCATION-COUNTER A-TEM1 OUTPUT-SELECTOR-RIGHTSHIFT-1) ;Relative PC (hwds)
	;; Build exit-state word from PC, M-FLAGS, and previous contents
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	((A-TEM1) SELECTIVE-DEPOSIT C-PDL-BUFFER-INDEX (BYTE-FIELD 21 17) A-TEM)
			;CODE KNOWS THAT %%LP-EXS-EXIT-PC IS 0017
	(POPJ-AFTER-NEXT			;Save M-QBBFL then clear it
	 (C-PDL-BUFFER-INDEX) DPB M-FLAGS (LISP-BYTE %%LP-EXS-PC-STATUS) A-TEM1)
       ((M-FLAGS) SELECTIVE-DEPOSIT M-FLAGS M-FLAGS-EXCEPT-PROCESSOR-FLAGS A-ZERO)

;Get here when resuming a stack group whose active frame is a FEF.
;Restore M-INST-BUFFER and A-LOCALP.
;Dont restore M-FLAGS, etc, because that is handled by SG resume mechanism.
QLLENT	((M-A) DPB C-PDL-BUFFER-INDEX (BYTE-FIELD 24. 2)
		   (A-CONSTANT 0))  ;SET UP FROM M-AP.  SHIFT TO BYTE ALIGN
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	((A-TEM1) DPB C-PDL-BUFFER-INDEX (BYTE-FIELD 17 1) A-ZERO) ;RELATIVE PC IN BYTES
			;CODE KNOWS THAT %%LP-EXS-EXIT-PC IS 0017
	((LOCATION-COUNTER) ADD M-A A-TEM1)	;RESTORE LC
	((LOCATION-COUNTER) SUB LOCATION-COUNTER (A-CONSTANT 2))  ;IT IS NECESSARY THAT
			;M-INSTRUCTION-BUFFER ACTUALLY HAVE THE LAST INSTRUCTION
			;EXECUTED (IE NOT SUFFICIENT MERELY THAT THE CORRECT INSTRUCTION
			;WILL BE FETCHED NEXT TIME AROUND THE MAIN LOOP).  THIS IS BECAUSE
			;THE CURRENT MACRO-INSTRUCTION, WHICH MAY BE BEING REENTERED
			;IN THE MIDDLE, CAN DISPATCH AGAIN ON M-INSTRUCTION-STREAM
			;(TO GET THE DESTINATION IN MISC, FOR EXAMPLE).  THE SIMPLEST
			;WAY TO ASSURE THIS IS TO BACK UP THE LOCATION COUNTER AND
			;RE-ADVANCE IT.
	(DISPATCH ADVANCE-INSTRUCTION-STREAM)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	(POPJ-AFTER-NEXT			;START INSTRUCTION FETCH, GET LOCAL BLOCK
	 (M-TEM) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX)
       ((A-LOCALP) ADD M-AP A-TEM)

;DTP-U-ENTRY turned out not to be microcoded.  Snap it out, and try again.
QME2	((PDL-BUFFER-INDEX) M-S)
	((C-PDL-BUFFER-INDEX M-A) SELECTIVE-DEPOSIT C-PDL-BUFFER-INDEX 	;CLOBBER INTO
		Q-ALL-BUT-TYPED-POINTER A-T)	; LP-FEF SLOT, REPLACING DTP-U-ENTRY
	(DISPATCH Q-DATA-TYPE M-A D-QMRCL)
       (NO-OP)

;Enter micro-code entry function, called by XXX-TO-MACRO call.
; M-S has new value for M-AP, 0(M-S) is function being
; called (also in M-A), 1(M-S) is 1st arg, 2(M-S) is 2nd, etc.
; Calling function has been left.  M-R has number of args.

QME1	((M-D) Q-POINTER M-A A-AMCENT)
	(CALL-GREATER-OR-EQUAL M-D A-AMCENT TRAP)	;OUT OF RANGE
  (ERROR-TABLE MICRO-CODE-ENTRY-OUT-OF-RANGE M-D)
	((VMA-START-READ) ADD M-D A-V-MICRO-CODE-ENTRY-AREA)  ;IF THIS A FIXNUM, ITS
	(CHECK-PAGE-READ)           ;INDEX TO MICRO-CODE-SYMBOL-AREA.  OTHERWISE, FCTN
	((M-ERROR-SUBSTATUS) A-ZERO)
	((M-T) READ-MEMORY-DATA)    ;IS NOT REALLY MICROCODED NOW, AND THIS IS OTHER DEF.
	((M-TEM) Q-DATA-TYPE M-T)   ;IF SO, PUT THIS IN LP-FEF SLOT AND TRY AGAIN.
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) QME2)	;Jump if not microcoded
	((VMA-START-READ) ADD M-D A-V-MICRO-CODE-ENTRY-ARGS-INFO-AREA)
	(CHECK-PAGE-READ)
	((PDL-BUFFER-INDEX) SUB M-S A-AP)	;Increment to M-AP (truncated to 10 bits)
	((M-PDL-BUFFER-ACTIVE-QS) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-ACTIVE-QS)
	((M-TEM) (LISP-BYTE %%ARG-DESC-MIN-ARGS) READ-MEMORY-DATA)
	(CALL-GREATER-THAN M-TEM A-R SET-TOO-FEW-ARGS)
	((M-TEM) (LISP-BYTE %%ARG-DESC-MAX-ARGS) READ-MEMORY-DATA)
	(CALL-LESS-THAN M-TEM A-R SET-TOO-MANY-ARGS)
			;NOTE, THIS DOESN'T CHECK FOR LEXPR/FEXPR CALL.
			;WE DO PROVIDE FOR MICROCODED FUNCTIONS WITH VARIABLE NUMBER
			;OF ARGS, WHICH ARE LEGAL PROVIDED THEY ARE NOT MISC INSTRUCTIONS.
	(CALL-GREATER-THAN-XCT-NEXT M-PDL-BUFFER-ACTIVE-QS
			   A-PDL-BUFFER-HIGH-WARNING PDL-BUFFER-DUMP)
       ((M-AP) M-S)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	((C-PDL-BUFFER-INDEX) DPB M-R (LISP-BYTE %%LP-ENS-NUM-ARGS-SUPPLIED)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-READ) ADD M-T A-V-MICRO-CODE-SYMBOL-AREA)  ;M-T HAS DATA READ FROM
	(CHECK-PAGE-READ)			;MICRO-CODE-ENTRY-AREA
QME1A	(JUMP-NOT-EQUAL M-ERROR-SUBSTATUS A-ZERO QLEERR) ;SIGNAL WRONG NUMBER OF ARGS ERROR
	((OA-REG-LOW M-LAST-MICRO-ENTRY) DPB READ-MEMORY-DATA OAL-JUMP A-ZERO)
	;; Drop into MISC-TO-RETURN.  Calls the micro-entry function with a return
	;; address of QMDDR.  Upon return the frame will be flushed.
	;; This return address of QMDDR causes multiple-values to work right.

MISC-TO-RETURN
	(CALL 0)				;CALL MISC FUNCTION, DROP INTO QMDDR

;;; DESTINATION RETURN  value in M-T.  Q-ALL-BUT-TYPED-POINTER bits must be 0.
QMDDR	((M-TEM) Q-DATA-TYPE M-T)
	(CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-STACK-CLOSURE))
		    STACK-CLOSURE-RETURN-TRAP)
	(JUMP-NOT-EQUAL M-AP A-IPMARK QMDDR-THROW) ;CHECK FOR UNWIND-PROTECT
QMDDR0	(CALL-IF-BIT-SET M-QBBFL BBLKP)		;POP BINDING BLOCK (IF STORED ONE)
QMEX1	((PDL-BUFFER-INDEX) M-AP)		;Save returning function for metering
	((M-A) C-PDL-BUFFER-INDEX)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-C) C-PDL-BUFFER-INDEX)
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-TRAP-ON-EXIT) C-PDL-BUFFER-INDEX QMEX1-TRAP)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE)
			 C-PDL-BUFFER-INDEX
			 QMEX1-COPY)
	;;*** next 2 instructions are temporary
	((M-TEM) MICRO-STACK-POINTER)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT 0) ILLOP)
	;;*** end of temporary code
	((PDL-BUFFER-POINTER) SUB M-AP (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH))) ;FLUSH PDL
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-ADI-PRESENT) M-C QRAD1)  ;FLUSH ADDTL INFO
	((A-TEM1) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) M-C)
	(JUMP-EQUAL M-ZERO A-TEM1 QMXSG)	;RETURNING OUT TOP OF STACK-GROUP
	((M-TEM) SUB M-AP A-TEM1)		;COMPUTE PREV A-IPMARK
	((A-IPMARK) (BYTE-FIELD 10. 0) M-TEM)	;RESTORE THAT
	((A-TEM1) (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) M-C)
	((PDL-BUFFER-INDEX) SUB M-AP A-TEM1)	;RESTORE M-AP
	((M-AP) PDL-BUFFER-INDEX)		;THIS OPERATION MASKS M-AP TO 10 BITS.
	((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM1)
	;; Make sure frame being returned to is in the pdl buffer
	(CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS
			(A-CONSTANT PDL-BUFFER-LOW-WARNING) PDL-BUFFER-REFILL)
	;; Now restore the state of the frame being returned to.  We will restore
	;; the FEF stuff even if it's not a FEF frame, at the cost of a slight
	;; amount of time.
	(CALL-IF-BIT-SET (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
		M-METER-ENABLES METER-FUNCTION-EXIT)
	((M-A) Q-POINTER C-PDL-BUFFER-INDEX)	;FUNCTION RETURNING TO
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	((M-TEM) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX)
	((A-LOCALP) ADD M-AP A-TEM)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	((M-FLAGS) (LISP-BYTE %%LP-EXS-PC-STATUS) C-PDL-BUFFER-INDEX A-FLAGS)
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-EXS-MICRO-STACK-SAVED) C-PDL-BUFFER-INDEX QMMPOP)
	((M-TEM) DPB M-A (BYTE-FIELD 24. 2) (A-CONSTANT 0))	;FEF address in bytes
	((A-TEM1) DPB C-PDL-BUFFER-INDEX (BYTE-FIELD 17 1) A-ZERO)
			;CODE KNOWS THAT %%LP-EXS-EXIT-PC IS 0017
	((LOCATION-COUNTER) ADD M-TEM A-TEM1)
QIMOVE-EXIT	;Store into destination in M-C.  Could be D-MICRO
	(DISPATCH (LISP-BYTE %%LP-CLS-DESTINATION) M-C QMDTBD)
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

;Here from QMDDR if data type of M-T is DTP-STACK-CLOSURE.
;Copy the closure into the heap, in case the frame it is in
;is about to go away.
STACK-CLOSURE-RETURN-TRAP
	((MD) M-T)
	((VMA) A-MINUS-ONE)
	(GC-WRITE-TEST)
	(POPJ-XCT-NEXT)
       ((M-T) MD)

;;; M-A has the function returning from
METER-FUNCTION-EXIT
	((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-EXIT-EVENT)))
	((C-PDL-BUFFER-POINTER-PUSH) M-A)
	(JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER)
       ((A-METER-LENGTH) (A-CONSTANT 1))	;Number of meters pushed

;This is here so I can put breakpoints before and after trapping.
QMEX1-TRAP
	((VMA) A-ZERO)		;Avoid illop due to pointer not in any region,
	((M-Q) A-ZERO)		;which seems frequently to be true of VMA at QMEX1.
	(CALL TRAP)
    (ERROR-TABLE EXIT-TRAP)
	(POPJ)

;Copy the frame being exited into a list, if it has the bit set
;saying that an environment pointer points at it.
;The pointers to the frame are all in copied closure values of
;LEXICAL-ENVIRONMENT, and all of them are in cells pointed to
;by EVCPs located in the locals of this frame!  So we can find those
;pointers and make them point instead at the newly made list copy.

;Must preserve M-A and M-C, as well as M-T (the returned value).
;Assumes PDL-BUFFER-INDEX points at the %LP-ENTRY-STATUS word of the frame.
QMEX1-COPY
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	((M-K) LDB (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX)
;Get number of locals in frame, from the fef.
	((PDL-BUFFER-INDEX) M-AP)
	((VMA-START-READ) ADD C-PDL-BUFFER-INDEX (A-CONSTANT (EVAL %FEFHI-MISC)))
	(CHECK-PAGE-READ)
	((M-B) (LISP-BYTE %%FEFHI-MS-LOCAL-BLOCK-LENGTH) READ-MEMORY-DATA)
;M-B now has number of locals in the frame.
;Save it for much later (QMEX1-FIND-CLOSURES).
;Also get the total size of frame data to be copied.
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((M-B) ADD M-B A-K)	
;Cons a block that big, preserving the size in B.
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	(CALL-XCT-NEXT LCONS)
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-BACKGROUND-CONS-AREA)
	((M-B) C-PDL-BUFFER-POINTER-POP)
	((PDL-BUFFER-INDEX) M-AP)
	((VMA) M-T)
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
;Copy the args and locals into the newly consed list.
;M-B has # left to copy, PDL-BUFFER-INDEX has where to copy from,
;VMA has where to copy to.
QMEX1-COPY-LOOP
	((MD-START-WRITE) Q-TYPED-POINTER C-PDL-BUFFER-INDEX
			  (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
	(CHECK-PAGE-WRITE)
	((M-B) SUB M-B (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO QMEX1-COPY-LOOP)
       ((VMA) M+1 VMA)
;Store CDR-NIL into the last word.
	((VMA) SUB VMA (A-CONSTANT 1))
	((MD-START-WRITE) Q-TYPED-POINTER MD
			  (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(CHECK-PAGE-WRITE)
;Get back the pointer to this list and store it
;into the forwarded copies of all the stack closures in this frame.
;Find them by scanning thru the frame's locals.
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-AP)
;M-D and M-T get original stack frame and copy, both with DTP-LIST.
	((M-D) M-K Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	((M-T) LDB C-PDL-BUFFER-POINTER-POP Q-POINTER
	       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	((M-B) C-PDL-BUFFER-POINTER-POP)	;pop number of locals.
	((M-K) A-LOCALP)	;Get pdl index of first local.
QMEX1-FIND-FORWARDS
;Look for a local that is a forwarded list.
	((PDL-BUFFER-INDEX) M-K)
	((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER))
	     QMEX1-NOT-FORWARD)
;Yes, find where forwarded to,
;and if it points at our stack frame,
;make it point at the new copy instead.
	((VMA-START-READ) C-PDL-BUFFER-INDEX)
	(CHECK-PAGE-READ)
	((M-TEM) Q-TYPED-POINTER MD)
	(JUMP-NOT-EQUAL M-TEM A-D QMEX1-NOT-FORWARD)
	((MD-START-WRITE) DPB MD Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
QMEX1-NOT-FORWARD
	((M-B) SUB M-B (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO QMEX1-FIND-FORWARDS)
       ((M-K) M+1 M-K)
	(POPJ-XCT-NEXT)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

;Restore the micro-stack from the binding stack
QMMPOP	((C-PDL-BUFFER-INDEX) ANDCA C-PDL-BUFFER-INDEX	;Clear flag since flushing saved stack
		(A-CONSTANT (BYTE-MASK %%LP-EXS-MICRO-STACK-SAVED)))
	((M-S) MICRO-STACK-DATA-POP)		;Pop off return
QMMPO2	((VMA-START-READ) A-QLBNDP)		;No transport, known to be a fixnum
	(CHECK-PAGE-READ)			;Bind stack not really consistent, no seq brk
	((A-QLBNDP) SUB VMA (A-CONSTANT 1))
	((MICRO-STACK-DATA-PUSH) READ-MEMORY-DATA)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) ILLOP)
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT READ-MEMORY-DATA QMMPO2)	;Jump if not last
	((OA-REG-LOW) DPB M-S OAL-JUMP A-ZERO)
	(JUMP 0)

;GET HERE WHEN RETURNING OUT TOP OF STACK GROUP
QMXSG	((PDL-BUFFER-POINTER) M-AP)	;AVOID GROSS SCREW WHERE P-F ROUTINES GET CONFUSED
		;ABOUT WHATS IN THE PDL-BUFFER DUE TO FACT PDL-BUFFER-POINTER WAS DECREMENTED
		;TO BEFORE ACTIVE CALL BLOCK (IE 1777 IF SG STARTED OFF AT 0@P)
	((VMA) A-QCSTKG)	;ERROR CHECK TO SEE IF DELTA S SCREWWED OR SOMETHING
	((VMA-START-READ) SUB VMA
		 (A-CONSTANT (PLUS 2 (EVAL SG-INITIAL-FUNCTION-INDEX))))
	(CHECK-PAGE-READ)
	((A-SG-TEM) M-T)	;VALUE GETTING RETURNED
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((PDL-BUFFER-INDEX) ADD READ-MEMORY-DATA A-PDL-BUFFER-HEAD)
	(CALL-NOT-EQUAL PDL-BUFFER-INDEX A-AP ILLOP)
	(JUMP-XCT-NEXT SG-RETURN-2)	;RETURN THIS LAST VALUE AND GO TO EXHAUSTED STATE
       ((M-TEM) (A-CONSTANT (EVAL SG-STATE-EXHAUSTED)))


;STORE LAST VALUE IN ADI CALL, FLUSH ADI FROM PDL
;MAY CLOBBER ALL REGISTERS EXCEPT M-C and M-A
QRAD1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QRAD1R)))  ;DONT CARE IF THIS 
							; LAST OR NOT.
	((PDL-BUFFER-POINTER) M-AP)	;IN CASE WE SWITCH STACK GROUPS INSIDE MVR
	((M-K) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((PDL-BUFFER-INDEX) SUB M-K A-PDL-BUFFER-HEAD)
	((M-K) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(CALL-XCT-NEXT MVR)	;STORE THE LAST VALUE INTO MV IF ANY
       ((M-S) A-ZERO)
QRAD1R	((PDL-BUFFER-INDEX M-K) SUB M-AP
		(A-CONSTANT (PLUS 1 (EVAL %LP-CALL-BLOCK-LENGTH)))) ;FLUSH ADI FROM PDL
QRAD2	(POPJ-IF-BIT-CLEAR-XCT-NEXT Q-FLAG-BIT C-PDL-BUFFER-INDEX)
       ((PDL-BUFFER-POINTER) SUB M-K (A-CONSTANT 1))
	(JUMP-XCT-NEXT QRAD2)
       ((PDL-BUFFER-INDEX M-K) SUB M-K (A-CONSTANT 2))

XRETN (MISC-INST-ENTRY %RETURN-N)		;RETURN N VALUES, LAST ARG IS N.
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP NIL)
  (ERROR-TABLE ARG-POPPED 0 PP)
	((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP) ;NUMBER OF VALUES TO RETURN
XRETN1	((M-C) SUB M-C (A-CONSTANT 1))
	(JUMP-LESS-OR-EQUAL M-C A-ZERO XRETN2) ;LAST
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL
	((M-S) A-ZERO)
	(CALL-XCT-NEXT XRNVRPI)
       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-C)	;NEXT ARGUMENT SLOT
	(JUMP XRETN1)

XRET3 (MISC-INST-ENTRY %RETURN-3)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL
	((M-S) A-ZERO)
	(CALL-XCT-NEXT XRNVRPI)
       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
XRET2 (MISC-INST-ENTRY %RETURN-2)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL
	((M-S) A-ZERO)
	(CALL-XCT-NEXT XRNVRPI)
       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 1))
XRETN2	(JUMP-XCT-NEXT QMDDR-KLUDGE)			;RETURN LAST VALUE REGULAR WAY
       ((M-T) C-PDL-BUFFER-POINTER)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS RETURN-LIST M-A)

XRETURN-LIST (MISC-INST-ENTRY RETURN-LIST)	;This is always used with dest D-RETURN!
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
	(JUMP-EQUAL M-A A-V-NIL RETURN-NO-VALUES)
XRETURN-LIST1
	(CALL-XCT-NEXT QMD)			;Get cdr of list
       ((M-T) C-PDL-BUFFER-POINTER)
	(JUMP-EQUAL M-T A-V-NIL QTA)		;This is last value, return it to QMDDR
	(CALL-XCT-NEXT QTA)			;Not last value, but get the value
       ((M-C) M-T)				; and save tail of list
	;Next element in M-T, list tail in M-C.  Return the element.
	;Push the address to return to if have no more values wanted (return via QMDDR)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CPOPJ)))
	((M-S) A-ZERO)
	(CALL XRNVR)
	(JUMP-XCT-NEXT XRETURN-LIST1)
       ((C-PDL-BUFFER-POINTER-PUSH) M-C)

;Come here with a NIL on the top of the stack.  Calls XRNVR with the M-S flag,
;and either return returns to QMDDR.  We go through MVR so that in case the
;caller used a multiple-value-list, we will clobber the ADI so that QMDDR won't
;return any values into that list.
RETURN-NO-VALUES
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Value is NIL, and flush the stack.
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CPOPJ)))
	((M-S) (A-CONSTANT 1))
	(CALL XRNVR)
	(POPJ)

XRNV (MISC-INST-ENTRY RETURN-NEXT-VALUE)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;GO TO QMDDR IF LAST
						;  VALUE.
	((M-S) A-ZERO)
	(CALL-XCT-NEXT XRNVR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;FROB TO RETURN
   (ERROR-TABLE ARG-POPPED 0 M-T)
	(POPJ)					;NOT LAST VALUE, RETURN TO MAIN LOOP

;This will eventually be replaced with just QMDDR.  It is here temporarily
;due to the compiler compiling the returning misc instructions to wrong destination.
QMDDR-KLUDGE
	((M-TEM) MICRO-STACK-POINTER)
	(JUMP-EQUAL M-TEM A-ZERO QMDDR)
	(JUMP QMDDR-KLUDGE MICRO-STACK-PNTR-AND-DATA-POP)

;Return next value.  See comments below for info on special calling sequence.
;We search back through the call stack until we get to a frame with a destination
;other than D-RETURN.  We then check that frame to see if it has multiple-value ADI.
;For speed, we try to avoid taking page faults when referencing the pdl buffer.
;M-K will have the virtual address being referenced, MD its contents.
;M-S must have the flag for MVR (q.v.).
XRNVRPI	((M-T) C-PDL-BUFFER-INDEX)		;Return value from PDL[PI]
XRNVR	((M-K) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((PDL-BUFFER-INDEX) SUB M-K A-PDL-BUFFER-HEAD)
	((M-K) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-VIRTUAL-ADDRESS)
XRNVR1	(CALL MKCONT)				;Get this frame's call state
	((M-TEM) (LISP-BYTE %%LP-CLS-DESTINATION) MD)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT D-RETURN) XRNVR2)
	((M-TEM) (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) MD)	;Chain back to previous frame
	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO XRNVR1)
       ((M-K) SUB M-K A-TEM)
	(CALL ILLOP)				;Stack exhausted

XRNVR2	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%LP-CLS-ADI-PRESENT) MD XRNVX)	;Not doing mult vals
	(JUMP MVR)				;Go return multiple values from this frame

;MD gets contents of untyped virtual address in M-K, when likely to be in pdl buffer
;and known not to be off the top end of the pdl buffer.
MKCONT	(JUMP-LESS-THAN M-K A-PDL-BUFFER-VIRTUAL-ADDRESS MKCONT1)
	((M-TEM) SUB M-K A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-TEM A-PDL-BUFFER-HEAD)
       ((MD) C-PDL-BUFFER-INDEX)

MKCONT1	(POPJ-AFTER-NEXT (VMA-START-READ) M-K)
       (CHECK-PAGE-READ)

;Contents of untyped virtual address in M-K gets MD, when likely to be in pdl buffer
;and known not to be off the top end of the pdl buffer.
MKWRIT	(JUMP-LESS-THAN M-K A-PDL-BUFFER-VIRTUAL-ADDRESS MKWRIT1)
	((M-TEM) SUB M-K A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-TEM A-PDL-BUFFER-HEAD)
       ((C-PDL-BUFFER-INDEX) MD)

MKWRIT1	(POPJ-AFTER-NEXT (VMA-START-WRITE) M-K)
       (CHECK-PAGE-WRITE)

;Documentation on calling sequence for XRNVR/MVR:
;M-T has the value to be returned.
;M-K has virtual address of LPCLS Q for the frame from which value is to be returned.
;M-S has a flag which is 1 when we are returning no values; this only happens
; from (return-list nil).
;The calling sequence is hairy to implement the feature that if the callee returns
;a value and the caller does not want further values after that one, the function
;suddenly returns.
;There are two return addresses on the micro-stack.  If this was the last value
; expected, the first return is taken; if more values are expected the second
; return is taken.  In the return-next-value case the first return should be
; QMDDR, causing a sudden return.  In the QRAD1 case both returns should be the same,
; since we are returning anyway whether or not this is the last value.
; In any case, both returns are flushed from the stack.
;The sudden return works by storing the value in the block, as usual, and then
; going to QMDDR to get the stack unwound and all, BUT first clobbering the
; ADI type to be ADI-USED-UP-RETURN-INFO so that QMDDR won't store the value
; all over again.

;  ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC <THAT-WAS-LAST-VALUE-RETURN>)))
;  (CALL XRVNR)
;  ... STILL EXPECTING MORE VALUES

;Clobbers A-TEM1, M-I, M-J, M-S, M-R, M-K plus calls QRDR1 (which doesnt clobber any more)
;Plus calls CONS, which clobbers more.  Protects M-C and M-A but probably not anything else.

;At this point M-K has the virtual address of the LPCLS Q for the frame
;from which the value is to be returned, which is known to have ADI.
;Investigate that ADI to see if there is a multiple-value receiver.
MVR	;; Get address of highest word of ADI
	((M-K) SUB M-K (A-CONSTANT (EVAL (+ %LP-CALL-BLOCK-LENGTH %LP-CALL-STATE))))
MVR0	(CALL MKCONT)				;MD gets ADI Q
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) Q-DATA-TYPE MD TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE DATA-TYPE-SCREWUP ADI)
	((M-J) (LISP-BYTE %%ADI-TYPE) MD)
	(JUMP-NOT-EQUAL M-J (A-CONSTANT (EVAL ADI-RETURN-INFO)) MVR1)
	(DISPATCH-XCT-NEXT (LISP-BYTE %%ADI-RET-STORING-OPTION) MD D-MVR)
       ((M-I) (LISP-BYTE %%ADI-RET-NUM-VALS-EXPECTING) MD)

MVR1	(CALL-IF-BIT-CLEAR Q-FLAG-BIT MD ILLOP)	;Info out of phase
	(CALL-XCT-NEXT MKCONT)
       ((M-K) SUB M-K (A-CONSTANT 1))
	(JUMP-IF-BIT-SET-XCT-NEXT Q-FLAG-BIT MD MVR0) ;More
       ((M-K) SUB M-K (A-CONSTANT 1))
	;; No ADI, this the last value
XRNVX	((M-GARBAGE) MICRO-STACK-DATA-POP)	;Flush second return
	(POPJ)					;That was last value, take first return
	
;Indirect link.  Only allowed to indirect to something in the same pdl,
;so that MKCONT and MKWRIT can work.
MVRIND	(CALL-XCT-NEXT MKCONT)			;Get pointer to ADI to use
       ((M-K) SUB M-K (A-CONSTANT 1))
	(JUMP-XCT-NEXT MVR0)
       ((M-K) Q-POINTER MD)

;Store in block
MVRB	(CALL-LESS-OR-EQUAL M-I A-ZERO ILLOP)	;Returning too many values
	((M-I) SUB M-I (A-CONSTANT 1))
	((M-TEM) MD)				;Store back decremented values count
	((MD M-TEM) DPB M-I (LISP-BYTE %%ADI-RET-NUM-VALS-EXPECTING) A-TEM)
	(JUMP-NOT-EQUAL M-I A-ZERO MVRB0)	;If last val expected, clobber ADI.
	((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM)
MVRB0	(CALL MKWRIT)
	(CALL-XCT-NEXT MKCONT)			;Get storing pointer
       ((M-K) SUB M-K (A-CONSTANT 1))
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(CALL-XCT-NEXT MKWRIT)
       ((MD M-R) ADD MD (A-CONSTANT 1))
MVRB1	((VMA-START-READ) SUB M-R (A-CONSTANT 1))	;No transport, since writing and no
MVRB2	(CHECK-PAGE-READ)				;need to follow invisible pntrs here
	((WRITE-MEMORY-DATA-START-WRITE)	;Store the value
		SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)
        (CHECK-PAGE-WRITE)
	(JUMP-EQUAL M-I A-ZERO XRNVX)		;This was the last value expected.
	(POPJ-AFTER-NEXT GC-WRITE-TEST)		;More expected, or doing return and that was
       ((M-GARBAGE) MICRO-STACK-DATA-POP)	;last, take second return and flush first

;Cons up list
;2nd (lower) ADI word points to list tail.  Initially it is a locative
;to the location which will eventually hold the list of returned values,
;which should be initialized to NIL.
;After the first time, it is a list-pointer to the last cons in the list.
;XNCONS mustn't clobber M-C, M-I, M-R; QRDR1 mustn't clobber M-C or M-R.
MVRC	(JUMP-EQUAL M-S (A-CONSTANT 1) MVRC1)	;Returning no values?
	((M-I) ADD M-K				;Save address of prev ADI Q
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE) -1)))
	(CALL-XCT-NEXT XNCONS)			;Cons up a 2-Q cons, cdr NIL, to M-T
       ((C-PDL-BUFFER-POINTER-PUSH M-R) M-T)	;Save value returning, will be car
	(CALL-XCT-NEXT MKCONT)			;Get pointer to list tail
       ((M-K) Q-POINTER M-I)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((M-S) MD)				;Save pntr to list tail
	(CALL-XCT-NEXT MKWRIT)
       ((MD) M-T)				;Change pntr to new list tail
	(CALL QRDR1)				;RPLACD tail of list
	(POPJ-XCT-NEXT)				;More <infinite> values expected
       ((M-T) SETA A-R MICRO-STACK-PNTR-AND-DATA-POP)    ;Restore value being returned 
		;and flush first return. (PNTR-AND-DATA necc. to avoid a byte-op)

;Returning no values.  Don't affect list, and clobber ADI-TYPE so that when
;QRAD1 calls MVR, it won't affect the list either.
MVRC1	((M-TEM) MD)
	((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM)
	(CALL MKWRIT)
	(POPJ-XCT-NEXT)				;More <infinite> values expected.
       ((M-GARBAGE) MICRO-STACK-DATA-POP)

;;; THROW CODE (*THROW, *UNWIND-STACK)
;;; Register Conventions:
;;; A-CATCH-MARK is the function for which an open call is what we want (usually *CATCH)
;;; A-CATCH-TAG is the first argument to that function.  Except, T and 0 are special.
;;; A-CATCH-COUNT contains a count of active frames.  If this reaches zero, we resume
;;;  that frame instead of throwing farther.  If this is NIL, no count.
;;; A-CATCH-ACTION contains the "action", which is usually NIL, but can if non-NIL,
;;;  when the resumption point is reached, instead of resuming it is a function
;;;  (or a stack-group) which gets called with one argument, the value being thrown.
;;; M-T value being thrown

;;; Special *CATCH tags are:
;;;  NIL  CATCH-ALL
;;;  T    UNWIND-PROTECT.  The difference between UNWIND-PROTECT and CATCH-ALL
;;;	  is that UNWIND-PROTECT will always continue throwing.

;;; Special *THROW, *UNWIND-STACK tags are:
;;;  0    Return from function (like destination-return)
;;;  T    Throw all the way out the top of the stack-group.  In this case we
;;;	  bypass CATCH-ALLs.  This is used for unwinding "old" stack groups.
;;;	  This must be used in connection with a non-null A-CATCH-ACTION.
;;;  NIL  *CATCH returns NIL as the tag if no throw or return operation occurred.
;;; If the tag is neither T nor 0, we throw to the nearest catch with that tag,
;;; or UNWIND-PROTECT, or CATCH-ALL.

;;; *UNWIND-STACK is a generalized *THROW, used by the error handler and
;;; by UNWIND-PROTECT.  The first two arguments are the same as to *THROW.
;;; The third argument is a count; if this NIL things are the same as *THROW,
;;; otherwise if this many frames are passed we resume as if a catch had been found.
;;; The fourth argument, if non-NIL, means that instead of resuming when
;;; we find the point to throw to, we call that function with one argument,
;;; the second arg to *UNWIND-STACK.

XCATCH (MISC-INST-ENTRY *CATCH)		;ONLY GET HERE WHEN NO *THROW 
	(POPJ-AFTER-NEXT 		;*CATCH WHICH COMPLETES RETURNS NIL AS SECOND VALUE
	 (M-T) C-PDL-BUFFER-POINTER-POP) ;VALUE OF FROB
       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)

METER-FUNCTION-UNWIND
	((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-UNWIND-EVENT)))
	(JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER)
       ((A-METER-LENGTH) M-ZERO)	;Number of meters pushed

;;; This like *UNWIND-STACK but takes its args in the order value, tag, count, action
;;; and simply moves value to the destination if tag is NIL (normal exit from unwind-protect)
XUWPCON (MISC-INST-ENTRY %UNWIND-PROTECT-CONTINUE)
	((A-CATCH-ACTION) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((A-CATCH-COUNT) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Tag
	(POPJ-EQUAL-XCT-NEXT M-1 A-V-NIL)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Value
	((C-PDL-BUFFER-POINTER-PUSH) M-1)		;Clobbered by meter code
	(CALL-IF-BIT-SET (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
		M-METER-ENABLES METER-FUNCTION-UNWIND)
	(JUMP-XCT-NEXT XUWPCN1)				;Join *UNWIND-STACK
       ((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
					 *CATCH-U-CODE-ENTRY-/#)))

XUWSTK (MISC-INST-ENTRY *UNWIND-STACK)
   (ERROR-TABLE RESTART *UNWIND-STACK)
	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
		M-METER-ENABLES METER-FUNCTION-UNWIND)
	((A-CATCH-ACTION) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((A-CATCH-COUNT) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT XUWS0)
      ;((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
      ;					 *CATCH-U-CODE-ENTRY-/#)))

(ERROR-TABLE DEFAULT-ARG-LOCATIONS *THROW A-CATCH-TAG M-T)

XTHROW (MISC-INST-ENTRY *THROW)
   (ERROR-TABLE RESTART *THROW)
		;Note the following instruction is also XCT-NEXT'ed from above
	((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
					  *CATCH-U-CODE-ENTRY-/#)))
	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
		M-METER-ENABLES METER-FUNCTION-UNWIND)
	((A-CATCH-ACTION) A-V-NIL)
	((A-CATCH-COUNT) A-V-NIL)
XUWS0	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Value thrown
XUWPCN1	((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Tag
	(JUMP-EQUAL-XCT-NEXT M-1 A-V-TRUE XTHRW7)	  ;Tag of T means all the way
       ((A-CATCH-TAG) M-1)				  ; so don't check first
	(JUMP-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		XTHRW7)					  ;Tag of 0 also special
;DROPS THROUGH

;DROPS IN, or jumps back from XTHC5.
;Before actually going and munging anything, follow the open-call-block chain
;and find out whether the catch tag we're looking for actually exists.
;Register usage:
;  M-A	Virtual address of next call block (typeless) (either active or open)
;  M-B	Virtual address of next active call block (typeless)
;  M-C	Pdl buffer address of next call block (only low 10 bits valid)
;  M-D  Typeless virtual address of outermost active frame we are popping
;       that has the %%LP-CLS-TRAP-ON-EXIT bit set; or zero, if there is none.
;  M-1	arg into / result out of XTHCG
XTHC0	((M-D) A-ZERO)
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-AP)
	((M-B) Q-POINTER M-K)
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) A-IPMARK)
	((M-A) Q-POINTER M-K)
	((M-C) A-IPMARK)
	(JUMP-NOT-EQUAL M-A A-B XTHC2)			;JUMP IF FOUND OPEN CALL BLOCK
XTHC1	(CALL-XCT-NEXT XTHCG)				;GET CALL STATE Q
       ((M-1) ADD M-A (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-ZR) (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) M-1)
	(JUMP-EQUAL M-ZR A-ZERO XTHC-ERROR)	        ;REACHED END OF PDL DIDN'T FIND MARK.
	((M-B) SUB M-B A-ZR)
XTHC4	((M-ZR) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) M-1)
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-TRAP-ON-EXIT) M-1 XTHC-TRAP-LATER)
	((M-A) SUB M-A A-ZR)
	(JUMP-EQUAL-XCT-NEXT M-A A-B XTHC1)
       ((M-C) SUB M-C A-ZR)
XTHC2	(CALL-XCT-NEXT XTHCG)				;GET LPFEF Q
       ((M-1) M-A)
	(JUMP-NOT-EQUAL M-1 A-CATCH-MARK XTHC3)		;NO GOOD
	(CALL-XCT-NEXT XTHCG)
       ((M-1) ADD M-A (A-CONSTANT 1))			;GET FIRST ARG
	(JUMP-EQUAL M-1 A-CATCH-TAG XTHC5)		;FOUND THE ONE WE'RE LOOKING FOR,
							;IT'S NOW SAFE TO GO THROW FOR REAL.
	(JUMP-EQUAL M-1 A-V-NIL XTHC5)			;FOUND CATCH-ALL, THATS OK TOO.
XTHC3	(CALL-XCT-NEXT XTHCG)				;GET CALL STATE Q
       ((M-1) ADD M-A (A-CONSTANT (EVAL %LP-CALL-STATE)))
	(JUMP XTHC4)

XTHC5	(JUMP-EQUAL M-D A-ZERO XTHRW7)
	((M-A) A-CATCH-TAG)
	((M-B) A-CATCH-COUNT)
	((M-C) A-CATCH-ACTION)
	((M-E) A-CATCH-MARK)
	((M-D) DPB M-D Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	(CALL TRAP)
    (ERROR-TABLE THROW-EXIT-TRAP)
	;Restart after clearing the trap-on-exit bit
	;of all the frames we are exiting.
	((A-CATCH-TAG) M-A)
	((A-CATCH-COUNT) M-B)
	((A-CATCH-ACTION) M-C)
	((A-CATCH-MARK) M-E)
	(JUMP XTHC0)

;Keep track of the lowest stack frame that has the %%LP-CLS-TRAP-ON-EXIT bit set.
XTHC-TRAP-LATER
	(POPJ-XCT-NEXT)
	((M-D) M-A)

XTHC-ERROR
	((M-A) A-CATCH-TAG)
	((M-B) A-CATCH-COUNT)
	((M-C) A-CATCH-ACTION)
	(CALL TRAP)
   (ERROR-TABLE THROW-TAG-NOT-SEEN)	;The EH knows specially about this entry.
					;It knows the tag is in M-A, the value is in M-T,
					;the count is in M-B, and the action is in M-C.

;GET A WORD WHOSE UNTYPED VIRTUAL ADDRESS IS IN M-1.  FOR SPEED, ATTEMPTS
;TO FIGURE OUT IF IT IS IN THE PDL BUFFER AND IF SO GET IT DIRECTLY
;WITHOUT BOTHERING WITH PAGE TRAPS.  BASHES M-1 TO Q-TYPED-POINTER OF THE FETCHED DATA.
XTHCG	(JUMP-LESS-THAN M-1 A-PDL-BUFFER-VIRTUAL-ADDRESS XTHCG1)
	((M-1) SUB M-1 A-A)
	(POPJ-AFTER-NEXT (PDL-BUFFER-INDEX) ADD M-1 A-C)
       ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)

XTHCG1	((VMA-START-READ) M-1)
	(CHECK-PAGE-READ)			;WILL PROBABLY ALWAYS FAULT
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-1) Q-TYPED-POINTER READ-MEMORY-DATA)

;Here from QMDDR if there are open call blocks in this frame.  It could
;be an UNWIND-PROTECT, so we come here to check it out by doing a throw
;of the value being returned, to the tag 0.
QMDDR-THROW
	((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
					  *CATCH-U-CODE-ENTRY-/#)))
	((A-CATCH-ACTION) A-V-NIL)
	((A-CATCH-COUNT) A-V-NIL)
	((A-CATCH-TAG) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;0
		;drop into XTHRW7
;This is the main throw loop.  Come here for each frame.
XTHRW7	(JUMP-EQUAL-XCT-NEXT M-AP A-IPMARK XTHRW1) ;LAST FRAME ACTIVE, UNWIND IT
       ((M-R) A-V-NIL)				;GET NIL ON THE M SIDE FOR LATER
	((M-I PDL-BUFFER-INDEX) A-IPMARK)	;LAST FRAME OPEN, NOTE IT MUST ALREADY BE IN
						; PDL BUFFER, SINCE ENTIRE ACTIVE FRAME IS.
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	(JUMP-NOT-EQUAL M-A A-CATCH-MARK XTHRW2)	;THATS NOT WHAT LOOKING FOR
	((PDL-BUFFER-INDEX) ADD A-IPMARK M-ZERO ALU-CARRY-IN-ONE)
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	(JUMP-EQUAL M-A A-V-TRUE XTHRW4)	;FOUND UNWIND-PROTECT, RESUME IT
	((M-1) A-V-TRUE)
	(JUMP-EQUAL A-CATCH-TAG M-1 XTHRW2)	;IF UNWINDING ALL THE WAY, KEEP LOOKING
	(JUMP-EQUAL M-A A-V-NIL XTHRW4)		;FOUND CATCH-ALL, RESUME IT
	(JUMP-NOT-EQUAL M-A A-CATCH-TAG XTHRW2)	;DIDN'T FIND RIGHT TAG, KEEP LOOKING
;FOUND FRAME TO RESUME
XTHRW4	((PDL-BUFFER-INDEX) ADD M-I (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-B) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)	;PRESERVE FOR USE BELOW
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%LP-CLS-ADI-PRESENT) C-PDL-BUFFER-INDEX 
		XTHRW9)		;NO ADI, HAD BETTER BE DESTINATION RETURN
	((PDL-BUFFER-INDEX M-D) SUB M-I (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH)))
XTHRW3	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
		     Q-DATA-TYPE C-PDL-BUFFER-INDEX TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE DATA-TYPE-SCREWUP ADI)
	((M-A) (LISP-BYTE %%ADI-TYPE) C-PDL-BUFFER-INDEX)
	(JUMP-NOT-EQUAL M-A (A-CONSTANT (EVAL ADI-RESTART-PC)) XTHRW8)
	((M-J) (LISP-BYTE %%ADI-RPC-MICRO-STACK-LEVEL) C-PDL-BUFFER-INDEX)
	((PDL-BUFFER-INDEX) SUB M-D (A-CONSTANT 1))
	((M-E) Q-POINTER C-PDL-BUFFER-INDEX)	    ;Restart PC
	((PDL-BUFFER-INDEX) M-AP)
	((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
	;; To make *CATCH in a micro-compiled function work will require more hair
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FEF-POINTER)) ILLOP)
	;; Change frame's return PC to restart PC
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	((M-TEM) C-PDL-BUFFER-INDEX)
	((C-PDL-BUFFER-INDEX) DPB M-E (LISP-BYTE %%LP-EXS-EXIT-PC) A-TEM)
	;; Pop micro-stack back to specified level
XTHRW5	((M-ZR) MICRO-STACK-POINTER)		;INVOLVES A LDB OP
	(JUMP-EQUAL M-ZR A-J XTHRW6)
	(CALL-LESS-THAN M-ZR A-J ILLOP)		;Already popped more than that?
	((M-ZR) MICRO-STACK-DATA-POP)
	(JUMP-XCT-NEXT XTHRW5)
       (CALL-IF-BIT-SET %%-PPBSPC M-ZR BBLKP)

XTHRW6A	(CALL QUNBND)		;POP BINDING AND DROP THRU. CLOBBERS M-C.
 ;ON ENTRY HERE, M-D HAS PDL-BUFFER INDEX OF ADI-RESTART-PC ADI, OR -1 IF NONE.
XTHRW6	(JUMP-LESS-THAN M-D A-ZERO XTHRW6B)	;IF ENCOUNTERED *CATCH W/O ADI-RESTART-PC ADI,
			;DONT TRY TO HACK BIND STACK.  THIS CAN HAPPEN VIA INTERPRETED 
			;*CATCH S.  SINCE FRAME DESTINATION MUST BE D-RETURN,
			;NO NEED TO HACK BIND STACK ANYWAY.
	((PDL-BUFFER-INDEX) SUB M-D (A-CONSTANT 3))  ;MOVE BACK TO THE DATA Q 
		;PREVIOUS ADI BLOCK WHICH HAD BETTER BE AN ADI-BIND-STACK-LEVEL BLOCK
	((M-B) Q-POINTER C-PDL-BUFFER-INDEX)	;GET BIND-STACK-LEVEL
	(JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-B XTHRW6C)  ;SIGN EXTEND SINCE EMPTY STACK
	((M-B) SELECTIVE-DEPOSIT M-B Q-POINTER (A-CONSTANT -1)) ;IS LEVEL OF -1
XTHRW6C	((M-J) A-QLBNDP)		; COMPUTE CURRENT RELATIVE STACK LEVEL
	((M-J) SUB M-J A-QLBNDO)
	(CALL-LESS-THAN M-J A-B ILLOP)	;ALREADY OVERPOPPED?
	(JUMP-NOT-EQUAL M-J A-B XTHRW6A) ;EVIDENTLY A BIND WAS DONE WITHIN THIS BLOCK ..
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))  ;STORE BACK QBBFL
	((M-TEM) C-PDL-BUFFER-INDEX)		;WHICH MAY HAVE BEEN CLEARED
	((C-PDL-BUFFER-INDEX) DPB M-FLAGS (LISP-BYTE %%LP-EXS-PC-STATUS) A-TEM)
XTHRW6B	((PDL-BUFFER-INDEX) SUB M-I A-AP)	;THIS EFFECTIVELY CANCELS WHAT WILL BE
	((M-PDL-BUFFER-ACTIVE-QS) ADD		; DONE AT QMEX1
		PDL-BUFFER-INDEX A-PDL-BUFFER-ACTIVE-QS)
	((M-AP) (BYTE-FIELD 10. 0) M-I)		;SIMULATE ACTIVATING CATCH FRAME
	((M-TEM) A-CATCH-TAG)			;IF THROWING OUT TOP, DON'T STOP ON
	(JUMP-EQUAL M-TEM A-V-TRUE XTHRW6D)	; UNWIND-PROTECT, GO WHOLE WAY
	(JUMP-NOT-EQUAL A-CATCH-ACTION M-R XUWR2);ACTION NON-NIL => DONT REALLY RESUME
						; EXECUTION, CALL FUNCTION INSTEAD.
XTHRW6D	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1)))
	((M-S) A-ZERO)
	(CALL XRNVR)				;FIRST VALUE IS VALUE THROWN (STILL IN M-T)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1)))
	((M-S) A-ZERO)
	(CALL-XCT-NEXT XRNVR)			;SECOND VALUE IS TAG
       ((M-T) A-CATCH-TAG)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1)))
	((M-S) A-ZERO)
	(CALL-XCT-NEXT XRNVR)			;THIRD VALUE IS COUNT
       ((M-T) A-CATCH-COUNT)
	(JUMP-XCT-NEXT QMEX1)			;FOURTH VALUE IS ACTION
       ((M-T) A-CATCH-ACTION)

XTHRW8	(CALL-IF-BIT-CLEAR Q-FLAG-BIT C-PDL-BUFFER-INDEX ILLOP)
	((PDL-BUFFER-INDEX M-D) SUB M-D (A-CONSTANT 1))
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT C-PDL-BUFFER-INDEX XTHRW9)
	((PDL-BUFFER-INDEX M-D) SUB M-D (A-CONSTANT 1))
	(JUMP-XCT-NEXT XTHRW3)
       ((M-D) (BYTE-FIELD 10. 0) M-D)	;ASSURE M-D POSITIVE SO CHECK AT XTHRW6 WINS.

;RAN OUT OF ADI.  THE SAVED DESTINATION HAD BETTER BE D-RETURN OR ERROR.  THIS
;CAN HAPPEN MAINLY THRU INTERPRETED CALLS TO *CATCH.
XTHRW9	((PDL-BUFFER-INDEX) ADD M-I (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-C) (LISP-BYTE %%LP-CLS-DESTINATION) C-PDL-BUFFER-INDEX)
	(CALL-NOT-EQUAL M-C (A-CONSTANT D-RETURN) ILLOP)
	((M-D) (M-CONSTANT -1))		;SET FLAG THAT RESTART-PC ADI NOT FOUND, SO
				;BIND PDL HACKERY NOT ATTEMPTED.
	((M-S) (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) C-PDL-BUFFER-INDEX)
	((M-I) SUB M-I A-S)
	(JUMP-XCT-NEXT XTHRW5)
       ((M-J) M-ZERO)				;Flush whole micro-stack

;Skip this open frame
XTHRW2	((PDL-BUFFER-INDEX) ADD M-I (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-ZR) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) C-PDL-BUFFER-INDEX)
	((M-ZR) SUB M-I A-ZR)
	(JUMP-XCT-NEXT XTHRW7)
       ((A-IPMARK) (BYTE-FIELD 10. 0) M-ZR)	;ASSURE NO GARBAGE IN A-IPMARK

;Unwind an active frame
XTHRW1	((M-TEM) MICRO-STACK-POINTER)		;INVOLVES A LDB OP
	(JUMP-EQUAL M-TEM A-ZERO XTHRW1A)	;FLUSH MICRO-STACK
	((M-TEM) MICRO-STACK-DATA-POP)
	(JUMP-XCT-NEXT XTHRW1)
       (CALL-IF-BIT-SET %%-PPBSPC M-TEM BBLKP)

XTHRW1A	((M-TEM) A-CATCH-TAG)			;CHECK FOR THROW TAG OF 0
	(JUMP-EQUAL M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		QMDDR0)				;YES, RETURN FROM THIS FRAME
	(JUMP-EQUAL M-R A-CATCH-COUNT XTHRW1B)	;JUMP IF NO COUNT
	((A-CATCH-COUNT Q-R) ADD A-CATCH-COUNT (M-CONSTANT -1))
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 23.) Q-R XUWR1)  ;REACHED MAGIC COUNT, RESUME BY RETURNING
XTHRW1B	(CALL-IF-BIT-SET M-QBBFL BBLKP)  	;POP BINDING-BLOCK IF FRAME HAS ONE
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((A-TEM1) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) C-PDL-BUFFER-INDEX)
	((M-ZR) SUB M-AP A-TEM1)		;COMPUTE PREV A-IPMARK
	((A-IPMARK) (BYTE-FIELD 10. 0) M-ZR)	;RESTORE THAT
	((A-TEM1) (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) C-PDL-BUFFER-INDEX)
	((PDL-BUFFER-POINTER) SUB M-AP (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH))) ;FLUSH PDL
	(JUMP-EQUAL A-TEM1 M-ZERO XUWR2)	;OFF THE BOTTOM OF THE STACK, GO CALL THE
						; ACTION, HAVING THROWN ALL THE WAY
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-ADI-PRESENT)
		C-PDL-BUFFER-INDEX QRAD1R)	;FLUSH ADDTL INFO
	((PDL-BUFFER-INDEX) SUB M-AP A-TEM1)	;RESTORE M-AP
	((M-AP) PDL-BUFFER-INDEX)	;THIS MASKS M-AP TO 10 BITS
	((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM1)
	(CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS 
			(A-CONSTANT PDL-BUFFER-LOW-WARNING) PDL-BUFFER-REFILL)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	((M-FLAGS) (LISP-BYTE %%LP-EXS-PC-STATUS) C-PDL-BUFFER-INDEX A-FLAGS)
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-EXS-MICRO-STACK-SAVED) C-PDL-BUFFER-INDEX QMMPOP)
						;RESTORE USTACK FROM BINDING STACK
	(JUMP XTHRW7)

;HERE WHEN THE COUNT RUNS OUT
XUWR1	(CALL-NOT-EQUAL A-CATCH-ACTION M-R XUWR2)	;CALL FUNCTION?
	(JUMP QMDDR0)	;CAUSE ACTIVE FRAME TO RETURN VALUE

;HERE WHEN ACTION NOT NIL, IT IS A FUNCTION TO BE CALLED.
XUWR2	(CALL P3ZERO)
	((C-PDL-BUFFER-POINTER-PUSH) A-CATCH-ACTION)
	((C-PDL-BUFFER-POINTER-PUSH) Q-TYPED-POINTER M-T
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-JUMP MMCALL) (I-ARG 1))
;IF THROWING OUT WHOLE WAY, SHOULDN'T RETURN.  MICROSTACK MUST BE CLEAR
;IN THIS CASE OR MLLV WILL STORE IT IN THE WRONG FRAME, BECAUSE OF THE
;ANOMALOUS CASE OF M-AP = M-S.  IF NOT THROWING OUT WHOLE WAY, FUNCTION
;MAY RETURN AND ITS VALUE WILL BE RETURNED FROM THE *CATCH BY THE EXIT
;TO QMDDR0 AT XUWR1.

;;; STUFF FOR CALLS WITH NUMBER OF ARGUMENTS NOT KNOWN AT COMPILE TIME
;;; AND FOR MAKING CALLS WITH SPECIAL ADI OF DIVERS SORTS

XOCB  (MISC-INST-ENTRY %OPEN-CALL-BLOCK)  ;<FCTN><ADI-PAIRS><DEST>
	((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(JUMP-EQUAL M-A A-ZERO CBM0)		;If no ADI, push regular call block
	((PDL-BUFFER-INDEX) PDL-BUFFER-POINTER)	;ADI, fix the flag bits
	((M-A) ADD M-A A-A)			;2 QS per ADI pair
XOCB1	((C-PDL-BUFFER-INDEX) IOR C-PDL-BUFFER-INDEX
		(A-CONSTANT (BYTE-MASK Q-FLAG-BIT)))
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-INDEX (A-CONSTANT 1))
	(JUMP-NOT-EQUAL-XCT-NEXT M-A (A-CONSTANT 2) XOCB1)
       ((M-A) SUB M-A (A-CONSTANT 1))
	(CALL-XCT-NEXT CBM0)		;Push call block but take dest from M-C
       ((C-PDL-BUFFER-INDEX)		;Clear flag bit in last wd of ADI
		ANDCA C-PDL-BUFFER-INDEX (A-CONSTANT (BYTE-MASK Q-FLAG-BIT)))
	(POPJ-AFTER-NEXT		;Fix the ADI-present flag
	 (PDL-BUFFER-INDEX) ADD PDL-BUFFER-POINTER (A-CONSTANT (EVAL %LP-CALL-STATE)))
       ((C-PDL-BUFFER-INDEX) IOR C-PDL-BUFFER-INDEX
		(A-CONSTANT (BYTE-MASK %%LP-CLS-ADI-PRESENT)))
	
XAOCB (MISC-INST-ENTRY %ACTIVATE-OPEN-CALL-BLOCK)
	;;*** this code is temporary to get around compiler bug
	((M-TEM) MICRO-STACK-POINTER)
	(JUMP-EQUAL M-TEM A-ZERO XAOCB0)
	(JUMP XAOCB MICRO-STACK-PNTR-AND-DATA-POP)

XAOCB0	;;*** end of temporary code
	(JUMP-XCT-NEXT QMRCL)		;Fix CDR-code of last arg then activate call
       ((C-PDL-BUFFER-POINTER) DPB C-PDL-BUFFER-POINTER
		Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
		
;;; I would be rather surprised if this is ever called!!  Foo, I'm surprised!
XPUSH (MISC-INST-ENTRY %PUSH)
	(POPJ-AFTER-NEXT 
	  (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
       (NO-OP)

XAPDLR (MISC-INST-ENTRY %ASSURE-PDL-ROOM)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;NUMBER OF PUSHES PLANNING TO DO
	((PDL-BUFFER-INDEX) M-A-1 PDL-BUFFER-POINTER A-AP)	;CURRENT FRAME SIZE
	(POPJ-AFTER-NEXT (M-2) ADD PDL-BUFFER-INDEX A-1)	;PROPOSED NEW FRAME SIZE
       (CALL-GREATER-THAN M-2 (A-CONSTANT 370) XAPDLR1)	;NOTE FUDGE FACTOR OF 10 SINCE WE DON'T
						;CURRENTLY KNOW HOW MANY COMPILER-GENERATED
						;PUSHES MIGHT BE GOING TO HAPPEN
XAPDLR1	(CALL TRAP)
    (ERROR-TABLE STACK-FRAME-TOO-LARGE)
    (ERROR-TABLE ARG-POPPED 0 M-1)

;This makes a list of specified length, full of NILs, on the stack.  Because it
;pushes on the stack it must be done at "top level" in the function body, rather
;than as an argument to a function, unless a SHRINK-PDL-SAVE-TOP instruction is
;emitted at a suitable place.
XMSL (MISC-INST-ENTRY %MAKE-STACK-LIST)
	(CALL XAPDLR)				;M-1 GETS LIST LENGTH, CHECK FOR ROOM
	(JUMP-EQUAL M-1 A-ZERO XFALSE)		;0-LENGTH LIST IS NIL
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)	;MAKE RETURN VALUE
       ((M-K) ADD PDL-BUFFER-POINTER (A-CONSTANT 1))
XMSL1	((C-PDL-BUFFER-POINTER-PUSH) DPB (M-CONSTANT -1)	;CDR-NEXT
		Q-CDR-CODE A-V-NIL)
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XMSL1)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (C-PDL-BUFFER-POINTER) Q-TYPED-POINTER C-PDL-BUFFER-POINTER
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
       ((M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))

;Like %MAKE-STACK-LIST but expects the contents of
;the list to be on the stack already,
;followed by a word containing the length, which we discard.
;We fix the cdr codes and return a pointer.
XMESL (MISC-INST-ENTRY %MAKE-EXPLICIT-STACK-LIST)
	((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	(JUMP-EQUAL M-A A-ZERO XFALSE)
	;Compute pointer to beginning of list.
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-A)
	;B gets CDR-NEXT.
	((M-B) DPB (M-CONSTANT -1) Q-CDR-CODE)
	(JUMP-EQUAL M-A (A-CONSTANT 1) XMESL2)
;Give all but last element of list CDR-NEXT.
XMESL1
	((C-PDL-BUFFER-INDEX) Q-TYPED-POINTER C-PDL-BUFFER-INDEX A-B)
	((M-A) SUB M-A (A-CONSTANT 1))
	((PDL-BUFFER-INDEX) ADD PDL-BUFFER-INDEX (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-A (A-CONSTANT 1) XMESL1)
XMESL2
;Give last element CDR-NIL.
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-INDEX) Q-TYPED-POINTER C-PDL-BUFFER-INDEX
			      (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))

;A lexical closure is a pointer with type DTP-CLOSURE or DTP-STACK-CLOSURE
;to a couple of lists on the stack which look like
;(function ,(LOCF LEXICAL-ENVIRONMENT) ((,(%STACK-FRAME-POINTER) . ,LEXICAL-ENVIRONMENT)))
;This uses six slots.  We expect the index of the first one within the local block.
;We set up the third slot (to point to the fourth, cdr-nil),
;the fourth slot (to point to the fifth, cdr-nil),
;and the fifth (our own stack frame, cdr-normal).
;Then we return a pointer to the first slot, with DTP-STACK-CLOSURE.
XMLC (MISC-INST-ENTRY %MAKE-LEXICAL-CLOSURE)
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	((M-B) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX)
	((M-B) ADD C-PDL-BUFFER-POINTER-POP A-B)
;Put in M-T the memory address of the first slot.
	((M-K) ADD M-AP A-B)
	((PDL-BUFFER-INDEX) ADD M-K (A-CONSTANT 2))
	(CALL CONVERT-PDL-BUFFER-ADDRESS)
	((M-T) DPB M-K Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-STACK-CLOSURE)))
;Set up the third slot.
	((M-K) M+A+1 M-T (A-CONSTANT 2))
	((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER 
			      (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST)
						(BYTE-VALUE Q-CDR-CODE CDR-NIL))))
;Set up the fourth slot.
	((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
	((M-K) M+1 M-K)
	((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER 
			      (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST)
						(BYTE-VALUE Q-CDR-CODE CDR-NIL))))
;Set up the fifth slot.
	((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-AP)
	((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER 
			      (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST)
						(BYTE-VALUE Q-CDR-CODE CDR-NORMAL))))
;Set up the sixth slot.
	((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
	(POPJ-AFTER-NEXT
	 (M-K) A-LEXICAL-ENVIRONMENT)
	((C-PDL-BUFFER-INDEX) DPB M-K Q-TYPED-POINTER 
			      (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR)))

;(%SPREAD LIST)D-NEXT sends the elements of the list which is
;on the top of the stack to D-NEXT.  (%SPREAD LIST)D-LAST is similar
;but sends the last one to D-LAST (i.e. activates an open-call).
;(%SPREAD LIST)D-PDL is identical to (%SPREAD LIST)D-NEXT
(ERROR-TABLE DEFAULT-ARG-LOCATIONS %SPREAD M-D)

XSPREAD (MISC-INST-ENTRY %SPREAD)
	((M-GARBAGE) MICRO-STACK-DATA-POP)	;DON'T STORE IN DESTINATION
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;LIST TO BE SPREAD
	((M-C) M-INST-DEST)
	((M-D) M-T)					;SAVE ORIGINAL ARG FOR ERROR MSG.
MC-SPREAD-0						;ENTRY FOR MICROCOMPILED CODE
	((PDL-BUFFER-INDEX) M-A-1 PDL-BUFFER-POINTER A-AP)	;CURRENT FRAME SIZE (MOD 2000)
	((M-B) SUB PDL-BUFFER-INDEX (A-CONSTANT 370))	;-# PUSHES ALLOWED (FUDGE FACTOR OF 10)
XSPREAD-1
	(JUMP-EQUAL M-T A-V-NIL XSPREAD-EMPTY)
	(CALL-XCT-NEXT QCAR)
       ((M-A) A-T)
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T
		Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	(CALL-XCT-NEXT QCDR)
       ((M-T) A-A)
	(JUMP-LESS-THAN-XCT-NEXT M-B A-ZERO XSPREAD-1)
       ((M-B) ADD M-B (A-CONSTANT 1))		;DECREASE NEGATIVE COUNT OF PUSHES ALLOWED
	(CALL TRAP)
    (ERROR-TABLE STACK-FRAME-TOO-LARGE)

XSPREAD-EMPTY
	(JUMP-EQUAL M-C (A-CONSTANT D-LAST) XAOCB)
	(POPJ)

XCTO (MISC-INST-ENTRY %CATCH-OPEN)
	(CALL-XCT-NEXT FLUSH-DESTINATION-RETURN-PC)
       ((M-T) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
				  *CATCH-U-CODE-ENTRY-/#)))
	(CALL-XCT-NEXT SBPL-ADI)	;PUSH ADI-BIND-STACK-LEVEL BLOCK
       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;GET RESTART PC OFF STACK
	((C-PDL-BUFFER-POINTER-PUSH)
		DPB (M-CONSTANT -1) Q-FLAG-BIT A-S)	;PUSH RESTART PC
	((M-R) MICRO-STACK-POINTER)
	(JUMP-XCT-NEXT XCTO1)
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-R (LISP-BYTE %%ADI-RPC-MICRO-STACK-LEVEL)
	     (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
			       (BYTE-VALUE Q-FLAG-BIT 1)
			       (BYTE-VALUE %%ADI-TYPE ADI-RESTART-PC))))
	
SBPL-ADI((M-1) A-QLBNDP)		;STORE ADI-BIND-STACK-LEVEL ADI BLOCK
	((M-1) SUB M-1 A-QLBNDO)
	(POPJ-AFTER-NEXT 
	 (C-PDL-BUFFER-POINTER-PUSH) DPB M-1 Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((C-PDL-BUFFER-POINTER-PUSH) 
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-FLAG-BIT 1)
				  (BYTE-VALUE %%ADI-TYPE ADI-BIND-STACK-LEVEL))))

XCTOM (MISC-INST-ENTRY %CATCH-OPEN-MV)
	(CALL-XCT-NEXT FLUSH-DESTINATION-RETURN-PC)
       ((M-T) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
				  *CATCH-U-CODE-ENTRY-/#)))
	((M-D) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;# VALS TO BE RECVD
	(CALL-XCT-NEXT LMVRB)				;LEAVE RM ON PDL TO RECEIVE VALS
       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;RESTART PC
	(CALL SBPL-ADI)		;PUSH ADI-BIND-STACK-LEVEL BLOCK
	((C-PDL-BUFFER-POINTER-PUSH) DPB (M-CONSTANT -1) Q-FLAG-BIT A-S)
	((M-R) MICRO-STACK-POINTER)
        ((C-PDL-BUFFER-POINTER-PUSH) DPB M-R (LISP-BYTE %%ADI-RPC-MICRO-STACK-LEVEL)
	     (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
			       (BYTE-VALUE Q-FLAG-BIT 1)
			       (BYTE-VALUE %%ADI-TYPE ADI-RESTART-PC))))
	(JUMP-XCT-NEXT XCTOM1)
       ((M-K) DPB (M-CONSTANT -1) Q-FLAG-BIT A-K) ;THIS ISN'T LAST ADI

XLEC (MISC-INST-ENTRY %LEXPR-CALL)
	(JUMP-XCT-NEXT XLEC1)
       ((M-S) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				(BYTE-VALUE Q-FLAG-BIT 1)
				(BYTE-VALUE %%ADI-TYPE ADI-LEXPR-CALL))))

XFEC (MISC-INST-ENTRY %FEXPR-CALL)
	((M-S) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				 (BYTE-VALUE Q-FLAG-BIT 1)
				 (BYTE-VALUE %%ADI-TYPE ADI-FEXPR-CALL))))
XLEC1	(CALL-XCT-NEXT FLUSH-DESTINATION-RETURN-PC)
       ((M-T) C-PDL-BUFFER-POINTER-POP)	;FUNCTION TO CALL
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP-XCT-NEXT XCTO1)
       ((C-PDL-BUFFER-POINTER-PUSH) M-S)	;STORE ADI

XLECM (MISC-INST-ENTRY %LEXPR-CALL-MV)
	(JUMP-XCT-NEXT XLECM1)
       ((M-S) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				(BYTE-VALUE Q-FLAG-BIT 1)
				(BYTE-VALUE %%ADI-TYPE ADI-LEXPR-CALL))))

XFECM (MISC-INST-ENTRY %FEXPR-CALL-MV)
	((M-S) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				 (BYTE-VALUE Q-FLAG-BIT 1)
				 (BYTE-VALUE %%ADI-TYPE ADI-FEXPR-CALL))))
XLECM1	(CALL-XCT-NEXT FLUSH-DESTINATION-RETURN-PC)
       ((M-D) C-PDL-BUFFER-POINTER-POP)		;NUMBER OF VALUES DESIRED
	(CALL-XCT-NEXT LMVRB)			;MAKE ROOM ON PDL
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;FCN TO CALL
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-POINTER-PUSH) M-S)	;STORE ADI
	(JUMP-XCT-NEXT XCTOM1)
       ((M-K) DPB (M-CONSTANT -1) Q-FLAG-BIT A-K) ;THIS ISN'T LAST ADI

XC0MVL (MISC-INST-ENTRY %CALL0-MULT-VALUE-LIST)
	((M-TEM) MICRO-STACK-POINTER)		;Insert continuation to QMRCL in pdl
	(JUMP-EQUAL M-TEM A-ZERO XC0MVL1)
	((M-GARBAGE) MICRO-STACK-DATA-POP)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMRCL)))
XC0MVL1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMRCL)))
XCMVL (MISC-INST-ENTRY %CALL-MULT-VALUE-LIST)
	(CALL-XCT-NEXT FLUSH-DESTINATION-RETURN-PC)
       ((M-T) C-PDL-BUFFER-POINTER-POP)	;FCN TO CALL
	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)	;INIT CDR OF LIST, ON RET WILL BE LIST
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) PDL-BUFFER-POINTER)		;GET LOCATIVE POINTER TO THAT NIL
	((C-PDL-BUFFER-POINTER-PUSH) M-K)	;AS 2ND ADI WORD
	(JUMP-XCT-NEXT XCTO1)
       ((C-PDL-BUFFER-POINTER-PUSH)		;ADI FOR RETURN VALUES INFO
	     (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
			       (BYTE-VALUE Q-FLAG-BIT 1)
			       (BYTE-VALUE %%ADI-TYPE ADI-RETURN-INFO)
			       (BYTE-VALUE %%ADI-RET-STORING-OPTION ADI-ST-MAKE-LIST))))

XC0MV (MISC-INST-ENTRY %CALL0-MULT-VALUE)
	((M-TEM) MICRO-STACK-POINTER)		;Insert continuation to QMRCL in pdl
	(JUMP-EQUAL M-TEM A-ZERO XC0MV1)
	((M-GARBAGE) MICRO-STACK-DATA-POP)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMRCL)))
XC0MV1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMRCL)))
XCMV (MISC-INST-ENTRY %CALL-MULT-VALUE)
	(CALL-XCT-NEXT FLUSH-DESTINATION-RETURN-PC)
       ((M-D) C-PDL-BUFFER-POINTER-POP)	;# VALUES DESIRED
XCMV1	(CALL-XCT-NEXT LMVRB)			;MAKE ROOM ON PDL
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;FCN TO CALL
XCTOM1	((C-PDL-BUFFER-POINTER-PUSH) M-K)	;RETURN VALUES BLOCK POINTER
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-D	;ADI FOR RETURN VALUES INFO
	  (LISP-BYTE %%ADI-RET-NUM-VALS-EXPECTING)
	     (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
			       (BYTE-VALUE Q-FLAG-BIT 1)
			       (BYTE-VALUE %%ADI-TYPE ADI-RETURN-INFO)
			       (BYTE-VALUE %%ADI-RET-STORING-OPTION ADI-ST-BLOCK))))
XCTO1	(CALL CBM)				;STORE CALL BLOCK
	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-INDEX) ADD M-ZR (A-CONSTANT (EVAL %LP-CALL-STATE)))
       ((C-PDL-BUFFER-INDEX) IOR C-PDL-BUFFER-INDEX
		(A-CONSTANT (BYTE-MASK %%LP-CLS-ADI-PRESENT)))

LMVRB	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) Q-DATA-TYPE M-D TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE DATA-TYPE-SCREWUP ADI)
	((M-D) Q-POINTER M-D)
	(CALL-GREATER-THAN M-D (A-CONSTANT 100) TRAP)
   (ERROR-TABLE MVR-BAD-NUMBER M-D)
ULMVRB	(CALL-EQUAL M-D A-ZERO TRAP)
   (ERROR-TABLE MVR-BAD-NUMBER M-D)
	((M-K) PDL-BUFFER-POINTER)		;LOC OF BLOCK AS PDL INDEX
	((M-E) M-D)
LMVRB1	((C-PDL-BUFFER-POINTER-PUSH)		;RESERVE SLOTS, FILL WITH NIL
		DPB (M-CONSTANT -1) Q-CDR-CODE A-V-NIL)	;WITH CDR-NEXT
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) LMVRB1)
       ((M-E) SUB M-E (A-CONSTANT 1))
	(JUMP-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)	;RET BLK PNTR AS LOCATIVE
       ((M-K) ADD M-K (A-CONSTANT 1))		;FIX POINTER

;;; The above misc instructions use their destination as a sub-opcode
;;; rather than as a normal destination.  This subroutine flushes the
;;; destination return address, if it is present.
;;; Note that none of the above will work anyway when called from micro-compiled code.
FLUSH-DESTINATION-RETURN-PC
	((M-TEM) M-INST-DEST)
	(POPJ-AFTER-NEXT POPJ-EQUAL M-TEM (A-CONSTANT D-IGNORE))
       ((M-GARBAGE) MICRO-STACK-DATA-POP)

;;; APPLY and MICRO-TO-MACRO calls (used by micro-compiled code and by
;;; certain things in the base microcode.)

UAPLY  (MISC-INST-ENTRY APPLY)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 1))
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)		;Function
	(CALL-XCT-NEXT XARGI0)		;RETURN ARG-INFO IN M-T
       ((M-J) M-S)			;Save a copy of function for later.
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)	;Arguments
	((M-1) (LISP-BYTE %%ARG-DESC-MAX-ARGS) M-T)
	(JUMP-NOT-EQUAL M-1 A-ZERO UAPLY1)	;IF ANY SPREAD ARGS, SPREAD THEM
				;ABOVE 2 INSTRUCTIONS ARE ONLY HERE BECAUSE
				;LINEAR ENTER WOULD BOMB OUT OTHERWISE
	(JUMP-IF-BIT-SET (LISP-BYTE %%ARG-DESC-QUOTED-REST) M-T UAPFX)
	(JUMP-IF-BIT-SET (LISP-BYTE %%ARG-DESC-EVALED-REST) M-T UAPFX)
	(JUMP-IF-BIT-SET (LISP-BYTE %%ARG-DESC-INTERPRETED) M-T UAPFX) ;BE CONSERVATIVE
UAPLY1	(CALL P3ZERO)				;PUSH MICRO-TO-MACRO CALL BLOCK, NO ADI
	((C-PDL-BUFFER-POINTER-PUSH) M-J)	;FINISH CALL BLOCK BY PUSHING FCTN
	((M-R) A-ZERO)			;COUNT OF # ARGS PUSHED
	(DISPATCH Q-DATA-TYPE M-A SKIP-IF-LIST)
	 (JUMP UAPLY4)
UAPLY5	(CALL-XCT-NEXT QCAR)
       ((M-T) M-A)
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-TYPED-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	(CALL-XCT-NEXT QCDR)
       ((M-T) M-A)
	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP UAPLY6)
	((M-A) M-T)
	(JUMP-XCT-NEXT UAPLY5)
       ((M-R) ADD M-R (A-CONSTANT 1))
	
UAPLY6	((C-PDL-BUFFER-POINTER) DPB C-PDL-BUFFER-POINTER Q-ALL-BUT-CDR-CODE 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(JUMP-XCT-NEXT UAPLY4)
       ((M-R) ADD M-R (A-CONSTANT 1))

UAPFX	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;ADI
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (PLUS (PLUS
		(BYTE-VALUE Q-DATA-TYPE DTP-FIX)
		(BYTE-VALUE Q-FLAG-BIT 1))
		(BYTE-VALUE %%ADI-TYPE ADI-FEXPR-CALL))))
	(CALL P3ADI)			;PUSH MICRO-TO-MACRO CALL BLOCK WITH ADI
	((C-PDL-BUFFER-POINTER-PUSH) M-J)	;function
	((C-PDL-BUFFER-POINTER-PUSH) M-A)	;list of args
	((M-R) (A-CONSTANT 1))
;This is like MMJCALL except that the number of args is already in M-R.
UAPLY4	((M-TEM) MICRO-STACK-DATA)		;Check the return address
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (I-MEM-LOC QMDDR)) UAPLY4R) ;ordinary return
;;; Change destination to D-RETURN so that multiple values will be passed
;;; back correctly.  Dont worry about args.  They will be flushed by frame unwindage.
	((M-GARBAGE) MICRO-STACK-DATA-POP)	;Flush return to QMDDR
	((M-TEM) A-IPMARK)			;Find LP-CLS Q of open call block
	((PDL-BUFFER-INDEX) ADD M-TEM (A-CONSTANT (EVAL %LP-CALL-STATE)))
	(JUMP-XCT-NEXT MMCAL4)
       ((C-PDL-BUFFER-INDEX) SUB C-PDL-BUFFER-INDEX
		(A-CONSTANT (BYTE-VALUE %%LP-CLS-DESTINATION
					(DIFFERENCE D-MICRO D-RETURN))))

UAPLY4R (CALL MMCAL4)
	(POPJ-AFTER-NEXT
	 (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))  ;remove args.
       (NO-OP)

;;; Activate a pending micro-to-macro call block.
;;; ((ARG-JUMP MMJCALL) (I-ARG number-args-pushed)) if you want to return the result(s)
;;; of the call as your own result(s).
;;; Changes the destination in the call-block from D-MICRO to D-RETURN if necessary
MMJCALL	((M-TEM) MICRO-STACK-DATA)		;Check the return address
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (I-MEM-LOC QMDDR)) MMCALL) ;ordinary return
;;; Change destination to D-RETURN so that multiple values will be passed
;;; back correctly.
	((M-GARBAGE) MICRO-STACK-DATA-POP)	;Flush return to QMDDR
MMJCALR	((M-TEM) A-IPMARK)			;Find LP-CLS Q of open call block
	((PDL-BUFFER-INDEX) ADD M-TEM (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((C-PDL-BUFFER-INDEX) SUB C-PDL-BUFFER-INDEX
		(A-CONSTANT (BYTE-VALUE %%LP-CLS-DESTINATION
					(DIFFERENCE D-MICRO D-RETURN))))
	;; Drop into MMCALL, dispatch-constant (I-ARG) still valid.
;;; Activate a pending micro-to-macro call block.
;;; ((ARG-CALL MMCALL) (I-ARG number-args-pushed)) if you want to get back the
;;; result of the function.  You can receive multiple values if you opened
;;; the call by pushing ADI and calling P3ADI rather than P3ZERO.
MMCALL	((M-R) READ-I-ARG)
;;; Here if M-R is already set up.
MMCAL4	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-R)	;Address of new frame
	((M-S) PDL-BUFFER-INDEX)		;Must be in both M-S and PDL-BUFFER-INDEX
	(CALL-NOT-EQUAL M-S A-IPMARK ILLOP)	;Frame not where it should be.  M-R lied?
       ((M-A) C-PDL-BUFFER-INDEX)		;M-A := FUNCTION TO CALL
	(DISPATCH Q-DATA-TYPE M-A D-QMRCL)	;Does MLLV if necc
       (CALL MLLV)

;microcompiled code runtime support
MC-READ-EXIT-VECTOR		;Read data from exit vector, leave it in MD.
	((VMA-START-READ) ADD READ-I-ARG A-MC-CODE-EXIT-VECTOR)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)  ;Follow all INVZ
       (NO-OP)

MC-SETZERO (JUMP-XCT-NEXT MC-WRITE-EXIT-VECTOR)
          ((MD) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

MC-SETNIL ((MD) A-V-NIL)
MC-WRITE-EXIT-VECTOR		;Write Q in MD thru exit vector.  Exit vector itself
	((M-A) MD)		;  had better have some kind of forwarding pointer.
	((VMA-START-READ) ADD READ-I-ARG A-MC-CODE-EXIT-VECTOR)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)	;Follow all INVZ
	((MD-START-WRITE) SELECTIVE-DEPOSIT MD Q-ALL-BUT-TYPED-POINTER A-A)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

MC-CALL-EXIT-VECTOR
	(CALL MC-READ-EXIT-VECTOR)
	(CALL-XCT-NEXT P3ZERO)
       ((M-T) Q-TYPED-POINTER MD)
	(POPJ-AFTER-NEXT (C-PDL-BUFFER-POINTER-PUSH) M-T)
       (NO-OP)

MC-BNDNIL ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
MC-BNDPOP ((VMA-START-READ) ADD READ-I-ARG A-MC-CODE-EXIT-VECTOR)  ;Exit vector points to
	  (CHECK-PAGE-READ)			; internal value cell.
	  ((M-LAST-MICRO-ENTRY) MICRO-STACK-DATA-POP)   ;Save return
      ;Return of microcompiled FCTN now in MICRO-STACK-DATA. Depends on M-QBBFL = bit 0
	  ((M-FLAGS) LDB %%-PPBSPC
			 MICRO-STACK-PNTR-AND-DATA A-FLAGS) ;Start or continue binding block
	  (CALL MC-BND1)
	  (JUMP MC-DOSX)

MC-BND1	((VMA-START-READ M-B) MD)
	(CHECK-PAGE-READ)
	(CALL QBND4)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-T WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-E
	        Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

;BIND A BLOCK OF SPECIAL VARIABLES.  INTERNAL VALUE CELL POINTERS ARE IN A BLOCK IN EXIT
;VECTOR STARTING AT ADDRESS GIVEN BY DISPATCH CONSTANT.  VALUES ARE IN PDL BUFFER LOCATIONS
;FLAGGED BY ONE BITS IN M-C INTERPRETED AS A BIT VECTOR (I.E. BIT 0, IF ON, SAYS BIND
;0(PP), ETC).
MC-DO-SPECBIND-PP-BASED
	((M-LAST-MICRO-ENTRY) MICRO-STACK-DATA-POP)   ;Save return
      ;Return of microcompiled FCTN now in MICRO-STACK-DATA. Depends on M-QBBFL = bit 0
	((M-FLAGS) LDB %%-PPBSPC
			MICRO-STACK-PNTR-AND-DATA A-FLAGS) ;Start or continue binding block
	((PDL-BUFFER-INDEX) PDL-BUFFER-POINTER)
	((M-D) ADD READ-I-ARG A-MC-CODE-EXIT-VECTOR)
MC-DOS1	(JUMP-EQUAL M-C A-ZERO MC-DOSX)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-C MC-DOS2)
	((VMA-START-READ) M-D)
	(CHECK-PAGE-READ)
	(CALL-XCT-NEXT MC-BND1)
       ((C-PDL-BUFFER-POINTER-PUSH) C-PDL-BUFFER-INDEX)
	((M-D) ADD M-D (A-CONSTANT 1))
MC-DOS2	((M-C) LDB (BYTE-FIELD 31. 1) M-C)
	(JUMP-XCT-NEXT MC-DOS1)
       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-INDEX (A-CONSTANT 1))

MC-DOSX	((M-2) MICRO-STACK-DATA-POP)		   ;Save M-QBBFL in his return
	((MICRO-STACK-DATA-PUSH) DPB M-FLAGS %%-PPBSPC A-2)  ;Depends on M-QBBFL = bit 0
	((OA-REG-LOW) DPB M-LAST-MICRO-ENTRY OAL-JUMP A-ZERO)
        (JUMP 0)	;RETURN

MC-POP-SPECPDL
	((M-D) READ-I-ARG)	;# to pop
	((M-LAST-MICRO-ENTRY) MICRO-STACK-DATA-POP)   ;Save return
      ;Return of microcompiled FCTN now in MICRO-STACK-DATA. Depends on M-QBBFL = bit 0
	((M-FLAGS) LDB %%-PPBSPC
			MICRO-STACK-PNTR-AND-DATA A-FLAGS) ;Start or continue binding block
MC-POPS1(JUMP-EQUAL M-D A-ZERO MC-DOSX)
	(CALL-IF-BIT-CLEAR M-QBBFL ILLOP)
	(CALL QUNBND)
	(JUMP-XCT-NEXT MC-POPS1)
       ((M-D) SUB M-D (A-CONSTANT 1))

;Special entries used by micro compiled code.  Most take arg via the DISPATCH-CONSTANT.
MC-SE1+ ((M-LAST-MICRO-ENTRY) (A-CONSTANT (I-MEM-LOC X1PLS)))
MC-SOP	(CALL MC-READ-EXIT-VECTOR)
	((C-PDL-BUFFER-POINTER-PUSH) VMA)
	((C-PDL-BUFFER-POINTER-PUSH) MD)
	((OA-REG-LOW M-LAST-MICRO-ENTRY) DPB M-LAST-MICRO-ENTRY OAL-JUMP A-ZERO)
	(CALL 0)  ;No XCT-NEXT since no pass around on PB and X1PLS depends on it.
		  ; Take arg on stack, return result in M-T
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)	;Follow all INVZ
	((MD-START-WRITE) SELECTIVE-DEPOSIT MD Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

MC-SE1- (JUMP-XCT-NEXT MC-SOP)
       ((M-LAST-MICRO-ENTRY) (A-CONSTANT (I-MEM-LOC X1MNS)))

MC-SECDR(JUMP-XCT-NEXT MC-SOP)
       ((M-LAST-MICRO-ENTRY) (A-CONSTANT (I-MEM-LOC QMD)))

MC-SECDDR
	(JUMP-XCT-NEXT MC-SOP)
       ((M-LAST-MICRO-ENTRY) (A-CONSTANT (I-MEM-LOC QMDD)))

MC-START-LIST-AREA
	(JUMP-XCT-NEXT MC-SL-1)
       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)

MC-START-LIST		;Allocates block of NILs and push two pointers to it.
	((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
MC-SL-1	(CALL-XCT-NEXT LIST-OF-NILS)	;Data type returnned garbage.
       ((M-B) READ-I-ARG)
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-POINTER-PUSH M-T)
	   Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)

MC-STORE-NEXT-LIST		;store M-T in next position of previously allocated list.
	((VMA-START-READ) C-PDL-BUFFER-POINTER)	;PTR TO NEXT PLACE IN LIST
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE)	;GET RANDOM BITS FROM PLACE STORING TO
	    SELECTIVE-DEPOSIT READ-MEMORY-DATA
		Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((C-PDL-BUFFER-POINTER) ADD C-PDL-BUFFER-POINTER (A-CONSTANT 1))

MC-STORE-LAST-LIST		;Last time around.  Leave completed list in M-T.
	(CALL MC-STORE-NEXT-LIST)
	(POPJ-AFTER-NEXT (M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

MC-MMCALB	;This is supposed to box M-T as well as push it.
MC-MMCALT
	(JUMP-XCT-NEXT MMCALL)
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-TYPED-POINTER	;last arg, CDR-NIL
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))

MC-GET-LOCATIVE-TO-PDL
	((M-TEM) READ-I-ARG)
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) SUB PDL-BUFFER-POINTER A-TEM)
	(POPJ-AFTER-NEXT (M-T) M-K)
       (NO-OP)

MC-GET-LOCATIVE-TO-VC
	((VMA-START-READ) ADD READ-I-ARG A-MC-CODE-EXIT-VECTOR)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)
       ((M-T) DPB VMA Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

MC-SPREAD	;%SPREAD expands into this.  Only tries to win for the D-LAST case as
	(CALL-XCT-NEXT MC-SPREAD-0)	;generated by LEXPR-FUNCALL.
       ((M-C) A-ZERO)			;fake out end switch of XSPREAD
	((C-PDL-BUFFER-POINTER) DPB C-PDL-BUFFER-POINTER Q-TYPED-POINTER
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))	;Fix the last arg.
	(JUMP-XCT-NEXT MMCALL)		;This has to hack specially since the normal thing
       ((M-R) SUB PDL-BUFFER-POINTER A-IPMARK) ;setting up M-R from the disp constant cant win.

MC-UCTOM(CALL ILLOP)	;*CATCH open, multiple values

MC-MMISU(CALL ILLOP)	;Prepare to make MICRO-MICRO call receiving N values.

MC-MURV	(CALL ILLOP)	;RETURN-NEXT-VALUE

MC-MRNV (CALL ILLOP)	;Return N values, number in M-E.  Is jumped to.

MC-MR2V	(CALL ILLOP)	;Return 2 values.  Is jumped to.

MC-MR3V	(CALL ILLOP)	;Return 3 values.  Is jumped to.

;Frobs which return.
MC-SUB-PP (POPJ-AFTER-NEXT (M-1) READ-I-ARG)
	 ((PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER A-1)

MC-POP-SPECPDL-AND-SUB-PP
	((M-1) READ-I-ARG)
	((PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER A-1)
	(CALL-IF-BIT-SET %%-PPBSPC
			MICRO-STACK-PNTR-AND-DATA BBLKP) ;POP BINDING BLOCK (IF STORED ONE)
	(POPJ)

;;; "LINEAR" ENTER
;   M-A HAS PNTR TO FEF TO CALL
;   M-S HAS EVENTUAL NEW ARG POINTER (M-AP)
;   M-R HAS NUMBER OF ARGUMENTS
;WE DON'T SUPPORT USER COPYING AND FORWARDING OF FEFS,
;SO IT'S NOT NECESSARY TO CALL THE TRANSPORTER EVERYWHERE.
;CAN SEQUENCE BREAK ONCE WE GET PAST THE ARGUMENTS AND START DOING VARIABLE
;INITIALIZATIONS, WHICH CAN CAUSE ERRORS.  THIS WILL INVALIDATE A-LCTYP BUT
;PRESERVE THE LETTERED M-REGISTERS.
;*** WE STILL HAVE A PROBLEM WITH M-ERROR-SUBSTATUS NOT BEING PRESERVED

QLENTR	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
		M-METER-ENABLES METER-FUNCTION-ENTRY)
	((PDL-BUFFER-INDEX) SUB M-S A-AP)	;ASSURE ROOM IN PDL-BUFFER
	((M-PDL-BUFFER-ACTIVE-QS) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-ACTIVE-QS)
	(CALL-GREATER-THAN-XCT-NEXT M-PDL-BUFFER-ACTIVE-QS 
			   A-PDL-BUFFER-HIGH-WARNING PDL-BUFFER-DUMP)
       ((M-AP) M-S)	;NEW ARG POINTER (DO THIS RIGHT AWAY TO MINIMIZE PROBLEMS IF ERR OUT)
	((VMA-START-READ) M-A)
	(CHECK-PAGE-READ)
	((M-ERROR-SUBSTATUS) M-ZERO)	;CLEAR OUT ERRORS
	((A-LCTYP) M-ZERO)		;CLEAR OUT LINEAR-CALL-TYPE 
	((M-D) Q-POINTER READ-MEMORY-DATA)	;GET FEF HEADER WORD
	((M-B) (LISP-BYTE %%HEADER-TYPE-FIELD) M-D)
	(CALL-NOT-EQUAL M-B (A-CONSTANT (EVAL %HEADER-TYPE-FEF)) ILLOP)	;NOT FEF
	((M-J) (LISP-BYTE %%FEFH-PC) M-D)	;MAY GET CHANGED DUE TO OPTIONAL ARGS.
					; ALSO NOTE RELATIVE TO FEF STILL
	((PDL-BUFFER-INDEX) ADD M-S (A-CONSTANT (EVAL %LP-CALL-STATE)))
	(JUMP-IF-BIT-SET (LISP-BYTE %%LP-CLS-ADI-PRESENT) 
			C-PDL-BUFFER-INDEX QLEAI1)  ;FEXPR OR LEXPR ?
QLEAI2	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEFH-FAST-ARG) M-D QRENT)  ;NO FAST-OPTION
;NEED ERRONEOUS QUOTED ARG CHECK
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-FAST-ARG-OPT)))
	(CHECK-PAGE-READ)		;GET FAST-OPTION WORD
	(DISPATCH Q-DATA-TYPE READ-MEMORY-DATA TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE DATA-TYPE-SCREWUP FEF)
	((M-C) (LISP-BYTE %%FEFHI-FSO-MIN-ARGS) READ-MEMORY-DATA)
	(CALL-GREATER-THAN M-C A-R SET-TOO-FEW-ARGS)
	((M-E) (LISP-BYTE %%FEFHI-FSO-MAX-ARGS) READ-MEMORY-DATA)
	(JUMP-IF-BIT-SET (LISP-BYTE %%ARG-DESC-QUOTED-REST) READ-MEMORY-DATA QLFOA1)
	(JUMP-IF-BIT-SET (LISP-BYTE %%ARG-DESC-EVALED-REST) READ-MEMORY-DATA QLFOA1)
	((Q-R) ADD M-E (A-CONSTANT (EVAL %LP-INITIAL-LOCAL-BLOCK-OFFSET)))
	((A-LOCALP) ADD Q-R A-S)
	((A-TEM1) DPB Q-R (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-C) DPB M-R (LISP-BYTE %%LP-ENS-NUM-ARGS-SUPPLIED) A-TEM1)
QLEAI5	((PDL-BUFFER-INDEX) ADD M-S (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	((C-PDL-BUFFER-INDEX) M-C)		;STORE ENTRY STATE Q
	(CALL-LESS-THAN M-E A-R SET-TOO-MANY-ARGS)
QFL2	(JUMP-LESS-OR-EQUAL M-E A-R QFL1)
	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)	;DEFAULT UNSUPPLIED ARGS TO NIL
	(JUMP-XCT-NEXT QFL2)
       ((M-E) SUB M-E (A-CONSTANT 1))

METER-FUNCTION-ENTRY
	((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-ENTRY-EVENT)))
	((C-PDL-BUFFER-POINTER-PUSH) M-A)
	(JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER)
       ((A-METER-LENGTH) (A-CONSTANT 1))	;Number of meters pushed

SET-TOO-FEW-ARGS
	(POPJ-AFTER-NEXT (M-QBTFA) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)
       (NO-OP)

SET-TOO-MANY-ARGS
	(POPJ-AFTER-NEXT (M-QBTMA) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)
       (NO-OP)

;HAVE SET UP ARGS
QFL1	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-MISC)))
	(CHECK-PAGE-READ)
	((M-T) (LISP-BYTE %%FEFHI-MS-LOCAL-BLOCK-LENGTH) READ-MEMORY-DATA)
QFL1C	(JUMP-EQUAL M-T A-ZERO QFL1A)
QFL1B	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL) 	;INIT LOCAL BLOCK TO NIL
	(JUMP-GREATER-THAN-XCT-NEXT M-T (A-CONSTANT 1) QFL1B)
       ((M-T) SUB M-T (A-CONSTANT 1))
QFL1A	(CALL-IF-BIT-SET (LISP-BYTE %%FEFH-SV-BIND) M-D FRMBN1)  ;MOVE S-V BINDINGS TO
		;S-V-CELLS AND PUSH PREVIOUS BINDINGS ON BINDING PDL (M-D HAS %FEFHI-IPC STILL)
;FINISH LINEARLY ENTERING
QLENX	((M-TEM) DPB M-A (BYTE-FIELD 24. 1) (A-CONSTANT 0))	;NOW UNRELOCATE PC
	((LOCATION-COUNTER) ADD M-TEM A-J OUTPUT-SELECTOR-LEFTSHIFT-1)
	(POPJ-EQUAL-XCT-NEXT M-ERROR-SUBSTATUS A-ZERO)	;RETURN TO MAIN LOOP IF NO ERROR
       ((A-IPMARK) (BYTE-FIELD 10. 0) M-AP)	;NO OPEN CALL BLOCK YET
QLEERR	((C-PDL-BUFFER-POINTER-PUSH) DPB M-ERROR-SUBSTATUS Q-POINTER ;PUSH M-ERROR-SUBSTATUS 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ; ONTO STACK SO ERROR HANDLER
	(CALL TRAP)					       ; CAN FIND IT.
   (ERROR-TABLE FUNCTION-ENTRY) ;This table entry is specially known about.

;Here if the function takes a rest arg.  M-E has # reg+opt args.
;ADL not being used, fast-arg option is active.
QLFOA1	(JUMP-NOT-EQUAL A-LCTYP M-ZERO QLFRA1)	;Called with LEXPR/FEXPR call
	;; Called with just spread arguments.
	;; If the rest arg will be NIL, push NILs for it and any missing optionals.
	(JUMP-LESS-THAN M-E A-R QLFSA2)
	((M-TEM) SUB M-E A-R)			;1- number of NILs to push
QLFSA1	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
	(JUMP-GREATER-THAN-XCT-NEXT M-TEM A-ZERO QLFSA1)
       ((M-TEM) SUB M-TEM (A-CONSTANT 1))
	((Q-R) ADD M-E (A-CONSTANT (EVAL %LP-INITIAL-LOCAL-BLOCK-OFFSET)))
	;; Args set up.  Set up entry-state and local-block (offset is in Q-R)
QLFOA5	((A-LOCALP) ADD Q-R A-S)
	((PDL-BUFFER-INDEX) ADD M-S (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	((A-TEM1) DPB M-R (LISP-BYTE %%LP-ENS-NUM-ARGS-SUPPLIED)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-INDEX) DPB Q-R (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN)
		A-TEM1)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-MISC)))
	(CHECK-PAGE-READ)
	((M-T) (LISP-BYTE %%FEFHI-MS-LOCAL-BLOCK-LENGTH) READ-MEMORY-DATA)
	(JUMP-XCT-NEXT QFL1C)
       ((M-T) SUB M-T (A-CONSTANT 1))		;First local (rest arg) already pushed

	;; Called with enough spread args to get into the rest arg
QLFSA2	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M+A+1 M-S A-E)		;First of rest, %LP-INITIAL-LOCAL-BLOCK-OFFSET = 1
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the rest-arg
		Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(JUMP-XCT-NEXT QLFOA5)			;Put the local block after the supplied args
       ((Q-R) ADD M-R (A-CONSTANT (EVAL %LP-INITIAL-LOCAL-BLOCK-OFFSET)))

	;; Called with a rest arg.
QLFRA1	((M-TEM) SUB M-R (A-CONSTANT 1))	;Number of spread args
	(JUMP-EQUAL-XCT-NEXT M-E A-TEM QLFOA5)	;Matches number desired, enter
       ((Q-R) ADD M-TEM (A-CONSTANT (EVAL %LP-INITIAL-LOCAL-BLOCK-OFFSET)))
	(CALL ILLOP)				;Could use QRENT, but would ILLOP at QBNDL2

;ADDITIONAL INFO, SEE IF LEXPR OR FEXPR CALL
QLEAI1	((M-K PDL-BUFFER-INDEX) ADD M-S (A-CONSTANT (EVAL (1- %LP-CALL-STATE))))
QLEAI3	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-INDEX TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE DATA-TYPE-SCREWUP FEF)
	(DISPATCH (LISP-BYTE %%ADI-TYPE) C-PDL-BUFFER-INDEX D-QLEAI3)
		;IF FEXPR OR LEXPR, REMEMBER WIERD CALL TYPE, JUMP TO QLEAI2, ELSE TO QLEAI4
       ((A-LCTYP) (LISP-BYTE %%ADI-TYPE) C-PDL-BUFFER-INDEX)

QLEAI4	(CALL-IF-BIT-CLEAR Q-FLAG-BIT C-PDL-BUFFER-INDEX ILLOP)	;IGNORE OTHER ADI
	((M-K PDL-BUFFER-INDEX) SUB M-K (A-CONSTANT 1))
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT C-PDL-BUFFER-INDEX QLEAI2);ALL ADI DONE
	(JUMP-XCT-NEXT QLEAI3)
       ((M-K PDL-BUFFER-INDEX) SUB M-K (A-CONSTANT 1))

;LINEAR ENTER WITHOUT FAST OPTION
; M-A FEF			M-R number of args called with
; M-B flags/temp		M-Q bind desc Q
; M-C flags/temp		M-I address of bind desc
; M-D pdl index of arg		M-J start PC of FEF
; M-E count of bind descs	M-S pdl index of frame
; M-T address of sv slot	M-K temp

QRENT	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-MISC)))
	(CHECK-PAGE-READ)
	((M-D PDL-BUFFER-INDEX) ADD M-S
		(A-CONSTANT (EVAL %LP-INITIAL-LOCAL-BLOCK-OFFSET)))        ;-> FIRST ARG
	((M-T) ADD M-A (A-CONSTANT (EVAL %FEFHI-SPECIAL-VALUE-CELL-PNTRS)));-> S-V SLOTS
	((A-ARGS-LEFT) M-R)					      ;# ARGS YET TO DO
	((A-TEM1) (LISP-BYTE %%FEFHI-MS-ARG-DESC-ORG) READ-MEMORY-DATA)
	((M-I) ADD A-TEM1 M-A)					    ;-> FIRST BIND DESC
	((M-E) (LISP-BYTE %%FEFHI-MS-BIND-DESC-LENGTH) READ-MEMORY-DATA)  ;# BIND DESCS
	((A-LOCALP) SETO)			    ;SIGNAL LOCAL BLOCK NOT YET LOCATED
	(JUMP-EQUAL A-LCTYP M-ZERO QBINDL)
	((A-ARGS-LEFT) ADD (M-CONSTANT -1) A-ARGS-LEFT) ;WAS FEXPR OR LEXPR CALL
			;FLUSH NO-SPREAD-ARG AND PROCESS ANY SPREAD ARGS
;BIND LOOP USED WHILE ARGS REMAIN TO BE PROCESSED
QBINDL	(JUMP-GREATER-OR-EQUAL M-ZERO A-ARGS-LEFT QBD0)	;OUT OF SPREAD ARGS
	(JUMP-LESS-THAN
		M-E (A-CONSTANT 1) QBTMA1) ;OUT OF BIND DESC, TOO MANY ARGS
	((VMA-START-READ) M-I)		;ACCESS WORD OF BINDING OPTIONS
	(CHECK-PAGE-READ)
	((M-E) SUB M-E (A-CONSTANT 1))
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEF-NAME-PRESENT) READ-MEMORY-DATA QBNDL1)
	((M-I) ADD A-ZERO M-I ALU-CARRY-IN-ONE)	;SKIP NAME Q IF PRESENT
QBNDL1	(DISPATCH-XCT-NEXT (LISP-BYTE %%FEF-ARG-SYNTAX) READ-MEMORY-DATA QREDT1)
       ((M-Q) READ-MEMORY-DATA)		;SAVE BIND DESC IN M-Q

QREW1	(CALL-LESS-THAN M-E (A-CONSTANT 1) ILLOP)
	((VMA-START-READ) M-I)		;ACCESS WORD OF BINDING OPTIONS
	(CHECK-PAGE-READ)
	((M-E) SUB M-E (A-CONSTANT 1))
	((M-Q) READ-MEMORY-DATA)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEF-NAME-PRESENT) M-Q QBNDL2)
	((M-I) ADD A-ZERO M-I ALU-CARRY-IN-ONE)	;SKIP NAME Q IF PRESENT
QBNDL2	((M-TEM) (LISP-BYTE %%FEF-ARG-SYNTAX) M-Q)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT 2) ILLOP)	;WASN'T REST ARG??
	(CALL-GREATER-THAN M-ZERO A-LOCALP QLLOCB)	;SET UP LOCAL BLOCK OVER ARG
	((PDL-BUFFER-POINTER) M-D)		;SO DONT STORE LOCALS OVER ARG
	(CALL-IF-BIT-SET (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBLSPCL)
	(JUMP-XCT-NEXT QBD1)
       ((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)

;OPTIONAL ARG IS PRESENT, SPACE PAST INITIALIZATION INFO IF ANY
QBROP1	(DISPATCH (LISP-BYTE %%FEF-INIT-OPTION) M-Q QBOPNP)

QBOSP	(JUMP-XCT-NEXT QBRQA)
       ((M-I) ADD A-ZERO M-I ALU-CARRY-IN-ONE)

QBOASA	((VMA-START-READ M-I) ADD A-ZERO M-I ALU-CARRY-IN-ONE)
	(CHECK-PAGE-READ)
	((M-J) Q-POINTER READ-MEMORY-DATA)	;START LATER TO AVOID CLOBBERING
;REQUIRED ARGUMENT IS PRESENT
QBRQA	(CALL-IF-BIT-SET (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBSPCL)

;ENTER HERE WHEN ARG HAS BEEN BOUND.  THESE CHECKS ONLY CAUSE EXCEPTIONS
QBDL1	(DISPATCH-XCT-NEXT (LISP-BYTE %%FEF-DES-DT) M-Q QBDDT)
       ((M-C) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
QBDDT1	;(DISPATCH-XCT-NEXT (LISP-BYTE %%FEF-QUOTE-STATUS) M-Q QBEQC)
       ;((M-C) Q-FLAG-BIT C-PDL-BUFFER-INDEX)
QBEQC1	((M-D PDL-BUFFER-INDEX) ADD M-D A-ZERO ALU-CARRY-IN-ONE) ;NEXT ARG SLOT
	((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE) ;NEXT BIND DESC ENTRY
	(JUMP-XCT-NEXT QBINDL)			;PROCEED TO NEXT ARG
       ((A-ARGS-LEFT) ADD (M-CONSTANT -1) A-ARGS-LEFT)

;REST ARG - FOR NOW I ASSUME MICRO-COMPILED FUNCTIONS DO STORE CDR CODES
QBRA	(CALL-NOT-EQUAL A-LCTYP M-ZERO ILLOP)	;IF A NON-SPREAD ARG, SHOULD NOT
						;GET TO REST ARG HERE.
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)	;MAKE PNTR TO LIST OF ARGS
       ((M-K) M-D)
	(CALL-GREATER-THAN-XCT-NEXT M-ZERO A-LOCALP QLLOCB)
       ((M-D) ADD M-D A-ARGS-LEFT)	 	;LOCATE LOCAL BLOCK AFTER LAST ARG
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-K	;STORE REST ARG AS FIRST LOCAL
		Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CALL-IF-BIT-SET (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBLSPCL)
	((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)	;ADVANCE TO NEXT BIND DESC

QBD0	(JUMP-NOT-EQUAL A-LCTYP M-ZERO QREW1)	;ALSO IS A NO-SPREAD ARG
;BINDING LOOP FOR WHEN ALL ARGS HAVE BEEN USED UP
QBD1	(JUMP-LESS-THAN
		M-E (A-CONSTANT 1) QBD2)	;JUMP IF FINISHED ALL BINDING
	((VMA-START-READ) M-I)			;GET NEXT BINDING DESC Q
	(CHECK-PAGE-READ)
	((M-E) SUB M-E (A-CONSTANT 1))
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEF-NAME-PRESENT) READ-MEMORY-DATA QBD2A)
	((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)	;SKIP NAME IF PRESENT
QBD2A	(DISPATCH-XCT-NEXT (LISP-BYTE %%FEF-ARG-SYNTAX) READ-MEMORY-DATA QBDT2)
       ((M-Q) READ-MEMORY-DATA)			;SAVE BINDING DESC IN M-Q

;LOCATE LOCAL BLOCK TO WHERE M-D POINTS
;AFTER THIS HAS BEEN CALLED, USE C-PDL-BUFFER-POINTER-PUSH TO STORE LOCALS
QLLOCB	(POPJ-AFTER-NEXT		;PDL-BUFFER-PTR SHOULD BE SET ALREADY?
					;  --NOT IF TOO FEW ARGS FOR ONE--.
	 (PDL-BUFFER-POINTER) SUB M-D (A-CONSTANT 1))	;FIRST PUSH WILL STORE @ M-D
       ((A-LOCALP) M-D)			;PDL INDEX OF LOCALS

;GOT ARG DESCRIPTOR WHEN OUT OF ARGS
QBTFA1	(JUMP-XCT-NEXT QBOPT2)			;SUPPLY ARG OF NIL
       ((M-QBTFA) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)	;GIVE TOO FEW ARGS ERR LATER

QBRA1	(CALL-GREATER-THAN M-ZERO A-LOCALP QLLOCB)	;REST ARG MISSING, MAKE 1ST LOCAL NIL
QBOPT2	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)	;STORE MISSING ARG AS NIL (CDR CODE?)
QBD1A	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBLSPCL)
       ((M-D) ADD M-D A-ZERO ALU-CARRY-IN-ONE)
QBDIN1	(JUMP-XCT-NEXT QBD1)
       ((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)

;INTERNAL
QBDINT	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBDIN2)
	(JUMP-XCT-NEXT QBDIN1)	;IF SPECIAL, NO LOCAL SLOT, TAKES S-V SLOT
       ((M-T) ADD M-T A-ZERO ALU-CARRY-IN-ONE)

QBDIN2	(JUMP-XCT-NEXT QBOPT2)	;IF LOCAL, IGNORE AT BIND TIME BUT RESERVE LOCAL SLOT
       (CALL-GREATER-THAN M-ZERO A-LOCALP QLLOCB)	;ALSO MUST LOCATE LOCAL BLOCK


;FREE
QBDFRE	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBDIN1) ;TAKES NO LCL SLOT
	(JUMP-XCT-NEXT QBDIN1)				    ;IF SPECIAL, TAKES S-V SLOT
       ((M-T) ADD M-T A-ZERO ALU-CARRY-IN-ONE)

;AUX
QBDAUX	(CALL-GREATER-THAN M-ZERO A-LOCALP QLLOCB)	;LOCATE LOCAL BLOCK, 
						; THEN DROP THROUGH TO INITIALIZE
QBOPT4	(DISPATCH (LISP-BYTE %%FEF-INIT-OPTION) M-Q QBOPTT)

;OPTIONAL NOT PRESENT
QBOPT1	(JUMP-GREATER-THAN M-ZERO A-LOCALP QBOPT4)
	(CALL ILLOP)		;SHOULDN'T HAVE ARGS AFTER LOCAL BLOCK IS LOCATED

;OPTIONAL ARGUMENT INIT VIA ALTERNATE STARTING ADDRESS AND NOT PRESENT
;LEAVE STARTING ADDRESS ALONE AND INIT TO SELF, COMPILED CODE WILL
;RE-INIT.  BUT DON'T FORGET TO SKIP OVER THE START ADDRESS.
QBOPT5	((M-I) ADD M-I (A-CONSTANT 1))
;OPTIONAL OR AUX, INIT TO SELF OR NONE, LATER MAY BE REINITED BY COMPILED CODE
QBOPT3	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%FEF-SPECIAL-BIT)
			M-Q QBOPT2)		;LOCAL, INIT TO NIL
	((VMA-START-READ) M-T)			;SPECIAL, GET POINTER TO VALUE CELL
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-NO-TRAP READ-MEMORY-DATA)	;FETCH EXTERNAL VALUE CELL.
							;MUST GET CURRENT VALUE, BUT NOT BARF
							;IF DTP-NULL.  MUST NOT LEAVE AN EVCP
							;SINCE THAT WOULD SCREW PREVIOUS
							;BINDING IF IT WAS SETQ'ED.
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)
;THIS IS LIKE QBD1A, EXCEPT THAT THE THING WE ARE BINDING IT TO
;MAY BE DTP-NULL, WHICH IS ILLEGAL TO LEAVE ON THE PDL BUFFER.
;ALSO, THE VARIABLE IS KNOWN NOT TO BE AN ARGUMENT THAT WAS SUPPLIED,
;SO THERE'S NO DANGER OF CLOBBERING USEFUL DEBUGGING INFORMATION
	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%FEF-SPECIAL-BIT) M-Q QBLSPCL)
       ((M-D) ADD M-D A-ZERO ALU-CARRY-IN-ONE)
	((C-PDL-BUFFER-POINTER) A-V-NIL)	;STORE NIL OVER POSSIBLE GARBAGE
	(JUMP-XCT-NEXT QBD1)
       ((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)

;INIT TO POINTER
QBOPNR	((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)
	((VMA-START-READ) M-I)			;FETCH THING TO INIT TOO, TRANSPORT IT
QBDR1	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(JUMP-XCT-NEXT QBD1A)
       ((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)

;INIT TO C(POINTER)
QBOCPT	((M-I) ADD M-I A-ZERO ALU-CARRY-IN-ONE)
	((VMA-START-READ) M-I)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(JUMP-XCT-NEXT QBDR1)
       ((VMA-START-READ) READ-MEMORY-DATA)

;INIT TO CONTENTS OF "EFFECTIVE ADDRESS"
QBOEFF	((M-I VMA-START-READ) ADD M-I A-ZERO ALU-CARRY-IN-ONE)
	(CHECK-PAGE-READ)
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 6) READ-MEMORY-DATA QBOFDT) ;DISPATCH ON REG
       ((M-1) (BYTE-FIELD 6 0) READ-MEMORY-DATA)	;PICK UP DELTA FIELD

QBFE	((M-1) (BYTE-FIELD 8 0) READ-MEMORY-DATA)	;FULL DELTA
	(JUMP-XCT-NEXT QBDR1)
       ((VMA-START-READ) ADD M-A A-1)		;FETCH FROM FEF OF FCN ENTERING

QBQT	(JUMP-XCT-NEXT QBDR1)
       ((VMA-START-READ) ADD M-1 A-V-CONSTANTS-AREA)	;FETCH FROM CONSTANTS PAGE

QBDLOC	(CALL-GREATER-THAN M-ZERO A-LOCALP ILLOP) ;TRYING TO ADDRESS LOCALS BEFORE LOCATED
	((PDL-BUFFER-INDEX) ADD M-1 A-LOCALP)	;FETCH LOCAL
	(JUMP-XCT-NEXT QBD1A)
       ((C-PDL-BUFFER-POINTER-PUSH) C-PDL-BUFFER-INDEX)

QBDARG	((PDL-BUFFER-INDEX) ADD M-1 A-S ALU-CARRY-IN-ONE)	;FETCH ARG
	(JUMP-XCT-NEXT QBD1A)		;(%LP-INITIAL-LOCAL-BLOCK-OFFSET = 1)
       ((C-PDL-BUFFER-POINTER-PUSH) C-PDL-BUFFER-INDEX)

;TOO MANY ARGS
QBTMA2	((M-QBTMA) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)
	(DISPATCH-XCT-NEXT  (LISP-BYTE %%FEF-ARG-SYNTAX) M-Q QBDT2) ;FINISH BIND DESCS
       ((M-D) ADD M-D A-ARGS-LEFT)	;ADVANCING LCL PNTR PAST THE EXTRA ARGS

;TOO MANY ARGS AND BIND DESC LIST ALL USED UP
QBTMA1	((M-QBTMA) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)
	((M-D) ADD M-D A-ARGS-LEFT)	;ADVANCE LCL PNTR PAST THE EXTRA ARGS

;HERE WHEN BIND DESC LIST HAS BEEN USED UP
QBD2	(CALL-GREATER-THAN M-ZERO A-LOCALP QLLOCB)  ;SET UP LOCAL BLOCK
	((M-TEM) A-LOCALP)
	((M-TEM) SUB M-TEM A-S)
	((A-TEM1) DPB M-TEM (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;ASSEMBLE ENTRY STATE Q
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	(JUMP-XCT-NEXT QLENX)
       ((C-PDL-BUFFER-INDEX) DPB M-R
		(LISP-BYTE %%LP-ENS-NUM-ARGS-SUPPLIED) A-TEM1)

;COME HERE WHEN BINDING A SPECIAL TO A LOCAL
QBLSPCL	((PDL-BUFFER-INDEX) PDL-BUFFER-POINTER)

;COME HERE WHEN BINDING A SPECIAL
; NOTE CODE BELOW CLEARS %%FEFHI-SVM-HIGH-BIT IN M-C.  THIS IS FOR THE BENEFIT OF
;FRMBN1.  ITS A CROCK, BUT NON-MODULARITY WAS DEEMED WORTH IT BECAUSE OTHERWISE
;CLEAR WOULD HAVE TO BE DONE IN A LOOP.
;NOTE THAT IF WE CAME HERE FROM QBOPT3 THERE MAY BE ILLEGAL DATA TEMPORARILY ON THE PDL BUFFER!
;LETTERED REGS CLOBBERED: M-B, M-K.  M-T HAS S-V PNTR TABLE ADDR, M-C HAS FLAGS.
QBSPCL	((VMA-START-READ) M-T)			;GET SPECIAL VALUE CELL POINTER
	(CHECK-PAGE-READ)
	((M-1) ADD (M-CONSTANT 23.) A-QLBNDP)	;TEST P.C.E. (THIS M-CONST JUST HAPPENED TO
	((M-1) SUB M-1 A-QLBNDH)		; BE AROUND AT THE WRONG TIME).
	(CALL-IF-BIT-CLEAR BOXED-SIGN-BIT M-1 TRAP)
	    (ERROR-TABLE PDL-OVERFLOW SPECIAL)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA) ;TRANSPORT THE SPECIAL VALUE CELL PTR
	((VMA-START-READ M-B) DPB READ-MEMORY-DATA Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	(CHECK-PAGE-READ)			;GET CONTENTS OF INTERNAL VALUE CELL
;CODE BELOW IS LOGICALLY SOMEWHAT SIMILAR TO QBND2.
	((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)	;CHASE FORWARDING PTR IF ANY
	((M-B) VMA)				;CELL ACTUALLY BOUND
	((M-K) Q-TYPED-POINTER READ-MEMORY-DATA) ;BINDING TO SAVE
	((M-TEM) C-PDL-BUFFER-INDEX)		;GET VAL TO BIND TO (ARG OR LOCAL)
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT 
		READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER 
		A-TEM)		;NEW VALUE CELL CONTENTS
	(CHECK-PAGE-WRITE)
	((M-C) DPB M-ZERO (LISP-BYTE %%FEFHI-SVM-HIGH-BIT) A-C) ;FOR FRMBN1'S BENEFIT
						;IF WE ARE COMING FROM THERE.
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) M-K)
	(JUMP-IF-BIT-SET-XCT-NEXT M-QBBFL QBSPCL1)	;JUMP IF NOT FIRST IN BLOCK
       ((M-T) ADD M-T A-ZERO ALU-CARRY-IN-ONE)	 ;ADVANCE TO NEXT S-V SLOT
	((M-K WRITE-MEMORY-DATA) DPB (M-CONSTANT -1) Q-FLAG-BIT A-K)
	((M-QBBFL) DPB (M-CONSTANT -1) A-FLAGS)
QBSPCL1 ((VMA-START-WRITE) A-QLBNDP)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) M-B)
	((VMA-START-WRITE M-K) M+A+1 M-ZERO A-QLBNDP)
	(CHECK-PAGE-WRITE)			;Note possible invz pntr cleared from M-K
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((A-QLBNDP) ADD M-ZERO A-QLBNDP ALU-CARRY-IN-ONE)

;DATA TYPE CHECKS
QDTATM	(JUMP-EQUAL M-C (A-CONSTANT (EVAL DTP-SYMBOL)) QBDDT1)
QDTN	(JUMP-EQUAL M-C (A-CONSTANT (EVAL DTP-FIX)) QBDDT1)
	(JUMP-EQUAL M-C (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) QBDDT1)
QBDDT3	(JUMP-XCT-NEXT QBDDT1)		;BAD DATA TYPE
       ((M-QBBDT) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)

QDTFXN	(JUMP-EQUAL M-C (A-CONSTANT (EVAL DTP-FIX)) QBDDT1)
	(JUMP QBDDT3)

QDTSYM	(JUMP-EQUAL M-C (A-CONSTANT (EVAL DTP-SYMBOL)) QBDDT1)
	(JUMP QBDDT3)

QDTLST	((M-C) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	(JUMP-EQUAL M-C A-V-NIL QBDDT1)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-INDEX SKIP-IF-LIST)
	 (JUMP QBDDT3)
	(JUMP QBDDT1)

QDTFRM	(JUMP-EQUAL M-C (A-CONSTANT (EVAL DTP-FEF-POINTER)) QBDDT1)
	(JUMP QBDDT3)

;EVAL/QUOTE CHECKS
;QBEQE	(JUMP-EQUAL M-C A-ZERO QBEQC1)
;QBEQQ1	(JUMP-XCT-NEXT QBEQC1)
;      ((M-QBBQTS) DPB (M-CONSTANT -1) A-ERROR-SUBSTATUS)
;
;QBEQQ	(JUMP-NOT-EQUAL M-C A-ZERO QBEQC1)
;	(JUMP QBEQQ1)

;;FRAME BIND. BIND S-V S FROM FRAME FAST ENTERED USING S.V. MAP
FRMBN1	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-SV-BITMAP)))
	(CHECK-PAGE-READ)
	((M-D PDL-BUFFER-INDEX) M-AP)
	((M-T) ADD M-A (A-CONSTANT (EVAL %FEFHI-SPECIAL-VALUE-CELL-PNTRS)))
	(CALL-IF-BIT-CLEAR (LISP-BYTE %%FEFHI-SVM-ACTIVE) 
		READ-MEMORY-DATA ILLOP)  ;FOO FAST OPT 
			;SHOULD NOT BE ON UNLESS SVM IS. (IT ISNT WORTH IT TO HAVE
			;ALL THE HAIRY MICROCODE TO SPEED THIS CASE UP A TAD.)
	((M-C) (LISP-BYTE %%FEFHI-SVM-BITS) READ-MEMORY-DATA)
FRMBN2	(POPJ-EQUAL M-C A-ZERO)	  ;POPJ IF NO MORE BITS
	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%FEFHI-SVM-HIGH-BIT) 
			M-C QBSPCL)	;QBSPCL CLEARS %%FEFHI-SVM-HIGH-BIT IN M-C
       ((M-D PDL-BUFFER-INDEX) ADD M-D A-ZERO ALU-CARRY-IN-ONE)
	(JUMP-XCT-NEXT FRMBN2)
       ((M-C) M+M M-C A-ZERO)

;POP A BLOCK OF BINDINGS
BBLKP	(JUMP-XCT-NEXT BBLKP1)
       ((M-ZR) SETCA A-ZERO)

;POP A BINDING (MUSTN'T BASH M-T, M-J, M-R, M-D, M-C)
QUNBND	((M-ZR) A-ZERO)
BBLKP1	((VMA-START-READ) A-QLBNDP)		;Get pntr to bound cell
	(CHECK-PAGE-READ)
	((A-QLBNDP) ADD A-QLBNDP (M-CONSTANT -1))
	((A-QLBNDP) ADD A-QLBNDP (M-CONSTANT -1))
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-Q) READ-MEMORY-DATA)
	((VMA-START-READ) M+A+1 M-ZERO A-QLBNDP)	;Previous contents
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE M-Q)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-LOCATIVE)) ILLOP)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-B) READ-MEMORY-DATA)
	((VMA-START-READ) M-Q)			;Access bound cell
	(CHECK-PAGE-READ)			;This is only to preserve cdr/flag bits
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT
		READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-B)
	(CHECK-PAGE-WRITE-BIND)
BBLKP3	(JUMP-IF-BIT-SET Q-FLAG-BIT M-B BBLKP2)	;Jump if last binding in block
	(JUMP-NOT-EQUAL M-ZR A-ZERO BBLKP1)	;Loop if BBLKP
	(POPJ-IF-BIT-CLEAR-XCT-NEXT M-DEFERRED-SEQUENCE-BREAK-FLAG)	;Exit if QUNBND
       ((M-B) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;Dont leave a DTP-E-V-C-P in M-B
	(JUMP SB-REINSTATE)			; (If SB, this might make SG switch bomb).

BBLKP2	((M-B) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;Dont leave a DTP-E-V-P in M-B
	(POPJ-IF-BIT-CLEAR-XCT-NEXT M-DEFERRED-SEQUENCE-BREAK-FLAG)
       ((M-QBBFL) DPB M-ZERO A-FLAGS)		;NO MORE B.B.
SB-REINSTATE		;SB deferred.  Take it now?
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-INHIBIT-SCHEDULING-FLAG)
	(POPJ-NOT-EQUAL M-TEM A-V-NIL)
	((LOCATION-COUNTER) LOCATION-COUNTER)   ;write LC (assuring fetch of PC)
	(POPJ-AFTER-NEXT   			; and set SB req.
	  (INTERRUPT-CONTROL) IOR LOCATION-COUNTER (A-CONSTANT 1_26.))
       ((M-DEFERRED-SEQUENCE-BREAK-FLAG) DPB M-ZERO A-FLAGS)

XUB (MISC-INST-ENTRY UNBIND-0)			;UNBIND N BLOCKS
    (MISC-INST-ENTRY UNBIND-1)
    (MISC-INST-ENTRY UNBIND-2)
    (MISC-INST-ENTRY UNBIND-3)
    (MISC-INST-ENTRY UNBIND-4)
    (MISC-INST-ENTRY UNBIND-5)
    (MISC-INST-ENTRY UNBIND-6)
    (MISC-INST-ENTRY UNBIND-7)
    (MISC-INST-ENTRY UNBIND-10)
    (MISC-INST-ENTRY UNBIND-11)
    (MISC-INST-ENTRY UNBIND-12)
    (MISC-INST-ENTRY UNBIND-13)
    (MISC-INST-ENTRY UNBIND-14)
    (MISC-INST-ENTRY UNBIND-15)
    (MISC-INST-ENTRY UNBIND-16)
    (MISC-INST-ENTRY UNBIND-17)
	((M-D) (BYTE-FIELD 4 0) M-B)	;GET # BINDINGS TO POP MINUS ONE
XUB1	(CALL-IF-BIT-CLEAR M-QBBFL ILLOP)	;TRYING TO OVERPOP FRAME
	(CALL QUNBND)	
	(POPJ-EQUAL M-D A-ZERO)
	(JUMP-XCT-NEXT XUB1)
       ((M-D) SUB M-D (A-CONSTANT 1))

XPOPIP (MISC-INST-ENTRY POPPDL-0)
       (MISC-INST-ENTRY POPPDL-1)
       (MISC-INST-ENTRY POPPDL-2)
       (MISC-INST-ENTRY POPPDL-3)
       (MISC-INST-ENTRY POPPDL-4)
       (MISC-INST-ENTRY POPPDL-5)
       (MISC-INST-ENTRY POPPDL-6)
       (MISC-INST-ENTRY POPPDL-7)
       (MISC-INST-ENTRY POPPDL-10)
       (MISC-INST-ENTRY POPPDL-11)
       (MISC-INST-ENTRY POPPDL-12)
       (MISC-INST-ENTRY POPPDL-13)
       (MISC-INST-ENTRY POPPDL-14)
       (MISC-INST-ENTRY POPPDL-15)
       (MISC-INST-ENTRY POPPDL-16)
       (MISC-INST-ENTRY POPPDL-17)
;	(POPJ-AFTER-NEXT
;	 (M-B) (BYTE-FIELD 4 0) M-B)	;POP PDL 1-16.  NOTE THIS CAN NOT BE CALLED BY
;					;COMPILED MICROCODE SINCE B WONT BE SET UP
;      ((PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER A-B)
;THE FOLLOWING IS A TEMPORARY KLUDGE UNTIL THE COMPILER BUG IS FIXED. 12/19/78 MOON, PER RMS
	((M-B) (BYTE-FIELD 4 0) M-B)
XPOPIP-2
	((PDL-BUFFER-POINTER M-B) SUB PDL-BUFFER-POINTER A-B)
XPOPIP-1
	((M-TEM) SUB PDL-BUFFER-POINTER A-IPMARK)
	(POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 9) M-TEM) ;PP >= A-IPMARK mod 2000
	(CALL XPOP-OPEN-CALL)		;Compiler forgot to flush this open call block
	(JUMP-XCT-NEXT XPOPIP-1)	;Try again
       ((PDL-BUFFER-POINTER) M-B)	;Try to put PP where compiler seemed to want it

XMOVE-PDL-TOP (MISC-INST-ENTRY MOVE-PDL-TOP)
	(POPJ-AFTER-NEXT (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
       (NO-OP)

XSHRINK-PDL-SAVE-TOP (MISC-INST-ENTRY SHRINK-PDL-SAVE-TOP)
	((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;AMT TO DECREMENT PP BY
	(JUMP-XCT-NEXT XPOPIP-2)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;THING TO RETURN

XSPECIAL-PDL-INDEX (MISC-INST-ENTRY SPECIAL-PDL-INDEX)
	((M-T) A-QLBNDP)
	(POPJ-AFTER-NEXT (M-T) SUB M-T A-QLBNDO)
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XUNBIND-TO-INDEX-MOVE (MISC-INST-ENTRY UNBIND-TO-INDEX-MOVE)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;VALUE TO RETURN LATER
XUNBIND-TO-INDEX (MISC-INST-ENTRY UNBIND-TO-INDEX)
	((M-D) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-D) ADD M-D A-QLBNDO)
XUNBIND-TO-INDEX-1
	(POPJ-GREATER-OR-EQUAL M-D A-QLBNDP)
	(CALL-IF-BIT-CLEAR M-QBBFL ILLOP)
	(JUMP-XCT-NEXT XUNBIND-TO-INDEX-1)
       (CALL QUNBND)

;Get rid of one open call block, setting PDL-BUFFER-POINTER back to before
;call block and associated ADI.  Note that an open call block never has any
;associated binding-pdl slots, since closures and so forth are processed
;when the call is activated.  The compiler always generates this to D-IGNORE,
;so we don't put anything in M-T (other callers may not want it clobbered.)
;Bashes only M-K.  This routine is for "macro" execution mode only.
XPOP-OPEN-CALL (MISC-INST-ENTRY POP-OPEN-CALL)
	((M-K) A-IPMARK)
	(CALL-EQUAL M-K A-AP TRAP)	;Trying to pop call block that isn't open
		(ERROR-TABLE ILLEGAL-INSTRUCTION)
	((PDL-BUFFER-INDEX) ADD M-K (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-TEM) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) C-PDL-BUFFER-INDEX)
	((M-TEM) SUB M-K A-TEM)
	((A-IPMARK) (BYTE-FIELD 10. 0) M-TEM)
	((PDL-BUFFER-POINTER) SUB M-K (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH)))
	(POPJ-IF-BIT-CLEAR (LISP-BYTE %%LP-CLS-ADI-PRESENT) C-PDL-BUFFER-INDEX)
	(JUMP-XCT-NEXT QRAD2)		;Must flush ADI.
       ((PDL-BUFFER-INDEX M-K) SUB PDL-BUFFER-POINTER (A-CONSTANT 1))

;;; CAR AND CDR
;   NOTE- ALWAYS RETURNS 0 IN FIELDS OTHER THAN POINTER AND DATA TYPE

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAR M-T)

QTA   (MISC-INST-ENTRY M-CAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMA
   (ERROR-TABLE RESTART CAR)
QCAR	(DISPATCH (I-ARG CAR-INVOKE-OP) Q-DATA-TYPE M-T CAR-PRE-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)
				;DROP THROUGH IF NORMAL CAR
QCAR3	((VMA-START-READ) M-T)
QCAR4	(CHECK-PAGE-READ)  
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)	;CHECK FOR INVZ, GC
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

QCARSY	(DISPATCH-XCT-NEXT M-CAR-SYM-MODE CAR-SYM-DISPATCH)	;CAR OF A SYMBOL
       ((M-T) Q-TYPED-POINTER M-T)
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL TRAP)
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)

QCARNM	(DISPATCH M-CAR-NUM-MODE CAR-NUM-DISPATCH)	;CAR OF A NUMBER
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)



(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDR M-T)

QTD   (MISC-INST-ENTRY M-CDR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMD   
   (ERROR-TABLE RESTART CDR)
QCDR	(DISPATCH (I-ARG CDR-INVOKE-OP) Q-DATA-TYPE M-T CDR-PRE-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)
					;DROP THROUGH IF NORMAL LIST CDR
QCDR3	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)  
	(DISPATCH TRANSPORT-CDR READ-MEMORY-DATA)	;CHECK FOR INVZ, DON'T REALLY TRANSPORT
	(DISPATCH Q-CDR-CODE READ-MEMORY-DATA CDR-CDR-DISPATCH)
   (ERROR-TABLE BAD-CDR-CODE RMD)				;POPJ-XCT-NEXT IF CDR NEXT
       ((M-T) ADD VMA (A-CONSTANT 1))		;SAME DATA TYPE AS ARG

QCDRSY	(DISPATCH-XCT-NEXT M-CDR-SYM-MODE CDR-SYM-DISPATCH)
       ((M-T) Q-TYPED-POINTER M-T)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL TRAP)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)

QCDRNM	(DISPATCH M-CDR-NUM-MODE CDR-NUM-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)

CDR-FULL-NODE 
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)  
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA) ;CHECK FOR INVISIBLE, GC
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

CDR-IS-NIL 
   (MISC-INST-ENTRY FALSE)
XFALSE 	(POPJ-AFTER-NEXT (M-T) A-V-NIL)
       (NO-OP)

QCDPRP	((M-T) Q-TYPED-POINTER M-T)		;TAKING CDR OF SYMBOL (IN P-LIST MODE)
	(JUMP-EQUAL M-T A-V-NIL XFALSE)		;CDR OF NIL IS NIL,
 	((M-T) ADD (A-CONSTANT 3) M-T)		;OTHERWISE IS THE SYMBOL'S PLIST
	(JUMP-XCT-NEXT QCDR)
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

;; Multiple CAR/CDR functions.

;; QMA, QMD, etc. take arg in M-T and return value in M-T.
;; XCAAR, etc. pop arg off stack and return value in M-T.
;; QTAD, etc., exist only for certain functions.
;; They pop arg off stack like XCADR, etc., but do not set M-A.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDDR M-A)

XCADDDR (MISC-INST-ENTRY CADDDR)
	((M-A) C-PDL-BUFFER-POINTER)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMADDD 	(CALL QMD)		;These also MC-LINKAGE entries
QMADD 	(CALL QMD)
QMAD 	(CALL QMD)
	(JUMP QMA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAAR M-A)

XCAAAAR	(MISC-INST-ENTRY CAAAAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
QMAAAA 	(CALL QMA)			;These also MC-LINKAGEs
QMAAA  	(CALL QMA)
QMAA   	(CALL QMA)
	(JUMP QMA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDDR M-A)

XCDDDDR (MISC-INST-ENTRY CDDDDR)
	((M-A) C-PDL-BUFFER-POINTER)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMDDDD 	(CALL QMD)		;These also MC-LINKAGE entries.
QMDDD 	(CALL QMD)
QMDD 	(CALL QMD)
	(JUMP QMD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAADR M-A)

XCAAADR (MISC-INST-ENTRY CAAADR)
 	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMAAA)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMAAAD 	(CALL QMD)			;MC-LINKAGE
	(JUMP QMAAA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDAR M-A)

XCDDDAR (MISC-INST-ENTRY CDDDAR)
 	(CALL-XCT-NEXT QMA)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMDDD)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMDDDA 	(CALL QMA)			;MC-LINKAGE
	(JUMP QMDDD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADDR M-A)

XCAADDR (MISC-INST-ENTRY CAADDR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
QMAADD 	(CALL QMD)			;MC-LINKAGE
QMAAD  	(CALL QMD)
	(JUMP QMAA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADAR M-A)

XCAADAR (MISC-INST-ENTRY CAADAR)
 	(CALL-XCT-NEXT QMA)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMAAD)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMAADA 	(CALL QMA)			;MC-LINKAGE
	(JUMP QMAAD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAAR M-A)

XCDDAAR (MISC-INST-ENTRY CDDAAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
QMDDAA 	(CALL QMA)			;MC-LINKAGE
QMDDA  	(CALL QMA)
	(JUMP QMDD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDADR M-A)

XCDDADR (MISC-INST-ENTRY CDDADR)	
 	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMDDA)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMDDAD 	(CALL QMD)			;MC-LINKAGE
	(JUMP QMDDA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAAR M-A)

XCADAAR (MISC-INST-ENTRY CADAAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
QMADAA 	(CALL QMA)			;MC-LINKAGE
QMADA  	(CALL QMA)
	(JUMP QMAD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADADR M-A)

XCADADR (MISC-INST-ENTRY CADADR)
 	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMADA)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMADAD 	(CALL QMD)			;MC-LINKAGE
	(JUMP QMADA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDAR M-A)

XCADDAR (MISC-INST-ENTRY CADDAR)
 	(CALL-XCT-NEXT QMA)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMADD)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMADDA 	(CALL QMA)			;MC-LINKAGE
	(JUMP QMADD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADAR M-A)

XCDADAR (MISC-INST-ENTRY CDADAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
QMDADA 	(CALL QMA)			;MC-LINKAGE
QMDAD  	(CALL QMD)
	(JUMP QMDA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADDR M-A)

XCDADDR (MISC-INST-ENTRY CDADDR)
 	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(CALL-XCT-NEXT QMD)
       ((M-A) C-PDL-BUFFER-POINTER-POP)
	(JUMP QMDA)

QMDADD 	(CALL QMD)			;MC-LINKAGE
	(JUMP QMDAD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAAR M-A)

XCDAAAR (MISC-INST-ENTRY CDAAAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
QMDAAA 	(CALL QMA)			;MC-LINKAGE
QMDAA  	(CALL QMA)
QMDA   	(CALL QMA)
	(JUMP QMD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAADR M-A)

XCDAADR (MISC-INST-ENTRY CDAADR)
 	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMDAA)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QMDAAD 	(CALL QMD)			;MC-LINKAGE
	(JUMP QMDAA)


;For CAAAR ... CDDDR, the arg is in M-A whenever an error occurs.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAR M-A)

XCAAAR (MISC-INST-ENTRY CAAAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMAAA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADR M-A)

XCAADR (MISC-INST-ENTRY CAADR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMAAD)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAR M-A)

XCADAR (MISC-INST-ENTRY CADAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMADA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDR M-A)

XCADDR (MISC-INST-ENTRY CADDR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMADD)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAR M-A)

XCDAAR (MISC-INST-ENTRY CDAAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMDAA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADR M-A)

XCDADR (MISC-INST-ENTRY CDADR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMDAD)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAR M-A)

XCDDAR (MISC-INST-ENTRY CDDAR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMDDA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDR M-A)

XCDDDR (MISC-INST-ENTRY CDDDR)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT QMDDD)
       ((M-A) M-T)

;For CAAR ... CDDR, the arg is in M-A unless an ARG-POPPED says it is elsewhere.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAR M-A)

XCAAR  (MISC-INST-ENTRY M-CAAR)
	(CALL-XCT-NEXT QMA)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMA)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADR M-A)

XCADR  (MISC-INST-ENTRY M-CADR)
	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMA)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAR M-A)

XCDAR  (MISC-INST-ENTRY M-CDAR)
	(CALL-XCT-NEXT QMA)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMD)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDR M-A)

XCDDR  (MISC-INST-ENTRY M-CDDR)
	(CALL-XCT-NEXT QMD)
       ((M-T) C-PDL-BUFFER-POINTER)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMD)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QTAD	(CALL QTD)
	(JUMP QMA)

QTDD	(CALL QTD)
	(JUMP QMD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTH PP M-T)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTHCDR PP M-T)

XNTH (MISC-INST-ENTRY NTH)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCAR)))
	;drops in
XNTHCDR (MISC-INST-ENTRY NTHCDR)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;List
		(ERROR-TABLE RESTART XNTHCDR0)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
	(CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP)
       ((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)		;Count
	(POPJ-EQUAL-XCT-NEXT M-1 A-ZERO)
       ((M-A) M-T)
XNTHCDR-1
	(CALL-NOT-EQUAL M-T A-V-NIL QCDR)
	    (ERROR-TABLE CALLS-SUB NTHCDR)
	    (ERROR-TABLE ARG-POPPED 0 M-B M-A)
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XNTHCDR-1)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	(POPJ)

;;; RPLACA AND RPLACD

  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACA M-S M-T)
  (MISC-INST-ENTRY RPLACA)
XRPLCA	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
   (ERROR-TABLE RESTART RPLACA)
QRAR1	(DISPATCH (I-ARG RPLACA-INVOKE-OP) Q-DATA-TYPE M-S QRACDT)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACA)

QRASYM	(CALL-EQUAL M-S A-V-NIL TRAP)		;RPLACA ING NIL ALWAYS ERROR
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACA)
	(DISPATCH M-CAR-SYM-MODE RPLACA-SYM-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACA)

QRAR3	((VMA-START-READ) M-S)			;FETCH WORD TO BE SMASHED
	(CHECK-PAGE-READ)			;NO INT, CALLED BY MVR
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)	;CHASE INVISIBLES
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT
		READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)	;STORE M-T INTO Q-TYPED-PNTR
	(CHECK-PAGE-WRITE)			;NO SEQ BRK, CALLED BY MVR (???)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) M-S)

  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACD M-S M-T)
  (MISC-INST-ENTRY RPLACD)
;MUSTN'T CLOBBER M-C OR M-R BECAUSE CALLED BY MULTIPLE-VALUE-LIST
;NOW CLOBBERS M-S, M-T, M-I, M-A
XRPLCD	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
   (ERROR-TABLE RESTART RPLACD)
QRDR1	(DISPATCH (I-ARG RPLACD-INVOKE-OP) Q-DATA-TYPE M-S QRDCDT)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACD)

QRDRSY	(DISPATCH M-CDR-SYM-MODE RPLACD-SYM-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACD)

QRDPRP 	((M-S) ADD (A-CONSTANT 3) M-S)		;RPLACD ING SYMBOL (IN P-LIST MODE)
	(JUMP-XCT-NEXT QRDR1)
       ((M-S) DPB M-S Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

QRDR3	((VMA-START-READ) M-S)			;GET CAR OF CONS TO BE SMASHED
	(CHECK-PAGE-READ)			;NO SEQ BRK, CDR CODE IN HAND, ALSO MVR
	(DISPATCH TRANSPORT-CDR READ-MEMORY-DATA) ;CHASE INVISIBLE, NO NEED TO TRANSPORT
	(DISPATCH-XCT-NEXT Q-CDR-CODE READ-MEMORY-DATA RPLACD-CDR-DISPATCH)
   (ERROR-TABLE BAD-CDR-CODE RMD)
       ((M-I) READ-MEMORY-DATA)

RPLACD-FULL-NODE
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;GET WORD TO SMASH
	(CHECK-PAGE-READ)			;NO SEQ BRK, WORD IN HAND, ALSO MVR
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)	;CHASE INVISIBLES
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT	;STORE M-T INTO Q-TYPED-PNTR
		READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)			;NO SEQ BRK, CALLED BY MVR (???)
QRDR2	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) M-S)

RPLACD-NEXT-NIL 
	(JUMP-EQUAL M-T A-V-NIL QRDR2)		;RPLACD WITH NIL AND CDR ALREADY NIL, NO-OP
RPLACD-CDR-NEXT 
;THIS CODE CAN SEQUENCE BREAK!!! BEWARE!!!
	((C-PDL-BUFFER-POINTER-PUSH) M-S)		;SAVE THIS SO WE CAN RETURN IT
	((C-PDL-BUFFER-POINTER-PUSH) VMA)		;ADDR OF CELL TO BE FORWARDED
	((MD) VMA)					;ADDRESS THE MAP
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits
	((M-TEM) (LISP-BYTE %%REGION-REPRESENTATION-TYPE) MEMORY-MAP-DATA)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-LIST)) TRAP)
    (ERROR-TABLE RPLACD-WRONG-REPRESENTATION-TYPE M-S)
    (ERROR-TABLE ARG-POPPED 0 (PP 1) M-T)
	((C-PDL-BUFFER-POINTER-PUSH) M-I)		;CAR OF NEW CELL
	((C-PDL-BUFFER-POINTER-PUSH) M-T)		;CDR OF NEW CELL
	(CALL-XCT-NEXT XARN)				;IN WHAT AREA WAS THE CONS?
       ((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER MD)	;MD HAS ORIGINAL VMA
	(CALL-XCT-NEXT QCONS)
       ((M-S) Q-TYPED-POINTER M-T)			;PASS ON THE AREA NUMBER
	((WRITE-MEMORY-DATA) DPB M-T Q-POINTER		;CLOBBER ORIGINAL "CAR"
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-HEADER-FORWARD)))
	((VMA-START-WRITE) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;RETURN THE ORIGINAL FIRST ARG

;;; EQUAL

XEQUAL	(MISC-INST-ENTRY EQUAL)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
XEQUAL-0
	(JUMP-EQUAL M-T A-B XTRUE)
	((M-1) Q-DATA-TYPE M-T)
	((M-2) Q-DATA-TYPE M-B)
	(JUMP-NOT-EQUAL M-1 A-2 XFALSE)
	(CALL XEQUAL-1)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XEQUAL-ARRAY)
	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-NO-ATOM)
	(JUMP XFALSE)

	;; Now we are a list	
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(CALL-XCT-NEXT QCAR3)
       ((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((M-B) M-T)
	(CALL-XCT-NEXT QCAR3)
       ((M-T) C-PDL-BUFFER-POINTER)
	;; If the micro stack is filling up, make new stack frame.
	(JUMP-GREATER-THAN MICRO-STACK-PNTR-AND-DATA (A-CONSTANT 10._24.)
			   XEQUAL-SLOW-RECURSE)
	;; Otherwise, test for EQUALity of the two cars.
	(CALL XEQUAL-0)

XEQUAL-CDR
	(JUMP-EQUAL M-T A-V-NIL XEQUAL-DIFFERENT-CARS)
	;; If the cars match, tail-recursively check the two cdrs.
	(CALL-XCT-NEXT QCDR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-B) M-T)
	(CALL-XCT-NEXT QCDR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP XEQUAL-0)

XEQUAL-DIFFERENT-CARS
	(POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
       (NO-OP)

XEQUAL-SLOW-RECURSE
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCEQL))
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((ARG-CALL MMCALL) (I-ARG 2))
	(JUMP XEQUAL-CDR)

	;;Numbers are EQUAL if =
XEQUAL-1
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T POPJ-IF-NOT-NUMBER)
       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL))
	((M-GARBAGE) MICRO-STACK-DATA-POP)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-B D-NUMARG1)
       (NO-OP)
	(JUMP XFALSE)				;Non-EQ fixnums

XEQUAL-ARRAY
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-1) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUAL-STRING)
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XFALSE)
XEQUAL-STRING
	((VMA-START-READ) M-B)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-2) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA)
	(JUMP-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUAL-STRING-1)
	(JUMP-NOT-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XFALSE)
XEQUAL-STRING-1
	((C-PDL-BUFFER-POINTER-PUSH) A-T)
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) )
	((C-PDL-BUFFER-POINTER-PUSH) A-B)
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
	(JUMP XSTRING-EQUAL)			;No XCT-NEXT here

;;; ARRAYS

;GENERAL ON ARRAY REFERENCING--
; CODE TO DEAL WITH NON-DISPLACED ARRAYS IS CODED OPEN, WHILE THAT TO
;DEAL WITH DISPLACED ARRAYS IS IN DSP-ARRAY-SETUP.  SINCE THE DISPLACED 
;CASE EVENTUALLY DROPS INTO THE NORMAL CASE, CERTAIN CONVENTIONS ARE NECESSARY.
; THE NORMAL SEQUENCE OF CODE IS
;      1: GET ARRAY-POINTER Q INTO M-A
;      2: CALL GAHD1 TO FETCH ARRAY-HEADER Q INTO M-B.  GAHD1 MAKES SURE IT
;	    IS THE RIGHT TYPE, ETC.  M-D GET NUMBER DIMENSIONS, M-E DATA ORIGIN,
;	    M-S DATA STORAGE LENGTH IN ELEMENTS (NOT QS).
;      3: GET ELEMENT NUMBER WANT TO REF IN M-Q.
;      4: DO (CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B DSP-ARRAY-SETUP)
;	    THIS WILL CHANGE M-E AND M-S, AND MAY CHANGE M-Q.
;	    DSP-ARRAY-SETUP IS TRANSPARENT TO M-A, M-B, AND M-D.
;	    DSP-ARRAY-SETUP KNOWS ABOUT INDIRECT ARRAYS, AND WILL FOLLOW
;		DISPLACED CHAINS, ETC.
;      5: BARF IF M-Q IS GREATER THAN OR EQUAL TO M-S (INDEX OUT OF BOUNDS).
;      6: DISPATCH ON ARRAY-TYPE TO APPROPRIATE REFERENCE ROUTINE.

;M-Q, M-S, M-D, M-E PURE (TYPE-LESS) NUMBERS

;NO SEQ BRKS ALLOWED ANYWHERE IN THIS CODE.  THIS (1) CAUSES STORES
;INTO BYTE ARRAYS TO NOT LOSE SIMULTANEOUS STORES INTO OTHER BYTES SAME WORD
;(2) PREVENTS LOSSAGE FROM ONE PROCESS *REARRAYING WHILE ANOTHER IS REFERENCING
;(3) ALLOWS TWO PROCESSES TO CALL ARRAY-PUSH WITH NO TIMING ERRORS

;THE FOLLOWING REGISTERS MUST BE PRESERVED THROUGH ARRAY REFERENCING,
;FOR THE SAKE OF BITBLT: M-C, M-I, M-K, M-ZR
;VARIOUS ROUTINES ALSO RELY ON M-E, M-Q, M-S, M-B BEING LEFT ALONE
;UPON RETURN FROM THE ARRAY-TYPE-REF-DISPATCH.

		(ERROR-TABLE RESTART BEGIN-QARYR)	;For error handler
QARYR	(CALL GAHD1)				;REFERENCE ARRAY
	(CALL-NOT-EQUAL M-D A-R TRAP)
   (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D M-R M-A)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL AREF)
	((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	(JUMP-NOT-EQUAL (A-CONSTANT 1) M-D QARY-MULTI)	;MULTI DIM ARRAY
QARY-M1	
QARYR1	((A-QLARYL) DPB M-Q Q-POINTER 	;LAST ELEMENT # REF ED
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT)
		 M-B DSP-ARRAY-SETUP)		;ARRAY DISPLACED
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)	;INDEX OUT OF BOUNDS
   (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
	(DISPATCH-CALL-XCT-NEXT 
		(LISP-BYTE %%ARRAY-TYPE-FIELD)
		M-B 
		ARRAY-TYPE-REF-DISPATCH)
   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
       ((A-QLARYH) Q-TYPED-POINTER M-A)	;PNTR TO HEADER OF LAST ARRAY REF ED
;DROPS THROUGH TO RETURN THE ARRAY CONTENTS (IN M-T)

;DROPS IN.  RETURN FROM X-TO-MACRO CALL TO AN ARRAY.
QARYR5	((M-TEM) A-IPMARK)		;GET POINTER TO (OLD) OPEN BLOCK
	((PDL-BUFFER-INDEX) ADD M-TEM (A-CONSTANT (EVAL %LP-CALL-STATE)))
	((M-C) C-PDL-BUFFER-INDEX)	;IN CASE CALL QRAD1 AND CLOBBER PDL INDEX
	((A-TEM1) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) M-C)
	((M-1) SUB M-TEM A-TEM1)
	((A-IPMARK) (BYTE-FIELD 10. 0) M-1)
	((PDL-BUFFER-POINTER) SUB M-TEM (A-CONSTANT (EVAL %LP-CALL-BLOCK-LENGTH)))
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-ADI-PRESENT)
			 M-C		;MULTI-VALUE CALL, STORE LAST VALUE
			 QRAD1)		;IN RIGHT PLACE, ETC
	;; Store into destination in M-C.  Could be D-MICRO.  Duplicates QIMOVE-EXIT
	(DISPATCH (LISP-BYTE %%LP-CLS-DESTINATION) M-C QMDTBD)
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE
			(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
;QBNEAF AND QBALM FLUSHED

;MULTI-DIMENSIONAL ARRAY
QARY-MULTI
	((M-J) M-E)				;Point after last multiplier
QARY-MULTI-1					;No transport since just touched header
	((VMA-START-READ M-J) SUB M-J (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-D) SUB M-D (A-CONSTANT 1))
	((Q-R) M-Q)
	(CALL-XCT-NEXT MPY)			;MULTIPLY M-1 
       ((M-1) Q-POINTER READ-MEMORY-DATA)	;BY CONTENTS OF Q-R, RESULT TO Q-R, BASH M-2
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL AREF)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-Q) ADD Q-R A-1)			;ADD NEXT SUBSCRIPT
	(JUMP-EQUAL (A-CONSTANT 1) M-D QARY-M1)	;JUMP IF THROUGH, FINAL SUBSC IN M-Q
	(JUMP QARY-MULTI-1)
		(ERROR-TABLE RESTART END-QARYR)

GAHD4	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-STACK-GROUP)) GAHD1)	;SG OK
	(CALL TRAP)			;BAD D.T. IN ARRAY-POINTER
   (ERROR-TABLE ARGTYP ARRAY M-A NIL GAHDR)

GAHDRA	((M-A) C-PDL-BUFFER-POINTER-POP)
   (ERROR-TABLE RESTART GAHDR)
GAHDR	((M-TEM) Q-DATA-TYPE M-A)	;FOR USE WHEN A IS NOT ALREADY KNOW TO BE
					; ARRAY-POINTER
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) GAHD4)
GAHD1	((VMA-START-READ) M-A)		;GET ARRAY HEADER
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)	;GC, FOLLOW INVZ
	((M-A) VMA)			;MAY HAVE FORWARDED, GET REAL ADDRESS
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)	;VERIFY ARRAY HEADER DATA TYPE
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-HEADER)) ILLOP)
	((M-B) Q-POINTER READ-MEMORY-DATA)	;SAVE ARRAY HEADER Q
	((M-E) Q-POINTER M-A)		;INITIAL TYPELESS PNTR TO FIRST DATA ELEMENT
	((M-D) (LISP-BYTE %%ARRAY-NUMBER-DIMENSIONS) M-B)
	((M-E) ADD M-E A-D)		;ADDR OF FIRST DATA ELEMENT OF ARRAY (TYPELESS)
	(POPJ-AFTER-NEXT
	 (M-S) (LISP-BYTE %%ARRAY-INDEX-LENGTH-IF-SHORT) M-B)	;INDEX LENGTH
       (CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-LONG-LENGTH-FLAG) M-B GAHD3)

GAHD3	((VMA-START-READ) ADD M-A (A-CONSTANT 1))	;LONG ARRAY, GET INDEX LENGTH Q
	(CHECK-PAGE-READ)		;NO TRANSP SINCE JUST TOUCHED HEADER
	(POPJ-AFTER-NEXT (M-E) ADD M-E (A-CONSTANT 1))	;SPACE OVER INDEX Q
       ((M-S) Q-POINTER READ-MEMORY-DATA)

XAIXL (MISC-INST-ENTRY ARRAY-LENGTH)
	(CALL GAHDRA)
  (ERROR-TABLE CALLS-SUB ARRAY-LENGTH)
  (ERROR-TABLE ARG-POPPED 0 M-A)
XAIXL1	(POPJ-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B)
       ((M-T) DPB M-S Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-READ) ADD M-E (A-CONSTANT 1))	;DISPLACED, GET INDEX LENGTH
	(CHECK-PAGE-READ)	;NO TRANSPORT SINCE JUST TOUCHED HDR
XAIXL2	(POPJ-AFTER-NEXT NO-OP)
       ((M-T) DPB READ-MEMORY-DATA Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XAAIXL (MISC-INST-ENTRY ARRAY-ACTIVE-LENGTH)
	(CALL GAHDRA)
  (ERROR-TABLE CALLS-SUB ARRAY-ACTIVE-LENGTH)
  (ERROR-TABLE ARG-POPPED 0 M-A)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B XAIXL1)
	((VMA-START-READ) SUB M-A (A-CONSTANT 2))	;Get fill pointer from leader
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)		;Fixnum there?
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XAIXL2) ;Yes, it's the fill ptr
	(JUMP XAIXL1)					;No, don't use garbage as fill ptr

DSP-ARRAY-SETUP   ;CALL WITH ARRAY POINTER IN M-A, HEADER IN M-B, 
		  ; FIRST DATA ELEM IN M-E, DESIRED ELEMENT NUMBER IN M-Q.
		  ;RETURNS WITH DATA ORIGIN IN M-E, M-S CHANGED TO REFLECT ARRAY
		  ; BEING REF'ED AND POSSIBLY ADJUSTED M-Q.
	((VMA-START-READ) ADD A-ZERO M-E ALU-CARRY-IN-ONE)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)	;TRANSPORT IN CASE POINTS TO OLDSPACE
	((M-S) Q-POINTER READ-MEMORY-DATA)	;GET NEW DATA LENGTH LIMIT
	((VMA-START-READ) M-E)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)	;TRANSPORT IN CASE POINTS TO OLDSPACE
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(POPJ-NOT-EQUAL-XCT-NEXT M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)))
       ((M-E) Q-POINTER READ-MEMORY-DATA)
;Drops in if Indirect-array
;Operation of QDACMP:
; The word just read from memory is the array-pointer to indirect to
; M-Q has entry number desired
;QDACMP pushes the info relative to the indirect array (M-A, M-B, M-D).
; M-E eventually gets the data base of the pointed-to array.
; M-S gets MIN(M-S from indirect array + index offset, index length of pointed-to array).
; In the process, M-Q will be adjusted if an index offset is encountered.
; After the final data base is determined, M-A, M-B, and M-D are restored.

QDACMP	((C-PDL-BUFFER-POINTER-PUSH) M-A)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((C-PDL-BUFFER-POINTER-PUSH) M-D)
	((C-PDL-BUFFER-POINTER-PUSH)	;SAVE ARRAY-TYPE OF ORIGINALLY REF'ED ARRAY
		(LISP-BYTE %%ARRAY-TYPE-FIELD) M-B  ;THIS MUST BE IN 0@PP BELOW
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
QDACM2	((M-A) READ-MEMORY-DATA)	;POINTED-TO ARRAY
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT READ-MEMORY-DATA QDACM5)  ;JUMP UNLESS INDEX OFFSET
	((VMA-START-READ) ADD VMA (A-CONSTANT 2))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE READ-MEMORY-DATA TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE DATA-TYPE-SCREWUP ARRAY)
	((M-D) Q-POINTER READ-MEMORY-DATA)		;FETCH INDEX OFFSET
	((M-S) ADD M-S A-D)				;ADJUST INDEX LIMIT
	((M-Q) ADD M-Q A-D)				;ADJUST CURRENT INDEX
QDACM5	(CALL-XCT-NEXT GAHD1)		;SETS UP M-E, M-S
       ((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-S	;SAVE POINTER'S INDEX LENGTH
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
  (ERROR-TABLE CALLS-SUB ARRAY-INDIRECT)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B QDACMI)
       ((M-D) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;NOW TAKE MINIMUM OF THE TWO LENGTHS
	((VMA-START-READ) ADD M-E (A-CONSTANT 1))	;DOUBLE DISPLACE, GET CORRECT LENGTH
	(CHECK-PAGE-READ)
	((M-S) Q-POINTER READ-MEMORY-DATA)
QDACMI	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B  ;CHECK IF SAME ARRAY-TYPE AS ORIG REF
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP-NOT-EQUAL C-PDL-BUFFER-POINTER A-TEM QDACM8)  ;NO, ORIG MUST CONTROL
	(JUMP-GREATER-OR-EQUAL M-D A-S QDACM7)
QDACM8	((M-S) M-D)
QDACM7	(JUMP-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B QDACM6) ;FURTHER INDIR
QDACM1	((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)	;FLUSH ARRAY TYPE
	((M-D) C-PDL-BUFFER-POINTER-POP) ;GOT ALL INFO, RESTORE M-A, M-B, M-D
	(POPJ-AFTER-NEXT 
	 (M-B) C-PDL-BUFFER-POINTER-POP)
       ((M-A) C-PDL-BUFFER-POINTER-POP)

QDACM6	((VMA-START-READ) M-E)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) QDACM2) ;DOUBLE INDIRECT
	(JUMP-XCT-NEXT QDACM1)				;JUST DISPLACED
       ((M-E) Q-POINTER READ-MEMORY-DATA)

QBARY	((M-J) (BYTE-FIELD 2 0) M-Q)		;BYTE ARRAY
	((A-TEM1) (BYTE-FIELD 26 2) M-Q)
	((VMA-START-READ) ADD A-TEM1 M-E)
	(CHECK-PAGE-READ)
	((A-TEM2) DPB M-J A-ZERO (BYTE-FIELD 2 3))	;LSH M-J 3 BECAUSE EA BYTE 8 BITS
	((A-TEM3) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 10 0)))) )
QBFXIT	((M-J) SUB (M-CONSTANT 40) A-TEM2)	;REFLECT BECAUSE OF SHIFTER LOSSAGE
QBFXIT1	((OA-REG-LOW) DPB M-J A-TEM3 OAL-MROT)	;MODIFY NEXT INSTRUCTION
		;DPB NECESSARY BECAUSE M-J = 40 IF A-TEM2 WAS 0
	(POPJ-AFTER-NEXT 
	 BYTE-INST (M-T) READ-MEMORY-DATA)
       ((M-T) IOR (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) M-T)

QB1RY	((A-TEM1) (BYTE-FIELD 23 5) M-Q)	;BIT ARRAY
	((VMA-START-READ) ADD A-TEM1 M-E)
	(CHECK-PAGE-READ)
	((A-TEM2) (BYTE-FIELD 5 0) M-Q)
	(JUMP-XCT-NEXT QBFXIT)			;NO LSH SINCE EA ELEMENT ONE BIT
       ((A-TEM3) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 1 0)))) )

QB2RY	((M-J) (BYTE-FIELD 4 0) M-Q)		;2 BIT ARRAY
	((A-TEM1) (BYTE-FIELD 24 4) M-Q)
	((VMA-START-READ) ADD A-TEM1 M-E)
	(CHECK-PAGE-READ)
	((A-TEM2) DPB M-J A-ZERO (BYTE-FIELD 4 1))	;LSH M-J 1
	(JUMP-XCT-NEXT QBFXIT)
       ((A-TEM3) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 2 0)))) )

QB4RY	((M-J) (BYTE-FIELD 3 0) M-Q)		;4 BIT ARRAY
	((A-TEM1) (BYTE-FIELD 25 3) M-Q)
	((VMA-START-READ) ADD A-TEM1 M-E)
	(CHECK-PAGE-READ)
	((A-TEM2) DPB M-J A-ZERO (BYTE-FIELD 3 2))	;LSH M-J 2
	(JUMP-XCT-NEXT QBFXIT)
       ((A-TEM3) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 4 0)))) )

QB16RY	((M-J) (BYTE-FIELD 1 0) M-Q)		;16 BIT ARRAY
	((A-TEM1) (BYTE-FIELD 27 1) M-Q)
	((VMA-START-READ) ADD A-TEM1 M-E)
	(CHECK-PAGE-READ)
	((A-TEM2) DPB M-J A-ZERO (BYTE-FIELD 1 4))	;LSH M-J 4
	(JUMP-XCT-NEXT QBFXIT)
       ((A-TEM3) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 20 0)))) )

QB32RY	((VMA-START-READ) ADD A-Q M-E)		;32 BIT ARRAY (REALLY POINTER SIZE AND FORCE
	(CHECK-PAGE-READ)			;FIXNUM DATA-TYPE) USEFUL FOR TV-BUFFER
	(POPJ-AFTER-NEXT NO-OP)
       ((M-T) DPB READ-MEMORY-DATA Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

QB16SRY	((A-TEM1) (BYTE-FIELD 27 1) M-Q)	;HALFWORD FIXNUM ARRAY
	((VMA-START-READ) ADD A-TEM1 M-E)
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-Q A-ZERO QB16SRY-1)
       ((M-T) (BYTE-FIELD 16. 0) READ-MEMORY-DATA
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-T) (BYTE-FIELD 16. 16.) READ-MEMORY-DATA
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
QB16SRY-1
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 15.) M-T)
       ((M-T) DPB (M-CONSTANT -1) (BYTE-FIELD 8 16.) A-T)	;NEGATIVE--EXTEND SIGN

QQARY	((VMA-START-READ) ADD A-Q M-E)		;Q ARRAY
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

QFARY	((M-TEM) ADD M-Q A-Q)			;FLOAT
	((VMA-START-READ) ADD M-E A-TEM)
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((C-PDL-BUFFER-POINTER-PUSH) M-E)
	((C-PDL-BUFFER-POINTER-PUSH) M-I)
	((M-I) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) M-K)
	((C-PDL-BUFFER-POINTER-PUSH) M-S)
	(CALL-XCT-NEXT FLOPACK)
       ((M-1) READ-MEMORY-DATA)
QFARY1	((M-S) C-PDL-BUFFER-POINTER-POP)
	((M-K) C-PDL-BUFFER-POINTER-POP)
	((M-I) C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT (M-E) C-PDL-BUFFER-POINTER-POP)
       ((M-B) C-PDL-BUFFER-POINTER-POP)

QFFARY	((VMA-START-READ) ADD M-Q A-E)		;FPS-FLOAT
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((C-PDL-BUFFER-POINTER-PUSH) M-E)
	((C-PDL-BUFFER-POINTER-PUSH) M-I)
	((C-PDL-BUFFER-POINTER-PUSH) M-K)
	((C-PDL-BUFFER-POINTER-PUSH) M-S)
	((M-TEM) (BYTE-FIELD 16. 16.) READ-MEMORY-DATA)		;Swap halves
	((M-TEM) DPB READ-MEMORY-DATA (BYTE-FIELD 16. 16.) A-TEM)
	((M-1) DPB M-TEM (BYTE-FIELD 23. 7) (A-CONSTANT 1_30.))	;Positive fraction
	((M-I) (BYTE-FIELD 8 23.) M-TEM)	;Excess-200 exponent
	(CALL-EQUAL-XCT-NEXT M-I A-ZERO FLZERO)	;0.0 is a special case
       ((M-I) ADD M-I (A-CONSTANT 1600))	;Excess-2000 exponent
	(CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-TEM FNEG1) ;If negative, negate
	(JUMP-XCT-NEXT QFARY1)       
       (CALL FLOPACK)

   (MISC-INST-ENTRY GET-LOCATIVE-POINTER-INTO-ARRAY)
XGLOPR  ((M-R) SETA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))
		    C-PDL-BUFFER-POINTER-POP)	;FLUSH ARGUMENT
	(CALL-XCT-NEXT GAHD1)
       ((M-A) A-QLARYH)		;CONCEIVABLY SHOULD CHECK TO MAKE SURE Q ORIENTED
  (ERROR-TABLE CALLS-SUB GET-LOCATIVE-POINTER-INTO-ARRAY)
	(JUMP-XCT-NEXT XGLOP1)	;ARRAY
       ((M-Q) DPB M-ZERO Q-ALL-BUT-POINTER A-QLARYL)

   (MISC-INST-ENTRY GET-LIST-POINTER-INTO-ARRAY)
XGLPA	((M-R) SETA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))
		     C-PDL-BUFFER-POINTER-POP)	;IGNORE ARGUMENT
					;GET LIST POINTER TO LAST ARRAY ELEMENT REF ED
	(CALL-XCT-NEXT GAHD1)
       ((M-A) A-QLARYH)
   (ERROR-TABLE CALLS-SUB GET-LIST-POINTER-INTO-ARRAY)
	((M-Q) DPB M-ZERO Q-ALL-BUT-POINTER A-QLARYL)		;ENTRY NUMBER
XGLPA1	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL (LSH ART-Q-LIST ARRAY-TYPE-SHIFT))) TRAP)
   (ERROR-TABLE ARGTYP ART-Q-LIST-ARRAY M-A T NIL)
XGLOP1	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B 
		DSP-ARRAY-SETUP)  		;DISPLACED
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)	;INDEX OUT OF BOUNDS
   (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
	(POPJ-AFTER-NEXT 
	 (A-TEM3) IOR A-R M-Q)
      ((M-T) ADD A-TEM3 M-E)

     (MISC-INST-ENTRY G-L-P)		;(G-L-P <ARRAY-POINTER-TO-ART-Q-LIST-ARRAY>)
XGLPAR	(CALL GAHDRA)			; RETURNS LIST POINTER TO ARRAY CONTENTS
    (ERROR-TABLE CALLS-SUB G-L-P)	;IF FILL-POINTER 0, RETURN NIL
    (ERROR-TABLE ARG-POPPED 0 M-A)
	(JUMP-IF-BIT-CLEAR M-B (LISP-BYTE %%ARRAY-LEADER-BIT) XGLPA2) ;JUMP ON NO LEADER
	((VMA-START-READ) SUB M-A (A-CONSTANT 2))	;NO TRANSPORT SINCE JUST TOUCHED HDR
	(CHECK-PAGE-READ)
	((M-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XFALSE)
XGLPA2	((M-R) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(JUMP-XCT-NEXT XGLPA1)		;RETURN POINTER TO ELEMENT NUMBER 0
       ((M-Q) A-ZERO)

;Storing into arrays.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS XSTORE M-T)

XXSTOR (MISC-INST-ENTRY XSTORE)
	((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)	;STORE IN LAST ARRAY ELEM REF ED
	(CALL-XCT-NEXT GAHD1)
       ((M-A) A-QLARYH)
   (ERROR-TABLE CALLS-SUB STORE)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((M-Q) DPB M-ZERO Q-ALL-BUT-POINTER A-QLARYL)
	(CALL-IF-BIT-SET M-B (LISP-BYTE %%ARRAY-DISPLACED-BIT) DSP-ARRAY-SETUP)
   (ERROR-TABLE ARG-POPPED 0 PP)
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)	;INDEX OUT OF BOUNDS
   (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
   (ERROR-TABLE ARG-POPPED 0 PP)
	(DISPATCH-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD) 
		M-B ARRAY-TYPE-STORE-DISPATCH)
   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

;Store routines for various types of arrays, reached via ARRAY-TYPE-STORE-DISPATCH.
;M-T has data to store, M-Q subscript, M-E etc. have GAHDR data.

;NOTE REFLECTING ABOUT 40 HACK NOT NECESSARY FOR DPB
QSBARY	((M-J) DPB M-Q (BYTE-FIELD 2 3)		;STORE IN BYTE ARRAY (8 BIT)
		(A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 10 0)))))
	((A-TEM1) (BYTE-FIELD 26 2) M-Q)	;WORD OFFSET
QSANUM	((VMA-START-READ) ADD A-TEM1 M-E)	;COMMON STORE ROUTINE FOR NUMERIC ARRAYS
	(CHECK-PAGE-READ)
	(DISPATCH Q-DATA-TYPE M-T TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM M-T 0)	;STORING IN NUMERIC ARRAY, MUST BE FIXNUM
	((A-TEM1) READ-MEMORY-DATA)
	((OA-REG-LOW) M-J)			;MODIFY FOLLOWING INST FOR WRITE
       ((WRITE-MEMORY-DATA-START-WRITE) DPB M-T A-TEM1)
	(CHECK-PAGE-WRITE)
CPOPJ	(POPJ)

QS1RY	((M-J) DPB M-Q (BYTE-FIELD 5 0)		;STORE IN BIT ARRAY
		(A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 1 0)))))
	(JUMP-XCT-NEXT QSANUM)
       ((A-TEM1) (BYTE-FIELD 23 5) M-Q)		;WORD OFFSET

QS2RY	((M-J) DPB M-Q (BYTE-FIELD 4 1)		;STORE IN 2-BIT ARRAY
		(A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 2 0)))))
	(JUMP-XCT-NEXT QSANUM)
       ((A-TEM1) (BYTE-FIELD 24 4) M-Q)		;WORD OFFSET

QS4RY	((M-J) DPB M-Q (BYTE-FIELD 3 2)		;STORE IN 4-BIT ARRAY
		(A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 4 0)))))
	(JUMP-XCT-NEXT QSANUM)
       ((A-TEM1) (BYTE-FIELD 25 3) M-Q)		;WORD OFFSET

QS16RY	((M-J) DPB M-Q (BYTE-FIELD 1 4)		;STORE IN 16-BIT ARRAY
		(A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST (BYTE-FIELD 20 0)))))
	(JUMP-XCT-NEXT QSANUM)
       ((A-TEM1) (BYTE-FIELD 27 1) M-Q)		;WORD OFFSET

QS32RY	((VMA) ADD A-Q M-E)			;32 BIT ARRAY (ANOMALOUS)
	((WRITE-MEMORY-DATA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	(POPJ)

QSQARY	((VMA) ADD A-Q M-E)			;Q ARRAY
	((WRITE-MEMORY-DATA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

QSLQRY	((VMA-START-READ) ADD A-Q M-E)		;Q-LIST ARRAY
	(CHECK-PAGE-READ)			;NO TRANSPORT SINCE STORING AND JUST
	((WRITE-MEMORY-DATA-START-WRITE)	;TOUCHED HEADER AND DON'T ALLOW ONE-Q-FORWARD
		SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

QSFARY	((M-J) M-I)				;Save M-I
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;Value being stored
	(CALL GET-FLONUM)
	((M-TEM) ADD M-Q A-Q)
	((WRITE-MEMORY-DATA) M-I)
	((VMA-START-WRITE) ADD M-E A-TEM)
	(CHECK-PAGE-WRITE)
	((M-I) M-J)				;Restore M-I
	((WRITE-MEMORY-DATA) M-1)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(POPJ)

;FPS-FLOAT has less precision than Lisp machine float, so round.
QSFFARY	((M-J) M-I)				;Save M-I
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;Value being stored
	(CALL GET-FLONUM)
	;Transfer sign bit to M-TEM and get magnitude of fraction
	(CALL-LESS-THAN-XCT-NEXT M-1 A-ZERO FNEG1)
       ((M-TEM) SELECTIVE-DEPOSIT M-1 (BYTE-FIELD 1 31.) A-ZERO)
	;Round off fraction
	((M-4) (BYTE-FIELD 7 0) M-1)		;Discarded bits of fraction
	(CALL-EQUAL M-4 (A-CONSTANT 1_6) QSFFRY2)	;Stable rounding
	((M-1) ADD M-1 (A-CONSTANT 1_6))
	(CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-1 QSFFRY3)	;Renormalize
QSFFRY0	((M-I) SUB M-I (A-CONSTANT 1600))	;Get excess-200 exponent
	(JUMP-LESS-OR-EQUAL M-I A-ZERO QSFFRY1)	;Underflow or zero => zero
	;Insert relevant fraction bits
	((M-TEM) (BYTE-FIELD 23. 7) M-1 A-TEM)
	(JUMP-LESS-THAN-XCT-NEXT M-I (A-CONSTANT 400) QSFFRY1)
       ((M-TEM) DPB M-I (BYTE-FIELD 8 23.) A-TEM)
	((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 31. 0) A-TEM)	;Overflow => infinity
QSFFRY1	((M-1) (BYTE-FIELD 16. 16.) M-TEM)	;Swap halves
	((WRITE-MEMORY-DATA) DPB M-TEM (BYTE-FIELD 16. 16.) A-1)	
	((VMA-START-WRITE) ADD M-E A-Q)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT (M-I) M-J)
       (NO-OP)

QSFFRY2	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET (BYTE-FIELD 1 7) M-1)
	(JUMP QSFFRY0)				;If lsb 0, suppress adding 1

QSFFRY3	(POPJ-AFTER-NEXT (M-1) (BYTE-FIELD 30. 1) M-1)	;Shift fraction right 1
       ((M-I) ADD M-I (A-CONSTANT 1))		;And increment exponent
				
   (ERROR-TABLE DEFAULT-ARG-LOCATIONS ARRAY-PUSH PP M-T)
   (MISC-INST-ENTRY ARRAY-PUSH)
XFARY	((M-T) C-PDL-BUFFER-POINTER-POP)
	(CALL-XCT-NEXT GAHDR)
       ((M-A) C-PDL-BUFFER-POINTER)
   (ERROR-TABLE CALLS-SUB ARRAY-PUSH)
	(CALL-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B TRAP)
   (ERROR-TABLE ARRAY-HAS-NO-LEADER M-A)
	((VMA-START-READ) SUB M-A (A-CONSTANT 2))	;REF FILL POINTER
	(CHECK-PAGE-READ)			;NO TRANSPORT SINCE JUST TOUCHED HEADER
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE READ-MEMORY-DATA TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE FILL-POINTER-NOT-FIXNUM M-A)
	((M-Q) Q-POINTER READ-MEMORY-DATA)	;THIS ONE GETS RELOCATED IF INDIRECT ARY
	((A-FARY-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)  ;NOT CLOBBERED BY ARY ROUTINES
						;THIS COPY USED FOR INCREMENTING AND 
						;STORING BACK
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B 
			 DSP-ARRAY-SETUP)
	(JUMP-GREATER-OR-EQUAL M-Q A-S POP-THEN-XFALSE)	;INDEX OUT OF BOUNDS, RETURN NIL,
							; DON'T STORE
	((VMA) SUB M-A (A-CONSTANT 2))		;KNOW WILL WIN NOW, MUNG
	((WRITE-MEMORY-DATA-START-WRITE) ADD A-FARY-TEM M-ZERO ALU-CARRY-IN-ONE)
	(CHECK-PAGE-WRITE)
	(DISPATCH-CALL (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B 
			ARRAY-TYPE-FILL-DISPATCH)
   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
	; ((M-T) A-FARY-TEM) and discard top of stack.
	(POPJ-AFTER-NEXT 	;RETURN ELEMENT NUMBER STORED INTO.
	 (M-T) SETA A-FARY-TEM C-PDL-BUFFER-POINTER-POP)
       ((M-T) IOR (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) M-T)

XFALAR	((A-TEM1) M-Q)			;HERE FROM ARRAY-TYPE-FILL-DISPATCH FOR Q-LIST-ARRAY
	((VMA) ADD A-TEM1 M-E)		;MUST HACK CDR CODES
	((WRITE-MEMORY-DATA-START-WRITE)  ;NO TRANSPORTER HACKERY NEEDED SINCE ADDRESSING
	     DPB M-T Q-TYPED-POINTER      ;A "FRESH" Q.
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(POPJ-EQUAL A-FARY-TEM M-ZERO)	;FIRST ENTRY, DO NOTHING
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))	;NO TRANSPORT NEEDED (JUST FIDDLING
	(CHECK-PAGE-READ)		                ;CDR CODE)
	(POPJ-AFTER-NEXT
	 (WRITE-MEMORY-DATA-START-WRITE)
	     DPB READ-MEMORY-DATA Q-TYPED-POINTER
		    (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
       (CHECK-PAGE-WRITE)

   (MISC-INST-ENTRY STORE-ARRAY-LEADER)
XSALDR	(CALL XFLAD1)		;STORE IN ARRAY LEADER
  (ERROR-TABLE CALLS-SUB STORE-ARRAY-LEADER)
;NEEDS TRANSPORTER HACKERY HERE IF ONE-Q-FORWARD S IN ARRAY-LEADERS ARE TO BE SUPPORTED.
	((M-T WRITE-MEMORY-DATA-START-WRITE) 
		Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-WRITE)		;SEQ BRK O.K. HERE
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

   (MISC-INST-ENTRY ARRAY-LEADER)
XFALDR	(CALL XFLAD1)			;FETCH ELEMENT IN ARRAY LEADER
  (ERROR-TABLE CALLS-SUB ARRAY-LEADER)
	((VMA-START-READ) VMA)
	(CHECK-PAGE-READ)		;SEQ BRK O.K. HERE
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

;Pop index and array off stack, and return in VMA the address
;of the slot in the leader specified by the index.
XFLAD1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) ;COMPUTE ADDRESS
   (ERROR-TABLE ARGTYP FIXNUM PP 1)
   (ERROR-TABLE ARG-POPPED 0 PP PP)
	((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)		;OR ARRAY LEADER ELEMENT
	(CALL-XCT-NEXT GAHDR)
       ((M-A) C-PDL-BUFFER-POINTER)
   (ERROR-TABLE ARG-POPPED 0 M-Q)
	(CALL-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B TRAP)	;NO LEADER
   (ERROR-TABLE ARRAY-HAS-NO-LEADER M-A)
   (ERROR-TABLE RESTART XFLAD1-A)
   (ERROR-TABLE ARG-POPPED 0 M-Q)
	((VMA-START-READ) SUB M-A (A-CONSTANT 1))	;GET LENGTH OF ARRAY LEADER
	(CHECK-PAGE-READ)	;NO TRANSPORT SINCE JUST TOUCHED HEADER
	((A-TEM1) Q-POINTER READ-MEMORY-DATA)
	(CALL-GREATER-OR-EQUAL M-Q A-TEM1 TRAP)		;SUBSCRIPT OUT OF BOUNDS
   (ERROR-TABLE SUBSCRIPT-OOB M-Q RMD XFLAD1-A)
   (ERROR-TABLE ARG-POPPED 0 M-Q)
	(C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT (A-TEM1) ADD M-Q (A-CONSTANT 2))
       ((VMA) SUB M-A A-TEM1)

XAHLP  (MISC-INST-ENTRY ARRAY-HAS-LEADER-P)
	(CALL GAHDRA)
  (ERROR-TABLE CALLS-SUB ARRAY-HAS-LEADER-P)
  ;; The following is ok because the arg is, unchanged, in M-A
  ;; at the time when GAHRDA might get an error,
  ;; and we don't need to worry about it after GAHDRA returns.
  (ERROR-TABLE ARG-POPPED 0 M-A)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B XFALSE)
	(JUMP XTRUE)

;;;??? This is very hard.
XAR1   (MISC-INST-ENTRY AR-1)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 1)
	(CALL-XCT-NEXT GAHDRA)
       ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)
  (ERROR-TABLE CALLS-SUB AR-1)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 1) TRAP)
  (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 1 M-A)
XAR1A	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT)
		M-B DSP-ARRAY-SETUP)		;ARRAY DISPLACED
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)	;INDEX OUT OF BOUNDS
  (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
	(DISPATCH-CALL-XCT-NEXT 
		(LISP-BYTE %%ARRAY-TYPE-FIELD)
		M-B 
		ARRAY-TYPE-REF-DISPATCH)
  (ERROR-TABLE BAD-ARRAY-TYPE M-B)
       (NO-OP)
	(POPJ)

XAPLD (MISC-INST-ENTRY AP-LEADER)	;RETURN LOCATIVE POINTER TO LEADER ELEMENT
	(CALL XFLAD1)			;SET UP VMA
  (ERROR-TABLE CALLS-SUB AP-LEADER)
XAP1B	(POPJ-AFTER-NEXT 
	 (M-T) DPB VMA Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       (NO-OP)

XAP1  (MISC-INST-ENTRY AP-1)	;RETURN LOCATIVE POINTER TO ARRAY ELEMENT REF'ED
	(CALL XAR1)		;REF ARRAY, LEAVING M-B AND VMA SET UP
  (ERROR-TABLE CALLS-SUB AP-1)
XAP1A	(DISPATCH (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B SKIP-IF-NUMERIC-ARRAY)
	 (JUMP XAP1B)
	(CALL TRAP)
	    (ERROR-TABLE NUMBER-ARRAY-NOT-ALLOWED M-A)

XAS1  (MISC-INST-ENTRY AS-1)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	(CALL-XCT-NEXT GAHDRA)
       ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)
   (ERROR-TABLE CALLS-SUB AS-1)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 1) TRAP)
   (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 1 M-A)
XAS1A	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT)
		M-B DSP-ARRAY-SETUP)		;ARRAY DISPLACED
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)	;INDEX OUT OF BOUNDS
   (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
	(DISPATCH-XCT-NEXT 
		(LISP-BYTE %%ARRAY-TYPE-FIELD)
		M-B 
		ARRAY-TYPE-STORE-DISPATCH)
   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
       ((M-T) C-PDL-BUFFER-POINTER-POP)	;DATA TO STORE

XAP2  (MISC-INST-ENTRY AP-2)
	(CALL XAR2)		;DO IT THIS WAY TO SAVE A RANDOM A-CONSTANT
   (ERROR-TABLE CALLS-SUB AP-2)
	(JUMP XAP1A)

XAS2  (MISC-INST-ENTRY AS-2)
	(JUMP-XCT-NEXT XAS2B)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XAS1A)))

XAR2  (MISC-INST-ENTRY AR-2)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XAR1A)))
XAS2B	((M-J) C-PDL-BUFFER-POINTER-POP)
	(CALL-XCT-NEXT GAHDRA)
       ((M-Q) C-PDL-BUFFER-POINTER-POP)
  (ERROR-TABLE CALLS-SUB AX-2)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 2) TRAP)
  (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 2 M-A)
	((M-1) Q-POINTER M-J)
XAR2A	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE M-Q TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM M-Q 1 NIL AR-2)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE M-J TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM M-J 2 NIL AR-2)
	((M-TEM) (LISP-BYTE %%ARRAY-LONG-LENGTH-FLAG) M-B)	;SPACE PAST LONG-LENGTH Q IF
	((VMA-START-READ) ADD M-A A-TEM ALU-CARRY-IN-ONE)	; PRESENT
	(CHECK-PAGE-READ)		;NO TRANSPORT SINCE JUST TOUCHED HDR
	(CALL-XCT-NEXT MPY)
       ((Q-R M-D) READ-MEMORY-DATA)		;FIRST DIMENSION, SAVE IN M-D FOR BITBLT
	(POPJ-AFTER-NEXT 
	 (M-Q) ADD Q-R A-Q)
       ((M-Q) Q-POINTER M-Q)

XAP3  (MISC-INST-ENTRY AP-3)
	(CALL XAR3)
  (ERROR-TABLE CALLS-SUB AP-3)
	(JUMP XAP1A)

XAS3  (MISC-INST-ENTRY AS-3)
	(JUMP-XCT-NEXT XAS3B)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XAS1A)))

XAR3  (MISC-INST-ENTRY AR-3)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XAR1A)))
XAS3B	((M-I) C-PDL-BUFFER-POINTER-POP)
	((M-J) C-PDL-BUFFER-POINTER-POP)
	(CALL-XCT-NEXT GAHDRA)
       ((M-Q) C-PDL-BUFFER-POINTER-POP)
   (ERROR-TABLE CALLS-SUB AX-3)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 3) TRAP)
   (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 3 M-A)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE M-I TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM M-I 3 NIL AR-3)
	((M-1) (LISP-BYTE %%ARRAY-LONG-LENGTH-FLAG) M-B)
	((M-1) ADD M-1 (A-CONSTANT 2))   ;TO SECOND DIMENSION
	((VMA-START-READ) ADD M-A A-1)   ;SPACE PAST LONG-LENGTH Q IF PRESENT
	(CHECK-PAGE-READ)		;NO TRANSPORT SINCE JUST TOUCHED HEADER
	((M-1) Q-POINTER M-I)
	(CALL-XCT-NEXT MPY)
       ((Q-R) READ-MEMORY-DATA)
	((M-1) ADD Q-R A-J)
	(JUMP-XCT-NEXT XAR2A)
       ((M-1) Q-POINTER M-1)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS COPY-ARRAY-CONTENTS-AND-LEADER M-C M-T)

XCARCL (MISC-INST-ENTRY COPY-ARRAY-CONTENTS-AND-LEADER)
	((M-T) C-PDL-BUFFER-POINTER-POP)		;TO
	((M-C) C-PDL-BUFFER-POINTER-POP)		;FROM
	(CALL-XCT-NEXT GALPTR)
       ((M-A) M-C)
	((M-Q) M-S)					;LENGTH OF FROM LEADER
	((M-J) M-E)					;HIGH ADDRESS OF FROM LEADER
	(CALL-XCT-NEXT GALPTR)
       ((M-A) M-T)
	((M-I) A-ZERO)					;CURRENT ARRAY LEADER INDEX
XCALD1	(JUMP-GREATER-OR-EQUAL M-I A-S XCARC0)		;TO LEADER DONE, GO COPY DATA
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-I A-Q XCALD2)
       ((WRITE-MEMORY-DATA) A-V-NIL)			;IF FROM LEADER EXHAUSTED, USE NIL
	((VMA-START-READ) M-J)				;GET FROM ARRAY LEADER ITEM
	(CHECK-PAGE-READ)
	((M-J) SUB M-J (A-CONSTANT 1))
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	;((WRITE-MEMORY-DATA) READ-MEMORY-DATA)
XCALD2	((VMA-START-WRITE) M-E)				;STORE IN TO ARRAY LEADER ITEM
	(CHECK-PAGE-WRITE)				;NO TRANSP HERE SINCE TOUCHED HEADER?
	(GC-WRITE-TEST)
	((M-E) SUB M-E (A-CONSTANT 1))
	(JUMP-XCT-NEXT XCALD1)
       ((M-I) ADD M-I (A-CONSTANT 1))
	
;(COPY-ARRAY-PORTION FROM-ARRAY FROM-START FROM-END TO-ARRAY TO-START TO-END)
;IF THE TO-LENGTH IS LONGER IT FILLS WITH 0 OR NIL
;;;??? This one is hard to remember the args for.
XCAP (MISC-INST-ENTRY COPY-ARRAY-PORTION)
	((M-R) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;TO-END
	(CALL-XCT-NEXT GAHDRA)
       ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;TO-START
  (ERROR-TABLE CALLS-SUB COPY-ARRAY-PORTION)
	((M-R) SUB M-R A-Q)				;DON'T GET SCREWED BY DSP-ARRAY-SETUP
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B DSP-ARRAY-SETUP)
	((M-R) ADD M-R A-Q)
	((M-I) M-Q)					;TO-INDEX
	(CALL-GREATER-THAN M-R A-S TRAP)		;TO-LENGTH IN M-R MUST BE IN-BOUNDS
  (ERROR-TABLE SUBSCRIPT-OOB M-R M-S)
	((M-C) M-E)					;TO-ADDRESS
	((M-K) M-B)					;TO-ARRAY-HEADER
	((M-T) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;FROM-END
	(CALL-XCT-NEXT GAHDRA)
       ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;FROM-START
  (ERROR-TABLE CALLS-SUB COPY-ARRAY-PORTION)
	((M-T) SUB M-T A-Q)				;DON'T GET SCREWED BY DSP-ARRAY-SETUP
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B DSP-ARRAY-SETUP)
	((M-T) ADD M-T A-Q)
	(CALL-GREATER-THAN M-T A-S TRAP)		;FROM-LENGTH IN M-T MUST BE IN-BOUNDS
  (ERROR-TABLE SUBSCRIPT-OOB M-T M-S)
	(JUMP-XCT-NEXT XCARC1)
       ((M-S) M-T)

;NOTE:  AN OPTIMIZATION TO DO IT WORD BY WORD MIGHT BE HANDY...
XCARC (MISC-INST-ENTRY COPY-ARRAY-CONTENTS)
	((M-T) C-PDL-BUFFER-POINTER-POP)		;TO
	((M-C) C-PDL-BUFFER-POINTER-POP)		;FROM
XCARC0	(CALL-XCT-NEXT GADPTR)
       ((M-A) M-T)
  (ERROR-TABLE CALLS-SUB COPY-ARRAY-CONTENTS)
  (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	((M-A) M-C)					;FROM-ARRAY
	((M-R) M-S)					;TO LENGTH
	((M-C) M-E)					;TO ADDRESS
	((M-I) M-Q)					;TO INITIAL INDEX
	(CALL-XCT-NEXT GADPTR)
       ((M-K) M-B)					;TO ARRAY HEADER
  (ERROR-TABLE CALLS-SUB COPY-ARRAY-CONTENTS)
  (ERROR-TABLE ARG-POPPED 0 M-A M-T)
XCARC1	(JUMP-GREATER-OR-EQUAL M-I A-R XTRUE)		;TO ARRAY DONE, RETURN
	(JUMP-GREATER-OR-EQUAL M-Q A-S XCARC3)		;JUMP IF FROM ARRAY EXHAUSTED
	(DISPATCH-CALL-XCT-NEXT				;M-T := FROM ITEM, CLOBBER M-J
		(LISP-BYTE %%ARRAY-TYPE-FIELD) M-B ARRAY-TYPE-REF-DISPATCH)
   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
XCARC4 ((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-Q
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-D) M-E)
	((M-Q) M-I)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XCARC5)))
	(DISPATCH-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD) M-K ARRAY-TYPE-STORE-DISPATCH)
   (ERROR-TABLE BAD-ARRAY-TYPE M-K)
       ((M-E) M-C)
XCARC5	((M-I) ADD M-I (A-CONSTANT 1))
	((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-Q) ADD M-Q (A-CONSTANT 1))
	(JUMP-XCT-NEXT XCARC1)
       ((M-E) M-D)

;COMPUTE FILLER VALUE IN M-T, REENTER AT XCARC4
;THIS USED TO PAD STRINGS WITH 200, BUT THAT WAS A CROCK
XCARC3	((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;Zero for numeric array
	(DISPATCH (LISP-BYTE %%ARRAY-TYPE-FIELD) M-K SKIP-IF-NUMERIC-ARRAY)
	 ((M-T) A-V-NIL)			;NIL for non-numeric
	(JUMP XCARC4)

;GET ADDRESS AND LENGTH OF ARRAY LEADER
GALPTR	(CALL GAHDR)
	((M-E) SUB M-A (A-CONSTANT 2))		;ADDRESS
	(POPJ-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-LEADER-BIT) M-B)
       ((M-S) A-ZERO)				;LENGTH
	((VMA-START-READ) SUB M-A (A-CONSTANT 1))	;NO TRANSPORT SINCE JUST TOUCHED HEADER
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT
	 (M-S) Q-POINTER READ-MEMORY-DATA)
       (NO-OP)

;GET ADDRESS, LENGTH, AND INITIAL INDEX OF ARRAY
GADPTR	(CALL GAHDR)
	(POPJ-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B)
       ((M-Q) A-ZERO)
	(JUMP DSP-ARRAY-SETUP)

;(%BLT from-address to-address n-words increment)
;Increment is usually 1, less often -1 for backwards blt.
XBLT (MISC-INST-ENTRY %BLT)
	((M-D) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-B) SUB M-B A-D)
	((M-A) SUB M-A A-D)
XBLT1	(JUMP-EQUAL M-C (A-CONSTANT 0) XFALSE)
	((VMA-START-READ M-A) ADD M-A A-D)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE M-B) ADD M-B A-D)
	(CHECK-PAGE-WRITE)
	(JUMP-XCT-NEXT XBLT1)
       ((M-C) SUB M-C (A-CONSTANT 1))

XNUMBP (MISC-INST-ENTRY NUMBERP)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTNUMB	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T POPJ-IF-NOT-NUMBER)	;MC-LINKAGE
       ((M-T) A-V-NIL)
	(JUMP XTRUE)

XFIXP (MISC-INST-ENTRY FIXP)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTFIXP	((M-TEM) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XTRUE)
	((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)))
XFXFLP	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) XFALSE)
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	((M-T) A-V-TRUE)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT (M-TEM) (LISP-BYTE %%HEADER-TYPE-FIELD) READ-MEMORY-DATA)
       (CALL-NOT-EQUAL M-TEM A-4 XFALSE)

XFLTP (MISC-INST-ENTRY FLOATP)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTFLTP	((M-TEM) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SMALL-FLONUM)) XTRUE)
	(JUMP-XCT-NEXT XFXFLP)
       ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM)))

XDATTP (MISC-INST-ENTRY %DATA-TYPE)
	(POPJ-AFTER-NEXT 
	 (M-T)  C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		Q-DATA-TYPE)
       (NO-OP)

XDAT   (MISC-INST-ENTRY %POINTER)
	(POPJ-AFTER-NEXT 
	 (M-T)  C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		Q-POINTER)
       (NO-OP)

XSDATP (MISC-INST-ENTRY %MAKE-POINTER)
	((A-TEM1) C-PDL-BUFFER-POINTER-POP)    ;ARG2, THE POINTER
	(POPJ-AFTER-NEXT 
	 (M-T) C-PDL-BUFFER-POINTER-POP)       ;ARG1, THE DATA TYPE
       ((M-T) DPB M-T Q-DATA-TYPE A-TEM1)
	
XSTND (MISC-INST-ENTRY %P-STORE-CONTENTS)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;NEED IN M-T FOR RETURNED VALUE
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE)
	    SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB-OFFSET PP M-C M-B)

XOPLDB(MISC-INST-ENTRY %P-LDB-OFFSET)
	(JUMP-XCT-NEXT XOPLD1)			;JOIN XLDB, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE LOCATION

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGLDB PP M-1)

XLLDB (MISC-INST-ENTRY %LOGLDB)			;LDB FOR FIXNUMS
	(JUMP-XCT-NEXT XLLDB1)
       ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB PP VMA)

;%P-LDB treats target Q just as 32 bits.  Data type is not interpreted.
XPLDB (MISC-INST-ENTRY %P-LDB)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)			;VMA MAY POINT AT UNBOXED DATA.
XOPLD1  ((M-1) READ-MEMORY-DATA)		;VMA MAY BE LEFT POINTING AT UNBOXED DATA..
XLLDB1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) ;ARG1, BYTE POINTER.  MUST BE FIXNUM.
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP 0)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XLDB-ZERO)  ;WANT 0 BITS, RETURN 0
					   ; (THIS IS A FAIRLY RANDOM THING TO CHECK FOR
					   ; BUT IF WE DIDNT, IT WOULD CAUSE LOSSAGE)
	(CALL-GREATER-THAN M-K (A-CONSTANT 30) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
	((M-J) SUB M-K (A-CONSTANT 1))	   ;BYTE LENGTH MINUS ONE FIELD
	((M-E) (BYTE-FIELD 6 6) C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER
	((A-TEM2) SUB (M-CONSTANT 40) A-E)	  ;COMPENSATE FOR SHIFTER LOSSAGE
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-J A-TEM2 OAL-BYTL-1)
       ((M-T) BYTE-INST 
		M-1 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;LDB can only extract from fixnums and bignums.  The target is considered to
; have infinite sign extension.  LDB "should" always return a positive number.
; This issue currently doesn't arise, since LDB is implemented only for
; positive-fixnum-sized bytes, i.e. a maximum of 23. bits wide.  Note the
; presence of %LOGLDB, which will load a 24-bit byte of a fixnum and return
; it as a possibly-negative fixnum.
XLDB  (MISC-INST-ENTRY LDB) (ERROR-TABLE RESTART XLDB)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)  ;Only the second operand is
	    (ERROR-TABLE ARGTYP NUMBER PP 1 XLDB)   ;processed via NUMARG.  Thus LDB is
	    (ERROR-TABLE ARG-POPPED 0 PP PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-LDB))	    ;considered to be a one operand op.
		(ERROR-TABLE RESTART XLDB0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)	;Arg1, byte pointer.  Must be fixnum.
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
            (ERROR-TABLE ARGTYP FIXNUM PP 0 XLDB0)
	    (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1))
;Fixnum case.  Data to LDB out of (arg2) sign extended in M-1.
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;Get number of bits
	(JUMP-EQUAL M-K A-ZERO XLDB-ZERO)  ;Want 0 bits, return 0
					   ; (This is a fairly random thing to check for
					   ; but if we didnt, it would cause lossage)
	(CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XLDB0)
    (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1))
	((M-J) SUB M-K (A-CONSTANT 1))	   ;Byte length minus one field
	((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
		 C-PDL-BUFFER-POINTER-POP) ;Get number of places over
	((M-2) SUB (M-CONSTANT 40) A-K)	   ;Maximum M-rotate to keep byte within a word
XLDB3	(JUMP-GREATER-THAN M-E A-2 XLDB2)  ;Jump if left edge of byte off end of word
	((A-TEM2) SUB (M-CONSTANT 40) A-E) ;Compensate for shifter lossage
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-J OAL-BYTL-1 A-TEM2)
       ((M-T) BYTE-INST M-1
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  

;Get here if left edge of byte is off 32. bit word.  Arithmetic shift right until it fits.
XLDB2	((M-1) LDB (BYTE-FIELD 31. 1) M-1 A-1)
	(JUMP-XCT-NEXT XLDB3)
       ((M-E) SUB M-E (A-CONSTANT 1))

BIGNUM-LDB	;M-Q has bignum, M-C has bignum header, M-I has length of bignum.
		(ERROR-TABLE RESTART BIGNUM-LDB)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)	;Arg1, byte pointer.  Must be fixnum.
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
            (ERROR-TABLE ARGTYP FIXNUM PP 0 BIGNUM-LDB)
	    (ERROR-TABLE ARG-POPPED 0 PP M-Q)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;Get number of bits
	(CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
	    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 BIGNUM-LDB)
	    (ERROR-TABLE ARG-POPPED 0 PP M-Q)
	((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
			 C-PDL-BUFFER-POINTER)  ;Number of places over
	((M-D) (A-CONSTANT 1))			;Offset within bignum
BIGLDB2	(JUMP-LESS-THAN M-E (A-CONSTANT 31.) BIGLDB1)  ;Found word desired byte starts in
	((M-D) ADD M-D (A-CONSTANT 1))
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-D A-I BIGLDB2)
       ((M-E) SUB M-E (A-CONSTANT 31.))
	((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C)	;Byte off top of bignum, return sign bits
	((M-T) M-ZERO)
	(JUMP C-PDL-BUFFER-POINTER-POP BIGLDB6)	;Truncate byte and return (also flush arg)

BIGLDB1	((VMA-START-READ) ADD M-Q A-D)	;Fetch word of bignum
	(CHECK-PAGE-READ)
	((M-ZR) (A-CONSTANT 31.))	;31. useful bits in bignum word.
	(CALL-XCT-NEXT I-LDB)		;Get at least some of the right stuff into M-2
       ((M-1) READ-MEMORY-DATA)
	((M-T) Q-POINTER M-2 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;Force result into fixnum
	(JUMP-EQUAL M-4 A-K BIGLDB3)   ;and return it if that is entire byte
	(JUMP-EQUAL M-D A-I BIGLDB3)   ;Also return if that was last word of bignum
	((VMA-START-READ) M+A+1 M-Q A-D)	;Get next word of bignum
	(CHECK-PAGE-READ)
	((M-J) M-A-1 M-K A-4)		;Number of bits left to go minus one
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-ZERO)
	((M-1) BYTE-INST READ-MEMORY-DATA A-ZERO)  ;Get bits from second word
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-4)   ;Put those bits above the previous bits.
	((M-T) DPB M-1 A-T)
BIGLDB3	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-C)	;Done if bignum was positive
       ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)	;Retrieve byte pos, flush arg from pdl
			 C-PDL-BUFFER-POINTER-POP)
	;; Bignum was negative.  Take complement of the byte value retrieved.
	;; This is a 1's or 2's complement depending on whether all bits to the
	;; right are zero.  M-K still has the byte size.
	((M-T) XOR M-T (A-CONSTANT -1))	;1's complement the byte and some extra bits to left
	((VMA) M-Q)			;Scan the bignum for zeros, until start of the byte
BIGLDB4	(JUMP-LESS-OR-EQUAL M-E A-ZERO BIGLDB7)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(JUMP-LESS-THAN M-E (A-CONSTANT 31.) BIGLDB5)
	(JUMP-EQUAL-XCT-NEXT READ-MEMORY-DATA A-ZERO BIGLDB4)
       ((M-E) SUB M-E (A-CONSTANT 31.))
BIGLDB6	((M-K) SUB M-K (A-CONSTANT 1))	;OK, truncate the byte value and return it
	(POPJ-AFTER-NEXT (OA-REG-LOW) DPB M-K OAL-BYTL-1 A-ZERO)
       ((M-T) (BYTE-FIELD 0 0) M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

BIGLDB5	((M-E) SUB M-E (A-CONSTANT 1))	;Check bits in last word
	((OA-REG-LOW) DPB M-E OAL-BYTL-1 A-ZERO)
	((M-TEM) (BYTE-FIELD 0 0) READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-TEM A-ZERO BIGLDB6)
BIGLDB7	(JUMP-XCT-NEXT BIGLDB6)		;2's complement
       ((M-T) ADD M-T (A-CONSTANT 1))

XLSH-ZERO 
XLDB-ZERO 
	(POPJ-AFTER-NEXT 
	 (M-T) SETA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) ;RESULT = 0
		    C-PDL-BUFFER-POINTER-POP)	;DON'T FORGET TO POP ARG1
       (NO-OP)

;INTERNAL LDB.  TAKES DATA IN M-1, BITS IN M-K, PLACES OVER IN M-E.
; SIZE OF DATA IN M-1 IN M-ZR (MAX 32.).
; RETURNS BYTE IN M-2.  M-4 GETS NUMBER OF BITS OF M-2 THAT ACTUALLY 
; CONTAIN DESIRED BYTE, IE, SAME AS M-K IF ENTIRE BYTE WAS WITHIN M-ZR BITS,
; OTHERWISE ONE LESS FOR EACH BIT BYTE EXTENDED BEYOND M-ZR BITS, OR ZERO IF
; BYTE WAS ENTIRELY TO THE LEFT OF M-ZR BITS.  REST OF M-2 IS ZERO.
I-LDB	((M-2) ADD M-K A-E)
	(JUMP-GREATER-THAN M-2 A-ZR I-LDB0)	;LEFT EDGE OF BYTE OFF TOP
	((M-4) M-K)				;ENTIRE BYTE WILL FIT.
I-LDB2	(POPJ-EQUAL-XCT-NEXT M-4 A-ZERO)
       ((M-2) A-ZERO)				;RETURN 0 FOR 0 LENGTH BYTE.
	((A-TEM2) SUB (M-CONSTANT 40) A-E)
	((M-TEM) SUB M-4 (A-CONSTANT 1))	;HARDWARE BYTE LENGTH IS REAL VALUE -1.
	(POPJ-AFTER-NEXT
	 (OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-TEM2)
       ((M-2) BYTE-INST M-1 A-ZERO)

I-LDB0	((M-2) SUB M-2 A-ZR)			;NUMBER OF BITS OFF TOP
	(JUMP-LESS-THAN-XCT-NEXT M-E A-ZR I-LDB2) ;JUMP IF ANY BITS OF BYTE IN THIS WORD
       ((M-4) SUB M-K A-2)			;REDUCE SIZE OF BYTE TO AS MUCH AS WILL FIT
	(POPJ-AFTER-NEXT (M-4) A-ZERO)		;BYTE NOT IN THIS WORD, RETURN 0 BITS
       ((M-2) A-ZERO)

;INTERNAL DPB. TAKES DATA TO DEPOSIT IN M-1, DATA TO DEPOSIT INTO IN M-2,
; SIZE OF M-2 (MAX 32.) IN M-ZR.  BITS IN M-K, PLACES OVER IN M-E.
; RESULT IN M-2.  M-K REDUCED BY BITS THAT WERE DEPOSITED (IE WILL BE ZERO IF
; ENTIRE BYTE FIT).  IF BYTE DID NOT COMPLETELY FIT, M-1 IS SHIFTED RIGHT BY
; AMOUNT THAT DID FIT.  SMASHES M-4, TEMPS
I-DPB	(POPJ-EQUAL M-K A-ZERO)
	((M-4) ADD M-K A-E)
	(JUMP-GREATER-THAN-XCT-NEXT M-4 A-ZR I-DPB0)	;JUMP IF LEFT EDGE OF BYTE OFF TOP
       ((M-TEM) SUB M-K (A-CONSTANT 1))
	((M-K) A-ZERO)				;NONE LEFT TO DO, WHOLE BYTE IN THIS WORD
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-E)
       ((M-2) DPB M-1 A-2)

I-DPB0	(POPJ-GREATER-OR-EQUAL M-E A-ZR)	;RETURN IF ENTIRE BYTE OFF TO LEFT
	((M-K) SUB M-4 A-ZR)			;M-K GETS NUMBER OF BITS LEFT OVER
	((M-TEM) SUB M-TEM A-K)			;REDUCE SIZE OF BYTE
	((OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-E)
	((M-2) DPB M-1 A-2)			;DO THE DPB
	((A-TEM2) M-A-1 (M-CONSTANT 40) A-TEM)	;SHIFT OVER TO USE UP WHATS BEEN DPB'ED
	(POPJ-AFTER-NEXT 			;FACT BYTE SIZE IS +1 DOESNT HURT,
	 (OA-REG-LOW) DPB M-K OAL-BYTL-1 A-TEM2)	; SINCE M-1 WASN'T 32 BITS
       ((M-1) BYTE-INST M-1 A-ZERO)		;RIGHT ADJUST BITS IN M-1 FOR NEXT TIME.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB-OFFSET PP PP M-C M-B)

XOPDPB(MISC-INST-ENTRY %P-DPB-OFFSET)
	(JUMP-XCT-NEXT XOPDP1)			;JOIN XDPB, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE DATA AND SET VMA

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGDPB M-1 (+ (LSH M-E 6) M-K) M-2)

XLDPB (MISC-INST-ENTRY %LOGDPB)    ;DPB FOR FIXNUMS ONLY, CAN STORE INTO SIGN BIT
	((M-2) C-PDL-BUFFER-POINTER-POP)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)
	((M-E) (BYTE-FIELD 6 6) C-PDL-BUFFER-POINTER-POP)
	((M-1) C-PDL-BUFFER-POINTER-POP)
	(CALL-XCT-NEXT I-DPB)	  ;SEMI-RANDOM TO USE THIS ROUTINE, BUT SPEED DOESNT
       ((M-ZR) (A-CONSTANT 24.))  ; MATTER AND IT SAVES A UINST OR TWO.
	(POPJ-AFTER-NEXT 
	  (M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB PP PP VMA)

XPDPB (MISC-INST-ENTRY %P-DPB)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)	;VMA MAY POINT TO UNBOXED DATA
XOPDP1  ((M-1) READ-MEMORY-DATA)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;ARG2, BYTE POINTER
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 1)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER) ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
	((M-K) SUB M-K (A-CONSTANT 1))
	((A-TEM1) (BYTE-FIELD 6 6) C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER
	((OA-REG-LOW) DPB M-K A-TEM1 OAL-BYTL-1)
	((WRITE-MEMORY-DATA-START-WRITE)	;VMA CAN BE LEFT POINTING AT UNBOXED DATA
		DPB C-PDL-BUFFER-POINTER-POP A-1)
	(CHECK-PAGE-WRITE)
	(JUMP XFALSE)
       
; DPB never changes the sign of quantity DPB'ed into, it extends
; the sign arbitrarily far to the left past the byte.
XDPB (MISC-INST-ENTRY DPB) (ERROR-TABLE RESTART XDPB)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))	;ADDRESS ARG1
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-INDEX TRAP-UNLESS-FIXNUM)	;MAKE SURE NOT BIGNUM
    (ERROR-TABLE ARGTYP FIXNUM (PP -2) 0 XDPB)
    (ERROR-TABLE ARG-POPPED 0 PP PP PP)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG) ;ONLY THE THIRD OPERAND IS 
	    (ERROR-TABLE ARGTYP NUMBER PP T XDPB)  ;PROCESSED VIA NUMARG. THUS DPB IS A
	    (ERROR-TABLE ARG-POPPED 0 PP PP PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-DPB))	   ;ONE OPERAND OP.
;FIXNUM CASE.  DATA TO DPB INTO (ARG3) SIGN EXTENDED IN M-1.
		(ERROR-TABLE RESTART XDPB0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;ARG2, BYTE POINTER
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 1 XDPB0)
    (ERROR-TABLE ARG-POPPED 0 PP PP M-1)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER) ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
	(CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XDPB0)
    (ERROR-TABLE ARG-POPPED 0 PP PP M-1)
	((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
			C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER
ASHDPB	((M-2) ADD M-K A-E)			;M-2 maximum number of bits in result
	(JUMP-GREATER-THAN M-2 (A-CONSTANT 32.) XDPB2A)	;Multi-word => use bignum code 
	(JUMP-LESS-THAN-XCT-NEXT M-1 A-ZERO ASHDPB-NEG)
       ((M-J) SUB M-K (A-CONSTANT 1))		;Single-word => use hardware DPB
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)
	((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1)
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO RETURN-M-1)	;Result in M-1 if sign didn't change
	((M-C) A-ZERO)				;Else it's a 2-word bignum
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE)
       ((M-2) A-ZERO)

ASHDPB-NEG					;Single-word DPB into negative number
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)
	((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1)
	(JUMP-LESS-THAN M-1 A-ZERO RETURN-M-1)	;Result in M-1 if sign didn't change
	((M-1) SUB M-ZERO A-1)			;Else it's a 2-word bignum
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-2) A-ZERO)
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-2) (A-CONSTANT 1))

;Get here on DPB ing into fixnum at position beyond 31. bits.  Fake up bignum
; and fall into bignum case.  Hair is that it avoids creating a
; garbage bignum just to copy out of.
XDPB2A	(CALL-LESS-THAN-XCT-NEXT M-1 A-ZERO XDPB-BM)   ;MAGNITUDIFY M-1 AND SAVE SIGN
       ((M-C) A-ZERO)		    ;IN BIGNUM-HEADER-SIGN POSITION.
ASHDPB1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC BIGDPB3)))
ASHDPB2	((M-J) DPB M-E (BYTE-FIELD (DIFFERENCE 23. 6) 6) A-K)
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-J Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;PUSH ARG2 BACK
	((M-D) DPB M-1 Q-POINTER    ;SUBROUTINE SMASHES M-1
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;THIS IS NOW ALWAYS A POSITIVE
	(CALL-XCT-NEXT DPB-BIGNUM-SETUP)			; NUMBER EVEN IF IT IS SETZ
       ((M-I) A-ZERO)	;INDICATE SPECIAL CASE TO BIGNUM-COPY-EXPAND. HEADER SIGN IN M-C.
	((MD) Q-POINTER M-D)
	((VMA-START-WRITE) ADD M-T (A-CONSTANT 1))  ;STORE AWAY SAVED PIECE, CREATING
	(CHECK-PAGE-WRITE)			    ;BIGNUM TO SMASH
;Smashable bignum in M-T, header in M-C.  Length in M-I has been smashed.
BIGDPB0	((M-I) BIGNUM-HEADER-LENGTH M-C)	;NEW LENGTH
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)  ;NUMBER-OF-BITS
	(CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
	    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
	    (ERROR-TABLE ARG-POPPED PP PP M-T)
	(CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG)	;GET 2'S COMPLEMENT REPRESENTATION
	((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
		C-PDL-BUFFER-POINTER-POP)  ;NUMBER OF PLACES OVER
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;DATA TO DEPOSIT.
	((M-D) (A-CONSTANT 1))		;OFFSET WITHIN BIGNUM
BIGDPB2	(JUMP-LESS-THAN M-E (A-CONSTANT 31.) BIGDPB1)
	((M-D) ADD M-D (A-CONSTANT 1))		;BYTE DOES NOT START IN THIS WORD
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-D A-I BIGDPB2)
       ((M-E) SUB M-E (A-CONSTANT 31.))
	(CALL TRAP)
	   (ERROR-TABLE BIGNUM-NOT-BIG-ENOUGH-DPB)	;SHOULDN'T HAPPEN

BIGDPB1	((VMA-START-READ) ADD M-T A-D)	  ;FETCH WORD OF BIGNUM
	(CHECK-PAGE-READ)
	((M-ZR) (A-CONSTANT 31.))
	(CALL-XCT-NEXT I-DPB)		;DEPOSIT IN SOME
       ((M-2) READ-MEMORY-DATA)
	((MD-START-WRITE) M-2)		;WRITE THAT WORD BACK.
	(CHECK-PAGE-WRITE)
	(POPJ-EQUAL M-K A-ZERO)			;NO BITS LEFT TO DEPOSIT
	((VMA-START-READ) ADD M-T A-D ALU-CARRY-IN-ONE)
	(CHECK-PAGE-READ)
	((M-E) A-ZERO)
	(CALL-XCT-NEXT I-DPB)		;DEPOSIT THE REST OF THE BITS.
       ((M-2) READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT (MD-START-WRITE) M-2)
       (CHECK-PAGE-WRITE)

XDPB-BM	(POPJ-AFTER-NEXT   ;MAKING NEGATIVE NUMBER.  MAGNITUDIFY AND SET BIGNUM SIGN BIT.
	 (M-1) SUB M-ZERO A-1)
       ((M-C) DPB M-MINUS-ONE BIGNUM-HEADER-SIGN A-ZERO)

;Bignum in M-T, length in M-I.  Take 2's complement of it.  Bashes M-3, M-4
BIGNEG	((M-3) (A-CONSTANT 1))		;Offset into bignum
	((M-4) (A-CONSTANT 0))		;0 if borrow, -1 if no borrow
BIGNEG1	((VMA-START-READ) ADD M-T A-3)
	(CHECK-PAGE-READ)
	((M-3) ADD M-3 (A-CONSTANT 1))
	((M-TEM) READ-MEMORY-DATA)
	(JUMP-EQUAL-XCT-NEXT READ-MEMORY-DATA A-ZERO BIGNEG2)
       ((M-TEM) SUB M-4 A-TEM)
	((M-4) (A-CONSTANT -1))		;No more borrow
BIGNEG2	((MD-START-WRITE) (BYTE-FIELD 31. 0) M-TEM)	;Make sure high bit stays clear
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-OR-EQUAL M-3 A-I BIGNEG1)
	(POPJ)

BIGNUM-DPB  ;bignum in M-Q, header in M-C, length in M-I.
	(CALL DPB-BIGNUM-SETUP)
	(CALL BIGDPB0)
BIGDPB3	(CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG)	;If was negated, put in sign-magn form
	(JUMP BIGNUM-DPB-CLEANUP)	;bignum in M-T, header in M-C, length in M-I.

XDPB-ZERO
	((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
	(POPJ-AFTER-NEXT 			;RESULT IS ARG3
	    (M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)	;AND POP OTHER TWO ARGS

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-MASK-FIELD-OFFSET PP M-C M-B)

XOPMF (MISC-INST-ENTRY %P-MASK-FIELD-OFFSET)
	(JUMP-XCT-NEXT XOPMF1)			;JOIN XMF, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE LOCATION

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-MASK-FIELD PP VMA)

XPMF  (MISC-INST-ENTRY %P-MASK-FIELD)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
XOPMF1	(JUMP-XCT-NEXT XPFM1)
       ((M-1) READ-MEMORY-DATA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS MASK-FIELD PP M-1)

XMF   (MISC-INST-ENTRY MASK-FIELD)	;LIKE LDB BUT DATA IN ORIGINAL POSITION IN Q
	((M-1) C-PDL-BUFFER-POINTER-POP)	;DATA TO EXTRACT
XPFM1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) ;ARG1, BYTE POINTER.  MUST BE FIXNUM.
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP 0)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XLDB-ZERO)  ;WANT 0 BITS, RETURN 0
					   ; (THIS IS A FAIRLY RANDOM THING TO CHECK FOR
					   ; BUT IF WE DIDNT, IT WOULD CAUSE LOSSAGE)
	((M-J) SUB M-K (A-CONSTANT 1))	   ;BECAUSE BITS IN LDB IS +1
	((A-TEM2) (BYTE-FIELD 6 6) C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER
	(POPJ-AFTER-NEXT 		   ;NO "SHIFTER LOSSAGE" ON SELECTIVE-DEPOSIT
	 (OA-REG-LOW) DPB M-J A-TEM2 OAL-BYTL-1)
       ((M-T) SELECTIVE-DEPOSIT 
		M-1 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DEPOSIT-FIELD-OFFSET PP PP M-C M-B)

XOPDF(MISC-INST-ENTRY %P-DEPOSIT-FIELD-OFFSET)
	(JUMP-XCT-NEXT XOPDF1)			;JOIN XDF, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE LOCATION AND SET VMA

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DEPOSIT-FIELD PP PP VMA)

XPDF (MISC-INST-ENTRY %P-DEPOSIT-FIELD)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
XOPDF1	(CALL-XCT-NEXT XPDF1)
       ((A-TEM3) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	(JUMP XFALSE)

;This can return untyped data.  It also doesn't work on bignums.
;Fortunately no one has ever called it.
XDF  (MISC-INST-ENTRY DEPOSIT-FIELD)
	((A-TEM3) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG3, DATA TO STORE IN
XPDF1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;ARG2, BYTE POINTER
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP 1)
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER) ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
	((M-K) SUB M-K (A-CONSTANT 1))
	((A-TEM1) (BYTE-FIELD 6 6) C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-K A-TEM1 OAL-BYTL-1)
       ((M-T) SELECTIVE-DEPOSIT C-PDL-BUFFER-POINTER-POP A-TEM3)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-STORE-TAG-AND-POINTER PP M-A)

XCMBS (MISC-INST-ENTRY %P-STORE-TAG-AND-POINTER)
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG3, VALUE FOR POINTER FIELD
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)	      ;ARG3 ANY TYPE, MISCBITS MUST BE FIXNUM
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	((WRITE-MEMORY-DATA) DPB C-PDL-BUFFER-POINTER-POP ;ARG2, VALUE FOR TYPE, ETC.
		Q-ALL-BUT-POINTER A-A)
	((VMA-START-WRITE) C-PDL-BUFFER-POINTER-POP) ;ARG1, WHERE TO STORE
	(CHECK-PAGE-WRITE)
	(JUMP XFALSE)

XPDAT (MISC-INST-ENTRY %P-POINTER)
	((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-POINTER))))
XPDAT1  ((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT
	 (OA-REG-LOW) M-K)
       ((M-T) BYTE-INST READ-MEMORY-DATA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XPDATP (MISC-INST-ENTRY %P-DATA-TYPE)
	(JUMP-XCT-NEXT XPDAT1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-DATA-TYPE))))

XPCDRC (MISC-INST-ENTRY %P-CDR-CODE)
	(JUMP-XCT-NEXT XPDAT1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-CDR-CODE))))

XPFLAG (MISC-INST-ENTRY %P-FLAG-BIT)
	(JUMP-XCT-NEXT XPDAT1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-FLAG-BIT))))

XSPDTP (MISC-INST-ENTRY %P-STORE-DATA-TYPE)
	((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-DATA-TYPE))))
XSPDTP1 ((M-T) C-PDL-BUFFER-POINTER-POP)	;DATA TO DPB IN (ALSO RETURN AS VALUE)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	((A-TEM2) READ-MEMORY-DATA)
	((OA-REG-LOW) M-K)
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-T A-TEM2)
	(CHECK-PAGE-WRITE)
	(POPJ)

XSPDAT (MISC-INST-ENTRY %P-STORE-POINTER)
	(JUMP-XCT-NEXT XSPDTP1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-POINTER))))

XSPCDR (MISC-INST-ENTRY %P-STORE-CDR-CODE)
	(JUMP-XCT-NEXT XSPDTP1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-CDR-CODE))))

XSPUSR (MISC-INST-ENTRY %P-STORE-FLAG-BIT)
	(JUMP-XCT-NEXT XSPDTP1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-FLAG-BIT))))

;Provides a way to pick up the pointer-field of an external-value-cell
;pointer or a dtp-null pointer, or any invisible pointer,
;converting it into a locative and transporting it if it points to old-space.
XPCAL (MISC-INST-ENTRY %P-CONTENTS-AS-LOCATIVE)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)	;GET SPECD LOCATION
	(CHECK-PAGE-READ)
XPCAL1	(CALL-XCT-NEXT TRANS-OLD0)			;TRANSPORT OLDSPACE POINTER, BUT
       ((M-1) MD)					; DON'T CHASE INVISIBLE POINTERS
	(POPJ-AFTER-NEXT (M-T) Q-POINTER MD 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       (CALL-NOT-EQUAL MD A-1 XPCAL1)			;REPEAT IF E.G. SNAPPED OUT HDR-FWD

XPCALO (MISC-INST-ENTRY %P-CONTENTS-AS-LOCATIVE-OFFSET)
	(JUMP-XCT-NEXT XPCAL1)
       (CALL XOMR0)					;GET SPECD LOCATION
	
XPDIF (MISC-INST-ENTRY %POINTER-DIFFERENCE)
	((M-T) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT
	  (M-T) SUB C-PDL-BUFFER-POINTER-POP A-T)
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;; (%WRITE-INTERNAL-PROCESSOR-MEMORIES CODE ADR D-HI D-LOW)
;;   CODE SELECTS WHICH MEMORY GETS WRITTEN. 1 -> I, 2 -> D, 4 -> A/M . 
;;    (THIS IS A SUBSET OF THE CODE USED IN MCR FILES).
XWIPM (MISC-INST-ENTRY %WRITE-INTERNAL-PROCESSOR-MEMORIES)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-1) DPB C-PDL-BUFFER-POINTER (BYTE-FIELD 10 30) A-1)  ;M-1 GETS 32 BITS DATA
	((M-2) (BYTE-FIELD 20 10) C-PDL-BUFFER-POINTER-POP)      ;M-2 GETS REST BEYOND THAT
	((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP)		;ADDRESS
	((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)		;CODE
	(JUMP-EQUAL M-B (A-CONSTANT 1) XWIPM-I)
	(JUMP-EQUAL M-B (A-CONSTANT 2) XWIPM-D)
	(CALL-NOT-EQUAL M-B (A-CONSTANT 4) TRAP)
   (ERROR-TABLE BAD-INTERNAL-MEMORY-SELECTOR-ARG M-B)
	(JUMP-LESS-THAN M-A (A-CONSTANT 40) XWIPM-M)
	((OA-REG-LOW) DPB M-A OAL-A-DEST A-ZERO)
	((A-GARBAGE) M-1)
	(JUMP XFALSE)

XWIPM-M ((OA-REG-LOW) DPB M-A OAL-M-DEST A-ZERO)
	((M-GARBAGE) M-1)
	(JUMP XFALSE)

XWIPM-D ((OA-REG-LOW) DPB M-A OAL-DISP A-ZERO)
	(DISPATCH A-1 WRITE-DISPATCH-RAM)
	(JUMP XFALSE)

XWIPM-I ((OA-REG-LOW) DPB M-A OAL-JUMP A-ZERO)
	(WRITE-I-MEM A-2 M-1)
	(JUMP XFALSE)

;; Give this an offset into the IO part of the XBUS, not an XBUS address.
XXBR (MISC-INST-ENTRY %XBUS-READ)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0)
    (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) (BYTE-FIELD 18. 0) C-PDL-BUFFER-POINTER-POP	;XBUS word addr
		(A-CONSTANT LOWEST-IO-SPACE-VIRTUAL-ADDRESS))
XUBR0	(CHECK-PAGE-READ)		;Mustn't check for sequence breaks since
	(JUMP-XCT-NEXT RETURN-M-1)	;on some devices reading has side effects and if
       ((M-1) READ-MEMORY-DATA)		;a sequence break occurred we would read it twice

XUBR (MISC-INST-ENTRY %UNIBUS-READ)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0)
    (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) (BYTE-FIELD 17. 1) C-PDL-BUFFER-POINTER-POP	;UBUS word addr
		(A-CONSTANT LOWEST-UNIBUS-VIRTUAL-ADDRESS))
	(JUMP XUBR0)

;; %XBUS-WRITE-SYNC w-loc w-val delay s-loc s-mask s-val
;; Waits for (LOGAND (%XBUS-READ s-loc) s-mask) to not-equal s-val, then
;; to equal s-val.  Then it loops 'delay' number of times and writes
;; w-val into w-loc.  This is intended for such things as color-map hacking.
XXBWS (MISC-INST-ENTRY %XBUS-WRITE-SYNC)
	(CALL GET-32-BITS)		;S-VAL
	((M-2) M-1)
	(CALL GET-32-BITS)		;S-MASK
	((VMA) (BYTE-FIELD 18. 0) C-PDL-BUFFER-POINTER-POP	;S-LOC
		(A-CONSTANT LOWEST-IO-SPACE-VIRTUAL-ADDRESS))
XXBWS1	((VMA-START-READ) VMA)
	(CHECK-PAGE-READ)
	((M-3) AND READ-MEMORY-DATA A-1)
	(JUMP-EQUAL M-3 A-2 XXBWS1)
XXBWS2	((VMA-START-READ) VMA)
	(CHECK-PAGE-READ)
	((M-3) AND READ-MEMORY-DATA A-1)
	(JUMP-NOT-EQUAL M-3 A-2 XXBWS2)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;DELAY
XXBWS3	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO XXBWS3)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	;drop into XXBW

;; See comments on %XBUS-READ above.
XXBW (MISC-INST-ENTRY %XBUS-WRITE)
	(CALL GET-32-BITS)		;M-1 gets value to write
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
		(ERROR-TABLE ARGTYP FIXNUM PP 0)
	((WRITE-MEMORY-DATA) M-1)
	((VMA-START-WRITE M-T) ADD C-PDL-BUFFER-POINTER-POP	;Return random fixnum in M-T
		(A-CONSTANT LOWEST-IO-SPACE-VIRTUAL-ADDRESS))
	(CHECK-PAGE-WRITE)
	(POPJ)

XUBW (MISC-INST-ENTRY %UNIBUS-WRITE)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
		(ERROR-TABLE ARGTYP FIXNUM PP 1)
	((M-T WRITE-MEMORY-DATA) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;WORD TO WRITE
;;; IF THIS IS MADE CONTINUABLE, THIS WILL HAVE TO BE FIXED
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
		(ERROR-TABLE ARGTYP FIXNUM PP 0)
	((M-A) (BYTE-FIELD 17. 1) C-PDL-BUFFER-POINTER-POP)	;UBUS WORD ADDR
	((VMA-START-WRITE) ADD M-A (A-CONSTANT LOWEST-UNIBUS-VIRTUAL-ADDRESS))
	(CHECK-PAGE-WRITE)
	(POPJ)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS GET M-B M-A)

XGET (MISC-INST-ENTRY GET)
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Arg2, property name.
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Arg1, symbol or plist.
	(CALL-XCT-NEXT PLGET)	;Get the plist itself into M-T.
       ((M-B) M-T)		;Save copy of arg in M-B.
XGET1	(POPJ-EQUAL M-T A-V-NIL)		;END OF PLIST REACHED
	(CALL-XCT-NEXT QCAR)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)	;SAVE THIS PLIST NODE
	(JUMP-EQUAL M-T A-A QTAD)		;GOT IT, RETURN CADR OF NODE
	(JUMP-XCT-NEXT XGET1)
       (CALL QTDD)				;TAKE CDDR AND LOOK AGAIN

;SUBROUTINE TO PICK UP THE PLIST OF THE OBJECT IN M-T, RETURNING IT IN M-T.
;RETURNS NIL IF A RANDOM TYPE, FOR MACLISP COMPATIBILITY.  UNFORTUNATELY
;NOT USEFUL FOR PLIST-CHANGING THINGS, BUT THOSE AREN'T CURRENTLY IN MICROCODE ANYWAY.
PLGET	((M-ZR) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) PLGET2)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LIST)) QCDR) ;"DISEMBODIED" PROPERTY LIST
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) QCDR) ;"DISEMBODIED" PROPERTY LIST
	(JUMP XFALSE)				;GET OF RANDOM THINGS NIL IN MACLISP, SO ...

PLGET2	((VMA-START-READ) ADD M-T		;ARG1, SYMBOL TO GET FROM
		      (A-CONSTANT 3))		;GET PLIST CELL OF ARG1
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS GETL M-B M-S)

XGETL (MISC-INST-ENTRY GETL)
	((M-S) C-PDL-BUFFER-POINTER-POP)	;ARG2, LIST OF PROPERTIES
	((M-B) C-PDL-BUFFER-POINTER-POP)	;ARG1, THING TO GET FROM
	(CALL-XCT-NEXT PLGET)
       ((M-T) M-B)
XGETL1	(POPJ-EQUAL M-T A-V-NIL)		;EXHAUSTED THE PLIST
	(CALL-XCT-NEXT QCAR)			;GET NEXT INDICATOR
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)	;SAVE CURRENT PLIST NODE
	((M-A) Q-TYPED-POINTER M-T)		;SAVE INDICATOR.
	((M-T) Q-TYPED-POINTER M-S)		;GET LIST OF PROPERTY NAMES
XGETL2	(JUMP-EQUAL M-T A-V-NIL XGETL3)		;NO MATCH THIS ONE
	(CALL-XCT-NEXT QCAR)			;GET NEXT PROP NAME TO TRY
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(JUMP-EQUAL M-T A-A POP1TJ)		;GOT IT
	(CALL-XCT-NEXT QCDR)
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;TRY NEXT PROP NAME
	(JUMP XGETL2)

XGETL3	(JUMP-XCT-NEXT XGETL1)       
       (CALL QTDD)				;TRY NEXT PROPERTY

POP1TJ	(POPJ-AFTER-NEXT
	  (M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS ASSQ M-A M-B)

XASSQ (MISC-INST-ENTRY ASSQ)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;ARG2
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;ARG1
	((M-B) M-T)
XASSQ1	(POPJ-EQUAL M-T A-V-NIL)
	(CALL-XCT-NEXT QMAA)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(JUMP-EQUAL M-T A-A QTA)
	(JUMP-XCT-NEXT XASSQ1)
       (CALL QTD)

POPTJ	(POPJ-AFTER-NEXT
	  (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS LAST (PP -1))

XLAST (MISC-INST-ENTRY LAST)
	((M-T C-PDL-BUFFER-POINTER-PUSH) C-PDL-BUFFER-POINTER)
XLAST1	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP POPT1J)
	(CALL-XCT-NEXT QCDR)
       ((C-PDL-BUFFER-POINTER) M-T)
	(JUMP XLAST1)

POPT1J	(POPJ-AFTER-NEXT
	  (M-T) C-PDL-BUFFER-POINTER-POP)
	(C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS LENGTH M-A)

XLENGT (MISC-INST-ENTRY LENGTH)
   (ERROR-TABLE RESTART LENGTH)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-A) M-T)
XTLENG	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)		;MC-LINKAGE
	 (CALL-NOT-EQUAL M-T A-V-NIL TRAP)
   (ERROR-TABLE ARGTYP LIST M-T T LENGTH)
	((C-PDL-BUFFER-POINTER-PUSH) 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
XLEN1	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP POPTJ)
	(CALL QCDR)
	(JUMP-XCT-NEXT XLEN1)
       ((C-PDL-BUFFER-POINTER) ADD C-PDL-BUFFER-POINTER (A-CONSTANT 1))

(ERROR-TABLE DEFAULT-ARG-LOCATIONS SET M-S M-T)

XSET (MISC-INST-ENTRY SET)
	((M-T) C-PDL-BUFFER-POINTER-POP) 		;ARG2, NEW VALUE & RESULT
		(ERROR-TABLE RESTART XSET)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		;ARG1, THE SYMBOL TO SET
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP 0 XSET)
   (ERROR-TABLE ARG-POPPED 0 PP M-T)
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((VMA-START-READ) ADD M-S (A-CONSTANT 1))	;ACCESS V.C.
	(CHECK-PAGE-READ)				;READ VALUE CELL FIRST
	(JUMP-NOT-EQUAL M-S A-V-NIL XSET2)		;Merge with STOCYC.
	(CALL TRAP)					;Don't clobber NIL!
   (ERROR-TABLE ARGTYP NON-NIL M-S 0)

XNOT (MISC-INST-ENTRY NOT)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(JUMP-EQUAL M-T A-V-NIL XTRUE)
	(JUMP XFALSE)

XATOM (MISC-INST-ENTRY ATOM)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP SKIP-IF-ATOM)
	(JUMP XFALSE)
	(JUMP XTRUE)

XHALT (MISC-INST-ENTRY %HALT)
	(JUMP HALT-CONS XFALSE)		;CONTINUING RETURNS NIL

XGPN  (MISC-INST-ENTRY GET-PNAME)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP T)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-T) DPB READ-MEMORY-DATA Q-POINTER
		 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))

; SHIFTING WITH CONS ...
;   THE CONS HARDWARE TAKES THE OPPOSITE APPROACH FROM MOST MACHINES IN THAT
; LDB AND DPB ARE PRIMITIVE AND SHIFTS HAVE TO BE BUILT UP OUT OF THEM INSTEAD
; OF THE OTHER WAY AROUND.  FOR THE PURPOSES OF CONS, THIS IS USUALLY A GREAT
; WIN, BUT IT DOES MAKE FOR A CERTAIN AMOUNT OF PAIN WHEN REALLY TRYING TO DO A SHIFT.
;   FURTHER PAIN IS CAUSED WHEN THE AMOUNT OF THE SHIFT MUST COME FROM THE
; "DATA" SIDE OF THE MACHINE (AS WITH ROT AND LSH) INSTEAD OF BEING A CONSTANT AMOUNT
; KNOWN AT MICRO-ASSEMBLY TIME.  WHEN THIS IS THE CASE,
;  (1) THE ARGUMENT MUST BE "MOVED" FROM THE DATA SIDE TO THE CONTROL SIDE BY THE USE
;	OF OA- TYPE DESTINATIONS.  AS A COLLARY OF THIS, IT IS NECESSARY TO MASK THINGS
;	CAREFULLY TO AVOID RANDOMNESS, AND THERE IS NOT MUCH FLEXIBILITY AS TO 
;	WHAT SIGNS THINGS HAVE ETC.  VARIOUS "QUIRKS" OF THE HARDWARE, NORMALLY
;	COMPENSATED FOR BY THE MICRO-ASSEMBLER, MUST BE DELT WITH BY THE USER:
;	(A) THE BYTE LENGTH FIELD IS REALLY THE	<BYTE-LENGTH-1> FIELD.
;	    ALSO, BECAUSE THE FIELD IS 5 BITS LONG, ZERO BIT BYTES DONT WIN
;	    AT ALL (THEY "BECOME" 32. BYTES).
;	(B) ONE MUST REMEMBER THE M-ROTATE IS ALWAYS A LEFT ROTATE.  THIS IS 
;	    "NATURAL" FOR DPB, BUT ON LDB THE MICROASSEMBLER NORMALLY HAS TO 
;	    BUGGER THINGS TO COMPENSATE AND MAKE IT APPEAR A RIGHT SHIFT IS
;	    BEING DONE.  NATURALLY, USING OA- MODIFIERS, THERE IS NO OPPORTUNITY
;	    FOR THIS TO HAPPEN WITHOUT BEING EXPLICITLY CODED IN MICRO-INSTRUCTIONS.
;	    THE BUGGER REQUIRED IS TO "REPLACE" THE M-ROTATE FIELD WITH
;	      (LOGAND 37 (- 40 <"NATURAL" M-ROTATE>)).
;  (2) THE POSSIBITY OF CONSTRUCTING AN "ILLEGAL" BYTE POINTER ON A DPB MUST BE 
;	CAREFULLY CONSIDERED.  BRIEFLY, THE SUM <BYTE-LENGTH-1> + <M-ROTATE> MUST BE
;	LESS THAN OR EQUAL TO 37 OCTAL.  IF IT IS GREATER, THE HARDWARE WILL
;	PRODUCE AN ALL-ZERO ANSWER (ACTUALLY, IT IS COMPLETELY IDENTICALLY EQUAL TO THE
;	A-SOURCE).  HERE A LDB DOESNT GIVE SO MUCH PROBLEM SINCE
;	THE HARDWARE JUST ROTATES THE INDICATED AMOUNT AND TAKES THE LOW N BITS.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS LSH PP M-K)

XLSH  (MISC-INST-ENTRY LSH)
		(ERROR-TABLE RESTART XLSH)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 1 XLSH)
   (ERROR-TABLE ARG-POPPED 0 PP PP)
	((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)  ;ARG2, AMT TO SHIFT
		(ERROR-TABLE RESTART XLSH0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 0 XLSH0)
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT M-K XLSH1)  ;SHIFT TO RIGHT
LSH-LEFT
	((M-1) SUB (M-CONSTANT 23.) A-K)	;COMPUTE BYTE LENGTH <24.-SHIFT-1>
	(JUMP-LESS-THAN M-1 A-ZERO XLSH-ZERO)
	(POPJ-AFTER-NEXT
	 (OA-REG-LOW) DPB M-1 OAL-BYTL-1 A-K)
       ((M-T) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 0 0) 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XLSH1	(JUMP-LESS-THAN M-K (A-CONSTANT (PLUS 1_24. -23.)) XLSH-ZERO) ;SHIFT RIGHT
	((A-TEM1) ADD M-K (A-CONSTANT (PLUS (BYTE-MASK BITS-ABOVE-FIXNUM)  ;TO SIGN EXTEND
					 40)))	; TO 32. COMPUTE 40-N .
	((M-1) ADD M-K (A-CONSTANT (PLUS (BYTE-MASK BITS-ABOVE-FIXNUM)
					 23.)))	;COMPUTE 24.-N-1
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-1 OAL-BYTL-1 A-TEM1)
       ((M-T) BYTE-INST (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
			C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS ROT PP M-K)

XROT  (MISC-INST-ENTRY ROT)
		(ERROR-TABLE RESTART XROT)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 1 XROT)
   (ERROR-TABLE ARG-POPPED 0 PP PP)
	((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)  ;ARG2, AMT TO ROT
		(ERROR-TABLE RESTART XROT0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 0 XROT0)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;ARG1, DATA TO ROT
XROT3 ;	*** THIS SHOULD PROBABLY LET YOU INTERRUPT AND SEQUENCE-BREAK OUT ***
	(JUMP-IF-BIT-SET BOXED-SIGN-BIT M-K XROT1)  ;ROT TO RIGHT
	(JUMP-EQUAL M-K A-ZERO CPOPJ)			;NO CHANGE (AVOID BYTL-1 LOSS)
	(JUMP-GREATER-OR-EQUAL M-K (A-CONSTANT 24.) XROT2)
;GENERAL IDEA: (1) SHIFT A 24.-N BIT PIECE N PLACES LEFT
;		    (ACTUALLY, A TRUE SHIFT OF A UNMASKED 32 BIT PIECE WOULD DO.
;		     ON THE OTHER HAND, WE HAVE THE UNSAFE BYTE POINTER PROBLEM.)
;	       (2) LDB A N BIT PIECE FROM 24-N BITS OVER
;	       (3) IOR THE TWO.
XROT3A	;REALLY DO THE WORK. BY NOW, 0 < M-K < 24.
						;DO LSH OF STEP ONE
	((M-1) SUB (M-CONSTANT 23.) A-K)	;COMPUTE BYTE LENGTH
;	(JUMP-LESS-THAN M-1 A-ZERO XLSH-ZERO)   ;CANT BE
	((OA-REG-LOW) DPB M-1 OAL-BYTL-1 A-K)
	((A-TEM3) DPB M-T (BYTE-FIELD 0 0) A-ZERO)	;PART 1 DONE
	((A-TEM2) ADD M-K (A-CONSTANT 8))		;COMPUTE 40-<24.-N>
	((M-ZR) SUB M-K (A-CONSTANT 1))		;BYTE LENGTH MINUS ONE
	((OA-REG-LOW) DPB M-ZR OAL-BYTL-1 A-TEM2)
	(POPJ-AFTER-NEXT			;PART 2 DONE
	  (M-T) BYTE-INST M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((M-T) IOR M-T A-TEM3)			;PART 3

XROT2	(JUMP-XCT-NEXT XROT3)			;LOOP UNTIL RESULT AFTER
       ((M-K) SUB M-K (A-CONSTANT 24.))		;SUBTRACTION IS LESS THAN 24.

;ROTATE TO RIGHT.  CONVERT TO EQUIVALENT LEFT ROTATE (24.- <-N>)
XROT1	((M-K) SELECTIVE-DEPOSIT M-K Q-POINTER (A-CONSTANT -1))	;EXTEND SIGN
	(JUMP-XCT-NEXT XROT3)
       ((M-K) ADD M-K (A-CONSTANT 24.))

      (MISC-INST-ENTRY %INTERNAL-VALUE-CELL)
XIVC	(CALL XVCL)		;Returns contents of IVC.  Does not follow EVCPs.
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA) ;GC
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

XVCL  (MISC-INST-ENTRY VALUE-CELL-LOCATION)
	((A-TEM1) (A-CONSTANT 1))
XCL1	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP T)
   (ERROR-TABLE ARG-POPPED 0 PP)
	(POPJ-AFTER-NEXT 
	 (M-T) DPB Q-POINTER C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       ((M-T) ADD M-T A-TEM1)

XFCL  (MISC-INST-ENTRY FUNCTION-CELL-LOCATION)
	(JUMP-XCT-NEXT XCL1)
       ((A-TEM1) (A-CONSTANT 2))

XPRPCL (MISC-INST-ENTRY PROPERTY-CELL-LOCATION)
	(JUMP-XCT-NEXT XCL1)
       ((A-TEM1) (A-CONSTANT 3))

XPACKCL (MISC-INST-ENTRY PACKAGE-CELL-LOCATION)
	(JUMP-XCT-NEXT XCL1)
       ((A-TEM1) (A-CONSTANT 4))


XFCTEV (MISC-INST-ENTRY FSYMEVAL)
	(JUMP-XCT-NEXT XSYME2)
       ((M-1) (A-CONSTANT 2))

XSYMEV (MISC-INST-ENTRY SYMEVAL)
	((M-1) (A-CONSTANT 1))
XSYME2		(ERROR-TABLE RESTART XSYME2)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
	 	  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP T XSYME2)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) ADD C-PDL-BUFFER-POINTER-POP A-1)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA) ;GC, FOLLOW INVZ
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

;THIS IS THE OLD VERSION OF THE MAKE-LIST FUNCTION.  WE HAVE TO KEEP THIS AROUND
;SO THAT QFASL FILES THAT USED TO CALL MAKE-LIST, AND WERE COMPILED TO PRODUCE
;THIS MISC-INST, WILL STILL WORK.  BUT THIS IS NOW COMPLETELY OBSOLETE.
(ERROR-TABLE DEFAULT-ARG-LOCATIONS %OLD-MAKE-LIST M-S M-B)

XMKLS (MISC-INST-ENTRY %OLD-MAKE-LIST)
		(ERROR-TABLE RESTART XMKLS)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 2 XMKLS)
    (ERROR-TABLE ARG-POPPED 0 PP PP)
	((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;ARG 2 NUMBER OF QS
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG 1 AREA
	(JUMP-EQUAL M-B A-ZERO XFALSE)			;ZERO LENGTH LIST IS NIL
	(CALL LIST-OF-NILS)
	(POPJ-AFTER-NEXT
	 (M-T) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
       (NO-OP)

;THIS IS THE NEW PRIMITIVE CALLED BY MAKE-LIST.  ARGUMENTS ARE
;INITIAL-VALUE, AREA, LENGTH.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %MAKE-LIST PP M-S M-B)

XNMKLS (MISC-INST-ENTRY %MAKE-LIST)
		(ERROR-TABLE RESTART XNMKLS)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 2 XNMKLS)
    (ERROR-TABLE ARG-POPPED 0 PP PP PP)
	((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;THIRD ARG NUMBER OF QS
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;SECOND ARG AREA
	(JUMP-EQUAL M-B A-ZERO POP-THEN-XFALSE)		;ZERO LENGTH LIST IS NIL
	(CALL LIST-OF-THINGS)				;TAKES INITIAL-VALUE ON STACK
	(POPJ-AFTER-NEXT
	 (M-T) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
       (NO-OP)

POP-THEN-XFALSE
	(JUMP-XCT-NEXT XFALSE)
       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS MEMQ M-A M-B)

XMEMQ (MISC-INST-ENTRY MEMQ)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-B) M-T)
XMEMQ1	(POPJ-EQUAL M-T A-V-NIL)
	(CALL-XCT-NEXT QCAR)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(POPJ-EQUAL-XCT-NEXT M-T A-A)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-XCT-NEXT XMEMQ1)
       (CALL QCDR)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS FIND-POSITION-IN-LIST M-A M-C)

XFPIL (MISC-INST-ENTRY FIND-POSITION-IN-LIST)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-C) M-T)
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-B) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
XFPIL1	(POPJ-EQUAL M-T A-V-NIL)
	(CALL-XCT-NEXT QCAR)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(JUMP-EQUAL-XCT-NEXT M-T A-A XFPLX)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-B) ADD M-B A-ZERO ALU-CARRY-IN-ONE)
	(JUMP-XCT-NEXT XFPIL1)
       (CALL QCDR)

XFPLX	(POPJ-AFTER-NEXT 
	 (M-T) M-B)
       (NO-OP)

   (MISC-INST-ENTRY LISTP)
XLISTP	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP SKIP-IF-LIST)
	(JUMP XFALSE)
	(JUMP XTRUE)

   (MISC-INST-ENTRY NLISTP)
XNLSTP	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP SKIP-IF-ATOM)
	(JUMP XFALSE)
	(JUMP XTRUE)

   (MISC-INST-ENTRY SYMBOLP)
XSYMP	((M-ZR) Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) XTRUE)
	(JUMP XFALSE)

   (MISC-INST-ENTRY NSYMBOLP)
XNSYMP	((M-ZR) Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP)
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) XTRUE)
	(JUMP XFALSE)

   (MISC-INST-ENTRY ARRAYP)
XARRYP	((M-ZR) Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XTRUE)
	(JUMP XFALSE)

   (MISC-INST-ENTRY STRINGP)
	;; A STRING IS DEFINED TO BE A ONE-D ARRAY OF TYPE ART-STRING OR ART-FAT-STRING.
XSTRNP	((M-A) C-PDL-BUFFER-POINTER-POP)
	((M-TEM) Q-DATA-TYPE M-A)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XFALSE)
	((VMA-START-READ) M-A)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) (LISP-BYTE %%ARRAY-NUMBER-DIMENSIONS) READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT 1) XFALSE)
	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XTRUE)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XTRUE)
	(JUMP XFALSE)

   (MISC-INST-ENTRY FBOUNDP)
XFCTNP	(JUMP-XCT-NEXT XBOUNP1)
       ((M-1) (A-CONSTANT 2))

   (MISC-INST-ENTRY BOUNDP)
XBOUNP	((M-1) (A-CONSTANT 1))
XBOUNP1	(ERROR-TABLE RESTART XBOUNP1)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP 0 XBOUNP1)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) ADD C-PDL-BUFFER-POINTER-POP A-1)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-WRITE READ-MEMORY-DATA)	;NOT USING CONTENTS, DON'T BARF IF NULL
	((M-ZR) Q-DATA-TYPE READ-MEMORY-DATA)		;AND DON'T TRANSPORT
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-NULL)) XFALSE)
	(JUMP XTRUE)

   (MISC-INST-ENTRY %BINDING-INSTANCES)    ;(%BINDING-INSTANCES <LIST-OF-SYMBOLS>)
  ;SIMILAR TO CLOSURE, BUT TAKES NO FUNCTION.  VALUE RETURNNED IS LIST OF
  ;LOCATIVES WHICH ARE ALTERNATELY INTERNAL AND EXTERNAL VALUE CELL POINTERS.
XBINS   ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
	(JUMP-EQUAL M-T A-V-NIL POPTJ)
	(CALL XTLENG)
	((M-B) ADD M-T A-T)			;TWO CELLS FOR EACH VAR
	((M-B) Q-POINTER M-B)
	(CALL-XCT-NEXT LIST-OF-NILS)		;ALLOCATE CLOSURE OUT OF LIST SPACE
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)  ;LIST OF NILS SETS UP CDR CODES
	((M-T C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-T 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))  ;VALUE TO RETURN, EVENTUALLY
	(JUMP-XCT-NEXT XBINS1)
       ((C-PDL-BUFFER-POINTER-PUSH) M-T)	;FILLING POINTER.

   (MISC-INST-ENTRY CLOSURE)	;(CLOSURE <CLOSURE-LIST> <FCTN>)
XCLOS	((M-J) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)   ;FCTN
	(CALL-XCT-NEXT XTLENG)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
	((M-B) ADD M-T A-T ALU-CARRY-IN-ONE)	;TWO CELLS FOR EACH VAR PLUS ONE FOR FCTN
	((M-B) Q-POINTER M-B)
	(CALL-XCT-NEXT LIST-OF-NILS)		;ALLOCATE CLOSURE OUT OF LIST SPACE
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)  ;LIST OF NILS SETS UP CDR CODES
	((C-PDL-BUFFER-POINTER-PUSH)	;EVENTUAL VALUE
		Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CLOSURE)))
	((M-S) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CALL-XCT-NEXT QRAR1)			;(RPLACA <CLOSURE-BLOCK> <FCTN>)
       ((M-T) M-J)				;FCTN
	((C-PDL-BUFFER-POINTER-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE)	;STEP FILLING POINTER
XBINS1	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
;0(IP) - POINTER TO BINDING INSTANCE BLOCK BEING FILLED IN
;-1(IP)- VALUE TO RETURN EVENTUALLY.
;-2(IP)- LIST OF VARS TO CLOSE OVER.
XCLOS4	(JUMP-EQUAL M-T A-V-NIL XCLOSX)		;LIST OF SYMS TO CLOSE IN M-T
	(CALL QCAR)
	(DISPATCH Q-DATA-TYPE M-T TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL M-T NIL)
	((M-S) C-PDL-BUFFER-POINTER-POP)	;FILLING POINTER  (IN POSITION FOR RPLACA)
	((M-T) DPB M-T Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	(CALL-XCT-NEXT QRAR1)
       ((M-T C-PDL-BUFFER-POINTER-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE)
					;POINTER TO INTERNAL VALUE CELL
					;M-T GETS LOCATION FILLED.
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)	;READ INTERNAL VALUE CELL
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE) ;BUMP FILLING POINTER
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-1) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER)) 
			XCLOS3A)	;XFER ON EXTERNAL VALUE CELL ALREADY EXISTS
	((C-PDL-BUFFER-POINTER-PUSH) VMA)	;SAVE POINTER TO INTERNAL VALUE CELL
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;SAVE INTERNAL VALUE CELL CONTENTS
	(CALL-XCT-NEXT LCONS-D)			;ALLOCATE EXT VAL CELL IN LIST SPACE
       ((M-B) (A-CONSTANT 1))
	((VMA M-T) Q-POINTER M-T		;ADDRESS OF NEW EXTERNAL V-C
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER)))
	((WRITE-MEMORY-DATA-START-WRITE)
		DPB C-PDL-BUFFER-POINTER Q-TYPED-POINTER  ;V-C CONTENTS
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(CHECK-PAGE-WRITE)
	((WRITE-MEMORY-DATA) SELECTIVE-DEPOSIT C-PDL-BUFFER-POINTER-POP 
		Q-ALL-BUT-TYPED-POINTER A-T)
	((VMA-START-WRITE) C-PDL-BUFFER-POINTER-POP)	;WRITE INTO INTERNAL V-C
	(CHECK-PAGE-WRITE)
XCLOS3	((M-T) DPB M-T Q-POINTER       ;TO AVOID PROFUSION OF RANDOM D.T.S.  AVOIDS LOSSAGE
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) ;WITH CAR IN QCLS1
					;QCLS1 CHANGES BACK TO DTP-EXT-V-C EVENTUALLY
	(CALL-XCT-NEXT QRAR1)				;FORWARDING PNTR IN M-T
       ((M-S) C-PDL-BUFFER-POINTER-POP)			;GET BACK FILL POINTER
	((C-PDL-BUFFER-POINTER-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE)   ;BUMP FILL POINTER
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))	;BUMP VARS POINTER
	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
		;PDL-BUFFER-INDEX NOT SAVED ACROSS SEQUENCE BREAKS
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
	(JUMP-XCT-NEXT XCLOS4)
       ((C-PDL-BUFFER-INDEX) M-T)

XCLOS3A	(JUMP-XCT-NEXT XCLOS3)
       ((M-T) READ-MEMORY-DATA)		;POINTER TO EXTERNAL V-C

XCLOSX	((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)	;FLUSH FILLING POINTER
	(POPJ-AFTER-NEXT 
	 (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)	;FLUSH CLOSURE-LIST

;;; Some support for instances

XFUNCTION-INSIDE-SELF (MISC-INST-ENTRY %FUNCTION-INSIDE-SELF)
	((M-T) A-SELF)
	((M-TEM) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE)) XFIS-I)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ENTITY)) XFIS-C)
	(POPJ-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-CLOSURE)))	;Default is to return self
XFIS-C	(JUMP-XCT-NEXT QCAR4)			;Get function of closure
      ;((VMA-START-READ) M-T)
XFIS-I	((VMA-START-READ) M-T)			;Get instance header
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	(JUMP-XCT-NEXT QCAR4)
       ((VMA-START-READ) ADD MD (A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-FUNCTION)))

XINSTANCE-REF (MISC-INST-ENTRY %INSTANCE-REF)
	(JUMP-XCT-NEXT QCAR3)
       (CALL XINSTANCE-LOC)

XINSTANCE-SET (MISC-INST-ENTRY %INSTANCE-SET)
	(CALL XINSTANCE-LOC)
		(ERROR-TABLE CALLS-SUB %INSTANCE-SET)
	((M-S) M-T)
	(JUMP-XCT-NEXT QRAR3)
       ((M-T) C-PDL-BUFFER-POINTER-POP)

XINSTANCE-LOC (MISC-INST-ENTRY %INSTANCE-LOC)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;Index
		(ERROR-TABLE RESTART XINSTANCE-LOC)
	((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-POINTER)	;Instance
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE)) TRAP)
		(ERROR-TABLE ARGTYP INSTANCE PP 0 XINSTANCE-LOC %INSTANCE-LOC)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)	;Get instance header
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE-HEADER)) TRAP)
		(ERROR-TABLE DATA-TYPE-SCREWUP DTP-INSTANCE-HEADER)
	((M-T) VMA)					;Possibly-forwarded instance
	((VMA-START-READ) ADD MD (A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-SIZE)))
	(CHECK-PAGE-READ)
	(CALL-EQUAL M-1 A-ZERO TRAP)			;Don't access the header!
		(ERROR-TABLE ARGTYP PLUSP M-1 1 NIL %INSTANCE-LOC)
	((M-2) Q-POINTER READ-MEMORY-DATA)		;Size of instance
	(CALL-GREATER-OR-EQUAL M-1 A-2 TRAP)
		(ERROR-TABLE SUBSCRIPT-OOB M-1 M-2)
	(POPJ-AFTER-NEXT (M-T) ADD M-T A-1)
       ((M-T) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	    
;;; MULTIPLY SUBROUTINE
;M-1 TIMES Q-R, RESULT TO Q-R, LEAVES CORRECT HIGH HALF IN M-2.
;CALLER MUST CHECK FOR OVERFLOW, IF SHE CARES.

MPY	((M-2) MULTIPLY-STEP A-1 M-ZERO)
(REPEAT 30. ((M-2) MULTIPLY-STEP M-2 A-1))
	(POPJ-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) Q-R)
       ((M-2) MULTIPLY-STEP M-2 A-1)
	(POPJ-AFTER-NEXT
	 (M-2) M-2 SUB A-1)		;FINAGLE IF NEGATIVE VALUE INITIALLY IN Q-R
       (NO-OP)

;;; DIVIDE SUBROUTINE
;   DIVIDEND IN M-1, DIVISOR IN M-2
;   QUOTIENT IN Q-R, REMAINDER IN M-1, CLOBBERS A-TEM1

DIV	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO DIV1)
       ((A-TEM1 Q-R) M-1)	;Q GETS MAGNITUDE OF DIVIDEND, A-TEM1 SAVES ORIGINAL
	((Q-R) SUB M-ZERO A-TEM1)
DIV1	((M-1) DIVIDE-FIRST-STEP M-ZERO A-2)
DIV1A	(CALL-IF-BIT-SET (BYTE-FIELD 1 0) Q-R TRAP)	;DIVIDE OVERFLOW
  (ERROR-TABLE DIVIDE-BY-ZERO)
(REPEAT 31. ((M-1) DIVIDE-STEP M-1 A-2))
	((M-1) DIVIDE-LAST-STEP M-1 A-2)
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-ZERO A-TEM1 DIV2) ;JUMP IF POSITIVE DIVIDEND
       ((M-1) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2) ;M-1 GETS MAGNITUDE OF REMAINDER
	((M-1) SUB M-ZERO A-1)		;NEGATIVE DIVIDEND => NEGATIVE REMAINDER
DIV2	((A-TEM1) XOR M-2 A-TEM1)	;IF SIGNS OF DIVIDEND AND DIVISOR ARE DIFFERENT,
	(POPJ-LESS-OR-EQUAL M-ZERO A-TEM1)
	(POPJ-AFTER-NEXT
	 (A-TEM1) Q-R)
       ((Q-R) SUB M-ZERO A-TEM1)	;THEN QUOTIENT IS NEGATIVE

;%ARGS-INFO <FUNCTION>   FUNCTION CAN BE ANYTHING MEANINGFUL IN
;FUNCTION CONTEXT. RETURNS FIXNUM.  FIELDS AS IN NUMERIC-ARG-DESC-INFO IN QCOM.

XARGI (MISC-INST-ENTRY %ARGS-INFO)
	((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
;ENTER HERE FROM APPLY, ALSO REENTER TO TRY AGAIN (CLOSURE, ETC).
XARGI0	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-S XARGI-DISPATCH)  ;INHIBIT-XCT-NEXT UNLESS
       ((M-T) (A-CONSTANT (PLUS (PLUS 			    ; INTERPRETER TRAP
 		(BYTE-VALUE Q-DATA-TYPE DTP-FIX) 
		(BYTE-MASK %%ARG-DESC-INTERPRETED))
		(BYTE-MASK %%ARG-DESC-MAX-ARGS))))

XAGISG	(POPJ-AFTER-NEXT				;STACK GROUP ACCEPTS ANY NUMBER
	 (M-T) DPB (M-CONSTANT -1) (LISP-BYTE %%ARG-DESC-MAX-ARGS)	;OF EVALED ARGS
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

XAGUE1	((VMA-START-READ) ADD M-S A-V-MICRO-CODE-ENTRY-AREA)
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XAGUE3)  ;NOT MICROCODED NOW.
	(JUMP-XCT-NEXT XAGUE2)				    ;UCODE-ENTRY
       ((VMA-START-READ) ADD M-S A-V-MICRO-CODE-ENTRY-ARGS-INFO-AREA)

XAGICL	(CALL-XCT-NEXT QCAR)				    ;CLOSURE
       ((M-T) Q-POINTER M-S		 ;REPLACE BY CAR OF IT AND TRY AGAIN.
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(JUMP-XCT-NEXT XARGI0)
       ((M-S) M-T)

XAGAR1	((VMA-START-READ) M-S)			;ARRAY-POINTER
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT 
	 (M-T)
	  (LISP-BYTE %%ARRAY-NUMBER-DIMENSIONS)
	 	 READ-MEMORY-DATA
		 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((M-T) DPB M-T (LISP-BYTE %%ARG-DESC-MIN-ARGS) A-T)  ;COPY INTO BOTH MAX AND MIN

XAGM1	((VMA-START-READ) ADD
		 M-S (A-CONSTANT (EVAL %FEFHI-FAST-ARG-OPT)));MACRO-COMPILED
XAGUE2	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)

XARGI3	((VMA-START-READ) ADD M-S (A-CONSTANT 2))	;SYM, REPLACE W FCTN CELL
	(CHECK-PAGE-READ)
XAGUE3	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(JUMP-XCT-NEXT XARGI0)
       ((M-S) Q-TYPED-POINTER READ-MEMORY-DATA)

XOMR (MISC-INST-ENTRY %P-CONTENTS-OFFSET)
	(CALL XOMR0)				;READ THE SPECIFIED LOCATION
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT READ-MEMORY-DATA)
       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)	;RETURN ITS CONTENTS

XOMR0	((M-B) C-PDL-BUFFER-POINTER-POP)	;GET THE OFFSET
	((VMA-START-READ M-C) C-PDL-BUFFER-POINTER-POP)	;READ THE HEADER WORD
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)	;FOLLOW FORWARDING PTR
	(POPJ-AFTER-NEXT
	 (VMA-START-READ) ADD VMA A-B)		;NOW REFERENCE THE SPECIFIED LOCATION
       (CHECK-PAGE-READ)			;VMA COULD BE POINTING INTO UNFORWARDED DATA

XOMS  (MISC-INST-ENTRY %P-STORE-CONTENTS-OFFSET)
	(CALL XOMR0)				;READ THE SPECIFIED LOCATION, SET VMA
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT READ-MEMORY-DATA 
		Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

;%MAKE-POINTER-OFFSET <new data type> <pointer> <offset> returns a pointer whose pointer
;   is (+ (%POINTER <pointer>) <offset>) and whose data type is <new data type>.  No data
;   type checks.
XMOP (MISC-INST-ENTRY %MAKE-POINTER-OFFSET)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT
		(M-T) ADD C-PDL-BUFFER-POINTER-POP A-T)
       ((M-T) DPB Q-DATA-TYPE C-PDL-BUFFER-POINTER-POP A-T)

;;; %STORE-CONDITIONAL pointer, old-val, new-val
;;; This is protected against interrupts, provided that the value you
;;; are storing does not point at the EXTRA-PDL, and that the location
;;; is guaranteed never to contain a pointer to old-space (i.e. it
;;; only points to static areas.)  This is always protected against
;;; sequence breaks (other macrocode processes).
XSTACQ (MISC-INST-ENTRY %STORE-CONDITIONAL) ;args are pointer, old-val, new-val
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;new
	((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;old
;Won't interrupt between reading out the data here
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP) ;pntr
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	((M-1) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-B A-1 XFALSE)		;Return NIL if old-val was wrong
	((WRITE-MEMORY-DATA-START-WRITE)	;Otherwise, store new-val
		SELECTIVE-DEPOSIT
		READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-A)
;and writing the replacement data here
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) A-V-TRUE)

XSFP (MISC-INST-ENTRY %STACK-FRAME-POINTER)
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-AP)
	(POPJ-AFTER-NEXT (M-T) M-K)
       (NO-OP)

XGCD (MISC-INST-ENTRY INTERNAL-\\)		;GCD, STEIN'S ALGORITHM.
	(CALL-XCT-NEXT GET-FIX-OR-BIGNUM)	; SET UP FOR GCD'S BY GETTING 2 ARGS
       ((M-A) M-ZERO)				;THIS IS MAGIC INDEX ON TYPES OF ARGUMENTS
	(DISPATCH (BYTE-FIELD 2 0) M-A GCD-DISPATCH)

(LOCALITY D-MEM)
(START-DISPATCH 2)
GCD-DISPATCH
	(P-BIT R-BIT)		;FIXNUM-FIXNUM CASE (DROPS THROUGH)
	(INHIBIT-XCT-NEXT-BIT GCD-FIX-BIG)	;FIXNUM-BIGNUM CASE
	(INHIBIT-XCT-NEXT-BIT GCD-BIG-FIX)	;BIGNUM-FIXNUM CASE
	(INHIBIT-XCT-NEXT-BIT GCD-BIG-BIG)	;BIGNUM-BIGNUM CASE
(END-DISPATCH)
(LOCALITY I-MEM)

;;; DROP THROUGH ON FIX-FIX CASE (ARGUMENTS IN M-1 M-2)
GCD-FIX-FIX
	((M-A Q-R) (A-CONSTANT (OA-LOW-CONTEXT ((BYTE-FIELD 32. 0)))))
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO XGCD0)	;TAKE ABS OF ARGS
	((M-1) SUB M-ZERO A-1)
XGCD0	(JUMP-GREATER-OR-EQUAL M-2 A-ZERO XGCDL)
	((M-2) SUB M-ZERO A-2)
XGCDL	(JUMP-EQUAL M-2 A-ZERO XGCD5)
	(JUMP-GREATER-THAN M-1 A-2 XGCD1)
	((M-TEM) M-1)		;EXCHANGE ARGS SO M-1 IS THE BIGGER
	((M-1) M-2)
	((M-2) M-TEM)
XGCD1	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-1 XGCD2)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-2 XGCD3)
	((M-A) SUB M-A (A-CONSTANT 37))			;BOTH EVEN
							;ADD1 TO ROTATE FIELD, SUB1 FROM LENGTH
        ((M-2) M-2 OUTPUT-SELECTOR-RIGHTSHIFT-1)
XGCD3	(JUMP-XCT-NEXT XGCDL)				;M-1 EVEN
       ((M-1) M-1 OUTPUT-SELECTOR-RIGHTSHIFT-1)

XGCD2	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) M-2 XGCD4)
	(JUMP-XCT-NEXT XGCDL)				;M-2 EVEN
       ((M-2) M-2 OUTPUT-SELECTOR-RIGHTSHIFT-1)

XGCD4	((M-TEM) M-2)		;BOTH ODD
	((M-2) SUB M-1 A-2)
	(JUMP-XCT-NEXT XGCDL)
       ((M-1) M-TEM)

XGCD5	((OA-REG-LOW) M-A)		;Final shifting step
	((M-1) DPB M-1 (BYTE-FIELD 0 0) A-ZERO)
	(JUMP RETURN-M-1)

;;; GCD IS SYMMETRICAL (BIGNUM IN M-B, FIXNUM IN M-2)
;;; THIS DEPENDS ON REMAINDER-BIG-FIX NOT SMASHING M-2 AND LEAVING RESULT IN M-1
;;; SO THAT WE CAN CALL GCD-FIX-FIX IMMEDIATELY
;;;If you want you can call GCD-BIG-FIX-1 with the length of the bignum in M-C
;;; and the sign bit in the low order bit of M-A. Note that GCD-BIG-FIX-1 doesn't handle
;;; the case with a fixnum 0!
GCD-BIG-FIX 
GCD-FIX-BIG
	(JUMP-EQUAL M-2 A-ZERO GCD-IS-ABS-M-B)
	((M-C) BIGNUM-HEADER-LENGTH MD)
	((M-A) BIGNUM-HEADER-SIGN MD)
GCD-BIG-FIX-1
GCD-FIX-BIG-1 
	(JUMP-XCT-NEXT GCD-FIX-FIX)		;DO A FIXNUM FIXNUM GCD,
       (CALL REMAINDER-BIG-FIX-1)		;BUT FIRST GET (\ BIGNUM FIXNUM)

GCD-IS-ABS-M-B
	((M-I) BIGNUM-HEADER-LENGTH MD)
	(JUMP-XCT-NEXT BIGNUM-ABS)
       ((M-Q) M-B)

;;;We get here with a bignum in M-B and a bignum in M-C with its header in MD
;;; M-T also has the same thing in it as M-B
GCD-BIG-BIG
	((M-E) HEADER-REST-FIELD MD)
	((VMA-START-READ) M-B)
	(CHECK-PAGE-READ)
	((M-J) BIGNUM-HEADER-LENGTH M-E)
	((M-I) BIGNUM-HEADER-LENGTH MD)
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-I A-J GCDBB-1)
       ((M-D) HEADER-REST-FIELD MD)
	((M-J) BIGNUM-HEADER-LENGTH M-D)
	((M-I) BIGNUM-HEADER-LENGTH M-E)
	((M-D) M-E)
	((M-B) M-C)
	((M-C) M-T)	;Remember M-T and M-B start with the same thing.
GCDBB-1
	(JUMP-GREATER-THAN M-J (A-CONSTANT 1) GCDBB-LONG)
	;; since M-J = 1 we can use Bignum-Fixnum case.
	((VMA-START-READ) ADD M-C (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-2) MD)
	((M-C) BIGNUM-HEADER-LENGTH M-D)
	((M-A) BIGNUM-HEADER-SIGN M-D)
	;;First do (\ bignum fixnum). REMAINDER-BIG-FIX must leave answer in
	;;M-1 and not bash M-2.
	(JUMP-XCT-NEXT GCD-FIX-FIX)
       (CALL REMAINDER-BIG-FIX-1)

;;;When we get here we have the longer bignum in M-B,M-I shorter in M-C,M-J
;;; So M-I and M-J are both 2 or more.
;;;To make this work BDIV-REMAINDER-COMMON must not touch the contents of M-C
GCDBB-LONG 
	((M-Q) M-B)
	((M-R) M-C)		;saved by BDIV-REMAINDER-COMMON
	(CALL-XCT-NEXT BDIV-REMAINDER-COMMON)
       ((M-A) A-ZERO)		;indicate quotient is not being saved.
	;; Now we have a bignum in M-Q,(M-I + 1) that is the remainder
	;;shifted left by an amount determined by M-D. M-C,M-J contains
	;;the bignum we were dividing by.
	;; We are going to pretend from now on that the bignum in
	;;M-Q is only M-J long.
	((M-T) M-C)
	((M-K) ADD M-I (A-CONSTANT 2))		;(length of bignum in M-Q) + 1
	;;Now shift down the bignum in M-Q
	((M-C) M-Q)
	(CALL-XCT-NEXT GCDBB-SHIFT)
       ((M-S) M-Q)
	(JUMP-NOT-EQUAL-XCT-NEXT M-E A-ZERO GCDBB-NO-LUCK)
       ((M-C) M-T)
	((M-1) M-Q)
	((M-Q) A-V-NIL)				;Possible pointer to garbage.
	((M-S) A-V-NIL)				;Possible pointer to garbage.
        (JUMP-XCT-NEXT UN-CONS)
       ((M-2) M-K)				;saved just for the occasion.

GCDBB-NO-LUCK
	;;Figure out how much it was shifted:
	((M-TEM) DPB M-3 (BYTE-FIELD 27. 5.) A-ZERO)
	((M-TEM) SUB M-TEM A-3)
	((M-TEM) ADD M-TEM A-4)
	((M-TEM) SUB M-TEM (A-CONSTANT 31.))
	((M-D) ADD M-TEM A-D)	;M-D had 31. - (the number of extra zeros that
				;BDIV-REMAINDER-COMMON introduced) .
	(CALL-XCT-NEXT SCONS-T)
       ((M-B) ADD M-J (A-CONSTANT 1))
	((MD) ADD M-J (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-R) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE)
       	(CALL-XCT-NEXT GCDBB-SHIFT)
       ((M-S) M-R)		;Prepare to call GCDBB-SHIFT
	;;M-TEM gets the number of factors of two in the bignum in M-R.
	((M-TEM) DPB M-3 (BYTE-FIELD 27. 5.) A-ZERO)
	((M-TEM) SUB M-TEM A-3)
	((M-TEM) ADD M-TEM A-4)
	;;M-D gets the power of two in the answer:
	(JUMP-LESS-THAN M-D A-TEM GCDBB-4)
       	((M-D) M-TEM)
GCDBB-4
	((M-T) M-Q)		;This one will be the answer
	((M-K) M-J)		;This is its length

;;;We get here with two odd bignums in M-Q and M-R, their actual length is in M-K,
;;; the one to return as answer is also in M-T, the number of powers of 2 in the
;;; answer is in M-D, M-J contains the length of the bignums that might still be nonzero.
GCDBB-LOOP
	((M-I) M-J)		;Step down the bignums
GCDBB-L1
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-2) MD)
	((VMA-START-READ) ADD M-R A-I)
	(CHECK-PAGE-READ)
;	(JUMP-EQUAL-XCT-NEXT M-I (A-CONSTANT 1) GCD-FIX-FIX) ;something like this
;      ((M-1) MD)						;should be done.
	(JUMP-NOT-EQUAL-XCT-NEXT M-2 A-ZERO GCDBB-SUB)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(JUMP-NOT-EQUAL MD A-ZERO GCDBB-ORDER)
	(JUMP-XCT-NEXT GCDBB-L1)
       ((M-J) M-I)

GCDBB-SUB-L
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-2) MD)
	((VMA-START-READ) ADD M-R A-I)
	(CHECK-PAGE-READ)
       	((M-I) SUB M-I (A-CONSTANT 1))
GCDBB-SUB
	(JUMP-GREATER-THAN MD A-2 GCDBB-ORDER)
	(JUMP-LESS-THAN MD A-2 GCDBB-NORDER)
	(JUMP-GREATER-THAN M-I A-ZERO GCDBB-SUB-L)

;;;Here we are done, the answer is in M-T, although it might have to be trimmed and shifted.
;;; There is a bignum to give back in M-Q or M-R.
	(JUMP-EQUAL-XCT-NEXT M-R A-T GCDBB-GIVE-BACK-M-Q)
       ((M-2) ADD M-K (A-CONSTANT 1))	;This is how much to give back
	((M-Q) M-R)
	((M-R) A-V-NIL)				;Possible pointer to garbage.
GCDBB-GIVE-BACK-M-Q
       	((M-1) Q-POINTER M-Q)
	((M-S) A-V-NIL)				;Possible pointer to garbage.
	(CALL-XCT-NEXT UN-CONS)
       ((M-Q) A-V-NIL)				;Possible pointer to garbage.
	((M-1) M-D)
	(CALL-XCT-NEXT DIV)
       ((M-2) (A-CONSTANT 31.))
       	(JUMP-EQUAL-XCT-NEXT M-1 A-ZERO GCDBB-COPY-WORDS)
       ((M-E) Q-R)		;This is the offset we want
	((M-I) M-K)		;Real length (sig. length in M-J)
	((M-B) M-T)				;From
	((M-D) M-T)				;To
	;;Constant for LDB (M-K):
	((M-K) ADD M-1 (A-CONSTANT 1))		;MROT   = M-1 + 1
	((M-TEM) SUB M-1 (A-CONSTANT 1))	;BYTL-1 = M-1 + 1
	((M-K) DPB M-TEM OAL-BYTL-1 A-K)
	;;Constant for DPB (M-S):
	((M-TEM) (A-CONSTANT 30.))
	((M-TEM) SUB M-TEM A-1)			;BYTL-1 = 30. - M-1
	((M-S) DPB M-TEM OAL-BYTL-1 A-1)	;MROT   = M-1
	((M-ZR) SUB M-I A-E)			;Read first word from here.
	((VMA-START-READ) ADD M-D A-ZR)
	(CHECK-PAGE-READ)
	((OA-REG-LOW) M-S)
	((M-2) DPB MD (BYTE-FIELD 0 0) A-ZERO)
	(CALL-XCT-NEXT BDIV-NORMALIZE)
       ((M-ZR) SUB M-ZR (A-CONSTANT 1))
GCDBB-RETURN
	;;Cleanup Bignum in M-Q (Have to reread header to get actual length!)
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	((M-D) BIGNUM-HEADER-LENGTH MD)
	((M-C) M-D)
	(JUMP-XCT-NEXT ARY-TO-BIG-CLEANUP)
       ((M-E) M-D)

GCDBB-COPY-WORDS
	(JUMP-EQUAL M-E A-ZERO GCDBB-RETURN)
	((M-A) M-K)				;Move words to here,
	((M-B) SUB M-A A-E)			;from here.
GCDBB-COPY-WORDS-1
	((VMA-START-READ) ADD M-T A-B)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE) ADD M-T A-A)
	(CHECK-PAGE-WRITE)
	((M-A) SUB M-A (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-B (A-CONSTANT 1) GCDBB-COPY-WORDS-1)
       ((M-B) SUB M-B (A-CONSTANT 1))
	((MD) A-ZERO)
GCDBB-COPY-WORDS-2
	((VMA-START-WRITE) ADD M-T A-A)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-A (A-CONSTANT 1) GCDBB-COPY-WORDS-2)
       ((M-A) SUB M-A (A-CONSTANT 1))
	(JUMP GCDBB-RETURN)

GCDBB-NORDER
	((M-TEM) M-Q)
	((M-Q) M-R)
	((M-R) M-TEM)
GCDBB-ORDER
	((M-ZR) (A-CONSTANT 1))	;steps (up) thru bignums
	((M-C) A-ZERO)		;borrow from last round
	((M-S) M-R)		;we subtract into this guy
	((M-E) A-ZERO)		;For BIGNUM-RIGHT-JUST
GCDBB-STUFF
	((VMA-START-READ) ADD M-Q A-ZR)
	(CHECK-PAGE-READ)
	((M-2) ADD MD A-C)	;remember to borrow
	((VMA-START-READ) ADD M-R A-ZR)
	(CHECK-PAGE-READ)
	((M-2) SUB MD A-2)
	((M-C) (BYTE-FIELD 1 31.) M-2 A-ZERO)
	(CALL-XCT-NEXT BIGNUM-RIGHT-JUST)
       ((M-2) (BYTE-FIELD 31. 0) M-2 A-ZERO)
	(JUMP-LESS-THAN-XCT-NEXT M-ZR A-J GCDBB-STUFF)
       ((M-ZR) ADD M-ZR (A-CONSTANT 1))
	(CALL-XCT-NEXT BIGNUM-RIGHT-JUST)	;Flush last bits.
       ((M-2) A-ZERO)
	(JUMP-GREATER-THAN M-E A-J GCDBB-LOOP)
GCDBB-STUFF-1
	((MD) A-ZERO)
	((VMA-START-WRITE) ADD M-S A-E)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-E A-J GCDBB-STUFF-1)
       ((M-E) ADD M-E (A-CONSTANT 1))
	(JUMP GCDBB-LOOP)

;;;Right justify a bignum in M-C into a bignum in M-S (M-J contains the length for both.)
;;; M-I steps through M-C and BIGNUM-RIGHT-JUST is used.
;;;In case M-C contains all zeros M-E will contain 0 instead of M-J + 1.
GCDBB-SHIFT
	((M-E) A-ZERO)
	((M-3) A-MINUS-ONE)
	((M-I) (A-CONSTANT 1))	;step thru bignum in M-C
GCDBB-2
	((VMA-START-READ) ADD M-C A-I)
	(CHECK-PAGE-READ)
	(CALL-XCT-NEXT BIGNUM-RIGHT-JUST)
       ((M-2) MD)
	(JUMP-LESS-THAN-XCT-NEXT M-I A-J GCDBB-2)
       ((M-I) ADD M-I (A-CONSTANT 1))
	(CALL-XCT-NEXT BIGNUM-RIGHT-JUST)	;Flush last bits
       ((M-2) A-ZERO)
	(POPJ-GREATER-THAN M-E A-J)
	(POPJ-EQUAL M-E A-ZERO)			;M-C was all zeros!
	((MD) A-ZERO)
GCDBB-3
	((VMA-START-WRITE) ADD M-S A-E)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-E A-J GCDBB-3)
       ((M-E) ADD M-E (A-CONSTANT 1))
	(POPJ)

;;;This takes a stream of 31. bit words and right justifies it
;;; into the bignum in M-S. You hand words in in M-2.
;;; After each call M-E "points" to the location about to be stored into or 0
;;; if no ones have been found, M-3 is the number of 31. bit words of zeros skipped,
;;; M-4 is the number of bits skipped mod 31. M-A and M-B are used for internal
;;; constants for ldbing and dpbing. Temporary things are kept in M-1 as well
;;; Inits: ((M-E) A-ZERO)	;flags that no 1s have been found.
;;;	   ((M-3) A-MINUS-ONE)	;Actually init to anything you want, it will be
;;;				; incremented N+1 times.
BIGNUM-RIGHT-JUST
	(JUMP-EQUAL M-E A-ZERO BIGNUM-RIGHT-JUST-FFO)
	(JUMP-EQUAL M-4 A-ZERO BIGNUM-RIGHT-JUST-PUNT)
	((OA-REG-LOW) M-A)
	((MD) DPB M-2 (BYTE-FIELD 0 0) A-1)
	((VMA-START-WRITE) ADD M-S A-E)
	(CHECK-PAGE-WRITE)
	((OA-REG-LOW) M-B)
	(POPJ-AFTER-NEXT (M-1) (BYTE-FIELD 0 0) M-2 A-ZERO)
       ((M-E) ADD M-E (A-CONSTANT 1))

BIGNUM-RIGHT-JUST-PUNT
	((MD) M-1)
	((VMA-START-WRITE) ADD M-S A-E)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT (M-1) M-2)
       ((M-E) ADD M-E (A-CONSTANT 1))

BIGNUM-RIGHT-JUST-FFO
	(POPJ-EQUAL-XCT-NEXT M-2 A-ZERO)
       ((M-3) ADD M-3 (A-CONSTANT 1))
	((M-E) (A-CONSTANT 1))
	((M-4) A-MINUS-ONE)
	((M-2) DPB M-2 (BYTE-FIELD 31. 1) A-ZERO)
BIGNUM-RIGHT-JUST-FFO-1
	((M-2) (BYTE-FIELD 31. 1) M-2 A-ZERO)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-2 BIGNUM-RIGHT-JUST-FFO-1)
       ((M-4) ADD M-4 (A-CONSTANT 1))
	((M-1) M-2)
	;;Now for DPB (M-A) we need BYTL-1 = M-4 - 1   and MROT = 31. - M-4
	;;and for LDB (M-B) we need BYTL-1 = 30. - M-4 and MROT = 32. - M-4
	((M-TEM) (A-CONSTANT 30.))
	((M-TEM) SUB M-TEM A-4)
	((M-A) ADD M-TEM (A-CONSTANT 1))
	((M-B) ADD M-TEM (A-CONSTANT 2))
	((M-B) DPB M-TEM OAL-BYTL-1 A-B)
	(POPJ-AFTER-NEXT (M-TEM) SUB M-4 (A-CONSTANT 1))
       ((M-A) DPB M-TEM OAL-BYTL-1 A-A)

XREM (MISC-INST-ENTRY \)
	(CALL-XCT-NEXT GET-FIX-OR-BIGNUM)
       ((M-A) M-ZERO)
	(DISPATCH (BYTE-FIELD 2 0) M-A REMAINDER-DISPATCH)
;;; DROP THROUGH ON FIX-FIX CASE
REMAINDER-FIX-FIX
	(CALL DIV)
XREM1	(POPJ-AFTER-NEXT
	 (M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

(LOCALITY D-MEM)
(START-DISPATCH 2)
REMAINDER-DISPATCH
	(P-BIT R-BIT)		;FIXNUM-FIXNUM CASE (DROPS THROUGH)
	(INHIBIT-XCT-NEXT-BIT REMAINDER-FIX-BIG)	;FIXNUM-BIGNUM CASE
	(INHIBIT-XCT-NEXT-BIT REMAINDER-BIG-FIX)	;BIGNUM-FIXNUM CASE
	(INHIBIT-XCT-NEXT-BIT REMAINDER-BIG-BIG)	;BIGNUM-BIGNUM CASE
(END-DISPATCH)
(LOCALITY I-MEM)

;;; THE VALUE IS ALWAYS THE FIXNUM EXCEPT WHEN THE FIXNUM IS "SETZ" AND THE BIGNUM IS
;;; POSITIVE "SETZ", IN WHICH CASE THE ANSWER IS 0 (THIS DEPENDS ON THE HEADER FOR THE
;;; BIGNUM BEING IN MD)
REMAINDER-FIX-BIG
	(POPJ-NOT-EQUAL-XCT-NEXT M-2 (A-CONSTANT NEGATIVE-SETZ))
       ((M-T) M-C)			;RESULT IS THE FIXNUM, USUALLY
	((M-1) BIGNUM-HEADER-LENGTH MD)	;GET THE LENGTH OF THE BIGNUM
	(POPJ-NOT-EQUAL M-1 (A-CONSTANT 1))
	((VMA-START-READ) ADD M-B (A-CONSTANT 1))	;READ THE BIGNUM
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT
	  POPJ-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ))
       ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;RESULT IS 0

;;; HERE THE BIGNUM IS IN M-B, FIXNUM IN M-2
;;; M-1 IS USED FOR ACCUMULATOR M-B IS THE POINTER TO THE
;;; BIGNUM, M-C IS THE LOOP COUNTER (INITED WITH THE LENGTH OF THE BIGNUM) (ALSO OFFSET)
;;; M-A IS THE SIGN BIT OF THE BIGNUM
;;; REMAINDER MUST BE LEFT IN M-1 FOR THE SAKE OF GCD-BIG-FIX AND REMAINDER-BIG-BIG
;;;People will want to call REMAINDER-BIG-FIX-1 with a fixnum in M-2 a bignum in M-B
;;; its length in M-C and sign bit in the low bit of M-A. REMAINDER-BIG-FIX-1 Doesn't
;;; work if the fixnum is 0! (You must deal with that yourself.)
REMAINDER-BIG-FIX
	(JUMP-EQUAL M-2 A-ZERO RETURN-M-B)
	((M-C) BIGNUM-HEADER-LENGTH MD)
	((M-A) BIGNUM-HEADER-SIGN MD)
REMAINDER-BIG-FIX-1
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO REM-BIG-FIX-LOOP)
       ((M-1) SETZ)
	((M-2) SUB M-ZERO A-2)		;TAKE ABS OF DIVISOR
REM-BIG-FIX-LOOP
	((VMA-START-READ) ADD M-B A-C)
	(CHECK-PAGE-READ)
	((A-TEM1) SETZ)			;IMPLICIT ARGUMENT TO DIV1A
	((M-TEM) DPB M-1 (BYTE-FIELD 1 31.) A-ZERO)
	((Q-R) ADD MD A-TEM)
	(JUMP-IF-BIT-SET-XCT-NEXT (BYTE-FIELD 1 31.) M-TEM REM-BIG-FIX-OVFL)
       ((M-1) (BYTE-FIELD 31. 1) M-1)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 31.) Q-R REM-BIG-FIX-OVFL)
	((M-1) ADD M-1 (A-CONSTANT 1))
;;; HERE M-1,,Q-R HAVE (M-1)*1_31.+MD
REM-BIG-FIX-OVFL
	(CALL-XCT-NEXT DIV1A)
       ((M-1) DIVIDE-FIRST-STEP M-1 A-2)
	(JUMP-NOT-EQUAL-XCT-NEXT M-C (A-CONSTANT 1) REM-BIG-FIX-LOOP)
       ((M-C) SUB M-C (A-CONSTANT 1))
	(POPJ-EQUAL-XCT-NEXT M-A A-ZERO)	;POPJ IF DIVIDEND POSITIVE
       ((M-T) DPB Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-AFTER-NEXT (M-1) SUB M-ZERO A-1)
       ((M-T) DPB Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

RETURN-M-B
 	(POPJ-AFTER-NEXT (M-T) M-B)
       (NO-OP)

;;; RETURNS IN M-A BITS SAYING WHAT THE TWO ARGUMENTS ARE (FOR \ AND \\)
;;; IN FIXNUM-FIXNUM CASE RETURNS M-A UNCHANGED (0) AND FIXNUMS IN M-1 AND M-2 (SECOND)
;;; IN THE BIGNUM-FIXNUM AND FIXNUM-BIGNUM CASE, IT RETURNS THE FIXNUM IN M-2 AND THE
;;; BIGNUM IN M-B. IN THE BIGNUM-BIGNUM CASE, IT RETURNS THE BIGNUMS IN M-B AND M-C
;;; IN ANY CASE M-T IS THE SECOND ARGUMENT, M-C IS THE FIRST
GET-FIX-OR-BIGNUM
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-1) SELECTIVE-DEPOSIT M-T Q-DATA-TYPE A-ZERO)
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
			GET-ANY-BIG)
       ((M-C) C-PDL-BUFFER-POINTER-POP)
	((OA-REG-HIGH) BOXED-SIGN-BIT M-T)		;SIGN EXTEND (MUNG M SOURCE)
	((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)
	((M-1) SELECTIVE-DEPOSIT M-C Q-DATA-TYPE A-ZERO)
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) GET-BIG-FIX)
	(POPJ-AFTER-NEXT
	 (OA-REG-HIGH) BOXED-SIGN-BIT M-C)		;SIGN EXTEND (MUNG M SOURCE)
       ((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-C)
GET-FIX-ANY
	(POPJ-AFTER-NEXT
	 (OA-REG-HIGH) BOXED-SIGN-BIT M-C)		;SIGN EXTEND (MUNG M SOURCE)
       ((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-C)

GET-BIG-FIX
	((M-A) (A-CONSTANT 2))
	((VMA-START-READ M-I) M-C)
	(CALL ASSURE-BIGNUM)
    (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	(POPJ-AFTER-NEXT
	 (M-C) M-I)
       ((M-B) M-I)

GET-ANY-BIG
	((M-A) (A-CONSTANT 1))
	((VMA-START-READ M-I) M-T)
	(CALL ASSURE-BIGNUM)
    (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	((M-T) M-I)
	((M-1) SELECTIVE-DEPOSIT M-C Q-DATA-TYPE A-ZERO)
	(JUMP-EQUAL-XCT-NEXT M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
			GET-FIX-ANY)
       ((M-B) M-T)		;THIS IS THE SECOND ARGUMENT BIGNUM
;;; HERE THEY ARE BIG-BIG
	((M-A) (A-CONSTANT 3))
	((VMA-START-READ M-I) M-C)
	(CALL ASSURE-BIGNUM)
    (ERROR-TABLE ARG-POPPED 0 M-C M-T)
	(POPJ-AFTER-NEXT
	 (M-C) M-I)
	(NO-OP)

;;; ASSURES THAT THE HEADER NOW BEING READ INTO MD POINTS TO A LEGAL BIGNUM HEADER
;;; VMA AND M-I CONTAIN POINTER TO THE BIGNUM
ASSURE-BIGNUM
	((M-TEM) Q-DATA-TYPE M-I)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) TRAP)
		(ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-I NIL)
	(CHECK-PAGE-READ)			;CHECK FOR PAGE FAULTS
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-I) VMA)		;get transported number address 
	((M-TEM) SELECTIVE-DEPOSIT MD HEADER-TYPE-FIELD A-ZERO)
	(POPJ-EQUAL M-TEM (A-CONSTANT (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM)))
	(CALL TRAP)
		(ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-I NIL)

;;; Takes a fixnum or bignum argument on the stack and returns the low-order 32
;;; bits of it in M-1.  Bashes M-I, M-J only.
GET-32-BITS
	((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-POINTER)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) FXUNPK-P-1)
	((VMA-START-READ M-I) C-PDL-BUFFER-POINTER-POP)
	(CALL ASSURE-BIGNUM)
	((M-I) BIGNUM-HEADER-LENGTH MD)
	((M-J) BIGNUM-HEADER-SIGN MD)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;Low-order word
	(CHECK-PAGE-READ)
	(JUMP-LESS-THAN-XCT-NEXT M-I (A-CONSTANT 2) GET-32-BITS-1)
       ((M-1) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-1) DPB READ-MEMORY-DATA (BYTE-FIELD 1 31.) A-1)
GET-32-BITS-1
	(POPJ-AFTER-NEXT POPJ-EQUAL M-J A-ZERO)	
       ((M-1) SUB M-ZERO A-1)				;Negative

;;; Operations on 24-bit unsigned quantities.

;TEMPORARY DOUBLE PRECISION KLUDGE.  DOESN'T CHECK FOR OVERFLOW (PRESUMABLY CAN'T ANYWAY!)
XMUL-FRACTIONS (MISC-INST-ENTRY %MULTIPLY-FRACTIONS)
	(CALL FXGTPP)
   (ERROR-TABLE CALLS-SUB %MULTIPLY-FRACTIONS)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-2)
	(POPJ-AFTER-NEXT
	 (M-T) (BYTE-FIELD 8 24.) Q-R (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((M-T) DPB M-2 (BYTE-FIELD 16. 8) A-T)

;SPECIAL NON-OVERFLOW-CHECKING FUNCTIONS FOR WEIRD HACKS
X24ADD (MISC-INST-ENTRY %24-BIT-PLUS)
	(CALL FXGTPP)
   (ERROR-TABLE CALLS-SUB %24-BIT-PLUS)
	(POPJ-AFTER-NEXT (M-1) ADD M-1 A-2)
       ((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

X24SUB (MISC-INST-ENTRY %24-BIT-DIFFERENCE)
	(CALL FXGTPP)
   (ERROR-TABLE CALLS-SUB %24-BIT-DIFFERENCE)
	(POPJ-AFTER-NEXT (M-1) SUB M-1 A-2)
       ((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

X24MUL (MISC-INST-ENTRY %24-BIT-TIMES)
	(CALL FXGTPP)
    (ERROR-TABLE CALLS-SUB %24-BIT-TIMES)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-2)
	(POPJ-AFTER-NEXT (M-T) DPB Q-R Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

XDIV-DOUBLE (MISC-INST-ENTRY %DIVIDE-DOUBLE)
	(CALL XDIVD1)					;CALL DOUBLE PRECISION DIVIDE
	(POPJ-AFTER-NEXT 		;DIVIDE CAN'T OVERFLOW
	 (M-T) DPB Q-R Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

XREM-DOUBLE (MISC-INST-ENTRY %REMAINDER-DOUBLE)
	(JUMP-XCT-NEXT XREM1)
       (CALL XDIVD1)					;CALL DOUBLE PRECISION DIVIDE

;DOUBLE PRECISION DIVIDE.  ARGS ON PDL ARE DIVIDEND HIGH, DIVIDEND LOW, DIVISOR
XDIVD1	(CALL FXGTPP)					;M-1 GETS DIVIDEND LOW, M-2 DIVISOR
	((M-A) M-1)					;SAVE DIVIDEND LOW
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;GET DIVIDEND HIGH.
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0)
    (ERROR-TABLE ARG-POPPED 0 PP M-A M-2)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	((OA-REG-HIGH) BOXED-SIGN-BIT M-T)		;SIGN EXTEND (MUNG M SOURCE)
	((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)
	((M-TEM) DPB M-1 (BYTE-FIELD 8 24.) A-A)	;LOW WORD HAS 32 BITS
	((M-A) (BYTE-FIELD 24. 8) M-1 A-1)		;ARITH SHIFT M-1 RIGHT 8 FOR HIGH WORD
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO XDIVD3)	;MAKE DIVIDEND POSITIVE
	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO XDIVD2)	;DOUBLE PRECISION NEGATE M-A,,M-TEM
       ((M-TEM) SUB M-ZERO A-TEM)
	((M-A) SUB M-A (A-CONSTANT 1))			;BORROW IF LOW WORD IS ZERO
XDIVD2	((M-A) SETCM M-A)				;ONES COMPLEMENT HIGH WORD
XDIVD3	;DIVIDEND IS IN M-A (HIGH), M-TEM (LOW), DIVISOR IS IN M-2
	((A-TEM1) M-1)	;ORIGINAL SIGN OF DIVIDEND IS IN SIGN(A-TEM1) FOR DIVIDE
	((Q-R) M-TEM)					;LOW DIVIDEND TO Q-R FOR DIVIDE
	(JUMP-XCT-NEXT DIV1A)				;JOIN NORMAL DIVIDE ROUTINE
       ((M-1) DIVIDE-FIRST-STEP M-A A-2)		;BUT WITH DIFFERENT FIRST STEP

;;; ARITHMETIC MICROCODE.

;Generic operations save away one of these codes to indicate the operation to
;be performed, and then jump to routines that think about types and unpacking.
(ASSIGN ARITH-1ARG-ABS 0)
(ASSIGN ARITH-1ARG-MINUS 1)
(ASSIGN ARITH-1ARG-ZEROP 2)
(ASSIGN ARITH-1ARG-PLUSP 3)
(ASSIGN ARITH-1ARG-MINUSP 4)
(ASSIGN ARITH-1ARG-ADD1 5)
(ASSIGN ARITH-1ARG-SUB1 6)
(ASSIGN ARITH-1ARG-FIX 7)
(ASSIGN ARITH-1ARG-FLOAT 10)
(ASSIGN ARITH-1ARG-SMALL-FLOAT 11)
(ASSIGN ARITH-1ARG-HAULONG 12)
(ASSIGN ARITH-1ARG-LDB 13)	;DEALS WITH 2ND ARG ONLY.
(ASSIGN ARITH-1ARG-DPB 14)	;DEALS WITH 3RD ARG ONLY.
(ASSIGN ARITH-1ARG-ASH 15)
(ASSIGN ARITH-1ARG-ODDP 16)
(ASSIGN ARITH-1ARG-EVENP 17)
;HAIPART?
(ASSIGN NUM-UNUSED-ARITH-1ARGS 0)

(ASSIGN ARITH-2ARG-ADD 0)
(ASSIGN ARITH-2ARG-SUB 1)
(ASSIGN ARITH-2ARG-MUL 2)
(ASSIGN ARITH-2ARG-DIV 3)
(ASSIGN ARITH-2ARG-EQUAL 4)
(ASSIGN ARITH-2ARG-GREATERP 5)
(ASSIGN ARITH-2ARG-LESSP 6)
(ASSIGN ARITH-2ARG-MIN 7)
(ASSIGN ARITH-2ARG-MAX 10)
(ASSIGN ARITH-2ARG-BOOLE 11)
(ASSIGN NUM-UNUSED-ARITH-2ARGS 6)
;REMAINDER, EXPT?

;These codes are used to save the type of the first numeric argument in dyadic
;operations, so that the routines for handling various types of second arguments
;can dispatch on them.
(ASSIGN NUMBER-CODE-FIXNUM 0)
(ASSIGN NUMBER-CODE-SMALL-FLONUM 1)
(ASSIGN NUMBER-CODE-FLONUM 2)
(ASSIGN NUMBER-CODE-BIGNUM 3)
(ASSIGN NUM-UNUSED-NUMBER-CODES 4)

;This is the format of all DTP-HEADER words.
(DEF-DATA-FIELD HEADER-TYPE-FIELD 5 19.)
(DEF-DATA-FIELD HEADER-REST-FIELD 19. 0)
(ASSIGN NUM-UNUSED-HEADER-TYPES 24.)

;This is how flonums are stored in a header, and how to convert from internal
;form (see below) back into flonum form.
(DEF-DATA-FIELD HEADER-FLONUM-EXPONENT 11. 8.)
(DEF-DATA-FIELD HEADER-FLONUM-HIGH-MANTISSA 8. 0)
(DEF-DATA-FIELD FLONUM-HEADER-HIGH-MANTISSA 8. 24.)
(DEF-DATA-FIELD FLONUM-HEADER-LOW-MANTISSA 24. 0)

;Small-flonum definitions.  These are inums, with a DTP-SMALL-FLONUM data type,
;a 7-bit excess-100 exponent (10^-19 to 10^+19 approximately), and a
;17-bit 2's complement normalized mantissa (5 digits approximately).  The
;sign bit is elided since it is always the complement of the high bit of
;the mantissa, except for zero, which is represented as an all-zero exponent
;and mantissa.

(DEF-DATA-FIELD SMALL-FLONUM-EXPONENT 7 17.)	;The exponent in a small-flonum
(ASSIGN SMALL-FLONUM-EXPONENT-OFFSET 1700)	;To convert from excess-100 to excess-2000
(ASSIGN SMALL-FLONUM-MAX-EXPONENT 177)		;Largest value that fits in exponent field
(DEF-DATA-FIELD FLONUM-SMALL-MANTISSA-FIELD 17. 14.) ;DPB here to put into low-level form
(DEF-DATA-FIELD FLONUM-SMALL-USELESS-BITS 14. 0) ;Low-order discarded bits of mantissa
(DEF-DATA-FIELD FLONUM-SMALL-ROUND-BIT 1 13.)	;Highest discarded bit
(DEF-DATA-FIELD FLONUM-SMALL-GUARD-BITS 13. 0)	;The remaining discarded bits
(DEF-DATA-FIELD FLONUM-SMALL-MANTISSA-LOW-BIT 1 14.)
(DEF-DATA-FIELD SMALL-FLONUM-MANTISSA-HIGH-BIT 1 16.)

;Both flonums and small flonums are converted to an internal
;format, on which the subrouines FADD, FSUB, FMPY, FDIV, etc. work.
;Those routines are also intended to be useful for hairier functions
;such as series expansions when written in microcode.

;These routines operate on numbers which consist of a 32-bit
;normalized 2's complement mantissa in M-1 or M-2 and an excess-2000
;exponent in M-I or M-J.  The binary point is just to the right
;of the sign (bit 31).  The range of mantissas is
;1/2 <= f < 1, -1/2 > f >= -1, except for zero which has a zero
;mantissa and a zero exponent.  All results are normalized and
;properly rounded, and returned in M-1 and M-I.  Overflow and underflow
;are not detected at this level, which is a feature.  Fuzz is not
;hacked.  Rounding is towards even if the discarded bits = exactly 1/2 lsb.

;Definitions for low-level form

(DEF-DATA-FIELD FLONUM-SIGN-BIT 1 31.)
(DEF-DATA-FIELD MANTISSA-HIGH-BIT 1 30.)
(ASSIGN FLONUM-EXPONENT-EXCESS 2000)	;The exponent is excess-2000.
(DEF-DATA-FIELD SIGN-BIT-AND-MANTISSA-HIGH-THREE 4 28.)
(DEF-DATA-FIELD SIGN-BIT-AND-MANTISSA-HIGH-TWO 3 29.)
(DEF-DATA-FIELD SIGN-BIT-AND-MANTISSA-HIGH-BIT 2 30.)

;;; Packing and unpacking fixnums.

FXUNPK-P-1
	((M-1) C-PDL-BUFFER-POINTER-POP)
SIGN-EXTEND-M-1
	(POPJ-AFTER-NEXT 
		(OA-REG-HIGH) BOXED-SIGN-BIT M-1)
       ((M-1) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-1)

FXUNPK-T-2
	(POPJ-AFTER-NEXT 
		(OA-REG-HIGH) BOXED-SIGN-BIT M-T)
       ((M-2) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-T)

;;; Come to one of these to return a fixnum in M-1.
;;; Checks for fixnum overflow, and adds data type DTP-FIX.
;;; Result goes to M-T, and FIXPACK-P also pushes it on the PDL.

;;; Return the number in M-1 as either a fixnum or a bignum depending on its magnitude
;;; Returns it via M-T
RETURN-M-1
	(JUMP-LESS-THAN M-1 (A-CONSTANT NEGATIVE-SETZ) FIX-OVERFLOW-1)
	(JUMP-GREATER-OR-EQUAL M-1 (A-CONSTANT POSITIVE-SETZ) FIX-OVERFLOW-1)
	;drop into FIXPACK-T

;;; Return it via M-T checking only for single-bit overflow
FIXPACK-T
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 0) 
		(BYTE-FIELD 2 23.) M-1 D-FXOVCK)
       ((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;;; Return it via pdl checking only for single-bit overflow
FIXPACK-P
	(DISPATCH-POPJ-XCT-NEXT (I-ARG 1) 
		(BYTE-FIELD 2 23.) M-1 D-FXOVCK)
       ((C-PDL-BUFFER-POINTER-PUSH M-T) DPB M-1 Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
(LOCALITY D-MEM)
;DISPATCH TABLE FOR CHECKING FOR SINGLE-BIT ADD/SUBTRACT-TYPE FIXNUM OVERFLOW
;ON VALUE WHICH IS UNBOXED IN M-1.  DISPATCH ON SIGN BIT AND LOW DATA TYPE BIT.
;I-ARG SHOULD BE 0 IF RESULT ONLY TO M-T, OR 1 IF ALSO TO PDL.  
;IN ANY CASE, DOES ESSENTIALLY POPJ-XCT-NEXT.
;NEXT SHOULD BE INSTRUCTION TO BOX M-1 AS A FIXNUM.
(START-DISPATCH 2 0)
D-FXOVCK	
	(R-BIT)					 ;BITS AGREE NO OVERFLOW
	(FIX-OVERFLOW INHIBIT-XCT-NEXT-BIT)	 ;DISAGREE => OVERFLOW
	(FIX-OVERFLOW INHIBIT-XCT-NEXT-BIT)	 ;DISAGREE => OVERFLOW
	(R-BIT)					 ;BITS AGREE NO OVERFLOW
(END-DISPATCH)
(LOCALITY I-MEM)

;;; This is called from the fixnum packing routines. M-1 contains a unboxed number
;;; IARG is 0 if the result is to go only to M-T, and 1 if it should also go to the
;;; PDL
FIX-OVERFLOW
	(JUMP-EQUAL READ-I-ARG A-ZERO FIX-OVERFLOW-1)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
FIX-OVERFLOW-1	;Enter directly here with unboxed number in M-1.  Returns bignum in M-T.
	((M-C) M-ZERO)				;sign bit
	(JUMP-GREATER-THAN-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE)
       ((M-2) M-ZERO)
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-1) SUB M-ZERO A-1)

;;; These return here before returning a value. This puts value from M-T
;;; also on stack for those that need it
M-T-TO-CPDL
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) 
       (NO-OP)

;;; This is called from the fixnum multiply. M-2 contains the high product
;;; and M-1 the low product. Result is to go to the PDL and M-T.
FIX-2-WORD-OVERFLOW
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO OVERFLOW-BIGNUM-CREATE)
       ((M-C) M-ZERO)				;sign bit
	((M-1) SUB M-ZERO A-1)
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-2) M-A-1 M-ZERO A-2)		;ONE'S COMPLEMENT
	((M-2) ADD M-2 (A-CONSTANT 1))	;CARRY FROM LOW TO HIGH WORD
					;DROPS THROUGH
;;; M-2,,M-1 HAS A 64 BIT POSITIVE NUMBER THAT IS A MAX OF 47 BITS OF PRECISION
;;; M-C GETS THE SIGN BIT
;;; M-J GETS LENGTH OF BIGNUM
OVERFLOW-BIGNUM-CREATE-NEGATIVE
	((M-C) SELECTIVE-DEPOSIT M-MINUS-ONE BIGNUM-HEADER-SIGN A-ZERO)
OVERFLOW-BIGNUM-CREATE
	;; We need a 2-word bignum if non-zero bits above the low 31. 
	(JUMP-NOT-EQUAL-XCT-NEXT M-2 A-ZERO OVERFLOW-BIGNUM-CREATE-1)
       ((M-J) (A-CONSTANT 2))
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 31.) M-1 OVERFLOW-BIGNUM-CREATE-1)
	((M-J) (A-CONSTANT 1))
OVERFLOW-BIGNUM-CREATE-1
	(CALL-XCT-NEXT BNCONS)			;Cons up a bignum
       ((M-B) ADD M-J (A-CONSTANT 1))
	((VMA) ADD M-T (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) (BYTE-FIELD 31. 0) M-1)  ;Low 31. bits
	(CHECK-PAGE-WRITE)
	(POPJ-EQUAL M-J (A-CONSTANT 1))
	((M-TEM) (BYTE-FIELD 1 31.) M-1)
	((VMA) ADD VMA (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-2 (BYTE-FIELD 31. 1) A-TEM)
	(CHECK-PAGE-WRITE)
	(POPJ) ;NO POPJ-AFTER-NEXT, MAY BE RETURNING TO MAIN-LOOP

;;; Packing and unpacking small flonums.

;Unpack from C-PDL-BUFFER-POINTER-POP into M-1 and M-I.
SFLUNPK-P-1
	((M-I) SMALL-FLONUM-EXPONENT C-PDL-BUFFER-POINTER)
	(POPJ-EQUAL-XCT-NEXT M-I A-ZERO FLZERO)		;zero exponent => this is 0.0
       ((M-1) DPB C-PDL-BUFFER-POINTER-POP FLONUM-SMALL-MANTISSA-FIELD A-ZERO)
	((M-I) ADD M-I (A-CONSTANT SMALL-FLONUM-EXPONENT-OFFSET))
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET MANTISSA-HIGH-BIT M-1)
       ((M-1) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-1)  ;negative => set sign bit

;Unpack from M-T into M-2 and M-J.
SFLUNPK-T-2
	((M-J) SMALL-FLONUM-EXPONENT M-T)
	(POPJ-EQUAL-XCT-NEXT M-J A-ZERO)	;zero exponent => this is 0.0
       ((M-2) DPB M-T FLONUM-SMALL-MANTISSA-FIELD A-ZERO)
	((M-J) ADD M-J (A-CONSTANT SMALL-FLONUM-EXPONENT-OFFSET))
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET SMALL-FLONUM-MANTISSA-HIGH-BIT M-T)
       ((M-2) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-2)

;Pack from M-1 and M-I into C-PDL-BUFFER-POINTER-PUSH and M-T, rounding.
SFLPACK-P
	(JUMP-IF-BIT-CLEAR FLONUM-SMALL-ROUND-BIT M-1 SFLPCK1)	;Jump if no rounding required
	((M-T) FLONUM-SMALL-GUARD-BITS M-1)	;Discarded fraction exactly 1/2 lsb?
	(JUMP-NOT-EQUAL M-T A-ZERO SFLPCK0)	;No, round.
	(JUMP-IF-BIT-CLEAR FLONUM-SMALL-MANTISSA-LOW-BIT M-1 SFLPCK1) ;Yes, round towards even.
SFLPCK0	(CALL-XCT-NEXT FRND1)			;Round and renormalize (may bring in two
       ((M-1) ADD M-1 (A-CONSTANT (BYTE-MASK FLONUM-SMALL-ROUND-BIT))	; garbage bits from Q)
		OUTPUT-SELECTOR-RIGHTSHIFT-1)
SFLPCK1	((M-1) DPB M-ZERO FLONUM-SMALL-USELESS-BITS A-1) ;clear low-order bits so can test zero
	(POPJ-EQUAL-XCT-NEXT M-1 A-ZERO)	;Special case 0.0, which has 0 in exponent
       ((M-T C-PDL-BUFFER-POINTER-PUSH) 	;Store mantissa and data-type fields
		FLONUM-SMALL-MANTISSA-FIELD M-1
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SMALL-FLONUM)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
	((M-I) SUB M-I (A-CONSTANT SMALL-FLONUM-EXPONENT-OFFSET))
	(JUMP-LESS-OR-EQUAL M-I A-ZERO SFL-E-UND)	;Underflow.  ZUNDERFLOW?
	(POPJ-AFTER-NEXT
	 (M-T C-PDL-BUFFER-POINTER) DPB M-I SMALL-FLONUM-EXPONENT A-T)
       (CALL-GREATER-THAN M-I (A-CONSTANT SMALL-FLONUM-MAX-EXPONENT) SFL-E-OV) ;Overflow

SFL-E-UND
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-ZUNDERFLOW)
	(CALL-EQUAL M-TEM A-V-NIL TRAP)
	    (ERROR-TABLE FLOATING-EXPONENT-UNDERFLOW SFL)
	(POPJ-AFTER-NEXT				;Return 0.0s0 instead or if continued
	 (M-T C-PDL-BUFFER-POINTER)
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SMALL-FLONUM)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
       (NO-OP)

SFL-E-OV (CALL TRAP)
   (ERROR-TABLE FLOATING-EXPONENT-OVERFLOW SFL)

;Pack from M-1 and M-I into M-T, rounding.
SFLPACK-T
	(CALL SFLPACK-P)
POP-PP-J
	(POPJ-AFTER-NEXT (M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
       (NO-OP)

;;; Packing flonums.

;;; Note: the code to unpack flonums only exists at ARITH-FLO-ANY
;;; and ARITH-ANY-FLO, and is written there.  There is also GET-FLONUM,
;;; a general routine which is not used by the normal arithmetic path. 

;;; Take a flonum in M-1/M-I, and return a DTP-EXTENDED-NUMBER to it.
FLOPACK-T
	(CALL FLOPACK)
	(POPJ)  ;May be returning to main loop, can't popj and start-write together

FLOPACK-P
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-STACK)))
FLOPACK	(CALL-LESS-OR-EQUAL M-I A-ZERO FLOPACK-UNDERFLOW)
 	(CALL-GREATER-OR-EQUAL M-I (A-CONSTANT 4000) TRAP)
	    (ERROR-TABLE FLOATING-EXPONENT-OVERFLOW FLO)
	(CALL-XCT-NEXT SCONS-T)
       ((M-B) (A-CONSTANT 2))
	((VMA) ADD M-T (A-CONSTANT 1))		;Write the second word
	((MD-START-WRITE)
		FLONUM-HEADER-LOW-MANTISSA M-1
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
				  (BYTE-VALUE Q-CDR-CODE CDR-NIL))))
	(CHECK-PAGE-WRITE)
	((M-TEM) FLONUM-HEADER-HIGH-MANTISSA M-1
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
				  (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
				  (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-FLONUM))))
	((VMA M-T) Q-POINTER M-T
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(POPJ-AFTER-NEXT (MD-START-WRITE) DPB M-I HEADER-FLONUM-EXPONENT A-TEM)
       (CHECK-PAGE-WRITE)
	
FLOPACK-UNDERFLOW
	(POPJ-EQUAL M-1 A-ZERO)		;0.0 case: M-I has zero, don't trap
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-ZUNDERFLOW)
	(CALL-EQUAL M-TEM A-V-NIL TRAP)
	    (ERROR-TABLE FLOATING-EXPONENT-UNDERFLOW FLO)
	(POPJ-AFTER-NEXT (M-I) A-ZERO)	;Return 0.0 instead
       ((M-1) A-ZERO)

;;; Given something on stack, return a flonum unpacked into M-I and M-1, doing coercions.
;;; Clobbers only M-T (inside FLOAT-A-BIGNUM)
GET-FLONUM  (ERROR-TABLE RESTART GET-FLONUM)
	((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-POINTER)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) GET-FLONUM-1)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) HEADER-TYPE-FIELD READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM)) GET-FLONUM-2)
	((M-I) HEADER-FLONUM-EXPONENT READ-MEMORY-DATA)
	((M-1) DPB READ-MEMORY-DATA FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT NO-OP)
       ((M-1) SELECTIVE-DEPOSIT READ-MEMORY-DATA FLONUM-HEADER-LOW-MANTISSA A-1)

GET-FLONUM-1
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SMALL-FLONUM)) SFLUNPK-P-1)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) TRAP)
	    (ERROR-TABLE ARGTYP NUMBER PP T GET-FLONUM)
	(CALL-XCT-NEXT FXUNPK-P-1)
       ((M-I) (A-CONSTANT 2036))
	(JUMP-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)

GET-FLONUM-2
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)) ILLOP) ;unknown type?
	((C-PDL-BUFFER-POINTER-PUSH) M-Q)
	((C-PDL-BUFFER-POINTER-PUSH) M-C)
	((C-PDL-BUFFER-POINTER-PUSH) M-K)
	((M-Q) VMA)
	((M-C) Q-POINTER READ-MEMORY-DATA)
	((M-I) BIGNUM-HEADER-LENGTH M-C)
	(CALL FLOAT-A-BIGNUM)
	((M-K) C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT (M-C) C-PDL-BUFFER-POINTER-POP)
       ((M-Q) C-PDL-BUFFER-POINTER-POP)

;;; Simple one-argument operations.

XABS (MISC-INST-ENTRY ABS) (ERROR-TABLE RESTART XABS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XABS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ABS))
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO FIXPACK-T)
	(JUMP-XCT-NEXT FIXPACK-T)
       ((M-1) SUB M-ZERO A-1)

XMINUS (MISC-INST-ENTRY MINUS) (ERROR-TABLE RESTART XMINUS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XMINUS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-MINUS))
	(JUMP-XCT-NEXT FIXPACK-T)
       ((M-1) SUB M-ZERO A-1)

XZEROP (MISC-INST-ENTRY ZEROP) (ERROR-TABLE RESTART XZEROP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XZEROP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ZEROP))
FLONUM-ZEROP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-EQUAL M-1 A-ZERO)
       ((M-T) A-V-NIL)

XPLUSP (MISC-INST-ENTRY PLUSP) (ERROR-TABLE RESTART XPLUSP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XPLUSP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-PLUSP))
FLONUM-PLUSP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-GREATER-THAN M-1 A-ZERO)
       ((M-T) A-V-NIL)

XMINUSP (MISC-INST-ENTRY MINUSP) (ERROR-TABLE RESTART XMINUSP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XMINUSP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-MINUSP))
FLONUM-MINUSP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-LESS-THAN M-1 A-ZERO)
       ((M-T) A-V-NIL)

XODDP (MISC-INST-ENTRY ODDP) (ERROR-TABLE RESTART XODDP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XODDP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ODDP))
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET (BYTE-FIELD 1 0) M-1)
       ((M-T) A-V-NIL)

XEVENP (MISC-INST-ENTRY EVENP) (ERROR-TABLE RESTART XEVENP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XEVENP)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-EVENP))
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-1)
       ((M-T) A-V-NIL)

X1PLS (MISC-INST-ENTRY 1+) ;ADD1 GETS FSET TO THIS
	    (ERROR-TABLE RESTART X1PLS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T X1PLS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-ADD1))
	(JUMP-XCT-NEXT FIXPACK-T)
       ((M-1) ADD M-1 (A-CONSTANT 1))

X1MNS (MISC-INST-ENTRY 1-) ;SUB1 GETS FSET TO THIS
	    (ERROR-TABLE RESTART X1MNS)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T X1MNS)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-SUB1))
	(JUMP-XCT-NEXT FIXPACK-T)
       ((M-1) SUB M-1 (A-CONSTANT 1))

XFIX (MISC-INST-ENTRY FIX) (ERROR-TABLE RESTART XFIX)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XFIX)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-FIX))
	(JUMP FIXPACK-T)

XFLOAT (MISC-INST-ENTRY FLOAT) (ERROR-TABLE RESTART XFLOAT)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XFLOAT)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-FLOAT))
	((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	(JUMP FLOPACK-T)

XSMALL-FLOAT (MISC-INST-ENTRY SMALL-FLOAT) (ERROR-TABLE RESTART XSMALL-FLOAT)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XSMALL-FLOAT)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-SMALL-FLOAT))
	((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	(JUMP SFLPACK-T)

XHAUL (MISC-INST-ENTRY HAULONG)	;TAKES ONE ARG, RETURNS # SIGNIFICANT BITS
	    (ERROR-TABLE RESTART XHAUL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)
    (ERROR-TABLE ARGTYP NUMBER PP T XHAUL)
    (ERROR-TABLE ARG-POPPED 0 PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-HAULONG))
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO XHAUL1)
       ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-1) SUB M-ZERO A-1)
XHAUL1	(POPJ-EQUAL M-1 A-ZERO)
	((M-T) ADD M-T (A-CONSTANT 1))
	(JUMP-XCT-NEXT XHAUL1)
       ((M-1) (BYTE-FIELD 31. 1) M-1)		;SHIFT RIGHT

XHAULFLO (CALL FLOPACK-P)	;HAULONG or LDB of a flonum.  Argument is unpacked.
	(CALL TRAP)		;Repack and hope don't mind if SFL became FLO in the process.
	    (ERROR-TABLE ARGTYP INTEGER PP T)

;;; Simple two-argument operations.

;;; Generic addition.
XMADD (MISC-INST-ENTRY M-+)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTCADD  ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POP-PP-J)))	;MC-LINKAGE
QIADD		(ERROR-TABLE RESTART QIADD)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIADD)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-ADD))
		(ERROR-TABLE RESTART QIADD0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIADD0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	(JUMP-XCT-NEXT FIXPACK-P)
       ((M-1) ADD M-1 A-2)

;;; Generic subtraction.
XMSUB (MISC-INST-ENTRY M--)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTCSUB	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POP-PP-J)))	;MC-LINKAGE
QISUB		(ERROR-TABLE RESTART QISUB)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QISUB)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-SUB))
		(ERROR-TABLE RESTART QISUB0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QISUB0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	(JUMP-XCT-NEXT FIXPACK-P)
       ((M-1) SUB M-1 A-2)

;;; Generic multiplication.
XMMUL (MISC-INST-ENTRY M-*)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTCMUL	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POP-PP-J)))	;MC-LINKAGE
QIMUL		(ERROR-TABLE RESTART QIMUL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIMUL)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-MUL))
		(ERROR-TABLE RESTART QIMUL0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIMUL0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	(CALL-XCT-NEXT MPY)	;LOW PRODUCT TO Q-R, HIGH TO M-2
       ((Q-R) M-2)
	((M-TEM) SELECTIVE-DEPOSIT Q-R (BYTE-FIELD 9 23.) A-2)	;DISCARDED BITS AND SIGN
	(JUMP-EQUAL-XCT-NEXT M-TEM A-ZERO FIXPACK-P)   ;JUMP IF NON-OVERFLOWING POSITIVE RESULT
       ((M-1) Q-POINTER Q-R A-TEM)		     ;SIGN EXTEND (IF NON-OVERFLOWING)
	(JUMP-EQUAL M-TEM (A-CONSTANT -1) FIXPACK-P)   ;JUMP IF NON-OVERFLOWING NEGATIVE
	(JUMP-XCT-NEXT FIX-2-WORD-OVERFLOW)
       ((M-1) Q-R)

;;; Generic division.
XMDIV (MISC-INST-ENTRY M-//)
	((M-T) C-PDL-BUFFER-POINTER-POP)
XTCDIV	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC POP-PP-J)))	;MC-LINKAGE
QIDIV		(ERROR-TABLE RESTART QIDIV)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIDIV)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-DIV))
		(ERROR-TABLE RESTART QIDIV0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIDIV0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	(CALL DIV)
	(JUMP-XCT-NEXT FIXPACK-P)	;DIVIDE CAN'T OVERFLOW EXCEPT FOR SETZ/-1
       ((M-1) Q-R)

;;; Generic numeric equality (the "=" function).
XMEQL (MISC-INST-ENTRY M-=)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMEQL					    ;MC-LINKAGE
QIEQL		(ERROR-TABLE RESTART QIEQL)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIEQL)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL))
		(ERROR-TABLE RESTART QIEQL0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIEQL0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-NOT-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

;;; Generic numeric GREATERP
XMGRTH (MISC-INST-ENTRY M->)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMGRP					     ;MC-LINKAGE
QIGRP		(ERROR-TABLE RESTART QIGRP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QIGRP)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-GREATERP))
		(ERROR-TABLE RESTART QIGRP0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QIGRP0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-LESS-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

;;; Generic numeric LESSP
XMLESS (MISC-INST-ENTRY M-<)
	((M-T) C-PDL-BUFFER-POINTER-POP)
QMLSP					      ;MC-LINKAGE
QILSP		(ERROR-TABLE RESTART QILSP)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 QILSP)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-LESSP))
		(ERROR-TABLE RESTART QILSP0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 QILSP0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

XMAX (MISC-INST-ENTRY *MAX)
	((M-T) C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART XMAX)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 XMAX)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-MAX))
		(ERROR-TABLE RESTART XMAX0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 XMAX0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	(JUMP-GREATER-OR-EQUAL M-1 A-2 FIXPACK-T)
	(JUMP-XCT-NEXT FIXPACK-T)
       ((M-1) A-2)

XMIN (MISC-INST-ENTRY *MIN)
	((M-T) C-PDL-BUFFER-POINTER-POP)
		(ERROR-TABLE RESTART XMIN)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP NUMBER PP 0 XMIN)
    (ERROR-TABLE ARG-POPPED 0 PP M-T)
       ((M-A) (A-CONSTANT ARITH-2ARG-MIN))
		(ERROR-TABLE RESTART XMIN0)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 XMIN0)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
	(JUMP-LESS-OR-EQUAL M-1 A-2 FIXPACK-T)
	(JUMP-XCT-NEXT FIXPACK-T)
       ((M-1) A-2)

;;; String processing

XCHAR-EQUAL (MISC-INST-ENTRY CHAR-EQUAL)
	(CALL FXGTPP)
	((M-1) (LISP-BYTE %%CH-CHAR) M-1)	;Flush font or bucky bits
	((M-2) (LISP-BYTE %%CH-CHAR) M-2)
XCHAR-EQUAL-1-2 ;Enter here with LDB'ed arguments in M-1, M-2
	(JUMP-EQUAL M-1 A-2 XTRUE)		;Equal if really equal
	((M-T) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON)
	(JUMP-NOT-EQUAL M-T A-V-NIL XFALSE)	;Certainly not equal if case matters
	((M-TEM) XOR M-1 A-2)			;Differ only in case bit?
	(POPJ-NOT-EQUAL M-TEM (A-CONSTANT 40))	;If not, not equal
	(POPJ-LESS-THAN M-1 (A-CONSTANT 101))	;And not equal if not a letter
	(POPJ-GREATER-THAN M-1 (A-CONSTANT 172))
	(JUMP-LESS-OR-EQUAL M-1 (A-CONSTANT 132) XTRUE)
	(JUMP-GREATER-OR-EQUAL M-1 (A-CONSTANT 141) XTRUE)
	(POPJ)

;;;??? LOSES LIKE AR-1.

XSTRING-SEARCH (MISC-INST-ENTRY %STRING-SEARCH-CHAR)
		;Arguments are character, array, start index, end index
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 3)
	((M-C) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	((M-I) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
	(JUMP-GREATER-OR-EQUAL M-I A-C XSTRING-SEARCH-9)
	(CALL XAR1)				;Set up M-Q, M-S, M-B, M-E, & get first char
    (ERROR-TABLE CALLS-SUB %STRING-SEARCH-CHAR)
    (ERROR-TABLE ARG-POPPED 0 PP PP PP M-C)
	((M-1) (LISP-BYTE %%CH-CHAR) C-PDL-BUFFER-POINTER-POP)
	(JUMP-GREATER-THAN M-1 (A-CONSTANT 172) XSTRING-SEARCH-3)
	(JUMP-LESS-THAN M-1 (A-CONSTANT 101) XSTRING-SEARCH-3)
;M-I initial subscript, M-C initial upper bound
;M-Q subscript, M-S upper bound after array-indirect
;M-1 character searching for, M-B array type, M-E array data base
;The loop is 27-32 cycles per character.  It could be bummed to be better
;but this is still much faster than macrocode.
XSTRING-SEARCH-1
	(CALL-XCT-NEXT XCHAR-EQUAL-1-2)
       ((M-2) (LISP-BYTE %%CH-CHAR) M-T)
	(JUMP-EQUAL-XCT-NEXT M-T A-V-TRUE XSTRING-SEARCH-4)	;Return if found it
       ((M-I) ADD M-I (A-CONSTANT 1))		;Advance subscripts
	((M-Q) ADD M-Q (A-CONSTANT 1))
	(JUMP-GREATER-OR-EQUAL M-I A-C XFALSE)	;Reached upper bound, return NIL
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)
    (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
	(DISPATCH-CALL-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B ARRAY-TYPE-REF-DISPATCH)
       (NO-OP)
	(JUMP XSTRING-SEARCH-1)

;;; This loop is for when we are not searching for a letter.
;;; Time is reduced to 17 cycles per character.
XSTRING-SEARCH-2
	(JUMP-GREATER-OR-EQUAL M-I A-C XFALSE)	;Reached upper bound, return NIL
	(CALL-GREATER-OR-EQUAL M-Q A-S TRAP)
    (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
	(DISPATCH-CALL-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B ARRAY-TYPE-REF-DISPATCH)
XSTRING-SEARCH-3
       ((M-I) ADD M-I (A-CONSTANT 1))
	((M-2) (LISP-BYTE %%CH-CHAR) M-T)
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-2 XSTRING-SEARCH-2)
       ((M-Q) ADD M-Q (A-CONSTANT 1))
;Found it.  Return the index before array-indirect, which has been incremented past.
XSTRING-SEARCH-4
	(POPJ-AFTER-NEXT NO-OP)
       ((M-T) SUB M-I (A-CONSTANT 1))

XSTRING-SEARCH-9 ;Here when start index not less than end index.  Avoid array bounds error.
	(POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 3))
       ((M-T) A-V-NIL)				;Flush arguments and return NIL

XSTRING-EQUAL (MISC-INST-ENTRY %STRING-EQUAL)
	;Arguments are the two strings (which must really be strings),
	;the two starting indices (which must be fixnums), and the
	;number of characters to compare.  If this count is a fixnum, it
	;is the number of characters to compare; if this runs off the end
	;of either string, they are not equal (no subscript-oob error occurs).
	;However, it won't work to have the starting-index greater than the
	;the length of the array (it is allowed to be equal).
	;If this count is NIL, the string's lengths are gotten via array-active-length.
	;Then if the lengths to be compared are not equal, the strings are not
	;equal, otherwise they are compared.  This takes care of the most common
	;cases, but is not the same as the STRING-EQUAL function.
	;Only the %%CH-CHAR field is compared.  There are no "case shifts".
	((M-J) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Get count argument (typed)
		(ERROR-TABLE RESTART XSTRING-EQUAL)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 3 XSTRING-EQUAL)
	(CALL-XCT-NEXT XAAIXL)			;Get second string's length and decode array
       ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;Index into second string
	(CALL-NOT-EQUAL M-D (A-CONSTANT 1) TRAP)
	    (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 1 M-A)
	((M-C) SUB M-T A-Q)			;First string's subrange length (typed)
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B DSP-ARRAY-SETUP)
	((M-I) M-Q)				;Save parameters of second string
	((M-K) M-E)
	((M-ZR) M-B)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 1)
	(CALL-XCT-NEXT XAAIXL)			;Get first string's length and decode array
       ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;Index into first string
	(CALL-NOT-EQUAL M-D (A-CONSTANT 1) TRAP)
	    (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 1 M-A)
	((M-T) SUB M-T A-Q)			;First string's subrange length (typed)
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B DSP-ARRAY-SETUP)
	(JUMP-EQUAL M-J A-V-NIL XSTRING-EQUAL-2)	;Jump if no count supplied
	(DISPATCH Q-DATA-TYPE M-J TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM M-J 4)
	(JUMP-GREATER-THAN M-J A-C XFALSE)	;If count exceeds either array, 
	(JUMP-GREATER-THAN M-J A-T XFALSE)	; then the answer is NIL.
	((M-C) Q-POINTER M-J)			;Number of chars to be compared
XSTRING-EQUAL-0	;No bounds-checking required beyond this point
	(JUMP-EQUAL M-C A-ZERO XTRUE)		;If no characters to compare, result is T
	((M-C) ADD M-Q A-C)			;Highest location to reference in first str
XSTRING-EQUAL-1	;This is the character-comparison loop (38-46 cycles/char)
	(DISPATCH-CALL-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B ARRAY-TYPE-REF-DISPATCH)
       ((A-BDIV-V1) M-Q)
	((A-BDIV-V2) M-E)
	((M-1) (LISP-BYTE %%CH-CHAR) M-T)	;Character from first string
	((M-Q) M-I)
	(DISPATCH-CALL-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD) M-ZR ARRAY-TYPE-REF-DISPATCH)
       ((M-E) M-K)
	(CALL-XCT-NEXT XCHAR-EQUAL-1-2)
       ((M-2) (LISP-BYTE %%CH-CHAR) M-T)	;Character from second string
	(POPJ-EQUAL M-T A-V-NIL)		;Chars not equal => strings not equal
	((M-E) A-BDIV-V2)
	((M-Q) M+A+1 M-ZERO A-BDIV-V1)
	(JUMP-LESS-THAN-XCT-NEXT M-Q A-C XSTRING-EQUAL-1)
       ((M-I) ADD M-I (A-CONSTANT 1))		;All chars equal => strings equal
	(POPJ)					;M-T already has A-V-TRUE in it

XSTRING-EQUAL-2
	(JUMP-EQUAL-XCT-NEXT M-T A-C XSTRING-EQUAL-0)	;If lengths same, 
       ((M-C) Q-POINTER M-C)			; compare that many,
	(JUMP XFALSE)				; else return NIL

;;; Boolean operations

QIAND	(JUMP-XCT-NEXT M-T-TO-CPDL)
       (CALL QIAND0)

XMAND (MISC-INST-ENTRY M-LOGAND)
	((M-T) C-PDL-BUFFER-POINTER-POP)	;Convert to Instruction calling seq
XTCAND						;MC-LINKAGE
QIAND0	((M-S) (A-CONSTANT (OA-LOW-CONTEXT (AND)))) ;An extra instruction, but saves hair
    (ERROR-TABLE RESTART QIAND0)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 0 QIAND0)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
    (ERROR-TABLE RESTART QIAND1)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 1 QIAND1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	(POPJ-AFTER-NEXT (M-1) AND M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

QIIOR	(JUMP-XCT-NEXT M-T-TO-CPDL)
       (CALL QIIOR0)

XMIOR (MISC-INST-ENTRY M-LOGIOR)
	((M-T) C-PDL-BUFFER-POINTER-POP)	;Convert to Instruction calling seq
XTCIOR						;MC-LINKAGE
QIIOR0	((M-S) (A-CONSTANT (OA-LOW-CONTEXT (IOR)))) ;An extra instruction, but saves hair
		(ERROR-TABLE RESTART QIIOR0)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 0 QIIOR0)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
		(ERROR-TABLE RESTART QIIOR1)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 1 QIIOR1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	(POPJ-AFTER-NEXT (M-1) IOR M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

QIXOR	(JUMP-XCT-NEXT M-T-TO-CPDL)
       (CALL QIXOR0)

XMXOR (MISC-INST-ENTRY M-LOGXOR)
	((M-T) C-PDL-BUFFER-POINTER-POP)	;Convert to Instruction calling seq
XTCXOR						;MC-LINKAGE
QIXOR0	((M-S) (A-CONSTANT (OA-LOW-CONTEXT (XOR)))) ;An extra instruction, but saves hair
		(ERROR-TABLE RESTART QIXOR0)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 0 QIXOR0)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
		(ERROR-TABLE RESTART QIXOR1)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 1 QIXOR1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	(POPJ-AFTER-NEXT (M-1) XOR M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

;The 2nd arg of BOOLE becomes the A operand of the logical instruction.
;The 3rd arg becomes the M operand.
XBOOLE (MISC-INST-ENTRY *BOOLE)
	((M-T) C-PDL-BUFFER-POINTER-POP)	;Arg 3
	((M-A) C-PDL-BUFFER-POINTER-POP)	;Arg 2
		(ERROR-TABLE RESTART XBOOLE)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0 XBOOLE)
    (ERROR-TABLE ARG-POPPED 0 PP M-A M-T)
	((M-B) C-PDL-BUFFER-POINTER-POP)
	((C-PDL-BUFFER-POINTER-PUSH) M-A)	;Put arg 2 back in standard place
	((M-S) DPB M-B OAL-ALUF)	;Arg 1 as OA-REG-LOW alu function
    (ERROR-TABLE RESTART XBOOLE1)
XBOOLE0	(DISPATCH-XCT-NEXT Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG1)
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) PP 1 XBOOLE1)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-2ARG-BOOLE))
    (ERROR-TABLE RESTART XBOOLE2)
	(DISPATCH Q-DATA-TYPE M-T D-FIXNUM-NUMARG2 (I-ARG NUMBER-CODE-FIXNUM))
    (ERROR-TABLE ARGTYP (FIXNUM BIGNUM) M-T 2 XBOOLE2)
    (ERROR-TABLE ARG-POPPED 0 M-T M-1)
	((OA-REG-LOW) M-S)
	(POPJ-AFTER-NEXT (M-1) SETZ M-2 A-1)
       ((M-T) Q-POINTER M-1 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

;Boolean function of two bignums, M-S has OA-REG-LOW to do the function.
;First arg in M-Q,M-C,M-I.  Second arg in M-B/M-T,M-D,M-J.
;Eventual ACs:  small arg in M-R,M-J.  big arg in M-Q,M-I.  alu func in M-A
; result in M-T,M-C.  M-D has bit flags:
;	bit 0 - sign of smaller arg
;	bit 1 - sign of bigger arg
;This hair is required because bignums are sign-and-magnitude,
;but BOOLE wants to treat them as 2's complement.

BBOOLE	((M-TEM) BIGNUM-HEADER-SIGN M-C)	;Sign of 1st arg
	((M-A OA-REG-LOW) M-S)			;save alu func, compute sign of result
	((M-C) SETZ M-C A-D)			; in BIGNUM-HEADER-SIGN bit of M-C
	((M-D) BIGNUM-HEADER-SIGN M-D)		;bit 0 of M-D gets sign of 2nd arg
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-I A-J BBOOL0)	;Make M-Q,M-I the longer
       ((M-D) DPB M-TEM (BYTE-FIELD 1 1) A-D)	;bit 1 of M-D gets sign of 1st arg
	(DISPATCH (BYTE-FIELD 2 0) M-D D-BOOLE-REV)	;Interchange bits 0 and 1 of M-D
	 ((M-D) XOR M-D (A-CONSTANT 3))
	((M-T) M-Q)
	((M-TEM) M-J)
	((M-J) M-I)
	((M-Q) M-B)
	(JUMP-XCT-NEXT BBOOL1)
       ((M-I) M-TEM)

;If we didn't interchange the args, interchange bits 4 and 5
;of the ALU function so as to make the first argument be on the M side.
BBOOL0	(DISPATCH (BYTE-FIELD 2 4) M-A D-BOOLE-REV)
	 ((M-A) XOR M-A (A-CONSTANT 60))	;Swap bits if different
BBOOL1	((M-R) M-T)				;Small arg in M-R,M-J, big in M-Q,M-I
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 2))		;Allocate result 1 longer than bigger arg
						; due to the damned SETZ case
	((M-B) (A-CONSTANT 1))			;Index
	((A-BOOLE-CARRY-1) M-ZERO)
	((A-BOOLE-CARRY-2) M-ZERO)
BBOOL2	((VMA-START-READ) ADD M-R A-B)		;Loop over length of smaller arg
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-D BBOL2A)
       ((M-1) ADD READ-MEMORY-DATA A-BOOLE-CARRY-1)
	((M-1) SUB M-ZERO A-1)			;Smaller arg negative, get 2's comp form
	((A-BOOLE-CARRY-1) (BYTE-FIELD 1 31.) M-1)
BBOL2A	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 1) M-D BBOL2B)
       ((M-2) ADD READ-MEMORY-DATA A-BOOLE-CARRY-2)
	((M-2) SUB M-ZERO A-2)			;Larger arg negative, get 2's comp form
	((A-BOOLE-CARRY-2) (BYTE-FIELD 1 31.) M-2)
BBOL2B	((OA-REG-LOW) M-A)
	((WRITE-MEMORY-DATA) SETZ M-2 A-1)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-B A-J BBOOL2)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-B A-I BBOOL5)
       ((M-1) SUB M-ZERO A-BOOLE-CARRY-1)	;Sign bits for smaller arg
BBOOL3	((VMA-START-READ) ADD M-Q A-B)		;Do bigger arg against sign of smaller
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 1) M-D BBOL3B)
       ((M-2) ADD READ-MEMORY-DATA A-BOOLE-CARRY-2)
	((M-2) SUB M-ZERO A-2)			;Larger arg negative, get 2's comp form
	((A-BOOLE-CARRY-2) (BYTE-FIELD 1 31.) M-2)
BBOL3B	((OA-REG-LOW) M-A)
	((WRITE-MEMORY-DATA) SETZ M-2 A-1)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-B A-I BBOOL3)
       ((M-B) ADD M-B (A-CONSTANT 1))
BBOOL5	((M-2) SUB M-ZERO A-BOOLE-CARRY-2)	;Sign bits for larger arg
	((OA-REG-LOW) M-A)			;High result word comes from sign bits
	((WRITE-MEMORY-DATA) SETZ M-2 A-1)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE)
	((M-I) ADD M-I (A-CONSTANT 1))		;Actual length of result (for BIGNEG)
	(CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG)	;Magnitude of negative result
	(JUMP BIGNUM-DPB-CLEANUP)		;Dispose of any unnecessary high words

(LOCALITY D-MEM)
(START-DISPATCH 2 (PLUS P-BIT R-BIT)) ;Skip if bits the same
D-BOOLE-REV
	(INHIBIT-XCT-NEXT-BIT)	;Bits same, no need to swap
	(0)			;Bits different, swap by XOR'ing
	(0)			;different
	(INHIBIT-XCT-NEXT-BIT)	;same
(END-DISPATCH)
(LOCALITY I-MEM)

;Mixed-mode cases...
;Bignum arg in M-Q,M-C,M-I.  Fixnum unpacked in M-2.  ALU function in M-S.
;The first arg goes on the A side, and we want the fixnum on the A side.
BFXBOOLE	;Fixnum second arg, take as first by switching ALU function
	(DISPATCH (BYTE-FIELD 2 4) M-S D-BOOLE-REV)
	 ((M-S) XOR M-S (A-CONSTANT 60))
FXBBOOLE
	((M-A) M-S)				;Stash function in M-A
	((M-D) BIGNUM-HEADER-SIGN M-C)		;M-D bit 1 gets sign of bigger arg
	((M-D) DPB M-D (BYTE-FIELD 1 1))
	((OA-REG-HIGH) (BYTE-FIELD 1 31.) M-2)	;Get sign bits for smaller arg
	((M-1) M-ZERO)
	((OA-REG-LOW) M-A)			;Compute sign of result
	((M-C) SETZ M-C A-1)
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 2))		;Allocate result one longer than bignum arg
						; due to the damned SETZ case
	((A-BOOLE-CARRY-2) M-ZERO)
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))	;Combine low word with fixnum arg
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 1) M-D BBOLFX)
       ((M-TEM) ADD READ-MEMORY-DATA A-BOOLE-CARRY-2)
	((M-TEM) SUB M-ZERO A-TEM)		;Larger arg negative, get 2's comp form
	((A-BOOLE-CARRY-2) (BYTE-FIELD 1 31.) M-TEM)
BBOLFX	((OA-REG-LOW) M-A)
	((WRITE-MEMORY-DATA) SETZ M-TEM A-2)
	((WRITE-MEMORY-DATA) (BYTE-FIELD 31. 0) WRITE-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-I (A-CONSTANT 2) BBOOL3)	;do more of bignum arg
       ((M-B) (A-CONSTANT 2))
	(JUMP BBOOL5)				;bignum arg only 1 word long

;;; Arithmetic shift.  Unlike LSH, ASH works on bignums

XASH (MISC-INST-ENTRY ASH)
		(ERROR-TABLE RESTART XASH)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)	;arg 2, shift count
    (ERROR-TABLE ARGTYP FIXNUM PP 1 XASH)
    (ERROR-TABLE ARG-POPPED 0 PP PP)
	(CALL FXUNPK-P-1)			;M-2 gets arg 2
	((M-2) M-1)
		(ERROR-TABLE RESTART XASH1)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)	;arg 1, number to shift
    (ERROR-TABLE ARGTYP NUMBER PP 0 XASH1)
    (ERROR-TABLE ARG-POPPED 0 PP M-1)
       ((M-A) (A-CONSTANT ARITH-1ARG-ASH))
	;Fixnum case
	((OA-REG-HIGH) (BYTE-FIELD 1 31.) M-1)	;M-3 gets sign extension of M-1
	((M-3) M-ZERO)
	(JUMP-GREATER-THAN M-2 A-ZERO XASH2)	;Jump if left shift
	((M-2) ADD M-2 (A-CONSTANT 40))		;Number of bits preserved by right shift
	(JUMP-GREATER-THAN M-2 A-ZERO XASH1)
	((M-2) (A-CONSTANT 1))			;Shifting too far, preserve only sign
XASH1	((M-4) SUB M-2 (A-CONSTANT 1))		;Byte size -1
	((OA-REG-LOW) DPB M-4 OAL-BYTL-1 A-2)	;Use byte hardware
	((M-1) (BYTE-FIELD 0 0) M-1 A-3)	;Do the right arithmetic shift
	(JUMP FIXPACK-T)

;Left ASH of a fixnum turns into DPB.
XASH2	((C-PDL-BUFFER-POINTER-PUSH M-4)	;Put arg 1 back on pdl
		Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-1) SELECTIVE-DEPOSIT M-3 (BYTE-FIELD 9 23.) A-ZERO)	;background to DPB into (signs)
	((M-K) (A-CONSTANT 23.))		;Byte size
	(JUMP-LESS-THAN-XCT-NEXT M-2 (A-CONSTANT 9) ASHDPB)	;Jump if fit in machine word
       ((M-E) M-2)				;Byte position
	((M-1) M-ZERO)				;Bignum, DPB into background of zero
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-3 A-ZERO ASHDPB1) ;if positive
       ((M-C) DPB M-3 BIGNUM-HEADER-SIGN A-ZERO)
	(JUMP-NOT-EQUAL-XCT-NEXT M-4		;If negative, do magic things that work
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) POSITIVE-SETZ))
		XASH3)
       ((M-4) SUB M-ZERO A-4)			;Make it positive
	((M-4) DPB (M-CONSTANT -1) (BYTE-FIELD 1 22.) A-ZERO)	;Divide SETZ by 2
	((M-E) ADD M-E (A-CONSTANT 1))		; and increase shift
XASH3	(CALL-XCT-NEXT ASHDPB2)
       ((C-PDL-BUFFER-POINTER) Q-POINTER M-4
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	;; Note that we don't 2's complement it back again.
	(JUMP BIGNUM-DPB-CLEANUP)

;ASH of a bignum, in M-Q,M-C,M-I.  M-2 shift distance.
BIGASH	(JUMP-EQUAL M-2 A-ZERO RETURN-M-Q)	;Code below doesn't work for shift of 0
	((M-1 MD) M-2)
	(CALL-XCT-NEXT DIV)			;Split shift into words and bits
       ((M-2) (A-CONSTANT 31.))			;Q-R gets number of words, M-1 gets bits
	(JUMP-LESS-THAN MD A-ZERO BIGASHR)	;Jump if right shift
	(JUMP-NOT-EQUAL M-1 A-ZERO BIGASH3)	;Make BDIV-NORMALIZE work, cannot shift by 0
	((M-1) (A-CONSTANT 31.))		;so shift by 31. bits and one less word.  This
	((Q-R) SUB Q-R (A-CONSTANT 1))		;depends on DPB with IR<9:0>=-1 generating 0.
BIGASH3	((M-R) Q-R)				;Number of words of shifting
	((M-J) A-ZERO)				;No words discarded
BIGASH2	((M-B) ADD Q-R A-I)			;Result length is number of zero words shifted
	(CALL-XCT-NEXT BNCONS)			; in at bottom, + arg length, +1 at top
       ((M-B) ADD M-B (A-CONSTANT 2))		; for bits shift, +1 for header
	((M-E) M-R)				;Number of zero words at bottom
	(CALL-XCT-NEXT BDIV-NORMALIZE-ENCODE-SHIFT)	;Encode bit shift from M-1
       ((M-1) M-A-1 (M-CONSTANT 32.) A-1)
	((M-ZR) ADD M-I A-J)			;Number of words to read from old bignum
	((M-B) SUB M-Q A-J)			;Address of old bignum (offset if right shift)
	((M-B) Q-POINTER M-B)			;Avoid illegal pointer lying around
	((M-D) M-T)				;Address of new bignum
	(CALL-XCT-NEXT BDIV-NORMALIZE)		;Shift subroutine
       ((M-2) A-ZERO)				;0 bits in at top
	(JUMP BIGNUM-DPB-CLEANUP)		;Fix bignum length and return

BIGASHR	((M-R) (A-CONSTANT -1))			;Bottom word of left-shift result discarded
	((M-J) Q-R)				;Negative number of words discarded at
						; bottom of input bignum
	((M-1) ADD M-1 (A-CONSTANT 31.))	;Convert right bit shift into left shift
	((Q-R) SUB M-J (A-CONSTANT 1))		;Cause M-B (to cons) to match M-ZR (to norm)
	((M-TEM) ADD M-J A-I)
	(JUMP-GREATER-THAN M-TEM A-ZERO BIGASH2)	;Jump if any significance
	((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C)	;Result is just sign bits
	((M-1) M-ZERO)
	(JUMP FIXPACK-T)

;ASH of a flonum is FSC, i.e. multiply by appropriate power of 2
FLONUM-ASH
	(POPJ-AFTER-NEXT (M-I) ADD M-I A-2)	;Add shift count to exponent
       (NO-OP)

;;; Data-type dispatches for arithmetic.

;;; Dispatch on the type of a one-argument numeric function.
;;; DTP-FIX unpacks and then drops through; eveything else jumps.
(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-NUMARG
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(P-BIT FXUNPK-P-1)			;FIX
	(ARITH-XNM)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(ARITH-SFL)				;SMALL-FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;;; Dispatch on the type of the first numeric arg.
;;; DTP-FIX unpacks and then drops through; eveything else jumps.
(START-DISPATCH 5 0)
D-NUMARG1
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(P-BIT FXUNPK-P-1)			;FIX
	(ARITH-XNM-ANY)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(ARITH-SFL-ANY)				;SMALL-FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;;; Data type dispatch on second numeric arg, when first one was a DTP-FIXNUM.
;;; DTP-FIXNUM unpacks and drops through; everything else jumps.  First arg
;;; is unpacked into M-1.  Second arg in M-T.
(START-DISPATCH 5 0)
D-FIXNUM-NUMARG2
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT FXUNPK-T-2)	;FIX
	(INHIBIT-XCT-NEXT-BIT ARITH-ANY-XNM)	;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(INHIBIT-XCT-NEXT-BIT ARITH-FIX-SFL)	;SMALL-FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;;; Data type dispatch for second numeric arg when first was NOT DTP-FIXNUM
;;; DTP-SMALL-FLONUM unpacks and drops through; everything else jumps.
;;; During this dispatch, the I-ARG contains a number code.
;;; The first arg has been unpacked as follows:
;;;  If BIGNUM, M-Q has BIGNUM pointer, M-C HEADER, M-I LENGTH.
;;;  If FLONUM, M-Q has FLONUM pointer, M-C HEADER, M-I exponent, M-1 mantissa.
;;;  If SMALL-FLONUM, M-Q has SMALL-FLONUM pointer, M-I has exponent, M-1 mantissa.
;;;  Also, the original pointer is kept in M-J.
(START-DISPATCH 5 0)
D-NUMARG2
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FREE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;SYMBOL HEADER
	(ARITH-ANY-FIX)				;FIX
	(ARITH-ANY-XNM)				;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;BODY-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LOCATIVE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT SFLUNPK-T-2)			;SMALL-FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; One-argument function.
ARITH-SFL
	(CALL SFLUNPK-P-1)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FLONUM-1ARG)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-T)))

ARITH-XNM
	((VMA-START-READ M-I) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-Q) VMA)		;get transported number address 
	((M-TEM) Q-DATA-TYPE MD)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER)) ILLOP)
	(DISPATCH-XCT-NEXT HEADER-TYPE-FIELD MD D-XNM-ARG)
       ((M-C) HEADER-REST-FIELD MD)

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-XNM-ARG
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ERROR
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY LEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;UNUSED
	(ARITH-FLO)				;FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;COMPLEX
	(ARITH-BIG)				;BIGNUM
	(ARITH-OUT)				;RATIONAL BIGNUMS
 (REPEAT NUM-UNUSED-HEADER-TYPES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-FLO
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-I) HEADER-FLONUM-EXPONENT M-C)
	((M-1) DPB M-C FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
	((M-1) SELECTIVE-DEPOSIT MD FLONUM-HEADER-LOW-MANTISSA A-1)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FLONUM-1ARG)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-T)))

;; Call out to macro-code.
ARITH-OUT
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCNUM1))
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the function code.
		Q-POINTER M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
						(BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the number.
		Q-TYPED-POINTER M-I (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-JUMP MMJCALL) (I-ARG 2))		;Call tail-recursively.

;;; This dispatch SOMETIMES executes next: viz., when the result will be a number.
;;; Dispatchers can push a PACK routine in the xct-next cycle.
(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-FLONUM-1ARG
	(FLONUM-ABS)
	(FLONUM-MINUS)
	(INHIBIT-XCT-NEXT-BIT FLONUM-ZEROP)
	(INHIBIT-XCT-NEXT-BIT FLONUM-PLUSP)
	(INHIBIT-XCT-NEXT-BIT FLONUM-MINUSP)
	(FLONUM-ADD1)
	(FLONUM-SUB1)
	(INHIBIT-XCT-NEXT-BIT FLONUM-FIX)
	(INHIBIT-XCT-NEXT-BIT FLOPACK-T)
	(INHIBIT-XCT-NEXT-BIT SFLPACK-T)
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;HAULONG DOESN'T WORK FOR FLONUMS
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;LDB DOESNT EITHER.
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;NOR DPB.
	(FLONUM-ASH)				;ASH OF A FLONUM = FSC
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;ODDP ILLEGAL
	(P-BIT INHIBIT-XCT-NEXT-BIT XHAULFLO)	;EVENP ILLEGAL
 (REPEAT NUM-UNUSED-ARITH-1ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)


FLONUM-ABS
	(POPJ-IF-BIT-CLEAR FLONUM-SIGN-BIT M-1)
	(JUMP FNEG1)

;FLONUM-MINUS is the same as FNEG1, see below.

;FLONUM-ZEROP, FLONUM-PLUSP and FLONUM-MINUSP are up with the fixnum cases,
;see above.

FLONUM-ADD1
	((M-2) DPB M-MINUS-ONE MANTISSA-HIGH-BIT A-ZERO);10_33
	(JUMP-XCT-NEXT FADD)
       ((M-J) M+A+1 M-ZERO (A-CONSTANT 2000))		;2001

FLONUM-SUB1
	((M-2) DPB M-MINUS-ONE FLONUM-SIGN-BIT A-ZERO)	;20_33
	(JUMP-XCT-NEXT FADD)
       ((M-J) (A-CONSTANT 2000))			;2000

FLONUM-FIX
	((OA-REG-HIGH) FLONUM-SIGN-BIT M-1)	;M-T gets 0 if arg positive,
       ((M-T) Q-POINTER M-ZERO			;  -1 if arg is negative.
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-LESS-OR-EQUAL M-I (A-CONSTANT 2000)) ;return 0 or -1 if fractional
	(JUMP-GREATER-OR-EQUAL M-I (A-CONSTANT 2030) FLONUM-BIGFIX) ;big enough to be bignum
	((M-A) M-A-1 M-I (A-CONSTANT 2000))	;Byte length - 1 (maximum byte length 23.)
	((M-B) ADD M-A (A-CONSTANT 2))		;Leftward rotation of M-1.
	(POPJ-AFTER-NEXT (OA-REG-LOW) DPB M-A OAL-BYTL-1 A-B)
       ((M-T) (BYTE-FIELD 0 0) M-1 A-T)		;A boxed signed fixnum!

FLONUM-BIGFIX
	((M-C) DPB M-T BIGNUM-HEADER-SIGN A-ZERO)	;Save sign
	(CALL FLONUM-ABS)
	((M-4) M-1)				;Save magnitude of mantissa
	((M-1) SUB M-I (A-CONSTANT (DIFFERENCE 2000 30.)))	;Compute bignum length
	(CALL-XCT-NEXT DIV)			;Q-R gets number of words,
       ((M-2) (A-CONSTANT 31.))			;M-1 gets bits minus one in last word
	((M-2) M-4)				;Restore mantissa magnitude
	((M-I) Q-R)				;Bignum length
	(CALL-XCT-NEXT BNCONS)			;Allocate a bignum result
       ((M-B) ADD Q-R (A-CONSTANT 1))
	((M-3) SUB M-I (A-CONSTANT 2))		;Zero out all but high 2 words of bignum
	(JUMP-LESS-OR-EQUAL M-3 A-ZERO FLONUM-BIGFIX1)
	((WRITE-MEMORY-DATA) M-ZERO)
FLONUM-BIGFIX0
	((VMA-START-WRITE) ADD M-T A-3)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 1) FLONUM-BIGFIX0)
       ((M-3) SUB M-3 (A-CONSTANT 1))
FLONUM-BIGFIX1
	((M-3) ADD M-1 (A-CONSTANT 2))		;Get high-order word of result
	((OA-REG-LOW) DPB M-1 OAL-BYTL-1 A-3)	;[Right-justify high (M-1)+1 bits of 31.]
	((WRITE-MEMORY-DATA) (BYTE-FIELD 0 0) M-2)
	((VMA-START-WRITE) ADD M-T A-I)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN M-I (A-CONSTANT 2) BIGNUM-DPB-CLEANUP)	;No low-order word
	((M-3) M-A-1 (M-CONSTANT 32.) A-3)	;Get low-order word (may be garbage)
	((M-1) ADD M-1 (A-CONSTANT 1))		;[Left-justify low 30.-(M-1) bits in 31.]
	((OA-REG-LOW) DPB M-3 OAL-BYTL-1 A-1)
	((WRITE-MEMORY-DATA) DPB M-2 (BYTE-FIELD 0 0) A-ZERO)
	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(JUMP BIGNUM-DPB-CLEANUP)		;Might really be a fixnum after all! (SETZ)

;;; Two-argument functions.

;;; The first arg, which is on the PDL, is a SMALL-FLONUM.  ARITH-2ARG is in M-A.
ARITH-SFL-ANY		(ERROR-TABLE RESTART ARITH-SFL-ANY)
	((M-Q) C-PDL-BUFFER-POINTER)	;Save arg in case error.
	((M-J) M-Q)			;Save arg in case of call-out.
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T D-NUMARG2 (I-ARG NUMBER-CODE-SMALL-FLONUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 ARITH-SFL-ANY)
       (CALL SFLUNPK-P-1)
	;; If it comes back here, both flonums are unpacked.
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-T 1)	;not easily continuable
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-P)))

;;; Second arg was a fixnum, but first wasn't.
;;; I-ARG contains type of first argument, M-A contains operation.
ARITH-ANY-FIX
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) READ-I-ARG D-ARITH-ANY-FIX)
       (CALL FXUNPK-T-2)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-ARITH-ANY-FIX
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FIX, SHOULN'T GET HERE.
	(ARITH-SFL-FIX)				;SMALL FLONUM
	(ARITH-FLO-FIX)				;FLONUM
	(ARITH-BIG-FIX)				;BIGNUM
 (REPEAT NUM-UNUSED-NUMBER-CODES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; First arg is a fixnum unpacked.  Second arg is a small flonum, packed.
ARITH-FIX-SFL
	(CALL-XCT-NEXT SFLUNPK-T-2)
       ((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-T 1)
    (ERROR-TABLE ARG-POPPED 0 M-1 M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-P)))

;;; We have a small flonum in M-1,M-I and a fixnum in M-2.
;;; Reverse the order, normalize the fixnum to a flonum, and call reverse operator.
ARITH-SFL-FIX
	((M-TEM) M-2)
	((M-2) M-1)
	((M-1) M-TEM)
	((M-J) M-I)
	((Q-R) M-ZERO)
	(CALL-XCT-NEXT FNORM)
       ((M-I) (A-CONSTANT 2036))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-REVERSE-FLONUM-OPS)
    (ERROR-TABLE FLONUM-NO-GOOD)	;ARGTYP not usable, arg not saved
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SFLPACK-P)))

;;; We have a flonum in M-1/M-I and a fixnum in M-2.  This is just like the above.
ARITH-FLO-FIX
	((M-TEM) M-2)
	((M-2) M-1)
	((M-1) M-TEM)
	((M-J) M-I)
	((Q-R) M-ZERO)
	(CALL-XCT-NEXT FNORM)
       ((M-I) (A-CONSTANT 2036))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-REVERSE-FLONUM-OPS)
    (ERROR-TABLE FLONUM-NO-GOOD)	;ARGTYP not usable, arg not saved
    (ERROR-TABLE ARG-POPPED M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

;;; Routines that look at the contents of M-A and act on it.

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-FORWARD-FLONUM-OPS
	(FADD)			;ADD
	(FSUB)			;SUB
	(FMPY)			;MUL
	(FDIV)			;DIV
	(INHIBIT-XCT-NEXT-BIT FEQL)	;=
	(INHIBIT-XCT-NEXT-BIT FGRP)	;>
	(INHIBIT-XCT-NEXT-BIT FLSP)	;<
	(FMIN)			;MIN
	(FMAX)			;MAX
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BOOLE
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

(START-DISPATCH 4 0)
D-REVERSE-FLONUM-OPS
	(FADD)			;REVERSE ADD
	(FSUB-REVERSE)		;REVERSE SUB
	(FMPY)			;REVERSE MPY
	(FDIV-REVERSE)		;REVERSE DIVIDE
	(INHIBIT-XCT-NEXT-BIT FEQL)	;REVERSE =
	(INHIBIT-XCT-NEXT-BIT FLSP)	;REVERSE >
	(INHIBIT-XCT-NEXT-BIT FGRP)	;REVERSE <
	(FMIN)			;REVERSE MIN
	(FMAX)			;REVERSE MAX
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BOOLE
(REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

FSUB-REVERSE
	(JUMP-XCT-NEXT FADD)
       (CALL FNEG1)

FDIV-REVERSE
	(JUMP-XCT-NEXT FDIV)
       (CALL SWAP-FLONUMS)

SWAP-FLONUMS
	((M-TEM) M-I)
	((M-I) M-J)
	((M-J) M-TEM)
	((M-TEM) M-1)
	(POPJ-AFTER-NEXT (M-1) M-2)
       ((M-2) M-TEM)

;;; Extended numbers.

;;; The first arg is an XNUM.  Arith op in M-A.
ARITH-XNM-ANY
	((VMA-START-READ M-J) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-Q) VMA)		;get transported number address 
	((M-TEM) Q-DATA-TYPE MD)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER)) ILLOP)
	(DISPATCH-XCT-NEXT HEADER-TYPE-FIELD MD D-XNM-ARG-1)
       ((M-C) HEADER-REST-FIELD MD)

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-XNM-ARG-1
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ERROR
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY LEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;UNUSED
	(ARITH-FLO-ANY)				;FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;COMPLEX
	(ARITH-BIG-ANY)				;BIGNUM
	(ARITH-OUT-ANY)				;RATIONAL BIGNUMS
 (REPEAT NUM-UNUSED-HEADER-TYPES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)

;This dispatch is used to push a return address of M-T-TO-CPDL if the
;instruction wants its result on the pdl (rather than in M-T).
;In any case we go to MMJCALL to activate the call to the macrocode routine.
(START-DISPATCH 4 0)
D-ARITH-OUT-RETURN
	(MMJCALL)		;ADD
	(MMJCALL)		;SUB
	(MMJCALL)		;MUL
	(MMJCALL)		;DIV
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;=
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;>
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;<
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;MIN
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;MAX
	(INHIBIT-XCT-NEXT-BIT MMJCALL)	;BOOLE
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; First argument is handled by macrocode.  Call out.
ARITH-OUT-ANY
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCNUM2))
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the function code.
		Q-POINTER M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
					        (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the first number.
		Q-TYPED-POINTER M-J (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the second number.
		Q-TYPED-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-ARITH-OUT-RETURN (I-ARG 3))	;Call tail-recursively.
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))

;;; First arg is a real flonum.  Pointer in M-Q, header-rest in M-C, op in M-A.
ARITH-FLO-ANY
	((VMA-START-READ) M-Q ADD (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-I) HEADER-FLONUM-EXPONENT M-C)
	((M-1) DPB M-C FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
    (ERROR-TABLE RESTART ARITH-FLO-ANY)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T D-NUMARG2 (I-ARG NUMBER-CODE-FLONUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1 ARITH-FLO-ANY)
       ((M-1) SELECTIVE-DEPOSIT MD FLONUM-HEADER-LOW-MANTISSA A-1)
	;; If falls through, second arg is a small flonum, already unpacked.
ARITH-FLO-SFL ;This label is not used.  It is here for completeness.
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-Q 0)	;not easily continuable
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

;;; The second arg is an extended number.  First arg is unpacked, type in I-ARG.
;;; Arith op in M-A.
ARITH-ANY-XNM
	((VMA-START-READ) M-T)
	((M-R) READ-I-ARG)			;Get number code of first arg.
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-T) VMA)		;get transported number address 
	((M-TEM) Q-DATA-TYPE MD)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER)) ILLOP)
	(DISPATCH-XCT-NEXT HEADER-TYPE-FIELD MD D-XNM-ARG-2)
       ((M-D) HEADER-REST-FIELD MD)

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
D-XNM-ARG-2
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ERROR
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;ARRAY LEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;UNUSED
	(ARITH-ANY-FLO)				;FLONUM
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;COMPLEX
	(ARITH-ANY-BIG)				;BIGNUM
	(ARITH-ANY-OUT)				;RATIONAL BIGNUMS
 (REPEAT NUM-UNUSED-HEADER-TYPES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; The second arg requires calling-out to macrocode.  The first
;;; argument is in M-J, unless it was a fixnum in which case
;;; it has been unpacked into M-1.  Second arg is in M-T.
ARITH-ANY-OUT
	(JUMP-NOT-EQUAL M-R (A-CONSTANT NUMBER-CODE-FIXNUM) ARITH-ANY-OUT-1)
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(CALL FIXPACK-T)
	((M-J) M-T)
	((M-T) C-PDL-BUFFER-POINTER-POP)
ARITH-ANY-OUT-1
	(CALL P3ZERO)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCNUM2))
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Push function
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the function code.
		Q-POINTER M-A (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
					        (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the first number.
		Q-TYPED-POINTER M-J (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((C-PDL-BUFFER-POINTER-PUSH)		;Push the second number.
		Q-TYPED-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(DISPATCH (BYTE-FIELD 4 0) M-A D-ARITH-OUT-RETURN (I-ARG 3))	;Call tail-recursively.
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))

;;; Number code of first arg in M-R.
;;; If is is a fixnum, small flonum, or flonum, it is unpacked in M-1/M-I.
;;; Our header rest field in M-D, our pointer in M-T.
ARITH-ANY-FLO
	((VMA-START-READ) M-T ADD (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-J) HEADER-FLONUM-EXPONENT M-D)
	((M-2) DPB M-D FLONUM-HEADER-HIGH-MANTISSA A-ZERO)
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) M-R D-ARITH-ANY-FLO)
       ((M-2) SELECTIVE-DEPOSIT MD FLONUM-HEADER-LOW-MANTISSA A-2)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-ARITH-ANY-FLO
	(ARITH-FIX-FLO)
	(ARITH-SFL-FLO)
	(ARITH-FLO-FLO)
	(ARITH-BIG-FLO)
 (REPEAT NUM-UNUSED-NUMBER-CODES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-FIX-FLO
	((M-Q) M-1)
	((M-I) (A-CONSTANT 2036))
	(CALL-XCT-NEXT FNORM)
       ((Q-R) M-ZERO)
	;drop in
ARITH-SFL-FLO 
ARITH-FLO-FLO
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE FLONUM-NO-GOOD)	;ARGTYP not usable, I think I lost the arg
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

;Flonum arithmetic routines.

;These routines bash M-J, M-2, M-TEM, Q-R, A-TEMn, M-K.
;M-ZERO is an even address in M-memory.  It contains zeros, and the following
;location contains a -1.  This is used to get A-TEM1 below by hacking
;the low bit of the OA-REG-HIGH, which is the low bit of the M-source field,
;to get either a word of zeros or a word of ones depending on the sign bit
;of M-2.

;Floating Subtract.  This changes the sign of M-2 and turns into Add.
FSUB	(CALL FNEG2)
	;drop through

;Floating Add.
FADD	(JUMP-EQUAL-XCT-NEXT M-I A-J FADD2)	;Jump if exponents equal, no shifting
       ((Q-R) M-ZERO)				;Initialize discarded bits.
	(CALL-LESS-THAN-XCT-NEXT M-I A-J FADD1)	;If M-1 to shift right, exchange args
       ((M-TEM) M-A-1 M-I A-J)			;Amt to shift M-2 right minus one
	(JUMP-GREATER-OR-EQUAL M-TEM (A-CONSTANT 37) FADD3)
	((OA-REG-HIGH) FLONUM-SIGN-BIT M-2)	;Sign-extend M-2
       ((A-TEM1) M-ZERO)			;Gets either all zeros or all ones.
	((M-J) M-A-1 (M-CONSTANT 40) A-TEM)	;40 minus exponent difference
	((OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-J)	; becomes m-rotate
       ((A-TEM2) DPB M-2 (BYTE-FIELD 0 0) A-ZERO) ;Get bits shifted off right end of M-2
	((Q-R) A-TEM2)				;Put them in Q-R where they belong
	((M-TEM) SUB M-J (A-CONSTANT 1))	;Byte length minus one
	((OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-J)
       ((M-2) (BYTE-FIELD 0 0) M-2 A-TEM1)	;Arithmetically shift M-2 right
FADD2	((M-1) ADD M-1 A-2 OUTPUT-SELECTOR-RIGHTSHIFT-1	;Do the add, collect
		SHIFT-Q-RIGHT)	; the overflow, discarded bits to Q
;Normalizing loop
FNORM	(DISPATCH SIGN-BIT-AND-MANTISSA-HIGH-THREE M-1 D-FNORM) ;Maybe xct-next
       ((M-I) ADD M-I (A-CONSTANT 1))		;Adjust exponent for right shift

(LOCALITY D-MEM)
(START-DISPATCH 4 0)	;s.xyz high 4 bits of sum to be normalized
D-FNORM	(INHIBIT-XCT-NEXT-BIT FNORM3)	;0.000 shift left at least 3
	(FNORM2)			;0.001 shift left 2
	(FNORM1)			;0.010 shift left 1
	(FNORM1)			;0.011 shift left 1
	(FRND)				;0.100 OK
	(FRND)				;0.101 OK
	(FRND)				;0.110 OK
	(FRND)				;0.111 OK
	(FRND)				;1.000 OK
	(FRND)				;1.001 OK
	(FRND)				;1.010 OK
	(FRND)				;1.011 OK
	(FNORM1)			;1.100 shift left 1
	(FNORM1)			;1.101 shift left 1
	(FNORM2)			;1.110 shift left 2
	(INHIBIT-XCT-NEXT-BIT FNORM3)	;1.111 shift left at least 3
(END-DISPATCH)
(LOCALITY I-MEM)

FNORM3	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((Q-R) ANDCA Q-R (A-CONSTANT 7))	;Zero the bits brought into Q
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO FNORM) ;Break the loop if trying
       ((M-I) SUB M-I (A-CONSTANT 3))		   ; to normalize zero
;Return a floating-point zero (in internal form)
FLZERO	(POPJ-AFTER-NEXT (M-I) A-ZERO)
       ((M-1) A-ZERO)

;If M-2 seems to pale into insignificance, it might be SETZ, which doesn't
FADD3	(POPJ-GREATER-THAN M-TEM (A-CONSTANT 37))
	(POPJ-NOT-EQUAL M-2 (A-CONSTANT (BYTE-MASK FLONUM-SIGN-BIT)))
	(JUMP-XCT-NEXT FADD2)
       ((M-2) (M-CONSTANT -1))

FNORM2	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((Q-R) ANDCA Q-R (A-CONSTANT 3))	;Zero the bits brought into Q
	(JUMP-XCT-NEXT FRND)
       ((M-I) SUB M-I (A-CONSTANT 2))

FNORM1	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)
	((Q-R) ANDCA Q-R (A-CONSTANT 1))	;Zero the bit brought into Q
	((M-I) SUB M-I (A-CONSTANT 1))
	;drops through
;Floating-point rounding routine.
;Get here with normalized mantissa in M-1, corresponding exponent in M-I,
;residual bits in Q-R.  Rounding cannot produce zero unless given zero,
;since the input is normalized.  Do not come here with zero in M-1
;unless M-I is zero and Q-R is non-negative, or an unnormalized
;result will be returned.
;After rounding, we renormalize with a 3-bit normalize since the rounding
;can make a positive number slightly bigger and a negative number slightly smaller,
;requiring a shift of 0, 1 right, or 1 left.
FRND	(POPJ-GREATER-OR-EQUAL Q-R A-ZERO)	;Return if discarded bits < 1/2 lsb, no rounding required.
	(JUMP-NOT-EQUAL Q-R (A-CONSTANT 1_31.) FRND2)	;If discarded bits = 1/2 lsb exactly,
	(POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-1) ; then round to even
FRND2	((M-1) ADD M-1 (A-CONSTANT 1)		;Add 1 lsb to mantissa, and
		OUTPUT-SELECTOR-RIGHTSHIFT-1 SHIFT-Q-RIGHT) ; capture overflow
FRND1	(DISPATCH SIGN-BIT-AND-MANTISSA-HIGH-TWO M-1 D-FRND) ;Renormalize & popj
       ((M-I) ADD M-I (A-CONSTANT 1))		;Right shift was good, fix exponent, popj

;This code is heavily bummed.  Beware.
;Note that Q normally has full low-order word.  From SFLPACK has garbage but won't be used.
FRND3	((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1 SHIFT-Q-LEFT)	;Restores the LSB from the Q.
FRND4	(POPJ-AFTER-NEXT (M-I) SUB M-I (A-CONSTANT 1))
       ((M-1) M-1 OUTPUT-SELECTOR-LEFTSHIFT-1)	;Restores the LSB from the Q.

(LOCALITY D-MEM)
(START-DISPATCH 3 0)  ;s.xx renormalize after round
D-FRND	(INHIBIT-XCT-NEXT-BIT FRND3)	;0.00 shift left two
	(FRND4)				;0.01 shift left one
	(R-BIT)				;0.10 OK
	(R-BIT)				;0.11 OK
	(R-BIT)				;1.00 OK
	(R-BIT)				;1.01 OK
	(FRND4)				;1.10 shift left one
	(INHIBIT-XCT-NEXT-BIT FRND3)	;1.11 shift left two
(END-DISPATCH)
(LOCALITY I-MEM)

;Exchange the arguments to FADD when the second has bigger exponent
FADD1	((M-I) M-J)		;Result exponent is exp of 2nd arg
	((M-TEM) M-A-1 (M-CONSTANT -1) A-TEM)	;Repair exponent difference
	((M-4) M-2)		;Exchange mantissas
	(POPJ-AFTER-NEXT (M-2) M-1)
       ((M-1) M-4)

;Negate operand 1.  
;Normally just change the sign of the mantissa, but note that
;to retain normalization 1/2 becomes -1 and -1 becomes 1/2, with adjustment of the exponent
FLONUM-MINUS 
FNEG1	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-1 A-ZERO FNEG1A)	;Jump if input positive
       ((M-1) SUB M-ZERO A-1)				;Change sign of mantissa
	(POPJ-IF-BIT-CLEAR FLONUM-SIGN-BIT M-1)		;Return if negative became positive
	(POPJ-AFTER-NEXT				;Otherwise generate 1/2 and increase
	 (M-1) DPB (M-CONSTANT -1) MANTISSA-HIGH-BIT A-ZERO) ; exponent since it must have
       ((M-I) ADD M-I (A-CONSTANT 1))			     ; been -1 which is "SETZ"
	
FNEG1A	(POPJ-NOT-EQUAL M-1 (A-CONSTANT (BYTE-MASK SIGN-BIT-AND-MANTISSA-HIGH-BIT)))
	(POPJ-AFTER-NEXT			;If result is -1/2,
	 (M-1) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-ZERO)	;Turn it into -1
       ((M-I) SUB M-I (A-CONSTANT 1))		;and decrease exponent

;Negate operand 2.  
;Normally just change the sign of the mantissa, but note that
;to retain normalization 1/2 becomes -1 and -1 becomes 1/2, with adjustment of the exponent
FNEG2	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO FNEG2A)	;Jump if input positive
       ((M-2) SUB M-ZERO A-2)				;Change sign of mantissa
	(POPJ-IF-BIT-CLEAR FLONUM-SIGN-BIT M-2)		;Return if negative became positive
	(POPJ-AFTER-NEXT				;Otherwise generate 1/2 and increase
	 (M-2) DPB (M-CONSTANT -1) MANTISSA-HIGH-BIT A-ZERO) ; exponent since it must have
       ((M-J) ADD M-J (A-CONSTANT 1))			     ; been -1 which is "SETZ"
	
FNEG2A	(POPJ-NOT-EQUAL M-2 (A-CONSTANT (BYTE-MASK SIGN-BIT-AND-MANTISSA-HIGH-BIT)))
	(POPJ-AFTER-NEXT			;If result is -1/2,
	 (M-2) DPB (M-CONSTANT -1) FLONUM-SIGN-BIT A-ZERO)	;Turn it into -1
       ((M-J) SUB M-J (A-CONSTANT 1))		;and decrease exponent

;Floating Division.
;First, make both arguments positive, and remember if the result is to
;be negative.  Also handle arguments of zero at this stage.  Then,
;arrange for the quotient to always be normalized by dividing the
;dividend by 2 if it is greater than the divisor.  This makes the
;result mantissa be between 1/2 and 1.  Note that if the dividend and
;divisor are equal, dividing the dividend by 2 could end up producing
;an unnormalized quotient less than 1/2 because of truncation error.
;We fix this by checking specially for the case of dividend and divisor
;equal.  To get a properly-scaled quotient, we shift the dividend left
;31. bits, plus 1 more bit to get it to a word boundary.  The extra bit
;is compensated for by doing one less divide step.  After dividing, we
;do stable rounding by comparing the remainder against half the
;divisor.  Recall that divide overflow occurs if the high word of the
;dividend is greater than or equal to the divisor.
FDIV	(CALL-EQUAL M-2 A-ZERO TRAP)
		(ERROR-TABLE DIVIDE-BY-ZERO)
		(ERROR-TABLE ARG-POPPED 0 M-Q M-T)
	(POPJ-EQUAL M-1 A-ZERO)			;(// 0.0 non-0) = 0.0
	(JUMP-LESS-THAN M-2 A-ZERO FDIV3)	;Jump if divisor negative
	(JUMP-LESS-THAN M-1 A-ZERO FDIV4)	;Jump if dividend negative
FDIV1	((M-I) M-I ADD (A-CONSTANT FLONUM-EXPONENT-EXCESS))
	(JUMP-LESS-THAN-XCT-NEXT M-1 A-2 FDIV2)	;If dividend >= divisor,
       ((M-I) SUB M-I A-J)
	(JUMP-EQUAL M-1 A-2 FDIV7)
	((M-1) (BYTE-FIELD 31. 1) M-1)		;shift dividend right 1,
	((M-I) ADD M-I (A-CONSTANT 1))		;and increase exponent of result
FDIV2	((Q-R) M-ZERO)				;Low bits of dividend
	((M-1) DIVIDE-FIRST-STEP M-1 A-2)	;Do the division, doesn't call DIV due to
(REPEAT 30. ((M-1) DIVIDE-STEP M-1 A-2))	; register conflicts and orneriness
	((M-1) DIVIDE-LAST-STEP M-1 A-2)
	((M-TEM) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2)
	;At this point, the normalized positive quotient is in Q-R, remainder is in M-TEM
	;We'd like to shift the remainder left and do an unsigned compare, but that
	;operation isn't available so we shift the divisor right and lose a bit.
	((A-TEM1) (BYTE-FIELD 31. 1) M-2)
	(POPJ-LESS-THAN-XCT-NEXT M-TEM A-TEM1)	;Round down if remainder < 1/2 divisor
       ((M-1) Q-R)
	(JUMP-GREATER-THAN M-TEM A-TEM1 FDIV6)	;Round up if remainder > 1/2 divisor
	(POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 0) M-1);Round to even lsb if remainder = 1/2 divisor
FDIV6	(JUMP-XCT-NEXT FRND1)			;Duplicate instruction at FRND2 for speed
       ((M-1) ADD M-1 (A-CONSTANT 1)		;Add 1 lsb to mantissa, and
		OUTPUT-SELECTOR-RIGHTSHIFT-1 SHIFT-Q-RIGHT) ; capture overflow

;Divisor is negative.  Change its sign and check sign of dividend
FDIV3	(JUMP-GREATER-THAN-XCT-NEXT M-1 A-ZERO FDIV5)	;Jump on positive dividend
       (CALL FNEG2)
	(JUMP-XCT-NEXT FDIV1)			;Both negative, result is positive
       (CALL FNEG1)

;Divisor is positive but dividend is negative.  Result is negative.
FDIV4	(CALL FNEG1)				;Change sign of dividend
FDIV5	(JUMP-XCT-NEXT FNEG1)			;Result is negative, get positive
       (CALL FDIV1)				; quotient and return it negated.

;Dividend and divisor mantissas equal.  Quotient mantissa is 1/2.
FDIV7	(POPJ-AFTER-NEXT (M-1) DPB (M-CONSTANT -1) MANTISSA-HIGH-BIT A-ZERO)
       ((M-I) ADD M-I (A-CONSTANT 1))

;Floating Multiplication.
FMPY	(CALL-XCT-NEXT MPY)	;Product of mantissas to M-2(high), Q-R(low)
       ((Q-R) M-2)
	(JUMP-EQUAL M-2 A-ZERO FLZERO) ;If high product of normalized operands is zero, the
				; whole product is zero.  Return proper zero.
	((M-1) M-2)		;Get result of MPY into M-1
	((M-I) M-I SUB (A-CONSTANT FLONUM-EXPONENT-EXCESS))
	(DISPATCH-XCT-NEXT SIGN-BIT-AND-MANTISSA-HIGH-TWO
			M-1 D-FMPY) ;Normalize.  May need 0, 1, or 2 left shifts
       ((M-I) M+A+1 M-I A-J)	;Exponent of product if no shifts

(LOCALITY D-MEM)
(START-DISPATCH 3 0)	;s.xy high bits of product
D-FMPY	(FNORM2)	;0.00 shift left 2
	(FNORM1)	;0.01 shift left 1
	(FRND)		;0.10 OK
	(FRND)		;0.11 OK
	(FRND)		;1.00 OK
	(FRND)		;1.01 OK
	(FNORM1)	;1.10 shift left 1
	(FNORM2)	;1.11 shift left 2
(END-DISPATCH)
(LOCALITY I-MEM)

;= for flonums.
FEQL	(POPJ-NOT-EQUAL-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-NOT-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FGRP	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-1 FGRP-1)
	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-2 XTRUE)
	;; Both operands to GREATERP positive
	(JUMP-GREATER-THAN M-I A-J XTRUE)
	(POPJ-LESS-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-LESS-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FGRP-1	(JUMP-IF-BIT-CLEAR FLONUM-SIGN-BIT M-2 XFALSE)
	;; Both operands to GREATERP negative
	(JUMP-LESS-THAN M-I A-J XTRUE)
	(POPJ-GREATER-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-LESS-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FLSP	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-1 FLSP-1)
	(JUMP-IF-BIT-SET FLONUM-SIGN-BIT M-2 XFALSE)
	;; Both operands to LESSP positive
	(JUMP-LESS-THAN M-I A-J XTRUE)
	(POPJ-GREATER-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FLSP-1	(JUMP-IF-BIT-CLEAR FLONUM-SIGN-BIT M-2 XTRUE)
	;; Both operands to LESSP negative
	(JUMP-GREATER-THAN M-I A-J XTRUE)
	(POPJ-LESS-THAN-XCT-NEXT M-I A-J)
       ((M-T) A-V-NIL)	
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-1 A-2)
       ((M-T) A-V-TRUE)

FMAX	(CALL FLSP)
	(JUMP-EQUAL M-T A-V-NIL FIX-FMAX-FMIN-RETURN-ADDRESS)
	((M-1) M-2)
	((M-I) M-J)
FIX-FMAX-FMIN-RETURN-ADDRESS
	((M-TEM) MICRO-STACK-DATA-POP)
	(JUMP-EQUAL M-TEM (A-CONSTANT (I-MEM-LOC SFLPACK-P)) SFLPACK-T)
	(JUMP FLOPACK-T)

FMIN	(CALL FGRP)
	(JUMP-EQUAL M-T A-V-NIL FIX-FMAX-FMIN-RETURN-ADDRESS)
	((M-1) M-2)
	(JUMP-XCT-NEXT FIX-FMAX-FMIN-RETURN-ADDRESS)
       ((M-I) M-J)

XFLOAT-DOUBLE (MISC-INST-ENTRY %FLOAT-DOUBLE)
	(CALL FXGTPP)
	((M-1) DPB M-1 (BYTE-FIELD 24. 7) A-ZERO)
	((M-1) (BYTE-FIELD 7. 17.) M-2 A-1)
	(JUMP-EQUAL M-1 A-ZERO FLOAT-DOUBLE-2)
	((M-TEM) DPB M-2 (BYTE-FIELD 17. 15.) A-ZERO)
	((Q-R) M-TEM)
	((M-I) (A-CONSTANT 2057))
FLOAT-DOUBLE-1
	(JUMP-XCT-NEXT FLOPACK-T)
       (CALL FNORM)

FLOAT-DOUBLE-2
	((M-1) DPB M-2 (BYTE-FIELD 24. 7.) A-ZERO)
	((Q-R) A-ZERO)
	(JUMP-XCT-NEXT FLOAT-DOUBLE-1)
       ((M-I) (A-CONSTANT 2027)) 

;;;  Bignum arithmetic.

(DEF-DATA-FIELD BIGNUM-HEADER-SIGN 1 18.)
(DEF-DATA-FIELD BIGNUM-HEADER-LENGTH 18. 0)

ARITH-BIG-ANY
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T D-NUMARG2 (I-ARG NUMBER-CODE-BIGNUM))
    (ERROR-TABLE ARGTYP NUMBER M-T 1)	;not continuable, bignum could move
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((M-I) BIGNUM-HEADER-LENGTH M-C)
ARITH-BIG-SFL 
ARITH-BIG-FLO
	(CALL FLOAT-A-BIGNUM)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-FORWARD-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-Q 0)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-T)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))

ARITH-ANY-BIG
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) M-R D-ARITH-ANY-BIG)
       ((M-J) BIGNUM-HEADER-LENGTH M-D)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-ARITH-ANY-BIG
	(ARITH-FIX-BIG)
	(ARITH-SFL-BIG)
	(ARITH-FLO-BIG)
	(ARITH-BIG-BIG)
 (REPEAT NUM-UNUSED-NUMBER-CODES (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-SFL-BIG 
ARITH-FLO-BIG
	((M-TEM) M-I)
	((M-I) M-J)
	((M-J) M-TEM)
	((C-PDL-BUFFER-POINTER-PUSH) M-Q)
	((M-Q) M-T)
	((M-C) M-D)
	(CALL-XCT-NEXT FLOAT-A-BIGNUM)
       ((M-2) M-1)
	((M-T) C-PDL-BUFFER-POINTER-POP)
	(DISPATCH (BYTE-FIELD 4 0) M-A D-REVERSE-FLONUM-OPS)
    (ERROR-TABLE ARGTYP INTEGER M-T 1)
    (ERROR-TABLE ARG-POPPED 0 M-T M-Q)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC FLOPACK-P)))
	
ARITH-BIG
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-BIGNUM-1ARG)
       ((M-I) BIGNUM-HEADER-LENGTH M-C)

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-BIGNUM-1ARG
	(BIGNUM-ABS)
	(BIGNUM-MINUS)
	(XFALSE)		;ZEROP OF A BIGNUM!!!!!
	(BIGNUM-PLUSP)
	(BIGNUM-MINUSP)
	(BIGNUM-ADD1)
	(BIGNUM-SUB1)
	(BIGNUM-FIX)
	(BIGNUM-FLOAT)
	(BIGNUM-SMALL-FLOAT)
	(BIGNUM-HAULONG)
	(BIGNUM-LDB)
	(BIGNUM-DPB)
	(BIGASH)
	(BIGNUM-ODDP)
	(BIGNUM-EVENP)
 (REPEAT NUM-UNUSED-ARITH-1ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; Cons up a bignum.
;;; Inputs: M-B length+1, M-C sign in BIGNUM-HEADER-SIGN position
;;; Outputs: M-T boxed bignum, M-C sign/length part of header, M-E,M-K,M-S bashed
;;;          VMA same as M-T, MD header
;;; Note that M-1 and M-2 are preserved
BNCONS	(CALL SCONS-T)				;Cons in structure space, extra-pdl
	((M-TEM) SUB M-B (A-CONSTANT 1))	;Length to go in header
	((M-C) SELECTIVE-DEPOSIT M-C BIGNUM-HEADER-SIGN A-TEM)	;Incorporate sign
	((WRITE-MEMORY-DATA) ADD M-C		;Make rest of header
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
				  (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	(POPJ-AFTER-NEXT (VMA-START-WRITE M-T)	;Store header, fix M-T data type
		Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
       (CHECK-PAGE-WRITE)

;; MD has the header of the bignum whether got here from ABS or from GCD
BIGNUM-ABS
	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN MD BIGNUM-COPY)
       ((M-C) M-I)				;Positive-signed header
RETURN-M-Q
 	(POPJ-AFTER-NEXT (M-T) M-Q)
       (NO-OP)

BIGNUM-MINUS
	(JUMP-NOT-EQUAL M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-LENGTH 1))
			BIGNUM-MINUS-1)	;check for +setzness
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ) BIGNUM-MINUS-1)
	(POPJ-AFTER-NEXT (M-T) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
						 POSITIVE-SETZ)))
       (NO-OP)
BIGNUM-MINUS-1
	((M-C) XOR M-C (A-CONSTANT (BYTE-MASK BIGNUM-HEADER-SIGN)))
;bignum in M-Q, new header(sign) in M-C, Length in M-I. Result in M-T.
BIGNUM-COPY
	(CALL-XCT-NEXT BNCONS)			;ALLOCATE IN STRUCTURE EXTRA-PDL
       ((M-B) ADD M-I (A-CONSTANT 1))
BIGNUM-COPY-L
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE) ADD M-T A-I)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-I (A-CONSTANT 1) BIGNUM-COPY-L)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(POPJ)

DPB-BIGNUM-SETUP  ;CALL HERE TO SET UP FOR DOING A DPB, SEE RELEVANT CODE.
	((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)
	((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6) C-PDL-BUFFER-POINTER)
	((M-1) ADD M-K A-E)			;COMPUTE BIT POSITION OF LEFT EDGE OF BYTE
	((M-1) ADD M-1 (A-CONSTANT 31.))	;ROUND UP
		;Note the inclusion of one extra bit.  This is in case we produce
		;a negative "SETZ", which is 1 bit longer in sign-and-magnitude than
		;in 2's complement.
	(CALL-XCT-NEXT DIV)	;DIVIDE BY 31. TO GET NUMBER OF WORDS IN BIGNUM
       ((M-2) (A-CONSTANT 31.))	;RETURN QUOTIENT IN Q-R
	((M-B) Q-R)		;NEED AT LEAST THIS MANY WORDS.
BIGNUM-COPY-EXPAND   ;Copy bignum.  Resulting bignum to have at least M-B words of
		     ;significance.  Start with bignum in M-Q, header in M-C, current
		     ;length in M-I.  Result in M-T.  As a special hack, if M-I is zero,
		     ;just allocate a 0 bignum.
	(JUMP-GREATER-OR-EQUAL M-I A-B BIGNUM-COPY)     ;No expansion needed, just copy
	(CALL-XCT-NEXT BNCONS)				;Allocate in structure extra-pdl
       ((M-B) ADD M-B (A-CONSTANT 1))    		;Plus one for header
	((M-B) SUB M-B (A-CONSTANT 1))
	(CALL-NOT-EQUAL-XCT-NEXT M-I A-ZERO BIGNUM-COPY-L)	;Copy the number part (if any)
       ((M-ZR) SUB M-B A-I)		;Save how many words to zero
	((MD) A-ZERO)
BCE2	((VMA-START-WRITE) ADD M-T A-B)	;Zero out the new words.
	(CHECK-PAGE-WRITE)
	((M-ZR) SUB M-ZR (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-ZR A-ZERO BCE2)
       ((M-B) SUB M-B (A-CONSTANT 1))
	(POPJ)

BIGNUM-PLUSP
	((M-T) A-V-TRUE)		;CORRECT SINCE NO BIGNUM ZERO
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-NIL)

BIGNUM-MINUSP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-NIL)

BIGNUM-FIX
	(POPJ-AFTER-NEXT (M-T) M-Q)
       (NO-OP)

BIGNUM-HAULONG
	((VMA-START-READ) ADD M-Q A-I)	;GET HIGH ORDER WORD
	(CHECK-PAGE-READ)
	;; (length - 1) * 31. =  (length * 32.) - length - 31.
	;; XHAUL1 wants this in M-T  and the high bits in M-1.
	((M-T) DPB M-I (BYTE-FIELD 18. 5.) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-T) SUB M-T A-I)
	((M-T) SUB M-T (A-CONSTANT 31.))
	(JUMP-XCT-NEXT XHAUL1)
       ((M-1) MD)

BIGNUM-FLOAT
	(JUMP-XCT-NEXT FLOPACK-T)
       (CALL FLOAT-A-BIGNUM)

BIGNUM-SMALL-FLOAT
	(JUMP-XCT-NEXT SFLPACK-T)
       (CALL FLOAT-A-BIGNUM)

BIGNUM-ODDP
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))	;Low-order word
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT XFALSE)
       (JUMP-IF-BIT-SET (BYTE-FIELD 1 0) READ-MEMORY-DATA XTRUE)

BIGNUM-EVENP
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))	;Low-order word
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT XFALSE)
       (JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) READ-MEMORY-DATA XTRUE)

;;; Convert a bignum to a flonum.  Takes the length of the bignum in M-I,
;;; the bignum pointer in M-Q, the rest-of-header in M-C.  Leaves an internal-format
;;; flonum in M-I and M-1.  Clobbers M-4, M-3, M-1, M-K, M-TEM, M-T.  Must NOT clobber
;;; M-A, M-2 and M-J!
FLOAT-A-BIGNUM
	;; First get the second-to-highest order word into M-3.
	;; (If there is only one word, get zeroes.)
	(JUMP-EQUAL-XCT-NEXT M-I (A-CONSTANT 1) FLOAT-A-BIGNUM-X)
       ((M-3) A-ZERO)
	((M-TEM) SUB M-I (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q A-TEM)
	(CHECK-PAGE-READ)
	((M-3) MD)
FLOAT-A-BIGNUM-X
	;; Now get the highest order word in M-1 and get its length in M-T.
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-T) A-ZERO)
	(CALL-XCT-NEXT XHAUL1)
       ((M-1 C-PDL-BUFFER-POINTER-PUSH) MD) ;EVIL ON PDL BUFFER, BUT WILL BE POPPED SOON
	;; If M-T contains 31. then the mantissa is on the pdl
	;; no need to ldb/dpb anything (in fact it won't work!)
	(JUMP-EQUAL M-T (A-CONSTANT 31.) FLOAT-A-BIGNUM-31)
	;; Now piece together the mantissa of the flonum into M-1.
	;; First LDB from M-3, with:
	;;		BYTL-1 = (30. - M-T)	MROT = (32. - M-T)
	;; Then DPB from C-PDL-BUFFER-POINTER-POP into M-1, with:
	;;		BYTL-1 = (M-T - 1)	MROT = (31. - M-T)
	((M-TEM) SUB (M-CONSTANT 32.) A-T)
	((M-4) SUB M-TEM (A-CONSTANT 2))
	((OA-REG-LOW) DPB M-4 OAL-BYTL-1 A-TEM)
	((M-1) (BYTE-FIELD 0 0) M-3 A-ZERO)
	((OA-REG-LOW) M-TEM)			;Rotate first dropped bit into sign of M-3
	((M-3) (BYTE-FIELD 32. 0) M-3)
	((M-K) SUB M-T (A-CONSTANT 1))
	((M-TEM) ADD M-4 (A-CONSTANT 1))
	((OA-REG-LOW) DPB M-K OAL-BYTL-1 A-TEM)
	((M-1) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 0 0) A-1)
FLOAT-A-BIGNUM-DONE
	;; length in M-I   nbits (sig bits in high order word) in M-T
	;; (length - 1) * 31. + nbits + 2000 =  
	;;       (length * 32. + nbits) - length + 1741
	((M-T) DPB M-I (BYTE-FIELD 27. 5.) A-T) ;Clears data-type
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 31.) M-3 FLOAT-A-BIGNUM-EXIT)
       ((M-T) SUB M-T A-I)
	((M-1) ADD M-1 (A-CONSTANT 1))		;First dropped bit was a 1, round up
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 31.) M-1 FLOAT-A-BIGNUM-EXIT)
	((M-1) (BYTE-FIELD 31. 1) M-1)		;Overflowed, shift right and
	((M-T) ADD M-T (A-CONSTANT 1))		; increase exponent
FLOAT-A-BIGNUM-EXIT
	(POPJ-AFTER-NEXT (M-I) ADD M-T (A-CONSTANT 1741))
       (CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C FNEG1)

FLOAT-A-BIGNUM-31
	(JUMP-XCT-NEXT FLOAT-A-BIGNUM-DONE)
       ((M-1) C-PDL-BUFFER-POINTER-POP)


ARITH-BIG-BIG
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-FORWARD-BIGNUM-OPS)
       ((M-B) M-T)

(LOCALITY D-MEM)
;BIGNUMS IN M-B AND M-T, M-Q.  THEIR HEADERS IN M-D, M-C.  LENGTHS IN M-J, M-I.
(START-DISPATCH 4 0)
D-FORWARD-BIGNUM-OPS
	(BADD)
	(BSUB)
	(BMPY)
	(BDIV)
	(BEQL)
	(BGRP)
	(BLSP)
	(BMIN)
	(BMAX)
	(BBOOLE)
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

BEQL	(POPJ-NOT-EQUAL-XCT-NEXT M-C A-D)
       ((M-T) A-V-NIL)
BEQL1	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-1) MD)
	((VMA-START-READ) ADD M-B A-I)
	(CHECK-PAGE-READ)
	(POPJ-NOT-EQUAL MD A-1)
	(JUMP-GREATER-THAN-XCT-NEXT M-I (A-CONSTANT 1) BEQL1)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)
       (NO-OP)

;; this loops over two bignum's magnitudes (in M-Q,M-C,M-I and M-B,M-D,M-J) does nothing
;; if the first is larger than the second, puts M-E in M-T if they are equal
;; else moves M-A into M-T.  In any case POPJing out. Smashes M-I (which better equal M-J
;; anyway!!!!)

BSHFFL	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	((M-1) MD)
	((VMA-START-READ) ADD M-B A-I)
	(CHECK-PAGE-READ)
	(POPJ-LESS-THAN MD A-1)			;first is bigger so popj
	(JUMP-NOT-EQUAL MD A-1 BSHFFL-1)	;second is bigger, move and popj
	;equal continue looping
	(JUMP-GREATER-THAN-XCT-NEXT M-I (A-CONSTANT 1) BSHFFL)
       ((M-I) SUB M-I (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (M-T) M-E)		;all equal return M-E
       (NO-OP)

BSHFFL-1
	(POPJ-AFTER-NEXT NO-OP)
       ((M-T) M-A)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return T if first
;; is bigger than the second. Uses M-A and M-T and M-E
BGRP	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BGRP-1)
       ((M-E) A-V-NIL)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-TRUE)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) A-V-NIL)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) A-V-NIL)		;Both pos. Second longer.
       (NO-OP)

BGRP-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-NIL)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) A-V-TRUE)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)	;both neg. second longer.
       (NO-OP)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return T if second
;; is bigger than the first. Uses M-A and M-T and M-E
BLSP	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BLSP-1)
       ((M-E) A-V-NIL)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-NIL)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) A-V-TRUE)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)	;Both pos. Second longer.
       (NO-OP)

BLSP-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) A-V-TRUE)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) A-V-NIL)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) A-V-NIL)		;both neg. second longer.
       (NO-OP)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return the bigger one.
;; Uses M-A and M-T and M-E
BMAX	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BMAX-1)
       ((M-E) M-Q)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-Q)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) M-B)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) M-B)		;Both pos. Second longer.
       (NO-OP)

BMAX-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-B)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) M-Q)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) M-Q)		;both neg. second longer.
       (NO-OP)

;; compare two bignums (in M-Q,M-C,M-I and M-B,M-D,M-J) and return the smaller one.
;; Uses M-A and M-T and M-E
BMIN	(JUMP-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-C BMIN-1)
       ((M-E) M-Q)				;Value to return if equal
	(POPJ-IF-BIT-SET-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-B)				;First is pos., second is neg.
	(POPJ-GREATER-THAN M-I A-J)		;Both pos. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;Both pos. Same length so loop.
       ((M-A) M-Q)				;M-A gets alternate answer
	(POPJ-AFTER-NEXT (M-T) M-Q)		;Both pos. Second longer.
       (NO-OP)

BMIN-1	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-D)
       ((M-T) M-Q)				;First is neg. second is pos.
	(POPJ-GREATER-THAN M-I A-J)		;both neg. First longer.
	(JUMP-EQUAL-XCT-NEXT M-I A-J BSHFFL)	;both neg. same length so loop.
       ((M-A) M-B)				;M-A gets other answer
	(POPJ-AFTER-NEXT (M-T) M-B)		;both neg. second longer.
       (NO-OP)

;; For add and subtract build the answer in M-T,M-K . sign of answer is expected to
;; be the sign bit in M-C. First arg in M-Q,M-I second in M-R,M-J (note the move to M-R)

;; For addition we want the longest BIGNUM in M-R,M-J

BADD	((M-TEM) XOR M-C A-D)
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-TEM BSUB1) ;signs don't agree so subtract
BADD1	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-J A-I BADD2)
       ((M-2) A-ZERO)				;M-2 gets the carry
	((M-TEM) M-I)				;Swap if second isn't largest.
	((M-I) M-J)
	((M-J) M-TEM)
	((M-B) M-Q)				;M-T and M-B contain the same thing!
	((M-Q) M-T)
BADD2	((M-R) M-B)
	(CALL-XCT-NEXT BNCONS)			;Allocate result bignum
       ((M-B) ADD M-J (A-CONSTANT 2))
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((M-D) (A-CONSTANT 1))			;M-D counts up
BADD3	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-2)			;M-2 has carry from last round
	((VMA-START-READ) ADD M-R A-D)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-1)			;M-1 now has sum (carry and 31 bits out)
	((MD) (BYTE-FIELD 31. 0) M-1 A-ZERO)	;Write 31 bits
	((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)	;save carry
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I BADD3)
       ((M-D) ADD M-D (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-D A-J BADD4)	;Jump if lengths (M-I,M-J) were equal,
						; there are no more words to add in
;;FIXNUM - BIGNUM addition joins us here (can drop in)
;; Bignum in M-R,M-J. 1 (sometimes) in M-D. Fixnum in M-2. Answer in M-T with header in M-C.
BADD5	((VMA-START-READ) ADD M-R A-D)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-2)			;M-2 has carry
	((MD) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-J BADD5)	;M-J'th word is last in M-R bignum
       ((M-D) ADD M-D (A-CONSTANT 1))
BADD4	(JUMP-GREATER-THAN M-2 A-ZERO BADD6)	;There was some carry, so store in last word.
	((M-C) SUB M-C (A-CONSTANT 1))		;no carry so give word back.
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	((M-1) ADD M-T A-D)
	(JUMP-XCT-NEXT UN-CONS)
       ((M-2) (A-CONSTANT 1))

BADD6	((MD) M-2)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE)
	(POPJ)		;NO POPJ-AFTER-NEXT, COULD BE RETURNING TO MAIN LOOP

;; Subtraction:
BSUB	((M-TEM) XOR M-C A-D)
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-TEM BADD1)	;signs don't agree so add
;; first we shuffle the bignums around to be sure of subtracting the smaller magnitude
;; from the larger. Note that if we switch them then we must complement the sign bit in M-C.
BSUB1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	((M-R) M-T)				;will need M-T for answer
	(JUMP-GREATER-THAN-XCT-NEXT M-I A-J BSUB-OK)
       ((M-D) M-I)				;M-D gets the number of the last different word
	(JUMP-LESS-THAN M-I A-J BSUB-SWITCH)
	;drops in
;; they are the same length so count M-D down until you find a word that is different.
;; M-J is also kept equal to M-D since there is no need to remember the words out there
;; if when you subtract them you get zero.  (7623456123-7623456032 is the same as 123-032 !)
BSUB-L	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-J) M-D)
	((M-1) MD)
	((VMA-START-READ) ADD M-R A-D)
	(CHECK-PAGE-READ)
	(JUMP-LESS-THAN MD A-1 BSUB-OK)
	(JUMP-GREATER-THAN MD A-1 BSUB-SWITCH-1)
	(JUMP-GREATER-THAN-XCT-NEXT M-D (A-CONSTANT 1) BSUB-L)
       ((M-D) SUB M-D (A-CONSTANT 1))
	(POPJ-AFTER-NEXT
	 (M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;EQUAL!
       (NO-OP)

BSUB-SWITCH
	((M-TEM) M-I)				;Switch (but nobody cares about M-I)
	((M-D) M-J)
	((M-J) M-TEM)
BSUB-SWITCH-1
	((M-C) XOR M-C (A-CONSTANT (BYTE-MASK BIGNUM-HEADER-SIGN)))	;Switch sign bit.
	((M-R) M-Q)
	((M-Q) M-T)				;M-T still contains the original thing!

;; we have now cleverly arranged for M-D to be the length of the longest possible answer
;; M-Q,(M-I *) contain the bigger magnitude bignum M-R,M-J the smaller
;; correct sign bit of answer is in M-C, answer to be built in M-T,M-C (sign bit kept
;; in M-C)
;; (* note that we really don't care about M-I so we havn't actually made sure it contains
;; the correct thing)
BSUB-OK	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-D (A-CONSTANT 1))
	((M-2) A-ZERO)				;borrow
	((M-B) (A-CONSTANT 1))			;counter
BSUB-IT	((VMA-START-READ) ADD M-R A-B)
	(CHECK-PAGE-READ)
	((M-1) ADD MD A-2)
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-1) SUB MD A-1)
	((MD M-3) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE)
	(JUMP-EQUAL-XCT-NEXT M-3 A-ZERO BSUB-IT1)
       ((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)
	((M-E) M-B)				;M-E gets number of last non-zero word stored
BSUB-IT1
	(JUMP-LESS-THAN-XCT-NEXT M-B A-J BSUB-IT)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP-GREATER-THAN M-B A-D BCLEANUP)	;Jump if no more words to borrow into
;;FIXNUM - BIGNUM subtraction joins us here.
;; Bignum in M-Q,M-D (yes M-D!). 1 in M-B. Fixnum in M-2. Answer in M-T with header in M-C.
;; 1 should be in M-E (despite the fact that that might be wrong, the answer will be
;; spotted as a fixnum zero anyway!)
BSUB-C	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-1) SUB MD A-2)
	((MD M-3) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((VMA-START-WRITE) ADD M-T A-B)
	(CHECK-PAGE-WRITE)
	(JUMP-EQUAL-XCT-NEXT M-3 A-ZERO BSUB-C1)
       ((M-2) (BYTE-FIELD 1 31.) M-1 A-ZERO)
	((M-E) M-B)				;Index of last non-zero word
BSUB-C1 (JUMP-LESS-THAN-XCT-NEXT M-B A-D BSUB-C)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP BCLEANUP)

;; multiply two bignums.
BMPY	((M-R) M-T)
	((M-K) ADD M-I A-J)	;Possible length of answer
	((M-C) XOR M-C A-D)	;Sign in C is correct
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-K (A-CONSTANT 1))
	((M-K) BIGNUM-HEADER-LENGTH M-C)		;M-K was smashed by SCONS
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))

;; Now we have first arg in M-Q,M-I  second in M-R,M-J .  We are building the answer in
;; M-T,M-K .  The correct header for the answer lives in M-C.
;; M-S will index into the answer, M-D into first arg, M-E + 1 into second.
;; it must be true that M-D + M-E = M-S
;; the running total is kept in M-A,M-2,M-1
;; M-B gets M-J - 1 for comparison
;; M-ZR gets M-K - 1 for comparison
	((M-B) SUB M-J (A-CONSTANT 1))
	((M-ZR) SUB M-K (A-CONSTANT 1))
	((M-S) (A-CONSTANT 1))
	((M-A) A-ZERO)
	((M-1) A-ZERO)
	((M-2) A-ZERO)
BMPY-LOOP
	(JUMP-GREATER-THAN-XCT-NEXT M-S A-I BMPY-LOOP-1)
       ((M-D) M-I)
	((M-D) M-S)		;M-D gets min{M-I,M-S}
BMPY-LOOP-1
	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-E) SUB M-S A-D)
	((M-3) MD)
	((VMA-START-READ) M+A+1 M-R A-E)
	(CHECK-PAGE-READ)
	((Q-R) MD)
	;; Having loaded the 2 31 bit things to be multiplied into Q-R and M-3
	;; this will multiply them and add the result into M-A,M-2,M-1
	;; (31 bits in M-1 and M-2, less than 24 in M-A)
(REPEAT 31. ((M-1) MULTIPLY-STEP M-1 A-3))
	((M-1) ADD M-1 A-2)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 31.) M-1 BMPY-C)
       ((M-2) (BYTE-FIELD 31. 0) M-1 A-ZERO)
	((M-A) ADD M-A (A-CONSTANT 1))
BMPY-C	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-E A-B BMPY-LOOP-1-DONE)	;M-B = M-J - 1
       ((M-1) (BYTE-FIELD 31. 1) Q-R A-ZERO)
	(JUMP-GREATER-THAN-XCT-NEXT M-D (A-CONSTANT 1) BMPY-LOOP-1)
       ((M-D) SUB M-D (A-CONSTANT 1))
BMPY-LOOP-1-DONE
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-S)
	(CHECK-PAGE-WRITE)
	((M-1) M-2)
	((M-2) M-A)
	((M-A) A-ZERO)
	(JUMP-LESS-THAN-XCT-NEXT M-S A-ZR BMPY-LOOP)	;M-ZR = M-K - 1
       ((M-S) ADD M-S (A-CONSTANT 1))
	(JUMP-NOT-EQUAL M-1 A-ZERO BMPY-FULL)
	((M-C) SUB M-C (A-CONSTANT 1))		;Result 1 word shorter than expected
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	((M-1) ADD M-T A-K)
	(JUMP-XCT-NEXT UN-CONS)
       ((M-2) (A-CONSTANT 1))

BMPY-FULL
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-S)
	(CHECK-PAGE-WRITE)
	(POPJ)		;NO POPJ-AFTER-NEXT, MIGHT BE RETURNING TO MAIN LOOP

;;; Bignum - Bignum division: (algorithm from Knuth Vol 2)
BDIV
	;;If second bignum is longer than the first bignum then the answer is 0
	(JUMP-GREATER-THAN M-J A-I RETURN-ZERO)
	;;Get sign of answer into M-C by xoring with M-D
	((M-D) SELECTIVE-DEPOSIT BIGNUM-HEADER-SIGN M-D A-ZERO)
	((M-C) XOR M-C A-D)
	;;If second is one word long then we can do Bignum - Fixnum division
	(JUMP-GREATER-THAN-XCT-NEXT M-J (A-CONSTANT 1) BDIV-1)
       ((M-R) M-T)
	((VMA-START-READ) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT BFXDIV)
       ((M-2) MD)

BDIV-1
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	;;Allocate a bignum for the answer: (put it in M-A)
	((M-A) SUB M-I A-J)
	((M-A) ADD M-A (A-CONSTANT 1))	;Possible length of answer.
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-A (A-CONSTANT 1))
	(CALL-XCT-NEXT BDIV-REMAINDER-COMMON)
       ((M-A) M-T)
	;;M-Q,(M-I + 1) contains garbage. M-T,M-K contains the answer (with perhaps
	;; a zero in the top word). M-C has the correct sign bit for the answer.
	((M-1) M-Q)
	((M-2) ADD M-I (A-CONSTANT 2))
	(CALL-XCT-NEXT UN-CONS)
       ((M-Q) A-V-NIL)				;clear pointer to possible garbage
	((VMA-START-READ) ADD M-T A-K)		;Quotient may be 1 too long.
	(CHECK-PAGE-READ)
	((M-D) M-K)
	((M-E) M-D)
	(JUMP-NOT-EQUAL-XCT-NEXT MD A-ZERO BCLEANUP)
       ((M-C) SELECTIVE-DEPOSIT M-C BIGNUM-HEADER-SIGN A-K)
	(JUMP-XCT-NEXT BCLEANUP)
       ((M-E) SUB M-E (A-CONSTANT 1))

;Bignum-bignum remainder
; We enter with the first bignum in M-C the second in M-B and the header
; of the first still in MD.
REMAINDER-BIG-BIG
	((M-Q) M-C)
	((M-C) HEADER-REST-FIELD MD)
	((VMA-START-READ) M-B)
	(CHECK-PAGE-READ)
	((M-R) M-B)
	((M-I) BIGNUM-HEADER-LENGTH M-C)
	((M-J) BIGNUM-HEADER-LENGTH MD)
	;;If second bignum is longer than the first bignum then the answer is the first
	(JUMP-GREATER-THAN M-J A-I RETURN-M-Q)
	;;Sign of answer is already in M-C
	;;If second is one word long then do Bignum - Fixnum remainder
	(JUMP-GREATER-THAN M-J (A-CONSTANT 1) BDIVR-2)
	((VMA-START-READ) ADD M-R (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-B) M-Q)
	((M-2) MD)
	((M-A) BIGNUM-HEADER-SIGN M-C)
	((M-C) BIGNUM-HEADER-LENGTH M-C)
	(CALL REMAINDER-BIG-FIX-1)
	(JUMP RETURN-M-1)

BDIVR-2
	(CALL-XCT-NEXT BDIV-REMAINDER-COMMON)
       ((M-A) A-ZERO)		;Indicate that quotient is not being saved.
	;;Now we have the remainder in M-Q,(M-I + 1) possibly shifted by
	;; an amount determined by
	;; the haulong still(!) in M-D. Sign of answer is still in M-C
	;;To shift back we perform an operation similar to BDIV-NORMALIZE:
	;; First we LDB from the current word with: (M-K)
	;;		BYTL-1 = Haulong - 1
	;;		MROT = Haulong + 1
	;; Then we DPB into that from the next higher word with: (M-S)
	;;		BYTL-1 = 30. - haulong
	;;		MROT = Haulong
	(JUMP-EQUAL-XCT-NEXT M-D (A-CONSTANT 31.) BDIVR-3)
       ((M-T) M-Q)
	((M-K) ADD M-D (A-CONSTANT 1))		;MROT
	((M-TEM) SUB M-D (A-CONSTANT 1))	;BYTL-1
	((M-K) DPB M-TEM OAL-BYTL-1 A-K)	;For LDB
	((M-TEM) (A-CONSTANT 30.))
	((M-TEM) SUB M-TEM A-D)			;BYTL-1, MROT in M-D
	((M-S) DPB M-TEM OAL-BYTL-1 A-D)	;For DPB
	((M-D) (A-CONSTANT 1))			;Counts through the bignum
	((M-E) (A-CONSTANT 1))			;Gets number of last non-zero word
	((VMA-START-READ) ADD M-T A-D)
	(CHECK-PAGE-READ)
	((M-1) MD)				;M-1 has word from last round.
BDIVR-UNNORMALIZE-LOOP
	((VMA-START-READ) M+A+1 M-T A-D)
	(CHECK-PAGE-READ)
	((OA-REG-LOW) M-K)
	((M-2) (BYTE-FIELD 0 0) M-1 A-ZERO)	;LDB out of lower word
	((M-1) MD)
	((OA-REG-LOW) M-S)
	((MD M-2) DPB M-1 (BYTE-FIELD 0 0) A-2)	;DPB in from higher word
	((VMA-START-WRITE) ADD M-T A-D)		;Put back into lower word
	(CHECK-PAGE-WRITE)
	(JUMP-EQUAL M-2 A-ZERO BDIVR-UNNORMALIZE-1)
	((M-E) M-D)
BDIVR-UNNORMALIZE-1
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I BDIVR-UNNORMALIZE-LOOP)
       ((M-D) ADD M-D (A-CONSTANT 1))
	(JUMP-XCT-NEXT BCLEANUP)
       ((M-C) SELECTIVE-DEPOSIT BIGNUM-HEADER-SIGN M-C A-D)

BDIVR-3	;;In this case (no shifting necessary) we must loop downward looking
	;; for the first non-zero word.  Cannot share code with BIGNUM-DPB-CLEANUP.
	((M-D) ADD M-I (A-CONSTANT 1))
	((M-C) SELECTIVE-DEPOSIT BIGNUM-HEADER-SIGN M-C A-D)
	((M-E) M-D)				;Counts down bignum
BDIVR-4	((VMA-START-READ) ADD M-T A-E)
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD A-ZERO BCLEANUP)
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 2) BDIVR-4)
       ((M-E) SUB M-E (A-CONSTANT 1))
	(JUMP BCLEANUP)			;Only one significant word

BDIV-REMAINDER-COMMON 
	;;allocate a temporary bignum one word longer than first arg (put it in M-D)
	;; If Bignum remainder got us here then this bignum will BE the answer
	(CALL-XCT-NEXT SCONS-T)
       ((M-B) ADD M-I (A-CONSTANT 2))
	((M-TEM) ADD M-I (A-CONSTANT 1))
	((MD) ADD M-TEM (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					  (BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-D) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE)
	;;Now do a haulong on the high order word of second arg (for normalization)
	;; note that if the answer is 31. then there is no need to normalize or allocate
	;; a second temporary bignum
	((VMA-START-READ) ADD M-R A-J)
	(CHECK-PAGE-READ)
	((M-T) A-ZERO)
	(CALL-XCT-NEXT XHAUL1)
       ((M-1) MD)
	(JUMP-EQUAL-XCT-NEXT M-T (A-CONSTANT 31.) BDIV-PUNT-NORMALIZING)
       ((M-1) M-T)		;hide away haulong for later
	;;allocate another temporary bignum as long as the second and keep it in M-T
	(CALL-XCT-NEXT SCONS-T)
       ((M-B) ADD M-J (A-CONSTANT 1))
	((MD) ADD M-J (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-T) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE)
	;;So now we build the proper constants from saved haulong in M-1
	;; for ldbing (in M-K) and dpbing (in M-S) to normalize (see comment in front
	;; of BDIV-NORMALIZE)
	(CALL BDIV-NORMALIZE-ENCODE-SHIFT)
	;;Perform normalization (subroutine takes old bignum in M-B and new in M-D
	;; steps length in M-ZR, bashes M-4)
	((M-E) A-ZERO)		;No offset for BDIV-NORMALIZE.
	((M-B) M-Q)
	((M-ZR) M-I)
	(CALL-XCT-NEXT BDIV-NORMALIZE)
       ((M-2) A-ZERO)
	((M-Q) M-D)		;Replace original dividend with copy
	;;Prepare to call it again:
	((VMA-START-READ) ADD M-R A-J)
	(CHECK-PAGE-READ)
	((M-D) M-T)
	((M-B) M-R)
	((OA-REG-LOW) M-S)
	((M-2) DPB MD (BYTE-FIELD 0 0) A-ZERO)
	(CALL-XCT-NEXT BDIV-NORMALIZE)
       ((M-ZR) SUB M-J (A-CONSTANT 1))
	(JUMP-XCT-NEXT BDIV-READY)
       ((M-R) M-D)		;Replace original divisor with copy

BDIV-PUNT-NORMALIZING
	;;In this case all we do is copy the first arg:
	((M-ZR) M-I)
BDIV-PUNT-NORMALIZING-1
	((VMA-START-READ) ADD M-Q A-ZR)
	(CHECK-PAGE-READ)
	((WRITE-MEMORY-DATA) READ-MEMORY-DATA)
	((VMA-START-WRITE) ADD M-D A-ZR)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-ZR (A-CONSTANT 1) BDIV-PUNT-NORMALIZING-1)
       ((M-ZR) SUB M-ZR (A-CONSTANT 1))
	((MD) A-ZERO)
	((VMA-START-WRITE) M+A+1 M-D A-I)
	(CHECK-PAGE-WRITE)
	((M-Q) M-D)		;Replace original dividend with copy
BDIV-READY
	((M-T) M-A)		;Answer will wind up in M-T so why not now?
				;If remainder then this is a zero.
	((M-K) SUB M-I A-J)
	((M-K) ADD M-K (A-CONSTANT 1))
	((C-PDL-BUFFER-POINTER-PUSH) M-1)		;Saved haulong
	;;So now the situation is as follows: The sign of the answer is in
	;; BIGNUM-HEADER-SIGN in M-C. The old haulong of the top word of the second
	;; argument is on top of the PDL (We have to save
	;; that information so we know wether or not to un-cons!) We have a bignum
	;; in M-Q,(M-I + 1) that we are dividing by a normalized bignum in M-R,M-J.
	;; Answer is being built in M-T,M-K. (M-T = 0 if remaindering.)
	((M-S) M-K)			;M-S will count down through the answer
	((M-E) M-I)			;M-E will step down bignum in M-Q
	((VMA-START-READ) ADD M-R A-J)
	(CHECK-PAGE-READ)
	((A-BDIV-V1) MD)				;V1
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((A-BDIV-V2) MD)				;V2
BDIV-LOOP
	;;Now we are ready to make an estimate of what that first 31. bits will be.
	;;Comments are notation from Knuth.
	((VMA-START-READ) M+A+1 M-Q A-E)
	(CHECK-PAGE-READ)
	((M-3) MD)					;U0
	((VMA-START-READ) ADD M-Q A-E)
	(CHECK-PAGE-READ)
	(JUMP-EQUAL M-3 A-BDIV-V1 BDIV-SIMPLE-CASE)
	((M-TEM) DPB M-3 (BYTE-FIELD 1 31.) A-ZERO)
	((Q-R) IOR MD A-TEM)				;low 32. bits of U0 * B + U1
	((M-3) (BYTE-FIELD 30. 1) M-3 A-ZERO)		;high 30. bits of same
	((M-1) A-BDIV-V1)				;Divide by V1
	;; Compute QHAT = Floor((U0 * B + U1) / V1) and RHAT = U0 * B + U1 - QHAT * V1
	((M-3) DIVIDE-FIRST-STEP M-3 A-1)
(REPEAT 31. ((M-3) DIVIDE-STEP M-3 A-1))
	((M-3) DIVIDE-LAST-STEP M-3 A-1)
	((M-3) DIVIDE-REMAINDER-CORRECTION-STEP M-3 A-1);RHAT
	(JUMP-XCT-NEXT BDIV-OPTIMIZE-QHAT)
       ((M-1) Q-R)					;QHAT

BDIV-SIMPLE-CASE
	((M-1) (A-CONSTANT 17777777777))		;QHAT = B - 1
	((M-3) ADD MD A-BDIV-V1)			;RHAT = U1 + V1
	;; If sign bit of M-3 is set then we know that RHAT * B + U2 is greater
	;; than QHAT * V2:
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 31.) M-3 BDIV-QHAT-IS-GOOD)
BDIV-OPTIMIZE-QHAT
	;;Now in order to check if RHAT * B + U2 < QHAT * V2 we first read in U2
	;; and then compute QHAT * V2 .
	((M-TEM) SUB M-E (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q A-TEM)
	(CHECK-PAGE-READ)
	((Q-R) A-BDIV-V2)
	(CALL-XCT-NEXT MPY)
       ((M-4) MD)					;U2
	((M-2) M-2 OUTPUT-SELECTOR-LEFTSHIFT-1)		;BRING IN HIGH BIT OF Q
	;;Now M-2 = High(QHAT * V2)
	;;    M-3 = RHAT = High(RHAT * B + U2)
	;;    M-4 = U2 = Low(RHAT * B + U2)
	;;    M-1 = QHAT
	;;    Q-R = Low(QHAT * V2) plus junk in sign bit
	(JUMP-GREATER-THAN M-3 A-2 BDIV-QHAT-IS-GOOD)
	((M-TEM) (BYTE-FIELD 31. 0) Q-R A-ZERO)		;Low(QHAT * V2)
	(JUMP-LESS-THAN M-3 A-2 BDIV-OPTIMIZE-QHAT-SUB1)
	(JUMP-GREATER-OR-EQUAL M-4 A-TEM BDIV-QHAT-IS-GOOD)
BDIV-OPTIMIZE-QHAT-SUB1
	;; So QHAT must be decremented and other quantities adjusted:
	((M-TEM) SUB M-TEM A-BDIV-V2)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 31.) M-TEM BDIV-2);carry into High(QHAT * V2)
       ((M-3) ADD M-3 A-BDIV-V1)			;Adjust RHAT
	((M-TEM) (BYTE-FIELD 31. 0) M-TEM A-ZERO)
	((M-2) SUB M-2 (A-CONSTANT 1))
BDIV-2
 	;;If M-3 is negative then RHAT * B + U2 overflew and must be greater than
	;; QHAT * V2
	(JUMP-IF-BIT-SET-XCT-NEXT (BYTE-FIELD 1 31.) M-3 BDIV-QHAT-IS-GOOD)
       ((M-1) SUB M-1 (A-CONSTANT 1))			;Decrement QHAT
	(JUMP-GREATER-THAN M-3 A-2 BDIV-QHAT-IS-GOOD)
	(JUMP-LESS-THAN M-3 A-2 BDIV-OPTIMIZE-QHAT-SUB2)
	(JUMP-GREATER-OR-EQUAL M-4 A-TEM BDIV-QHAT-IS-GOOD)
BDIV-OPTIMIZE-QHAT-SUB2
	((M-1) SUB M-1 (A-CONSTANT 1))			;Decrement QHAT second time.
BDIV-QHAT-IS-GOOD
	;;QHAT contains the wrong thing only once every 716 million times!
	;;We multiply divisor by QHAT and subtract from dividend
	((M-A) (A-CONSTANT 1))			;steps through M-R
	((M-B) SUB M-E A-J)
	((M-B) ADD M-B (A-CONSTANT 1))		;steps through M-Q
	((M-ZR) A-ZERO)				;borrow from last round
	((M-2) A-ZERO)				;for multiplication scratch
BDIV-MPY-LOOP
	((VMA-START-READ) ADD M-R A-A)
	(CHECK-PAGE-READ)
	((Q-R) MD)
(REPEAT 31. ((M-2) MULTIPLY-STEP M-2 A-1))
	((M-D) (BYTE-FIELD 31. 1) Q-R A-ZERO)	;Now M-D might contain gubbish.
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-TEM) SUB MD A-D)
	((M-TEM) SUB M-TEM A-ZR)
	((MD) (BYTE-FIELD 31. 0) M-TEM A-ZERO)
	((M-ZR) (BYTE-FIELD 1 31.) M-TEM A-ZERO)
	((VMA-START-WRITE) ADD M-Q A-B)
	(CHECK-PAGE-WRITE)
	((M-A) ADD M-A (A-CONSTANT 1))
	(JUMP-LESS-THAN-XCT-NEXT M-B A-E BDIV-MPY-LOOP)
       ((M-B) ADD M-B (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-4) SUB MD A-2)
	((MD-START-WRITE M-4) SUB M-4 A-ZR)
	(CHECK-PAGE-WRITE)
	(CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-4 BDIV-ONCE-IN-716MILLION) ;DAMN! QHAT too big.
	(JUMP-EQUAL-XCT-NEXT M-T A-ZERO BDIV-DONT-STORE)	;write QHAT into quotient
       ((M-E) SUB M-E (A-CONSTANT 1))				;If not remaindering
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-S)
	(CHECK-PAGE-WRITE)
BDIV-DONT-STORE
	(JUMP-GREATER-THAN-XCT-NEXT M-S (A-CONSTANT 1) BDIV-LOOP)
       ((M-S) SUB M-S (A-CONSTANT 1))
	;;Now we have the answer so we give up any temp. storage and cleanup the answer.
	((M-D) C-PDL-BUFFER-POINTER-POP)	;Clears any gubbish from M-D
	;;Now M-D contains the haulong of high word of original M-R
	(POPJ-EQUAL M-D (A-CONSTANT 31.))
	((M-1) M-R)
	((M-2) ADD M-J (A-CONSTANT 1))
	(JUMP-XCT-NEXT UN-CONS)			;Tail recursive call
       ((M-R) A-V-NIL)				;clear pointer to possible garbage

;;We come here in the case where QHAT was 1 too large, we must add divisor back into
;; dividend once.
BDIV-ONCE-IN-716MILLION
	((M-A) (A-CONSTANT 1))			;steps through M-R
	((M-B) SUB M-E A-J)
	((M-B) ADD M-B (A-CONSTANT 1))		;steps through M-Q
	((M-ZR) A-ZERO)				;carry
BDIV-ONCE-IN-716MILLION-1
	((VMA-START-READ) ADD M-R A-A)
	(CHECK-PAGE-READ)
	((M-4) ADD MD A-ZR)
	((VMA-START-READ) ADD M-Q A-B)
	(CHECK-PAGE-READ)
	((M-4) ADD MD A-4)
	((M-ZR) (BYTE-FIELD 1 31.) M-4 A-ZERO)
	((MD-START-WRITE) (BYTE-FIELD 31. 0) M-4 A-ZERO)
	(CHECK-PAGE-WRITE)
	((M-A) ADD M-A (A-CONSTANT 1))
	(JUMP-LESS-THAN-XCT-NEXT M-B A-E BDIV-ONCE-IN-716MILLION-1)
       ((M-B) ADD M-B (A-CONSTANT 1))
	((MD) A-ZERO)		;Keep remainder correct.
	((VMA-START-WRITE) ADD M-Q A-B)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT (M-1) SUB M-1 (A-CONSTANT 1))	;decrement QHAT
       (NO-OP)

;;; Set up args for the below from shift in M-1
BDIV-NORMALIZE-ENCODE-SHIFT
	((M-TEM) SUB (M-CONSTANT 32.) A-1)	;MROT = 32. - Haulong
	((M-K) SUB M-TEM (A-CONSTANT 2))	;BYTL-1 = 30. - Haulong
	((M-K) DPB M-K OAL-BYTL-1 A-TEM)	;M-K constant for LDBing
	((M-TEM) SUB M-TEM (A-CONSTANT 1))	;MROT = 31. -Haulong
	(POPJ-AFTER-NEXT
	 (M-S) SUB M-1 (A-CONSTANT 1))		;BYTL-1 = Haulong - 1
       ((M-S) DPB M-S OAL-BYTL-1 A-TEM)		;M-S constant for DPBing

;;; Subroutine for normalizing bignums:
;;; Does a left shift using M-K to ldb from C(M-B + M-ZR) into M-2 and stored at
;;; (M-D + A-ZR + 1 + M-E), and then dpb using M-S from C(M-B + M-ZR) into M-2 for the
;;; next time around:
;;;
;;;	|0| X |  Y  |	becomes:	|0|  Y  |   |  ;left in M-2 for next round.
;;;	|0|   |     |			|0|     | X |  ;written out with high half
;;;						       ; from last round.
;;; 
;;; M-K is the LDB pointer for X.  The thing initially in M-1 is the width of Y.
;;; M-S is the DPB pointer for Y.
;;;
;;; M-4 is bashed. M-2 can be loaded with whatever you want in the high part of the
;;; first word written (at M-D + M-ZR + 1 + M-E), you also load M-ZR
;;;Note that M-E is an offset in words to shift the bignum, that many words of zeros
;;; will be placed in the low bits of the bignum in M-D.
;;;This is crocked to work if M-E is 0, but not if it is negative!
;;; But -1 in M-E causes the bottom word (the final Y) of the bignum
;;; in M-D to disappear (for ASH).
BDIV-NORMALIZE
	(JUMP-EQUAL M-ZR A-ZERO BDIV-NORMALIZE-0)
	((VMA-START-READ) ADD M-B A-ZR)
	(CHECK-PAGE-READ)
	((OA-REG-LOW) M-K)
	((M-4) (BYTE-FIELD 0 0) MD A-2)
	((OA-REG-LOW) M-S)
	((M-2) DPB MD (BYTE-FIELD 0 0) A-ZERO)
	((MD) M-4)
	((M-4) ADD M-ZR A-E)
	((VMA-START-WRITE) M+A+1 M-D A-4)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-ZR (A-CONSTANT 1) BDIV-NORMALIZE)
       ((M-ZR) SUB M-ZR (A-CONSTANT 1))
BDIV-NORMALIZE-0
	(POPJ-LESS-THAN M-E A-ZERO)
	((MD) M-2)
	((VMA-START-WRITE) M+A+1 M-D A-E)
       	(CHECK-PAGE-WRITE)
	(POPJ-EQUAL M-E A-ZERO)
	((MD) A-ZERO)
BDIV-NORMALIZE-1
	((VMA-START-WRITE) ADD M-D A-E)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) BDIV-NORMALIZE-1)
       ((M-E) SUB M-E (A-CONSTANT 1))
	(POPJ)

ARITH-FIX-BIG
	((M-2) M-1)	;UNPACKED FIXNUM ARG
	((M-Q) M-T)	;BIGNUM ITSELF (SECOND ARG)
	((M-C) M-D)	;BIGNUM HEADER
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-FIXNUM-BIGNUM-OPS)
       ((M-I) M-J)      ;BIGNUM LENGTH

(LOCALITY D-MEM)
;FIXNUM IN BOTH M-1, M-2.  BIGNUM IN BOTH M-Q, M-T.  HEADER IN M-C, M-D.  LENGTH IN M-I, M-J.
(START-DISPATCH 4 0)
D-FIXNUM-BIGNUM-OPS
	(FXBADD)
	(FXBSUB)
	(FXBMPY)
	(FXBDIV)
	(XFALSE)			;Fixnum = Bignum ???
	(FXBGRP)
	(FXBLSP)
	(FXBMIN)
	(FXBMAX)
	(FXBBOOLE)
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

ARITH-BIG-FIX
	(DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-A D-BIGNUM-FIXNUM-OPS)
       (NO-OP)

(LOCALITY D-MEM)
;FIXNUM IN M-T, UNPACKED INTO M-2.
;BIGNUM IN M-Q, HEADER IN M-C, LENGTH IN M-I.
(START-DISPATCH 4 0)
D-BIGNUM-FIXNUM-OPS
	(BFXADD)
	(BFXSUB)
	(BFXMPY)
	(BFXDIV)
	(XFALSE)			;Bignum = Fixnum ???
	(BFXGRP)
	(BFXLSP)
	(BFXMIN)
	(BFXMAX)
	(BFXBOOLE)
 (REPEAT NUM-UNUSED-ARITH-2ARGS (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
(END-DISPATCH)
(LOCALITY I-MEM)

FXBSUB	(JUMP-XCT-NEXT FXBADD0)
       ((M-C) XOR M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-SIGN 1)))

FXBRETQ	(POPJ-AFTER-NEXT	;RETURN BIGNUM ARG.
	 (M-T) Q-TYPED-POINTER M-Q)
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE   ;LEAVE RESULT BOTH PLACES
			 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))  ;FOR GOOD MEASURE.

BFXSUB	((M-2) SUB M-ZERO A-2)	;NO SETZ PROBLEMS!
BFXADD 
FXBADD	(JUMP-EQUAL M-2 A-ZERO FXBRETQ)  ;SPECIAL CASE IF ADDING ZERO, JUST RETURN OTHER GUY
FXBADD0	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-2 A-ZERO BFXADD-1)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	((M-2) SUB M-ZERO A-2)			;Make positive
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BFXADD-ADD)
BFXADD-SUB	;M-Q/M-I bignum, M-2 positive number to be subtracted
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((M-D) M-I)
	((M-B) (A-CONSTANT 1))
	(JUMP-XCT-NEXT BSUB-C)
       ((M-E) (A-CONSTANT 1))

BFXADD-1
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BFXADD-SUB)
BFXADD-ADD	;M-Q/M-I bignum, M-2 positive number to be added
	(CALL-XCT-NEXT BNCONS)			;ALLOCATE IN STRUCTURE EXTRA-PDL
       ((M-B) ADD M-I (A-CONSTANT 2))
	((M-I) ADD M-I (A-CONSTANT 1))
	((M-R) M-Q)
	((M-J) SUB M-I (A-CONSTANT 1)) ;Recover length of bignum in M-Q (M-R)
	(JUMP-XCT-NEXT BADD5)
       ((M-D) (A-CONSTANT 1))

BIGNUM-ADD1
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-C BFXADD-ADD)
       ((M-2) (A-CONSTANT 1))
	(JUMP BFXADD-SUB)

BIGNUM-SUB1
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-C BFXADD-SUB)
       ((M-2) (A-CONSTANT 1))
	(JUMP BFXADD-ADD)

RETURN-ZERO
	(POPJ-AFTER-NEXT (M-T C-PDL-BUFFER-POINTER-PUSH)
		(A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
				  (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
       (NO-OP)

;; A fixnum multiplied by a bignum can yield a fixnum in just two cases(!):
BFXMPY 
FXBMPY	(JUMP-EQUAL M-2 A-ZERO RETURN-ZERO)	;0*X=0
	(JUMP-NOT-EQUAL M-2 A-MINUS-ONE BFXMPY-OK)	;(-1)*(+SETZ)=(-SETZ)
	(JUMP-NOT-EQUAL M-I (A-CONSTANT 1) BFXMPY-OK)
	((VMA-START-READ) ADD M-Q A-I)
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ) BFXMPY-OK)
	(POPJ-AFTER-NEXT (M-T C-PDL-BUFFER-POINTER-PUSH)
		Q-POINTER MD (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
					       (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
       (NO-OP)

BFXMPY-OK
	(JUMP-GREATER-OR-EQUAL M-2 A-ZERO BFXMPY-1)
	((M-2) SUB M-ZERO A-2)			;NEGATIVE FIXNUM, CHANGE SIGN OF RESULT
	((M-C) XOR M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-SIGN 1)))
BFXMPY-1
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 2))
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
					 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	(CALL-XCT-NEXT MULTIPLY-ONCE)
       ((M-1) A-ZERO)
	((MD) M-1)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE)
	(POPJ-NOT-EQUAL M-1 A-ZERO)
	((M-C) SUB M-C (A-CONSTANT 1))
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	((M-1) ADD M-T A-D)
	(JUMP-XCT-NEXT UN-CONS)
       ((M-2) (A-CONSTANT 1))

;; MULTIPLY-ONCE multiplies a bignum in M-Q,M-I by a fixnum in M-2 and adds the fixnum in M-1.
;; Writes answer M-T (as if it is a bignum). Leaves last word (not written) in M-1.
;; Bashes M-D to be M-I + 1
MULTIPLY-ONCE
	((M-D) (A-CONSTANT 1))
BFXMPY-LOOP
	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((Q-R) MD)
(REPEAT 31. ((M-1) MULTIPLY-STEP M-1 A-2))
	((M-1) (BYTE-FIELD 31. 0) M-1)
	((MD) (BYTE-FIELD 31. 1) Q-R)
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I BFXMPY-LOOP)
       ((M-D) ADD M-D (A-CONSTANT 1))
	(POPJ)

BFXDIV
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC M-T-TO-CPDL)))
	(CALL-EQUAL M-2 A-ZERO TRAP)
		(ERROR-TABLE DIVIDE-BY-ZERO)
		(ERROR-TABLE ARG-POPPED M-Q M-T)
	(JUMP-GREATER-THAN M-2 A-ZERO BFXDIV-1)
	((M-C) XOR M-C (A-CONSTANT (BYTE-VALUE BIGNUM-HEADER-SIGN 1)))	;If fixnum is negative
	((M-2) SUB M-ZERO A-2)	;then change sign of both args.
BFXDIV-1
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((M-R) M-T)
	(CALL-XCT-NEXT DIVIDE-ONCE)	;divide once stores into bignum in M-R,M-J
       ((M-J) M-I)
	((M-D) M-I)		;current length
	((VMA-START-READ) ADD M-T A-D)	;read last word to see if it is zeros
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL-XCT-NEXT MD A-ZERO BCLEANUP)	;not zeros
       ((M-E) M-D)
	(JUMP-XCT-NEXT BCLEANUP)	;zeros so length should be M-D - 1
       ((M-E) SUB M-E (A-CONSTANT 1))

;; DIVIDE-ONCE divides bignum in M-Q,M-I by positive(!) number in M-2.
;; bashes M-1 M-3 M-TEM M-D
;; answer is stored in M-R,M-J
;; remainder is left in M-1
DIVIDE-ONCE
	((M-1) A-ZERO)
	((M-3) (A-CONSTANT 1))
	((M-D) M-I)
DIVIDE-ONCE-L
	((VMA-START-READ) ADD M-Q A-D)
	(CHECK-PAGE-READ)
	((M-TEM) DPB M-3 (BYTE-FIELD 30. 1) A-ZERO)
	((A-TEM1) DPB MD (BYTE-FIELD 31. 1) A-3)
	((Q-R) A-TEM1)
(REPEAT 31. ((M-1) DIVIDE-STEP M-1 A-2))
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-D A-J DIVIDE-ONCE-1)
       ((M-3) Q-R)			;Save Q-R which is bashed by page faults
	((MD) (BYTE-FIELD 1 30.) Q-R A-TEM)
	((VMA-START-WRITE) M+A+1 M-R A-D)
	(CHECK-PAGE-WRITE)
DIVIDE-ONCE-1
	(JUMP-GREATER-THAN-XCT-NEXT M-D (A-CONSTANT 1) DIVIDE-ONCE-L)
       ((M-D) SUB M-D (A-CONSTANT 1))
	((Q-R) M-3)
	((M-1) DIVIDE-LAST-STEP M-1 A-2)
	((M-1) DIVIDE-REMAINDER-CORRECTION-STEP M-1 A-2)
	((MD) (BYTE-FIELD 31. 0) Q-R)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) ADD M-R (A-CONSTANT 1))
       (CHECK-PAGE-WRITE)

;Fixnum divided by bignum is 0 except for -setz over +setz which is -1
FXBDIV
	(POPJ-NOT-EQUAL-XCT-NEXT M-2 (A-CONSTANT NEGATIVE-SETZ))
       ((M-T C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
							  (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	(POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
	(POPJ-NOT-EQUAL M-I (A-CONSTANT 1))
	((VMA-START-READ) ADD M-Q (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT POPJ-NOT-EQUAL MD (A-CONSTANT POSITIVE-SETZ))
       ((M-T C-PDL-BUFFER-POINTER) DPB M-MINUS-ONE Q-POINTER A-T)

BFXGRP 
FXBLSP
	((M-T) A-V-NIL)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-TRUE)

BFXLSP 
FXBGRP
	((M-T) A-V-TRUE)
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) A-V-NIL)

BFXMIN 
FXBMIN
	((M-T) M-Q)			;neg. bignums are less than fixnums!
	(POPJ-AFTER-NEXT POPJ-IF-BIT-SET BIGNUM-HEADER-SIGN M-C)
       ((M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	
BFXMAX 
FXBMAX
	((M-T) M-Q)			;positive bignums are greater than fixnums!
	(POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR BIGNUM-HEADER-SIGN M-C)
       ((M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))


;; First arg a bignum second a fixnum.  The bignum is expressed in the base of the fixnum
;; and stuffed in to an appropriate art-q array.
(MISC-INST-ENTRY BIGNUM-TO-ARRAY)
BIG-TO-ARY
	((M-A) C-PDL-BUFFER-POINTER-POP)
	((M-Q) C-PDL-BUFFER-POINTER-POP)
    (ERROR-TABLE RESTART BIG-TO-ARY)
	((M-TEM) Q-DATA-TYPE M-Q)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) TRAP)
    (ERROR-TABLE ARGTYP BIGNUM M-Q 0 BIG-TO-ARY)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-A)
	(DISPATCH Q-DATA-TYPE M-A TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-A 1 BIG-TO-ARY)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-A)
	((VMA-START-READ) M-Q)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
	((M-TEM) HEADER-TYPE-FIELD MD)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)) TRAP)
    (ERROR-TABLE ARGTYP BIGNUM M-Q 0 BIG-TO-ARY)
    (ERROR-TABLE ARG-POPPED 0 M-Q M-A)
	((M-Q) VMA)		;get transported number address 
	((M-I) BIGNUM-HEADER-LENGTH MD)
	((M-1) Q-POINTER M-A)
	(CALL-XCT-NEXT XHAUL1)	;M-T gets number of bits in M-A LESS ONE(!)
       ((M-T) A-MINUS-ONE)
	;; we must allocate an array at least 31*I/T long
	;; 31*I = 32*I - I
	((M-1) DPB M-I (BYTE-FIELD 18. 5) A-ZERO)
	((M-1) SUB M-1 A-I)
	(CALL-XCT-NEXT DIV)
       ((M-2) Q-POINTER M-T)
	(JUMP-EQUAL-XCT-NEXT M-1 A-ZERO BIG-TO-ARY-1)	;If no remainder then we are o.k.
       ((M-C) Q-R)
	((M-C) ADD M-C (A-CONSTANT 1))	;with remainder then allocate 1 more
BIG-TO-ARY-1
	(CALL-XCT-NEXT SCONS-D)	;Allocate space for art-q array
       ((M-B) ADD M-C (A-CONSTANT 2))
	((MD) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-HEADER)
				(BYTE-VALUE %%ARRAY-NUMBER-DIMENSIONS 1)
				(BYTE-VALUE %%ARRAY-LONG-LENGTH-FLAG 1)
				(EVAL ART-Q))))
	((VMA-START-WRITE M-R) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))
	(CHECK-PAGE-WRITE)
	((MD) Q-POINTER M-C (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) ADD M-R (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	;; now we have the array in M-R with length in M-C
	;; we must now allocate a bignum to divide into.
	(CALL-XCT-NEXT SCONS-T)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((MD) ADD M-I (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-T) Q-POINTER M-T
			       (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)))
	(CHECK-PAGE-WRITE)
	;; now we have a (temp.) bignum in M-T so we start to divide
	((M-E) M-R)		;move the array into M-E
	((M-B) M-I)		;save length of bignum
	((M-2) Q-POINTER M-A)	;fixnum to divide by
	((M-A) (A-CONSTANT 1))	;index+1 into array
	((M-R) M-T)
	(CALL-XCT-NEXT DIVIDE-ONCE)
       ((M-J) M-I)
	((M-Q) M-R)		;from now on we divide from the temp bignum to itself.
BIG-TO-ARY-L
	((MD) Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) M+A+1 M-E A-A)	;write remainder.
	(CHECK-PAGE-WRITE)
	((VMA-START-READ) ADD M-R A-J)	;Check to see if last word of quotient was zero.
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD A-ZERO BIG-TO-ARY-2)
	(JUMP-EQUAL M-I (A-CONSTANT 1) BIG-TO-ARY-CLEANUP)	;bignum is zero, done
	((M-I) SUB M-I (A-CONSTANT 1))	;pretend bignum is shorter
BIG-TO-ARY-2
	(CALL-XCT-NEXT DIVIDE-ONCE)
       ((M-J) M-I)
	(JUMP-XCT-NEXT BIG-TO-ARY-L)
       ((M-A) ADD M-A (A-CONSTANT 1))

BIG-TO-ARY-CLEANUP
	((M-T) M-E)		;array to return
	((M-1) M-R)
	((M-D) M-A)		;M-A smashed by UN-CONS
	(CALL-XCT-NEXT UN-CONS)	;Give back the bignum
       ((M-2) ADD M-B (A-CONSTANT 1))
	(POPJ-EQUAL M-C A-D)	;all array used so return it!
	;; else give back unused end of array
	((MD) Q-POINTER M-D (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE M-1) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	((M-1) M+A+1 M-1 A-D)
	(JUMP-XCT-NEXT UN-CONS)	;tail recursive call
       ((M-2) SUB M-C A-D)

;; First arg a art-q array second a fixnum third the sign bit (zero or one).
;; Returns a bignum. Inverse of BIGNUM-TO-ARRAY
(MISC-INST-ENTRY ARRAY-TO-BIGNUM)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS ARRAY-TO-BIGNUM PP M-J M-C)
ARY-TO-BIG
	((M-C) C-PDL-BUFFER-POINTER-POP)	;sign bit.
	((M-J) C-PDL-BUFFER-POINTER-POP)	;fixnum.
    (ERROR-TABLE RESTART ARY-TO-BIG)
	(DISPATCH Q-DATA-TYPE M-C TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-C 2 ARY-TO-BIG)
	(DISPATCH Q-DATA-TYPE M-J TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM M-J 1 ARY-TO-BIG)
	((M-C) DPB M-C BIGNUM-HEADER-SIGN A-ZERO)
	((M-A) C-PDL-BUFFER-POINTER)
	(CALL-XCT-NEXT GAHDRA)			;array.
       ((M-J) Q-POINTER M-J)
	(CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B TRAP)
    (ERROR-TABLE ARGTYP NON-DISPLACED-ARRAY PP 0)
	((M-B) SELECTIVE-DEPOSIT M-B (LISP-BYTE %%ARRAY-TYPE-FIELD) A-ZERO)
	(CALL-NOT-EQUAL M-B (A-CONSTANT (EVAL ART-Q)) TRAP)
    (ERROR-TABLE ARGTYP ART-Q-ARRAY PP 0)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 1) TRAP)
    (ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 1 PP)
	;; now we have the array in M-A (origin in M-E, length in M-S)
	;; sign bit in correct spot in M-C
	;; fixnum in M-J (unboxed)
	((M-T) A-ZERO)
	(CALL-XCT-NEXT XHAUL1)			;Get # bits per array element
       ((M-1) M-J)
	((M-1) M-T)				;Size of bignum in bits
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-S)
	(CALL-NOT-EQUAL M-2 A-ZERO TRAP)
		(ERROR-TABLE ARGTYP REASONABLE-SIZE-ARRAY M-A)
	((M-1) Q-R)
	(CALL-XCT-NEXT DIV)			;Get size of bignum in words
       ((M-2) (A-CONSTANT 31.))
	((M-I) ADD Q-R (A-CONSTANT 1))
	;; we have now computed the amount of space to allocate for the bignum.
	;; The formula is I := 1+(haulong J)*S/31.
	((M-R) M-E)		;shuffle (origin of array)
	((M-D) M-S)		;suuffle (length of array)
	(CALL-XCT-NEXT BNCONS)
       ((M-B) ADD M-I (A-CONSTANT 1))
	((M-S) M-D)		;unshuffle (length of array)
	((M-2) M-J)		;"radix"
	;; now we have the array in M-A (origin in M-R length in M-S),
	;; we have the fixnum in M-2, we have the bignum in M-T (header in M-C, length in M-I)
	;; first we must zero the bignum.
	((M-D) (A-CONSTANT 1))
	((MD) A-ZERO)
ARY-TO-BIG-2
	((VMA-START-WRITE) ADD M-T A-D)
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN-XCT-NEXT M-D A-I ARY-TO-BIG-2)
       ((M-D) ADD M-D (A-CONSTANT 1))
	((M-Q) M-T)		;copy in M-Q
	;; now we start:
	((M-S) SUB M-S (A-CONSTANT 1))
ARY-TO-BIG-L
	((VMA-START-READ) ADD M-R A-S)
	(CHECK-PAGE-READ)
	(CALL-XCT-NEXT MULTIPLY-ONCE)
       ((M-1) Q-POINTER MD)
	(CALL-NOT-EQUAL M-1 A-ZERO ILLOP)	;overflow (should never happen)
	(JUMP-GREATER-THAN-XCT-NEXT M-S A-ZERO ARY-TO-BIG-L)
       ((M-S) SUB M-S (A-CONSTANT 1))
	;; now we see how many zeros we have at the end
BIGNUM-DPB-CLEANUP	;Enters here with bignum in M-T, header in M-C
			;Use this only for logical operations, not arithmetic
			; ones!  Note the treatment of negative zero!
	((M-E) BIGNUM-HEADER-LENGTH M-C)
	((M-D) BIGNUM-HEADER-LENGTH M-C)
ARY-TO-BIG-CLEANUP
	((VMA-START-READ) ADD M-T A-E)
	(CHECK-PAGE-READ)
	(JUMP-NOT-EQUAL MD A-ZERO BCLEANUP)
	(JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) ARY-TO-BIG-CLEANUP)
       ((M-E) SUB M-E (A-CONSTANT 1))
	;; Number is nothing but sign bits
	((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C)
	((M-TEM) M-ZERO)
	((M-1) Q-POINTER M-T)				;For UN-CONS
	(JUMP-XCT-NEXT BCLEANUP-1)
       ((M-2) ADD M-D (A-CONSTANT 1))

;; Clean up and return a bignum in M-T. Hands back storage and checks for fixnums.
;; Bignum in M-T, header in M-C, length in M-D, actual length in M-E (# of non-zero words).
BCLEANUP
	(JUMP-GREATER-THAN M-E (A-CONSTANT 1) BCLEANUP-X)  ;Could answer be a fixnum?
	((VMA-START-READ) ADD M-T (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-1) Q-POINTER M-T)				;For UN-CONS
	((M-2) ADD M-D (A-CONSTANT 1))
	((M-A) (BYTE-FIELD 9. 23.) MD)			;All but 23 low bits
	(JUMP-NOT-EQUAL-XCT-NEXT M-A A-ZERO BCLEANUP-SETZP)	;no. (unless it is SETZ)
       ((M-TEM) MD)
	(JUMP-IF-BIT-CLEAR BIGNUM-HEADER-SIGN M-C BCLEANUP-1)
	((M-TEM) SUB M-ZERO A-TEM)				;Its negative.
BCLEANUP-1
	(JUMP-XCT-NEXT UN-CONS)
       ((M-T) Q-POINTER M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

BCLEANUP-SETZP
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT POSITIVE-SETZ) BCLEANUP-X)	;Is it setz?
	(JUMP-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BCLEANUP-1)
BCLEANUP-X
	(POPJ-EQUAL M-D A-E)
	((M-2) SUB M-D A-E)			;Number of unused words at end
	((M-C) SUB M-C A-2)			;Fix the header
	((MD) ADD M-C (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER)
					(BYTE-VALUE HEADER-TYPE-FIELD %HEADER-TYPE-BIGNUM))))
	((VMA-START-WRITE M-1) Q-POINTER M-T)
	(CHECK-PAGE-WRITE)
	((M-1) M+A+1 M-1 A-E)
;; FALLS THROUGH

;; Takes a pointer to a block of words to free up in M-1, the number of words in M-2.
;; This only works for structure space.
;; Smashes M-A,M-B,M-E,M-TEM,M-2. M-1 preserved. NO SEQUENCE BREAKS TAKEN.

UN-CONS	(POPJ-EQUAL M-2 A-ZERO)
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;Protect M-T through this routine
	(CALL-XCT-NEXT XRGN1)			;Get region number from M-1 in M-T
       ((M-A) Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-T) Q-POINTER M-T)
	(JUMP-NOT-EQUAL M-T A-SCAV-REGION UN-CONS-0)
	((A-SCAV-COUNT) (A-CONSTANT 0))		;Make scavenger forget this region
UN-CONS-0
	((VMA-START-READ) ADD M-T A-V-REGION-ORIGIN)
	(CHECK-PAGE-READ)
	((M-E) ADD M-A A-2)			;M-E gets where free pointer should be
	((M-A) MD)				;M-A gets region origin
	((VMA-START-READ) ADD M-T A-V-REGION-FREE-POINTER)
	(CHECK-PAGE-READ)
	((M-E) Q-POINTER M-E)
	((M-TEM) ADD MD A-A)			;M-TEM gets actual free pointer
	((M-TEM) Q-POINTER M-TEM)
	(JUMP-NOT-EQUAL M-TEM A-E UN-CONS-FILL)	;Something else got allocated, don't mess
	((MD-START-WRITE) SUB MD A-2)		;Decrement free pointer.
	(CHECK-PAGE-WRITE)
	(JUMP-NOT-EQUAL M-T A-SCONS-CACHE-REGION UN-CONS-1)	;Fix free ptr in cache, too
	((A-SCONS-CACHE-FREE-POINTER) ADD MD A-SCONS-CACHE-REGION-ORIGIN)
UN-CONS-1
	((VMA-START-READ) ADD M-T A-V-REGION-GC-POINTER)	;back up scav pointer if necc
	(CHECK-PAGE-READ)
	((M-TEM) SUB M-ZERO A-2)		;Undo cons-work-done
	((A-CONS-WORK-DONE) ADD M-TEM A-CONS-WORK-DONE)
	((M-TEM) Q-POINTER READ-MEMORY-DATA)
	(POPJ-LESS-OR-EQUAL-XCT-NEXT M-TEM A-E)
       ((M-T) C-PDL-BUFFER-POINTER-POP)		;Restore M-T
	((MD-START-WRITE) SELECTIVE-DEPOSIT MD Q-ALL-BUT-POINTER A-E)
	(CHECK-PAGE-WRITE)
	(POPJ)	;NO POPJ-AFTER-NEXT, BADD4 CAN JUMP HERE, THEN WE RETURN TO MAIN LOOP

UN-CONS-FILL
	((M-2) SUB M-2 (A-CONSTANT 1))		;M-2 gets length of array to fill with
	(CALL-GREATER-THAN M-2 (A-CONSTANT (EVAL %ARRAY-MAX-SHORT-INDEX-LENGTH)) ILLOP)
	((MD) ADD M-2 (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-HEADER)
					(BYTE-VALUE %%ARRAY-NUMBER-DIMENSIONS 1)
					(EVAL ART-32B))))
	((VMA-START-WRITE) M-1)		;NO POPJ-AFTER-NEXT, SEE ABOVE
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT (M-T) C-PDL-BUFFER-POINTER-POP)	;RESTORE IT.
       (NO-OP)

;;; THE TRANSPORTER

;		"Energize!"
;		     -- J. T. Kirk
;
;THIS CAN CALL CONS BUT CANNOT SEQUENCE-BREAK.  IT WILL NOT CLOBBER ANY REGISTERS
;EXCEPT WHAT PAGE-FAULTS CLOBBER.  IF IT NEEDS TO SEQUENCE BREAK, THE BREAK WILL
;ACTUALLY BE DEFERRED SO THAT EVERYONE WHO TRANSPORTS DOESN'T HAVE TO WORRY ABOUT
;SEQUENCE BREAKS.

;GET HERE BY SPECIAL DISPATCH, THE RETURN ADDRESS ON THE MICROSTACK
;IS THE ADDRESS OF THE DISPATCH INSTRUCTION ITSELF.
;PRESENTLY, WE HAVE ONE DISPATCH TABLE AND USE I-ARG'S TO DISTINGUISH THE
;CASES.  IF IT TURNS OUT WE OUGHT TO HAVE DROPPED THROUGH, WE RETURN TO
;THE DISPATCH INSTRUCTION, OA-MODIFYING IT TO DISPATCH THROUGH LOC 3777
;WHICH FORCES IT TO DROP THROUGH.  NORMALLY, WE EITHER ERR OUT OR ALTER
;VMA AND MD AND RETURN TO RE-EXECUTE THE DISPATCH.

;Enter here if either the MD is a pointer to old-space or we have a map miss
TRANS-OLD
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 1) READ-I-ARG TRANS-DROP-THROUGH);Ignore if no-transport
TRANS-OLD0	;Enter here if forwarding-pointer, mustn't ever drop-through
	((A-TRANS-VMA) VMA)			;Save where MD came from
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits
	(POPJ-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%REGION-OLDSPACE-META-BIT)
		MEMORY-MAP-DATA)		;Re-transport if was just map not set up
       ((VMA) A-TRANS-VMA)			;Restoring VMA which could have been bashed
	((VMA-START-READ) MD)			;Get word out of old space
	(CHECK-PAGE-READ)	;** Should blow out here if was really free space
	((A-TRANS-MD) VMA)			;Save pointer to old space
	(DISPATCH Q-DATA-TYPE READ-MEMORY-DATA D-TRANS-OLD)

(LOCALITY D-MEM)
;Dispatch on datatype of word fetched from old space when transporting a pointer to old-space
;Usually go to TRANS-OLD-COPY to copy the containing structure.  Check specially for
;GC-FORWARD (already copied), invisibles (snap out).
(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)
D-TRANS-OLD
	(TRANS-OLD-COPY)	;TRAP
	(TRANS-OLD-COPY)	;NULL
	(TRANS-OLD-COPY)	;FREE
	(TRANS-OLD-COPY)	;SYMBOL
	(TRANS-OLD-COPY)	;SYMBOL-HEADER
	(TRANS-OLD-COPY)	;FIX
	(TRANS-OLD-COPY)	;EXTENDED NUMBER
	(TRANS-OLD-COPY)	;HEADER
	(TRANS-OLD-GC-FWD)	;GC-FORWARD
	(TRANS-OLD-COPY)	;EXTERNAL-VALUE-CELL-POINTER
	(TRANS-OLD-COPY)	;ONE-Q-FORWARD
	(TRANS-OLD-HDR-FWD)	;HEADER-FORWARD
	(TRANS-OLD-BODY-FWD)	;BODY-FORWARD
	(TRANS-OLD-COPY)	;LOCATIVE
	(TRANS-OLD-COPY)	;LIST
	(TRANS-OLD-COPY)	;U CODE ENTRY
	(TRANS-OLD-COPY)	;FEF
	(TRANS-OLD-COPY)	;ARRAY-POINTER
	(TRANS-OLD-COPY)	;ARRAY-HEADER
	(TRANS-OLD-COPY)	;STACK-GROUP
	(TRANS-OLD-COPY)	;CLOSURE
	(TRANS-OLD-COPY)	;SMALL-FLONUM 
	(TRANS-OLD-COPY)	;SELECT-METHOD
	(TRANS-OLD-COPY)	;INSTANCE
	(TRANS-OLD-COPY)	;INSTANCE-HEADER
	(TRANS-OLD-COPY)	;ENTITY
	(TRANS-OLD-COPY)	;STACK-CLOSURE
 (REPEAT NQZUSD (TRANS-OLD-COPY))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; Copy object found in oldspace
TRANS-OLD-COPY
	((C-PDL-BUFFER-POINTER-PUSH) M-A)	;Protect regs used by XARN
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	(CALL-XCT-NEXT XARN)			;M-T gets area# object is in
       ((C-PDL-BUFFER-POINTER-PUSH) A-TRANS-MD)
	((M-TEM) M-T)				;Allocate new copy in same area
	((M-T) C-PDL-BUFFER-POINTER-POP)	;Restore registers
	((M-B) C-PDL-BUFFER-POINTER-POP)
	((M-A) C-PDL-BUFFER-POINTER-POP)
	(CALL-XCT-NEXT TRANS-COPY)		;Make new copy
       ((A-TRANS-COPY-FWD-DTP)
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-GC-FORWARD)
				  (BYTE-VALUE Q-CDR-CODE CDR-ERROR))))
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-TRANS-VMA)	;Replace oldspace ptr with newspace ptr
       (CHECK-PAGE-WRITE-FORCE)			;and transport again

;DTP-BODY-FORWARD in old space.  Must find header, find new copy, and snap out.
TRANS-OLD-BODY-FWD
	((VMA-START-READ) MD)			;Pick up the DTP-HEADER-FORWARD
	(CHECK-PAGE-READ)
	((A-TRANS-TEM) SUB VMA A-TRANS-MD)	;Offset from particular Q to header
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)	;Consistency check
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER-FORWARD)) ILLOP)
	((MD) SUB READ-MEMORY-DATA A-TRANS-TEM)	;MD gets address of new copy of Q
						;Drops through
;DTP-GC-FORWARD in old space.  Take what it points to.
TRANS-OLD-GC-FWD
	((MD) Q-POINTER MD A-TRANS-MD)		;Combine new pointer with old tag
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-TRANS-VMA)	;Snap it out
       (CHECK-PAGE-WRITE-FORCE)			;and transport again

;DTP-HEADER-FORWARD in old space.  In structure space, just snap it out.
;Then transport again in case it pointed to oldspace.
;In list space, header-forward is something else entirely, namely
;rplacd-forwarding pointer.  We ignore the header-forward and do
;the usual copying operation, which will handle the header-forward suitably.
TRANS-OLD-HDR-FWD
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Meta bits for new copy
	(DISPATCH (LISP-BYTE %%REGION-REPRESENTATION-TYPE)
		MEMORY-MAP-DATA D-TRANS-OLD-HDR-FWD)

(LOCALITY D-MEM)
(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
D-TRANS-OLD-HDR-FWD
	(TRANS-OLD-COPY)	;0 list
	(TRANS-OLD-GC-FWD)	;1 structure
(REPEAT 2 (P-BIT ILLOP))	;2, 3 not used
(END-DISPATCH)
(LOCALITY I-MEM)

;Enter here for trapping data type.  If it points to old-space, and
;this is not an inum-type (DTP-NULL), will have already been
;transported.  If going to write, we ignore it, otherwise we trap anyway.
TRANS-TRAP
	(CALL-IF-BIT-CLEAR (BYTE-FIELD 1 4) READ-I-ARG TRAP)	;BARF IF READING RANDOM DATA
  (ERROR-TABLE TRANS-TRAP) ;This is a special entry, which the EH knows all about.
;Return to caller, causing dispatch to drop through by OA-modifying it.
;Assume that VMA and MD haven't been modified, or have been saved and restored.
TRANS-DROP-THROUGH	
	(POPJ-AFTER-NEXT NO-OP)
       ((OA-REG-LOW) DPB (M-CONSTANT -1) OAL-DISP A-ZERO)	;FORCE DISP TO LOC 3777

    (ERROR-TABLE RESTART TRANS-TRAP-RESTART)
	(JUMP-XCT-NEXT TRANS-DROP-THROUGH)	;Here to continue from TRANS-TRAP
       ((MD) C-PDL-BUFFER-POINTER-POP)		;with replacement data from the stack

;Enter here if external-value-cell-pointer to old-space.
;If supposed to invz, transport first.  Otherwise, transport
;unless don't-transport bit is set.
TRANS-OLDP-EVCP
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 1) READ-I-ARG TRANS-OLD0) ;Transport if supposed to.
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 0) READ-I-ARG TRANS-OLD0) ;Transport first, if must invz
	;Drop into TRANS-EVCP if either going to drop-through and no transp desired,
	;or if going to ILLOP
;Enter here for external-value-cell-pointer to newspace.
TRANS-EVCP
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) READ-I-ARG TRANS-EVCP-1) ;JUMP IF SHOULDN'T INVZ
	;Else drop into TRANS-INVZ, faster than jumping

;Enter here for DTP-HEADER-FORWARD pointer, always forwards.
;Already transported if was old-space.
TRANS-HFWD	
;Chase forwarding pointer, restart cycle
TRANS-INVZ	
	((A-TEM1) READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT
	 (VMA-START-READ) SELECTIVE-DEPOSIT VMA		;RETAIN DATA TYPE,
			 Q-ALL-BUT-POINTER A-TEM1)	;ALTER POINTER
       (CHECK-PAGE-READ)

TRANS-EVCP-1
	(JUMP-XCT-NEXT TRANS-DROP-THROUGH)	;SHOULDN'T INVZ, GO SIMULATE DROP THROUGH
       (CALL-IF-BIT-SET (BYTE-FIELD 1 2) READ-I-ARG ILLOP)	;BARF IF TRANSPORT-HEADER

;Enter here for one-q-forward.  Already transported if was old-space.
TRANS-OQF
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 3) READ-I-ARG TRANS-DROP-THROUGH) ;IGNORE OQF IF JUST
	(JUMP-XCT-NEXT TRANS-INVZ)					 ;CHECKING CDR CODE
       (CALL-IF-BIT-SET (BYTE-FIELD 1 2) READ-I-ARG ILLOP)	;BARF IF TRANSPORT-HEADER

;Enter here for DTP-BODY-FORWARD, always forwards, but must "go around" through header
TRANS-BFWD	
	((A-TRANS-VMA) VMA)			;REMEMBER WHERE ORIGINAL REFERENCE WAS
	((VMA-START-READ) DPB READ-MEMORY-DATA	;PICK UP DTP-HEADER-FORWARD FROM OLD HEADER
		Q-POINTER A-TRANS-VMA)		;DON'T CHANGE DATA TYPE OF VMA
	(CHECK-PAGE-READ)
	((A-TEM1) SUB VMA A-TRANS-VMA)		;MINUS OFFSET FROM HEADER TO DATA
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)	;THESE 2 INSTRUCTIONS ARE JUST A RANDOMNESS
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-HEADER-FORWARD)) ILLOP)	; CHECK
	((M-TEM) SUB READ-MEMORY-DATA A-TEM1)	;GET ADDRESS RELOCATED TO
	(POPJ-AFTER-NEXT			;REFERENCE THAT ADDRESS, VMA DATATYPE UNCHANGED
	 (VMA-START-READ) SELECTIVE-DEPOSIT VMA Q-ALL-BUT-POINTER A-TEM)
       (CHECK-PAGE-READ)

;;; Routine to copy what A-TRANS-MD points to into area in M-TEM.
;;; Returns with MD pointing to copy.  Leaves forwarding pointers behind,
;;; whose data-type and cdr code come from A-TRANS-COPY-FWD-DTP
;;; Note that cdr-code of the GC-forwarding pointer must be cdr-error,
;;; to avoid faking out XFSHL.
;;; Used by the transporter and the extra-pdl copier.
;;; In list space, we have to worry about complicated dealings with rplacd-forwards
;;; Can't save registers in the pdl buffer since might be called from XFLIPW
;;; and might decide to clobber the registers with GC-forwarding pointers.
TRANS-COPY
	((M-TRANSPORT-FLAG) DPB (M-CONSTANT -1) A-FLAGS) ;No sequence break out of CONS!
	(CALL TRANS-COPY-SAVE)
	((M-S) M-TEM)				;Area in which to allocate
	(CALL-XCT-NEXT XFSL)			;Find start of structure (to M-T)
       ((C-PDL-BUFFER-POINTER-PUSH) A-TRANS-MD)	;arg
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;Save old object
	(CALL-XCT-NEXT STRUCTURE-INFO)		;Find size of structure
       ((MD) M-T)
	;; Cons up new copy.  If list representation, branch off to special code first.
	(DISPATCH-XCT-NEXT (LISP-BYTE %%REGION-REPRESENTATION-TYPE) M-K D-TRANS-COPY)
       ((M-B) ADD M-3 A-4)			;Total size of it
TRANS-COPY-1
	((M-K) SETO)				;Extinguish flag
TRANS-COPY-1K
	;; Copy it, boxed and unboxed Q's alike, since shouldn't transport here.
	;; Length is in M-B, last A-SINF-PAD Q's not to be copied.
	((M-E) SUB C-PDL-BUFFER-POINTER-POP (A-CONSTANT 1)) ;Old object minus 1
TRANS-COPY-2  ;Copy loop
	((VMA-START-READ M-E) ADD M-E (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-B) SUB M-B (A-CONSTANT 1))
TRANS-COPY-5
	((M-A) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE)	;Replace with GC-forwarding pointer
		Q-POINTER M-T A-TRANS-COPY-FWD-DTP)
	(CHECK-PAGE-WRITE-FORCE)
	((M-TEM) Q-DATA-TYPE M-A)		;Check data type of Q being copied
	(JUMP-EQUAL M-TEM A-K TRANS-COPY-4)	;Oops, special hair for rplacd-forwarding
	((WRITE-MEMORY-DATA) M-A)		;Store old contents in new place
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE-FORCE)
	(JUMP-GREATER-THAN-XCT-NEXT M-B A-SINF-PAD TRANS-COPY-2)
       ((M-T) ADD M-T (A-CONSTANT 1))
	(JUMP-EQUAL M-B A-ZERO TRANS-COPY-9)
TRANS-COPY-7	;"Copy" the padding.  Must store forwarding pointers but clobber contents.
	((VMA M-E) ADD M-E (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE)	;Replace with forwarding pointer
		Q-POINTER M-T A-TRANS-COPY-FWD-DTP)
	(CHECK-PAGE-WRITE-FORCE)
	((M-B) SUB M-B (A-CONSTANT 1))
	((VMA) M-T)
	((WRITE-MEMORY-DATA-START-WRITE)	;"Copy" gets a fixnum zero
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CHECK-PAGE-WRITE-FORCE)
	(JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO TRANS-COPY-7)
       ((M-T) ADD M-T (A-CONSTANT 1))
TRANS-COPY-9
	((M-TEM) M-A-1 M-T A-E)			;Offset from old to new
	((MD) ADD M-TEM A-TRANS-MD)		;Change value being stored
TRANS-COPY-3
	((MD) Q-POINTER MD A-TRANS-MD)		;But only the address part
	(JUMP-XCT-NEXT TRANS-COPY-RESTORE)
       ((M-TRANSPORT-FLAG) DPB (M-CONSTANT 0) A-FLAGS)

TRANS-COPY-4 ;Copy last 2 words, rplacd-forwarded list, that have been snapped in
	(CALL-NOT-EQUAL M-B (A-CONSTANT 1) ILLOP)	;Fuckup somewhere
	((VMA-START-READ) M-A)			;Get first of 2 words via forwarding ptr
	(CHECK-PAGE-READ)
	((M-E) ADD M-E (A-CONSTANT 1))
	((M-B) READ-MEMORY-DATA)		;Cdr-code will always be CDR-NORMAL
	((WRITE-MEMORY-DATA-START-WRITE)	;Replace with GC-forwarding pointer
		Q-POINTER M-T A-TRANS-COPY-FWD-DTP)
	(CHECK-PAGE-WRITE-FORCE)
	((WRITE-MEMORY-DATA) M-B)		;Store old contents in new place
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE-FORCE)
	((M-B) (A-CONSTANT 0))
	((VMA-START-READ) ADD M-A (A-CONSTANT 1))	;Get second of 2 words
	(CHECK-PAGE-READ)
	(JUMP-XCT-NEXT TRANS-COPY-5)		;Rejoin main code to do last word
       ((M-T) ADD M-T (A-CONSTANT 1))

TRANS-COPY-SAVE
	((A-TRANS-SAVE-A) M-A)			;Save regs bashed by CONS, FSH
	((A-TRANS-SAVE-B) M-B)
	((A-TRANS-SAVE-E) M-E)
	((A-TRANS-SAVE-K) M-K)
	((A-TRANS-SAVE-S) M-S)
	((A-TRANS-SAVE-T) M-T)
	(POPJ-AFTER-NEXT
	 (A-TRANS-SAVE-3) M-3)
	((A-TRANS-SAVE-4) M-4)

TRANS-COPY-RESTORE
	((M-4) A-TRANS-SAVE-4)			;Restore registers
	((M-3) A-TRANS-SAVE-3)
	((M-T) A-TRANS-SAVE-T)
	((M-S) A-TRANS-SAVE-S)
	((M-K) A-TRANS-SAVE-K)
	((M-E) A-TRANS-SAVE-E)
	(POPJ-AFTER-NEXT
	 (M-B) A-TRANS-SAVE-B)
	((M-A) A-TRANS-SAVE-A)

(LOCALITY D-MEM)
(START-DISPATCH 2 0)
;Dispatch on representation type for CONS inside of TRANS-COPY
D-TRANS-COPY
	(TRANS-COPY-LIST)	;0 List
	(P-BIT SCONS)		;1 Structure
	(P-BIT ILLOP)		;2 unused
 	(P-BIT ILLOP)		;3 unused
(END-DISPATCH)
(LOCALITY I-MEM)

;;; TRANS-COPY on a list
TRANS-COPY-LIST
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 31.) M-K TRANS-COPY-LIST-0) ;Test for RPLACD-forwarding
	(JUMP-XCT-NEXT TRANS-COPY-1)		;No RPLACD-forwarding, copy just like structure
       (CALL LCONS)

TRANS-COPY-LIST-0
	(JUMP-GREATER-THAN M-B (A-CONSTANT 2) TRANS-COPY-LIST-1) ;Test for hairy case
	;; The entire list-structure (1 Q) was forwarded, so simply snap out
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)	;Fetch forwarding pointer
	(CHECK-PAGE-READ)
	(JUMP TRANS-COPY-3)			;Use what it points at

;;; Here if the list-structure is partially in one place and partially in another.
;;; If the new node created by rplacd is in oldspace and not yet copied, we should
;;; snap-out by copying it into the same place as the old part of the list-structure.
;;; And if we didn't snap out we could be storing a pointer to oldspace which is a no-no.
;;; On the other hand, if the new node is in newspace or has already been copied,
;;; we can't snap out.  Instead we create a full-node out of the cdr-next
;;; node just before the forwarded one.
TRANS-COPY-LIST-1
	((M-T) SUB M-B (A-CONSTANT 2))		;Offset to dtp-header-forward Q
	((VMA-START-READ M-T) ADD C-PDL-BUFFER-POINTER A-T)	;Fetch him
	(CHECK-PAGE-READ)
	((M-TEM) READ-MEMORY-DATA)		;Complete read cycle
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Validate meta bits
	(JUMP-IF-BIT-SET (LISP-BYTE %%REGION-OLDSPACE-META-BIT) MEMORY-MAP-DATA
		TRANS-COPY-LIST-3)		;Jump if new node is in newspace
	((VMA-START-READ) MD)			;Pick up first word of new node
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)	;Look for GC-forward
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-GC-FORWARD)) TRANS-COPY-LIST-3)
	;; New node can be merged with old node, full snapping-out
	(CALL LCONS)				;Cons new list, big enough for both
	(JUMP-XCT-NEXT TRANS-COPY-1K)		;Go join normal copy
       ((M-K) (A-CONSTANT (EVAL DTP-HEADER-FORWARD))) ;but watch out for this data type

TRANS-COPY-LIST-3 ;Can't snap out.  MD -> new node in newspace.
	((VMA) M-T)				;Clobber hdr-fwd with cdr pointer
	((MD-START-WRITE) Q-POINTER MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CHECK-PAGE-WRITE-FORCE)
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))	;Fix cdr code of preceding word
	(CHECK-PAGE-READ)
	((M-B) SUB M-B (A-CONSTANT 1))		;Copy will be 1 Q shorter since no snapout
	((MD-START-WRITE) Q-ALL-BUT-CDR-CODE READ-MEMORY-DATA
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)))
	(CHECK-PAGE-WRITE-FORCE)
	(JUMP-XCT-NEXT TRANS-COPY-1)		;Copy fudged list
       (CALL LCONS)

;;; EXTRA-PDL-TRAP
;;; We get here if we just wrote a possible pointer to the extra-pdl
;;; into main memory.  If so, we must copy the object out into a normal
;;; area and do the write again.  Mustn't sequence-break while the
;;; bad thing is in memory, and mustn't clobber anything other than
;;; what page faults clobber.  SMASHES PDL-BUFFER-INDEX.
;;; (I-ARG 1) indicates coming from pdl-buffer dumper, special return
;;; indicated since map has been munged.
;;; Note that we cannot get here from inside the transporter, which
;;; is fortunate since some variables are shared.

EXTRA-PDL-TRAP
	((A-TRANS-MD) MD)			;SAVE DUBIOUS OBJECT
	(JUMP-IF-BIT-SET-XCT-NEXT		;CHECK FOR CALL FROM PDL-BUFFER DUMPER
		(BYTE-FIELD 1 0) READ-I-ARG EXTRA-PDL-TRAP-0)
       ((A-TRANS-VMA) VMA)			;SAVE ADDRESS WRITTEN INTO
EXTRA-PDL-TRAP-1
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;ENSURE VALIDITY OF META BITS
	(POPJ-IF-BIT-SET-XCT-NEXT		;RETURN IF FALSE ALARM
		(LISP-BYTE %%REGION-EXTRA-PDL-META-BIT) MEMORY-MAP-DATA)
       ((VMA) A-TRANS-VMA)			;RESTORE VMA
;Real extra-pdl trap, copy object out into working storage
	((VMA-START-READ) MD)			;Check for forwarding pointer
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-EQUAL-XCT-NEXT M-TEM (A-CONSTANT (EVAL DTP-HEADER-FORWARD)) EXTRA-PDL-TRAP-3)
       ((MD) Q-POINTER MD A-TRANS-MD)		;Change address to follow forwarding ptr
	((A-TRANS-COPY-FWD-DTP)			;Forward with header forwards
		(A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-HEADER-FORWARD)
				  (BYTE-VALUE Q-CDR-CODE CDR-ERROR))))
	(CALL-XCT-NEXT TRANS-COPY)		;Copy the frob in A-TRANS-MD
       ((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF) ;into default area
EXTRA-PDL-TRAP-3	;New copy is now in MD, with suitable tag
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-TRANS-VMA) ;Correct store that trapped
       (CHECK-PAGE-WRITE)			; and return

;Here for EXTRA-PDL-TRAP while storing pdl-buffer.  Must clean up
;before processing the trap, and must eventually return to P-B-MR0.
;Cleanup is different in that VMA and PI haven't been advanced yet.
EXTRA-PDL-TRAP-0
	((M-TEM) SUB VMA A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Number of locations dumped -1
	((M-PDL-BUFFER-ACTIVE-QS) M-A-1 M-PDL-BUFFER-ACTIVE-QS A-TEM)
	((A-PDL-BUFFER-VIRTUAL-ADDRESS) ADD VMA (A-CONSTANT 1))
	((PDL-BUFFER-INDEX) ADD PDL-BUFFER-INDEX (A-CONSTANT 1))
	((A-PDL-BUFFER-HEAD) PDL-BUFFER-INDEX)
	((MD) Q-R)				;Address the map
	((VMA-WRITE-MAP) DPB M-PGF-TEM		;Restore the map for this page
		MAP-WRITE-SECOND-LEVEL-MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	((MD) SETA A-TRANS-MD			;Restore dubious MD
		MICRO-STACK-PNTR-AND-DATA-POP)	;and flush useless return address
	(JUMP-XCT-NEXT EXTRA-PDL-TRAP-1)	;Return to mainline
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC P-B-MR0))) ;with return address buggered

;;; Copy a DTP-STACK-CLOSURE when it is stored anywhere but
;;; into the same stack it points at, and farther down than where it points.
;;; There is no way to forward the stack closure to the copy,
;;; because only header-forward works to forward a list's car and cdr,
;;; and putting that inside a structure will confuse other things.
;;; So we stick an external-value-cell-pointer into the stack closure
;;; pointing at the copy.  This does not forward it as far as the
;;; low levels of the system is concerned!  But as long as the
;;; stack closure still exists, that's ok; the evcp forwards only the car
;;; of the stack closure, but forwards it to the car of the copy,
;;; which contains the correct value.

;Here from GC-WRITE-TEST if data type is DTP-STACK-CLOSURE.
;If VMA is -1, it means always copy; and don't store the
;new value anywhere, just leave it in MD.
STACK-CLOSURE-TRAP
	((M-TEM) Q-POINTER MD)
	((M-PGF-TEM) Q-POINTER VMA)
;If storing into the same stack and below where it points, don't copy.
	(JUMP-LESS-THAN M-PGF-TEM A-TEM STACK-CLOSURE-TRAP-REALLY)
	(JUMP-LESS-THAN M-PGF-TEM A-QLPDLH TRANS-DROP-THROUGH)

;Here if the stack-closure is being stored into a place it should not be.
STACK-CLOSURE-TRAP-REALLY
	((C-PDL-BUFFER-POINTER-PUSH) VMA)
	((VMA-START-READ) MD)			;Check for forwarding pointer already.
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER))
	    STACK-CLOSURE-TRAP-MUST-COPY)
STACK-CLOSURE-STORE-COPY
	((MD) Q-POINTER MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CLOSURE)))
	((VMA) C-PDL-BUFFER-POINTER-POP)
	(JUMP-EQUAL VMA A-MINUS-ONE TRANS-DROP-THROUGH)
	((VMA-START-WRITE) VMA)
	(CHECK-PAGE-WRITE)
	(JUMP TRANS-DROP-THROUGH)

;This stack-closure has not yet had a copy made.
;The original stack-closure object is now in VMA.
STACK-CLOSURE-TRAP-MUST-COPY
	((C-PDL-BUFFER-POINTER-PUSH) VMA)
;Make sure all the cells of the environment list are in newspace.
;Or rather, that their containing stacks are in newspace.
	((VMA-START-READ) ADD C-PDL-BUFFER-POINTER (A-CONSTANT 3))
	(CHECK-PAGE-READ)		;MD has ptr to list, VMA as addr of that ptr.
	(CALL ENSURE-STACK-ENV-TRANSPORTED)
;Now no more transporting can happen,
;so save many ACs the same way the transporter does.
	(CALL TRANS-COPY-SAVE)
;Go through the environment-list of the closure,
;forwarding each cell of the list.
	((MD) ADD C-PDL-BUFFER-POINTER (A-CONSTANT 4))
	(CALL ENSURE-STACK-ENV-COPIED)
;Get the address of the copy just made of the first cell of the environment-list.  Save it.
	((VMA-START-READ) ADD C-PDL-BUFFER-POINTER (A-CONSTANT 4))
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) DPB MD Q-POINTER
				     (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
;Go through again, splicing the EVCPs out
;so that the new copies point directly one at the next.
	(CALL ENSURE-STACK-ENV-SNAPPED)
;Now get its car (the stack frame it points at)
;and set that frame's copy-on-exit bit.
	((VMA-START-READ) C-PDL-BUFFER-POINTER)
	(CHECK-PAGE-READ)
	((VMA-START-READ) ADD MD (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
	(CHECK-PAGE-READ)
	((MD-START-WRITE) IOR MD
	    (A-CONSTANT (BYTE-VALUE (LISP-BYTE %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE) 1)))
	(CHECK-PAGE-WRITE)
;Cons a new single cell to be the vcell of the copied closure.
;Make it point at the copied value, which is popped off the stack.
	(CALL-XCT-NEXT XNCONQ)
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-BACKGROUND-CONS-AREA)
;There is no need to make the old closure vcell forward to the new one!
;Save the new one's address.
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
;Copy the closure itself.
	((M-B) (A-CONSTANT 3))
	(CALL-XCT-NEXT LCONS)
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-BACKGROUND-CONS-AREA)
;Store ptr to new vcell in last slot.
	((VMA) ADD M-T (A-CONSTANT 2))
	((MD-START-WRITE) DPB Q-TYPED-POINTER
		C-PDL-BUFFER-POINTER-POP 
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(CHECK-PAGE-WRITE)
;Get back ptr to original stack closure
	((M-K) C-PDL-BUFFER-POINTER-POP)
;Just copy the first two slots.
	((VMA-START-READ) M+1 M-K)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE) M+1 M-T)
	(CHECK-PAGE-WRITE)
	((VMA-START-READ) M-K)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
;Make the closure on the stack point at the copy with an EVCP.
	((MD) DPB M-T Q-POINTER
		  (A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NEXT)
				    (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER))))
	((VMA-START-WRITE) M-K)
	(CALL TRANS-COPY-RESTORE)
;Now store updated ptr (now in MD) in user's memory location, and return.
	(JUMP STACK-CLOSURE-STORE-COPY)

;Make sure that all the cells of the list pointed to by MD
;have been copied into newspace if necessary.
;Actually, the entire stacks that contain them are copied.
;VMA should point at a storage word which points to the list;
;that pointer is updated to point to the copy in newspace,
;and the cdr pointers of the list all point at the copies too.
ENSURE-STACK-ENV-TRANSPORTED
	((MD) Q-TYPED-POINTER MD)
	(POPJ-EQUAL MD A-V-NIL)
	(DISPATCH TRANSPORT MD)
	((VMA-START-READ) M+1 MD)
	(CHECK-PAGE-READ)
	(JUMP ENSURE-STACK-ENV-TRANSPORTED)

;Make sure that all the elements of the list pointed to by MD
;are forwarded (with EVCPs).  Keep forwarding them
;until we reach one that is already forwarded
;or one that is actually in list space.
ENSURE-STACK-ENV-COPIED
;Is this cell in list space?  If so, don't bother with it.
	(DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Meta bits for cell.
	((M-A) (LISP-BYTE %%REGION-REPRESENTATION-TYPE) MEMORY-MAP-DATA)
	(POPJ-EQUAL M-A A-ZERO)
;Is this cell already copied?  If so, return.
	((VMA-START-READ M-A) MD)
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(POPJ-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER)))
;Not already copied => push its car, then its cdr.
	((C-PDL-BUFFER-POINTER-PUSH) MD)
	((VMA) M+1 VMA)
	(CHECK-PAGE-READ)
	((C-PDL-BUFFER-POINTER-PUSH) MD)
;Then cons a new cell with same car and cdr.
	(CALL-XCT-NEXT QCONS)
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-BACKGROUND-CONS-AREA)
;Make the old one point to the new one with an EVCP in the car.
	((VMA) M-A)
	((MD-START-WRITE) DPB M-T Q-POINTER
		(A-CONSTANT (PLUS (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)
				  (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER))))
	(CHECK-PAGE-WRITE)
;Get the cdr, which is either NIL or another full-cons.
;If not NIL, go copy it.
	((VMA-START-READ) M+1 VMA)
	(CHECK-PAGE-READ)
	((M-TEM) Q-TYPED-POINTER MD)
	(JUMP-NOT-EQUAL M-TEM A-V-NIL ENSURE-STACK-ENV-COPIED)
	(POPJ)

;Snap out any EVCPs in the cells of the list that MD points to.
;Replace each cdr-pointer to a cell that has an EVCP in its car
;with a pointer to where the EVCP points.
;ENSURE-STACK-ENV-TRANSPORTED, followed by ENSURE-STACK-ENV-COPIED and this,
;is a non-recursive way of copying and snapping an entire list of any length.
;Note that this must act on the start of the copy, not the start
;of the original list.
ENSURE-STACK-ENV-SNAPPED
;Get the first cell's cdr.
	((VMA-START-READ M-A) M+1 MD)
	(CHECK-PAGE-READ)
	((M-TEM) Q-TYPED-POINTER MD)
	(POPJ-EQUAL M-TEM A-V-NIL)
;Is this cell "forwarded" with an EVCP in its car?
	((VMA-START-READ) MD)
	(CHECK-PAGE-READ)
	((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)
	(POPJ-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER)))
;Else compute the forwarded CDR, and store it back.
	((M-TEM) VMA)
	((MD) Q-POINTER MD A-TEM)
	((VMA-START-WRITE) M-A)
	(CHECK-PAGE-WRITE)
;Do the same thing to the next cell (the forwarded CDR).
	(JUMP ENSURE-STACK-ENV-SNAPPED)	

;;; METERING STUFF

;;; (%RECORD-EVENT DATA-1 ... DATA-N N-FUNCTIONS-UP EVENT-NUM N)
;;; records an event number and labels function N-FUNCTIONS-UP stack frames
;;; up the stack. Additional info DATA-n, and N which is needed so that
;;; it knows what the number of data are.
X-RECORD-EVENT	(MISC-INST-ENTRY %RECORD-EVENT)
	((A-METER-LENGTH) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	(CALL-XCT-NEXT METER-SETUP)
       ((A-METER-EVENT) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;get levels to go back
	(POPJ-EQUAL M-ZERO A-TEM1)	;punt if not appropriate
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-AP)
	(JUMP-XCT-NEXT XRECEV2)
XRECEV1	((VMA-START-READ) ADD M-K (A-CONSTANT (EVAL %LP-CALL-STATE)))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) (LISP-BYTE %%LP-CLS-DELTA-TO-ACTIVE-BLOCK) READ-MEMORY-DATA)
	((M-K) SUB M-K A-TEM)
XRECEV2	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO XRECEV1)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	(CALL METER-ASSURE-ROOM)
	((VMA-START-READ) M-K)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(CALL-XCT-NEXT METER-WRITE-HEADER)
       ((M-1) READ-MEMORY-DATA)
	(JUMP METER-CLEANUP)
	

;;; Takes number of data to push in M-D. Assumes that the disk count is non zero
METER-ASSURE-ROOM
	((M-TEM) DPB M-ZERO (BYTE-FIELD 30 10) A-METER-BUFFER-POINTER)
	((M-TEM) ADD M-TEM A-METER-LENGTH)
	(POPJ-LESS-THAN-XCT-NEXT M-TEM (A-CONSTANT (EVAL (- PAGE-SIZE 6))))
       ((A-METER-LOCK) (A-CONSTANT 1))	;Lock out everyone
	((VMA) A-METER-BUFFER-POINTER)	;Write a word of zero, it wont fit
	((WRITE-MEMORY-DATA-START-WRITE) SETZ)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)

;;; Flush the meter buffer, and maintain disk count and disk address
METER-FLUSH-BUFFER
	((A-METER-LOCK) M+A+1 M-ZERO A-METER-LOCK)	;Lock out everyone
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	((C-PDL-BUFFER-POINTER-PUSH) M-C)
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	((A-METER-BUFFER-POINTER) DPB M-ZERO (BYTE-FIELD 8 0) A-METER-BUFFER-POINTER)
					;Reset buffer pointer and address map
	((MD) A-METER-BUFFER-POINTER)	;Address map
	((M-1) MAP-STATUS-CODE MEMORY-MAP-DATA)	;Paranoia checks to see if map is set up
	(JUMP-LESS-THAN M-1 (A-CONSTANT 2) ILLOP)
	((M-B) MAP-PHYSICAL-PAGE-NUMBER MEMORY-MAP-DATA)	;Get physical page number
	((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-METER-DISK-ADDRESS)
	((A-METER-DISK-ADDRESS) M+A+1 M-ZERO A-METER-DISK-ADDRESS)	;Inc disk address
	((A-METER-DISK-COUNT) ADD (M-CONSTANT -1) A-METER-DISK-COUNT)	;Dec meter disk count
	((A-METER-START-TIME) M-2)		;Save microsecond clock
	(CALL-XCT-NEXT START-DISK-1-PAGE)	;Do the disk operation
       ((M-T) (A-CONSTANT DISK-WRITE-COMMAND))
	(CALL-XCT-NEXT AWAIT-DISK)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	((M-2) A-METER-START-TIME)
	((M-C) C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT
	    (M-B) C-PDL-BUFFER-POINTER-POP)
       ((A-METER-LOCK) ADD (M-CONSTANT -1) A-METER-LOCK)	;Free lock up

;;; Assumes A-METER-EVENT is set to the event we want to record
;;; and A-METER-LENGTH is set to the number of extra data words we want to push
;;; Bashes M-1 and M-2
METER-MICRO-WRITE-HEADER
	(CALL METER-SETUP)
METER-MICRO-WRITE-HEADER-1
	(POPJ-EQUAL M-ZERO A-TEM1)	;punt if not appropriate
	((C-PDL-BUFFER-POINTER-PUSH) PDL-BUFFER-INDEX)
	(CALL-XCT-NEXT METER-ASSURE-ROOM)
       ((PDL-BUFFER-INDEX) M-AP)
	(CALL-XCT-NEXT METER-WRITE-HEADER)
       ((M-1) C-PDL-BUFFER-INDEX)
	(JUMP-XCT-NEXT METER-CLEANUP)
       ((PDL-BUFFER-INDEX) C-PDL-BUFFER-POINTER-POP)

METER-MICRO-WRITE-HEADER-NO-SG-TEST
	(JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER-1)
       (CALL METER-SETUP-NO-SG-TEST)

;;; Take A-METER-LENGTH objects from the pdl, and put into meter buffer
;;; M-2 has microsecond clock reading when we started, so that metering
;;; overhead can be charged to A-DISK-WAIT-TIME.
METER-PUSH-LP
	((VMA) A-METER-BUFFER-POINTER)
	((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((A-METER-BUFFER-POINTER) M+A+1 M-ZERO A-METER-BUFFER-POINTER)
METER-CLEANUP
	(JUMP-LESS-THAN-XCT-NEXT M-ZERO A-METER-LENGTH METER-PUSH-LP)
       ((A-METER-LENGTH) ADD (M-CONSTANT -1) A-METER-LENGTH)
	((M-1) (BYTE-FIELD 8 0) VMA A-MINUS-ONE)
					;Screw case where we are pointing to last word
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-MINUS-ONE METER-CLEANUP-1)	;Still buffer left
       ((A-METER-LOCK) ADD (M-CONSTANT -1) A-METER-LOCK)
	(CALL-XCT-NEXT METER-FLUSH-BUFFER)	;Flush current buffer
       ((A-METER-BUFFER-POINTER) ADD (M-CONSTANT -1) A-METER-BUFFER-POINTER)
					;Decrement so that it points to the right block again
METER-CLEANUP-1
	(CALL-XCT-NEXT READ-MICROSECOND-CLOCK)
       ((A-TEM1) M-2)
	(POPJ-AFTER-NEXT (M-TEM) SUB M-2 A-TEM1)	;Time spent metering
       ((A-DISK-WAIT-TIME) ADD M-TEM A-DISK-WAIT-TIME)

;;; Returns with A-TEM1 = 0 if not appropriate to make this meter entry
;;; If not appropriate, pop off A-METER-LENGTH of pdl
;;; If appropriate, microsecond clock is in M-2
METER-SETUP
	(JUMP-IF-BIT-SET M-METER-STACK-GROUP-ENABLE METER-SETUP-NO-SG-TEST)	;This SG
	((M-TEM) A-METER-GLOBAL-ENABLE)						;Any SG
	(JUMP-NOT-EQUAL M-TEM A-V-TRUE METER-SETUP-1)
METER-SETUP-NO-SG-TEST
	(JUMP-NOT-EQUAL M-ZERO A-METER-LOCK METER-SETUP-1)
	((A-TEM1) DPB M-ZERO Q-ALL-BUT-POINTER A-METER-DISK-COUNT)
	(JUMP-NOT-EQUAL M-ZERO A-TEM1 READ-MICROSECOND-CLOCK)
METER-SETUP-1
	(POPJ-AFTER-NEXT
		(PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER A-METER-LENGTH)	;Pop args
       ((A-TEM1) SETZ)

;;; Writes the header of the meter info function is in M-1
;;; M-2 has the microsecond clock as of the time of entry
METER-WRITE-HEADER
	((C-PDL-BUFFER-POINTER-PUSH) M-1)
	;; Write length,,event
	((M-1 VMA) A-METER-BUFFER-POINTER)
	((M-TEM) A-METER-LENGTH)
	((M-TEM) ADD M-TEM (A-CONSTANT METER-OVERHEAD-LENGTH))
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-TEM METER-LENGTH A-METER-EVENT)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Write Usec timer
	((M-1 VMA) ADD M-1 (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) M-2)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Write the page fault time
	((M-1 VMA) ADD M-1 (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) A-DISK-WAIT-TIME)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Write page fault count
	((M-1 VMA) ADD M-1 (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) A-DISK-PAGE-READ-COUNT)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Write current stack group
	((M-1 VMA) ADD M-1 (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) A-QCSTKG)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Write current function
	((M-1 VMA) ADD M-1 (A-CONSTANT 1))
	((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP)	;Current function
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Write current stack depth (M-AP)
	((M-1 VMA) ADD M-1 (A-CONSTANT 1))
	((M-TEM) SUB M-AP A-PDL-BUFFER-HEAD)
	((M-TEM) DPB M-TEM (BYTE-FIELD 10. 0) A-ZERO)
	((M-TEM) ADD M-TEM A-PDL-BUFFER-VIRTUAL-ADDRESS)
	((WRITE-MEMORY-DATA-START-WRITE) SUB M-TEM A-QLPDLO)	;Current stack depth
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(POPJ-AFTER-NEXT			;Update buffer pointer
		(A-METER-BUFFER-POINTER) ADD M-1 (A-CONSTANT 1))

;;; Read microsecond clock into M-2  (preserve A-TEM1)
READ-MICROSECOND-CLOCK
	((VMA-START-READ) (A-CONSTANT 77772050))	;Unibus 764120
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-2) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;Unibus 764122
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(POPJ-AFTER-NEXT
		(M-2) DPB READ-MEMORY-DATA (BYTE-FIELD 20 20) A-2)
       (NO-OP)

;;; Sophisticated audio home entertainment center.

XBEEP (MISC-INST-ENTRY %BEEP)
;;; First argument is half-wavelength, second is duration.  Both are in microseconds.
;;; M-1 has 2nd argument (duration) which is added to initial time-check
;;; M-2 contains most recent time check
;;;     to compute quitting time
;;; M-C contains 1st argument, the wavelength
;;; M-4 contains the time at which the next click must be done.
;;; Note that the 32-bit clock wraps around once an hour, we have to be careful
;;; to compare clock values in the correct way, namely without overflow checking. 
	(CALL-XCT-NEXT READ-MICROSECOND-CLOCK)
       ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-1) M-1 ADD A-2)
	((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-4) M-2)
BEEP-NEXT-CLICK
	((M-4) M-4 ADD A-C)
BEEP-WAIT
	(CALL READ-MICROSECOND-CLOCK)
	((M-TEM) SUB M-2 A-1)
	(JUMP-GREATER-OR-EQUAL M-TEM A-ZERO XFALSE)
	((M-TEM) SUB M-2 A-4)
	(JUMP-LESS-OR-EQUAL M-TEM A-ZERO BEEP-WAIT)
	((VMA-START-WRITE) (A-CONSTANT 77772044))	;Unibus 764110
	(CHECK-PAGE-WRITE)
	(JUMP BEEP-NEXT-CLICK)

;;; TV ROUTINES

;(%DRAW-CHAR FONT-ARRAY-PNTR CHAR-CODE X-BIT-POS Y-BIT-POS ALU-FUNC SHEET)
;THE X-BIT-POS AND Y-BIT-POS ARE OF THE TOP LEFT CORNER OF THE CHARACTER.
; (0,0) IS THE TOP LEFT CORNER OF THE SCREEN
;THE ALU-FUNC IS SUITABLE FOR OA-REG-LOW.  GOOD VALUES ARE:
;	IOR	740
;	XOR	540
;	ANDCA	560
;	SETA	640
;YOU SHOULD USE THE TV:ALU- VARIABLES, THESE NUMBERS ARE MACHINE-DEPENDENT

;(%DRAW-RECTANGLE WIDTH HEIGHT X-BIT-POS Y-BIT-POS ALU-FUNC SHEET)
;WIDTH AND HEIGHT ARE IN BITS.  A RECTANGLE OF THE INDICATED
;SIZE, OF ALL 1S, IS CREATED AND STORED INTO THE SPECIFIED
;PART OF THE TV BUFFER USING THE SPECIFIED ALU-FUNC.  USUALLY
;THE ANDCA FUNCTION IS USED FOR ERASING, BUT XOR COULD BE USED
;FOR THE BLINKING CURSOR ETC.

;A FONT ARRAY MAY NOT BE DISPLACED OR ANYTHING HAIRY LIKE THAT.
;ITS ARRAY LEADER CONTAINS:
;	0	NOT USED IN CASE MIGHT BE FILL POINTER?
;	1	FONT (NAME-STRUCTURE-SYMBOL)
;	2	NAME
;	3	CHARACTER CELL HEIGHT
;	4	CHARACTER CELL WIDTH (USED IF ITEM 7 IS NIL)
;	5	RASTER HEIGHT
;	6	RASTER WIDTH
;	7	FLOOR 32./RASTER WIDTH (# ROWS PER WORD)
;	8	CEILING RASTER HEIGHT/#5 (# WORDS PER CHAR)
;	9	NIL OR ARRAY POINTER TO CHARACTER WIDTH TABLE
;	10	NIL OR ARRAY POINTER TO LEFT KERN TABLE

;THE DATA PART OF THE ARRAY CONTAINS AN INTEGRAL NUMBER OF WORDS
;PER CHARACTER.  EACH WORD CONTAINS AN INTEGRAL NUMBER OF ROWS
;OF RASTER, LEFT ADJUSTED AND PROCESSED FROM LEFT TO RIGHT.
;(RIGHT TO LEFT ON 32-BIT TVS)
;ALL 32 BITS OF EACH Q IN THIS ARRAY ARE USED.  FOR EASIEST PROCESSING
;BY LISP PROGRAMS, IT SHOULD BE OF 1-BIT BYTE ARRAY TYPE.

;%DRAW-CHAR ONLY WORKS FOR RASTER WIDTHS OF AT MOST 32 (DECIMAL).
;FOR LARGER WIDTHS IT TRAPS TO ILLOP.  MACROCODE DRAWS LARGER CHARACTERS
;BY DRAWING SEVERAL NARROWER CHARACTERS SIDE BY SIDE.

;NO SEQUENCE BREAKS IN TV ROUTINES DUE TO LARGE NUMBER OF ACS USED
;ALSO DUE TO SELECT-SHEET

;;; SELECT A SHEET FOR USE BY THE OTHER FUNCTIONS
;;; HERE ARE VARIABLES WE SET UP:
;;; A-TV-CURRENT-SHEET A-TV-SCREEN-BUFFER-ADDRESS A-TV-SCREEN-BUFFER-END-ADDRESS
;;; A-TV-SCREEN-LOCATIONS-PER-LINE A-TV-SCREEN-BUFFER-BIT-OFFSET
;;; A-TV-SCREEN-WIDTH A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT

;SUBROUTINE TO SELECT SHEET POPPED FROM PDL
;SMASHES M-A, M-B, M-C, M-D, M-E, M-Q, M-S, M-1
;ONLY REALLY GUARANTEED TO PRESERVE M-I, M-K, M-ZR
SELECT-SHEET	(ERROR-TABLE RESTART SELECT-SHEET)
	((M-C) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-TEM) Q-DATA-TYPE M-C)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE)) SELECT-SHEET-ARRAY)
	(CALL-NOT-EQUAL M-C A-CURRENTLY-PREPARED-SHEET TRAP)
		(ERROR-TABLE TURD-ALERT M-C)
	(POPJ-EQUAL M-C A-TV-CURRENT-SHEET)	;Already got data
SELECT-SHEET-1
	((VMA-START-READ) ADD M-C (A-CONSTANT 2)) ;Locations per line is second inst var
	(CHECK-PAGE-READ)
	((A-TV-SCREEN-LOCATIONS-PER-LINE) Q-POINTER READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-C (A-CONSTANT 14.))	;Width is 14th instance variable
	(CHECK-PAGE-READ)
	((A-TV-SCREEN-WIDTH) Q-POINTER READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-C (A-CONSTANT 1)) ;The array is the first instance variable
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(CALL-XCT-NEXT GAHDR)
       ((M-A) READ-MEMORY-DATA)
	(CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B DSP-ARRAY-SETUP)
       ((M-Q) A-ZERO)
	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B)
	((M-TEM) SUB M-TEM (A-CONSTANT 1))
	((A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT) DPB M-TEM OAL-MROT A-ZERO)
	(CALL-GREATER-THAN M-TEM (A-CONSTANT 5) TRAP)
		(ERROR-TABLE ARGTYP NUMERIC-ARRAY M-A)
	(CALL-NOT-EQUAL M-D (A-CONSTANT 2) TRAP)
		(ERROR-TABLE ARRAY-NUMBER-DIMENSIONS M-D 2 M-A)
	((OA-REG-LOW) A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	;; Offset of start of buffer in bits	
	((A-TV-SCREEN-BUFFER-BIT-OFFSET) DPB M-Q (BYTE-FIELD 27. 0) A-ZERO) 
	((A-TV-SCREEN-BUFFER-ADDRESS) M-E)
	((M-TEM) ADD (M-CONSTANT 40) A-TEM)	;Size in words depends on element size
	((M-TEM) SUB M-TEM (A-CONSTANT 5))	; (also calculate MROT in same calc)
	((OA-REG-LOW) DPB M-TEM OAL-MROT A-ZERO)
       ((M-TEM) (BYTE-FIELD 27. 0) M-S)		;Size of buffer in words
	(POPJ-AFTER-NEXT
	 (A-TV-SCREEN-BUFFER-END-ADDRESS) ADD M-TEM A-TV-SCREEN-BUFFER-ADDRESS)
       ((A-TV-CURRENT-SHEET) M-C)

SELECT-SHEET-ARRAY
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)))
		(ERROR-TABLE ARGTYP (INSTANCE ARRAY) M-C NIL SELECT-SHEET)
	(POPJ-EQUAL M-C A-TV-CURRENT-SHEET)	;Already got data
	((C-PDL-BUFFER-POINTER-PUSH) M-C)
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL BITBLT-DECODE-ARRAY)
	((A-TV-SCREEN-LOCATIONS-PER-LINE) (BYTE-FIELD 27. 5) M-1)
	((A-TV-SCREEN-WIDTH) Q-POINTER M-D)
	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B)
	((M-TEM) SUB M-TEM (A-CONSTANT 1))
	((A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT) DPB M-TEM OAL-MROT A-ZERO)
	(CALL-GREATER-THAN M-TEM (A-CONSTANT 5) TRAP)
		(ERROR-TABLE ARGTYP NUMERIC-ARRAY M-C)
	((A-TV-SCREEN-BUFFER-ADDRESS) M-A)
	((A-TV-SCREEN-BUFFER-BIT-OFFSET) (BYTE-FIELD 5 0) M-Q)
	(CALL-XCT-NEXT MPY)			;Q-R has Y dimension
       ((M-1) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(POPJ-AFTER-NEXT (A-TV-SCREEN-BUFFER-END-ADDRESS) ADD Q-R A-TV-SCREEN-BUFFER-ADDRESS)
       ((A-TV-CURRENT-SHEET) M-C)

;;; NEW TV-DRAW-CHAR MICROCODE, FOR 32-BIT TV BUFFERS, BITS NUMBERED RIGHT-TO-LEFT

;; THE CODE BELOW WILL NEVER READ OR STORE OUTSIDE THE MEMORY LIMITS SET BY THE SCREEN.
;;STORING BELOW THE REGULAR TV-BUFFER IS A PARTICULAR SCREW, SINCE A-MEMORY IS MAPPED THERE!
;;STORING ABOVE THE TV-BUFFER IS LESS DISASTEROUS NOW, BUT COULD EASILY CAUSE LOSSAGE
;;IN THE FUTURE.  IF (IN THE FUTURE) THIS CODE IS USED TO WRITE DIRECTLY INTO MEMORY
;;ARRAYS, IT WILL BE ESSENTIAL THAT IT NOT CLOBBER OUT OF BOUNDS.
;; THE ALTERNATIVE DECISION WOULD BE TO PUT THE RESPONSIBILITY ON THE CALLER OF TV-DRAW-CHAR
;;TO ASSURE THE ARGUMENTS WERE IN RANGE.  AGAINST THIS IS, (1) ITS CALLED TV-DRAW-CHAR
;;NOT %TV-DRAW-CHAR, SO IT SHOULDN'T BE CAPABLE OF DESTROYING STORAGE INTEGRITY AND
;;(2) STICKY PROBLEMS ARISE WITH CURSORS WHICH ARE PAINFUL TO DEAL WITH IN MACROCODE.
;;BASICALLY THE CURSOR WANTS TO BE ABLE TO POINT ANYWHERE ON THE SCREEN (INCLUDING THE
;;EDGE), MOVE SMOOTHLY, AND BE AT LEAST PARTIALLY VISIBLE AT ALL TIMES.
;; THE DISADVANTAGE OF CHECKING IN TV-DRAW-CHAR IS THAT SLOWS DOWN THE INNER LOOP
;;OF DRAWING CHARACTERS.  THIS IS CURRENTLY NOT TOO IMPORTANT SINCE CASES OF INTEREST ARE
;;DOMINATED BY PER CHARACTER MACRO-CODE EXECUTION TIMES, AND THE PERCENT SLOWDOWN
;;EVEN WITHIN TV-DRAW-CHAR IS SMALL.


X-DRAW-CHAR (MISC-INST-ENTRY %DRAW-CHAR)
	(CALL SELECT-SHEET)
	(CALL-XCT-NEXT TVXYADR)				;M-E GETS WORD ADDR, M-T BIT OFFSET
       ((M-J) DPB C-PDL-BUFFER-POINTER-POP OAL-ALUF)	;M-J GETS ALU FUNCTION
	    (ERROR-TABLE CALLS-SUB %DRAW-CHAR)
	((M-I) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;M-I GETS CHARACTER CODE
	(CALL-XCT-NEXT GAHDRA)				;M-A ARRAY POINTER, M-E DATA ADDRESS
       ((M-C) M-E)					;M-C SAVES TV BUFFER ADDRESS
  (ERROR-TABLE CALLS-SUB TV-DRAW-CHAR)
	((VMA-START-READ) SUB M-A (A-CONSTANT 10.))	;GET NUMBER OF WORDS PER CHAR
	(CHECK-PAGE-READ)
	((Q-R) M-I)					;AND MULTIPLY BY CHARACTER CODE
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB READ-MEMORY-DATA (BYTE-FIELD 20. 12.) A-ZERO)	;M-2 GETS PRODUCT
	((VMA-START-READ) SUB M-A (A-CONSTANT 8.))	;M-B GETS RASTER WIDTH
	(CHECK-PAGE-READ)
	((M-B) Q-POINTER READ-MEMORY-DATA)
	((VMA-START-READ) SUB M-A (A-CONSTANT 9.))	;M-R GETS NUMBER OF ROWS PER WORD
	(CHECK-PAGE-READ)
	(CALL-GREATER-THAN M-B (A-CONSTANT 32.) ILLOP)	;TOO WIDE
	((M-I) SUB (M-CONSTANT 40) A-B)			;40 - RASTER WIDTH
		;THIS HAS OVERFLOW BUG IF M-B=40, BUT WILL NEVER BE USED IN THAT CASE ANYWAY
	((M-Q) DPB M-I OAL-BYTL-1 A-I)			;LDB PNTR +40 TO SHIFT FONT WORD
	((M-R) Q-POINTER READ-MEMORY-DATA)		; RIGHT BY ONE RASTER ROW
	((VMA-START-READ) SUB M-A (A-CONSTANT 7))	;M-D GETS RASTER HEIGHT
	(CHECK-PAGE-READ)
	((M-K) ADD M-B A-T)				;RASTER WIDTH PLUS BIT OFFSET
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-K (A-CONSTANT 40) XTVCH4) ;JUMP IF DOESN'T CROSS
       ((M-D) Q-POINTER READ-MEMORY-DATA)		; WORD BOUNDARY
							;NOTE C(M-T) > 0, SO NO OVERFLOW
	((M-TEM) SUB (M-CONSTANT 40) A-T)		;LENGTH OF BYTE AT LEFT OF 1ST WORD
	((M-T) DPB M-TEM OAL-BYTL-1 A-T)		;DPB PNTR +40 FOR THAT BYTE
	((M-I) DPB M-K OAL-BYTL-1 A-T)			;LDB PNTR +40 FOR BYTE AT RIGHT OF 2ND
;DROPS THROUGH
;DROPS IN
	((VMA-START-READ M-E) ADD M-2 A-E)		;FETCH FIRST WORD OF RASTER
;M-1 WORD FROM FONT ARRAY
;M-A FONT ARRAY POINTER
;M-B RASTER WIDTH
;M-C TV BUFFER WORD ADDRESS
;M-D RASTER HEIGHT (NUMBER OF ROWS TO GO)
;M-E ADDRESS OF WORD IN FONT ARRAY
;M-I LDB PNTR +40 TO STORE INTO SECOND TV WORD
;M-J ALU FUNCTION
;M-Q LDB PNTR +40 TO SHIFT FONT WORD RIGHT ONE RASTER ROW
;M-R NUMBER OF RASTER ROWS PER WORD
;M-S NUMBER OF RASTER ROWS IN M-1
;M-T DPB PNTR +40 TO STORE INTO FIRST TV WORD
;HERE WITH FETCH OF NEXT RASTER WORD STARTED, IN THE CASE WHERE IT CROSSES A WORD BOUNDARY
XTVCH1	(CHECK-PAGE-READ)
	((M-S) M-R)					;THIS MANY ROWS IN THIS WORD
	((M-1) READ-MEMORY-DATA)			;M-1 GETS WORD FROM FONT ARRAY
;HERE FOR EACH ROW OF RASTER, IN THE CASE WHERE IT CROSSES A WORD BOUNDARY
XTVCH2  (JUMP-LESS-THAN M-C A-TV-SCREEN-BUFFER-ADDRESS XTVCHO1)  ;COMMENT ABOUT RANGE CHECKING 
	(JUMP-GREATER-OR-EQUAL M-C A-TV-SCREEN-BUFFER-END-ADDRESS XTVCHO1)  ;ABOVE
	((VMA-START-READ) M-C)				;GET FIRST TV BUFFER WORD
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-LOW) SUB M-T (A-CONSTANT 40))		;ALIGN RASTER
       ((M-2) DPB M-1 (BYTE-FIELD 0 0) A-ZERO)
	((OA-REG-LOW) M-J)				;COMBINE AND STORE BACK
       ((WRITE-MEMORY-DATA-START-WRITE) SETZ READ-MEMORY-DATA A-2)
	(CHECK-PAGE-WRITE)
XTVCHO1	((VMA) ADD M-C (A-CONSTANT 1))
	(JUMP-LESS-THAN VMA A-TV-SCREEN-BUFFER-ADDRESS XTVCHO2)
	(JUMP-GREATER-OR-EQUAL VMA A-TV-SCREEN-BUFFER-END-ADDRESS XTVCHO2)
	((VMA-START-READ) ADD M-C (A-CONSTANT 1))	;GET SECOND TV BUFFER WORD
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-LOW) SUB M-I (A-CONSTANT 40))		;ALIGN RASTER
       ((M-2) (BYTE-FIELD 0 0) M-1)
	((OA-REG-LOW) M-J)				;COMBINE AND STORE BACK
       ((WRITE-MEMORY-DATA-START-WRITE) SETZ READ-MEMORY-DATA A-2)
	(CHECK-PAGE-WRITE)
XTVCHO2	(JUMP-LESS-OR-EQUAL M-D (A-CONSTANT 1) XFALSE)	;STOP IF DONE
	((M-D) SUB M-D (A-CONSTANT 1))
	((M-C) ADD M-C A-TV-SCREEN-LOCATIONS-PER-LINE)	;ADVANCE TO NEXT LINE
	((OA-REG-LOW) SUB M-Q (A-CONSTANT 40))		;SHIFT RASTER RIGHT
       ((M-1) (BYTE-FIELD 0 0) M-1)
	(JUMP-GREATER-THAN-XCT-NEXT M-S (A-CONSTANT 1) XTVCH2)	;JUMP IF WORD NOT USED UP
       ((M-S) SUB M-S (A-CONSTANT 1))
	(JUMP-XCT-NEXT XTVCH1)				;FETCH NEW WORD
       ((VMA-START-READ M-E) ADD M-E (A-CONSTANT 1))

;THIS VERSION OF THE ABOVE IS FOR THE FAST CASE, WHERE IT DOES NOT CROSS A WORD BOUNDARY
XTVCH4	((M-T) DPB M-B (BYTE-FIELD 6 5) A-T)		;DPB PNTR +40 FOR ALIGNING RASTER
		;BYTE-FIELD IS ALMOST OAL-BYTL-1
	((VMA-START-READ M-E) ADD M-2 A-E)		;FETCH FIRST WORD OF RASTER
;M-1 WORD FROM FONT ARRAY
;M-A FONT ARRAY POINTER
;M-B RASTER WIDTH
;M-C TV BUFFER WORD ADDRESS
;M-D RASTER HEIGHT (NUMBER OF ROWS TO GO)
;M-E ADDRESS OF WORD IN FONT ARRAY
;M-J ALU FUNCTION
;M-Q LDB PNTR +40 TO SHIFT FONT WORD RIGHT ONE RASTER ROW
;M-R NUMBER OF RASTER ROWS PER WORD
;M-S NUMBER OF RASTER ROWS IN M-1
;M-T DPB PNTR +40 TO STORE INTO TV WORD
;HERE WITH FETCH OF NEXT RASTER WORD STARTED
XTVCH5	(CHECK-PAGE-READ)
	((M-S) M-R)					;THIS MANY ROWS IN THIS WORD
	((M-1) READ-MEMORY-DATA)			;M-1 GETS WORD FROM FONT ARRAY
;HERE FOR EACH ROW OF RASTER
XTVCH6	(JUMP-LESS-THAN M-C A-TV-SCREEN-BUFFER-ADDRESS XTVCHO3)  ;COMMENT ABOUT RANGE CHECKING 
	(JUMP-GREATER-OR-EQUAL M-C A-TV-SCREEN-BUFFER-END-ADDRESS XTVCHO3)  ;ABOVE
	((VMA-START-READ) M-C)				;GET TV BUFFER WORD
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-LOW) SUB M-T (A-CONSTANT 40))		;ALIGN RASTER
       ((M-2) DPB M-1 (BYTE-FIELD 0 0) A-ZERO)
	((OA-REG-LOW) M-J)				;COMBINE AND STORE BACK
       ((WRITE-MEMORY-DATA-START-WRITE) SETZ READ-MEMORY-DATA A-2)
	(CHECK-PAGE-WRITE)
XTVCHO3	(JUMP-LESS-OR-EQUAL M-D (A-CONSTANT 1) XFALSE)	;STOP IF DONE
	((M-D) SUB M-D (A-CONSTANT 1))
	((M-C) ADD M-C A-TV-SCREEN-LOCATIONS-PER-LINE)	;ADVANCE TO NEXT LINE
	((OA-REG-LOW) SUB M-Q (A-CONSTANT 40))		;SHIFT RASTER RIGHT
       ((M-1) (BYTE-FIELD 0 0) M-1)
	(JUMP-GREATER-THAN-XCT-NEXT M-S (A-CONSTANT 1) XTVCH6)	;JUMP IF WORD NOT USED UP
       ((M-S) SUB M-S (A-CONSTANT 1))
	(JUMP-XCT-NEXT XTVCH5)				;FETCH NEW WORD
       ((VMA-START-READ M-E) ADD M-E (A-CONSTANT 1))

;12-BIT UNSIGNED MULTIPLY
; M-1<31:12> TIMES Q-R <11:0> TO M-2<31:0>.  M-1<11:0> MUST BE ZERO.
MPY12	((M-2) MULTIPLY-STEP A-1 M-ZERO)
(REPEAT 9 ((M-2) MULTIPLY-STEP M-2 A-1))
	(POPJ-AFTER-NEXT (M-2) MULTIPLY-STEP M-2 A-1)
       ((M-2) MULTIPLY-STEP M-2 A-1)

;NEW VERSION OF TVXYADR
;POP OFF Y-BIT-POS AND X-BIT-POS AND CONVERT TO WORD AND BIT ADDRESS
;M-E GETS ABSOLUTE WORD ADDRESS, M-T GETS BIT OFFSET FROM RIGHT (LEFT) IF 32 (16) BIT.
;CLOBBER M-1, M-2
TVXYADR	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP NIL)
	((M-1) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 20. 12.) A-ZERO) ;Y POSITION (LSH 12)
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP NIL)
	(CALL-XCT-NEXT MPY12)
       ((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)		;M-2 GETS OFFSET TO START OF LINE
TVXYAD0 ((OA-REG-LOW) A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	;; X coordinate gets multiplied by pixel size
	((M-TEM) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 24. 0) A-ZERO)
	((M-TEM) ADD M-TEM A-TV-SCREEN-BUFFER-BIT-OFFSET)
	((M-1) (BYTE-FIELD 19. 5) M-TEM)		;WORD PART OF X POSITION
	((OA-REG-HIGH) (BYTE-FIELD 1 18.) M-1)
	((M-1) SELECTIVE-DEPOSIT M-ZERO (BYTE-FIELD 13. 19.) A-1)
	((M-E) ADD M-2 A-1)				;RELATIVE WORD ADDRESS
	(POPJ-AFTER-NEXT (M-E) ADD M-E A-TV-SCREEN-BUFFER-ADDRESS)
       ((M-T) (BYTE-FIELD 5 0) M-TEM)			;BIT PART OF X POSITION

;;; TV-ERASE width height x y alu

X-DRAW-RECTANGLE (MISC-INST-ENTRY %DRAW-RECTANGLE)
	(CALL SELECT-SHEET)
	(CALL-XCT-NEXT TVXYADR)				;M-E := ADDR, M-T := BIT OFFSET
       ((M-J) DPB C-PDL-BUFFER-POINTER-POP OAL-ALUF)	;ALU FUNC
	    (ERROR-TABLE CALLS-SUB %DRAW-RECTANGLE)
	((M-D) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;HEIGHT IN RASTER LINES
XTVERS5	((OA-REG-LOW) A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	((M-C) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 24. 0) A-ZERO)	;WIDTH IN BITS
	;; Fix up tag field
	((M-C) SELECTIVE-DEPOSIT M-C Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP-EQUAL M-D A-ZERO XFALSE)			;DO NOTHING IF HEIGHT IS ZERO
	(JUMP-EQUAL M-C (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XFALSE)	;OR WIDTH
	((M-C C-PDL-BUFFER-POINTER-PUSH) ADD M-T A-C)	;ADJUST WIDTH TO PRETEND
							; STARTING ON WORD BOUNDARY
	((M-C) (BYTE-FIELD 19. 5) M-C)			;WIDTH IN WORDS
	((M-Q) (BYTE-FIELD 5 0) (M-CONSTANT -1))	;37 ;LOAD HANDY CONSTANT, USED LATER
	((M-K) SUB M-Q A-T)				;BYTL-1 FOR FIRST WORD
	((OA-REG-LOW) DPB M-K OAL-BYTL-1 A-T)		;GET MASK FOR BITS IN LEFT OF 1ST WD
	((M-K) DPB (M-CONSTANT -1) (BYTE-FIELD 0 0) A-ZERO)
	(JUMP-EQUAL-XCT-NEXT M-C A-ZERO XTVERS3)	;JUMP IF NARROW (LESS THAN 1 WORD)
XTVERS0((M-B) M-D)					;COPY OF HEIGHT
	(CALL-LESS-THAN M-E A-TV-SCREEN-BUFFER-ADDRESS TRAP)
  (ERROR-TABLE TV-ERASE-OFF-SCREEN)
	(CALL-GREATER-OR-EQUAL M-E A-TV-SCREEN-BUFFER-END-ADDRESS TRAP)
  (ERROR-TABLE TV-ERASE-OFF-SCREEN)			;This is special.
	((VMA-START-READ) M-E)				;FETCH TOP LEFT-HAND WORD
XTVERS1	(CHECK-PAGE-READ-NO-INTERRUPT)			;DO FIRST COLUMN
	(JUMP-LESS-OR-EQUAL M-B A-ZERO XTVERS2)		;JUMP IF COLUMN ALL DONE
	(CALL-GREATER-OR-EQUAL VMA A-TV-SCREEN-BUFFER-END-ADDRESS TRAP)
  (ERROR-TABLE TV-ERASE-OFF-SCREEN)			;This is special.
	((OA-REG-LOW) M-J)
	((WRITE-MEMORY-DATA-START-WRITE) SETZ READ-MEMORY-DATA A-K)
	(CHECK-PAGE-WRITE)
	((M-B) SUB M-B (A-CONSTANT 1))
	(JUMP-XCT-NEXT XTVERS1)
       ((VMA-START-READ) ADD VMA A-TV-SCREEN-LOCATIONS-PER-LINE)

XTVERS2	((M-E) ADD M-E (A-CONSTANT 1))			;NEXT COLUMN
	((M-C) SUB M-C (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-C A-ZERO XTVERS0)
       ((M-K) SETO)					;DO MIDDLE COLUMNS, MASK IS ALL BITS
	(JUMP-LESS-THAN M-C A-ZERO XFALSE)		;ALL DONE (SECOND TIME THROUGH HERE)
XTVERS3	((M-B) AND C-PDL-BUFFER-POINTER-POP A-Q)	;NUMBER BITS TO DO IN LAST COLUMN
	(JUMP-EQUAL M-B A-ZERO XFALSE)			;NO LAST COLUMN, RETURN NIL
	((M-B) SUB M-B (A-CONSTANT 1))
	((OA-REG-LOW) DPB M-B OAL-BYTL-1 A-ZERO)	;CLEAR THAT MANY BITS ON THE LEFT
	((M-K) (BYTE-FIELD 0 0) M-K)
	(JUMP XTVERS0)

;;;Line drawing

X-DRAW-LINE (MISC-INST-ENTRY %DRAW-LINE)
	(CALL SELECT-SHEET)
TVDRL0	((A-DRAW-LINE-DRAW-LAST-POINT) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;endpoint flag
	((A-DRAW-LINE-DRAW-FIRST-POINT) Q-POINTER A-V-TRUE)
	((M-J) DPB C-PDL-BUFFER-POINTER-POP OAL-ALUF)	;M-J ALU function
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 3)
	    (ERROR-TABLE ARG-POPPED 0 M-J A-DRAW-LINE-DRAW-LAST-POINT)
	((M-4) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;M-4 Y
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	    (ERROR-TABLE ARG-POPPED 0 M-4 M-J A-DRAW-LINE-DRAW-LAST-POINT)
	((M-TEM) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;M-TEM X
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 1)
	    (ERROR-TABLE ARG-POPPED 0 M-TEM M-4 M-J A-DRAW-LINE-DRAW-LAST-POINT)
	((M-2) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;M-2 Y0
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 0)
	    (ERROR-TABLE ARG-POPPED 0 M-2 M-TEM M-4 M-J A-DRAW-LINE-DRAW-LAST-POINT)
	((M-S) SUB M-4 A-2)				;M-S DY
	((M-1) Q-POINTER C-PDL-BUFFER-POINTER)		;M-1 X0
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-TEM A-1 TVDRL1)	;DX0?
       ((M-R) SUB M-TEM A-1)				;M-R DX
	((M-R) SUB M-ZERO A-R)				;yes, exch X and X0
	((C-PDL-BUFFER-POINTER) DPB M-TEM Q-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-S) SUB M-ZERO A-S)				;and Y and Y0
	((M-2) M-4)
	((A-DRAW-LINE-DRAW-FIRST-POINT) A-DRAW-LINE-DRAW-LAST-POINT)	;and endpoint flags
	((A-DRAW-LINE-DRAW-LAST-POINT) Q-POINTER A-V-TRUE)
	;;DX now assured of being non-negative
TVDRL1  ((C-PDL-BUFFER-POINTER-PUSH) DPB M-2 Q-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL TVXYADR)					;M-E addr M-T bit offset
	    (ERROR-TABLE CALLS-SUB %DRAW-LINE)
	    (ERROR-TABLE ARG-POPPED 0 M-1 M-2 M-TEM M-4 M-J A-DRAW-LINE-DRAW-LAST-POINT)
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-S A-ZERO TVDRL2)
       ((M-I) A-TV-SCREEN-LOCATIONS-PER-LINE)		;M-I Y increment with correct sign
	((M-I) SUB M-ZERO A-I)
	((M-S) SUB M-ZERO A-S)
TVDRL2	((M-K) SUB M-R A-S)				;M-K flag for DY>DX
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-K A-ZERO TVDRL3)
       ((M-C) M-R)					;number of points to do on long side
	((M-C) M-S)					;exch DX and DY
	((M-S) M-R)
	((M-R) M-C)
TVDRL3	((M-A) (BYTE-FIELD 23. 1) M-R)			;M-A <length of long side>/2
	((OA-REG-LOW) A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT)	;Log of pixel size
	((M-2) DPB (M-CONSTANT -1) (BYTE-FIELD 1 0) A-ZERO)	;Number of bits in pixel
	((M-1) SUB M-2 (A-CONSTANT 1))
	((M-1) DPB M-1 OAL-BYTL-1 A-ZERO)		;Position for hardware byte size
	(JUMP-EQUAL M-ZERO A-DRAW-LINE-DRAW-FIRST-POINT TVDRL7)	;Skip first point?
TVDRL4	(JUMP-LESS-THAN M-E A-TV-SCREEN-BUFFER-ADDRESS TVDRL7) ;Clip
	(JUMP-GREATER-OR-EQUAL M-E A-TV-SCREEN-BUFFER-END-ADDRESS TVDRL7) ;Clip
	((VMA-START-READ) M-E)				;get data
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-LOW) DPB M-T OAL-MROT A-1)		;bit offset
       ((M-TEM) SELECTIVE-DEPOSIT (BYTE-FIELD 0 0) (M-CONSTANT -1))	;M-TEM byte to twiddle
	((OA-REG-LOW) M-J)				;ALU
       ((WRITE-MEMORY-DATA-START-WRITE) SETZ READ-MEMORY-DATA A-TEM)	;munge it
	(CHECK-PAGE-WRITE)
TVDRL7	(JUMP-GREATER-THAN-XCT-NEXT M-C (A-CONSTANT 1) TVDRL8)	;lots more to do
       ((M-C) SUB M-C (A-CONSTANT 1))
	(JUMP-LESS-THAN M-C A-ZERO XFALSE)		;return if done stepping long side
	(JUMP-EQUAL M-ZERO A-DRAW-LINE-DRAW-LAST-POINT XFALSE)	;or skipping last point
TVDRL8	((M-A) SUB M-A A-S)
	(JUMP-LESS-THAN M-A A-ZERO TVDRL5)		;time to bump short side too?
	(JUMP-GREATER-OR-EQUAL M-K A-ZERO TVDRL6)	;just increment long side
	(JUMP-XCT-NEXT TVDRL4)				;y side longer
TVDRL5 ((M-E) ADD M-E A-I)				;increment both x and y
	((M-A) ADD M-A A-R)
TVDRL6	((M-T) ADD M-T A-2)				;increment x
	(JUMP-LESS-THAN M-T (A-CONSTANT 40) TVDRL4)	;see if past end of word
	((M-E) ADD M-E (A-CONSTANT 1))			;move to next word
	(JUMP-XCT-NEXT TVDRL4)
       ((M-T) SETZ)

; (BITBLT alu width height from-array from-x from-y to-array to-x to-y)
;Features:
; The X and Y arguments specify the coordinates of the upper-left-hand
;  corner of the <width> x <height> region to be operated on.  The operation
;  is normally performed top to bottom then left to right, but making
;  width or height negative will make it go the other way, useful when
;  regions overlap.  The X and Y should still be for the top-left corner.
; Works on any numeric array type.  For more than 1-bit bytes, the X and Y arguments
;  are in bytes rather than bits.
; If you run off the edge of the source array, it wraps around
;  to the opposite edge.  This is intended to allow such
;  things as replication of small stipple patterns through a large screen area.
;  If you run off the edge of the destination array, an error occurs.
; The function cannot be made to reference outside of the argument arrays
;  by giving it bad arguments.
;Crocks:
; Requires that the first dimension of the array be a multiple of 32. bits.
; Index-offset arrays do not work with wrap-around.
;Register conventions are commented a little bit later.

BITBLT (MISC-INST-ENTRY BITBLT)
	(CALL BITBLT-DECODE-ARRAY)			;Decode destination
	((M-C) M-1)					;Save BITBLT-DST-WIDTH
	((M-ZR) SUB Q-R A-4)				;Save eventual contents of M-T
	((M-I) M-A)					;Save eventual contents of M-D
	((M-R) M-Q)					;X offset in bits
	((M-1) SUB (M-CONSTANT 23.) A-3)		;Make DPB ptr to convert width
	((M-K) DPB M-1 OAL-BYTL-1 A-3)			; from bytes to bits
	(CALL BITBLT-DECODE-ARRAY)			;Decode source
	;; No sequence breaks after this point
	((A-BITBLT-DST-WIDTH) M-C)			;Get dest parameters saved above
	((M-T) M-ZR)
	((M-D) M-I)
	((A-BITBLT-SRC-WIDTH) M-1)			;Save source parameters
	((A-BITBLT-SRC-WIDTH-WORDS) (BYTE-FIELD 27. 5) M-1) ;This copy is always positive
	;; Set up the vertical address increments and column heights for the arrays
	((M-B) (BYTE-FIELD 27. 5) M-1)			;Word increment between source rows
	((M-C) Q-R)					;Total number of source rows
	((A-BITBLT-SRC-Y Q-R) M-4)			;Number of rows down we start at
	(CALL-XCT-NEXT MPY)				;Initial Y
       ((M-1) A-BITBLT-SRC-WIDTH-WORDS)			; times words per row
	((A-BITBLT-SRC-Y-OFFSET) Q-R)			; gives offset from top of column
	((M-A) SUB M-A A-BITBLT-SRC-Y-OFFSET)		;Start M-A at top of column
	((M-1) A-BITBLT-DST-WIDTH)
	((M-E) (BYTE-FIELD 27. 5) M-1)			;Word increment between dest rows
	;; Get the height in M-S.  If negative, make positive and rearrange parameters
	;; so that it will start at the bottom and move up.
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER BITBLT-1)
       ((M-S) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-S) SUB M-ZERO A-S)				;Negative height, change around
	((M-S) Q-POINTER M-S)
	((M-B) SUB M-ZERO A-B)
	((M-E) SUB M-ZERO A-E)
	((M-1) SUB M-C (A-CONSTANT 1))			;Change tops of columns to bottoms
	(CALL-XCT-NEXT MPY)
       ((Q-R) SUB M-ZERO A-B)
	((M-A) ADD Q-R A-A)
	((M-1) ADD M-S A-BITBLT-SRC-Y)			;Move source offset to other end
	(CALL-XCT-NEXT DIV)				;Taking modulo size of source
       ((M-2) M-C)
	((A-BITBLT-SRC-Y Q-R) SUB M-C A-1)		;Number rows offset is up from bottom
	(CALL-XCT-NEXT MPY)
       ((M-1) SUB M-ZERO A-BITBLT-SRC-WIDTH-WORDS)
	((A-BITBLT-SRC-Y-OFFSET) Q-R)			;Negative offset up from bottom
	((M-1) SUB M-S (A-CONSTANT 1))
	(CALL-XCT-NEXT MPY)
       ((Q-R) SUB M-ZERO A-E)
	((M-D) ADD Q-R A-D)
BITBLT-1	;Now get the width, check for negative
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 1)
	((OA-REG-LOW) M-K)				;Convert from bytes to bits
	((M-1) DPB C-PDL-BUFFER-POINTER-POP A-ZERO)
	(JUMP-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT M-1 BITBLT-RTL) ;Neg width means right to left
       ((A-ALUF) DPB C-PDL-BUFFER-POINTER-POP OAL-ALUF)	;Alu function
	((A-BITBLT-HOR-COUNT) SUB M-ZERO A-1)		;Sign-extended negative width
;Drops through into BITBLT-LTR
;drops in
	;; Now, enter a loop by columns.  Each column is as wide as will avoid
	;; crossing word boundaries in source and in destination.
	;; This is for left-to-right case
BITBLT-LTR
	;; Compute width of column to be done.
	((M-1) (BYTE-FIELD 5 0) M-Q)			;Source bit offset
	((M-2) (BYTE-FIELD 5 0) M-R)			;Destination bit offset
	((M-3) SUB M-Q A-BITBLT-SRC-WIDTH)		;Negative bits left in source array
	((M-J) SUB M-1 (A-CONSTANT 40))			;Negative bits left in source word
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-J A-3 BITBLT-LTR-1)	;Take the smaller
       ((M-I) SUB M-2 A-1)				;Left rotate for source
	((M-J) M-3)					;Reached right-hand end of array
BITBLT-LTR-1
	((M-3) SUB M-R A-BITBLT-DST-WIDTH)		;Negative bits left in dest array
	((M-1) SUB M-2 (A-CONSTANT 40))			;Negative bits left in dest word
	(JUMP-GREATER-OR-EQUAL M-1 A-3 BITBLT-LTR-2)	;Take the smaller
	((M-1) M-3)
BITBLT-LTR-2
	(JUMP-GREATER-OR-EQUAL M-J A-1 BITBLT-LTR-3)	;Take smaller of src, dest
	((M-J) M-1)
BITBLT-LTR-3
	(JUMP-GREATER-OR-EQUAL M-J A-BITBLT-HOR-COUNT BITBLT-LTR-4) ;Min with overall count
	((M-J) A-BITBLT-HOR-COUNT)
BITBLT-LTR-4	;Here M-J has negative width of this column
	(JUMP-GREATER-OR-EQUAL M-J A-ZERO XFALSE)	;Return NIL if zero width (can't do)
	((M-TEM) M-A-1 M-ZERO A-J)			;Positive byte length minus one
	((M-K) DPB M-TEM (BYTE-FIELD 27. 5) A-R)	;Byte pointer to part of destination
	(CALL-XCT-NEXT BITBLT-INNER-LOOP)		; to be modified
       ((A-BITBLT-HOR-COUNT) M+A+1 M-TEM A-BITBLT-HOR-COUNT)	;Advance negative bit count
	(JUMP-LESS-OR-EQUAL M-ZERO A-BITBLT-HOR-COUNT XFALSE)	;Return NIL if done
	((M-TEM) (BYTE-FIELD 5 0) (M-CONSTANT -1) A-Q)	;Last bit this source word
	((M-Q) SUB M-Q A-J)				;Advance source X bit offset
	(JUMP-LESS-OR-EQUAL M-Q A-TEM BITBLT-LTR-5)
	((M-A) ADD M-A (A-CONSTANT 1))			;Entered next word
BITBLT-LTR-5
	(JUMP-LESS-THAN M-Q A-BITBLT-SRC-WIDTH BITBLT-LTR-6)
	((M-Q) SUB M-Q A-BITBLT-SRC-WIDTH)		;Wrap around (M-Q should get 0 here)
	((M-A) SUB M-A A-BITBLT-SRC-WIDTH-WORDS)
BITBLT-LTR-6
	((M-TEM) (BYTE-FIELD 5 0) (M-CONSTANT -1) A-R)	;Last bit this destination word
	((M-R) SUB M-R A-J)				;Advance destination X bit offset
	(JUMP-LESS-OR-EQUAL M-R A-TEM BITBLT-LTR-7)
	((M-D) ADD M-D (A-CONSTANT 1))			;Entered next word
BITBLT-LTR-7
	(JUMP-LESS-THAN M-R A-BITBLT-DST-WIDTH BITBLT-LTR)	;Loop for more columns
	(CALL TRAP)
	    (ERROR-TABLE BITBLT-DESTINATION-TOO-SMALL)

	;; Now, enter a loop by columns.  Each column is as wide as will avoid
	;; crossing word boundaries in source and in destination.
	;; This is for right-to-left case
BITBLT-RTL
	((M-1) Q-POINTER M-1 (A-CONSTANT -1))		;Sign-extended negative width
	((A-BITBLT-HOR-COUNT) SUB M-ZERO A-1)		;We want it positive
	;; Adjust parameters to point to after right-most column to be done
	((M-TEM) (BYTE-FIELD 27. 5) M-R)
	((M-D) SUB M-D A-TEM)
	((M-R) ADD M-R A-BITBLT-HOR-COUNT)		;Bit offset to right of dest area
	(CALL-GREATER-THAN M-R A-BITBLT-DST-WIDTH TRAP)
	    (ERROR-TABLE BITBLT-DESTINATION-TOO-SMALL)
	((M-TEM) (BYTE-FIELD 27. 5) M-R)
	((M-D) ADD M-D A-TEM)				;Corresponding word address
	((M-TEM) (BYTE-FIELD 27. 5) M-Q)
	((M-A) SUB M-A A-TEM)
	((M-1) ADD M-Q A-BITBLT-HOR-COUNT)		;Bit offset to right of source area
	(CALL-XCT-NEXT DIV)				;Take modulo source width
       ((M-2) A-BITBLT-SRC-WIDTH)			; to effect wrap-around
	((M-Q) M-1)					;Remainder is initial bit offset
	((M-TEM) (BYTE-FIELD 27. 5) M-Q)
	((M-A) ADD M-A A-TEM)				;Corresponding word address
BITBLT-RTL-LOOP
	;; Compute width of column to be done, to left of these bit offsets
	(JUMP-GREATER-THAN M-Q A-ZERO BITBLT-RTL-0)	;Check for wrap-around
	((M-Q) A-BITBLT-SRC-WIDTH)
	((M-A) ADD M-A A-BITBLT-SRC-WIDTH-WORDS)
BITBLT-RTL-0
	((M-J) (BYTE-FIELD 5 0) M-Q)			;Source bit offset
	(JUMP-NOT-EQUAL M-J A-ZERO BITBLT-RTL-1)	;Jump if not at left of word
	((M-A) SUB M-A (A-CONSTANT 1))			;Else back up to previous word
	((M-J) (A-CONSTANT 40))				;And there are 40 bits in it
BITBLT-RTL-1
	((M-2) (BYTE-FIELD 5 0) M-R)			;Destination bit offset
	(JUMP-NOT-EQUAL-XCT-NEXT M-2 A-ZERO BITBLT-RTL-2) ;Jump if not at left of word
       ((M-I) SUB M-2 A-J)				;Left rotate for source
	((M-D) SUB M-D (A-CONSTANT 1))			;Else back up to previous word
	((M-2) (A-CONSTANT 40))				;And there are 40 bits in it
BITBLT-RTL-2
	(JUMP-LESS-OR-EQUAL M-J A-2 BITBLT-RTL-3)	;Take lesser of bits left in words
	((M-J) M-2)
BITBLT-RTL-3
	(JUMP-LESS-OR-EQUAL M-J A-Q BITBLT-RTL-4)	;Min with bits left in source array
	((M-J) M-Q)					;(Dest array already range-checked)
BITBLT-RTL-4
	(JUMP-LESS-OR-EQUAL M-J A-BITBLT-HOR-COUNT BITBLT-RTL-5)
	((M-J) A-BITBLT-HOR-COUNT)			;Min with bits left to do
BITBLT-RTL-5	;M-J now has positive number of bits in this column
	(JUMP-LESS-OR-EQUAL M-J A-ZERO XFALSE)		;Return NIL if zero width (can't do)
	((M-K) SUB M-R A-J)				;<5:0>=MROT for dest bits to modify
	((M-TEM) SUB M-J (A-CONSTANT 1))		;BYTL-1 for dest bits to modify
	((M-K) DPB M-TEM (BYTE-FIELD 27. 5) A-K)	;Byte pointer to part of destination
	((M-TEM) SUB M-ZERO A-J)			; to be modified
	(CALL-XCT-NEXT BITBLT-INNER-LOOP)
       ((A-BITBLT-HOR-COUNT) ADD M-TEM A-BITBLT-HOR-COUNT)	;Decrease bit count
	((M-Q) SUB M-Q A-J)				;Decrease source bit offset
	(JUMP-LESS-THAN-XCT-NEXT M-ZERO A-BITBLT-HOR-COUNT BITBLT-RTL-LOOP)
       ((M-R) SUB M-R A-J)				;Decrease destination bit offset 
	(JUMP XFALSE)					;Done

;;; Inner loop of vertical BITBLT
;;; Note, does wrap-around in the vertical coordinates of the source
;;; Args:  (none of these are modified)
;;;  A-ALUF alu-function (source is "A" operand)
;;;  M-I left rotate for source word (only low 5 bits looked at)
;;;  M-K selective-deposit B.P. for part of destination to change
;;;  M-S height of column
;;;  M-A source column address (top if M-B positive, bottom inclusive if M-B negative)
;;;  M-B source address increment, M-C source column height
;;;  A-BITBLT-SRC-Y, A-BITBLT-SRC-Y-OFFSET Y coord and word offset thereof
;;;   These determine the initial location referenced in the source column
;;;  M-D destination column address (top if M-E positive, bottom inclusive if M-E negative)
;;;      This is the first destination address referenced
;;;  M-E destination address increment, M-T destination column height
;;; Temps:
;;;  M-1 source address, M-2 destination address, A-BITBLT-TEM rotated source word
;;;  M-3 source rows before wrap-around
;;;  A-BITBLT-COUNT negative rows before done, M-4 loop counter for inner inner loop
;;; Only used in caller:
;;;  M-Q horizontal bit offset in source
;;;  M-R horizontal bit offset in destination
;;;  M-J bit count (width of this column)

BITBLT-INNER-LOOP
	((M-1) SUB M-A A-B)				;Init source address
	((M-1) ADD M-1 A-BITBLT-SRC-Y-OFFSET)		;Offset to actual starting place
	((M-3) SUB M-C A-BITBLT-SRC-Y)			;Number source rows until wrap-around
	((M-2) SUB M-D A-E)				;Init destination address
	(CALL-LESS-THAN M-T A-S TRAP)			;Range-check destination
	    (ERROR-TABLE BITBLT-DESTINATION-TOO-SMALL)
	((A-BITBLT-COUNT) SUB M-ZERO A-S)		;Init negative total row count
BITBLT-INNER-0		;Loops back to here
	(JUMP-GREATER-THAN-XCT-NEXT M-3 A-ZERO BITBLT-INNER-1)	;Check source wrap-around
       ((M-4) SUB M-ZERO A-BITBLT-COUNT)		;Assume we'll be doing all rows at once
	((M-1) SUB M-A A-B)				;Wrap-around, init source address
	((M-3) M-C)					; and row count to top
BITBLT-INNER-1
	(JUMP-GREATER-THAN M-3 A-4 BITBLT-INNER-2)	;Do only up to
	((M-4) M-3)					; next source wrap point
BITBLT-INNER-2
	(POPJ-LESS-OR-EQUAL M-4 A-ZERO)			;Zero-length array, or we're done
	((A-BITBLT-COUNT) ADD M-4 A-BITBLT-COUNT)	;Count down remaining rows
	((M-3) SUB M-3 A-4)				;Count down source rows before wrap
	;; Check for fast case not requiring rotate nor read of destination
	((M-TEM) (BYTE-FIELD 5 0) M-I A-K)		;Check for rotate or part-word
	((M-TEM) DPB M-TEM (BYTE-FIELD 10. 6) A-ALUF)	;Check for ALU function of SETA
	(JUMP-EQUAL M-TEM (A-CONSTANT 174050) BITBLT-INNER-4)	;Go to fast case
BITBLT-INNER-3		;This is the inner inner loop
	((VMA-START-READ M-1) ADD M-1 A-B)		;Fetch source word
	(CHECK-PAGE-READ)
	((OA-REG-LOW) DPB M-I OAL-MROT A-ZERO)		;Rotate it into position
	((A-BITBLT-TEM) (BYTE-FIELD 32. 0) READ-MEMORY-DATA)
	((VMA-START-READ M-2) ADD M-2 A-E)		;Fetch destination word
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-LOW) A-ALUF)				;ALU func
	((M-TEM) SETZ READ-MEMORY-DATA A-BITBLT-TEM)	;Combine source and dest
	((A-TEM1) READ-MEMORY-DATA)			;Get onto A side
	((OA-REG-LOW) M-K)				;Store back under byte control
	((WRITE-MEMORY-DATA-START-WRITE)
		SELECTIVE-DEPOSIT M-TEM (BYTE-FIELD 0 0) A-TEM1)
	(CHECK-PAGE-WRITE)
	(JUMP-GREATER-THAN-XCT-NEXT M-4 (A-CONSTANT 1) BITBLT-INNER-3)
       ((M-4) SUB M-4 (A-CONSTANT 1))
	(POPJ-XCT-NEXT)
       (CALL-NOT-EQUAL M-ZERO A-BITBLT-COUNT BITBLT-INNER-0)	;Jump if more to do

BITBLT-INNER-5		;This is the fast inner inner loop
	((VMA-START-WRITE M-2) ADD M-2 A-E)		;Store destination word
	(CHECK-PAGE-WRITE)
BITBLT-INNER-4
	((VMA-START-READ M-1) ADD M-1 A-B)		;Fetch source word
	(CHECK-PAGE-READ)
	((M-4) SUB M-4 (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-4 A-ZERO BITBLT-INNER-5)
       ((WRITE-MEMORY-DATA) READ-MEMORY-DATA)		;Check parity
	((VMA-START-WRITE M-2) ADD M-2 A-E)		;Store last destination word
	(CHECK-PAGE-WRITE)
	(POPJ-XCT-NEXT)
       (CALL-NOT-EQUAL M-ZERO A-BITBLT-COUNT BITBLT-INNER-0)	;Jump if more to do

;;; Decode array, x, y on the stack into:
;;; M-1	X dimension of array in bits
;;; Q-R	Y dimension of array
;;; M-4 initial Y-coordinate
;;; M-Q initial X coordinate in bits
;;; M-A word address of selected bit
;;; M-3 OA-REG-LOW value to convert bytes to bits 
;;; Preserves: M-C, M-I, M-K, M-R, M-ZR (array routines better preserve these)

BITBLT-DECODE-ARRAY
	(CALL XAR2)					;Access the array in usual way
	;; Leaves following stuff sitting around:
	;; M-A the array, M-E base address, VMA word address, M-Q 1-D index,
	;; M-D first dimension, M-S product of dimensions, M-B array header
	((M-3) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B)	;Array type.  For a numeric array,
	((M-3) SUB M-3 (A-CONSTANT 1))			; it is 1+ log2 of the byte size.
	(CALL-GREATER-THAN M-3 (A-CONSTANT 5) TRAP)	;Bigger than 32-bit byte? Non-numeric
	    (ERROR-TABLE ARGTYP NUMERIC-ARRAY M-A)
	((M-1) Q-POINTER M-Q)				;Convert index into (X,Y) coords
	(CALL-XCT-NEXT DIV)				;Q-R gets Y, M-1 gets X
       ((M-2) Q-POINTER M-D)
	((M-4) Q-R)
	((M-Q) M-1)
	((M-1) Q-POINTER M-S)				;Compute second dimension (in Q-R)
	(CALL-XCT-NEXT DIV)
       ((M-2) Q-POINTER M-D)
	((OA-REG-LOW) M-3)				;Rotate first dimension left
	((M-1) (BYTE-FIELD 32. 0) M-2)
	((M-2) (BYTE-FIELD 5 0) M-1)			;Width must be multiple of 32 bits
	(CALL-NOT-EQUAL M-2 A-ZERO TRAP)
	    (ERROR-TABLE BITBLT-ARRAY-FRACTIONAL-WORD-WIDTH M-A)
	((OA-REG-LOW) M-3)				;Convert X coordinate to bits
	(POPJ-AFTER-NEXT (M-Q) (BYTE-FIELD 32. 0) M-Q)
       ((M-A) Q-POINTER VMA)				;Word address of selected bit

;;; %DRAW-TRIANGLE X1 Y1 X2 Y2 X3 Y3 ALU SHEET

X-DRAW-TRIANGLE (MISC-INST-ENTRY %DRAW-TRIANGLE)
	(CALL SELECT-SHEET)
	((M-J) DPB C-PDL-BUFFER-POINTER-POP OAL-ALUF)	;M-J ALU function
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 5)
	(CALL FXUNPK-P-1)	;M-1 Y3 sign extended
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 4)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 X3 sign extended
       ((M-C) M-1)		;M-C Y3
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 3)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 Y2 sign extended
       ((M-3) M-1)		;M-3 X3
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 X2 sign extended
       ((M-B) M-1)		;M-B Y2
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 1)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 Y1 sign extended
       ((M-2) M-1)		;M-2 X2
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 0)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 X1 sign extended
       ((M-A) M-1)		;M-A Y1
	;;Sort by Y co-ordinate
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-A A-B TV-DRAW-TRI-SORT-1)
       ((M-TEM) M-1)
	((M-1) M-2)
	((M-2) M-TEM)
	((M-TEM) M-A)
	((M-A) M-B)
	((M-B) M-TEM)
TV-DRAW-TRI-SORT-1
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-A A-C TV-DRAW-TRI-SORT-2)
       ((M-TEM) M-1)
	((M-1) M-3)
	((M-3) M-TEM)
	((M-TEM) M-A)
	((M-A) M-C)
	((M-C) M-TEM)
TV-DRAW-TRI-SORT-2
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-B A-C TV-DRAW-TRI-SORT-3)
       ((M-TEM) M-2)
	((M-2) M-3)
	((M-3) M-TEM)
	((M-TEM) M-B)
	((M-B) M-C)
	((M-C) M-TEM)
TV-DRAW-TRI-SORT-3
	;;Now sorted, Y1 > Y2 > Y3
	((A-TRI-Y1) M-A)
	((A-TRI-X1) M-1)
	((A-TRI-Y2) M-B)
	((A-TRI-X2) M-2)
	((A-TRI-Y3) M-C)
	((A-TRI-X3) M-3)
	;;Now compute Y co-ordinates as array addresses
	((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB M-A (BYTE-FIELD 20. 12.) A-ZERO)
	((A-TRI-Y1-ADDR) SUB M-2 A-TV-SCREEN-LOCATIONS-PER-LINE)
	((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB M-B (BYTE-FIELD 20. 12.) A-ZERO)
	((A-TRI-Y2-ADDR) M-2)
	((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB M-C (BYTE-FIELD 20. 12.) A-ZERO)
	((A-TRI-Y3-ADDR) M-2)
	;;Compute determinant to get handedness
	((M-1) SUB M-3 A-TRI-X1)	;X3 - X1
	(CALL-XCT-NEXT MPY)
       ((Q-R) SUB M-B A-A)		;Y2 - Y1
	((M-3) Q-R)			;(X3 - X1) * (Y2 - Y1)
	((M-1) A-TRI-X1)
	((M-1) SUB M-1 A-TRI-X2)	;X1 - X2
	(CALL-XCT-NEXT MPY)
       ((Q-R) SUB M-A A-C)		;Y1 - Y3
	((A-TRI-DET) SUB Q-R A-3)	;((X1 - X2) * (Y1 - Y3)) - ((Y1 - Y2) * (X1 - X3))
	(JUMP-EQUAL-XCT-NEXT M-ZERO A-TRI-DET XFALSE)	;Colinear, draw nothing
       ((M-1) A-TRI-X1)
	((M-B) A-TRI-Y1)
	((M-2) A-TRI-X2)
	(CALL-XCT-NEXT TV-DRAW-TRI-1)
       ((M-C) A-TRI-Y2)
	((M-1) A-TRI-X1)
	((M-B) A-TRI-Y1)
	((M-2) A-TRI-X3)
	(CALL-XCT-NEXT TV-DRAW-TRI-1)
       ((M-C) A-TRI-Y3)
	((M-A) A-TRI-Y1-ADDR)		;Initial Y address
	((A-TRI-Y-LIM) A-TRI-Y2-ADDR)	;Ending Y address for bottom half
TV-DRAW-TRI-LOOP
	(JUMP-GREATER-OR-EQUAL M-A A-TRI-Y-LIM TV-DRAW-TRI-LOOP-1)
TV-DRAW-TRI-HALF-DONE
	(JUMP-LESS-THAN-XCT-NEXT M-A A-TRI-Y3-ADDR XFALSE)	;Done with second half
       ((A-TRI-Y-LIM) A-TRI-Y3-ADDR)
	((M-1) A-TRI-X2)
	((M-B) A-TRI-Y2)
	((M-2) A-TRI-X3)
	(CALL-XCT-NEXT TV-DRAW-TRI-1)
       ((M-C) A-TRI-Y3)
TV-DRAW-TRI-LOOP-1
	(JUMP-LESS-THAN-XCT-NEXT M-A A-ZERO TV-DRAW-TRI-SKIP-LINE)
       ((M-D) M-S)		;Nominal right end
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-R A-ZERO TV-DRAW-TRI-X0-OK)
       ((M-C) M-R)		;Nominal left end
	((M-C) SETZ)		;M-C clipped left end
	(JUMP-GREATER-OR-EQUAL M-D A-C TV-DRAW-TRI-X0-OK)
	((M-D) SETZ)		;Right may be to left of clipped left
TV-DRAW-TRI-X0-OK
	((C-PDL-BUFFER-POINTER-PUSH) M-C)	;Setup x co-ordinate
	(CALL-XCT-NEXT TVXYAD0)
       ((M-2) M-A)			;Setup Y co-ordinate
	(JUMP-GREATER-OR-EQUAL M-E A-TV-SCREEN-BUFFER-END-ADDRESS TV-DRAW-TRI-SKIP-LINE)
	(JUMP-LESS-OR-EQUAL M-D A-TV-SCREEN-WIDTH TV-DRAW-TRI-X1-OK)
	((M-D) A-TV-SCREEN-WIDTH)	;M-D clipped right end
	(JUMP-GREATER-OR-EQUAL M-D A-C TV-DRAW-TRI-X1-OK)
	((M-C) M-D)		;Left may be to right of clipped right
TV-DRAW-TRI-X1-OK
	((C-PDL-BUFFER-POINTER-PUSH) SUB M-D A-C)	;Setup width
	(CALL-XCT-NEXT XTVERS5)
       ((M-D) (A-CONSTANT 1))		;Height is 1
TV-DRAW-TRI-SKIP-LINE
	((M-A) SUB M-A A-TV-SCREEN-LOCATIONS-PER-LINE)	;Y := Y - 1
	((M-3) SUB M-3 A-TRI-XLIR)	;XLR := XLR - XLIR
	(JUMP-LESS-THAN-XCT-NEXT M-3 A-ZERO TV-DRAW-TRI-XLR-NEG)
       ((M-R) SUB M-R A-TRI-XLI)	;XL := XL - XLI
	(JUMP-GREATER-OR-EQUAL M-3 A-TRI-LY TV-DRAW-TRI-XLR-WRAP)
TV-DRAW-TRI-INCR-1
	((M-4) SUB M-4 A-TRI-XRIR)	;XRR := XRR - XRIR
	(JUMP-LESS-THAN-XCT-NEXT M-4 A-ZERO TV-DRAW-TRI-XRR-NEG)
       ((M-S) SUB M-S A-TRI-XRI)	;XR := XR - XRI
	(JUMP-LESS-THAN M-4 A-TRI-RY TV-DRAW-TRI-LOOP)
TV-DRAW-TRI-XRR-WRAP
	((M-4) SUB M-4 A-TRI-RY)
	(JUMP-XCT-NEXT TV-DRAW-TRI-LOOP)
       ((M-S) ADD M-S (A-CONSTANT 1))
TV-DRAW-TRI-XLR-NEG
	((M-3) ADD M-3 A-TRI-LY)
	(JUMP-XCT-NEXT TV-DRAW-TRI-INCR-1)
       ((M-R) SUB M-R (A-CONSTANT 1))
TV-DRAW-TRI-XLR-WRAP
	((M-3) SUB M-3 A-TRI-LY)
	(JUMP-XCT-NEXT TV-DRAW-TRI-INCR-1)
       ((M-R) ADD M-R (A-CONSTANT 1))
TV-DRAW-TRI-XRR-NEG
	((M-4) ADD M-4 A-TRI-RY)
	(JUMP-XCT-NEXT TV-DRAW-TRI-LOOP)
       ((M-S) SUB M-S (A-CONSTANT 1))

;;;This sets up the starting and incrementing remainders and quotients for the left or right
;;;point depending on the sign of det, which it complements, so as to do the other one next
;;;time.
TV-DRAW-TRI-1
	((A-TRI-DET) SUB M-ZERO A-TRI-DET)
	((M-C) SUB M-B A-C)		;Y1 - Y2
	(JUMP-EQUAL-XCT-NEXT M-C A-ZERO XFALSE)	;Avoid divide by 0
       ((M-T) SUB M-1 A-2)		;X1 - X2
	((M-1) DPB M-1 (BYTE-FIELD 31. 1) (A-CONSTANT 1))	;(2 * X1) + 1
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-C)
	((M-1) SUB Q-R A-T)		;L := (((2 * X1) + 1) * (Y1 - Y2)) - (X1 - X2)
	((M-C) ADD M-C A-C)		;DY := 2 * (Y1 - Y2)
	(CALL-XCT-NEXT DIV)
       ((M-2) M-C)
	((M-B) Q-R)			;Save L DIV DY
	((M-I) M-1)			;Save L REM DY
	((M-1) ADD M-T A-T)
	(CALL-XCT-NEXT DIV)
       ((M-2) M-C)
	(JUMP-LESS-THAN M-ZERO A-TRI-DET TV-DRAW-TRI-1-R)
TV-DRAW-TRI-1-L
	((A-TRI-LY) M-C)
	((M-R) M-B)
	((M-3) M-I)
	(POPJ-AFTER-NEXT (A-TRI-XLI) Q-R)
       ((A-TRI-XLIR) M-1)

TV-DRAW-TRI-1-R
	((A-TRI-RY) M-C)
	((M-S) M-B)
	((M-4) M-I)
	(POPJ-AFTER-NEXT (A-TRI-XRI) Q-R)
       ((A-TRI-XRIR) M-1)

;;; %AOS-TRIANGLE X1 Y1 X2 Y2 X3 Y3 INCREMENT SHEET
;;; Increment each pixel inside the triangle by the specified amount

X-AOS-TRIANGLE (MISC-INST-ENTRY %AOS-TRIANGLE)
	(CALL SELECT-SHEET)
	((M-J) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;M-J increment amount
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 5)
	(CALL FXUNPK-P-1)	;M-1 Y3 sign extended
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 4)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 X3 sign extended
       ((M-C) M-1)		;M-C Y3
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 3)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 Y2 sign extended
       ((M-3) M-1)		;M-3 X3
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 X2 sign extended
       ((M-B) M-1)		;M-B Y2
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 1)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 Y1 sign extended
       ((M-2) M-1)		;M-2 X2
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP FIXNUM PP 0)
	(CALL-XCT-NEXT FXUNPK-P-1)	;M-1 X1 sign extended
       ((M-A) M-1)		;M-A Y1
	;;Sort by Y co-ordinate
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-A A-B TV-AOS-TRI-SORT-1)
       ((M-TEM) M-1)
	((M-1) M-2)
	((M-2) M-TEM)
	((M-TEM) M-A)
	((M-A) M-B)
	((M-B) M-TEM)
TV-AOS-TRI-SORT-1
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-A A-C TV-AOS-TRI-SORT-2)
       ((M-TEM) M-1)
	((M-1) M-3)
	((M-3) M-TEM)
	((M-TEM) M-A)
	((M-A) M-C)
	((M-C) M-TEM)
TV-AOS-TRI-SORT-2
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-B A-C TV-AOS-TRI-SORT-3)
       ((M-TEM) M-2)
	((M-2) M-3)
	((M-3) M-TEM)
	((M-TEM) M-B)
	((M-B) M-C)
	((M-C) M-TEM)
TV-AOS-TRI-SORT-3
	;;Now sorted, Y1 > Y2 > Y3
	((A-TRI-Y1) M-A)
	((A-TRI-X1) M-1)
	((A-TRI-Y2) M-B)
	((A-TRI-X2) M-2)
	((A-TRI-Y3) M-C)
	((A-TRI-X3) M-3)
	;;Now compute Y co-ordinates as array addresses
	((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB M-A (BYTE-FIELD 20. 12.) A-ZERO)
	((A-TRI-Y1-ADDR) SUB M-2 A-TV-SCREEN-LOCATIONS-PER-LINE)
	((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB M-B (BYTE-FIELD 20. 12.) A-ZERO)
	((A-TRI-Y2-ADDR) M-2)
	((Q-R) A-TV-SCREEN-LOCATIONS-PER-LINE)
	(CALL-XCT-NEXT MPY12)
       ((M-1) DPB M-C (BYTE-FIELD 20. 12.) A-ZERO)
	((A-TRI-Y3-ADDR) M-2)
	;;Compute determinant to get handedness
	((M-1) SUB M-3 A-TRI-X1)	;X3 - X1
	(CALL-XCT-NEXT MPY)
       ((Q-R) SUB M-B A-A)		;Y2 - Y1
	((M-3) Q-R)			;(X3 - X1) * (Y2 - Y1)
	((M-1) A-TRI-X1)
	((M-1) SUB M-1 A-TRI-X2)	;X1 - X2
	(CALL-XCT-NEXT MPY)
       ((Q-R) SUB M-A A-C)		;Y1 - Y3
	((A-TRI-DET) SUB Q-R A-3)	;((X1 - X2) * (Y1 - Y3)) - ((Y1 - Y2) * (X1 - X3))
	(JUMP-EQUAL-XCT-NEXT M-ZERO A-TRI-DET XFALSE)	;Colinear, draw nothing
       ((M-1) A-TRI-X1)
	((M-B) A-TRI-Y1)
	((M-2) A-TRI-X2)
	(CALL-XCT-NEXT TV-DRAW-TRI-1)
       ((M-C) A-TRI-Y2)
	((M-1) A-TRI-X1)
	((M-B) A-TRI-Y1)
	((M-2) A-TRI-X3)
	(CALL-XCT-NEXT TV-DRAW-TRI-1)
       ((M-C) A-TRI-Y3)
	((M-A) A-TRI-Y1-ADDR)		;Initial Y address
	((A-TRI-Y-LIM) A-TRI-Y2-ADDR)	;Ending Y address for bottom half
TV-AOS-TRI-LOOP
	(JUMP-GREATER-OR-EQUAL M-A A-TRI-Y-LIM TV-AOS-TRI-LOOP-1)
TV-AOS-TRI-HALF-DONE
	(JUMP-LESS-THAN-XCT-NEXT M-A A-TRI-Y3-ADDR XFALSE)	;Done with second half
       ((A-TRI-Y-LIM) A-TRI-Y3-ADDR)
	((M-1) A-TRI-X2)
	((M-B) A-TRI-Y2)
	((M-2) A-TRI-X3)
	(CALL-XCT-NEXT TV-DRAW-TRI-1)
       ((M-C) A-TRI-Y3)
TV-AOS-TRI-LOOP-1
	(JUMP-LESS-THAN-XCT-NEXT M-A A-ZERO TV-AOS-TRI-SKIP-LINE)
       ((M-D) M-S)		;Nominal right end
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-R A-ZERO TV-AOS-TRI-X0-OK)
       ((M-C) M-R)		;Nominal left end
	((M-C) SETZ)		;M-C clipped left end
	(JUMP-GREATER-OR-EQUAL M-D A-C TV-AOS-TRI-X0-OK)
	((M-D) SETZ)		;Right may be to left of clipped left
TV-AOS-TRI-X0-OK
	((C-PDL-BUFFER-POINTER-PUSH) M-C)	;Setup x co-ordinate
	(CALL-XCT-NEXT TVXYAD0)
       ((M-2) M-A)			;Setup Y co-ordinate
	(JUMP-GREATER-OR-EQUAL M-E A-TV-SCREEN-BUFFER-END-ADDRESS TV-AOS-TRI-SKIP-LINE)
	(JUMP-LESS-OR-EQUAL M-D A-TV-SCREEN-WIDTH TV-AOS-TRI-X1-OK)
	((M-D) A-TV-SCREEN-WIDTH)	;M-D clipped right end
	(JUMP-GREATER-OR-EQUAL M-D A-C TV-AOS-TRI-X1-OK)
	((M-C) M-D)		;Left may be to right of clipped right
TV-AOS-TRI-X1-OK
	((M-C) SUB M-D A-C)			;Width in pixels
;;; ******* BEGIN CHANGE FROM %DRAW-TRIANGLE
	;; M-C has width in pixels
	;; M-E has starting address of word
	;; M-J has pixel increment amount
	;; M-T has bit offset into first word
	(JUMP-EQUAL M-C A-ZERO TV-AOS-TRI-SKIP-LINE)
	((M-Q) (A-CONSTANT 1))
	((OA-REG-LOW) A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	((M-Q) DPB M-Q (BYTE-FIELD 1 0) A-ZERO)
	((M-Q) SUB M-Q (A-CONSTANT 1))
	;; M-Q has number of bits per pixel minus 1
	((M-D) M-T)				;Get starting bit position
	((VMA-START-READ) M-E)			;Fetch left-hand word
TV-AOS-TRI-INC-LOOP
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-K) READ-MEMORY-DATA)		;Word containing up to 8 bytes
TV-AOS-TRI-INC-NEXT-BYTE
	((M-C) SUB M-C (A-CONSTANT 1))		;Decrement number of pixels left
	((M-TEM) SUB (M-CONSTANT 40) A-D)	;Reflect around 32. for LDB
	((OA-REG-LOW) DPB OAL-BYTL-1 M-Q A-TEM)	;Rotation and size
	((M-TEM) LDB (BYTE-FIELD 0 0) M-K A-ZERO) ;Get byte of interest
	((M-TEM) ADD M-TEM A-J)			;Frob pixel
	((OA-REG-LOW) DPB OAL-BYTL-1 M-Q A-D)
	((M-K) DPB (BYTE-FIELD 0 0) M-TEM A-K)	;Store frobbed pixel
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-C A-ZERO TV-AOS-TRI-INC-WRITE-WORD) ;Jump if row done
       ((M-D) ADD M-D A-Q)			;Also number of bits left in word minus 1
        ;; Write word and get next if at end of word
	(JUMP-LESS-THAN-XCT-NEXT M-D (A-CONSTANT 31.) TV-AOS-TRI-INC-NEXT-BYTE)
       ((M-D) ADD M-D (A-CONSTANT 1))		;Fix up M-T, which is off by one
TV-AOS-TRI-INC-WRITE-WORD
	((WRITE-MEMORY-DATA-START-WRITE) M-K)	;Ran out of the word, store it back
	((M-K) SETZ)				;Don't leave shit that GC won't like
	(CHECK-PAGE-WRITE)
        (JUMP-LESS-OR-EQUAL-XCT-NEXT M-C A-ZERO TV-AOS-TRI-SKIP-LINE)	;Terminate if no more
       ((M-D) SETZ)				;Start at low order bit
	(JUMP-XCT-NEXT TV-AOS-TRI-INC-LOOP)	;Else read next word and go on
       ((VMA-START-READ) ADD VMA (A-CONSTANT 1))
;;; ******* END CHANGE FROM %DRAW-TRIANGLE
TV-AOS-TRI-SKIP-LINE
	((M-A) SUB M-A A-TV-SCREEN-LOCATIONS-PER-LINE)	;Y := Y - 1
	((M-3) SUB M-3 A-TRI-XLIR)	;XLR := XLR - XLIR
	(JUMP-LESS-THAN-XCT-NEXT M-3 A-ZERO TV-AOS-TRI-XLR-NEG)
       ((M-R) SUB M-R A-TRI-XLI)	;XL := XL - XLI
	(JUMP-GREATER-OR-EQUAL M-3 A-TRI-LY TV-AOS-TRI-XLR-WRAP)
TV-AOS-TRI-INCR-1
	((M-4) SUB M-4 A-TRI-XRIR)	;XRR := XRR - XRIR
	(JUMP-LESS-THAN-XCT-NEXT M-4 A-ZERO TV-AOS-TRI-XRR-NEG)
       ((M-S) SUB M-S A-TRI-XRI)	;XR := XR - XRI
	(JUMP-LESS-THAN M-4 A-TRI-RY TV-AOS-TRI-LOOP)
TV-AOS-TRI-XRR-WRAP
	((M-4) SUB M-4 A-TRI-RY)
	(JUMP-XCT-NEXT TV-AOS-TRI-LOOP)
       ((M-S) ADD M-S (A-CONSTANT 1))
TV-AOS-TRI-XLR-NEG
	((M-3) ADD M-3 A-TRI-LY)
	(JUMP-XCT-NEXT TV-AOS-TRI-INCR-1)
       ((M-R) SUB M-R (A-CONSTANT 1))
TV-AOS-TRI-XLR-WRAP
	((M-3) SUB M-3 A-TRI-LY)
	(JUMP-XCT-NEXT TV-AOS-TRI-INCR-1)
       ((M-R) ADD M-R (A-CONSTANT 1))
TV-AOS-TRI-XRR-NEG
	((M-4) ADD M-4 A-TRI-RY)
	(JUMP-XCT-NEXT TV-AOS-TRI-LOOP)
       ((M-S) SUB M-S (A-CONSTANT 1))

;;; Given a rectangle of an ART-4B array, and 16 values which specify new values
;;; for the pixels (indexed by current pixel value), hacks the ART-4B array appropriately
;;;
;;; (%COLOR-TRANSFORM N17 N16 N15 N14 N13 N12 N11 N10 N7 N6 N5 N4 N3 N2 N1 N0
;;;		      WIDTH HEIGHT ARRAY START-X START-Y)

XCOLOR-TRANSFORM (MISC-INST-ENTRY %COLOR-TRANSFORM)
	(CALL XAR2)
	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL (LSH ART-4B ARRAY-TYPE-SHIFT))) TRAP)
	    (ERROR-TABLE ARGTYP ART-4B-ARRAY M-A)
	(CALL FXGTPP)		;M-1 width, M-2 height
	(JUMP-LESS-OR-EQUAL M-1 A-ZERO COLR-DONE)	;Don't do anything if width is zero
	((M-D) Q-POINTER M-D)				;Get rid of data type

	;;; Outer loop over all Y's
	;;; M-E is array base address
	;;; M-J is current array index
	;;; M-S is array length
	;;; M-1 is rectangle width
	;;; M-2 is row counter
	;;; M-C is byte counter
	;;; M-D is total array width
	;;; M-Q holds array index of start of next row
COLR-NEXT-Y
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-2 A-ZERO COLR-DONE)
       ((M-2) SUB M-2 (A-CONSTANT 1))			;One fewer iterations
	((M-C) M-1)					;Do this many bytes
	((M-TEM) (BYTE-FIELD 21. 3) M-Q)		;Word offset in array
	((VMA-START-READ) ADD M-E A-TEM)
	((M-J) M-Q)					;Copy array index
	((M-Q) ADD M-Q A-D)				;Start of next row
COLR-NEXT-WORD
	(CALL-GREATER-OR-EQUAL M-J A-S TRAP)		;Bounds checking
	    (ERROR-TABLE SUBSCRIPT-OOB M-J M-S)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-4) READ-MEMORY-DATA)			;Word containing up to 8 bytes
COLR-NEXT-BYTE
	((M-C) SUB M-C (A-CONSTANT 1))
	((M-K) DPB M-J (BYTE-FIELD 3 2) A-ZERO)		;Rotation amount in bits
	((M-TEM) SUB (M-CONSTANT 40) A-K)		;To rotate byte to low end of word
	((OA-REG-LOW) DPB M-TEM OAL-MROT A-ZERO)
	((M-3) (BYTE-FIELD 4 0) M-4 A-ZERO)		;Get byte field
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-3)	;Offset to new byte
	((OA-REG-LOW) DPB M-K OAL-MROT A-ZERO)
	((M-4) DPB C-PDL-BUFFER-INDEX (BYTE-FIELD 4 0) A-4)	;Replace byte
	(JUMP-LESS-OR-EQUAL M-C A-ZERO COLR-WRITE-WORD)	;Jump if row done
	(JUMP-LESS-THAN-XCT-NEXT M-K (A-CONSTANT 34) COLR-NEXT-BYTE)	;Jump if word not done
       ((M-J) ADD M-J (A-CONSTANT 1))			;One more byte rotation
COLR-WRITE-WORD
	((WRITE-MEMORY-DATA-START-WRITE) M-4)		;Ran out of the word, store it back
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-OR-EQUAL M-C A-ZERO COLR-NEXT-Y)	;Terminate if no more
	(JUMP-XCT-NEXT COLR-NEXT-WORD)			;Else read next word and go on
       ((VMA-START-READ) ADD VMA (A-CONSTANT 1))

COLR-DONE
	(JUMP-XCT-NEXT XTRUE)
       ((PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 16.))

;;; "Build a better mousetrap and the world will beat a path to your door"
;;;					-- Samuel F. B. Morse

XSET-MOUSE-SCREEN (MISC-INST-ENTRY %SET-MOUSE-SCREEN)
	(CALL SWAP-TV-AND-MOUSE-SCREENS)
	(CALL SELECT-SHEET-0)
		;drops through
SWAP-TV-AND-MOUSE-SCREENS
	((M-TEM) A-MOUSE-SCREEN-BUFFER-ADDRESS)
	((A-MOUSE-SCREEN-BUFFER-ADDRESS) A-TV-SCREEN-BUFFER-ADDRESS)
	((A-TV-SCREEN-BUFFER-ADDRESS) M-TEM)
	((M-TEM) A-MOUSE-SCREEN-BUFFER-END-ADDRESS)
	((A-MOUSE-SCREEN-BUFFER-END-ADDRESS) A-TV-SCREEN-BUFFER-END-ADDRESS)
	((A-TV-SCREEN-BUFFER-END-ADDRESS) M-TEM)
	((M-TEM) A-MOUSE-SCREEN-LOCATIONS-PER-LINE)
	((A-MOUSE-SCREEN-LOCATIONS-PER-LINE) A-TV-SCREEN-LOCATIONS-PER-LINE)
	((A-TV-SCREEN-LOCATIONS-PER-LINE) M-TEM)
	((M-TEM) A-MOUSE-SCREEN-BUFFER-BIT-OFFSET)
	((A-MOUSE-SCREEN-BUFFER-BIT-OFFSET) A-TV-SCREEN-BUFFER-BIT-OFFSET)
	((A-TV-SCREEN-BUFFER-BIT-OFFSET) M-TEM)
	((M-TEM) A-MOUSE-SCREEN-WIDTH)
	((A-MOUSE-SCREEN-WIDTH) A-TV-SCREEN-WIDTH)
	((A-TV-SCREEN-WIDTH) M-TEM)
	((M-TEM) A-MOUSE-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	((A-MOUSE-SCREEN-BUFFER-PIXEL-SIZE-MROT) A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	((A-TV-SCREEN-BUFFER-PIXEL-SIZE-MROT) M-TEM)
	((M-TEM) A-MOUSE-SCREEN)
	(POPJ-AFTER-NEXT (A-MOUSE-SCREEN) A-TV-CURRENT-SHEET)
       ((A-TV-CURRENT-SHEET) M-TEM)

SELECT-SHEET-0
	((M-C) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	((M-TEM) Q-DATA-TYPE M-C)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE)) SELECT-SHEET-ARRAY)
	(JUMP SELECT-SHEET-1)

;XOR the mouse cursor into the screen at its current position (except that if
;MOUSE-X, MOUSE-Y lie outside the MOUSE-SHEET, force the cursor to stay inside.)
;Due to the offset, the bits of the cursor can hang out in any direction.  We
;clip at the top and bottom, but let it wrap around at left and right for now.
;Uses M-1, M-2, M-A, M-B, M-E, M-T, Q-R, M-TEM only
XOR-MOUSE-CURSOR
	((M-A) A-MOUSE-CURSOR-X)
	((M-B) A-MOUSE-CURSOR-Y)
XOR-MOUSE-CURSOR-0
	;Confine reference position in M-A, M-B to within the sheet
	(JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-A CONFINE-CURSOR-1)
	((M-A) A-ZERO)
CONFINE-CURSOR-1
	(JUMP-LESS-THAN M-A A-MOUSE-SCREEN-WIDTH CONFINE-CURSOR-2)
	((M-A) ADD (M-CONSTANT -1) A-MOUSE-SCREEN-WIDTH)
CONFINE-CURSOR-2
	(JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-B CONFINE-CURSOR-3)
	((M-B) A-ZERO)
CONFINE-CURSOR-3
	;Don't bother at the bottom, since SELECT-SHEET didn't save the
	;right value and for most cursors the difference would be indistinguishable.

	;Convert (X,Y) address like TVXYADR
	((M-1) DPB M-B (BYTE-FIELD 20. 12.) A-ZERO)	;Y POSITION (LSH 12)
	(CALL-XCT-NEXT MPY12)
       ((Q-R) A-MOUSE-SCREEN-LOCATIONS-PER-LINE)	;M-2 GETS OFFSET TO START OF LINE
	((OA-REG-LOW) A-MOUSE-SCREEN-BUFFER-PIXEL-SIZE-MROT)
	;; X coordinate gets multiplied by pixel size
	((M-TEM) DPB M-A (BYTE-FIELD 24. 0) A-ZERO)
	((M-TEM) ADD M-TEM A-MOUSE-SCREEN-BUFFER-BIT-OFFSET)
	((M-1) (BYTE-FIELD 19. 5) M-TEM)		;WORD PART OF X POSITION
	((OA-REG-HIGH) (BYTE-FIELD 1 18.) M-1)
	((M-1) SELECTIVE-DEPOSIT M-ZERO (BYTE-FIELD 13. 19.) A-1)
	((M-E) ADD M-2 A-1)				;RELATIVE WORD ADDRESS
	((M-E) ADD M-E A-MOUSE-SCREEN-BUFFER-ADDRESS)
	((M-T) (BYTE-FIELD 5 0) M-TEM)			;BIT PART OF X POSITION
	((M-E) Q-POINTER M-E)			;Truncate in case of ridiculous X,Y
	;M-E word address, M-T bit offset in that word
	;Now output one or two columns, depending on whether it crosses word boundary
	((M-B) ADD (M-CONSTANT -1) A-MOUSE-CURSOR-WIDTH)
	((M-B) (BYTE-FIELD 5 0) M-B)
	((M-TEM) M-A-1 (M-CONSTANT 40) A-T)
	(JUMP-LESS-OR-EQUAL M-B A-TEM XOR-MOUSE-CURSOR-3)
	;Do second column first
	((M-2) M-A-1 M-B A-TEM)			;Byte width-1 for second column
	((M-B) M-TEM)				;Byte width-1 for first column
	((M-TEM) M-A-1 (M-CONSTANT 40) A-B)
	((M-2) DPB M-2 OAL-BYTL-1 A-TEM)	;LDB pointer for second column
	((M-A) (A-CONSTANT MOUSE-CURSOR-PATTERN-AMEM-LOC))
	((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-CURSOR-HEIGHT)
	((VMA) SUB M-E A-MOUSE-SCREEN-LOCATIONS-PER-LINE)
	((VMA) ADD VMA (A-CONSTANT 1))
XOR-MOUSE-CURSOR-1
	((VMA-START-READ) ADD VMA A-MOUSE-SCREEN-LOCATIONS-PER-LINE)
	(JUMP-LESS-THAN VMA A-MOUSE-SCREEN-BUFFER-ADDRESS XOR-MOUSE-CURSOR-2)
	(JUMP-GREATER-OR-EQUAL VMA A-MOUSE-SCREEN-BUFFER-END-ADDRESS XOR-MOUSE-CURSOR-3)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-HIGH) DPB M-A OAH-A-SRC A-ZERO)
	((M-TEM) A-GARBAGE)
	((OA-REG-LOW) M-2)
	((M-TEM) (BYTE-FIELD 0 0) M-TEM)		;Cursor pattern aligned
	((WRITE-MEMORY-DATA-START-WRITE) XOR READ-MEMORY-DATA A-TEM)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
XOR-MOUSE-CURSOR-2
	((M-A) ADD M-A (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XOR-MOUSE-CURSOR-1)
       ((M-1) SUB M-1 (A-CONSTANT 1))
XOR-MOUSE-CURSOR-3
	;Now do first column
	((M-A) (A-CONSTANT MOUSE-CURSOR-PATTERN-AMEM-LOC))
	((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-CURSOR-HEIGHT)
	((VMA) SUB M-E A-MOUSE-SCREEN-LOCATIONS-PER-LINE)
XOR-MOUSE-CURSOR-4
	((VMA-START-READ) ADD VMA A-MOUSE-SCREEN-LOCATIONS-PER-LINE)
	(JUMP-LESS-THAN VMA A-MOUSE-SCREEN-BUFFER-ADDRESS XOR-MOUSE-CURSOR-5)
	(POPJ-GREATER-OR-EQUAL VMA A-MOUSE-SCREEN-BUFFER-END-ADDRESS)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-HIGH) DPB M-A OAH-A-SRC A-ZERO)
	((M-TEM) A-GARBAGE)
	((OA-REG-LOW) DPB M-B OAL-BYTL-1 A-T)
	((M-TEM) DPB M-TEM (BYTE-FIELD 0 0) A-ZERO)	;Cursor pattern aligned
	((WRITE-MEMORY-DATA-START-WRITE) XOR READ-MEMORY-DATA A-TEM)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
XOR-MOUSE-CURSOR-5
	((M-A) ADD M-A (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XOR-MOUSE-CURSOR-4)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	(POPJ)

XOPEN-MOUSE-CURSOR (MISC-INST-ENTRY %OPEN-MOUSE-CURSOR)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-CURSOR-STATE)
	(CALL-EQUAL M-TEM (A-CONSTANT 3) XOR-MOUSE-CURSOR)
	(JUMP-XCT-NEXT XFALSE)
       ((A-MOUSE-CURSOR-STATE) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 1)))

;Here every 60th of a second
TRACK-MOUSE
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-CURSOR-STATE)
	(POPJ-EQUAL M-TEM A-ZERO)		;Disabled
	((VMA-START-READ) A-MOUSE-HARDWARE-ADDRESS)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-MOUSE-SAVE-1) M-1)
	((A-MOUSE-SAVE-2) M-2)
	((A-MOUSE-SAVE-E) M-E)
	((M-A) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) XOR M-A A-MOUSE-LAST-H1)	;Have buttons changed state?
	((M-TEM) (BYTE-FIELD 3 12.) M-TEM)
	(JUMP-EQUAL-XCT-NEXT M-TEM A-ZERO TRACK-MOUSE-1)
       ((M-B) READ-MEMORY-DATA)
	;Store new state of buttons into buttons buffer
	((A-MOUSE-WAKEUP) A-V-TRUE)
	((M-T) DPB M-ZERO (BYTE-FIELD 27. 5) A-MOUSE-BUTTONS-BUFFER-IN-INDEX)
	((M-T) ADD M-T (A-CONSTANT MOUSE-BUTTONS-BUFFER-AMEM-LOC))
	(CALL READ-MICROSECOND-CLOCK)		;M-2 gets clock
	((OA-REG-LOW M-TEM) DPB M-T OAL-A-DEST A-ZERO)
	((A-GARBAGE) BOXED-NUM-EXCEPT-SIGN-BIT M-2	;FIXNUM-MICROSECOND-TIME
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((OA-REG-LOW M-TEM) ADD M-TEM (A-CONSTANT (BYTE-VALUE OAL-A-DEST 1)))
	((A-GARBAGE) A-MOUSE-X)
	((OA-REG-LOW M-TEM) ADD M-TEM (A-CONSTANT (BYTE-VALUE OAL-A-DEST 1)))
	((A-GARBAGE) A-MOUSE-Y)
	((OA-REG-LOW M-TEM) ADD M-TEM (A-CONSTANT (BYTE-VALUE OAL-A-DEST 1)))
	((A-GARBAGE) (BYTE-FIELD 3 12.) M-A (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-T) ADD M-T (A-CONSTANT 4))
	((M-T) (BYTE-FIELD 5 0) M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP-NOT-EQUAL-XCT-NEXT M-T A-MOUSE-BUTTONS-BUFFER-OUT-INDEX TRACK-MOUSE-1)
       ((A-MOUSE-BUTTONS-BUFFER-IN-INDEX) M-T)
	((M-T) ADD M-T (A-CONSTANT 4))		;Buffer full: discard oldest value
	((A-MOUSE-BUTTONS-BUFFER-OUT-INDEX) (BYTE-FIELD 5 0) M-T
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
TRACK-MOUSE-1
	;Compute physical delta-X (in M-B) and delta-Y (in M-A)
	((M-A) SUB M-A A-MOUSE-LAST-H1)
	((A-MOUSE-LAST-H1) ADD M-A A-MOUSE-LAST-H1)
	((OA-REG-HIGH) (BYTE-FIELD 1 11.) M-A)
	((M-A) DPB M-ZERO (BYTE-FIELD 21. 11.) A-A)
	((M-B) SUB M-B A-MOUSE-LAST-H2)
	((A-MOUSE-LAST-H2) ADD M-B A-MOUSE-LAST-H2)
	((OA-REG-HIGH) (BYTE-FIELD 1 11.) M-B)
	((M-B) DPB M-ZERO (BYTE-FIELD 21. 11.) A-B)
	;Compute physical speed, which involves time averaging
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-Y-SPEED)
	(JUMP-EQUAL M-TEM A-ZERO TRACK-MOUSE-1C)
	((A-TEM1) (BYTE-FIELD 20. 4) M-TEM)
	((M-TEM) M-A-1 M-TEM A-TEM1)		;Speed times 15/16 or less
TRACK-MOUSE-1C
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-A A-ZERO TRACK-MOUSE-1A)
       ((A-TEM1) DPB M-A (BYTE-FIELD 30. 2) A-ZERO)	;delta-Y times 4
	((A-TEM1) SUB M-ZERO A-TEM1)		;sum((15/16)^i,i,0,inf)=16
TRACK-MOUSE-1A
	((M-TEM) ADD M-TEM A-TEM1)		;New speed
	((A-MOUSE-Y-SPEED) Q-POINTER M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-X-SPEED)
	(JUMP-EQUAL M-TEM A-ZERO TRACK-MOUSE-1D)
	((A-TEM1) (BYTE-FIELD 20. 4) M-TEM)
	((M-TEM) M-A-1 M-TEM A-TEM1)		;Speed times 15/16 or less
TRACK-MOUSE-1D
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-B A-ZERO TRACK-MOUSE-1B)
       ((A-TEM1) DPB M-B (BYTE-FIELD 30. 2) A-ZERO)	;delta-X times 4
	((A-TEM1) SUB M-ZERO A-TEM1)
TRACK-MOUSE-1B
	((M-TEM) ADD M-TEM A-TEM1)		;New speed
	((A-MOUSE-X-SPEED) Q-POINTER M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	;Speed bum if mouse hasn't moved
	((M-TEM) IOR M-A A-B)
	(JUMP-EQUAL M-TEM A-ZERO TRACK-MOUSE-XSC-NO-MOTION)
	;Do speed-dependent scaling into logical delta-X, delta-Y, and update position
	((M-1) (A-CONSTANT MOUSE-Y-SCALE-ARRAY-AMEM-LOC))
	((M-2) ADD M-1 (A-CONSTANT 12.))
TRACK-MOUSE-YSC-LOOP
	((OA-REG-HI) DPB M-1 OAH-A-SRC A-ZERO)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-GARBAGE)
	(JUMP-GREATER-THAN M-TEM A-MOUSE-Y-SPEED TRACK-MOUSE-YSC)
	(JUMP-LESS-THAN-XCT-NEXT M-1 A-2 TRACK-MOUSE-YSC-LOOP)
       ((M-1) ADD M-1 (A-CONSTANT 2))
TRACK-MOUSE-YSC
	((OA-REG-HI) DPB M-1 OAH-A-SRC A-ZERO)
	((M-1) A-PGF-TEM)			;A-PGF-TEM = 1@A
	((OA-REG-HIGH) BOXED-SIGN-BIT M-1)
	((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-1)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-A)
	((M-TEM) ADD Q-R A-MOUSE-Y-FRACTION)	;Delta-Y times 1024
	((A-MOUSE-Y-FRACTION) (BYTE-FIELD 10. 0) M-TEM)
	((M-TEM) (BYTE-FIELD 22. 10.) M-TEM A-TEM)
	(JUMP-EQUAL M-TEM A-ZERO TRACK-MOUSE-YSC-NO-MOTION)
	((M-TEM) ADD M-TEM A-MOUSE-Y)
	;Note that we do not clip the mouse position at this level; the macrocode
	;will handle that by warping the cursor back into the valid region
	((A-MOUSE-Y) Q-POINTER M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((A-MOUSE-WAKEUP) A-V-TRUE)
TRACK-MOUSE-YSC-NO-MOTION
	((M-1) (A-CONSTANT MOUSE-X-SCALE-ARRAY-AMEM-LOC))
	((M-2) ADD M-1 (A-CONSTANT 12.))
TRACK-MOUSE-XSC-LOOP
	((OA-REG-HI) DPB M-1 OAH-A-SRC A-ZERO)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-GARBAGE)
	(JUMP-GREATER-THAN M-TEM A-MOUSE-X-SPEED TRACK-MOUSE-XSC)
	(JUMP-LESS-THAN-XCT-NEXT M-1 A-2 TRACK-MOUSE-XSC-LOOP)
       ((M-1) ADD M-1 (A-CONSTANT 2))
TRACK-MOUSE-XSC
	((OA-REG-HI) DPB M-1 OAH-A-SRC A-ZERO)
	((M-1) A-PGF-TEM)			;A-PGF-TEM = 1@A
	((OA-REG-HIGH) BOXED-SIGN-BIT M-1)
	((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-1)
	(CALL-XCT-NEXT MPY)
       ((Q-R) M-B)
	((M-TEM) ADD Q-R A-MOUSE-X-FRACTION)	;Delta-X times 1024
	((A-MOUSE-X-FRACTION) (BYTE-FIELD 10. 0) M-TEM)
	((M-TEM) (BYTE-FIELD 22. 10.) M-TEM A-TEM)
	(JUMP-EQUAL M-TEM A-ZERO TRACK-MOUSE-XSC-NO-MOTION)
	((M-TEM) ADD M-TEM A-MOUSE-X)
	((A-MOUSE-X) Q-POINTER M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((A-MOUSE-WAKEUP) A-V-TRUE)
TRACK-MOUSE-XSC-NO-MOTION
	;Now see if the cursor needs attention.  If it is off, turn it on.  If it
	;is on but in the wrong place, turn it off, move it, turn it on.
	((M-T) DPB M-ZERO Q-ALL-BUT-POINTER A-MOUSE-CURSOR-STATE)
	(JUMP-LESS-THAN M-T (A-CONSTANT 2) TRACK-MOUSE-9)	;Cursor is open
	((M-A) A-MOUSE-CURSOR-X)
	((M-1) A-MOUSE-X)			;Compute where cursor should be
	((M-1) SUB M-1 A-MOUSE-CURSOR-X-OFFSET)
	((A-MOUSE-CURSOR-X) Q-POINTER M-1)
	((M-B) A-MOUSE-CURSOR-Y)
	((M-2) A-MOUSE-Y)
	((M-2) SUB M-2 A-MOUSE-CURSOR-Y-OFFSET)
	((A-MOUSE-CURSOR-Y) Q-POINTER M-2)
	((A-MOUSE-CURSOR-STATE) DPB (M-CONSTANT -1)	;Set it to 3 (on)
			(BYTE-FIELD 2 0) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP-NOT-EQUAL M-T (A-CONSTANT 3) TRACK-MOUSE-8)
	(JUMP-NOT-EQUAL M-A A-MOUSE-CURSOR-X TRACK-MOUSE-7)
	(JUMP-EQUAL M-B A-MOUSE-CURSOR-Y TRACK-MOUSE-9)
TRACK-MOUSE-7
	(CALL XOR-MOUSE-CURSOR-0)		;Undraw old cursor
TRACK-MOUSE-8
	(CALL XOR-MOUSE-CURSOR)			;Draw new cursor
TRACK-MOUSE-9
	((M-1) A-MOUSE-SAVE-1)
	(POPJ-AFTER-NEXT (M-2) A-MOUSE-SAVE-2)
       ((M-E) A-MOUSE-SAVE-E)

;;; PAGE FAULT HANDLER

;PAGE FAULTS GENERALLY DO NOT CLOBBER ANYTHING.
;EXCEPTIONS:
;	THE A-PGF-MUMBLE REGISTERS ARE CLOBBERED.  ONLY THE PAGE FAULT
;		ROUTINES SHOULD USE THEM.
;	M-TEM, A-TEM1, A-TEM2, AND A-TEM3 ARE CLOBBERED.  THEY ARE SUPER-TEMPORARY.
;	THE DISPATCH CONSTANT AND THE Q REGISTER ARE CLOBBERED.
;	THE DATA-TYPE OF VMA -MUST NOT- BE CLOBBERED.
;	THE PDL-BUFFER-INDEX ISN'T CLOBBERED, BUT IT SHOULD BE.
;
;IF AN INTERRUPT OCCURS, IT HAS ALMOST NO SIDE-EFFECTS OTHER THAN WHAT
;PAGE FAULTS HAVE.
;
;IF A SEQUENCE BREAK IS ALLOWED AND OCCURS, IT OCCURS AFTER A WRITE CYCLE
;IS SUCCESSFULLY COMPLETED, BUT EFFECTIVELY BEFORE A READ CYCLE.
;THE MD IS RESET FROM THE VMA.  THE LETTERED M ACS ARE SAVED,
;AND MUST CONTAIN GC MARKABLE STUFF OR DTP TRAP (OR -1).  RANDOM
;MISCELLANEOUS ACS LIKE A-TEM'S ARE CLOBBERED BY SEQUENCE BREAKS.

; DEFINITIONS OF FIELDS IN THE MAP HARDWARE
;  BITS IN MEMORY-MAP-DATA (FUNCTIONAL SOURCE 11).

(DEF-DATA-FIELD MAP-READ-FAULT-BIT 1 30.)
(DEF-DATA-FIELD MAP-WRITE-FAULT-BIT 1 31.)
(DEF-DATA-FIELD MAP-PHYSICAL-PAGE-NUMBER 14. 0)
(DEF-DATA-FIELD MAP-META-BITS 6 14.)    	;THE HIGH TWO OF THESE ARE HACKABLE BY
						; DISPATCH INSTRUCTION
						;THE REST ARE JUST FOR SOFTWARE TO LOOK AT
(DEF-DATA-FIELD MAP-STATUS-CODE 3 20.)
(DEF-DATA-FIELD MAP-ACCESS-CODE 2 22.)		;NOTE BIT 22 IS IN TWO FIELDS
(DEF-DATA-FIELD MAP-FIRST-LEVEL-MAP 5 24.)	;NOTE NOT THE SAME AS WHERE IT WRITES
(DEF-DATA-FIELD MAP-SECOND-LEVEL-MAP 24. 0)
(DEF-DATA-FIELD MAP-ACCESS-STATUS-AND-META-BITS 10. 14.)
(DEF-DATA-FIELD MAP-HARDWARE-READ-ACCESS 1 23.)	;HARDWARE PERMITS (AT LEAST) READ ACCESS
						; IF THIS BIT SET.

;FIELDS IN VMA WHEN WRITING MAP.
(DEF-DATA-FIELD MAP-WRITE-SECOND-LEVEL-MAP 24. 0)
(DEF-DATA-FIELD MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1 25.)
(DEF-DATA-FIELD MAP-WRITE-ENABLE-FIRST-LEVEL-WRITE 1 26.)
(DEF-DATA-FIELD MAP-WRITE-FIRST-LEVEL-MAP 5 27.) ;NOTE NOT THE SAME AS WHERE IT READS

; DEFINITIONS OF FIELDS IN PAGE HASH TABLE

 ;WORD 1
(DEF-DATA-FIELD PHT1-VIRTUAL-PAGE-NUMBER 16. 8)	;ALIGNED SAME AS VMA
(DEF-DATA-FIELD PHT1-SWAP-STATUS-CODE 3 0)
 (DEF-DATA-FIELD PHT1-ALL-BUT-SWAP-STATUS-CODE 29. 3)
(DEF-DATA-FIELD PHT1-AGE 2 3)
 (DEF-DATA-FIELD PHT1-ALL-BUT-AGE-AND-SWAP-STATUS-CODE 27. 5)
(DEF-DATA-FIELD PHT1-MODIFIED-BIT 1 5)		;SET IF PAGE MODIFIED
(DEF-DATA-FIELD PHT1-VALID-BIT 1 6)
 ;WORD 2  THESE ARE NOW THE SAME BIT POSITIONS AS IN THE SECOND LEVEL MAP
(DEF-DATA-FIELD PHT2-META-BITS 6 14.)
(DEF-DATA-FIELD PHT2-MAP-STATUS-CODE 3 20.)
(DEF-DATA-FIELD PHT2-MAP-ACCESS-CODE 2 22.)
(DEF-DATA-FIELD PHT2-MAP-ACCESS-AND-STATUS-CODE 4 20.)
(DEF-DATA-FIELD PHT2-ACCESS-STATUS-AND-META-BITS 10. 14.)
(DEF-DATA-FIELD PHT2-PHYSICAL-PAGE-NUMBER 14. 0) 

; DEFINITIONS OF FIELDS IN THE ADDRESS

(DEF-DATA-FIELD VMA-MAP-BLOCK-PART 11. 13.)	;ADDRESS BLOCK OF 32. PAGES
(DEF-DATA-FIELD VMA-PAGE-ADDR-PART 16. 8)	;VIRTUAL PAGE NUMBER
(DEF-DATA-FIELD VMA-PHYS-PAGE-ADDR-PART 14. 8)	;PHYSICAL PAGE NUMBER
(DEF-DATA-FIELD VMA-LOW-BITS 8 0)		;ADDR WITHIN PAGE
(DEF-DATA-FIELD ALL-BUT-VMA-LOW-BITS 24. 8)

;NOTE: PGF-R, ETC CAN BE ENTERED RECURSIVELY IF THE PAGE IS SWAPPED OUT AND THE DISK 
;ROUTINES FAULT WHEN REFERENCING THE DISK CONTROL.

;THESE COMMENTS APPLY TO SEQUENCE BREAK
;INTERRUPT MAY BE INSERTED -AFTER- THE READ CYCLE, HOWEVER
;IT IS EFFECTIVELY BEFORE SINCE ON DISMISS READ-MEMORY-DATA RESTORED FROM VMA!!
;NOTE THAT THIS ORDERING ALLOWS AN EFFECTIVE READ-PAUSE-WRITE CYCLE
;TO BE DONE JUST BY DOING A READ THEN A WRITE, EVEN
;THOUGH AFTER EACH CYCLE IS STARTED INTERRUPTS ARE CHECKED.

;To request a sequence-break, do
;       ((LOCATION-COUNTER) LOCATION-COUNTER)   ;Assure PC gets fetched
;	((INTERRUPT-CONTROL) IOR LOCATION-COUNTER (A-CONSTANT 1_26.)) .

;PUSHJ HERE ON PAGE FAULT, INTERRUPT REQUEST, OR SEQUENCE BREAK DURING READ CYCLE
PGF-R-SB(CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-R-I)
	(JUMP-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-R-SB)   ;Another one?
SBSER	(POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 26.) LOCATION-COUNTER)  ;Flush on no SB req
	((M-TEM) M-FLAGS-NO-SEQUENCE-BREAK)	;TURN INTO ILLOP IF TRAP AT BAD TIME
	(CALL-NOT-EQUAL M-TEM A-ZERO ILLOP)	;NOTE WOULD PROBABLY DIE LATER ANYWAY
	((INTERRUPT-CONTROL) ANDCA LOCATION-COUNTER (A-CONSTANT 1_26.))
	((M-TEM) A-INHIBIT-SCHEDULING-FLAG)
	(JUMP-NOT-EQUAL M-TEM A-V-NIL SB-DEFER)
	((M-DEFERRED-SEQUENCE-BREAK-FLAG) DPB M-ZERO A-FLAGS)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-QSSTKG)
	(CALL-EQUAL M-TEM A-QCSTKG ILLOP)       ;SCHEDULER SHOULD HAVE DEFERED INTERRUPTS
	((A-QLBNDH) A-QLBNDRH)			;ENSURE NO SPECIAL PDL OVERFLOW STORING STATUS
						;REGULAR PDL IS PREWITHDRAWN, CAN'T OVERFLOW
	(CALL-XCT-NEXT SGLV)			;STORE CURRENT STATUS
       ((M-TEM) (A-CONSTANT (EVAL SG-STATE-RESUMABLE))) ;AND SWAP SPECIAL-PDL
	((A-SG-TEM) A-V-NIL)				;Transmit NIL 
	(JUMP-XCT-NEXT SG-ENTER)			;"CALL" SCHEDULER STACK GROUP
       ((M-A) A-QSSTKG)

SB-DEFER (POPJ-AFTER-NEXT 
	   (M-DEFERRED-SEQUENCE-BREAK-FLAG) DPB (M-CONSTANT -1) A-FLAGS)
       (NO-OP)

;PUSHJ HERE ON PAGE FAULT OR INTERRUPT REQUEST DURING READ CYCLE
PGF-R-I	(JUMP-CONDITIONAL NO-PG-FAULT INTR)	;IF NO PG FAULT, TAKE INTERRUPT

;PUSHJ HERE ON READ CYCLE PAGE FAULT WHEN DESIRE NOT TO TAKE INTERRUPT
;GUARANTEED TO RETURN WITHOUT ANY INTERRUPTS HAPPENING, OR ELSE TO GO TO ILLOP
;BUT SEE THE COMMENTS ON THE DEFINITION OF CHECK-PAGE-READ-NO-INTERRUPT
PGF-R	((MD) VMA)				;ADDRESS THE MAP
	(DISPATCH-XCT-NEXT MAP-STATUS-CODE MEMORY-MAP-DATA D-PGF)
       ((M-PGF-WRITE) DPB M-ZERO A-FLAGS)
;IF IT RETURNS HERE, WE RESTART THE READ REFERENCE
	((VMA-START-READ) A-PGF-VMA)
	(POPJ-AFTER-NEXT NO-OP)
       (CHECK-PAGE-READ-NO-INTERRUPT)		;DIDN'T ENTIRELY SUCCEED, TRY AGAIN

;PUSHJ HERE ON PAGE FAULT, INTERRUPT, OR SEQUENCE BREAK DURING WRITE CYCLE
PGF-W-SB(CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-W-I)
	(JUMP-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-W-SB)       ;ANOTHER ONE (OR SOMETHING)
	(JUMP SBSER)

PGF-W-BIND
	(JUMP-XCT-NEXT PGF-W-1)
       ((A-PGF-MODE) A-V-TRUE)

PGF-W-FORCE
	(JUMP-XCT-NEXT PGF-W-1)
       ((A-PGF-MODE) M-MINUS-ONE)

;PUSHJ HERE ON PAGE FAULT OR INTERRUPT REQUEST DURING WRITE CYCLE
PGF-W-I	(JUMP-CONDITIONAL NO-PG-FAULT INTR)	;NO PAGE FAULT, THEN TAKE INTERRUPT

;PUSHJ HERE ON PAGE FAULT WHEN DESIRE NOT TO TAKE INTERRUPT
;GUARANTEED TO RETURN WITH NO INTERRUPT, OR TO GO TO ILLOP
;BUT SEE THE COMMENTS ON THE DEFINITION OF CHECK-PAGE-READ-NO-INTERRUPT
PGF-W	((A-PGF-MODE) A-V-NIL)
PGF-W-1	((A-PGF-WMD) MD)			;SAVE DATA BEING WRITTEN
	((MD) VMA)				;ADDRESS THE MAP
	(DISPATCH-XCT-NEXT MAP-STATUS-CODE MEMORY-MAP-DATA D-PGF)
       ((M-PGF-WRITE) DPB (M-CONSTANT -1) A-FLAGS)
;IF IT RETURNS HERE, WE RESTART THE WRITE REFERENCE
	((WRITE-MEMORY-DATA) A-PGF-WMD)
	((VMA-START-WRITE) A-PGF-VMA)		; ASSUMES WE WERE TRYING TO DO A WRITE CYCLE
	(POPJ-AFTER-NEXT NO-OP)
       (CHECK-PAGE-WRITE-RETRY)			;DIDN'T ENTIRELY SUCCEED, TRY AGAIN

(LOCALITY D-MEM)
(START-DISPATCH 3 0)		;DISPATCH ON MAP STATUS
D-PGF	(P-BIT PGF-MAP-MISS)	;0 LEVEL 1 OR 2 MAP NOT VALID
	(P-BIT PGF-MAP-MISS)	;1 META BITS ONLY, TAKE AS MAP MISS
	(PGF-RDONLY)		;2 WRITE IN READ ONLY
	(P-BIT PGF-RWF)		;3 WRITE IN READ/WRITE FIRST
	(P-BIT ILLOP)		;4 READ/WRITE
	(PGF-PDL)		;5 MAY BE IN PDL BUFFER
	(PGF-MAR)		;6 POSSIBLE MAR BREAK
	(P-BIT ILLOP)		;7 NOT USED
(END-DISPATCH)
(LOCALITY I-MEM)

;THIS DISPATCH IS FOR GETTING META BITS FROM MAP[MD] WITHOUT SWAPPING IN
;WHAT IT POINTS TO.  SMASHES VMA.
(LOCALITY D-MEM)
(START-DISPATCH 3 0)
D-GET-MAP-BITS
	(P-BIT INHIBIT-XCT-NEXT-BIT GET-MAP-BITS) ;0 LEVEL 1 OR 2 MAP NOT VALID
	(P-BIT R-BIT)				;1 GOT MAP BITS ANYWAY
	(P-BIT R-BIT)				;2 READ ONLY
	(P-BIT R-BIT)				;3 READ/WRITE FIRST
	(P-BIT R-BIT)				;4 READ/WRITE
	(P-BIT R-BIT)				;5 MAY BE IN PDL BUFFER
	(P-BIT R-BIT)				;6 POSSIBLE MAR BREAK
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;7 NOT USED
(END-DISPATCH)
(LOCALITY I-MEM)

;MAP MISS WHEN TRYING TO GET META BITS.  GET FROM REGION TABLE, SET UP META-BITS-ONLY STATUS
GET-MAP-BITS
	((A-META-BITS-MAP-RELOADS) ADD M-ZERO A-META-BITS-MAP-RELOADS ALU-CARRY-IN-ONE)
	(CALL-XCT-NEXT PGF-SAVE-1)		;Save MD, M-A, M-B, M-T
       ((A-PGF-VMA) MD)				;Address of reference, also saves MD
	((M-TEM) MAP-FIRST-LEVEL-MAP MEMORY-MAP-DATA)	;Check for level 1 map miss
	(CALL-EQUAL M-TEM (A-CONSTANT 37) LEVEL-1-MAP-MISS)
	((M-A) DPB M-ZERO Q-ALL-BUT-POINTER A-PGF-VMA)
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT		;Check for A-memory or I/O address
		M-A (A-CONSTANT LOWEST-A-MEM-VIRTUAL-ADDRESS)
		GET-MAP-BITS-1)
       ((MD) (A-CONSTANT (PLUS (BYTE-MASK %%REGION-OLDSPACE-META-BIT)
			       (BYTE-MASK %%REGION-EXTRA-PDL-META-BIT)
			       (BYTE-VALUE %%REGION-REPRESENTATION-TYPE
					   %REGION-REPRESENTATION-TYPE-STRUCTURE))))
	(CALL-XCT-NEXT XRGN1)			;Normal address, get meta bits from region
       ((M-A) Q-POINTER M-A (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-EQUAL M-T A-V-NIL ILLOP)		;Region not found
	((VMA-START-READ) ADD M-T A-V-REGION-BITS)	;Fetch meta bits
	(ILLOP-IF-PAGE-FAULT)
GET-MAP-BITS-1
	((VMA) SELECTIVE-DEPOSIT READ-MEMORY-DATA MAP-META-BITS
		(A-CONSTANT (PLUS (BYTE-VALUE MAP-STATUS-CODE %PHT-MAP-STATUS-META-BITS-ONLY)
				  (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE))))
	((MD-WRITE-MAP) A-PGF-VMA)
	(JUMP PGF-RESTORE)			;Restore M-A, M-B, M-T
		;Note that POPJ-AFTER-NEXT cannot be used, because we mustn't return
		;with a map-write in progress, since there is no pass-around path
		;on the map, and the caller is going to look at the map in the
		;first instruction returned to.

;PDL BUFFER HANDLING CONVENTIONS:
;  THE LINEAR PUSHDOWN LIST MUST ALWAYS BE COMPOSED OF PAGES FROM AN AREA WHOSE
;REGION-BITS Q HAS %PHT-MAP-STATUS-PDL-BUFFER IN THE MAP STATUS PORTION OF ITS
;%%REGION-MAP-BITS FIELD.  THUS ANY MEMORY CYCLE REF'ING 
;SUCH AN AREA WILL TRAP AND COME HERE, WHERE THE CODE CHECKS TO SEE IF IT IS REALLY
;IN THE PDL-BUFFER NOW.  IF NOT, IT TURNS ON R/W ACCESS TEMPORARILY AND PERFORMS THE
;REQUESTED CYCLE, ETC.
;  THESE PAGES ARE TREATED ENTIRELY AS NORMAL PAGES FOR SWAPPING PURPOSES, AND MAY
;EVEN BE SWAPPED OUT WHILE ACTUALLY RESIDENT IN THE PDL-BUFFER! THE ONLY DIFFERENCE
;IS THAT THE PAGE MUST ALWAYS BE WRITTEN TO THE DISK ON SWAP-OUT, SINCE THE R-W-F
;MECHANISM IS NOT AVAILABLE TO KEEP TRACK OF WHETHER IT HAS ACTUALLY BEEN MODIFIED.
;  PDL-BUFFER-POINTER IS TAKEN TO MARK THE HIGHEST PDL-BUFFER LOCN WHICH IS REALLY VALID.

PGF-PDL	(JUMP-IF-BIT-SET M-PGF-WRITE PGF-W-PDL)
;READ REFERENCE TO LOCATION THAT MAY BE IN THE PDL BUFFER
PGF-R-PDL	
	((M-PGF-TEM) SUB PDL-BUFFER-POINTER A-PDL-BUFFER-HEAD)
	((M-PGF-TEM) ADD M-PGF-TEM (A-CONSTANT 1))	;*** THIS CODE COULD USE BUMMING ***
	((M-PGF-TEM) (BYTE-FIELD 10. 0) M-PGF-TEM)	;COMPUTE # ACTIVE WDS IN PDL-BUFFER
	((A-PGF-B) ADD M-PGF-TEM A-PDL-BUFFER-VIRTUAL-ADDRESS)
	((M-PGF-TEM) Q-POINTER VMA)	;GET ADDRESS BEING REFERENCED SANS EXTRA BITS
	(JUMP-LESS-THAN M-PGF-TEM A-PDL-BUFFER-VIRTUAL-ADDRESS PGF-R-NOT-REALLY-IN-PDL-BUFFER)
	(JUMP-GREATER-THAN M-PGF-TEM A-PGF-B PGF-R-NOT-REALLY-IN-PDL-BUFFER) ;GREATER BECAUSE 
							;(PP) IS A VALID WD.
	;READ REFERENCE TO LOCATION THAT IS IN THE PDL BUFFER
	((A-PDL-BUFFER-READ-FAULTS) ADD A-PDL-BUFFER-READ-FAULTS M-ZERO ALU-CARRY-IN-ONE)
	((M-PGF-TEM) SUB M-PGF-TEM 
		A-PDL-BUFFER-VIRTUAL-ADDRESS)  ;GET RELATIVE PDL LOC REFERENCED
	((A-PGF-A) PDL-BUFFER-INDEX)	;DON'T CLOBBER PDL-BUFFER-INDEX
	((PDL-BUFFER-INDEX) ADD M-PGF-TEM A-PDL-BUFFER-HEAD)	;TRUNCATES TO 10 BITS
	(POPJ-AFTER-NEXT (MD) C-PDL-BUFFER-INDEX)
       ((PDL-BUFFER-INDEX) A-PGF-A)

;READ REFERENCE TO LOCATION NOT IN THE PDL BUFFER, BUT IT MIGHT HAVE BEEN.
PGF-R-NOT-REALLY-IN-PDL-BUFFER	
	((A-PDL-BUFFER-MEMORY-FAULTS) ADD A-PDL-BUFFER-MEMORY-FAULTS M-ZERO ALU-CARRY-IN-ONE)
	((M-PGF-TEM) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)	;SAVE CORRECT MAP CONTENTS
	((VMA-WRITE-MAP) IOR M-PGF-TEM		;TURN ON ACCESS
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 3)))) ;R/W
	((VMA-START-READ) MD)			;READ OUT THAT LOCATION
	(ILLOP-IF-PAGE-FAULT)			;I THOUGHT WE JUST TURNED ON ACCESS
	((A-PGF-WMD) READ-MEMORY-DATA)		;SAVE CONTENTS 
	((MD) VMA)				;ADDRESS THE MAP
	((VMA-WRITE-MAP) DPB M-PGF-TEM		;RESTORE THE MAP
		MAP-WRITE-SECOND-LEVEL-MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	(POPJ-AFTER-NEXT			;RESTORE REGISTERS AND RETURN
	 (VMA) MD)
       ((MD) A-PGF-WMD)

;WRITE REFERENCE TO LOCATION THAT MAY BE IN THE PDL BUFFER
PGF-W-PDL	
	((M-PGF-TEM) SUB PDL-BUFFER-POINTER A-PDL-BUFFER-HEAD)
	((M-PGF-TEM) ADD M-PGF-TEM (A-CONSTANT 1))	;*** THIS CODE COULD USE BUMMING ***
	((M-PGF-TEM) (BYTE-FIELD 10. 0) M-PGF-TEM)	;COMPUTE # ACTIVE WDS IN PDL-BUFFER
	((A-PGF-B) ADD M-PGF-TEM A-PDL-BUFFER-VIRTUAL-ADDRESS) ;HIGHEST VIRT LOC IN P.B,
	((M-PGF-TEM) Q-POINTER VMA)	;GET ADDRESS BEING REFERENCED SANS EXTRA BITS
	(JUMP-LESS-THAN M-PGF-TEM A-PDL-BUFFER-VIRTUAL-ADDRESS PGF-W-NOT-REALLY-IN-PDL-BUFFER)
	(JUMP-GREATER-THAN M-PGF-TEM A-PGF-B PGF-W-NOT-REALLY-IN-PDL-BUFFER) ;GREATER BECAUSE
							;(PP) IS A VALID WD
	;WRITE REFERENCE TO LOCATION THAT IS IN THE PDL BUFFER
	((A-PDL-BUFFER-WRITE-FAULTS) ADD A-PDL-BUFFER-WRITE-FAULTS M-ZERO ALU-CARRY-IN-ONE)
	((M-PGF-TEM) SUB M-PGF-TEM 
		A-PDL-BUFFER-VIRTUAL-ADDRESS)  ;GET RELATIVE PDL LOC REFERENCED
	((A-PGF-A) PDL-BUFFER-INDEX)	;DON'T CLOBBER PDL-BUFFER-INDEX
	((PDL-BUFFER-INDEX) ADD M-PGF-TEM A-PDL-BUFFER-HEAD)	;TRUNCATES TO 10 BITS
	((MD) A-PGF-WMD)
	(POPJ-AFTER-NEXT
	 (C-PDL-BUFFER-INDEX) MD)	;DO THE WRITE
       ((PDL-BUFFER-INDEX) A-PGF-A)	;RESTORE REGS AND RETURN FROM FAULT

;WRITE REFERENCE TO LOCATION NOT IN THE PDL BUFFER, BUT IT MIGHT HAVE BEEN
PGF-W-NOT-REALLY-IN-PDL-BUFFER	
	((A-PDL-BUFFER-MEMORY-FAULTS) ADD A-PDL-BUFFER-MEMORY-FAULTS M-ZERO ALU-CARRY-IN-ONE)
	((M-PGF-TEM) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)	;SAVE CORRECT MAP CONTENTS
	((VMA-WRITE-MAP) IOR M-PGF-TEM		;TURN ON ACCESS
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 3)))) ;R/W
	((VMA) MD)				;WRITE INTO THAT LOCATION
	((WRITE-MEMORY-DATA-START-WRITE) A-PGF-WMD)
	(ILLOP-IF-PAGE-FAULT)			;I THOUGHT WE JUST TURNED ON ACCESS
	((MD) VMA)				;ADDRESS THE MAP
	((VMA-WRITE-MAP) DPB M-PGF-TEM		;RESTORE THE MAP
		MAP-WRITE-SECOND-LEVEL-MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	(POPJ-AFTER-NEXT			;RESTORE REGISTERS AND RETURN
	 (VMA) MD)
       ((MD) A-PGF-WMD)

;SAVE REGISTERS UPON ENTERING PAGE FAULT HANDLER
PGF-SAVE
	((A-PGF-VMA) VMA)
PGF-SAVE-1
	((A-PGF-A) M-A)
	(POPJ-AFTER-NEXT (A-PGF-B) M-B)
       ((A-PGF-T) M-T)

;RESTORE REGISTERS AND LEAVE PAGE FAULT HANDLER
;DOESN'T RESTORE VMA SINCE CYCLE RESTARTER (POPJED TO) WILL DO THAT
PGF-RESTORE	
	((M-A) A-PGF-A)
	(POPJ-AFTER-NEXT (M-B) A-PGF-B)
       ((M-T) A-PGF-T)

 ;Page fault level routines call these in order to be able to take map-reload-type page
 ;faults recursively.  Even after saving here, any recursive page fault which
 ;touched the disk would lose since these variables would get stored over by the
 ;call to DISK-PGF-SAVE at DISK-SWAP-HANDLER.
DISK-PGF-SAVE
	((A-DISK-SAVE-PGF-VMA) A-PGF-VMA)	;Save page fault handler variables
	((A-DISK-SAVE-PGF-WMD) A-PGF-WMD)	;in case of recursive fault
	((A-DISK-SAVE-PGF-T) A-PGF-T)
	((A-DISK-SAVE-PGF-A) A-PGF-A)
	((A-DISK-SAVE-PGF-B) A-PGF-B)
	((A-DISK-SAVE-MODE) A-PGF-MODE)
	(POPJ-AFTER-NEXT
	 (A-DISK-SAVE-1) M-1)			;Clobbered by disk routine
       ((A-DISK-SAVE-2) M-2)			;..

DISK-PGF-RESTORE
	((M-2) A-DISK-SAVE-2)		;Restore registers
	((M-1) A-DISK-SAVE-1)
	((A-PGF-MODE) A-DISK-SAVE-MODE)
	((A-PGF-B) A-DISK-SAVE-PGF-B)
	((A-PGF-A) A-DISK-SAVE-PGF-A)
	((A-PGF-T) A-DISK-SAVE-PGF-T)
	(POPJ-AFTER-NEXT
	 (A-PGF-WMD) A-DISK-SAVE-PGF-WMD)
       ((A-PGF-VMA) A-DISK-SAVE-PGF-VMA)

;ROUTINE TO HANDLE LEVEL-1 MAP MISSES.  CALLED FROM PGF-MAP-MISS AND FROM GET-MAP-BITS.
;ADDRESS IN MD ON CALL AND RETURN, VMA CLOBBERED.  PGF-SAVE MUST HAVE BEEN CALLED.
LEVEL-1-MAP-MISS
	((A-FIRST-LEVEL-MAP-RELOADS) ADD A-FIRST-LEVEL-MAP-RELOADS M-ZERO ALU-CARRY-IN-ONE)
	((M-T) A-SECOND-LEVEL-MAP-REUSE-POINTER)	;ALLOCATE A BLOCK OF LVL 2 MAP
	((MD M-A) SELECTIVE-DEPOSIT MD VMA-MAP-BLOCK-PART A-ZERO) ;-> 1ST ENTRY IN BLOCK
	((VMA-WRITE-MAP) DPB M-T MAP-WRITE-FIRST-LEVEL-MAP	;POINT 1ST LVL AT IT
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-FIRST-LEVEL-WRITE)))
	((M-PGF-TEM) ADD M-T (A-CONSTANT 40))		;REVERSE 1ST LVL MAP IN 40-77 OF
	((VMA-START-READ) ADD M-PGF-TEM A-V-SYSTEM-COMMUNICATION-AREA)  ;SYS COM AREA.
	(ILLOP-IF-PAGE-FAULT)				;THIS POINTS MD AT THE OLD MAP
	(JUMP-LESS-THAN READ-MEMORY-DATA A-ZERO PGF-L1C) ;DON'T WRITE MAP IF NO PREVIOUS
	((VMA-WRITE-MAP) DPB				;AND 37-IFY OLD 1ST LVL MAP
		(M-CONSTANT -1) MAP-WRITE-FIRST-LEVEL-MAP	;ENTRY SO WILL FAULT IF USED
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-FIRST-LEVEL-WRITE)))
	((VMA) ADD M-PGF-TEM A-V-SYSTEM-COMMUNICATION-AREA)
PGF-L1C	((WRITE-MEMORY-DATA-START-WRITE) M-A)		;UPDATE REVERSE FIRST LVL MAP
	(ILLOP-IF-PAGE-FAULT)				;THIS POINTS MD AT 1ST ENTRY IN BLOCK
	((M-T) (M-CONSTANT 40))				;DO ALL 32. ENTRIES IN BLOCK
PGF-L1A	((VMA-WRITE-MAP)				;FILL 2ND-LEVEL MAP WITH MAP-MISS (0)
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	((MD M-A) ADD M-A (A-CONSTANT (BYTE-VALUE VMA-PAGE-ADDR-PART 1)))
	(JUMP-GREATER-THAN-XCT-NEXT M-T (A-CONSTANT 1) PGF-L1A)
       ((M-T) SUB M-T (A-CONSTANT 1))
	((MD) A-PGF-VMA)				;RESTORE MD (ADDRESS OF REFERENCE)
	;DROP THROUGH ADVANCE-SECOND-LEVEL-MAP-REUSE-POINTER, AND RETURN
;ROUTINE TO ADVANCE SECOND LEVEL MAP REUSE POINTER, WITH CARE.  CLOBBERS Q-R
ADVANCE-SECOND-LEVEL-MAP-REUSE-POINTER	
	((Q-R A-SECOND-LEVEL-MAP-REUSE-POINTER)
		ADD M-ZERO A-SECOND-LEVEL-MAP-REUSE-POINTER ALU-CARRY-IN-ONE)
	(POPJ-AFTER-NEXT POPJ-LESS-THAN Q-R (A-CONSTANT 37))
       ((A-SECOND-LEVEL-MAP-REUSE-POINTER)
		A-SECOND-LEVEL-MAP-REUSE-POINTER-INIT)	;WRAP AROUND TO AFTER THE WIRED ONES

;MAP MISS COMES HERE.  ADDRESS IN VMA AND MD BOTH.
;SET UP FIRST-LEVEL MAP IF NECESSARY.  THEN DEAL WITH PAGE-FAULT.
PGF-MAP-MISS
	(CALL-XCT-NEXT PGF-SAVE)	;SAVE A,B,T,VMA
       ((M-TEM) MAP-FIRST-LEVEL-MAP MEMORY-MAP-DATA)	;CHECK FOR 1ST-LEVEL MISS
	(CALL-EQUAL M-TEM (A-CONSTANT 37) LEVEL-1-MAP-MISS)
	;; MD HAS ADDRESS, VMA SAVED AND CLOBBERED.  HANDLE 2ND-LEVEL MISS
	((A-SECOND-LEVEL-MAP-RELOADS) ADD A-SECOND-LEVEL-MAP-RELOADS M-ZERO ALU-CARRY-IN-ONE)
	((M-T) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-PGF-VMA) ;ADDRESS SANS EXTRA BITS
	(JUMP-LESS-THAN M-T (A-CONSTANT LOWEST-A-MEM-VIRTUAL-ADDRESS) PGF-L2A)
	(JUMP-LESS-THAN M-T (A-CONSTANT LOWEST-IO-SPACE-VIRTUAL-ADDRESS)
		PGF-SPECIAL-A-MEMORY-REFERENCE)
;REFERENCE TO UNIBUS OR X-BUS IO VIRTUAL ADDRESS.  FAKE UP PAGE HASH TABLE ENTRY
	((M-T) VMA-PHYS-PAGE-ADDR-PART M-T
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	((M-A) (A-CONSTANT 1460))		;RW ACCESS, STATUS=4, NO AREA TRAPS, REP TYPE 0
	(JUMP-XCT-NEXT PGF-RESTORE)		;GO RETRY REFERENCE
       ((VMA-WRITE-MAP) DPB M-A MAP-ACCESS-STATUS-AND-META-BITS A-T)

;REFERENCE TO ORDINARY VIRTUAL ADDRESS.  LOOK IN PAGE HASH TABLE
PGF-L2A	(CALL SEARCH-PAGE-HASH-TABLE)
	(DISPATCH PHT1-SWAP-STATUS-CODE READ-MEMORY-DATA D-PGF-PHT) ;FOUND, CHK SW STS

(LOCALITY D-MEM)
(START-DISPATCH 3 INHIBIT-XCT-NEXT-BIT)	;DISPATCH ON SWAP STATUS
D-PGF-PHT	
	(SWAPIN)		;0 PHT ENTRY INVALID, GET PAGE FROM DISK
	(PGF-RL)		;1 NORMAL, RELOAD PAGE MAP
	(PGF-FL)		;2 FLUSHABLE, CHANGE BACK TO NORMAL
	(PGF-PRE)		;3 PREPAGED, CHANGE TO NORMAL, WE WANT IT NOW
	(PGF-AG)		;4 AGE, CHANGE BACK TO NORMAL
	(PGF-RL)		;5 WIRED DOWN, RELOAD PAGE MAP
	(P-BIT ILLOP)		;6 NOT USED
	(P-BIT ILLOP)		;7 NOT USED
(END-DISPATCH)

(START-DISPATCH 3 0)	;DROP THROUGH (SKIPPING) IF MAR BREAK NOT TO GO OFF, ELSE CALL TRAP
D-MAR	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;0 READ, MAR DISABLED
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;1 READ, READ-TRAP
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;2 READ, WRITE-TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;3 READ, READ-WRITE-TRAP
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;4 WRITE, MAR DISABLED
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;5 WRITE, READ-TRAP
	(P-BIT TRAP)				;6 WRITE, WRITE-TRAP
	(P-BIT TRAP)				;7 WRITE, READ-WRITE-TRAP
(END-DISPATCH)
(LOCALITY I-MEM)

;Here on reference to page containing the MAR'ed location.
;The VMA is still valid, the MD has been clobbered to the VMA but
;if writing is saved in A-PGF-WMD, and M-PGF-WRITE says type of cycle.
;If this traps, VMA and M-PGF-WRITE will still be valid as saved by SGLV.
;In the case of a write, the data to be written will be on the stack.
;A read can be recovered just by returning from PGF-R,
;since the MAR is inhibited during stack-group switching.
;A write is continued by simulation in the error handler, followed
;by same continuation as a read.
PGF-MAR	((M-PGF-TEM) M-FLAGS-NO-SEQUENCE-BREAK)	;If can't take trap now
	(JUMP-NOT-EQUAL M-PGF-TEM A-ZERO PGF-MAR1) ;then don't take one
	((M-PGF-TEM) Q-POINTER VMA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(JUMP-LESS-THAN M-PGF-TEM A-MAR-LOW PGF-MAR1)	;Check address bounds
	(JUMP-GREATER-THAN M-PGF-TEM A-MAR-HIGH PGF-MAR1)
	(DISPATCH M-FLAGS-MAR-DISP D-MAR)	;Take MAR break if necessary
    (ERROR-TABLE MAR-BREAK READ)		;otherwise skip to PGF-MAR1
       ((C-PDL-BUFFER-POINTER-PUSH) A-PGF-WMD)
    (ERROR-TABLE MAR-BREAK WRITE)
PGF-MAR1	
	;False alarm, simulate the memory cycle,
	;but it might be in the PDL buffer, so simulate that trap.
	;Anyway that code is pretty experienced at simulating memory cycles.
	(JUMP-IF-BIT-CLEAR M-PGF-WRITE PGF-R-PDL)
	(JUMP PGF-W-PDL)

;HERE ON REFERENCE TO LOCATION MAPPED INTO A/M SCRATCHPAD, ADDRESS IN M-T
PGF-SPECIAL-A-MEMORY-REFERENCE
	(JUMP-IF-BIT-SET-XCT-NEXT M-PGF-WRITE PGF-SA-W)	;JUMP IF CYCLE IS A WRITE
       ((M-GARBAGE) MICRO-STACK-PNTR-AND-DATA-POP)	;FLUSH RETRY-CYCLE RETURN
	((OA-REG-HIGH) DPB M-T OAH-A-SRC A-ZERO)	 ;NOTE LOWEST-A-MEM-VIRTUAL-ADDRESS 
	((MD) A-GARBAGE)			 ;MUST BE 0 MODULO A-MEMORY SIZE
	(JUMP-XCT-NEXT PGF-RESTORE)
       ((VMA) A-PGF-VMA)		;NOBODY ELSE WILL PUT BACK VMA

PGF-SA-W
	((M-A) A-V-TRUE)
	(JUMP-NOT-EQUAL M-A A-PGF-MODE PGF-SA-W-NOT-BINDING)
	((M-A) A-V-NIL)
	(JUMP-EQUAL M-A A-AMEM-EVCP-VECTOR PGF-SA-W-NOT-BINDING)
	;; Get a-mem address being bound.  In range for EVCP hacking?
	((VMA) DPB M-ZERO (BYTE-FIELD 22. 10.) A-PGF-VMA)	;Get low 10 bits
	(JUMP-GREATER-OR-EQUAL VMA (A-CONSTANT (A-MEM-LOC A-END-Q-POINTERS))
			PGF-SA-W-NOT-BINDING)
	;; We are binding or unbinding and must hack the EVCP vector.
	;; "restore" all info saved by PGF-W to its real home
	;; or else save it on the stack
	;; so we can be in a position to take recursive page faults.
	;; Note: A-PGF-WMD can be untyped data, but since we
	;; do not allow sequence breaks herein, that can't cause trouble.
	;; Also, since this happens only from binding or unbinding,
	;; we need not fear that PDL-BUFFER-POINTER doesn't really
	;; point at the top of the stack.
	(CALL PGF-RESTORE)
	((C-PDL-BUFFER-POINTER-PUSH) A-PGF-WMD)
	((C-PDL-BUFFER-POINTER-PUSH) A-PGF-VMA)
	;Now we can take page faults again!
	;Get the current EVCP out of the EVCP vector.
	((VMA-START-READ) M+A+1 A-AMEM-EVCP-VECTOR VMA)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((MD) Q-TYPED-POINTER MD)
	(JUMP-EQUAL MD A-V-NIL PGF-SA-BIND-NO-EVCP)
	;Write current contents of a-mem location into the EVCP, if any.
	((VMA) MD)
	((M-TEM) (BYTE-FIELD 10. 0) C-PDL-BUFFER-POINTER)
	((OA-REG-HIGH) DPB M-TEM OAH-A-SRC A-ZERO) ;NOTE LOWEST-A-MEM-VIRTUAL-ADDRESS 
	((MD-START-WRITE) A-GARBAGE)	;MUST BE 0 MODULO A-MEMORY SIZE
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
PGF-SA-BIND-NO-EVCP
	;Replace the current EVCP with the old one, or NIL if not an EVCP.
	((VMA) C-PDL-BUFFER-POINTER-POP)
	((MD) C-PDL-BUFFER-POINTER)
	((C-PDL-BUFFER-POINTER-PUSH) VMA)
	((M-TEM) Q-DATA-TYPE MD)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER))
		    PGF-SA-BIND-NEW-EVCP)
	((MD) A-V-NIL)
PGF-SA-BIND-NEW-EVCP
	((VMA) (BYTE-FIELD 10. 0) VMA)
	((VMA-START-WRITE) M+A+1 A-AMEM-EVCP-VECTOR VMA)
	(CHECK-PAGE-WRITE)	
	(JUMP-EQUAL MD A-V-NIL PGF-SA-BIND-NO-NEW-EVCP)
	;Get contents of the new EVCP, and put that in a mem instead of the EVCP.
	((VMA-START-READ) MD)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-NO-EVCP)
	(CALL-XCT-NEXT PGF-SAVE)
       ((A-PGF-WMD) MD)
	(CALL-XCT-NEXT PGF-SA-W-NOT-BINDING)
       ((A-PGF-VMA) C-PDL-BUFFER-POINTER-POP)
	((MD) C-PDL-BUFFER-POINTER-POP)
	(POPJ)

PGF-SA-BIND-NO-NEW-EVCP
	((A-PGF-VMA) C-PDL-BUFFER-POINTER-POP)
	((A-PGF-WMD) C-PDL-BUFFER-POINTER-POP)
	(CALL PGF-SAVE-1)
	;Now we are inside a page fault again!
	;Finish writing new contents into A memory.
PGF-SA-W-NOT-BINDING
	((M-T) DPB M-ZERO (BYTE-FIELD 22. 10.) A-PGF-VMA)
	(JUMP-LESS-THAN M-T (A-CONSTANT 40) PGF-SM-W)  ;LOCN REALLY IN M-MEM.
	((OA-REG-LOW) DPB M-T OAL-A-DEST A-ZERO)
	((A-GARBAGE) A-PGF-WMD)
	((MD) A-PGF-WMD)
	(JUMP-XCT-NEXT PGF-RESTORE)
       ((VMA) A-PGF-VMA)		;NOBODY ELSE WILL PUT BACK VMA

PGF-SM-W((OA-REG-LOW) DPB M-T OAL-M-DEST A-ZERO)
	((M-GARBAGE MD) A-PGF-WMD)
	(JUMP-XCT-NEXT PGF-RESTORE)
       ((VMA) A-PGF-VMA)		;NOBODY ELSE WILL PUT BACK VMA

;Write in read-only.
PGF-RDONLY
	;; Should not get here on a read.
	(CALL-IF-BIT-CLEAR M-PGF-WRITE ILLOP)
	;; If this is a CHECK-PAGE-WRITE-FORCE, do it anyway.
	(JUMP-EQUAL A-PGF-MODE M-MINUS-ONE FORCE-WR-RDONLY)
	((M-TEM) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-INHIBIT-READ-ONLY)
	(CALL-EQUAL M-TEM A-V-NIL TRAP)
		(ERROR-TABLE WRITE-IN-READ-ONLY VMA)	;Not continuable!
		;drop into FORCE-WR-RDONLY
;Forced write in nominally read-only area.
;Second-level map is set-up and grants read-only access.
FORCE-WR-RDONLY
	(CALL PGF-SAVE)
	((VMA-WRITE-MAP) (BYTE-FIELD 22. 0) MEMORY-MAP-DATA	;Force read/write access
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 3))))
	((VMA) A-PGF-VMA)		;Restore original VMA
	((MD-START-WRITE) A-PGF-WMD)	;Do the write
	(ILLOP-IF-PAGE-FAULT)
	((MD) VMA)			;Address map again
	((VMA-WRITE-MAP) (BYTE-FIELD 22. 0) MEMORY-MAP-DATA	;Set read-only access again
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 2))))
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)	;Find PHT entry to mark page as modified
       ((M-T) A-PGF-VMA)
	(CALL-IF-BIT-CLEAR PHT1-VALID-BIT READ-MEMORY-DATA ILLOP) ;not found?
	((WRITE-MEMORY-DATA-START-WRITE)
		IOR READ-MEMORY-DATA (A-CONSTANT (BYTE-MASK PHT1-MODIFIED-BIT)))
	(ILLOP-IF-PAGE-FAULT)
	(CALL PGF-RESTORE)
	(POPJ-AFTER-NEXT		;Memory cycle completed, return
	 (VMA) A-PGF-VMA)
       ((MD) A-PGF-WMD)

;HERE FOR READ-WRITE-FIRST TRAP
;FIND PAGE HASH TABLE ENTRY, CHANGE STATUS TO READ/WRITE, AND RELOAD MAP
PGF-RWF	(CALL-IF-BIT-CLEAR M-PGF-WRITE ILLOP)
	(CALL PGF-SAVE)
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)
       ((M-T) A-PGF-VMA)
	(CALL-IF-BIT-CLEAR PHT1-VALID-BIT READ-MEMORY-DATA ILLOP)	;NOT IN PHT??
	((WRITE-MEMORY-DATA-START-WRITE)		;MARK PAGE MODIFIED
		IOR READ-MEMORY-DATA (A-CONSTANT (BYTE-MASK PHT1-MODIFIED-BIT)))
	(ILLOP-IF-PAGE-FAULT)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;GET SECOND WORD
	(ILLOP-IF-PAGE-FAULT)				;TABLE SUPPOSED TO BE WIRED
	((M-A) A-PGF-A)					;RESTORE A REG DURING MEM CYCLE
	((M-T) (A-CONSTANT 4))				;NORMAL STATUS
	((M-B) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE M-T) DPB M-T
		PHT2-MAP-STATUS-CODE A-B)
	(ILLOP-IF-PAGE-FAULT)
	((M-B) A-PGF-B)
	((MD) A-PGF-VMA)				;ADDRESS THE MAP
	(POPJ-AFTER-NEXT				;PHT2 IS IDENTICAL TO 2ND LVL MAP
	 (VMA-WRITE-MAP) MAP-WRITE-SECOND-LEVEL-MAP M-T
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
       ((M-T) A-PGF-T)					;GO RETRY MEMORY CYCLE

;REFERENCE TO PAGE THAT WAS PREPAGED AND HASN'T BEEN TOUCHED YET.  GRAB IT.
PGF-PRE
	((A-DISK-PREPAGE-USED-COUNT) M+A+1 M-ZERO A-DISK-PREPAGE-USED-COUNT)
;REFERENCE TO PAGE MARKED FLUSHABLE.  WE WANT THIS PAGE AFTER ALL, CHANGE BACK TO NORMAL
PGF-FL	;drop through
;REFERENCE TO PAGE WITH AGE TRAP.  CHANGE BACK TO NORMAL TO INDICATE PAGE
;HAS BEEN REFERENCED, AND SHOULDN'T BE SWAPPED OUT OR MADE FLUSHABLE.
PGF-AG	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT READ-MEMORY-DATA
		PHT1-ALL-BUT-SWAP-STATUS-CODE (A-CONSTANT 1))	;SW STS := NORMAL
	(ILLOP-IF-PAGE-FAULT)				;THEN DROP THROUGH

;RELOAD HARDWARE MAP FROM PAGE HASH TABLE
PGF-RL	((MD) A-PGF-VMA)				;ADDRESS THE MAP
	((M-T) MAP-FIRST-LEVEL-MAP MEMORY-MAP-DATA)
	(CALL-EQUAL M-T (A-CONSTANT 37) ILLOP)		;ABOUT TO CLOBBER
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;GET SECOND WORD OF PHT ENTRY
	(ILLOP-IF-PAGE-FAULT)				;TABLE SUPPOSED TO BE WIRED
	((M-A) A-PGF-A)					;RESTORE REGS DURING MEM CYCLE
	((M-B) A-PGF-B)
	(DISPATCH PHT2-MAP-STATUS-CODE READ-MEMORY-DATA D-SWAPAR)	;VERIFY THE BITS
		;; This will go to ILLOP if this is a page of a free region
	((VMA) MAP-WRITE-SECOND-LEVEL-MAP READ-MEMORY-DATA	;VALUE TO WRITE INTO MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	(POPJ-AFTER-NEXT				;COMES DIRECTLY FROM PHT2
	 (MD-WRITE-MAP) A-PGF-VMA)			;WRITE THE MAP AND RETURN
       ((M-T) A-PGF-T)

;ROUTINE TO LOOK FOR PAGE ADDRESSED BY M-T IN THE PAGE HASH TABLE
;RETURNS WITH VMA AND READ-MEMORY-DATA POINTING TO PHT1 WORD,
;OR VMA POINTING TO FIRST HOLE IN HASH TABLE AND PHT1-VALID-BIT
;OF READ-MEMORY-DATA ZERO.  IN THIS CASE, THE SWAP STATUS FIELD
;OF READ-MEMORY-DATA WILL ALSO BE ZERO.  CLOBBERS M-A, M-B, M-T, A-TEM1, A-TEM3

SEARCH-PAGE-HASH-TABLE	
	((A-TEM3) M-T)				;SAVE FOR COMPARISON BELOW
	(CALL COMPUTE-PAGE-HASH)		;M-T := HASH (M-T)
SPHT1	((VMA-START-READ) ADD A-V-PAGE-TABLE-AREA M-T)	;GET PHT ENTRY
	(ILLOP-IF-PAGE-FAULT)			;SUPPOSED TO BE WIRED
	((M-T) ADD M-T (A-CONSTANT 2))		;BUMP INDEX FOR NEXT ITERATION
	(JUMP-LESS-THAN M-T A-PHT-INDEX-LIMIT SPHT2)
	((M-T) SUB M-T A-PHT-INDEX-LIMIT)	;WRAP AROUND
SPHT2	(POPJ-IF-BIT-CLEAR PHT1-VALID-BIT READ-MEMORY-DATA) ;PAGE NOT IN PHT
	((M-A) XOR A-TEM3 READ-MEMORY-DATA)	;XOR VIRTUAL ADDRESSES
	(POPJ-AFTER-NEXT			;(HOPING WE'LL WIN AND RETURN)
	 (M-B) PHT1-VIRTUAL-PAGE-NUMBER M-A)	;ZERO IF MATCH
       (CALL-NOT-EQUAL M-B A-ZERO SPHT1)	;IF NOT FOUND, TRY NEXT

XCPH (MISC-INST-ENTRY %COMPUTE-PAGE-HASH)
	(CALL-XCT-NEXT COMPUTE-PAGE-HASH)
       ((M-T) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	(POPJ-AFTER-NEXT (M-T) Q-POINTER M-T
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	;execute one more instruction, clobbering A-TEM1
COMPUTE-PAGE-HASH				;New algorithm, 3-DEC-80
	((A-TEM1) (BYTE-FIELD 10. 14.) M-T)	;VMA<23:14>
	((M-T) (BYTE-FIELD 20. 4) M-T)		;VMA<23:8>x16+C
	((M-T) ANDCA M-T (A-CONSTANT 17))	;-C
	((M-T) XOR M-T A-TEM1)
	((M-T) AND M-T A-PHT-INDEX-MASK)
	(POPJ-AFTER-NEXT POPJ-LESS-THAN M-T A-PHT-INDEX-LIMIT)
       ((M-T) SUB M-T A-PHT-INDEX-LIMIT)	;Wrap around

;COMES HERE WHEN A PAGE NEEDS TO BE READ IN FROM DISK.
;
;FIRST, FIND SOME MEMORY.  ENTER A LOOP THAT SEARCHES PHYSICAL-PAGE-DATA,
;STARTING FROM LAST PLACE STOPPED, FOR A FLUSHABLE PAGE.  IF NONE
;FOUND, SEARCH INSTEAD FOR ANY NON WIRED PAGE. (THE EMERGENCY CASE.)
;
;HAVING FOUND A PAGE TO REPLACE, WRITE IT TO THE DISK IF NECESSARY.  THEN DELETE
;THAT ENTRY FROM THE PAGE HASH TABLE (HARD), AND FROM THE HARDWARE MAP (EASY).
;
;PERFORM THE DISK READ INTO THE CORE PAGE THUS MADE FREE.
;
;USE A PIPELINED LOOP TO SEARCH THE REGION TABLES AT MEMORY SPEED TO FIND THE
;REGION CONTAINING THE PAGE BEING REFERENCED, AND GET THE META BITS.
;
;NOW RE-HASH THE ADDRESS ORIGINALLY BEING
;REFERENCED TO FIND THE FIRST HOLE (MAY HAVE MOVED DUE TO DELETION) AND PUT
;IN AN ENTRY FOR THAT PAGE.  RESTART THE REFERENCE (SET UP THE MAP FIRST?)

SWAPIN	(CALL-IF-BIT-SET M-INTERRUPT-FLAG ILLOP)	;Uh uh, no paging from interrupts
  ;decide how many pages to bring in with one disk op.  Must not bring in again a page
  ;already in.  Must not cross region boundaries. (There is no reason to believe we
  ;will need pages from another region and complications arise in making the pages known.)
	((A-DISK-SWAPIN-VIRTUAL-ADDRESS) DPB M-ZERO Q-ALL-BUT-POINTER A-PGF-VMA)
	((A-DISK-SWAP-IN-CCW-POINTER) (A-CONSTANT DISK-SWAP-IN-CCW-BASE))
	((A-DISK-SWAPIN-SIZE) (A-CONSTANT 1))
	(JUMP-IF-BIT-SET M-DONT-SWAP-IN SWAPIN-SIZE-X)  ;going to create 0 core, no disk op.
	((M-TEM) A-DISK-SWITCHES)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 3) M-TEM SWAPIN-SIZE-X)  ;multi-swapin not enabled


	((C-PDL-BUFFER-POINTER-PUSH) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	(CALL XRGN)				;=> region number in M-T.. no XCT-NEXT.
	(CALL-EQUAL M-T A-V-NIL ILLOP)		;Swapping in a page not in a region
	((A-DISK-SAVE-PGF-T) M-T)
	((VMA-START-READ) ADD M-T A-V-REGION-BITS)
	(ILLOP-IF-PAGE-FAULT)
	((A-DISK-SAVE-PGF-A) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
  	((A-DISK-SAVE-1) (LISP-BYTE %%REGION-SWAPIN-QUANTUM) READ-MEMORY-DATA)

SWAPIN-SIZE-LOOP
	(JUMP-GREATER-OR-EQUAL M-ZERO A-DISK-SAVE-1 SWAPIN-SIZE-X)
	((M-A) (A-CONSTANT (EVAL PAGE-SIZE)))
	((A-DISK-SAVE-PGF-A) ADD M-A A-DISK-SAVE-PGF-A)
	((C-PDL-BUFFER-POINTER-PUSH) A-DISK-SAVE-PGF-A)
	(CALL XRGN)
	(JUMP-NOT-EQUAL M-T A-DISK-SAVE-PGF-T SWAPIN-SIZE-X)		;not same region
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)
       ((M-T) A-DISK-SAVE-PGF-A)
	(JUMP-IF-BIT-SET PHT1-VALID-BIT READ-MEMORY-DATA SWAPIN-SIZE-X) ;page in core.
	  ;append to transfer
	((A-DISK-PAGE-READ-APPENDS) M+A+1 M-ZERO A-DISK-PAGE-READ-APPENDS)
	((A-DISK-SWAPIN-SIZE) M+A+1 M-ZERO A-DISK-SWAPIN-SIZE)
	(JUMP-XCT-NEXT SWAPIN-SIZE-LOOP)
       ((A-DISK-SAVE-1) ADD (M-CONSTANT -1) A-DISK-SAVE-1)

SWAPIN-SIZE-X 
SWAPIN-LOOP 
	(JUMP-XCT-NEXT SWAPIN0)
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC SWAPIN1))) ;Continuation after FINDCORE


XFINDCORE (MISC-INST-ENTRY %FINDCORE)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC RETURN-M-B)))
SWAPIN0	((M-B) A-FINDCORE-SCAN-POINTER)			;Next page frame to consider
FINDCORE0
	((VMA-START-READ) ADD M-B A-V-PHYSICAL-PAGE-DATA)
FINDCORE1
	(CALL-GREATER-OR-EQUAL VMA A-V-PHYSICAL-PAGE-DATA-END FINDCORE2)
	(ILLOP-IF-PAGE-FAULT)				;Delayed for fencepost error
	((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP-EQUAL M-B A-FINDCORE-SCAN-POINTER FINDCORE3)	;Did all pages but 1, no luck
	((M-TEM) (BYTE-FIELD 20 0) READ-MEMORY-DATA)	;PHT entry index
	((VMA-START-READ M-T) ADD M-TEM A-V-PAGE-TABLE-AREA)
	(JUMP-EQUAL-XCT-NEXT M-TEM (A-CONSTANT 177777) FINDCORE0)	;No page here
       ((A-COUNT-FINDCORE-STEPS) M+A+1 M-ZERO A-COUNT-FINDCORE-STEPS)
	(ILLOP-IF-PAGE-FAULT)				;Check delayed to make code faster
	(DISPATCH-XCT-NEXT PHT1-SWAP-STATUS-CODE READ-MEMORY-DATA D-FINDCORE)
       ((VMA-START-READ) ADD M-B A-V-PHYSICAL-PAGE-DATA)	;Check next page
    ;Note! The above instruction is logically duplicated near COREFOUND-PRE and COREFOUND.

FINDCORE2	;Reached end of memory.  Wrap around to page zero.  There can be pageable
		;memory in the middle of the wired pages on machines with small memory.
	(POPJ-AFTER-NEXT (M-B) A-ZERO)
       ((VMA-START-READ) ADD M-B A-V-PHYSICAL-PAGE-DATA)

;; Searched all of memory (except for the last page brought in), time for emergency measures
;; Age all of the pages in memory, which should make some flushable
FINDCORE3
	((A-COUNT-FINDCORE-EMERGENCIES) M+A+1 M-ZERO A-COUNT-FINDCORE-EMERGENCIES)	
	((M-T) M-1)				;Mustn't clobber M-1
	(CALL-XCT-NEXT AGER)
       ((M-1) A-FINDCORE-SCAN-POINTER)
	(JUMP-XCT-NEXT FINDCORE0)		;Try again
       ((M-1) M-T)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)		;DISPATCH TABLE TO LOOK FOR FLUSHABLE PAGES
D-FINDCORE			;DISPATCH ON SWAP STATUS
	(FINDCORE1)			;0 ILLEGAL
	(FINDCORE1)			;1 NORMAL
	(INHIBIT-XCT-NEXT-BIT COREFOUND);2 FLUSHABLE
	(INHIBIT-XCT-NEXT-BIT COREFOUND-PRE) ;3 PREPAGE
	(FINDCORE1)			;4 AGE TRAP
	(FINDCORE1)			;5 WIRED DOWN
	(FINDCORE1)			;6 NOT USED
	(FINDCORE1)			;7 NOT USED
(END-DISPATCH)

(START-DISPATCH 3 0)		;FOR SWAP-OUT CANDIDATE FROM SCAV WORKING-SET
D-SCAV-SWAPOUT			;DISPATCH ON SWAP STATUS
	(INHIBIT-XCT-NEXT-BIT SWAPIN0)	;0 ILLEGAL
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;1 NORMAL - TAKE
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;2 FLUSHABLE - TAKE
	(P-BIT R-BIT)				;3 PREPAGE - TAKE AND METER
	(P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)	;4 AGE TRAP - TAKE
	(INHIBIT-XCT-NEXT-BIT SWAPIN0)	;5 WIRED DOWN
	(INHIBIT-XCT-NEXT-BIT SWAPIN0)	;6 NOT USED
	(INHIBIT-XCT-NEXT-BIT SWAPIN0)	;7 NOT USED
(END-DISPATCH)

(START-DISPATCH 3 0)		;DISPATCH TABLE TO DROP THROUGH IF PAGE NEEDS WRITING
D-WRITEBACK-NEEDED		;DISPATCH ON MAP STATUS
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;0 ILLEGAL (LVL 1 MAP)
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;1 ILLEGAL (LVL 2 MAP)
	(INHIBIT-XCT-NEXT-BIT COREFOUND2)	;2 READ ONLY
	(INHIBIT-XCT-NEXT-BIT COREFOUND2)	;3 READ/WRITE FIRST
	(P-BIT R-BIT)				;4 READ/WRITE - INDICATES PAGE MODIFIED
	(P-BIT R-BIT)				;5 PDL BUFFER, ALWAYS WRITE PDL-BUFFER PAGES
						;   SINCE R/W/F MECHANISM NOT AVAILABLE.
	(P-BIT R-BIT)				;6 MAR BREAK, ALWAYS WRITE FOR SAME REASON
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;7 ILLEGAL (NOT USED)
(END-DISPATCH)

(START-DISPATCH 3 0)		;DISPATCH TABLE TO DROP THROUGH IF PAGE NEEDS WRITING
D-WRITEBACK-NEEDED-CCW		;DISPATCH ON MAP STATUS
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;0 ILLEGAL (LVL 1 MAP)
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;1 ILLEGAL (LVL 2 MAP)
	(INHIBIT-XCT-NEXT-BIT COREF-CCW-X)	;2 READ ONLY
	(INHIBIT-XCT-NEXT-BIT COREF-CCW-X)	;3 READ/WRITE FIRST
	(P-BIT R-BIT)				;4 READ/WRITE - INDICATES PAGE MODIFIED
	(INHIBIT-XCT-NEXT-BIT COREF-CCW-X)	;5 PDL BUFFER, ALWAYS WRITE PDL-BUFFER PAGES
						;   SINCE R/W/F MECHANISM NOT AVAILABLE.
						;HOWEVER, WE DONT APPEND THESE.
	(INHIBIT-XCT-NEXT-BIT COREF-CCW-X)	;6 MAR BREAK, ALWAYS WRITE FOR SAME REASON
						;HOWEVER, WE DONT APPEND THESE.
	(INHIBIT-XCT-NEXT-BIT P-BIT ILLOP)	;7 ILLEGAL (NOT USED)
(END-DISPATCH)
(LOCALITY I-MEM)

;Here when we've found a page to evict.  M-B has the PFN+1.
;VMA and MD are for the PHT1.  M-T same as VMA.

;This version for the case where victim was pre-paged in and not used
COREFOUND-PRE
	(JUMP-IF-BIT-CLEAR M-SCAVENGE-FLAG COREFOUND-PRE-REALLY)
	((A-TEM1) DPB M-B VMA-PHYS-PAGE-ADDR-PART A-ZERO)  ;phys adr + page size
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-SCAVENGER-WS-ENABLE)
	(JUMP-LESS-OR-EQUAL M-TEM A-TEM1 COREFOUND-PRE-REALLY)
	(JUMP-XCT-NEXT FINDCORE1) 
	   ;; Page being brought in by the scavenger but this page not part of SCAV WS.
	   ;; Continue searching to find another victim instead of kicking out part of
           ;; the user's working set.  Following instruction gets pipeline started again.
       ((VMA-START-READ) ADD M-B A-V-PHYSICAL-PAGE-DATA)  ;duplicates inst near FINDCORE1

COREFOUND-PRE-REALLY
	(JUMP-XCT-NEXT COREFOUND0)
       ((A-DISK-PREPAGE-NOT-USED-COUNT) M+A+1 M-ZERO A-DISK-PREPAGE-NOT-USED-COUNT)

;This version for the normal case
COREFOUND	
	(JUMP-IF-BIT-CLEAR M-SCAVENGE-FLAG COREFOUND-REALLY)  ;see comments above
	((A-TEM1) DPB M-B VMA-PHYS-PAGE-ADDR-PART A-ZERO)  ;phys adr + page size
	((M-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-SCAVENGER-WS-ENABLE)
	(JUMP-LESS-OR-EQUAL M-TEM A-TEM1 COREFOUND-REALLY)
	(JUMP-XCT-NEXT FINDCORE1) 
       ((VMA-START-READ) ADD M-B A-V-PHYSICAL-PAGE-DATA)

COREFOUND-REALLY   
COREFOUND0
	((A-FINDCORE-SCAN-POINTER) M-B)		;Next time, start search with page after this
	((M-B) SUB M-B (A-CONSTANT 1))
COREFOUND3					;Enter here on %DELETE-PHYSICAL-PAGE.
	(CALL-IF-BIT-CLEAR PHT1-VALID-BIT READ-MEMORY-DATA ILLOP)
	((M-A) READ-MEMORY-DATA)			;PHT1
COREFOUND1
	(CALL-NOT-EQUAL A-PAGE-TRACE-PTR M-ZERO PAGE-TRACE-OUT) ;Trace page eviction
	(CALL-IF-BIT-SET (LISP-BYTE %%METER-PAGE-FAULT-ENABLE) M-METER-ENABLES
		METER-PAGE-OUT)

	;;*** When there is background writing, will have to synchronize here
	;;*** This will require dual modified bits or something.
	((VMA-START-READ) ADD M-T (A-CONSTANT 1))	;Get PHT2
	(ILLOP-IF-PAGE-FAULT)				;PHT should be addressable
	(JUMP-IF-BIT-SET PHT1-MODIFIED-BIT M-A COREFOUND1A)
	(DISPATCH PHT2-MAP-STATUS-CODE
		 READ-MEMORY-DATA D-WRITEBACK-NEEDED)	;See if needs writing
COREFOUND1A	;Page needs to be written back to disk
	((C-PDL-BUFFER-POINTER-PUSH) M-T)		;PHT1 address.
	((A-DISK-SWAP-OUT-CCW-POINTER) (A-CONSTANT DISK-SWAP-OUT-CCW-BASE))
	((A-DISK-PAGE-WRITE-COUNT) M+A+1 M-ZERO A-DISK-PAGE-WRITE-COUNT)
     ;add main memory page frame number in M-B to CCW list.
	((WRITE-MEMORY-DATA) DPB M-B VMA-PHYS-PAGE-ADDR-PART (A-CONSTANT 1))
	((VMA-START-WRITE) A-DISK-SWAP-OUT-CCW-POINTER)
	(ILLOP-IF-PAGE-FAULT)
	((A-DISK-SWAP-OUT-CCW-POINTER)
	     ADD A-DISK-SWAP-OUT-CCW-POINTER M-ZERO ALU-CARRY-IN-ONE)
	((A-DISK-SAVE-PGF-A) M-A)
	((A-DISK-SAVE-PGF-B) M-B)
	((M-TEM) A-DISK-SWITCHES)		;Multiple page swapouts enabled?
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 2) M-TEM COREF-CCW-X)
	((A-DISK-SAVE-1) M-A)
COREF-CCW-0
	((M-T) (A-CONSTANT (EVAL PAGE-SIZE)))
	((A-DISK-SAVE-1) ADD M-T A-DISK-SAVE-1)
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)   ;Is next higher page in core?
       ((M-T) A-DISK-SAVE-1)  			 ; virt adr in M-T.
		; clobbers m-a m-b m-t a-tem1 a-tem3
	(JUMP-IF-BIT-CLEAR PHT1-VALID-BIT READ-MEMORY-DATA COREF-CCW-X) ;not found.
		;That page in core, does it need to be written?
	((M-T) VMA)				;Save PHT1 adr.
	((M-A) MD)				;Save PHT1.
	((VMA-START-READ) ADD M-T (A-CONSTANT 1))	;get PHT2
	(ILLOP-IF-PAGE-FAULT)
	((M-B) READ-MEMORY-DATA)
	(JUMP-IF-BIT-SET PHT1-MODIFIED-BIT M-A COREF-CCW-ADD)
	(DISPATCH PHT2-MAP-STATUS-CODE M-B D-WRITEBACK-NEEDED-CCW)  ;See if needs writing
COREF-CCW-ADD 
	((WRITE-MEMORY-DATA M-A) ANDCA M-A
	   (A-CONSTANT (BYTE-MASK PHT1-MODIFIED-BIT))) ;clear modified flag
	((VMA-START-WRITE) M-T)
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) PHT2-MAP-STATUS-CODE M-B)
	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT 4) COREF-CCW-ADD-1)  ;change RW to RWF
	((M-TEM) (A-CONSTANT 3))
	((WRITE-MEMORY-DATA M-B) DPB M-TEM PHT2-MAP-STATUS-CODE A-B)
	((VMA-START-WRITE) ADD M-T (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((MD) M-A)					;address the map
	((M-TEM) MAP-STATUS-CODE MEMORY-MAP-DATA)	;see if map is set up
	(JUMP-LESS-THAN M-TEM (A-CONSTANT 2) COREF-CCW-ADD-1)
	((VMA-WRITE-MAP) MAP-WRITE-SECOND-LEVEL-MAP M-B	;PHT2 IS IDENTICAL TO 2ND LVL MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
COREF-CCW-ADD-1
	((A-DISK-PAGE-WRITE-APPENDS) M+A+1 M-ZERO A-DISK-PAGE-WRITE-APPENDS)
	((A-DISK-PAGE-WRITE-COUNT) M+A+1 M-ZERO A-DISK-PAGE-WRITE-COUNT)
   ;add main memory page frame number in M-B to CCW list.
	((WRITE-MEMORY-DATA) DPB M-B VMA-PHYS-PAGE-ADDR-PART (A-CONSTANT 1))
	((VMA-START-WRITE) A-DISK-SWAP-OUT-CCW-POINTER)
	(ILLOP-IF-PAGE-FAULT)
	((A-DISK-SWAP-OUT-CCW-POINTER)
	   M+A+1 A-DISK-SWAP-OUT-CCW-POINTER M-ZERO)
	((M-TEM) A-DISK-SWAP-OUT-CCW-POINTER)
	(JUMP-LESS-THAN M-TEM (A-CONSTANT DISK-SWAP-OUT-CCW-MAX) COREF-CCW-0)
COREF-CCW-X
	((VMA-START-READ) ADD A-DISK-SWAP-OUT-CCW-POINTER (M-CONSTANT -1))
	(ILLOP-IF-PAGE-FAULT)
	((A-DISK-PAGE-WRITE-OP-COUNT) M+A+1 M-ZERO A-DISK-PAGE-WRITE-OP-COUNT)
	((WRITE-MEMORY-DATA-START-WRITE) SUB READ-MEMORY-DATA (A-CONSTANT 1)) ;last CCW
	(ILLOP-IF-PAGE-FAULT)
	((M-A) A-DISK-SAVE-PGF-A)			;get back base virt adr.
	((M-B) A-DISK-SAVE-PGF-B)			;get back page frame number of first
							; page.  It is no longer used by
							; disk swap handler, but is needed
							; by COREFOUND2.
	((C-PDL-BUFFER-POINTER-PUSH) M-C)
	((M-C) (A-CONSTANT DISK-SWAP-OUT-CCW-BASE))	;M-C
	(CALL-XCT-NEXT DISK-SWAP-HANDLER)		;Do the write (virt adr in M-A)
       ((M-T) (A-CONSTANT DISK-WRITE-COMMAND))
	((M-C) C-PDL-BUFFER-POINTER-POP)
	((A-DISK-PAGE-WRITE-WAIT-COUNT) M+A+1 M-ZERO A-DISK-PAGE-WRITE-WAIT-COUNT)
	((M-T) C-PDL-BUFFER-POINTER-POP)		;RESTORE PHT ENTRY ADDRESS
;DROPS THROUGH
;DROPS IN
;AT THIS POINT, M-T HAS ADDR OF PHT ENTRY TO BE DELETED,
;M-A HAS ITS VIRTUAL ADDRESS, M-B HAS ITS PAGE FRAME NUMBER (NOT! PHYSICAL ADDRESS)
;DELETION WORKS BY FINDING PAGES THAT SHOULD HAVE HASHED TO THE
;HOLE WHERE THE THING WAS DELETED, AND EXCHANGING THEM WITH THE HOLE.
;NOTE THAT THE ALGORITHM IN THE PAGING MEMO IS WRONG.
;CONVENTIONS: M-B POINTS AT THE HOLE, VMA POINTS AT THE ITEM SUSPECTED
;OF BEING IN THE WRONG PLACE, M-PGF-TEM POINTS AT THE UPPERMOST ENTRY IN THE PHT,
;M-T POINTS AT WHERE (VMA) SHOULD HAVE HASHED TO. THESE ARE TYPELESS ABSOLUTE ADDRESSES.

COREFOUND2	
	((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-B	;Save page frame number
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((WRITE-MEMORY-DATA) (M-CONSTANT -1))		;Remove pointer to PHT entry
	((VMA-START-WRITE) ADD M-B A-V-PHYSICAL-PAGE-DATA)
	(ILLOP-IF-PAGE-FAULT)
	((M-B) M-T)					;-> PHT entry to delete
	((M-PGF-TEM) DPB M-ZERO Q-ALL-BUT-POINTER A-V-PAGE-TABLE-AREA)
	((M-PGF-TEM) ADD M-PGF-TEM A-PHT-INDEX-LIMIT)	;-> last entry in table +2
PHTDEL1	((WRITE-MEMORY-DATA)
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;Delete PHT entry
	((VMA-START-WRITE M-B) Q-POINTER M-B)
	(ILLOP-IF-PAGE-FAULT)				;Supposed to be wired
PHTDEL2	((VMA-START-READ) ADD VMA (A-CONSTANT 2))	;Check location following hole
	(JUMP-GREATER-OR-EQUAL VMA A-PGF-TEM PHTDEL5)	;Jump if wrap around
PHTDEL3	(ILLOP-IF-PAGE-FAULT)
	(JUMP-IF-BIT-CLEAR PHT1-VALID-BIT READ-MEMORY-DATA PHTDELX)
	((M-T) SELECTIVE-DEPOSIT READ-MEMORY-DATA	;Check for dummy entry
		PHT1-VIRTUAL-PAGE-NUMBER (A-CONSTANT -1))	;which has an address of -1
	(JUMP-EQUAL-XCT-NEXT M-T (A-CONSTANT -1) PHTDEL7)	;Dummy always hashes
       ((M-T) M-B)						; to the hole
	(CALL-XCT-NEXT COMPUTE-PAGE-HASH)		;Something there, rehash it
       ((M-T) READ-MEMORY-DATA)
	((M-T) ADD M-T A-V-PAGE-TABLE-AREA)		;Convert fixnum hash to address
	((M-T) Q-POINTER M-T)				; sans extra bits
PHTDEL7	(JUMP-LESS-THAN VMA A-T PHTDEL4)		;Jump on funny wrap around case
	(JUMP-GREATER-THAN M-T A-B PHTDEL2)		;Jump if hole is not between where
	(JUMP-LESS-THAN VMA A-B PHTDEL2)		; the frob is and where it hashes to
PHTDEL6	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)	;Move the cell into the hole
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((M-T) SUB VMA (A-CONSTANT 1))			;Save pointer to moved cell
	((WRITE-MEMORY-DATA) READ-MEMORY-DATA)		;Complete the cycle
	((VMA-START-WRITE) ADD M-B (A-CONSTANT 1))	;Address the hole, store PHT2
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) PHT2-PHYSICAL-PAGE-NUMBER MD)		;Fix up physical-page-data
	((VMA-START-READ) ADD M-TEM A-V-PHYSICAL-PAGE-DATA)
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) SUB M-B A-V-PAGE-TABLE-AREA)		;New PHT index
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT
		READ-MEMORY-DATA (BYTE-FIELD 20 20) A-TEM)
	(ILLOP-IF-PAGE-FAULT)
	((VMA) M-B)
	((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP) ;Store PHT1
	(ILLOP-IF-PAGE-FAULT)
	(JUMP-XCT-NEXT PHTDEL1)				;Make the moved cell into new hole
       ((M-B) M-T)

PHTDEL4	(JUMP-LESS-OR-EQUAL M-T A-B PHTDEL6)		;Jump if hole is between where the
	(JUMP-GREATER-OR-EQUAL VMA A-B PHTDEL6)		; frob is and where it hashes to
	(JUMP PHTDEL2)					;It's not, loop more

PHTDEL5	(JUMP-XCT-NEXT PHTDEL3)				;Wrap around to beg of PHT
       ((VMA-START-READ) DPB M-ZERO Q-ALL-BUT-POINTER A-V-PAGE-TABLE-AREA)

PHTDELX	((M-B) C-PDL-BUFFER-POINTER-POP)		;Restore found page frame number
	(POPJ-AFTER-NEXT (MD) M-A)			;Access map for virt page deleted
       ((VMA-WRITE-MAP)					;Flush 2nd lvl map, if any
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
				;Note that if we have a first-level map miss, this does no harm

;We have found one page of core, store it away in the CCW and loop
; until we have got enuf for the transfer we intend.
SWAPIN1	   ;add main memory page frame number in M-B to CCW list.
	((WRITE-MEMORY-DATA) DPB M-B VMA-PHYS-PAGE-ADDR-PART (A-CONSTANT 1))
	((VMA-START-WRITE) A-DISK-SWAP-IN-CCW-POINTER)
	(ILLOP-IF-PAGE-FAULT)
	((A-DISK-SWAP-IN-CCW-POINTER) M+A+1 A-DISK-SWAP-IN-CCW-POINTER M-ZERO)
	((A-DISK-PAGE-READ-COUNT) ADD M-ZERO A-DISK-PAGE-READ-COUNT ALU-CARRY-IN-ONE)
	((A-DISK-SWAPIN-SIZE) ADD A-DISK-SWAPIN-SIZE (M-CONSTANT -1))
	(JUMP-NOT-EQUAL A-DISK-SWAPIN-SIZE M-ZERO SWAPIN-LOOP)
	((VMA-START-READ) ADD A-DISK-SWAP-IN-CCW-POINTER (M-CONSTANT -1))  ;finish ccw list
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA-START-WRITE) SUB WRITE-MEMORY-DATA (A-CONSTANT 1)) ;last
	(ILLOP-IF-PAGE-FAULT)
SWAPIN1-GO
;CONTINUE SWAPPING IN.  NEXT STEP IS TO SEARCH REGION TABLES TO FIND META BITS.
	(CALL PAGE-IN-GET-MAP-BITS)	;note M-B still holds page frame number in path
					; to CZRR.
	(JUMP-IF-BIT-SET M-DONT-SWAP-IN CZRR)		;IF FRESH PAGE DON'T REALLY SWAP IN
	((C-PDL-BUFFER-POINTER-PUSH) M-C)
	((M-C) (A-CONSTANT DISK-SWAP-IN-CCW-BASE))	;CCW list pointer (CLP)
	(CALL-XCT-NEXT DISK-SWAP-HANDLER)		;Do actual disk transfer
       ((M-T) (A-CONSTANT DISK-READ-COMMAND))
	((M-C) C-PDL-BUFFER-POINTER-POP)
SWAPIN2
	;; Now loop through ccw list making the pages known.
	((M-B) (A-CONSTANT DISK-SWAP-IN-CCW-BASE))
	;; First page in gets normal swap-status
	((A-PAGE-IN-PHT1) (A-CONSTANT (PLUS (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
						  (BYTE-VALUE PHT1-VALID-BIT 1))
					    (BYTE-VALUE PHT1-SWAP-STATUS-CODE 1))))
	((A-DISK-PAGE-READ-OP-COUNT) ADD M-ZERO A-DISK-PAGE-READ-OP-COUNT ALU-CARRY-IN-ONE)
SWAPIN2-LOOP
	(CALL-NOT-EQUAL A-PAGE-TRACE-PTR M-ZERO PAGE-TRACE-IN) ;Trace page swapin
	(CALL-IF-BIT-SET (LISP-BYTE %%METER-PAGE-FAULT-ENABLE) M-METER-ENABLES
		METER-PAGE-IN)
	((VMA-START-READ) M-B)
	(ILLOP-IF-PAGE-FAULT)
	((A-DISK-SWAPIN-PAGE-FRAME) LDB VMA-PHYS-PAGE-ADDR-PART READ-MEMORY-DATA A-ZERO)
	((C-PDL-BUFFER-POINTER-PUSH) M-B)
	(CALL PAGE-IN-MAKE-KNOWN)
	((M-B) C-PDL-BUFFER-POINTER-POP)
	((M-A) (A-CONSTANT (EVAL PAGE-SIZE)))
	((A-DISK-SWAPIN-VIRTUAL-ADDRESS) ADD M-A A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	((M-B) M+A+1 M-B A-ZERO)
	(JUMP-LESS-THAN-XCT-NEXT M-B A-DISK-SWAP-IN-CCW-POINTER SWAPIN2-LOOP)
	;; Pages after the first get pre-paged swap-status
       ((A-PAGE-IN-PHT1) (A-CONSTANT (PLUS (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
						 (BYTE-VALUE PHT1-VALID-BIT 1))
					   (BYTE-VALUE PHT1-SWAP-STATUS-CODE 3))))
SWAPIN2-X
	(JUMP PGF-RESTORE)	;TAKE FAULT AGAIN SINCE DISK XFER
				;MAY HAVE FAULTED AND FLUSHED SECOND LEVEL MAP BLOCK.


PAGE-IN-GET-MAP-BITS   ;Get PHT2 bits and leave them in A-DISK-SWAPIN-PHT2-BITS.
	((C-PDL-BUFFER-POINTER-PUSH) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	(CALL XRGN)					;=> region number in M-T
	(CALL-EQUAL M-T A-V-NIL ILLOP)			;Swapping in a page not in a region
	((VMA-START-READ) ADD M-T A-V-REGION-BITS)	;Get misc bits word
	(ILLOP-IF-PAGE-FAULT)				;Should be wired down
	((M-A) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	((M-TEM) SELECTIVE-DEPOSIT READ-MEMORY-DATA (LISP-BYTE %%REGION-MAP-BITS)
	     (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((A-DISK-SWAPIN-PHT2-BITS) M-TEM)
	((M-T) A-MAR-LOW)				;Check VMA against MAR
	((M-T) SELECTIVE-DEPOSIT M-T VMA-PAGE-ADDR-PART A-ZERO)
	(POPJ-LESS-THAN M-A A-T)
	((M-T) A-MAR-HIGH)
	((M-T) SELECTIVE-DEPOSIT M-T VMA-PAGE-ADDR-PART (A-CONSTANT (EVAL (1- PAGE-SIZE))))
	(POPJ-GREATER-THAN M-A A-T)	;If MAR to be set, change map status and turn off
	(POPJ-AFTER-NEXT
	 (M-T) (A-CONSTANT (EVAL %PHT-MAP-STATUS-MAR)))	; hardware access
       ((A-DISK-SWAPIN-PHT2-BITS) DPB M-T PHT2-MAP-ACCESS-AND-STATUS-CODE A-TEM)

;;; Second part.  Make physical page frame number A-DISK-SWAPIN-PHYSICAL-PAGE-FRAME
;;;  known at A-DISK-SWAPIN-VIRTUAL-ADDRESS.  PHT2 bits are in
;;;  A-DISK-SWAPIN-PHT2-BITS.  
;;; A-PAGE-IN-PHT1 contains the bits desired in the PHT1 (swap status mainly)
;;; Clobbers M-A, M-B, M-T, A-TEM1, A-TEM3

PAGE-IN-MAKE-KNOWN
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)		;Find hole in PHT for it
       ((M-T) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	(CALL-IF-BIT-SET PHT1-VALID-BIT READ-MEMORY-DATA ILLOP)	;Supposed to be a hole!
	((M-A) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	((WRITE-MEMORY-DATA-START-WRITE)  ;Construct and store PHT1 word
	    SELECTIVE-DEPOSIT M-A PHT1-VIRTUAL-PAGE-NUMBER A-PAGE-IN-PHT1)
	(ILLOP-IF-PAGE-FAULT)			;Should be wired
	((M-PGF-TEM) A-DISK-SWAPIN-PAGE-FRAME)
	((WRITE-MEMORY-DATA) SELECTIVE-DEPOSIT M-PGF-TEM 
		PHT2-PHYSICAL-PAGE-NUMBER	;Restore access, status, and meta bits
		A-DISK-SWAPIN-PHT2-BITS)
	(DISPATCH (LISP-BYTE %%PHT2-MAP-STATUS-CODE) MD D-SWAPAR) ;Verify the bits
		;; This will go to ILLOP if this is a page of a free region
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))	;Store PHT2
	(ILLOP-IF-PAGE-FAULT)				;Should be wired
	((WRITE-MEMORY-DATA) M-A-1 VMA A-V-PAGE-TABLE-AREA)	;0,,Index in PHT
	((VMA) A-DISK-SWAPIN-PAGE-FRAME)
	(POPJ-AFTER-NEXT
	 (VMA-START-WRITE) ADD VMA A-V-PHYSICAL-PAGE-DATA)
       (ILLOP-IF-PAGE-FAULT)

(LOCALITY D-MEM)
(START-DISPATCH 3 0)				;DISPATCH ON MAP-STATUS
D-SWAPAR					;VERIFY MAP STATUS CODE FROM CORE
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;0 MAP NOT SET UP ERRONEOUS
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;1 META BITS ONLY ERRONEOUS
	(P-BIT R-BIT)				;2 READ ONLY
	(P-BIT R-BIT)				;3 READ WRITE FIRST
	(P-BIT R-BIT)				;4 READ WRITE
	(P-BIT R-BIT)				;5 PDL BUFFER
	(P-BIT R-BIT)				;6 MAR BREAK
	(P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)	;7 UNUSED CODE
(END-DISPATCH)
(LOCALITY I-MEM)

;INITIALIZE A FRESH PAGE BY FILLING IT WITH <DTP-TRAP .>
; Virtual adr in A-DISK-SWAPIN-VIRTUAL-ADDRESS (no type bits), M-B/ PAGE FRAME NUMBER
CZRR	((MD) A-ZERO)				;CLOBBER MAP 0 TO POINT TO PAGE
	((M-T) MEMORY-MAP-DATA)			;SAVE 0@2
	((VMA-WRITE-MAP) DPB M-B MAP-PHYSICAL-PAGE-NUMBER
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 3)))) ;R/W
	((VMA) A-ZERO)			;COMPUTE PAGE BASE ADDRESS
	((A-TEM1) SELECTIVE-DEPOSIT M-ZERO VMA-LOW-BITS A-DISK-SWAPIN-VIRTUAL-ADDRESS)
CZRR1	((WRITE-MEMORY-DATA-START-WRITE)	;STORE TRAPS POINTING TO SELF
		ADD VMA A-TEM1)			;NOTE DTP-TRAP = 0
	(ILLOP-IF-PAGE-FAULT)
	(JUMP-LESS-THAN-XCT-NEXT VMA (A-CONSTANT 377) CZRR1)
       ((VMA) ADD VMA (A-CONSTANT 1))
	((A-FRESH-PAGE-COUNT) ADD M-ZERO A-FRESH-PAGE-COUNT ALU-CARRY-IN-ONE)
	((MD) A-ZERO)
	(JUMP-XCT-NEXT SWAPIN2)			;RETURN TO MAIN SWAP-IN CODE
       ((VMA-WRITE-MAP) MAP-WRITE-SECOND-LEVEL-MAP M-T	;RESTORE 0@2
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))

;Ager. Called from DISK-SWAP-HANDLER, may clobber M-1, A-TEM1, A-TEM2, A-TEM3, M-TEM.
;Must be called with A-AGING-SCAN-POINTER in M-1.
;This advances A-AGING-SCAN-POINTER through main memory until it catches up
;to A-FINDCORE-SCAN-POINTER, skipping over the page which is being read in now.
;If a page is found with normal swap-status, it is changed to age trap.
;If a page is found with age-trap status, it is changed to flushable.
AGER	((A-AGING-SCAN-POINTER) A-FINDCORE-SCAN-POINTER)	;Will advance to here
AGER0	((VMA-START-READ) ADD M-1 A-V-PHYSICAL-PAGE-DATA)
	(CALL-GREATER-OR-EQUAL VMA A-V-PHYSICAL-PAGE-DATA-END AGER1)	;If wrap around
	(ILLOP-IF-PAGE-FAULT)
	((M-1) ADD M-1 (A-CONSTANT 1))
	(POPJ-EQUAL M-1 A-FINDCORE-SCAN-POINTER)	;Return if caught up, skipping this one
	((M-TEM) (BYTE-FIELD 20 0) READ-MEMORY-DATA)	;PHT entry index
	(JUMP-EQUAL M-TEM (A-CONSTANT 177777) AGER0)	;No page here
	((VMA-START-READ) ADD M-TEM A-V-PAGE-TABLE-AREA)
	(ILLOP-IF-PAGE-FAULT)
	(DISPATCH PHT1-SWAP-STATUS-CODE READ-MEMORY-DATA D-AGER)

AGER1	(POPJ-AFTER-NEXT (M-1) A-ZERO)			;Wrap around to page zero
       ((VMA-START-READ) ADD M-1 A-V-PHYSICAL-PAGE-DATA)

(LOCALITY D-MEM)
(START-DISPATCH 3 INHIBIT-XCT-NEXT-BIT)
D-AGER	(AGER0)		;0 PHT ENTRY INVALID, IGNORE
	(AGER2)		;1 NORMAL, SET AGE TRAP
	(AGER0)		;2 FLUSHABLE, IGNORE
	(AGER0)		;3 PREPAGED, IGNORE
	(AGER3)		;4 AGE TRAP, CHANGE TO FLUSHABLE IF AGED ENOUGH
	(AGER0)		;5 WIRED, IGNORE
	(P-BIT ILLOP)	;6 NOT USED, ERROR
	(P-BIT ILLOP)	;7 NOT USED, ERROR
(END-DISPATCH)
(LOCALITY I-MEM)

;CHANGE NORMAL TO AGE-TRAP, ALSO TURN OFF HARDWARE MAP ACCESS, SET AGE TO 0
AGER2	((A-PAGE-AGE-COUNT) ADD M-ZERO A-PAGE-AGE-COUNT ALU-CARRY-IN-ONE)
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT READ-MEMORY-DATA
	    PHT1-ALL-BUT-AGE-AND-SWAP-STATUS-CODE
	    (A-CONSTANT (EVAL %PHT-SWAP-STATUS-AGE-TRAP)))
	(ILLOP-IF-PAGE-FAULT)
	(JUMP-XCT-NEXT AGER0)
       ((VMA-WRITE-MAP)				;FLUSH 2ND LVL MAP, IF ANY
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))

;CHANGE AGE-TRAP TO FLUSHABLE IF HAS BEEN AGED ENOUGH
AGER3	((M-TEM) PHT1-AGE READ-MEMORY-DATA)
	(JUMP-GREATER-OR-EQUAL M-TEM A-AGING-DEPTH AGER4)	;AGED ENOUGH
	((WRITE-MEMORY-DATA-START-WRITE) ADD READ-MEMORY-DATA	;AGE MORE BEFORE MAKING
		(A-CONSTANT (BYTE-VALUE PHT1-AGE 1)))		; FLUSHABLE
	(ILLOP-IF-PAGE-FAULT)
	(JUMP AGER0)

AGER4	((A-PAGE-FLUSH-COUNT) ADD M-ZERO A-PAGE-FLUSH-COUNT ALU-CARRY-IN-ONE)
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT READ-MEMORY-DATA
	    PHT1-ALL-BUT-SWAP-STATUS-CODE (A-CONSTANT (EVAL %PHT-SWAP-STATUS-FLUSHABLE)))
	(ILLOP-IF-PAGE-FAULT)
	(JUMP AGER0)

;GIVEN AN ADDRESS FIND WHAT AREA IT IS IN.  RETURNS THE AREA NUMBER OR NIL.
;THIS WORKS BY FINDING THE REGION NUMBER, THEN FINDING WHAT AREA THAT REGION LIES IN.
XARN (MISC-INST-ENTRY %AREA-NUMBER)
	(CALL XRGN)			;GET REGION NUMBER FROM ARG ON PDL
	(POPJ-EQUAL M-T A-V-NIL)	;NONE
;GIVEN A REGION NUMBER IN M-T, FIND THE AREA-NUMBER (IN M-T WITH DATA-TYPE)
REGION-TO-AREA 
	((VMA-START-READ) ADD M-T A-V-REGION-LIST-THREAD)
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT BOXED-SIGN-BIT READ-MEMORY-DATA REGION-TO-AREA)
       ((M-T) BOXED-NUM-EXCEPT-SIGN-BIT READ-MEMORY-DATA	;GET NEXT IN LIST
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ)				;END OF LIST, M-T HAS AREA NUMBER

;GIVEN AN ADDRESS FIND WHAT REGION IT IS IN.  RETURNS THE REGION NUMBER OR NIL
;IF NOT IN ANY REGION, IN M-T.  RETURNS (OR TAKES AT XRGN1) THE POINTER IN M-A.
;MUST CLOBBER ONLY M-T, M-TEM, Q-R, A-TEM1, A-TEM2, A-TEM3, M-A
;SINCE IT IS CALLED BY THE PAGE FAULT ROUTINES.
XRGN (MISC-INST-ENTRY %REGION-NUMBER)
	((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP	;An address in the region
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
XRGN1	;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!)
	((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-A A-V-ADDRESS-SPACE-MAP)
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-A)	;Byte number in that word
	((M-TEM) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO)
	((OA-REG-LOW) SUB (M-CONSTANT 40) A-TEM)	;40 doesn't hurt here, IORed in
       ((M-T) (BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) READ-MEMORY-DATA
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(POPJ-NOT-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	;; 0 in table, is either free space or fixed area
	(JUMP-GREATER-OR-EQUAL M-A A-V-FIRST-UNFIXED-AREA XFALSE)	;Free space
	;; Search table of area origins.  I guess linear search is fast enough
	((M-T) (A-CONSTANT (A-MEM-LOC A-V-INIT-LIST-AREA)))
XRGN2	((OA-REG-HIGH) DPB M-T OAH-A-SRC A-ZERO)
       (JUMP-LESS-THAN-XCT-NEXT M-A A-GARBAGE XRGN2)
      ((M-T) SUB M-T (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (M-T) SUB M-T
		(A-CONSTANT (DIFFERENCE (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA) 1)))
       ((M-T) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;;; MISCELLANEOUS FUNCTIONS FOR LISP PROGRAMS TO HACK THE PAGE HASH TABLE

XCPGS (MISC-INST-ENTRY %CHANGE-PAGE-STATUS)
	;ARGS ARE VIRTUAL ADDRESS, SWAP STATUS CODE, ACCESS STATUS AND META BITS
	;DOESN'T DO ERROR CHECKING, IF YOU DO THE WRONG THING YOU WILL LOSE.
	((M-E) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Access, status, and meta bits
	((M-D) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;Swap status code
;Here from UPDATE-REGION-PHT.  Must bash only M-A, M-B, M-T, tems.
;Returns address which came in on pdl, in MD.
;Note magic kludge -- sign of M-D means get rid of page entirely (for FREE-REGION)
XCPGS0	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)
       ((M-T) Q-POINTER C-PDL-BUFFER-POINTER)	;Virtual address
	(JUMP-IF-BIT-CLEAR-XCT-NEXT		;If not swapped in, return NIL, and make
		PHT1-VALID-BIT READ-MEMORY-DATA XCPGS2)	; sure to clear the map
       ((M-T) A-V-NIL)
	((M-T) A-V-TRUE)			;Get ready to return T
	(JUMP-EQUAL M-D A-V-NIL XCPGS1)		;See if should change swap-status
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 31.) M-D XCPGS3) ;If sign bit of M-D set,
	((A-TEM2) ANDCA MD (A-CONSTANT (BYTE-MASK PHT1-MODIFIED-BIT))) ;clear modified flag
	((MD) DPB (M-CONSTANT -1) PHT1-VIRTUAL-PAGE-NUMBER A-TEM2) ;and forget virtual page
XCPGS3	((WRITE-MEMORY-DATA-START-WRITE)
		SELECTIVE-DEPOSIT MD PHT1-ALL-BUT-SWAP-STATUS-CODE A-D)
	(ILLOP-IF-PAGE-FAULT)
XCPGS1	(JUMP-EQUAL M-E A-V-NIL XCPGS2)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((A-TEM2) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-E PHT2-ACCESS-STATUS-AND-META-BITS A-TEM2)
	(ILLOP-IF-PAGE-FAULT)
XCPGS2	((MD) C-PDL-BUFFER-POINTER-POP)		;ADDRESS LOCATION BEING HACKED
	((VMA-WRITE-MAP)			;FLUSH 2ND LVL MAP, IF ANY
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
			;NO HARM DONE IF MAP MISS ALREADY, EITHER LEVEL
	(POPJ-XCT-NEXT)				;MUSTN'T POPJ DURING MAP-WRITE CYCLE
       ((VMA) A-V-NIL)				;INSTRUCTIONS MUST LEAVE VMA NON-GARBAGE

XCPPG (MISC-INST-ENTRY %CREATE-PHYSICAL-PAGE)
	;ARG IS PHYSICAL ADDRESS
	((VMA-START-READ) A-V-PAGE-TABLE-AREA)		;FIND FIRST HOLE
XCPPG0	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) SUB VMA A-V-PAGE-TABLE-AREA)
	(CALL-GREATER-OR-EQUAL M-TEM A-PHT-INDEX-LIMIT ILLOP)	;OUT OF BOUNDS
	(JUMP-IF-BIT-SET-XCT-NEXT PHT1-VALID-BIT READ-MEMORY-DATA XCPPG0)
       ((VMA-START-READ) ADD VMA (A-CONSTANT 2))
	(NO-OP)						;USELESS MEM CYCLE
	((VMA) SUB VMA (A-CONSTANT 2))			;ADDRESS PHT1 OF HOLE
;Enter here from COLD-REINIT-PHT.  May smash only M-T.
XCPPG1	((WRITE-MEMORY-DATA-START-WRITE) DPB (M-CONSTANT -1)	;FAKE VIRTUAL ADDRESS
		PHT1-VIRTUAL-PAGE-NUMBER
		(A-CONSTANT (PLUS (PLUS (BYTE-VALUE PHT1-SWAP-STATUS-CODE 2) ;FLUSHABLE
					(BYTE-VALUE PHT1-VALID-BIT 1))
				  (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))
	(ILLOP-IF-PAGE-FAULT)
	((M-T) VMA-PHYS-PAGE-ADDR-PART C-PDL-BUFFER-POINTER-POP);PAGE FRAME NUMBER
	((WRITE-MEMORY-DATA) SUB VMA A-V-PAGE-TABLE-AREA)	;0,,PHT INDEX
	((VMA-START-WRITE) ADD M-T A-V-PHYSICAL-PAGE-DATA)
	(ILLOP-IF-PAGE-FAULT)
	(JUMP-LESS-THAN VMA A-V-PHYSICAL-PAGE-DATA-END XCPPG2)	;See if table getting bigger
	(CALL-GREATER-OR-EQUAL VMA A-V-REGION-ORIGIN ILLOP)	;Bigger than space allocated
	((A-V-PHYSICAL-PAGE-DATA-END) ADD VMA (A-CONSTANT 1))
XCPPG2	((VMA) M+A+1 MD A-V-PAGE-TABLE-AREA)		;Address PHT2
	(JUMP-XCT-NEXT XTRUE)
       ((WRITE-MEMORY-DATA-START-WRITE) IOR M-T
		(A-CONSTANT (PLUS (BYTE-VALUE PHT2-ACCESS-STATUS-AND-META-BITS 1200) ;RO
				  (BYTE-VALUE Q-DATA-TYPE DTP-FIX))))

XDPPG (MISC-INST-ENTRY %DELETE-PHYSICAL-PAGE)
	;ARG is physical address
	((M-B) VMA-PHYS-PAGE-ADDR-PART C-PDL-BUFFER-POINTER-POP);Page frame number
	((VMA-START-READ) ADD M-B A-V-PHYSICAL-PAGE-DATA)
	(ILLOP-IF-PAGE-FAULT)
	(CALL-GREATER-OR-EQUAL VMA A-V-PHYSICAL-PAGE-DATA-END ILLOP)	;PFN too big
	((M-TEM) (BYTE-FIELD 20 0) READ-MEMORY-DATA)	;PHT entry index
	(JUMP-EQUAL M-TEM (A-CONSTANT 177777) XFALSE)	;Already deleted or wired
	((VMA-START-READ M-T) ADD M-TEM A-V-PAGE-TABLE-AREA)
	(ILLOP-IF-PAGE-FAULT)
	(CALL COREFOUND3)				;Swap it out, delete PHT entry
XDPPG1	(POPJ-AFTER-NEXT (M-T) A-V-TRUE)	;Done, return T
       ((VMA) A-V-NIL)				;INSTRUCTIONS MUST LEAVE VMA NON-GARBAGE

XPAGE-IN (MISC-INST-ENTRY %PAGE-IN)
	((A-DISK-SWAPIN-VIRTUAL-ADDRESS) DPB	;ARG 2 - VIRTUAL PAGE NUMBER
		 C-PDL-BUFFER-POINTER-POP VMA-PAGE-ADDR-PART A-ZERO)
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)		;SEE IF ALREADY IN
       ((M-T) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	(JUMP-IF-BIT-SET-XCT-NEXT PHT1-VALID-BIT READ-MEMORY-DATA XFALSE) ;YES, RETURN NIL
       ((A-DISK-SWAPIN-PAGE-FRAME) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;ARG 1 - PAGE FRAME
	(CALL PAGE-IN-GET-MAP-BITS)			;NO, PUT IT IN
	(CALL-XCT-NEXT PAGE-IN-MAKE-KNOWN)
       ((A-PAGE-IN-PHT1) (A-CONSTANT (PLUS (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
						 (BYTE-VALUE PHT1-VALID-BIT 1))
					   (BYTE-VALUE PHT1-SWAP-STATUS-CODE 1))))
	(JUMP XDPPG1)					;RETURN T, FIX VMA

;NIL if not swapped in, 0 if in and not modified, 1 if in and modified
XPGSTS (MISC-INST-ENTRY %PAGE-STATUS)
	(CALL-XCT-NEXT SEARCH-PAGE-HASH-TABLE)
       ((M-T) C-PDL-BUFFER-POINTER-POP)
	(JUMP-IF-BIT-CLEAR PHT1-VALID-BIT MD XFALSE)
	(POPJ-IF-BIT-SET-XCT-NEXT PHT1-MODIFIED-BIT MD)
       ((M-T) DPB (M-CONSTANT -1) (BYTE-FIELD 1 0) 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;Get PHT2
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) PHT2-MAP-STATUS-CODE READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT POPJ-GREATER-OR-EQUAL M-TEM
				(A-CONSTANT (EVAL %PHT-MAP-STATUS-READ-WRITE)))
       ((M-T) SUB M-T (A-CONSTANT 1))			;Not modified

XPHYADR (MISC-INST-ENTRY %PHYSICAL-ADDRESS)
	((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)	;ADDRESS THE MAP
	(CHECK-PAGE-READ-NO-INTERRUPT)		;BE SURE INTERRUPT DOESN'T DISTURB MAP
	((MD) VMA)				;ADDRESS MAP (DELAYS UNTIL READ CYCLE OVER)
	(POPJ-AFTER-NEXT (M-T) DPB MEMORY-MAP-DATA
		 VMA-PHYS-PAGE-ADDR-PART (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
       ((M-T) VMA-LOW-BITS MD A-T)

METER-PAGE-OUT
	((A-METER-EVENT) (A-CONSTANT (EVAL %METER-PAGE-OUT-EVENT)))
	(JUMP-XCT-NEXT METER-PAGE)
       ((M-TEM) SELECTIVE-DEPOSIT M-A PHT1-VIRTUAL-PAGE-NUMBER A-ZERO)

METER-PAGE-IN
	((A-METER-EVENT) (A-CONSTANT (EVAL %METER-PAGE-IN-EVENT)))
	((M-TEM) A-DISK-SWAPIN-VIRTUAL-ADDRESS)

METER-PAGE
	(CALL-XCT-NEXT DISK-PGF-SAVE)
       ((A-METER-LENGTH) (A-CONSTANT 2))	;Two words of info
	((A-TEM1) MICRO-STACK-DATA-POP)		;Kludgey way you have to look back
	((A-TEM2) MICRO-STACK-DATA-POP)		; up the micro-stack
	((A-TEM3) MICRO-STACK-DATA-POP)
	((M-1) (BYTE-FIELD 14. 0)	;Just the return address, not any funny flags
		MICRO-STACK-PNTR-AND-DATA	;Call to PGF-R, PGF-W
		A-ZERO)
	((MICRO-STACK-DATA-PUSH) A-TEM3)
	((MICRO-STACK-DATA-PUSH) A-TEM2)
	((MICRO-STACK-DATA-PUSH) A-TEM1)
	((M-2) M-FLAGS-FOR-PAGE-TRACE)		;Get flags
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-2 (BYTE-FIELD 3 28.) A-1)
	(CALL-XCT-NEXT METER-MICRO-WRITE-HEADER)	;Write meter info
       ((C-PDL-BUFFER-POINTER-PUSH) M-TEM)	;VMA of reference
	(JUMP DISK-PGF-RESTORE)

;Set up to do page-tracing.  We get a wired-down array and fill in 4-word
;entries for page-in and page-out.  An entry looks like:
;	Microsecond clock value
;	Virtual address
;	Miscellany:
;	 bit 31: swap-out flag,
;	 bit 30: stack-group-switch flag
;	 bit 29: transport flag
;	 bit 28: scavenge flag
;	 bits 15-0: micro-pc
;	Current function (just randomly picks up @M-AP, hopefully reasonable)
;If A-PAGE-TRACE-PTR is non-zero, it's the next location to write into,
;and A-PAGE-TRACE-START is the lowest value, A-PAGE-TRACE-END is the wrap-around point
;The array better be wired, have 32-bit elements, and be a multiple of 4 long
;or the machine will blow totally away.
X-PAGE-TRACE (MISC-INST-ENTRY %PAGE-TRACE)
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
	(POPJ-EQUAL-XCT-NEXT M-T A-V-NIL)
       ((A-PAGE-TRACE-PTR) SETZ)		;Assume trace to be shut off
	(CALL-XCT-NEXT GAHDR)
       ((M-A) M-T)				;M-E origin, M-S length, untyped
	((A-PAGE-TRACE-PTR) M-E)
	(POPJ-AFTER-NEXT (A-PAGE-TRACE-START) M-E)
       ((A-PAGE-TRACE-END) ADD M-E A-S)	

;Make a page-trace entry for swap in.
;Only call this if A-PAGE-TRACE-PTR is non-zero
;Can take recursive page faults.
;Note that map faults, such as the interrupt routine can take, don't cause page tracing.
PAGE-TRACE-OUT	;Here when swapping page out
	((A-PAGE-TRACE-UPC) (A-CONSTANT (BYTE-MASK SIGN-BIT)))
	(JUMP-XCT-NEXT PAGE-TRACE-0)
       ((A-PAGE-TRACE-VMA) SELECTIVE-DEPOSIT M-A PHT1-VIRTUAL-PAGE-NUMBER A-ZERO)

PAGE-TRACE-IN	;Here when swapping page in
	((A-PAGE-TRACE-VMA) A-DISK-SWAPIN-VIRTUAL-ADDRESS)
	((A-PAGE-TRACE-UPC) (A-CONSTANT 0))
PAGE-TRACE-0					;clobbers M-1, M-2.
	((A-TEM1) MICRO-STACK-DATA-POP)		;Kludgey way you have to look back
	((A-TEM2) MICRO-STACK-DATA-POP)		; up the micro-stack
	((A-TEM3) MICRO-STACK-DATA-POP)
	((A-PAGE-TRACE-UPC) (BYTE-FIELD 14. 0)	;Just the return address, not any funny flags
		MICRO-STACK-PNTR-AND-DATA	;Call to PGF-R, PGF-W
		A-PAGE-TRACE-UPC)		;Appropriate flags
	((MICRO-STACK-DATA-PUSH) A-TEM3)
	((MICRO-STACK-DATA-PUSH) A-TEM2)
	((MICRO-STACK-DATA-PUSH) A-TEM1)
	(CALL DISK-PGF-SAVE)			;Allow recursive faulting.
	((A-DISK-SAVE-1) PDL-BUFFER-INDEX)
	((A-DISK-SAVE-2) M-FLAGS)
	((M-INTERRUPT-FLAG) DPB (M-CONSTANT -1) A-FLAGS) ;No page swapping (error check)
	((VMA-START-READ) (A-CONSTANT 77772050))	;Microsecond clock (764120)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-TEM1) READ-MEMORY-DATA)		;Stash low word
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)			;Map should be set up, don't bash A-TEM1
	((WRITE-MEMORY-DATA) DPB READ-MEMORY-DATA (BYTE-FIELD 20 20) A-TEM1)
	((VMA-START-WRITE) A-PAGE-TRACE-PTR)	;1st trace word: clock
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) A-PAGE-TRACE-VMA)	;2nd trace word: address referenced
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))	
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((M-TEM) M-FLAGS-FOR-PAGE-TRACE)	;3rd trace word: flags, micro-pc
	((WRITE-MEMORY-DATA) DPB M-TEM (BYTE-FIELD 3 28.) A-PAGE-TRACE-UPC)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))	
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((PDL-BUFFER-INDEX) M-AP)		;4th trace word: macro-function
	((WRITE-MEMORY-DATA) C-PDL-BUFFER-INDEX)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))	
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((VMA) ADD VMA (A-CONSTANT 1))		;Next trace entry address
	(JUMP-LESS-THAN VMA A-PAGE-TRACE-END PAGE-TRACE-1)
	((VMA) A-PAGE-TRACE-START)		;Wrap around
PAGE-TRACE-1
	(CALL-XCT-NEXT DISK-PGF-RESTORE)	;Restore and return
       ((A-PAGE-TRACE-PTR) VMA)
	(POPJ-AFTER-NEXT
	  (M-FLAGS) A-DISK-SAVE-2)
       ((PDL-BUFFER-INDEX) A-DISK-SAVE-1)


;;; Here to perform a disk swapping operation.
;;; M-A has the virtual memory address, M-T has the command.
;;; M-B is no longer an argument at this level.
;;; The CCW is already set up starting at location in M-C.  M-C, M-T bashed.
;;; Returns with operation successfully completed.

DISK-SWAP-HANDLER
	(CALL-XCT-NEXT DISK-PGF-SAVE)
       ((A-DISK-IDLE-TIME) M-ZERO)		;I use the disk
	((M-1) VMA-PAGE-ADDR-PART M-A)		;Convert virtual address to disk address
	(CALL-GREATER-OR-EQUAL M-1 A-DISK-MAXIMUM ILLOP)	;Address out of bounds
	((M-1) ADD M-1 A-DISK-OFFSET)		;Relocate to appropriate part of disk
	(CALL START-DISK-SWAP)			;Start the disk operation
	((WRITE-MEMORY-DATA) SETZ)		;Turn off CPU run light
	((VMA-START-WRITE M-T) ADD VMA (A-CONSTANT 2))
	(CHECK-PAGE-WRITE)
	(CALL READ-MICROSECOND-CLOCK)		;Read microsecond clock into M-2
	((M-1) A-AGING-SCAN-POINTER)		;Run Ager while in disk wait
	(CALL-NOT-EQUAL M-1 A-FINDCORE-SCAN-POINTER AGER)
	(CALL AWAIT-DISK)			;Now wait for operation to complete
	(CALL-XCT-NEXT READ-MICROSECOND-CLOCK)	;Get current time
       ((M-1) M-2)				;but save old time
	((M-2) SUB M-2 A-1)			;Get delta time
	((A-DISK-WAIT-TIME) ADD M-2 A-DISK-WAIT-TIME)	;Increment wait time counter
	((WRITE-MEMORY-DATA) Q-POINTER (M-CONSTANT -1))	;Turn on CPU run light
	((VMA-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	(JUMP DISK-PGF-RESTORE)

;Given a typeless virtual memory address in M-A, set A-DISK-CYL-BEG and A-DISK-CYL-END
;to the typeless virtual memory addresses which enclose the cylinder containing that block
;Smashes M-1, M-2, A-TEM1
GET-DISK-CYLINDER-BOUNDARY
	((M-1) VMA-PAGE-ADDR-PART M-A)
	((M-1) ADD M-1 A-DISK-OFFSET)
	(CALL-XCT-NEXT DIV)			;M-1 gets n blocks into cylinder
       ((M-2) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-BLOCKS-PER-CYLINDER)
	((M-1) DPB M-1 VMA-PAGE-ADDR-PART A-ZERO)	;Convert pages to words
	((M-2) DPB M-2 VMA-PAGE-ADDR-PART A-ZERO)
	(POPJ-AFTER-NEXT (A-DISK-CYL-BEG) SUB M-A A-1)
       ((A-DISK-CYL-END) ADD M-2 A-DISK-CYL-BEG)


;;; Here to start a disk operation, first waiting for the disk to become idle.
;;; M-1 has the disk address, M-T has the command.
;;; The CLP is already built and is in M-C.  M-T, M-C, M-1, M-2 bashed.
;;; Multiple pages can be transfered to consecutive pages on the disk, as
;;; per the CCW list.  Returns with A-DISK-RUN-LIGHT in VMA.
START-DISK-SWAP
	(CALL AWAIT-DISK)			;Wait until disk is idle
	((A-DISK-READ-WRITE) M-T)		;Then store parameters into A-memory
	((A-DISK-CLP) M-C)
	((A-DISK-RETRY-STATE) M-ZERO)
	(CALL-XCT-NEXT DIV)			;Convert disk address to physical
       ((M-2) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-BLOCKS-PER-CYLINDER)
	((A-DISK-ADDRESS) DPB Q-R (BYTE-FIELD 12. 16.) A-ZERO)	;Save cylinder
	(CALL-XCT-NEXT DIV)
       ((M-2) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-BLOCKS-PER-TRACK)
	((A-DISK-ADDRESS) DPB Q-R (BYTE-FIELD 8 8) A-DISK-ADDRESS)	;Save head
	((A-DISK-ADDRESS) DPB M-1 (BYTE-FIELD 8 0) A-DISK-ADDRESS)	;Save block
	(JUMP-XCT-NEXT START-DISK-OP)
       ((A-DISK-RESERVED-FOR-USER) (A-CONSTANT 0))	;Not any more, it isn't!

;;; Here to start a disk operation, first waiting for the disk to become idle.
;;; M-1 has the disk address, M-B has the page frame number of the first main
;;; memory page to transfer, M-T has the command.
;;; The CLP is always 777 .  M-T, M-C, M-1, M-2 bashed.
;;; Returns with A-DISK-RUN-LIGHT in VMA.
START-DISK-1-PAGE
	((M-2) (A-CONSTANT 1))			;Transfer just one page
	((M-C) (A-CONSTANT 777))		;CLP is always 777
;;; M-1 starting disk address, M-B starting main memory page frame number.
;;; M-2 number of pages to transfer, M-T command, M-C address of CCW list.
;;; Bashes M-T, M-1, M-2.  Returns with A-DISK-RUN-LIGHT in VMA.
START-DISK-N-PAGES
	(CALL AWAIT-DISK)			;Wait until disk is idle
	((A-DISK-READ-WRITE) M-T)		;Then store parameters into A-memory
	((A-DISK-CLP) M-C)
	((A-DISK-RETRY-STATE) M-ZERO)
	((M-T) M-2)
	(CALL-XCT-NEXT DIV)			;Convert disk address to physical
       ((M-2) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-BLOCKS-PER-CYLINDER)
	((A-DISK-ADDRESS) DPB Q-R (BYTE-FIELD 12. 16.) A-ZERO)	;Save cylinder
	(CALL-XCT-NEXT DIV)
       ((M-2) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-BLOCKS-PER-TRACK)
	((A-DISK-ADDRESS) DPB Q-R (BYTE-FIELD 8 8) A-DISK-ADDRESS)	;Save head
	((A-DISK-ADDRESS) DPB M-1 (BYTE-FIELD 8 0) A-DISK-ADDRESS)	;Save block
	;; Now build the CCW list
	((VMA) ADD (M-CONSTANT -1) A-DISK-CLP)
	((WRITE-MEMORY-DATA) DPB M-B VMA-PHYS-PAGE-ADDR-PART (A-CONSTANT 1))
BUILD-CCW-LIST-1
	(JUMP-GREATER-THAN M-T (A-CONSTANT 1) BUILD-CCW-LIST-2)
	((WRITE-MEMORY-DATA) SUB WRITE-MEMORY-DATA (A-CONSTANT 1))	;last
BUILD-CCW-LIST-2
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((M-T) SUB M-T (A-CONSTANT 1))
	(JUMP-GREATER-THAN-XCT-NEXT M-T (A-CONSTANT 0) BUILD-CCW-LIST-1)
       ((WRITE-MEMORY-DATA) ADD WRITE-MEMORY-DATA (A-CONSTANT (EVAL PAGE-SIZE)))
	((A-DISK-RESERVED-FOR-USER) (A-CONSTANT 0))	;Not any more, it isn't!
;;; Here to start a disk operation that has been set up in the A-memory variables.
;;; Also called from interrupt level for retries
;;; Returns immediately; call AWAIT-DISK if you want to wait for completion.
;;; Returns with address of disk-run-light in VMA
START-DISK-OP
	((A-DISK-COMMAND) A-DISK-READ-WRITE)
	((A-DISK-DOING-READ-COMPARE) M-ZERO)
;;; Here to start some command other than the one we are really supposed to be doing
START-DISK-OP-1
	((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1)	;Turn on interrupt enable
		(BYTE-FIELD 1 11.) A-DISK-COMMAND)
;;; Enter here from %DISK-OP
START-DISK-OP-2
	((VMA-START-WRITE) A-DISK-REGS-BASE)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) A-DISK-CLP)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) A-DISK-ADDRESS)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((A-DISK-BUSY) (M-CONSTANT -1))
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))	;Start it up
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1)	;Turn on disk run light
		BOXED-NUM-EXCEPT-SIGN-BIT A-ZERO)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-DISK-RUN-LIGHT)
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

;;; Subroutine to wait for a disk operation to complete.  Checks for interrupts,
;;; but doesn't check for interrupts between discovering that it is idle and
;;; returning; hence it is guaranteed still to be idle.
AWAIT-DISK
	(POPJ-EQUAL A-DISK-BUSY M-ZERO)
	(CHECK-PAGE-READ)		;Check for interrupt (can't do directly)
	(JUMP AWAIT-DISK)

;;; Disk completion handler - called from XBUS interrupt handler, status in MD
;;; The following registers may be clobbered
;;; M-A, M-B, M-T
;;; M-TEM, A-TEM1, A-TEM2, A-TEM3
;;; DISPATCH-CONSTANT, Q-R, VMA, MD

DISK-COMPLETION
	(CALL-IF-BIT-CLEAR (BYTE-FIELD 1 0) READ-MEMORY-DATA ILLOP)	;Control busy?
	((A-DISK-STATUS) READ-MEMORY-DATA)	;Store away results of operation
	((M-A) AND READ-MEMORY-DATA		;Get just error status bits
		(A-CONSTANT (PLUS 1_4 1_5 1_6 1_8 1_9 1_10. 1_11. 1_12. 1_13.
				  1_14. 1_15. 1_16. 1_17. 1_18. 1_19. 1_20. 1_23.)))
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-DISK-MA) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-DISK-FINAL-ADDRESS) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-DISK-ECC) READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-ZERO A-DISK-DOING-READ-COMPARE DISK-COMPLETION-READ-COMPARE-OVER)
	(JUMP-NOT-EQUAL M-A A-ZERO DISK-COMPLETION-ERROR)
	;; Operation completed without error, but may still need to do a read-compare.
	((OA-REG-LOW) DPB M-ZERO (BYTE-FIELD 31. 1) A-DISK-READ-WRITE)
	((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 1 0))	;1 if read, 2 if write
	((M-TEM) AND M-TEM A-DISK-SWITCHES)
	((M-B) (A-CONSTANT DISK-READ-COMPARE-COMMAND))
	((A-DISK-DOING-READ-COMPARE) SETO)
	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO START-DISK-OP-1) ;Must check this transfer
       ((A-DISK-COMMAND) DPB M-B (BYTE-FIELD 4 0) A-DISK-COMMAND) ;using same recovery features
DISK-COMPLETION-OK	;; Here when a disk operation has successfully completed
	((WRITE-MEMORY-DATA) M-ZERO)	;Turn off disk run light
	((VMA-START-WRITE) A-DISK-RUN-LIGHT)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((A-DISK-BUSY) M-ZERO)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-DISK-REGS-BASE) ;Clear interrupt enable
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

DISK-COMPLETION-READ-COMPARE-OVER
	((A-DISK-DOING-READ-COMPARE) M-ZERO)
	(JUMP-NOT-EQUAL M-A A-ZERO DISK-COMPLETION-READ-COMPARE-ERROR)
	((M-TEM) A-DISK-STATUS)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 22.) M-TEM DISK-COMPLETION-OK)	;No rd/comp error
	((A-DISK-READ-COMPARE-DIFFERENCES) M+A+1 M-ZERO A-DISK-READ-COMPARE-DIFFERENCES)
DISK-COMPLETION-READ-COMPARE-ERROR
	(JUMP-EQUAL A-DISK-READ-WRITE M-ZERO DISK-COMPLETION-READ-COMPARE-READ-ERROR)
	(CALL LOG-DISK-ERROR)
	(JUMP-XCT-NEXT START-DISK-OP)		;Do write over
       ((A-DISK-READ-COMPARE-REWRITES) M+A+1 M-ZERO A-DISK-READ-COMPARE-REWRITES)

DISK-COMPLETION-READ-COMPARE-READ-ERROR
	((A-DISK-READ-COMPARE-REREADS) M+A+1 M-ZERO A-DISK-READ-COMPARE-REREADS)
DISK-COMPLETION-ERROR
	((A-DISK-ERROR-COUNT) M+A+1 M-ZERO A-DISK-ERROR-COUNT)
	(CALL LOG-DISK-ERROR)
	((M-TEM) AND M-A (A-CONSTANT (PLUS 1_4   ;Multiple select
					   1_5   ;No select
					   1_6   ;Fault
					   1_9   ;Off line
					   1_19. ;Mem parity error
					   1_20. ;NXM
					   )))
	(JUMP-NOT-EQUAL M-TEM A-ZERO FATAL-DISK-ERROR)	;Fatal error, die
	((M-TEM) AND M-A (A-CONSTANT (PLUS 1_8   ;Off cylinder
					   1_10. ;Seek error
					   1_11. ;Timeout error
					   1_12. ;Start-block error
					   1_13. ;Any termination
					   1_14. ;Overrun
					   1_23. ;Internal parity error
					   )))
	(JUMP-NOT-EQUAL M-TEM A-ZERO DISK-COMPLETION-RETRY)
	;(JUMP-IF-BIT-SET (BYTE-FIELD 1 15.) M-A DISK-COMPLETION-ECC)
	;; ECC Hard, ECC Soft, Header ECC, or Header Compare
	;; Operation may succeed if error-recovery features invoked (command <7:4>)
	;; However, we use only the data strobe features, not the servo offset
	;; features.  See the bugs mentioned in LMDOC;DISK
DISK-COMPLETION-RECOVER
	(JUMP-EQUAL M-B (A-CONSTANT DISK-WRITE-COMMAND) DISK-COMPLETION-RETRY)
	((M-TEM) A-DISK-MA)		;Get controller type
	(DISPATCH (BYTE-FIELD 2 22.) M-TEM D-DISK-COMPLETION-RECOVER)
(LOCALITY D-MEM)
(START-DISPATCH 2 0)
D-DISK-COMPLETION-RECOVER
	(P-BIT R-BIT)			;Trident, drop through
	(INHIBIT-XCT-NEXT-BIT DISK-COMPLETION-RETRY)	;Marksman, no recovery features
	(INHIBIT-XCT-NEXT-BIT ILLOP)	;Type 2 not defined
	(P-BIT R-BIT)			;Type 3 treat as Trident in case old disk control
(END-DISPATCH)
(LOCALITY I-MEM)
	((M-TEM) A-DISK-COMMAND)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 6) M-TEM DISK-COMPLETION-RETRY) ;Features exhausted
	(JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 7) M-TEM START-DISK-OP-1)
       ((A-DISK-COMMAND) DPB (M-CONSTANT -1) (BYTE-FIELD 1 7) A-DISK-COMMAND)
	(JUMP-XCT-NEXT START-DISK-OP-1)
       ((A-DISK-COMMAND) SUB M-TEM (A-CONSTANT 1_6))	;Bit 7 off, bit 6 on

DISK-COMPLETION-RETRY	;Operation may succeed if tried again
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 14.) M-A DISK-COMPLETION-RETRY-1)
	((VMA-START-READ) A-CHAOS-CSR-ADDRESS)	;Overrun: try turning off Chaosnet
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-ZERO
		(LISP-BYTE %%CHAOS-CSR-INTERRUPT-ENABLES) A-TEM)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
DISK-COMPLETION-RETRY-1
	((A-DISK-RETRY-STATE Q-R) M+A+1 M-ZERO A-DISK-RETRY-STATE)
	(JUMP-GREATER-THAN Q-R (A-CONSTANT 5) FATAL-DISK-ERROR)	;Give up after 5 tries
	(CALL-IF-BIT-CLEAR (BYTE-FIELD 1 0) Q-R DISK-RECALIBRATE)	;Recal 2nd, 4th time
	(JUMP START-DISK-OP)

;;; This is called with the disk not busy, and possibly at interrupt level.
DISK-RECALIBRATE	;Recalibrate the disk.  Callable as a subroutine.
	((MD) (A-CONSTANT DISK-RECALIBRATE-COMMAND))
	((VMA-START-WRITE) A-DISK-REGS-BASE)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((A-DISK-RECALIBRATE-COUNT) M+A+1 M-ZERO A-DISK-RECALIBRATE-COUNT)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 3))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
DISK-RECALIBRATE-WAIT	;Now wait for on-cylinder.  Must NOT check for interrupts
			;since may be called from interrupt level.  Hopefully this
			;doesn't happen often enough to lose many keyboard characters.
			;This is also called from COLD-RUN-DISK
	((VMA-START-READ) A-DISK-REGS-BASE)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) MD DISK-RECALIBRATE-WAIT) ;Wait for startup
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 8) MD DISK-RECALIBRATE-WAIT) ;Wait for not off cyl
	(POPJ)

;;; Here if a fatal disk error has occurred.  Pass back to user if this is from user.
FATAL-DISK-ERROR
	(CALL-EQUAL M-ZERO A-DISK-RESERVED-FOR-USER ILLOP)
	(JUMP DISK-COMPLETION-OK)	;Well, sort of

;;; Log a disk error for later analysis by macrocode or console program
LOG-DISK-ERROR
	((M-TEM) A-DISK-CLP)
	((WRITE-MEMORY-DATA) DPB M-TEM (BYTE-FIELD 20 20) A-DISK-COMMAND)
	((VMA-START-WRITE) A-DISK-ERROR-LOG-POINTER)
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) A-DISK-FINAL-ADDRESS)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) A-DISK-STATUS)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) A-DISK-MA)	
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	(POPJ-LESS-THAN-XCT-NEXT VMA (A-CONSTANT 637))
       ((A-DISK-ERROR-LOG-POINTER) ADD VMA (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (A-DISK-ERROR-LOG-POINTER) (A-CONSTANT 600))
       (NO-OP)

;I don't want to try out this error-correction stuff right now
;Also this knows the disk geometry (e.g. number of heads per disk)
;Something will have to change for multiple units
;
;DISK-COMPLETION-ECC	;ECC Soft - fix bad bits in memory and continue
;			;The disk address has not been incremented past the sector in error
;			;The MA has the address of the last word in the bad page
;			;The right half of the ECC register is the bit number in error
;			;The left half of the ECC register is a mask of which bits are wrong
;	((A-DISK-ECC-COUNT) M+A+1 M-ZERO A-DISK-ECC-COUNT)
;	((M-A) A-DISK-ECC)
;	(CALL-XCT-NEXT PHYS-MEM-READ)
;       ((VMA) (BYTE-FIELD 8 5) M-A A-DISK-MA)	;VMA<21:0> gets physical addr of 1st bad word
;	((M-B) (BYTE-FIELD 5 0) M-A)	;Get bit number of first erroneous bit
;	((M-A) (BYTE-FIELD 20 20) M-A)	;Get erroneous bits mask
;	((M-TEM) M-A-1 (M-CONSTANT 32.) A-B)	;Byte length-1 for bits in first word
;	((OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-B)
;	((A-TEM1) DPB M-A (BYTE-FIELD 0 0) A-ZERO)	;Erroneous bits in first word
;	(CALL-XCT-NEXT PHYS-MEM-WRITE)	;Correct first word
;       ((MD) XOR MD A-TEM1)
;	(JUMP-LESS-OR-EQUAL M-B (A-CONSTANT 16.) DISK-COMPLETION-ECC-2) ;If all bits in 1st wd
;	((OA-REG-LOW) SUB (M-CONSTANT 32.) A-B)	;Rotate remainder of bit mask to low bits
;	((M-A) (BYTE-FIELD 16. 0) M-A)
;	(JUMP-EQUAL M-A A-ZERO DISK-COMPLETION-ECC-2)	;Jump if no bits in second word
;	(CALL-XCT-NEXT PHYS-MEM-READ)
;       ((VMA) ADD VMA (A-CONSTANT 1))
;	(CALL-XCT-NEXT PHYS-MEM-WRITE)
;       ((MD) XOR MD A-A)
;DISK-COMPLETION-ECC-2
;	(CALL-XCT-NEXT PHYS-MEM-READ)	;Fetch a CCW
;       ((VMA) A-DISK-CLP)
;	((M-TEM) XOR MD A-DISK-MA)
;	((M-TEM) (BYTE-FIELD 14. 8) M-TEM)
;	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 0) MD DISK-COMPLETION-ECC-4)	;End CCW list
;	(JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO DISK-COMPLETION-ECC-2)
;       ((A-DISK-CLP) ADD VMA (A-CONSTANT 1))
;	;Advance the disk address manually
;	((M-A) M+A+1 M-ZERO A-DISK-FINAL-ADDRESS)
;	((M-TEM) (BYTE-FIELD 8 0) M-A)	;Block number
;	(JUMP-LESS-THAN M-TEM A-DISK-CURRENT-BLOCKS-PER-TRACK DISK-COMPLETION-ECC-3)
;	((M-A) DPB M-ZERO (BYTE-FIELD 8 0) A-A)	;Recycle to block 0
;	((M-A) ADD M-A (A-CONSTANT 400))	; on next head
;	((M-TEM) (BYTE-FIELD 8 8) M-A)	;Head number
;	(JUMP-LESS-THAN M-TEM A-DISK-CURRENT-NUMBER-OF-HEADS DISK-COMPLETION-ECC-3)
;	((M-A) DPB M-ZERO (BYTE-FIELD 8 8) A-A)	;Recycle to head 0
;	((M-A) ADD M-A (A-CONSTANT 200000))	; on next cylinder
;DISK-COMPLETION-ECC-3
;	((A-DISK-ADDRESS) M-A)
;	(JUMP START-DISK-OP-1)
;
;DISK-COMPLETION-ECC-4		;Here for ECC error corrected on last page of transfer
;	(CALL-NOT-EQUAL M-TEM A-ZERO ILLOP)	;CCW not found in CCW list?
;	(JUMP DISK-COMPLETION-OK)

;;; Support for "user" disk I/O
;;; Note that the interrupt-enable bit in the command word controls
;;; whether or not system error recovery features are invoked.

XDSKOP (MISC-INST-ENTRY %DISK-OP)
	(CALL GAHDRA)		;Get disk-rq array, which must be temp-wired
	;; For now, no queueing, just perform request immediately
	((A-DISK-IDLE-TIME) M-ZERO)		;I use the disk
	((A-DISK-RESERVED-FOR-USER) SETO)	;I want the disk
	(CALL AWAIT-DISK)			;Wait for disk control to become available
	((VMA-START-READ) ADD M-E (A-CONSTANT (EVAL (// %DISK-RQ-COMMAND 2))))
	(CHECK-PAGE-READ)			;Copy user's commands into A-memory
	((A-DISK-COMMAND) READ-MEMORY-DATA)
	((A-DISK-READ-WRITE) (BYTE-FIELD 4 0) READ-MEMORY-DATA)	;For error recovery
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;CLP
	(CHECK-PAGE-READ)
	((A-DISK-CLP) READ-MEMORY-DATA)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;Address
	(CHECK-PAGE-READ)
	((A-DISK-ADDRESS) READ-MEMORY-DATA)
	((A-DISK-RETRY-STATE) M-ZERO)
	((A-DISK-DOING-READ-COMPARE) M-ZERO)
	(CALL-XCT-NEXT START-DISK-OP-2)		;Fire it up
       ((WRITE-MEMORY-DATA M-1) A-DISK-COMMAND)
XDSKOP2	((VMA-START-READ) A-DISK-REGS-BASE)	;Await controller ready
	(CHECK-PAGE-READ)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%DISK-STATUS-LOW-READY) READ-MEMORY-DATA XDSKOP2)
	(CALL-IF-BIT-SET (BYTE-FIELD 1 11.) M-1 AWAIT-DISK)	;Await retry if enabled
	(CALL-IF-BIT-CLEAR (BYTE-FIELD 1 11.) M-1 DISK-COMPLETION-OK)	;Else finish up
	;Return status from hardware, not A-memory, in case microcode was not enabled
	((M-2) ADD M-E (A-CONSTANT (EVAL (1- (// %DISK-RQ-STATUS-LOW 2)))))
	((M-1) ADD (M-CONSTANT -1) A-DISK-REGS-BASE)
	((M-3) A-ZERO)
XDSKOP3	((VMA-START-READ M-1) ADD M-1 (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	((M-3) ADD M-3 (A-CONSTANT 1))
	((VMA-START-WRITE M-2) ADD M-2 (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-THAN M-3 (A-CONSTANT 4) XDSKOP3)	;Status is 4 words
	((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1) (BYTE-FIELD 17. 15.) A-DISK-RETRY-STATE)
	((VMA-START-WRITE) ADD M-E (A-CONSTANT (EVAL (// %DISK-RQ-DONE-FLAG 2))))
	(CHECK-PAGE-WRITE)			;Set completion flag, return retry state
	(CALL-EQUAL M-ZERO A-DISK-RESERVED-FOR-USER ILLOP)	;Took a page fault??
	(POPJ-AFTER-NEXT (M-T) A-V-NIL)
       ((A-DISK-RESERVED-FOR-USER) M-ZERO)	;I'm done with it

;;; INTERRUPTS

;;; This code looks for a Unibus interrupt.  If it finds one it checks whether
;;; it was a keyboard interrupt; if so the character is read out and stored
;;; into the keyboard buffer.  Then the bus interface is readied to take another
;;; interrupt.

;;; Interrupts may clobber only what page faults clobber, plus the A-INTR-TEM
;;; registers.  Interrupts may take page faults to set up the map, but may
;;; not swap in pages.  Interrupts save and restore VMA and MD, but may
;;; possibly invalidate MAP[VMA] and MAP[MD].  Note that if you use
;;; (CHECK-PAGE-READ), an interrupt may occur after the read, and if you
;;; use (CHECK-PAGE-WRITE), an interrupt may occur after the write,
;;; or before it if the page is not swapped in.
;;; It is best if interrupts don't touch the pdl buffer.

INTR	(CALL-IF-BIT-SET M-INTERRUPT-FLAG ILLOP);Recursive interrupt!
	((A-INTR-VMA) VMA)			;Mustn't bash the VMA
	((A-INTR-MD) MD)			; nor the MD
	((M-INTERRUPT-FLAG) DPB (M-CONSTANT -1) A-FLAGS) ;No page faults allowed here
	((VMA-START-READ) (A-CONSTANT 77773020)) ;Unibus address 766040 (interrupt status)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-A) M-A)			;I need a couple M registers
	((A-INTR-B) M-B)
	((A-INTR-T) M-T)			;Convenient to be able to clobber this
	((A-INTR-LOCAL-UNIBUS-MODE) (BYTE-FIELD 1 1) MD)
	(JUMP-EQUAL A-INTR-LOCAL-UNIBUS-MODE M-ZERO INNL0)  ;jump on no local-enable, ie,
						; PDP11 arbritrating UNIBUS. 
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 15.) MD INTRX0) ;If not Unibus, go check for XBUS
	((M-B) SELECTIVE-DEPOSIT MD (BYTE-FIELD 8 2) A-ZERO)	;Interrupt vector address
	(JUMP-EQUAL M-B (A-CONSTANT 270) CHAOS-INTR)	;Chaos net has special handler
	(JUMP-EQUAL M-B (A-CONSTANT 400) ETHER-XMIT-DONE)	;Ether Xmit completed
	(JUMP-EQUAL M-B (A-CONSTANT 404) ETHER-RCV-DONE)	;Ether Receive done
	(JUMP-EQUAL M-B (A-CONSTANT 410) ETHER-COLLISION)	;Collision.
	;No specially provided device handler, maybe this is a general buffered device
	;E.g. the keyboard is one.
	((M-A) (A-CONSTANT (EVAL (+ 400 %SYS-COM-UNIBUS-INTERRUPT-LIST
				    %UNIBUS-CHANNEL-VECTOR-ADDRESS
				    (- %UNIBUS-CHANNEL-LINK)))))
INTR-0	((VMA-START-READ) ADD M-A
		(A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-LINK %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((MD) Q-POINTER MD)
	(CALL-EQUAL MD A-ZERO ILLOP)	;Reached end of list, lossage occurring
	((VMA-START-READ M-A) ADD MD (A-CONSTANT (EVAL %UNIBUS-CHANNEL-VECTOR-ADDRESS)))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-NOT-EQUAL MD A-B INTR-0)		;Loop until find device with this vector
	((VMA-START-READ) ADD M-A
	    (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-CSR-BITS %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-TEM1) READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-A
	    (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-CSR-ADDRESS %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((VMA-START-READ) READ-MEMORY-DATA)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) AND READ-MEMORY-DATA A-INTR-TEM1)
	(JUMP-EQUAL M-TEM A-ZERO INTR-0)	;Device's ready bit not on, try for other
						;devices on the same vector
INNUBI		;Merge here in pdp11 arbitrating unibus case.
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-IN-PTR
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-B) READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-DATA-ADDRESS
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) A-INTR-TEM1)			;Output device?
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 16.) M-TEM INTR-OUTDEV)
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT READ-MEMORY-DATA INTR-1)	;Jump if one-word device
	((VMA-START-READ) ADD MD (A-CONSTANT 1))	;Two-word device (kbd) needs to
	(CHECK-PAGE-READ-NO-INTERRUPT)			; read the high-order word first.
	((A-INTR-TEM1) DPB READ-MEMORY-DATA (BYTE-FIELD 20 20) A-ZERO)
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-XCT-NEXT INTR-2)
       ((MD) (BYTE-FIELD 20 0) READ-MEMORY-DATA A-INTR-TEM1)

INTR-1	((VMA-START-READ) READ-MEMORY-DATA)	;Get device data
	(CHECK-PAGE-READ-NO-INTERRUPT) 
INTR-2	((VMA-START-WRITE) M-B)			;Write into buffer
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-END
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-B) ADD M-B (A-CONSTANT 1))		;Advance storing pointer
	(JUMP-IF-BIT-CLEAR Q-FLAG-BIT READ-MEMORY-DATA INTR-NO-SB);This bit enables seq breaks.
	(JUMP-IF-BIT-CLEAR-XCT-NEXT M-SBS-UNIBUS INTR-NO-SB)     ;This bit does so too.
       ((MD) Q-POINTER READ-MEMORY-DATA)	;Flush the flag bit.
	((INTERRUPT-CONTROL) IOR LOCATION-COUNTER (A-CONSTANT 1_26.))
INTR-NO-SB
	(JUMP-GREATER-THAN READ-MEMORY-DATA A-B INTR-3)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-START
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-B) READ-MEMORY-DATA)
INTR-3	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-OUT-PTR
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-EQUAL READ-MEMORY-DATA A-B UB-INTR-RET)	;Don't advance IN ptr if buffer full
	((WRITE-MEMORY-DATA) M-B)
	((VMA-START-WRITE) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-IN-PTR
						        %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
UB-INTR-RET
	((MD) A-ZERO)				;Clear Unibus interrupt flag
	((VMA-START-WRITE) (A-CONSTANT 77773021)) ;Unibus address 766042
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((MD) (A-CONSTANT 6000))		;Enable one more Unibus interrupt
	((VMA-START-WRITE) (A-CONSTANT 77773020)) ;Unibus address 766040
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
XB-INTR-RET
	((M-INTERRUPT-FLAG) DPB (M-CONSTANT 0) A-FLAGS)	;Allow page faults again
	((MD) A-INTR-MD)
	((VMA) A-INTR-VMA)
	((M-T) A-INTR-T)
	(POPJ-AFTER-NEXT (M-B) A-INTR-B)	;Dismiss
       ((M-A) A-INTR-A)

INTR-OUTDEV
	((A-INTR-TEM1) READ-MEMORY-DATA)	;Address of device data register
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-OUT-PTR
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((VMA-START-READ) READ-MEMORY-DATA)	;Get next word to go out
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-EQUAL VMA A-B INTR-OUTSTOP)	;Buffer empty, stop device
	((M-B) VMA)				;Save out pointer
	((WRITE-MEMORY-DATA) READ-MEMORY-DATA)	;Parity check
	((VMA-START-WRITE) A-INTR-TEM1)		;Store into device
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-END
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-B) ADD M-B (A-CONSTANT 1))		;Advance reading pointer
	(JUMP-GREATER-THAN READ-MEMORY-DATA A-B INTR-OUTDEV3)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-START
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-B) READ-MEMORY-DATA)
INTR-OUTDEV3
	((WRITE-MEMORY-DATA) M-B)
	((VMA-START-WRITE) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-BUFFER-OUT-PTR
						        %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(JUMP UB-INTR-RET)

INTR-OUTSTOP
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-OUTPUT-TURNOFF-BITS
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-TEM1) READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-OUTPUT-TURNOFF-ADDRESS
						       %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((VMA) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) A-INTR-TEM1)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)		;Clear interrupt-enable bit
	(JUMP UB-INTR-RET)

;get here if PDP11 arbitrating UNIBUS.  This means we cannot depend on any UNIBUS
;interrupts so we poll all UNIBUS devices every XBUS interrupt.
INNL0	((VMA-START-READ M-B) A-CHAOS-CSR-ADDRESS)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%CHAOS-CSR-RECEIVE-ENABLE) MD INNL1)
	(JUMP-IF-BIT-SET (LISP-BYTE %%CHAOS-CSR-RECEIVE-DONE) MD CHAOS-INTR)
INNL1	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%CHAOS-CSR-TRANSMIT-ENABLE) MD INNL2)
	(JUMP-IF-BIT-SET (LISP-BYTE %%CHAOS-CSR-TRANSMIT-DONE) MD CHAOS-INTR)
INNL2
  ;Now check all devices in the unibus vector tables.
	((M-A) (A-CONSTANT (EVAL (+ 400 %SYS-COM-UNIBUS-INTERRUPT-LIST
				    %UNIBUS-CHANNEL-VECTOR-ADDRESS
				    (- %UNIBUS-CHANNEL-LINK)))))
INND0	((VMA-START-READ) ADD M-A
		(A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-LINK %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((MD) Q-POINTER MD)
	(JUMP-EQUAL MD A-ZERO INTRX0)	;Reached end of list, maybe it really is the XBUS.
	((M-A) ADD MD (A-CONSTANT (EVAL %UNIBUS-CHANNEL-VECTOR-ADDRESS)))
	((VMA-START-READ) ADD M-A
	    (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-CSR-BITS %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-TEM1) READ-MEMORY-DATA)
	((VMA-START-READ) ADD M-A
	    (A-CONSTANT (EVAL (- %UNIBUS-CHANNEL-CSR-ADDRESS %UNIBUS-CHANNEL-VECTOR-ADDRESS))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((VMA-START-READ) READ-MEMORY-DATA)
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) AND READ-MEMORY-DATA A-INTR-TEM1)
  ;***Should make sure interrupt enable on.  It will be for kbd tho.***
	(JUMP-NOT-EQUAL M-TEM A-ZERO INNUBI)	;Device's ready bit on, handle.
	(JUMP INND0)

;;; XBUS interrupts

INTRX0	((VMA-START-READ) A-TV-REGS-BASE)	;Look for TV interrupt
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 4) READ-MEMORY-DATA INTRX1)
	((WRITE-MEMORY-DATA-START-WRITE)	;Yes, clear flag
		ANDCA READ-MEMORY-DATA (A-CONSTANT 1_4))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Here is the roughly-60-cycle clock interrupt handler
	(JUMP-LESS-OR-EQUAL M-ZERO A-CHAOS-TRANSMIT-ABORTED 60CYC-0)
	;; Wake up Chaosnet after transmit abort
	(CALL-XCT-NEXT CHAOS-WAKEUP)
       ((A-CHAOS-TRANSMIT-ABORTED) (A-CONSTANT 1))
60CYC-0	(JUMP-NOT-EQUAL A-DISK-BUSY M-ZERO 60CYC-1)
	((A-DISK-IDLE-TIME) M+A+1 M-ZERO A-DISK-IDLE-TIME)
60CYC-1	(CALL TRACK-MOUSE)			;See if the mouse has moved
	;; End of the 60-cycle clock interrupt handler
	(JUMP-LESS-THAN-XCT-NEXT M-ZERO A-TV-CLOCK-COUNTER INTRX1)
       ((A-TV-CLOCK-COUNTER) ADD (M-CONSTANT -1) A-TV-CLOCK-COUNTER)
	(JUMP-IF-BIT-CLEAR-XCT-NEXT M-SBS-CLOCK INTRX1)
       ((A-TV-CLOCK-COUNTER) ADD (M-CONSTANT -1) A-TV-CLOCK-RATE) ;Counted down, recycle
	((INTERRUPT-CONTROL)			; and give sequence break if needed
		IOR LOCATION-COUNTER (A-CONSTANT 1_26.))
INTRX1	(JUMP-EQUAL A-DISK-BUSY M-ZERO INTRX2)	;Look for disk interrupt
	((VMA-START-READ) A-DISK-REGS-BASE)
	(CHECK-PAGE-READ-NO-INTERRUPT)		;Bit 3 is interrupt-request
	(CALL-IF-BIT-SET (BYTE-FIELD 1 3) READ-MEMORY-DATA DISK-COMPLETION)
INTRX2	(JUMP XB-INTR-RET)			;End of interrupt chain

;;; Come here for Unibus interrupt from Chaos network

(ASSIGN CHAOS-NUMBER-TRANSMIT-RETRIES 3)	;Send once and retry twice if aborted

CHAOS-INTR
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC UB-INTR-RET)))
	((VMA-START-READ M-B) A-CHAOS-CSR-ADDRESS) ;M-B has base address of hardware
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%CHAOS-CSR-RECEIVE-DONE) READ-MEMORY-DATA
		CHAOS-XMT-INTR)			;See if received a packet
	((A-INTR-TEM2) Q-POINTER READ-MEMORY-DATA	;Save CSR for later
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-XCT-NEXT CHAOS-LIST-GET)		;M-A gets next packet from free list
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-FREE-LIST))))
	(JUMP-EQUAL M-A A-V-NIL CHAOS-XMT-INTR)	;Can't receive now, hold up
	;; Read out the packet into this buffer, along with CSR1, CSR2, Bit-count
	;; M-A points at the buffer and M-B points at the hardware
	;; Buffer is assumed to be big enough for max possible word count (255)
	((WRITE-MEMORY-DATA) A-INTR-TEM2)	;Save CSR1
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-CSR-1))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %CHAOS-BIT-COUNT-OFFSET)))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((WRITE-MEMORY-DATA M-TEM) M+A+1 READ-MEMORY-DATA	;Type bits are 0, bit count is
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	;off by 1
	((A-INTR-TEM1) (BYTE-FIELD 8 4) M-TEM)	;Get word count, then save bit count
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-BIT-COUNT))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) SELECTIVE-DEPOSIT WRITE-MEMORY-DATA
		Q-ALL-BUT-POINTER A-INTR-TEM1)	;Save word count
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-WORD-COUNT))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((A-INTR-TEM2) (A-CONSTANT 1))		;Offset in buffer array
CHAOS-RCV-INTR-LOOP	;Read two words out of the hardware, then store them
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %CHAOS-READ-BUFFER-OFFSET)))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-TEM1) ADD (M-CONSTANT -1) A-INTR-TEM1)	;Count down word count
	((M-TEM) READ-MEMORY-DATA)		;Save low word
	(JUMP-EQUAL M-ZERO A-INTR-TEM1 CHAOS-RCV-INTR-2)	;If word count was odd
	((VMA-START-READ) VMA)			;Get high word
	(ILLOP-IF-PAGE-FAULT)			;Mustn't bash M-TEM
	((A-INTR-TEM1) ADD (M-CONSTANT -1) A-INTR-TEM1)	;Count down word count
	;If the disk is busy, give it time to get three Xbus cycles after our two
	;Unibus cycles.  Combined with the one Xbus cycle it gets between the
	;two Unibus cycles, this should be enough to keep it from overrunning,
	;although just barely.
	(JUMP-NOT-EQUAL-XCT-NEXT A-DISK-BUSY M-ZERO CHAOS-RCV-INTR-1)
       ((M-T) (A-CONSTANT 16.))			;6.0 microseconds
	;If pdp11 is arbitrating Unibus, also delay, supposedly to make pdp11
	;run faster and prevent other devices such as Arm servo from getting
	;overrun.  Since the code for this that used to be here was a complete
	;no-op, this probably is not important, but do it anyway.
	(JUMP-EQUAL A-INTR-LOCAL-UNIBUS-MODE M-ZERO CHAOS-RCV-INTR-1)
	((M-T) M-ZERO)				;Default delay count (no delay)
CHAOS-RCV-INTR-1
	((WRITE-MEMORY-DATA) DPB READ-MEMORY-DATA (BYTE-FIELD 20 20) A-TEM)
CHAOS-RCV-DELAY
	(JUMP-NOT-EQUAL-XCT-NEXT M-T A-ZERO CHAOS-RCV-DELAY)
       ((M-T) SUB M-T (A-CONSTANT 1))
CHAOS-RCV-INTR-2
	((VMA-START-WRITE) ADD M-A A-INTR-TEM2)	;Write two halfwords into buffer
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(JUMP-LESS-THAN-XCT-NEXT M-ZERO A-INTR-TEM1 CHAOS-RCV-INTR-LOOP)
       ((A-INTR-TEM2) M+A+1 M-ZERO A-INTR-TEM2)
	;; Now save CSR2, enable next receive, and cons onto receive list
	((VMA-START-READ) M-B)			;Get CSR
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) Q-POINTER READ-MEMORY-DATA
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-CSR-2))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) IOR WRITE-MEMORY-DATA
		(A-CONSTANT (BYTE-MASK %%CHAOS-CSR-RECEIVER-CLEAR)))
	((VMA-START-WRITE) M-B)			;Write CSR to clear receiver
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(CALL-XCT-NEXT CHAOS-LIST-PUT)		;Add packet in M-A to receive list
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-RECEIVE-LIST))))
	(JUMP-IF-BIT-CLEAR M-SBS-CHAOS CHAOS-INTR-EXIT)	;Request SB if enabled
	((INTERRUPT-CONTROL) IOR LOCATION-COUNTER (A-CONSTANT 1_26.))
;drops through
;drops in
CHAOS-WAKEUP (MISC-INST-ENTRY %CHAOS-WAKEUP)
	;drops in
;; Here to dismiss the interrupt.  We must decide on the interrupt enables.
;; If there are any free buffers, we can enable receive interrupts.
;; If there are any buffers wanting to be transmitted, we can enable transmit interrupts.
CHAOS-INTR-EXIT
	((M-A) SETZ)				;20 = receive-enable, 40 = transmit-enable
	((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-FREE-LIST))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM A-V-NIL CHAOS-INTR-EXIT-1)
	((M-A) DPB (M-CONSTANT -1) (LISP-BYTE %%CHAOS-CSR-RECEIVE-ENABLE) A-A)
						;Free list not empty, enable receive done
CHAOS-INTR-EXIT-1
	(JUMP-GREATER-THAN M-ZERO A-CHAOS-TRANSMIT-ABORTED
		CHAOS-INTR-EXIT-2)		;Disable transmit-done if in abort-timeout
	((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-TRANSMIT-LIST))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-TEM A-V-NIL CHAOS-INTR-EXIT-2)
	((M-A) DPB (M-CONSTANT -1) (LISP-BYTE %%CHAOS-CSR-TRANSMIT-ENABLE) A-A)
						;Xmt list not empty, enable transmit done
CHAOS-INTR-EXIT-2
	((VMA-START-READ) A-CHAOS-CSR-ADDRESS)	;M-B not valid if called as misc inst
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-TEM) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-A
		(LISP-BYTE %%CHAOS-CSR-INTERRUPT-ENABLES) A-TEM)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(JUMP XFALSE)				;Could be called as misc inst, mustn't popj

;;; Transmit interrupt handler
;;; A-CHAOS-TRANSMIT-RETRY-COUNT is 0 if nothing going on, otherwise number of retries
;;; before we should give up.  Note buffer not removed from list until done.
CHAOS-XMT-INTR
	((VMA-START-READ) M-B)			;Fetch CSR again
	(CHECK-PAGE-READ-NO-INTERRUPT)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%CHAOS-CSR-TRANSMIT-DONE) READ-MEMORY-DATA
		CHAOS-INTR-EXIT)		;Transmit in progress
	(JUMP-EQUAL A-CHAOS-TRANSMIT-RETRY-COUNT M-ZERO CHAOS-XMT-0) ;Jump if transmit idle
	;; Next instruction starts a retransmission if either we have finished delaying
	;; after a transmit abort, or if we get woken up or receive a packet during
	;; a transmit abort delay (this prevents infinite hang if the clock is off and doesn't
	;; sound too unreasonable).
	(JUMP-NOT-EQUAL A-CHAOS-TRANSMIT-ABORTED M-ZERO CHAOS-XMT-0)
	;; Here if a transmission really just completed
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%CHAOS-CSR-TRANSMIT-ABORT) READ-MEMORY-DATA
		CHAOS-XMT-DONE)			;Jump if transmit done and not aborted
	((A-COUNT-CHAOS-TRANSMIT-ABORTS) M+A+1 M-ZERO A-COUNT-CHAOS-TRANSMIT-ABORTS)
	;; If transmit aborted, keep trying until count runs out, then give up
	((A-CHAOS-TRANSMIT-RETRY-COUNT) ADD (M-CONSTANT -1) A-CHAOS-TRANSMIT-RETRY-COUNT)
	(JUMP-EQUAL M-ZERO A-CHAOS-TRANSMIT-RETRY-COUNT CHAOS-XMT-DONE)	;Give up
	(JUMP-XCT-NEXT CHAOS-INTR-EXIT)		;Wait a while, then retransmit
       ((A-CHAOS-TRANSMIT-ABORTED) SETO)

CHAOS-XMT-0
	;; Get current or next transmit packet
	((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-TRANSMIT-LIST))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-CHAOS-TRANSMIT-ABORTED) SETZ)	;Forget this state left from previous packet
	((M-A) Q-TYPED-POINTER READ-MEMORY-DATA) ;Note, don't call CHAOS-LIST-GET
						;since we are leaving it on the list for now
	(JUMP-EQUAL M-A A-V-NIL CHAOS-INTR-EXIT)	;Nothing to transmit, give up
	;; If this is not a retransmission, initialize retry count
	(JUMP-NOT-EQUAL M-ZERO A-CHAOS-TRANSMIT-RETRY-COUNT CHAOS-XMT-1)
	((A-CHAOS-TRANSMIT-RETRY-COUNT) (A-CONSTANT CHAOS-NUMBER-TRANSMIT-RETRIES))
CHAOS-XMT-1
	((VMA-START-READ) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-WORD-COUNT))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-TEM2) (A-CONSTANT 1))		;Offset in buffer
	((A-INTR-TEM1) Q-POINTER READ-MEMORY-DATA)	;Halfword count
CHAOS-XMT-2
	((VMA-START-READ) ADD M-A A-INTR-TEM2)	;Get a pair of halfwords
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((A-INTR-TEM1) ADD (M-CONSTANT -1) A-INTR-TEM1)	;Count down word count
	;See comments in receive loop above
	(JUMP-NOT-EQUAL-XCT-NEXT A-DISK-BUSY M-ZERO CHAOS-XMT-4)
       ((M-T) (A-CONSTANT 16.))			;6.0 microseconds
	(JUMP-EQUAL A-INTR-LOCAL-UNIBUS-MODE M-ZERO CHAOS-XMT-4)
	((M-T) M-ZERO)				;Default delay count (no delay)
CHAOS-XMT-4
	((WRITE-MEMORY-DATA) READ-MEMORY-DATA)	;Write first halfword into hardware
CHAOS-XMT-DELAY
	(JUMP-NOT-EQUAL-XCT-NEXT M-T A-ZERO CHAOS-XMT-DELAY)
       ((M-T) SUB M-T (A-CONSTANT 1))
	((VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %CHAOS-WRITE-BUFFER-OFFSET)))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(JUMP-EQUAL M-ZERO A-INTR-TEM1 CHAOS-XMT-3)	;Done if was odd number of words
	((WRITE-MEMORY-DATA-START-WRITE) (BYTE-FIELD 20 20) WRITE-MEMORY-DATA)
	(CHECK-PAGE-WRITE-NO-INTERRUPT)		;Write second halfword into hardware
	((A-INTR-TEM1) ADD (M-CONSTANT -1) A-INTR-TEM1)	;Count down word count
	(JUMP-LESS-THAN-XCT-NEXT M-ZERO A-INTR-TEM1 CHAOS-XMT-2)
       ((A-INTR-TEM2) M+A+1 M-ZERO A-INTR-TEM2)
CHAOS-XMT-3
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %CHAOS-START-TRANSMIT-OFFSET)))
	(CHECK-PAGE-READ-NO-INTERRUPT)		;Initiate transmission
	(JUMP CHAOS-INTR-EXIT)

;; Here when we are through with a transmit packet.
CHAOS-XMT-DONE
	(CALL-XCT-NEXT CHAOS-LIST-GET)		;Pull this guy off xmt list, we're done with it
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-TRANSMIT-LIST))))
	(CALL-NOT-EQUAL-XCT-NEXT M-A A-V-NIL CHAOS-LIST-PUT)	;Add to free list
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-CHAOS-FREE-LIST))))
	(JUMP-XCT-NEXT CHAOS-XMT-0)		;Now transmit more if possible
       ((A-CHAOS-TRANSMIT-RETRY-COUNT) SETZ)	;Transmit not in progress now

;;; Take packet off list which has been VMA-START-READ, return it in M-A
;;; M-A can return with NIL in it.  Uses A-INTR-TEM1
CHAOS-LIST-GET
	(CHECK-PAGE-READ-NO-INTERRUPT)		;MD gets first buffer on list
	((A-INTR-TEM1) VMA)			;Save address of list header
	((M-A) Q-TYPED-POINTER READ-MEMORY-DATA)
	(POPJ-EQUAL M-A A-V-NIL)		;Return if list empty
	((VMA-START-READ) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-THREAD))))
	(CHECK-PAGE-READ-NO-INTERRUPT)		;MD gets next buffer on list
	((WRITE-MEMORY-DATA) Q-TYPED-POINTER READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-INTR-TEM1)
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

;;; Put packet in M-A onto list which has been VMA-START-READ
;;; Uses A-INTR-TEM1
CHAOS-LIST-PUT
	(CHECK-PAGE-READ-NO-INTERRUPT)		;MD gets present first buffer on list
	((A-INTR-TEM1) VMA)			;Save address of list header
	((WRITE-MEMORY-DATA) Q-TYPED-POINTER READ-MEMORY-DATA)	;Thread onto new first buffer
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %CHAOS-LEADER-THREAD))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) Q-TYPED-POINTER M-A)	;Change list header
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-INTR-TEM1)
       (CHECK-PAGE-WRITE-NO-INTERRUPT)



;;; Ethernet microcode

;;; Additions to DEFMIC
;  (defmic %ether-wakeup 711 (reset-p) t)
;  (defmic %checksum-pup 712 (art-16b-pup start length) t)
;  (defmic %decode-pup 713 (art-byte-pup start length state super-image-p) t)
	

(ASSIGN ETHER-MAX-RETRANSMITS 16.)		;Max times the u-code tries to retransmit
(ASSIGN ETHER-OUTPUT-CSR-ENABLES 101)		;These are not changeable
(ASSIGN UNIBUS-MAP-VIRTUAL-BASE-ADDRESS 77773060)	;Base of the unibus map
(DEF-DATA-FIELD UNIBUS-MAP-BLOCK 4. 10.)	;Map block address in unibus address

(LOCALITY A-MEM)
A-CURRENT-ETHER-RCV-PACKET			;Current packet being received (no data-type)
	((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)	;ie NIL
A-ETHER-REGISTER-BASE		(77772100)	;Virtual address of ether net base
A-ETHER-INPUT-CSR-ENABLES	(101)		;Input csr enables initially non-promiscuous
(LOCALITY I-MEM)

;;; Ether net driver
;;; Note that we use M-SBS-CHAOS to enable Ether sequence breaks
;;; Questions: What about lack of room in SYS-COM area?  What about transmission completion?

ETHER-RCV-DONE
	((M-B) A-ETHER-REGISTER-BASE)
	((M-A) A-CURRENT-ETHER-RCV-PACKET)
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %ETHER-INPUT-CSR-OFFSET)))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	;; Save CSR into packet
	((WRITE-MEMORY-DATA) Q-POINTER READ-MEMORY-DATA
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %ETHER-LEADER-CSR))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 15.) READ-MEMORY-DATA
		ETHER-RCV-RET)		;Error on the receive, just return packet
	;; Save active length
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %ETHER-INPUT-WORD-COUNT-OFFSET)))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((MD) SUB READ-MEMORY-DATA
		(A-CONSTANT (EVAL (LOGAND 1777 (- ETHER-MAXIMUM-PACKET-LENGTH)))))
	((WRITE-MEMORY-DATA) Q-POINTER MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %ETHER-LEADER-ACTIVE-LENGTH))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; Install on Receive list
ETHER-RCV-RET
	(CALL-XCT-NEXT ETHER-LIST-PUT)
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-ETHER-RECEIVE-LIST))))
	(JUMP-IF-BIT-CLEAR-XCT-NEXT M-SBS-CHAOS ETHER-RCV-NEW-PACKET)	;SB enabled?
       ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC UB-INTR-RET)))
	((INTERRUPT-CONTROL) IOR LOCATION-COUNTER (A-CONSTANT 1_26.))	;request SB
	;; Drops through to reenable the interface

ETHER-RCV-NEW-PACKET
	(CALL-XCT-NEXT ETHER-LIST-GET)
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-ETHER-FREE-LIST))))
	((A-CURRENT-ETHER-RCV-PACKET) M-A)
	(JUMP-EQUAL M-A A-V-NIL ETHER-NO-FREE-PACKETS)
	((M-A) ADD M-A (A-CONSTANT 1))
	(CALL-XCT-NEXT ETHER-MAP-PACKET)	;Map in this packet
       ((M-B) (A-CONSTANT (EVAL ETHER-UNIBUS-BLOCK)))
	((VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-INPUT-BUFFER-POINTER-OFFSET)))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) (A-CONSTANT (EVAL (- ETHER-MAXIMUM-PACKET-LENGTH))))
	((VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-INPUT-WORD-COUNT-OFFSET)))	
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) A-ETHER-INPUT-CSR-ENABLES)
	(POPJ-AFTER-NEXT
		(VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-INPUT-CSR-OFFSET)))
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

ETHER-NO-FREE-PACKETS
	((WRITE-MEMORY-DATA) SETZ)
	((M-B) A-ETHER-REGISTER-BASE)
	(POPJ-AFTER-NEXT
		(VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-INPUT-CSR-OFFSET)))
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

;;; Currently transmitting packet got a collision
ETHER-COLLISION
	((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-ETHER-TRANSMIT-LIST))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-A) READ-MEMORY-DATA)		;Current packet
	((VMA-START-READ) SUB M-A (A-CONSTANT (EVAL (+ 2 %ETHER-LEADER-TRANSMIT-COUNT))))
	(CHECK-PAGE-READ-NO-INTERRUPT)		;Get the number of retransmit times
	(JUMP-GREATER-THAN READ-MEMORY-DATA (A-CONSTANT ETHER-MAX-RETRANSMITS)
			ETHER-XMIT-DONE)	;Punt
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC UB-INTR-RET)))
	((M-B) READ-MEMORY-DATA)
	((WRITE-MEMORY-DATA-START-WRITE) ADD READ-MEMORY-DATA (A-CONSTANT 1))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;; here number of retries is in M-B
	((VMA-START-READ) (A-CONSTANT 77772050))	;Pick up u-sec clock
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((OA-REG-LOW) DPB M-B OAL-BYTL-1 A-ZERO)	;Pick up n bottom bits of it
	((WRITE-MEMORY-DATA) BYTE-INST READ-MEMORY-DATA A-ZERO)
	((VMA) A-ETHER-REGISTER-BASE)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT (EVAL %ETHER-OUTPUT-DELAY-OFFSET)))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)		;Set the delay to that
	((M-A) ADD M-A (A-CONSTANT 1))
	((M-B) (A-CONSTANT (EVAL ETHER-UNIBUS-BLOCK)))	;Use receive map
	(JUMP-XCT-NEXT ETHER-XMIT-PACKET)	;Retransmit packet
       (CALL ETHER-ADDRESS-PACKET)		;But first calculate the address

ETHER-XMIT-DONE
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC UB-INTR-RET)))
	(CALL-XCT-NEXT ETHER-LIST-GET)		;Read output packet
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-ETHER-TRANSMIT-LIST))))
	((M-B) Q-TYPED-POINTER M-A)
	(JUMP-EQUAL M-B A-V-NIL ETHER-NO-XMIT)
	(CALL-XCT-NEXT ETHER-LIST-PUT)
       ((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-ETHER-FREE-LIST))))	;Free packet
	(JUMP-IF-BIT-CLEAR M-SBS-CHAOS ETHER-XMIT-NEW-PACKET)		;SB enabled?
	((INTERRUPT-CONTROL) IOR LOCATION-COUNTER (A-CONSTANT 1_26.))	;request SB

;;; Sets up the next packet transfer
ETHER-XMIT-NEW-PACKET
	((VMA-START-READ) (A-CONSTANT (EVAL (+ 400 %SYS-COM-ETHER-TRANSMIT-LIST))))
	(CHECK-PAGE-READ-NO-INTERRUPT)		;Read output packet
	((M-A) Q-TYPED-POINTER READ-MEMORY-DATA)
	(JUMP-EQUAL M-A A-V-NIL ETHER-NO-XMIT)	;No packet available
	((M-A) ADD M-A (A-CONSTANT 1))		;Get pointer to data word
	(CALL-XCT-NEXT ETHER-MAP-PACKET)
       ((M-B) (A-CONSTANT (EVAL (+ ETHER-UNIBUS-BLOCK 2))))	;Transmit is next blocks
;;; Here packet is setup and addressed by map. MD is the unibus address of it
ETHER-XMIT-PACKET
	((VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-OUTPUT-BUFFER-POINTER-OFFSET)))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((VMA-START-READ) SUB M-A (A-CONSTANT (EVAL (+ 3 %ETHER-LEADER-ACTIVE-LENGTH))))
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((M-A) Q-POINTER READ-MEMORY-DATA A-ZERO)
	((WRITE-MEMORY-DATA) SUB M-ZERO A-A)
	((VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-OUTPUT-WORD-COUNT-OFFSET)))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) (A-CONSTANT ETHER-OUTPUT-CSR-ENABLES))
	(POPJ-AFTER-NEXT
		(VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-OUTPUT-CSR-OFFSET)))
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

ETHER-NO-XMIT
	((WRITE-MEMORY-DATA) SETZ)
	((M-B) A-ETHER-REGISTER-BASE)
	(POPJ-AFTER-NEXT
		(VMA-START-WRITE) ADD M-B (A-CONSTANT (EVAL %ETHER-OUTPUT-CSR-OFFSET)))
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

;;; M-A is the page to address, M-B is the unibus block to use
;;; Returns with MD full with the appropriate unibus address to
;;; address the buffer, and M-B points to the ether register base
ETHER-MAP-PACKET
	((VMA-START-READ) M-A)				;Look up physical address
	(CHECK-PAGE-READ-NO-INTERRUPT)
	((MD) VMA)
	((WRITE-MEMORY-DATA) MAP-PHYSICAL-PAGE-NUMBER	;UNIBUS map enable word
		MEMORY-MAP-DATA (A-CONSTANT 140000))
	((VMA-START-WRITE) ADD M-B (A-CONSTANT UNIBUS-MAP-VIRTUAL-BASE-ADDRESS))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	;((WRITE-MEMORY-DATA) ADD MD (A-CONSTANT 1))	;--- this has to be wrong ---
	((WRITE-MEMORY-DATA) A-ZERO)			;disable next map, see what happens
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))	;Next page
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
ETHER-ADDRESS-PACKET
	((M-B) DPB M-B UNIBUS-MAP-BLOCK (A-CONSTANT 140000))	;Set the page number
	(POPJ-AFTER-NEXT			;Fill in page offset
		(WRITE-MEMORY-DATA) DPB M-A (BYTE-FIELD 8. 2) A-B)
       ((M-B) A-ETHER-REGISTER-BASE)	;Restore this for fun

ETHER-WAKEUP (MISC-INST-ENTRY %ETHER-WAKEUP)
;This version that takes an argument works due to the following convoluted reasons:
;Usual (easy) case: arg=NIL, so first call doesn't happen, second call is comparing
;to M-A=NIL (instead of A-V-NIL) so it works as before.  Reset-P case: arg is non-NIL
;so first call happens.  Usually this finds a packet, sets A-CURRENT-ETHER-RCV-PACKET
;and increments M-A.  Thus they are not equal and the second call does not happen.
;If it doesn't find a packet both are NIL.  This causes the second call to happen,
;but since the first call didn't do much it is unlikely to have any effect anyway.
	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;get reset-p arg
	(CALL-NOT-EQUAL M-A A-V-NIL ETHER-RCV-NEW-PACKET)	;enable reception if resetting
	(CALL-EQUAL M-A A-CURRENT-ETHER-RCV-PACKET ETHER-RCV-NEW-PACKET) ;or need packet
	((M-B) A-ETHER-REGISTER-BASE)		; Now enable output side
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %ETHER-OUTPUT-CSR-OFFSET)))
	(CHECK-PAGE-READ-NO-INTERRUPT)		;Cant allow interrupts
	(CALL-IF-BIT-CLEAR (BYTE-FIELD 1 6) READ-MEMORY-DATA
		ETHER-XMIT-NEW-PACKET)		;Interrupts off, so try to send new packet
	(JUMP XFALSE)

;;; Take packet off list which has been VMA-START-READ, return it in M-A
;;; M-A can return with NIL in it.  Uses A-INTR-TEM1
ETHER-LIST-GET
	(CHECK-PAGE-READ-NO-INTERRUPT)		;MD gets first buffer on list
	((A-INTR-TEM1) VMA)			;Save address of list header
	((M-A) Q-TYPED-POINTER READ-MEMORY-DATA)
	(POPJ-EQUAL M-A A-V-NIL)		;Return if list empty
	((VMA-START-READ) SUB M-A (A-CONSTANT (EVAL (+ 2 %ETHER-LEADER-THREAD))))
	(CHECK-PAGE-READ-NO-INTERRUPT)		;MD gets next buffer on list
	((WRITE-MEMORY-DATA) Q-TYPED-POINTER READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-INTR-TEM1)
       (CHECK-PAGE-WRITE-NO-INTERRUPT)

;;; Put packet in M-A onto list which has been VMA-START-READ
;;; Uses A-INTR-TEM1
ETHER-LIST-PUT
	(CHECK-PAGE-READ-NO-INTERRUPT)		;MD gets present first buffer on list
	((A-INTR-TEM1) VMA)			;Save address of list header
	((WRITE-MEMORY-DATA) Q-TYPED-POINTER READ-MEMORY-DATA)	;Thread onto new first buffer
	((VMA-START-WRITE) SUB M-A (A-CONSTANT (EVAL (+ 2 %ETHER-LEADER-THREAD))))
	(CHECK-PAGE-WRITE-NO-INTERRUPT)
	((WRITE-MEMORY-DATA) Q-TYPED-POINTER M-A)	;Change list header
	(POPJ-AFTER-NEXT (VMA-START-WRITE) A-INTR-TEM1)
       (CHECK-PAGE-WRITE-NO-INTERRUPT)


;UCODE-AR-1-SETUP prepares an array for microcode access.  The first argument gives the
;array, the second the starting element and the third argument the number of elements.
;This calls the system microcode, which may have side-effects.  The following are returned:
; M-A the array, M-E base address, VMA word address, M-Q first index, M-K last index,
; M-D first dimension, M-S product of dimensions, M-B array header, M-T first element of array
; Preserves: M-C, M-I, M-R, M-ZR (if the system microcode does!).
;
UCODE-AR-1-SETUP
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL UCODE-AR-1-SETUP)	;bless number of elements
	((M-TEM) SUB C-PDL-BUFFER-POINTER-POP (A-CONSTANT 1))	;M-TEM: first-last offset
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL UCODE-AR-1-SETUP)	;bless first element
        ((M-K) ADD C-PDL-BUFFER-POINTER A-TEM)			;add first to get last
	((C-PDL-BUFFER-POINTER)					;Store last index
		Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-XCT-NEXT XAR1)
       ((M-K) SUB M-K A-TEM)					;Reconstruct first index
   (ERROR-TABLE CALLS-SUB UCODE-AR-1-SETUP)
	((C-PDL-BUFFER-POINTER-PUSH) M-A)			;repush array
	((C-PDL-BUFFER-POINTER-PUSH) M-K)			;push saved first
	(JUMP-XCT-NEXT XAR1)					;"call" AR-1 for first index
       ((M-K) M-Q)						;save index to last word

;ETH-CHECKSUM-PUP checksums a segment of an ART-16B.  The first argument gives the array,
;the second the starting element and the third argument gives the number of elements.
;Example:  (defun fast-checksum-pup (epkt &aux (n (lsh (1- (pup-length epkt)) -1)))
;	     (values (%checksum-pup epkt 2 n) (+ 2 n)))
;
;This is the original Lisp (attributed to MOON).
;Note ucode takes args to specify position in ART-16B.
; (DEFUN CHECKSUM-PUP (EPKT)
;      (DO ((I 2. (1+ I))
;	   (CK 0)
;	   (N (LSH (1- (PUP-LENGTH EPKT)) -1) (1- N)))
;	  ((ZEROP N)
;	   (AND (= CK 177777) (SETQ CK 0))	;Gronk minus zero
;	   (RETURN CK I))			;Return checksum and index in PUP of cksm
;	(SETQ CK (+ CK (AREF EPKT I)))		;1's complement add
;	(AND (BIT-TEST 200000 CK) (SETQ CK (LDB 0020 (1+ CK))))
;	(SETQ CK (DPB CK 0117 (LDB 1701 CK)))))	;16-bit left rotate
;
ETH-CHECKSUM-PUP	(MISC-INST-ENTRY %CHECKSUM-PUP)
   (ERROR-TABLE RESTART ETH-CHECKSUM-PUP)
	(CALL UCODE-AR-1-SETUP)					;set up for array access
   (ERROR-TABLE CALLS-SUB ETH-CHECKSUM-PUP)
	((M-TEM) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B)		;trap if not 16B
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL (LSH ART-16B ARRAY-TYPE-SHIFT))) TRAP)
   (ERROR-TABLE ARGTYP ART-16B M-A 0 ETH-CHECKSUM-PUP %CHECKSUM-PUP)
	((M-1) DPB M-T (BYTE-FIELD 20 20) A-ZERO)		;init M-1 as tho for odd index
	(JUMP-IF-BIT-CLEAR-XCT-NEXT
	  M-Q (BYTE-FIELD 1 0) ETH-CHECKSUM-PUP-EVEN)		;jump if starting even index
       ((M-T) SETZ) 					        ;zero running checksum
;We now ping-pong between the even and odd indices.
;M-1 = 32B memory data, M-T = running checksum
;M-Q = current array index, M-K = final array index
;M-Q is right shifted one place when used to index off of M-E, the array base memory address.
ETH-CHECKSUM-PUP-ODD		;data has been read from the array, use hi order 16 bits
	(JUMP-GREATER-THAN-XCT-NEXT M-Q A-K ETH-CHECKSUM-PUP-EXIT)	;end test
       ((A-TEM1) (BYTE-FIELD 20 20) M-1)    			;checksum left half  
	((M-T) ADD M-T A-TEM1)					;16B two's complement sum
	((A-TEM1) (BYTE-FIELD 1 20) M-T)			;A-TEM1 gets 16B "overflow"
	((M-T) OUTPUT-SELECTOR-LEFTSHIFT-1 ADD M-T A-TEM1)	;end-around carry, M-T gets
								;1's comp sum left shifted
								;lsb gets "don't care" from Q
	((A-TEM1) (BYTE-FIELD 1 20) M-T)			;A-TEM1 gets msb of 1's comp
        ((M-T) SELECTIVE-DEPOSIT M-T (BYTE-FIELD 17 1) A-TEM1)	;M-T gets rotated 16B 1's comp
	((M-Q) ADD M-Q (A-CONSTANT 1))				;increment index
ETH-CHECKSUM-PUP-EVEN		;read data from array, use lo order 16 bits
	(JUMP-GREATER-THAN-XCT-NEXT M-Q A-K ETH-CHECKSUM-PUP-EXIT)	;end test
       ((A-TEM1) (BYTE-FIELD 27 1) M-Q)				;A-TEM1 gets word-wise index
	((VMA-START-READ) ADD M-E A-TEM1)			;M-1 gets entire data word
	(CHECK-PAGE-READ)
	((M-1) READ-MEMORY-DATA)
        ((A-TEM1) (BYTE-FIELD 20 0) M-1)  			;checksum right half
	((M-T) ADD M-T A-TEM1)					;16B two's complement sum
	((A-TEM1) (BYTE-FIELD 1 20) M-T)			;A-TEM1 gets 16B "overflow"
	((M-T) OUTPUT-SELECTOR-LEFTSHIFT-1 ADD M-T A-TEM1)	;end-around carry, M-T gets
								;1's comp sum left shifted
								;lsb gets "don't care" from Q
	((A-TEM1) (BYTE-FIELD 1 20) M-T)			;A-TEM1 gets msb of 1's comp
        ((M-T) SELECTIVE-DEPOSIT M-T (BYTE-FIELD 17 1) A-TEM1)	;M-T gets rotated 16B 1's comp
	(JUMP-XCT-NEXT ETH-CHECKSUM-PUP-ODD)			;loop
       ((M-Q) ADD M-Q (A-CONSTANT 1))				;increment index
ETH-CHECKSUM-PUP-EXIT						;return  M-T = PUP checksum
	(POPJ-NOT-EQUAL-XCT-NEXT M-T (A-CONSTANT 177777))	;test for 16B minus zero
       ((M-T) DPB M-T Q-POINTER					;return fixnum
		(A-CONSTANT (BYTE-VALUE %%Q-DATA-TYPE DTP-FIX)))
	(POPJ-AFTER-NEXT (M-T) DPB M-ZERO Q-POINTER		;return plus zero crock
		(A-CONSTANT (BYTE-VALUE %%Q-DATA-TYPE DTP-FIX)))
       (NO-OP)

;ETH-DECODE-PUP decodes a segment of an array of bytes.  The first argument gives the
;array, the second the starting byte and the third argument gives the number of bytes.
;The fourth argument is an initial state and the fifth if non-nil indicates super-image
;style decoding.  The routine returns a fixnum: the lowest two bits give the final state
;and the remaining bits give the number of decoded bytes.  This is never greater than
;the third argument.  The bytes are decoded in-place, munging the original pup.  The
;initial state should be 0 on the first call, and subsequently should be the final state
;returned from the previous call.  The possible states are:
;	0 - normal decoding
;	1 - return seen (gobbles subsequent line feeds)
;	2 - rubout prefix seen (controls 200 bit of subsequent character)
;[It is expected that this misc instruction will be nicely packaged in macrocode to do
;such things as make a displaced ART-8B into the actual PUP (which is 16B), set its
;length to the number of decoded bytes and return only the final state.  Also sanitize
;input (eg ignore null strings) before this routine sees it.]  Example:
;(defun decode-pup-string (pup-string &optional (state 0) super-image-p)
;  (if (< (string-length pup-string) 1) state	;null strings are no-ops
;      (setq state
;	     (%decode-pup pup-string 0 (array-active-length pup-string) state super-image-p))
;      (store-array-leader (%logldb 0226 state) pup-string 0)	;set new length
;      (%logldb 0002 state)))					;return new state

;The ordering of bytes in a PUP has different "sex" than in a string.  Hence:
(DEF-DATA-FIELD PUP-BYTE-0 10 10)		;first byte in incoming word
(DEF-DATA-FIELD PUP-BYTE-1 10 0)		;second byte in incoming word
(DEF-DATA-FIELD PUP-BYTE-2 10 30)		;third byte in incoming word
(DEF-DATA-FIELD PUP-BYTE-3 10 20)		;last byte in incoming word
;Don't you think these are decorative?
(DEF-DATA-FIELD STRING-BYTE-0 10 0)		;first byte in outgoing word
(DEF-DATA-FIELD STRING-BYTE-1 10 10)		;second byte in outgoing word
(DEF-DATA-FIELD STRING-BYTE-2 10 20)		;third byte in outgoing word
(DEF-DATA-FIELD STRING-BYTE-3 10 30)		;last byte in outgoing word

(DEF-DATA-FIELD 200BIT 1 7)			;msb of byte, & object of unseemly fascination

;Dispatch tables
(LOCALITY D-MEM)	

(START-DISPATCH 2 P-BIT)			;CALL-XCT-NEXT
D-ETH-DECODE-PUP-WRITE				;write appropriate byte in output
	(ETH-DECODE-PUP-WRITE-BYTE-0)
	(ETH-DECODE-PUP-WRITE-BYTE-1)
	(ETH-DECODE-PUP-WRITE-BYTE-2)
	(ETH-DECODE-PUP-WRITE-BYTE-3)
(END-DISPATCH)	

(START-DISPATCH 3)				;JUMP-XCT-NEXT
D-ETH-DECODE-PUP-BYTE				;handle characters 10 to 17
	(ETH-DECODE-PUP-TOGGLE)			;10
	(ETH-DECODE-PUP-TOGGLE)			;11
	(ETH-DECODE-PUP-12 INHIBIT-XCT-NEXT-BIT);12 - inhibits clearing gobble bit
	(P-BIT R-BIT)				;13 - vanilla fall-through
	(ETH-DECODE-PUP-TOGGLE)			;14
	(ETH-DECODE-PUP-15)			;15
	(P-BIT R-BIT)				;16 - vanilla fall-through
	(P-BIT R-BIT)				;17 - vanilla fall-through
(END-DISPATCH)

(LOCALITY I-MEM)
	
;Register usage:
;	M-R	super-image-p argument
;	M-C	internal state: 0=normal, 1=gobble, 200=prefix seen
;		(the 200 bit is frobbed internally while handling the byte)
;	M-I	initial byte index (for length calculation)
;	M-Q	input byte index
;	M-T	output byte index
;	M-1	input word data
;	M-2	output word data
;	M-3	current byte
;M-4, A-TEM1 are temps, other registers are as UCODE-AR-1-SETUP deigns
;
ETH-DECODE-PUP	(MISC-INST-ENTRY %DECODE-PUP)
   (ERROR-TABLE RESTART ETH-DECODE-PUP)
	((M-R) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)	;get super-image-p arg
 	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 3 ETH-DECODE-PUP %DECODE-PUP)	;bless initial state
        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)	;get external format initial state
	(CALL-GREATER-THAN M-C (A-CONSTANT 2) TRAP)	;impossible state
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 1) M-C ETH-DECODE-PUP-SETUP)
	((M-C) (A-CONSTANT 200))		;create internal format for prefix case
ETH-DECODE-PUP-SETUP
	(CALL UCODE-AR-1-SETUP)
   (ERROR-TABLE CALLS-SUB ETH-DECODE-PUP)
	((M-T) M-Q)				;initialize output index at input index
	((M-I) M-Q)				;M-I gets inital index
	((A-TEM1) (BYTE-FIELD 26 2) M-I)	;read in initial word
	((VMA-START-READ) ADD M-E A-TEM1)
	(CHECK-PAGE-READ)
	;punt if there isn't anything to do -- we CALL because exit code pops microstack
	(CALL-GREATER-THAN-XCT-NEXT M-Q A-K ETH-DECODE-PUP-EXIT)
       ((M-2) READ-MEMORY-DATA)			;if M-Q mod 4  0 must restore initial word
	((M-4) (BYTE-FIELD 2 0) M-Q)		;M-4 gets initial read phase to "dispatch" on
	(JUMP-EQUAL-XCT-NEXT M-4 (A-CONSTANT 0) ETH-DECODE-PUP-INITIAL-BYTE-0)	;phase=0
       ((M-1) M-2)				;also setup input register with initial word
	(JUMP-EQUAL M-4 (A-CONSTANT 2) ETH-DECODE-PUP-READ-BYTE-2)	;phase=2 (most likely)
	(JUMP-EQUAL M-4 (A-CONSTANT 1) ETH-DECODE-PUP-READ-BYTE-1)	;phase=1
	(JUMP-EQUAL M-4 (A-CONSTANT 3) ETH-DECODE-PUP-READ-BYTE-3)	;phase=3
;here we're all ready to go -- we loop, sucessively decoding each of the 4 bytes in the word
ETH-DECODE-PUP-READ-BYTE-0
	((A-TEM1) (BYTE-FIELD 26 2) M-Q)	;read in word
	((VMA-START-READ) ADD M-E A-TEM1)
	(CHECK-PAGE-READ)
	((M-1) READ-MEMORY-DATA)
ETH-DECODE-PUP-INITIAL-BYTE-0			;label for first-word-already-read-in bum
	(CALL-XCT-NEXT ETH-DECODE-PUP-BYTE)
       ((M-3) PUP-BYTE-0 M-1)
ETH-DECODE-PUP-READ-BYTE-1
	(CALL-XCT-NEXT ETH-DECODE-PUP-BYTE)
       ((M-3) PUP-BYTE-1 M-1)
ETH-DECODE-PUP-READ-BYTE-2
	(CALL-XCT-NEXT ETH-DECODE-PUP-BYTE)
       ((M-3) PUP-BYTE-2 M-1)
ETH-DECODE-PUP-READ-BYTE-3
	((MICRO-STACK-DATA-PUSH)
		(A-CONSTANT (I-MEM-LOC ETH-DECODE-PUP-READ-BYTE-0)))	;hack return address
	((M-3) PUP-BYTE-3 M-1)						;and just fall thru...
;This gets called to handle each byte and then increment the read pointer M-Q.  If we're
;done, instead of returning, we enter the exit sequence (hence we must pop ustack then).
ETH-DECODE-PUP-BYTE
	(JUMP-EQUAL M-3 (A-CONSTANT 177) ETH-DECODE-PUP-177)		;prefix char
	(JUMP-GREATER-THAN M-3 (A-CONSTANT 17) ETH-DECODE-PUP-VANILLA)	;vanilla char
	(JUMP-LESS-THAN M-3 (A-CONSTANT 10) ETH-DECODE-PUP-VANILLA)	;french vanilla char
	(DISPATCH-XCT-NEXT (BYTE-FIELD 3 0) M-3 D-ETH-DECODE-PUP-BYTE)
;this is the main sequence for most chars, special cases join in at various points	
ETH-DECODE-PUP-VANILLA				;usual thing to do
       ((M-C) DPB M-ZERO (BYTE-FIELD 1 0) A-C)	;clear gobble bit (on LFs this get inhibited)
ETH-DECODE-PUP-BUILD-CHAR			;the Charles Atlas way
	((M-3) SELECTIVE-DEPOSIT M-C 200BIT A-3)	;deposit 200 bit into char
ETH-DECODE-PUP-WRITE-CHAR			;output the thing
	(DISPATCH-CALL-XCT-NEXT (BYTE-FIELD 2 0) M-T D-ETH-DECODE-PUP-WRITE)
       ((M-C) DPB M-ZERO 200BIT A-C)		;clear the 200 bit in state
;paths for all characters rejoin main sequence here	
ETH-DECODE-PUP-BYTE-TAIL			;*ouch*
	(POPJ-NOT-EQUAL-XCT-NEXT M-Q A-K)	;return to main loop if haven't read last byte
       ((M-Q) ADD M-Q (A-CONSTANT 1))		;increment input index
ETH-DECODE-PUP-EXIT				;all done...
	((M-4) (BYTE-FIELD 2 0) M-T)		;set M-4 to phase of write
	(JUMP-EQUAL-XCT-NEXT M-4 (A-CONSTANT 0) ETH-DECODE-PUP-RETURN-COUNT)	;phase=0: noop
       ((M-GARBAGE) MICRO-STACK-POINTER-POP)	;also clean up pending call on ustack
;this is to flush out bytes in M-2 that haven't been written into memory yet -- we try
;to minimally trash the word (up to 16B boundry anyway, odd bytes CAN'T work correctly)
	(JUMP-EQUAL-XCT-NEXT M-4 (A-CONSTANT 3)
		ETH-DECODE-PUP-WRITE-LAST-WORD)	;if phase=3 we just dump M-2
       ((A-TEM1) (BYTE-FIELD 26 2) M-T)		;for phase=1 or 2: read word at current index
	((VMA-START-READ) ADD M-E A-TEM1)
	(CHECK-PAGE-READ)
	((M-2) SELECTIVE-DEPOSIT READ-MEMORY-DATA (BYTE-FIELD 20 20) A-2)	;fix left half
ETH-DECODE-PUP-WRITE-LAST-WORD
	((WRITE-MEMORY-DATA) M-2)		;write out last few bytes in M-2
	((A-TEM1) (BYTE-FIELD 26 2) M-T)
	((VMA-START-WRITE) ADD M-E A-TEM1)
	(CHECK-PAGE-WRITE)
ETH-DECODE-PUP-RETURN-COUNT
;return number of bytes lsh 2, with state (in external format) in least significant bits
	((M-T) SUB M-T A-I)			;length (M-T= final, M-I= initial index)
	((M-T) DPB M-T (BYTE-FIELD 26 2)	;lsh 2, and make fixnum
		(A-CONSTANT (BYTE-VALUE %%Q-DATA-TYPE DTP-FIX)))
	(POPJ-IF-BIT-CLEAR-XCT-NEXT M-C 200BIT)	;non-prefix cases exit
       ((M-T) DPB M-C (BYTE-FIELD 2 0) A-T)	;set state field for normal/gobble cases
	(POPJ-AFTER-NEXT (M-T) DPB M-MINUS-ONE (BYTE-FIELD 1 1) A-T)	;prefix case
       (NO-OP)
;this is the code dispatched into for the really special-case characters
ETH-DECODE-PUP-12				;line feed (falls thru to TOGGLE usually)
	(JUMP-IF-BIT-SET M-C (BYTE-FIELD 1 0) ETH-DECODE-PUP-BYTE-TAIL)	;ignore if gobbling
ETH-DECODE-PUP-TOGGLE				;toggle 200 bit first
	(JUMP-XCT-NEXT ETH-DECODE-PUP-BUILD-CHAR)
       ((M-C) XOR M-C (A-CONSTANT 200))		;toggle 200 bit
ETH-DECODE-PUP-15				;carriage return
	(JUMP-XCT-NEXT ETH-DECODE-PUP-TOGGLE)
       ((M-C) DPB M-MINUS-ONE (BYTE-FIELD 1 0) A-C)	;set gobble bit
ETH-DECODE-PUP-177				;prefix
	(JUMP-IF-BIT-SET-XCT-NEXT M-C 200BIT ETH-DECODE-PUP-WRITE-CHAR)	;prefixxed prefix
       ((M-C) DPB M-ZERO (BYTE-FIELD 1 0) A-C)	;clear gobble bit
	(JUMP-NOT-EQUAL M-R A-V-NIL ETH-DECODE-PUP-WRITE-CHAR)	;super-image mode
	(JUMP-XCT-NEXT ETH-DECODE-PUP-BYTE-TAIL)
       ((M-C) DPB M-MINUS-ONE 200BIT A-C)		;set 200 bit
;dispatch here to handle the various output phases
ETH-DECODE-PUP-WRITE-BYTE-0
	(POPJ-AFTER-NEXT (M-2) DPB M-3 STRING-BYTE-0 A-2)
       ((M-T) ADD M-T (A-CONSTANT 1))
ETH-DECODE-PUP-WRITE-BYTE-1
	(POPJ-AFTER-NEXT (M-2) DPB M-3 STRING-BYTE-1 A-2)
       ((M-T) ADD M-T (A-CONSTANT 1))
ETH-DECODE-PUP-WRITE-BYTE-2
	(POPJ-AFTER-NEXT (M-2) DPB M-3 STRING-BYTE-2 A-2)
       ((M-T) ADD M-T (A-CONSTANT 1))
ETH-DECODE-PUP-WRITE-BYTE-3			;this is the last byte, so write the word
	((WRITE-MEMORY-DATA) DPB M-3 STRING-BYTE-3 A-2)
	((A-TEM1) (BYTE-FIELD 26 2) M-T)
	((VMA-START-WRITE) ADD M-E A-TEM1)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT (M-T) ADD M-T (A-CONSTANT 1))
       (NO-OP)

;PDL-BUFFER LOADING CONVENTIONS:
;   1. THE CURRENT RUNNING FRAME IS ALWAYS COMPLETELY CONTAINED WITHIN THE PDL-BUFFER.
;   2. SO IS ITS CALLING ADI (LOCATED IMMEDIATELY BEFORE IT ON PDL).
;   3. POINTERS ASSOCIATED WITH ADI (SUCH AS MULTIPLE VALUE STORING POINTERS
;	AND INDIRECT-ADI POINTERS) MAY POINT AT REGIONS OF THE PDL WHICH
;	ARE NOT CONTAINED WITHIN THE PDL-BUFFER.

;CHECKING TO SEE IF PDL-BUFFER NEEDS TO BE REFILLED:
;   SINCE M-AP CHANGES MUCH LESS FREQUENTLY THAN THE PDL-BUFFER POINTER ITSELF,
; ALL TESTING FOR PDL-BUFFER DUMPING/REFILLING IS DONE WITH REFERENCE TO M-AP.
; AS A RESULT, 400 (OCTAL) WORDS (THE MAXIMUM FRAME SIZE) EXTRA SLOP MUST BE LEFT.
; M-PDL-BUFFER-ACTIVE-QS CONTAINS THE NUMBER OF QS BETWEEN A-PDL-BUFFER-HEAD
; AND M-AP (MOMENTARILY, IT MAY BE NEGATIVE).
; WHENEVER M-AP IS CHANGED, M-PDL-BUFFER-ACTIVE-QS MUST LIKEWISE BE ADJUSTED.
;    CLEARLY, M-PDL-BUFFER-ACTIVE-QS MUST BE AT LEAST 4 FOR ANY CODE TO BE RUNNABLE.
; IN ADDITION, THE ADI OF THE RUNNING FRAME, IF ANY, MUST ALSO BE IN THE PDL-BUFFER.
; IF M-PDL-BUFFER-ACTIVE-QS IS GREATER THAN THE CONSTANT PDL-BUFFER-LOW-WARNING
; (SET TO 4 + MAX LENGTH OF ADI), IT MAY SAFELY BE ASSUMED THAT THE ADI, IF ANY,
; IS IN.
;    WHENEVER M-AP IS ADJUSTED DOWNWARD (POPPED), M-AP SHOULD BE ADJUSTED BEFORE
; M-PDL-BUFFER-ACTIVE-QS TESTED, SO THAT M-AP IS AT ITS NEW VALUE IF AND WHEN 
; PDL-BUFFER-REFILL IS REACHED.

;ROUTINE TO UNLOAD PDL-BUFFER INTO MAIN MEMORY, MAKING AT LEAST N WDS
; OF ROOM IN PDL BUFFER.  GENERAL IDEA IS START AT PDL-BUFFER INDEX A-PDL-BUFFER-HEAD
; AND VIRTUAL ADDRESS A-PDL-BUFFER-VIRTUAL-ADDRESS, WRITING OUT CRUFT AND INCREMENTING
; BOTH POINTERS.  ONE OPTIMIZATION IS WE FIDDLE MAP TO AVOID GOING THRU
; PAGE FAULT HANDLER ON EVERY CYCLE (WHICH WOULDNT QUITE WORK ANYWAY SINCE IT
; WOULD WRITE THE STUFF BACK IN THE PDL-BUFFER).  THUS, WE HAVE TO KEEP TRACK OF
; WHICH MAP PAGE WE HAVE HACKED AND PUT IT BACK AT END.  ALSO, CHECK IF MOVING TO A
; NEW PAGE, ETC.

PDL-BUFFER-DUMP 
	((M-2) (A-CONSTANT PDL-BUFFER-HIGH-LIMIT))
	(CALL-NOT-EQUAL M-2 A-PDL-BUFFER-HIGH-WARNING TRAP)	;PUSH-DOWN CAPACITY EXCEEDED
   (ERROR-TABLE PDL-OVERFLOW REGULAR)	;I.E. ALREADY NEAR END, THERE IS PROBABLY JUST
					;ENOUGH SPACE LEFT TO DUMP WHAT'S IN THE PDL BUFFER NOW
			;HERE I AM ASSUMING THAT A-PDL-BUFFER-HIGH-WARNING IS GUARANTEED
			;NOT TO COME OUT NEGATIVE AFTER PDL-BUFFER-MAKE-ROOM RETURNS,
			;BECAUSE OF THE CHECK ABOVE.  THIS USED TO BE CHECKED.
;ARG IN M-2 -> HIGHEST "SATISFACTORY" VALUE FOR M-PDL-BUFFER-ACTIVE-QS.
; COMMON VALUES ARE PDL-BUFFER-HIGH-LIMIT TO UNBLOAT PDL-BUFFER OR
;   0 TO COMPLETELY DUMP PDL-BUFFER (THRU M-AP) OR
; - (PP - M-AP) [MINUS SIZE OF ACTIVE FRAME] TO REALLY COMPLETELY DUMP PDL-BUFFER
PDL-BUFFER-MAKE-ROOM 			;ARG IN M-2
	((A-PDLB-TEM) PDL-BUFFER-INDEX)	;PRESERVE..
P-B-MR0	(JUMP-LESS-OR-EQUAL M-PDL-BUFFER-ACTIVE-QS A-2 P-B-X1)	;If nothing to do, done
	((VMA-START-READ) A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Take a read cycle to
	(CHECK-PAGE-READ-NO-INTERRUPT)			;make sure 2nd lvl map set up, etc
		;Note a reference is guaranteed to set up 2nd level map
		;even if it turns out to be in the pdl-buffer and no main memory
		;cycle is made.
	((MD Q-R) VMA)				;Address the map, Q-R saves addr
	((M-PGF-TEM) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)	;Save correct map contents
						;OK to use M-PGF-TEM since not going to fault
	((VMA-WRITE-MAP) IOR M-PGF-TEM		;Turn on access
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 3)))) ;R/W
	((M-TEM) DPB (M-CONSTANT -1) ALL-BUT-VMA-LOW-BITS A-PDL-BUFFER-VIRTUAL-ADDRESS)
	((A-PDL-FINAL-VMA) SUB M-ZERO A-TEM)	;Number locations left in page
	((M-TEM) SUB M-PDL-BUFFER-ACTIVE-QS A-2)	;Number locations to do total
	(JUMP-GREATER-OR-EQUAL M-TEM A-PDL-FINAL-VMA P-B-MR3)
	((A-PDL-FINAL-VMA) M-TEM)		;Don't do a full page
P-B-MR3	((PDL-BUFFER-INDEX) A-PDL-BUFFER-HEAD)	;Starting pdl-buffer address
	((VMA) A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Starting virtual-memory address
	((A-PDL-FINAL-VMA) ADD VMA A-PDL-FINAL-VMA)	;Ending virtual-memory address +1
P-B-MR1	((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-INDEX)	;Write next Q into memory
	(ILLOP-IF-PAGE-FAULT)			;Write-access supposedly turned on.
	(DISPATCH Q-DATA-TYPE WRITE-MEMORY-DATA D-ILLOP-IF-BAD-DATA-TYPE)
						;Error-check stuff being written
	(GC-WRITE-TEST (I-ARG 1))		;Check for writing ptr to extra-pdl
						;If traps, will clean up & return to P-B-MR0
	((VMA) ADD VMA (A-CONSTANT 1))		;Close loop
	(JUMP-LESS-THAN-XCT-NEXT VMA A-PDL-FINAL-VMA P-B-MR1)
       ((PDL-BUFFER-INDEX) ADD PDL-BUFFER-INDEX (A-CONSTANT 1))
;Clean up and restore the map.
	((M-TEM) SUB VMA A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Number of locations dumped
	((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM)
	((A-PDL-BUFFER-VIRTUAL-ADDRESS) VMA)
	((A-PDL-BUFFER-HEAD) PDL-BUFFER-INDEX)
	((MD) Q-R)				;Address the map
	(JUMP-GREATER-THAN-XCT-NEXT		;Loop back for next page
		M-PDL-BUFFER-ACTIVE-QS A-2 P-B-MR0)
       ((VMA-WRITE-MAP) DPB M-PGF-TEM		;Restore the map for this page
		MAP-WRITE-SECOND-LEVEL-MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
;Here when we're done
P-B-X1	((M-2) A-QLPDLH)			;Recompute A-PDL-BUFFER-HIGH-WARNING
	((M-2) SUB M-2 A-PDL-BUFFER-VIRTUAL-ADDRESS)
	((M-2) SUB M-2 (A-CONSTANT 2000))	;Result negative if within pdl-buffer size
						; of the end of the regular-pdl in virt mem
	(JUMP-LESS-THAN M-2 A-ZERO P-B-SL-1)
	(POPJ-AFTER-NEXT			;Enough room, allow P.B. to fill
	 (A-PDL-BUFFER-HIGH-WARNING) (A-CONSTANT PDL-BUFFER-HIGH-LIMIT))
       ((PDL-BUFFER-INDEX) A-PDLB-TEM)		;Restore

;Getting near the end of the stack.  Set A-PDL-BUFFER-HIGH-WARNING
;so that we will trap to PDL-BUFFER-DUMP before getting more stuff
;into the pdl buffer than there is room to store into virtual memory.
;Note that this result can actually be negative if we are currently
;in the process of taking a pdl-overflow trap.
P-B-SL-1(POPJ-AFTER-NEXT
	 (A-PDL-BUFFER-HIGH-WARNING) ADD M-2 (A-CONSTANT PDL-BUFFER-HIGH-LIMIT))
       ((PDL-BUFFER-INDEX) A-PDLB-TEM)		;Restore

;Attempt to refill pdl-buffer from virtual memory such that
;M-PDL-BUFFER-ACTIVE-QS is at least PDL-BUFFER-LOW-WARNING.
PDL-BUFFER-REFILL	
	((A-PDLB-TEM) PDL-BUFFER-INDEX)		;Preserve PI
	((M-2) A-QLPDLO)			;Get base address of pdl into M memory
P-R-0	(JUMP-GREATER-OR-EQUAL M-2 A-PDL-BUFFER-VIRTUAL-ADDRESS
				P-R-AT-BOTTOM)	;No more pdl to reload, exit
	(JUMP-GREATER-OR-EQUAL M-PDL-BUFFER-ACTIVE-QS 
	   (A-CONSTANT PDL-BUFFER-LOW-WARNING) P-R-AT-BOTTOM)	;Enough in there to win
	((VMA-START-READ) ADD (M-CONSTANT -1) A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(CHECK-PAGE-READ-NO-INTERRUPT)		;Take cycle to assure 2nd lvl map set up
	((MD Q-R) VMA)				;Address the map
	((M-PGF-TEM) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)	;Save correct map contents
	((VMA-WRITE-MAP) IOR M-PGF-TEM		;Turn on access to mem which shadows pdl buf
		(A-CONSTANT (PLUS (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)
				  (BYTE-VALUE MAP-ACCESS-CODE 3)))) ;R/W
	((M-TEM) SUB M-PDL-BUFFER-ACTIVE-QS	;Negative number of words to do total
		(A-CONSTANT PDL-BUFFER-LOW-WARNING))
	((M-1) SUB M-2 A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Negative number of words left in pdl
	(JUMP-GREATER-OR-EQUAL M-TEM A-1 P-R-2)
	((M-TEM) M-1)
P-R-2	((M-TEM) SUB M-ZERO A-TEM)		;Max number of words for those reasons
	((A-PDL-LOOP-COUNT) VMA-LOW-BITS Q-R)	;Number of words on this page -1
	(JUMP-GREATER-THAN M-TEM A-PDL-LOOP-COUNT P-R-3)
	((A-PDL-LOOP-COUNT) SUB M-TEM (A-CONSTANT 1))	;Won't be able to do full page
P-R-3	((VMA) A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Initial virtual-memory address +1
	((PDL-BUFFER-INDEX) A-PDL-BUFFER-HEAD)	;Initial P.B. address +1
P-R-1	((VMA-START-READ) SUB VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)			;Map should be hacked
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-INDEX (A-CONSTANT 1))
	(DISPATCH Q-DATA-TYPE-PLUS-ONE-BIT	;Transport the data just read from memory
		DISPATCH-ON-MAP-19
		READ-MEMORY-DATA D-PB-TRANS)	;Running cleanup handler first
	((C-PDL-BUFFER-INDEX) READ-MEMORY-DATA)
	(JUMP-LESS-THAN-XCT-NEXT M-ZERO A-PDL-LOOP-COUNT P-R-1)
       ((A-PDL-LOOP-COUNT) ADD (M-CONSTANT -1) A-PDL-LOOP-COUNT)
;Now clean up
	((M-TEM) SUB VMA A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Minus number of Q's moved
	((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM)	;Increase this
	((A-PDL-BUFFER-VIRTUAL-ADDRESS) VMA)
	((A-PDL-BUFFER-HEAD) PDL-BUFFER-INDEX)
	((MD) Q-R)				;Address the map
	(JUMP-LESS-THAN-XCT-NEXT		;Loop back for next page
		M-2 A-PDL-BUFFER-VIRTUAL-ADDRESS P-R-0)	; unless at bottom of pdl
       ((VMA-WRITE-MAP) DPB M-PGF-TEM		;Restore the map
		MAP-WRITE-SECOND-LEVEL-MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
P-R-AT-BOTTOM
	(JUMP-XCT-NEXT P-B-X1)
       (CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS (A-CONSTANT 4) ILLOP)	;Over pop

;Here if transport required while reloading pdl.  Clean up first.
;Note that the transport happens with the bottom pdl word not stored into
;yet.  This should be all right.
PB-TRANS((M-TEM) SUB VMA A-PDL-BUFFER-VIRTUAL-ADDRESS)	;Minus number of Q's moved
	((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM)	;Increase this
	((A-PDL-BUFFER-VIRTUAL-ADDRESS) VMA)
	((A-PDL-BUFFER-HEAD) PDL-BUFFER-INDEX)
	((C-PDL-BUFFER-POINTER-PUSH) A-PDLB-TEM);Save stuff momentarily
	((C-PDL-BUFFER-POINTER-PUSH) MD)
	((MD) VMA)				;Address the map
	((VMA-WRITE-MAP) DPB M-PGF-TEM		;Restore the map
		MAP-WRITE-SECOND-LEVEL-MAP
		(A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
	((VMA) MD)				;Restore VMA
	((MD) C-PDL-BUFFER-POINTER-POP)		;Restore MD
  ;This used to be just TRANSPORT.  Changed to allow EVCPs on PDL.  There is some loss of
  ;error checking (for DTP-NULL, etc) involved in this, so we may eventually want another
  ;dispatch table.
	(DISPATCH TRANSPORT-NO-EVCP MD)		;Now invoke the transporter
	((A-PDLB-TEM) C-PDL-BUFFER-POINTER-POP)	;Restore A-PDLB-TEM, lost by transporter
	((PDL-BUFFER-INDEX) A-PDL-BUFFER-HEAD)
	(JUMP-XCT-NEXT P-R-0)			;Now re-start fast loop for next word
       ((C-PDL-BUFFER-INDEX) MD)		;Put the transported datum on the pdl

;STACK-GROUP STUFF
; THE STACK GROUP QS MAY BE CONSIDERED TO BE DIVIDED INTO THREE GROUPS:
;   STATIC POINTERS, DYNAMIC STATE, AND LINKAGE QS.
; STATIC POINTERS ARE THINGS LIKE PDL ORIGINS.  THEY ARE LOADED, BUT NEVER STORED
;  BY STACK GROUP HACKING ROUTINES.
; DYNAMIC STATE ARE THINGS WHICH ARE CHANGED DURING THE OPERATION OF THE MACHINE.
;  THEY ARE BOTH LOADED AND STORED.
; LINKAGE QS ARE THINGS LIKE SG-STATE, SG-PREVIOUS-STACK-GROUP, ETC.  THEY ARE NOT
;  LOADED AND UNLOADED FROM A-MEMORY BY THE LOW LEVEL ROUTINES, BUT NOT "UPDATED".
;EACH OF THESE GROUPS IS ALLOCATED A CONTIGIOUS AREA WITHIN THE STACK-GROUP-HEADER.

; WHEN SAVING STATE, THINGS ARE FIRST SAVED IN THE PDL-BUFFER.  THE ENTIRE BLOCK
;IS THEN WRITTEN TO MAIN MEMORY.  WHEN RESTORING, THE ENTIRE BLOCK IS READ INTO
;THE PDL BUFFER, THEN RESTORED TO THE APPROPRIATE PLACES.  SINCE GENERALLY THE MOST
;"VOLATILE" THINGS WANT TO BE SAVED FIRST AND RESTORED LAST, A SORT OF PUSH DOWN LIKE
;OPERATION IS APPROPRIATE.  THUS THE VMA PUSHED ONTO THE PDL-BUFFER FIRST.
;ON THE STORE INTO MAIN MEMORY, IT IS STORED LAST.  THE STORING PROCEEDS IN LEADER
;INDEX ORDER (IE COUNTING DOWN IN MEMORY).  THUS THE VMA WINDS UP IN THE LOWEST
;Q OF THE ARRAY LEADER (JUST BEYOND THE LEADER-HEADER).  ON THE RELOAD,
;THE VMA IS THE FIRST THING READ FROM MEMORY.  IT THUS BECOMES DEEPEST ON THE PDL-BUFFER
;STACK, AND IS THE LAST THING RESTORED TO THE REAL MACHINE.  (ACTUALLY, THE VERY FIRST
;THING SAVED IS THE PDL-BUFFER-PHASING Q, WHICH IS SOMEWHAT SPECIAL SINCE IT IS ACTUALLY
;"USED" WHEN FIRST READ ON THE RELOAD).

;STORE DYNAMIC STATE OF MACHINE IN CURRENT STACK GROUP
;  MUST NOT CLOBBER M-A ON IMMEDIATE RETURN (THAT CAN HAVE SG-GOING-TO)
SGLV		;STORE EVERYTHING IN PDL-BUFFER IN REVERSE ORDER ITS TO BE WRITTEN TO MEMORY
		;M-TEM HAS DESIRED NEW STATE FOR CURRENT STACK GROUP.  SWAP L-B-P OF
		;CURRENT STACK GROUP UNLESS 1.7 OF M-TEM IS 1.
	((M-3) M-METER-STACK-GROUP-ENABLE)
	((A-LAST-STACK-GROUP) DPB M-3 Q-FLAG-BIT A-QCSTKG)
	((M-STACK-GROUP-SWITCH-FLAG) DPB (M-CONSTANT -1) A-FLAGS) ;SHUT OFF TRAPS, ETC.
	((M-3) A-QCSTKG)
	((M-3) Q-DATA-TYPE M-3)
	(CALL-NOT-EQUAL M-3 (A-CONSTANT (EVAL DTP-STACK-GROUP)) ILLOP)

	((A-SG-STATE) DPB M-TEM (LISP-BYTE %%SG-ST-CURRENT-STATE) A-SG-STATE)
	((M-4) PDL-BUFFER-POINTER)		;SAVE ORIGINAL PDL LVL

	((C-PDL-BUFFER-POINTER-PUSH) DPB M-4 Q-POINTER 		;SAVE PDL-BUFFER-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))	; FOR PHASING.
	((C-PDL-BUFFER-POINTER-PUSH) DPB VMA Q-POINTER	;SAVE VMA AS A LOCATIVE
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	((M-3) Q-ALL-BUT-POINTER VMA		;SAVE TAGS OF VMA, M-1, AND M-2 AS FIXNUM
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA) Q-ALL-BUT-POINTER M-1)
	((M-3) DPB VMA (BYTE-FIELD 8 8) A-3)
	((VMA) Q-ALL-BUT-POINTER M-2)
	((C-PDL-BUFFER-POINTER-PUSH) DPB VMA (BYTE-FIELD 8 16.) A-3)
	((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-1	;SAVE POINTERS OF M-1, M-2 AS FIXNUMS
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-2
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-1) (A-CONSTANT (M-MEM-LOC M-ZR)))   ;SAVE REGS M-ZR THROUGH M-K
SGLV0	((OA-REG-HIGH) DPB M-1 OAH-M-SRC A-ZERO)
	((C-PDL-BUFFER-POINTER-PUSH) M-GARBAGE)		;M-GARBAGE = 0@M
	(JUMP-LESS-THAN-XCT-NEXT M-1 (A-CONSTANT (M-MEM-LOC M-K)) SGLV0)
       ((M-1) ADD M-1 (A-CONSTANT 1))

	(JUMP-IF-BIT-SET-XCT-NEXT M-TEM (BYTE-FIELD 1 6) SGLV2)	;WANT TO SWAP THIS GUY' L-B-P?
       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-FLAGS Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-J) A-QLBNDP)
SGLV3	(JUMP-LESS-OR-EQUAL M-J A-QLBNDO SGLV4)	;Jump if through
	((VMA-START-READ) M-J)
	(CHECK-PAGE-READ)
	((M-ZR) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) SGVSP)	;Jump if not binding
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-C) READ-MEMORY-DATA)		;Pointer to cell bound
	((VMA-START-READ M-J) SUB M-J (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-D) READ-MEMORY-DATA)		;Old binding to be restored
	((VMA-START-READ) M-C)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-ZR) READ-MEMORY-DATA)		;New binding to be saved
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-D Q-TYPED-POINTER A-ZR)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) DPB M-ZR Q-TYPED-POINTER A-D)
	((VMA-START-WRITE) M-J)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(JUMP-XCT-NEXT SGLV3)		;In this direction, no need to check flag bits
       ((M-J) SUB M-J (A-CONSTANT 1))	;Since things must remain paired as long as in bindings

SGVSP	(JUMP-IF-BIT-SET-XCT-NEXT Q-FLAG-BIT READ-MEMORY-DATA SGLV3)
       ((M-J) SUB M-J (A-CONSTANT 1))		;Space past, down to Q with flag bit
	(JUMP-LESS-OR-EQUAL M-J A-QLBNDO SGLV4)
	((VMA-START-READ) M-J)
	(CHECK-PAGE-READ)
	(JUMP SGVSP)

SGLV4	((A-SG-STATE) DPB (M-CONSTANT -1) (LISP-BYTE %%SG-ST-IN-SWAPPED-STATE) A-SG-STATE)
SGLV2	((C-PDL-BUFFER-POINTER-PUSH) A-QLARYL)
	((C-PDL-BUFFER-POINTER-PUSH) A-QLARYH)

	((C-PDL-BUFFER-POINTER-PUSH) A-TRAP-MICRO-PC)

	((M-B) MICRO-STACK-DATA-POP)	;Save return from SGLV
	(CALL MLLV)			;Save state of running frame (LC, micro-stack, etc.)
	((MICRO-STACK-DATA-PUSH) M-B)	;Restore return from SGLV

	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)		;SAVE A-IPMARK
       ((M-K) A-IPMARK)
	((M-K) SUB M-K A-QLPDLO)
	((C-PDL-BUFFER-POINTER-PUSH) DPB Q-POINTER M-K 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)		;SAVE M-AP
       ((M-K) M-AP)
	((M-K) SUB M-K A-QLPDLO)
	((C-PDL-BUFFER-POINTER-PUSH) DPB Q-POINTER M-K 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

	((M-1) A-QLBNDP)
	((M-1) SUB M-1 A-QLBNDO)
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-1 Q-POINTER 		;SAVE L-B-P LEVEL
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-4)			;SAVE P-B-POINTER AS RELATIVE ADR TO ENTIRE PDL
	((M-1) SUB M-K A-QLPDLO)	; ARRAY
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-1 Q-POINTER 		;SAVE PDL LEVEL
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

	((C-PDL-BUFFER-POINTER-PUSH) A-TRAP-AP-LEVEL)
;	((C-PDL-BUFFER-POINTER-PUSH) A-SG-FOLLOWING-STACK-GROUP)
	((C-PDL-BUFFER-POINTER-PUSH) A-SG-CALLING-ARGS-NUMBER)
	((C-PDL-BUFFER-POINTER-PUSH) A-SG-CALLING-ARGS-POINTER)
	((C-PDL-BUFFER-POINTER-PUSH) A-SG-PREVIOUS-STACK-GROUP)
	((C-PDL-BUFFER-POINTER-PUSH) A-SG-STATE)

	((M-2) SUB M-AP A-4)		;GET - QS IN ACTIVE FRAME (AS 10. BIT NEG NUMBER OR 0)
	(JUMP-EQUAL M-2 A-ZERO SGLV1)
	((M-2) (BYTE-FIELD 10. 0) M-2 (A-CONSTANT -1))	;EXTEND SIGN TO MAKE REAL NEG NUMBER.
SGLV1	(CALL PDL-BUFFER-MAKE-ROOM) ;CAUSE ENTIRE PDL-BUFFER TO GET WRITTEN OUT.
				    ;BUT NOT THE SG-LEADER STUFF PUSHED ABOVE
	((VMA) A-QCSTKG)
	((VMA) SUB VMA (A-CONSTANT (PLUS 2 (EVAL SG-STATE))))  ;2 FOR LEADER HEADER
	(CALL-XCT-NEXT SG-WRITE-BLOCK-FROM-PDL-BUFFER)
      ((M-ZR) ADD M-ZERO (A-CONSTANT (DIFFERENCE (EVAL SG-PDL-PHASE) (EVAL SG-STATE)))
			ALU-CARRY-IN-ONE)	;WANT PHASE-STATE+1
	(POPJ-XCT-NEXT)
       ((M-STACK-GROUP-SWITCH-FLAG) DPB (M-CONSTANT 0) A-FLAGS)

SG-WRITE-BLOCK-FROM-PDL-BUFFER 
	((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(POPJ-LESS-OR-EQUAL M-ZR (A-CONSTANT 1))
	((M-ZR) SUB M-ZR (A-CONSTANT 1))
	(JUMP-XCT-NEXT SG-WRITE-BLOCK-FROM-PDL-BUFFER)
       ((VMA) SUB VMA (A-CONSTANT 1))

SG-LOAD-BLOCK-INTO-PDL-BUFFER 
	((VMA-START-READ) VMA)
	(CHECK-PAGE-READ)
	(POPJ-LESS-OR-EQUAL M-ZR (A-CONSTANT 0))  ;IN THIS CASE, USELESS READ DONE & IGNORED
	((M-ZR) SUB M-ZR (A-CONSTANT 1))
	(DISPATCH TRANSPORT-AC READ-MEMORY-DATA)
	((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)
SG-L-P-B-1
	(JUMP-XCT-NEXT SG-LOAD-BLOCK-INTO-PDL-BUFFER)
       ((VMA) ADD VMA (A-CONSTANT 1))

SG-LOAD-STATIC-STATE 		;LOAD STATIC STATE FOR STACK GROUP
	((M-C) A-QCSTKG)
	((M-TEM) Q-DATA-TYPE M-C)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-STACK-GROUP)) ILLOP)
	((VMA-START-READ) SUB M-C (A-CONSTANT (PLUS 2 (EVAL SG-REGULAR-PDL))))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(CALL-XCT-NEXT GAHD1)		;SET UP ARRAY LENGTH IN M-S AND DATA ORIGIN IN M-E
       ((M-A) READ-MEMORY-DATA)
  (ERROR-TABLE CALLS-SUB SG-REG-PDL)
	((VMA-START-READ) SUB M-C (A-CONSTANT (PLUS 2 (EVAL SG-REGULAR-PDL-LIMIT))))
	(CHECK-PAGE-READ)
	((A-QLPDLO) M-E)
	((A-QLPDLH) ADD M-E A-S)
	((M-TEM) Q-POINTER READ-MEMORY-DATA)
	(JUMP-GREATER-THAN M-TEM A-S SG-LOAD-STATIC-STATE-1)
	((A-QLPDLH) ADD M-E A-TEM)
SG-LOAD-STATIC-STATE-1
	((VMA-START-READ) SUB M-C (A-CONSTANT (PLUS 2 (EVAL SG-SPECIAL-PDL))))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT READ-MEMORY-DATA)
	(CALL-XCT-NEXT GAHD1)		;COMPUTE SAME THINGS FOR LINEAR-BINDING-ARRAY
       ((M-A) READ-MEMORY-DATA)
   (ERROR-TABLE CALLS-SUB SG-SPECIAL-PDL)
	((VMA-START-READ) SUB M-C (A-CONSTANT (PLUS 2 (EVAL SG-SPECIAL-PDL-LIMIT))))
	(CHECK-PAGE-READ)
	((A-QLBNDO) M-E)
	((A-QLBNDRH) ADD M-E A-S)
	((A-QLBNDH) A-QLBNDRH)
	((M-TEM) Q-POINTER READ-MEMORY-DATA)
	(POPJ-AFTER-NEXT POPJ-GREATER-THAN M-TEM A-S)
       ((A-QLBNDH) ADD M-E A-TEM)

;PDL BUFFER "PHASING".  IF A STACK-GROUP IS INTERRUPTED AND LATER RESUMED,
;  IT HAS BEEN DECIDED TO PRESERVE THE "PHASING" OF THE PDL-BUFFER.
;  THIS MEANS THAT (FOR EXAMPLE) M-AP, A-IPMARK, PP, ETC, WILL HAVE THE
;  SAME OCTAL VALUES AS THEY DID (NOT MERELY POINT TO THE SAME QS, ETC).
;  IF THIS WERE NOT DONE, ONE COULD NOT "HOLD" A PDL-BUFFER INDEX ACROSS A 
;  POSSIBLE PAGE-FAULT BOUNDARY.  ALTHOUGH THAT MIGHT BE A LIVABLE-WITHABLE RESTRICTION,
;  IT SEEMS WORTH IT TO AVOID THAT CLASS OF POSSIBLE BUGS.

;CHANGE STACK-GROUP STATE TO ACTIVE.  RETURN IN M-TEM PREVIOUS STATE.  IF L-B-P WAS
; SWAPPED, SWAP IT BACK.
SGENT	(CALL-XCT-NEXT SG-LOAD-STATIC-STATE)
       ((M-STACK-GROUP-SWITCH-FLAG) DPB (M-CONSTANT -1) A-FLAGS)
	((VMA) A-QCSTKG)
	((VMA-START-READ) SUB VMA (A-CONSTANT (PLUS 2 (EVAL SG-PDL-PHASE))))
	(CHECK-PAGE-READ)			;NO TRANSPORT SINCE IT'S A FIXNUM
	((PDL-BUFFER-POINTER) READ-MEMORY-DATA)		;RESTORE PP WITH CORRECT PHASING
	((M-1) Q-POINTER READ-MEMORY-DATA)
	((A-PDL-BUFFER-HEAD) ADD M-1 (A-CONSTANT 1))	;POINTS AT PDL-BUFFER LOCN WITH VALID
						;DATA (IE NONE YET)
	(CALL-XCT-NEXT SG-L-P-B-1)
       ((M-ZR) ADD M-ZERO		;-1 BECAUSE ONE FROB ALREADY HACKED, BUT +1 BECAUSE
	   (A-CONSTANT (DIFFERENCE (EVAL SG-PDL-PHASE) (EVAL SG-STATE))))  ;WANT PHASE-STATE+1

	((A-SG-STATE) C-PDL-BUFFER-POINTER-POP)
	((A-SG-PREVIOUS-STACK-GROUP) C-PDL-BUFFER-POINTER-POP)
	((A-SG-CALLING-ARGS-POINTER) C-PDL-BUFFER-POINTER-POP)
	((A-SG-CALLING-ARGS-NUMBER) C-PDL-BUFFER-POINTER-POP)
;	((A-SG-FOLLOWING-STACK-GROUP) C-PDL-BUFFER-POINTER-POP)
	((A-TRAP-AP-LEVEL) C-PDL-BUFFER-POINTER-POP)

		;GET PDL-BUFFER RELOAD POINTER BACK INTO PHASE
	((M-1) ADD A-QLPDLO C-PDL-BUFFER-POINTER-POP ALU-CARRY-IN-ONE)  ;V.A. OF P.B. LOCN W/
	((A-PDL-BUFFER-VIRTUAL-ADDRESS) Q-POINTER M-1)		;VALID DATA (IE NONE YET).
	((M-1) ADD A-QLBNDO C-PDL-BUFFER-POINTER-POP)
	((A-QLBNDP) Q-POINTER M-1)
	(CALL-XCT-NEXT GET-PDL-BUFFER-INDEX)
       ((M-K) ADD C-PDL-BUFFER-POINTER-POP A-QLPDLO)
	((M-AP) M-K)					;RESTORE M-AP
	(CALL-XCT-NEXT GET-PDL-BUFFER-INDEX)
       ((M-K) ADD C-PDL-BUFFER-POINTER-POP A-QLPDLO)
	((A-IPMARK) M-K)				;RESTORE A-IPMARK
	((M-LAST-MICRO-ENTRY) MICRO-STACK-DATA-POP)	;SAVE RETURN TO SGENT

;COMPUTE LENGTH OF ACTIVE FRAME AND LOAD MINUS THAT INTO M-PDL-BUFFER-ACTIVE-QS.
;THEN PDL-BUFFER-REFILL WILL RELOAD ENTIRE ACTIVE FRAME PLUS PDL-BUFFER-LOW-WARNING
;WORTH OF OTHER STUFF.
	((M-1) ADD (M-CONSTANT -1) A-PDL-BUFFER-HEAD)   ;WHAT PP WILL BE WHEN ALL THIS IS OVER
	((M-PDL-BUFFER-ACTIVE-QS) SUB M-AP A-1) 	;GET - LENGTH OF ACTIVE FRAME MODULO
	(JUMP-EQUAL M-PDL-BUFFER-ACTIVE-QS A-ZERO SGENT1)  ;P.B. WRAPAROUND PROBLEMS
	((M-PDL-BUFFER-ACTIVE-QS) (BYTE-FIELD 10. 0) M-PDL-BUFFER-ACTIVE-QS 
		 (A-CONSTANT -1))		;EXTEND SIGN TO MAKE REAL NEG NUMBER.
SGENT1	(CALL PDL-BUFFER-REFILL)		;REFILL PDL-BUFFER WITH GOOD STUFF
	(CALL-GREATER-THAN M-ZERO A-PDL-BUFFER-HIGH-WARNING TRAP)  ;LOSEY LOSEY IT CANT EVEN
   (ERROR-TABLE PDL-OVERFLOW REGULAR)				   ; HOLD 1 MAXIMUM SIZE FRAME
	((PDL-BUFFER-INDEX) M-AP)		;IF RUNNING MACRO-CODE, RESTORE MACRO PC
	((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
	(CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FEF-POINTER)) QLLENT)
;;; NOW SET UP THE CORRECT BASE OF THE MICRO-STACK
	;;*** Next 2 lines are temporary
	((M-TEM) MICRO-STACK-POINTER)
	(CALL-NOT-EQUAL M-TEM A-ZERO ILLOP)
	;;*** End temporary code
	((M-GARBAGE) MICRO-STACK-DATA-POP)	;POP OFF THE CURRENT BASE
	((M-1) A-SG-STATE)			;GET THE STATE OF THIS STACK GROUP
	((M-1) (LISP-BYTE %%SG-ST-INST-DISP) M-1)	;READ OUT THE INSTRUCTION DISPATCH
	((M-1) ADD M-1 (A-CONSTANT (A-MEM-LOC A-MAIN-DISPATCH)))
	((OA-REG-HIGH) DPB M-1 A-ZERO OAH-A-SRC)
	((MICRO-STACK-DATA-PUSH) A-GARBAGE)	;PUSH THE BASE ADDRESS

;;; RESTORE THE REST OF THE SG'S MICRO-STACK
	((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-EXIT-STATE)))
	(CALL-IF-BIT-SET (LISP-BYTE %%LP-EXS-MICRO-STACK-SAVED) C-PDL-BUFFER-INDEX QMMPOP)

	((MICRO-STACK-DATA-PUSH) M-LAST-MICRO-ENTRY)	;PUSH BACK RETURN FROM SGENT

	((A-TRAP-MICRO-PC) C-PDL-BUFFER-POINTER-POP)

	((A-QLARYH) C-PDL-BUFFER-POINTER-POP)
	((A-QLARYL) C-PDL-BUFFER-POINTER-POP)
	((M-FLAGS) C-PDL-BUFFER-POINTER-POP)

	((M-1) A-SG-STATE)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%SG-ST-IN-SWAPPED-STATE) M-1 
		SGENT2)		;FALL THRU ON L-B-P SWAPPED
	((M-A) A-QLBNDO)	;POINTS TO FIRST WD OF FIRST BLOCK.
SGENT3	((VMA-START-READ M-A) ADD M-A (A-CONSTANT 1))	;IS 2ND WD OF BLOCK PNTR TO VALUE
	(CHECK-PAGE-READ)				; CELL?
	(JUMP-GREATER-THAN M-A A-QLBNDP SGENT4)		;XFER ON THRU
	(JUMP-IF-BIT-SET Q-FLAG-BIT READ-MEMORY-DATA SGENT3)  ;MUST NOT BE 1ST WD OF BLOCK
							;IF IT IS, LOOP BACK FOR THAT BLOCK
	((M-ZR) Q-DATA-TYPE READ-MEMORY-DATA)
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) SGENT6)
SGENT5	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-C) READ-MEMORY-DATA)			;M-C HAS POINTER TO INTERNAL V.C.
	((VMA-START-READ) SUB M-A (A-CONSTANT 1))	;FIRST WD OF PAIR HOLDS INACTIVE 
	(CHECK-PAGE-READ)				; BINDING
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-D) READ-MEMORY-DATA)			;M-D HAS NEW VALUE BEING RESTORED
	((VMA-START-READ) M-C)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-NO-EVCP READ-MEMORY-DATA)
	((M-ZR) READ-MEMORY-DATA)			;M-ZR HAS OLD VALUE BEING SAVED
	((WRITE-MEMORY-DATA-START-WRITE) DPB M-D Q-TYPED-POINTER A-ZR)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	((WRITE-MEMORY-DATA) DPB M-ZR Q-TYPED-POINTER A-D)
	((VMA-START-WRITE) SUB M-A (A-CONSTANT 1))
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(JUMP-XCT-NEXT SGENT3)
       ((M-A) ADD M-A (A-CONSTANT 1))			;SPACE TO FIRST Q OF NEXT PAIR

SGENT6	((VMA-START-READ M-A) ADD M-A (A-CONSTANT 1))  ;THIS NOT A BINDING BLOCK, SPACE OVER
	(CHECK-PAGE-READ)			       ; IT.
	(JUMP-IF-BIT-SET Q-FLAG-BIT READ-MEMORY-DATA SGENT3)  ;FOUND FIRST Q OF NEXT BLOCK
	(JUMP-GREATER-OR-EQUAL M-A A-QLBNDP SGENT4)
	(JUMP SGENT6)					;KEEP LOOKING

SGENT4	((A-SG-STATE) DPB M-ZERO (LISP-BYTE %%SG-ST-IN-SWAPPED-STATE) A-SG-STATE)
SGENT2
	((M-1) (A-CONSTANT (M-MEM-LOC M-K)))   		;RESTORE REGS
SGENT0	((OA-REG-LOW) DPB M-1 OAL-M-DEST A-ZERO)
	((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)		;M-GARBAGE = 0@M
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT (M-MEM-LOC M-ZR)) SGENT0)
       ((M-1) SUB M-1 (A-CONSTANT 1)) 

	(CALL-IF-BIT-SET (LISP-BYTE %%METER-STACK-GROUP-SWITCH-ENABLE)
		M-METER-ENABLES METER-SG-ENTER)
	((M-2) C-PDL-BUFFER-POINTER-POP)		;RESTORE POINTER FIELDS OF M-1,M-2
	((M-1) C-PDL-BUFFER-POINTER-POP)
	((M-3) (BYTE-FIELD 8 16.) C-PDL-BUFFER-POINTER)	;THEN RESTORE THEIR TAG FIELDS
	((M-2) DPB M-3 Q-ALL-BUT-POINTER A-2)
	((M-3) (BYTE-FIELD 8 8) C-PDL-BUFFER-POINTER)
	((M-1) DPB M-3 Q-ALL-BUT-POINTER A-1)
	((M-3) DPB C-PDL-BUFFER-POINTER-POP Q-ALL-BUT-POINTER A-ZERO) ;TAG FOR VMA

	((M-4) A-QCSTKG)				;CHANGE SG-STATE TO ACTIVE
	((VMA) SUB M-4 (A-CONSTANT (PLUS 2 (EVAL SG-STATE))))
	((M-4) (A-CONSTANT (EVAL SG-STATE-ACTIVE)))
	((WRITE-MEMORY-DATA-START-WRITE M-4)
		DPB M-4 (LISP-BYTE %%SG-ST-CURRENT-STATE) A-SG-STATE)
	(CHECK-PAGE-WRITE)
	((VMA-START-READ) Q-POINTER C-PDL-BUFFER-POINTER-POP A-3)     ;RESTORE VMA AND MD
	(CHECK-PAGE-READ)
	((M-STACK-GROUP-SWITCH-FLAG) DPB (M-CONSTANT 0) A-FLAGS)
	(CALL-IF-BIT-SET M-DEFERRED-SEQUENCE-BREAK-FLAG SB-REINSTATE)
	(POPJ-AFTER-NEXT				;PGF-x SMASHES M-TEM, DELAY LOADING
		(M-TEM) DPB M-ZERO (ALL-BUT-LISP-BYTE %%SG-ST-CURRENT-STATE) A-SG-STATE)
       ((A-SG-STATE) M-4)

METER-SG-ENTER
	((A-METER-EVENT) (A-CONSTANT (EVAL %METER-STACK-GROUP-SWITCH-EVENT)))
	((M-1) A-LAST-STACK-GROUP)
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-1)
	(JUMP-IF-BIT-SET-XCT-NEXT Q-FLAG-BIT M-1 METER-MICRO-WRITE-HEADER-NO-SG-TEST)
       ((A-METER-LENGTH) (A-CONSTANT 1))
	(JUMP METER-MICRO-WRITE-HEADER)

;; High-level stack group stuff.

;; Takes a stack group in M-2, returns the SG-STATE word in M-TEM,
;; and the state subfield in M-1.
GET-SG-STATE
	((VMA-START-READ) SUB M-2 (A-CONSTANT (PLUS 2 (EVAL SG-STATE))))
	(CHECK-PAGE-READ)			;NO TRANSPORT SINCE IT'S A FIXNUM
	(POPJ-AFTER-NEXT 
	 (M-TEM) READ-MEMORY-DATA)
      ((M-1) (LISP-BYTE %%SG-ST-CURRENT-STATE) READ-MEMORY-DATA)

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
TRAP-ON-BAD-SG-STATE
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-ERROR
	(P-BIT TRAP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-ACTIVE
	(P-BIT R-BIT)				;SG-STATE-RESUMABLE
	(P-BIT R-BIT)				;SG-STATE-AWAITING-RETURN
	(P-BIT R-BIT)				;SG-STATE-INVOKE-CALL-ON-RETURN
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-INTERRUPTED-DIRTY
	(P-BIT TRAP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-AWAITING-ERROR-RECOVERY
	(P-BIT R-BIT)				;SG-STATE-AWAITING-CALL 
	(P-BIT R-BIT)				;SG-STATE-AWAITING-INITIAL-CALL
	(P-BIT TRAP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-EXHAUSTED
(REPEAT 6 (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT))
(END-DISPATCH)
(LOCALITY I-MEM)

;;     This routine handles a stack group's being called as a function;
;; it is reached from the D-QMRCL dispatch.  Thus, M-A contains the new stack group.
;;  First, error checking: if both SG's are SAFE, then the called one has to be
;; in the AWAITING-CALL or AWAITING-INITIAL-CALL state.
SG-CALL	(CALL FINISH-ENTERED-FRAME)
	(CALL-XCT-NEXT GET-SG-STATE)        ;GET STATE OF SG GOING TO.  ALSO USE THIS BELOW.
       ((M-2) M-A)
	(DISPATCH (BYTE-FIELD 4 0) M-1 TRAP-ON-BAD-SG-STATE)
    (ERROR-TABLE WRONG-SG-STATE M-A)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%SG-ST-SAFE) M-TEM SG-CALL-1)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL SG-STATE-AWAITING-CALL)) SG-CALL-1)
	((M-2) A-SG-STATE)
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%SG-ST-SAFE) M-2 SG-CALL-1)
	(CALL-NOT-EQUAL M-1 (A-CONSTANT (EVAL SG-STATE-AWAITING-INITIAL-CALL)) TRAP)
    (ERROR-TABLE WRONG-SG-STATE M-A)
SG-CALL-1
	((M-B) M-TEM)		;Save SG-STATE of SG going to
;; Set up the argument list.  This doesn't handle LEXPR/FEXPR calls!
	((A-SG-TEM) A-V-NIL)
	(JUMP-EQUAL-XCT-NEXT M-R A-ZERO SG-CALL-2)
       ((A-SG-TEM1) A-V-NIL)			; No args, list is NIL.
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1))		; List pointer to arg list.
	((A-SG-TEM1) M-K)
	((A-SG-TEM) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
SG-CALL-2
;; Leave old SG in awaiting-return, and don't swap if both of these bits are off.
	((M-2) (A-CONSTANT (EVAL SG-STATE-AWAITING-RETURN)))
	((M-C) A-SG-STATE)
	(JUMP-IF-BIT-SET (LISP-BYTE %%SG-ST-SWAP-SV-ON-CALL-OUT) M-C SG-CALL-3)
	(JUMP-IF-BIT-SET (LISP-BYTE %%SG-ST-SWAP-SV-OF-SG-THAT-CALLS-ME) M-B SG-CALL-3)
	((M-2) DPB (M-CONSTANT -1) (BYTE-FIELD 1 6) A-2)	;Set 100 bit; don't swap L-B-P
SG-CALL-3
	((VMA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))  ;VMA NOT IMPORTANT IN
			;THIS PATH, FLUSH ANY GARBAGE.  CRUFT POSSIBLE VIA PATH FROM
			;XUWR2, AT LEAST.
	(CALL-XCT-NEXT SGLV)			; Leave!
       ((M-TEM) M-2)   ;M-TEM has the new state, plus 100 bit says to not swap L-B-P.
;; Drops through.

;; More high-level stack group stuff.

;; Drops in.

SG-ENTER
; This is the common routine for activating a new stack group.  It takes the following
; things:  the new stack group itself in M-A, the transmitted value in A-SG-TEM,
; the argument list in A-SG-TEM1, and the argument count in M-R.
	((A-SG-TEM2) A-QCSTKG)
	(CALL-XCT-NEXT SGENT)
       ((A-QCSTKG) M-A)
	((A-SG-PREVIOUS-STACK-GROUP) A-SG-TEM2)
SG-ENTER-1
	((A-SG-CALLING-ARGS-POINTER) A-SG-TEM1)
	((A-SG-CALLING-ARGS-NUMBER) DPB M-R Q-POINTER
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
;; Now dispatch to separate routines, based on what state the new SG is in.
;; SGENT left that state in M-TEM.  It only dispatches on the low four bits
;; of the state because there are only 10. states implemented, and although
;; the state is a 6 bit field, it would waste lot of D-MEM to make the table
;; that large.
	(DISPATCH (BYTE-FIELD 4 0) M-TEM D-SG-ENTER)
       ((M-T) A-SG-TEM)				;SOMETIMES executes next!!

(LOCALITY D-MEM)
(START-DISPATCH 4 0)
D-SG-ENTER
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-ERROR
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-ACTIVE
	(R-BIT INHIBIT-XCT-NEXT-BIT)		;SG-STATE-RESUMABLE
	(QMDDR0)				;SG-STATE-AWAITING-RETURN
	(SG-ENTER-CALL INHIBIT-XCT-NEXT-BIT)	;SG-STATE-INVOKE-CALL-ON-RETURN
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-INTERRUPTED-DIRTY
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-AWAITING-ERROR-RECOVERY
	(R-BIT)					;SG-STATE-AWAITING-CALL 
	(SG-ENTER-CALL INHIBIT-XCT-NEXT-BIT)	;SG-STATE-AWAITING-INITIAL-CALL
	(P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)	;SG-STATE-EXHAUSTED
(REPEAT 6 (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT))
(END-DISPATCH)
(LOCALITY I-MEM)

SG-ENTER-CALL
;; This is similar to QMRCL, but it never does a "leave".
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-IPMARK)	;Count arguments
	((M-R) PDL-BUFFER-INDEX)
	((PDL-BUFFER-INDEX M-S) A-IPMARK)	;Get fef pointer pointer
	((M-A) C-PDL-BUFFER-INDEX)		;M-A := Function to call
	(DISPATCH Q-DATA-TYPE M-A D-QMRCL)	;Dispatch on data type
       (NO-OP)					;No leave neccesary.

;; More high-level stack group stuff.
;; This page contains STACK-GROUP-RESUME, STACK-GROUP-RETURN,
;;  and the SG-ENTER-NO-PREV entry-point.

     (MISC-INST-ENTRY STACK-GROUP-RESUME)
SG-RESUME
	((A-SG-TEM) C-PDL-BUFFER-POINTER-POP)	; Get the value being transmitted.
	((M-A) C-PDL-BUFFER-POINTER-POP)	; Get the destination SG.
	((A-SG-TEM1) A-V-NIL)			; Argument list.
	(CALL-XCT-NEXT GET-SG-STATE)		; Get state of destination SG.
       ((M-2) M-A)
	(DISPATCH (BYTE-FIELD 4 0) M-1 TRAP-ON-BAD-SG-STATE)
    (ERROR-TABLE WRONG-SG-STATE A-SG-PREVIOUS-STACK-GROUP)
	((M-TEM) (A-CONSTANT (EVAL SG-STATE-AWAITING-CALL)))
	(CALL SGLV)
	(JUMP SG-ENTER-NO-PREV)


     (MISC-INST-ENTRY STACK-GROUP-RETURN)
SG-RETURN
	((M-2) A-SG-STATE)
	(CALL-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%SG-ST-SAFE) M-2 TRAP)
    (ERROR-TABLE SG-RETURN-UNSAFE)
       ((A-SG-TEM1) A-V-NIL)			; Arg list (just in case...)
	(CALL-XCT-NEXT GET-SG-STATE)		; Get state of prev. SG in M-1
       ((M-2) A-SG-PREVIOUS-STACK-GROUP)
	(CALL-EQUAL M-1 (A-CONSTANT (EVAL SG-STATE-AWAITING-CALL)) TRAP)
    (ERROR-TABLE WRONG-SG-STATE A-SG-PREVIOUS-STACK-GROUP)
	(CALL-EQUAL M-1 (A-CONSTANT (EVAL SG-STATE-AWAITING-INITIAL-CALL)) TRAP)
    (ERROR-TABLE WRONG-SG-STATE A-SG-PREVIOUS-STACK-GROUP)
	(DISPATCH (BYTE-FIELD 4 0) M-1 TRAP-ON-BAD-SG-STATE)
    (ERROR-TABLE WRONG-SG-STATE A-SG-PREVIOUS-STACK-GROUP)

SG-RETURN-1
	((A-SG-TEM) C-PDL-BUFFER-POINTER-POP)	; Get the value being transmitted.
	((M-TEM) (A-CONSTANT (EVAL SG-STATE-AWAITING-CALL)))
SG-RETURN-2  ; Entrypoint from QMXSG, which is where we exit the top of a stack group.
	(CALL SGLV)
	((M-A) A-SG-PREVIOUS-STACK-GROUP)
;; Falls into:


; This is like SG-ENTER (q.v.) except that it doesn't set up the PREVIOUS-STACK-GROUP
; at all, and so it takes no arg in A-SG-TEM2.
SG-ENTER-NO-PREV
	(CALL-XCT-NEXT SGENT)
       ((A-QCSTKG) M-A)
	(JUMP SG-ENTER-1)

RESET-MACHINE
	((A-DISK-BUSY) M-ZERO)			;Forget pending disk operation
	((INTERRUPT-CONTROL) DPB (M-CONSTANT -1)	;Reset the bus interface and I/O devs
		(BYTE-FIELD 1 28.) A-ZERO)
	((M-1) (A-CONSTANT 40))				;Generate RESET for 10 microseconds
RST	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO RST)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	((INTERRUPT-CONTROL) DPB (M-CONSTANT -1)	;Clear RESET, set halfword-mode,
		(BYTE-FIELD 1 27.) A-ZERO)		;and enable interrupts
	((MD) SETZ)
	(CALL-XCT-NEXT PHYS-MEM-WRITE)			;Reset bus interface status.
       ((VMA) (A-CONSTANT 17773022))			;Unibus loc 766044
	;Drop into INITIAL-MAP

;LOADING THE INITIAL MAP.
; THE FIRST STEP IS TO ADDRESS THE SYSTEM COMMUNICATION AREA AND FIND
; OUT MUCH VIRTUAL MEMORY SHOULD BE WIRED AND STRAIGHT-MAPPED (%SYS-COM-WIRED-SIZE).
; THE MAP IS THEN SET UP FOR THOSE PAGES.  THE REMAINDER OF VIRTUAL
; SPACE IS MADE "MAP NOT SET UP."  STUFF WILL THEN BE PICKED
; UP OUT OF THE PAGE HASH TABLE.  IT IS ALSO NECESSARY TO SET UP THE
; LAST BLOCK OF LEVEL 2 MAP TO "MAP NOT SET UP (ZERO)".

INITIAL-MAP
	(CALL-XCT-NEXT PHYS-MEM-READ)		;ADDRESS SYSTEM COMMUNICATION AREA
       ((VMA) (A-CONSTANT (PLUS 400 (EVAL %SYS-COM-WIRED-SIZE))))
	((M-A) Q-POINTER MD)			;SAVE NUMBER OF WIRED WORDS
INITIAL-MAP-A	;Enter here with number of words to map in M-A
	;FIRST SET ALL LEVEL 1 MAP TO 37
	((VMA) DPB (M-CONSTANT -1) MAP-WRITE-FIRST-LEVEL-MAP 
		   (A-CONSTANT (BYTE-VALUE MAP-WRITE-ENABLE-FIRST-LEVEL-WRITE 1)))
	((MD) DPB (M-CONSTANT -1) (BYTE-FIELD 1 24.) A-ZERO)
INIMAP1	((MD-WRITE-MAP) SUB MD (A-CONSTANT 20000))
	(JUMP-NOT-EQUAL MD A-ZERO INIMAP1)
	;THEN ZERO LAST BLOCK OF LEVEL 2 MAP
	((MD) A-ZERO)
INIMAP2	((VMA-WRITE-MAP) DPB (M-CONSTANT -1) MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE A-ZERO)
	((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))
	(JUMP-IF-BIT-CLEAR (BYTE-FIELD 1 13.) MD INIMAP2)
	;NOW SET UP WIRED LEVEL 1 MAP
	((MD) A-ZERO)
	((M-C) DPB (M-CONSTANT -1) MAP-WRITE-ENABLE-FIRST-LEVEL-WRITE A-ZERO)
INIMAP7	((VMA-WRITE-MAP) M-C) 
	((MD) ADD MD (A-CONSTANT 20000))
	(JUMP-LESS-THAN-XCT-NEXT MD A-A INIMAP7)
       ((M-C) ADD M-C (A-CONSTANT (BYTE-VALUE MAP-WRITE-FIRST-LEVEL-MAP 1)))
	((A-SECOND-LEVEL-MAP-REUSE-POINTER-INIT) 
		MAP-WRITE-FIRST-LEVEL-MAP M-C)	;FIRST NON-WIRED
	;THEN SET UP WIRED LEVEL 2 MAP
	((MD) SETZ)
INIMAP3	((VMA-WRITE-MAP) VMA-PHYS-PAGE-ADDR-PART MD	;SELF-ADDRESS
		(A-CONSTANT (PLUS (BYTE-VALUE MAP-ACCESS-CODE 3)   ;RW
				  ;(BYTE-VALUE MAP-STATUS-CODE 0)  ;4 READ/WRITE
				  (BYTE-VALUE MAP-META-BITS 64) ;NOT OLD, NOT EXTRA-PDL, STRUC
				  (BYTE-VALUE MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1))))
	((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))			;NEXT PAGE
	(JUMP-LESS-THAN MD A-A INIMAP3)		;LOOP UNTIL DONE ALL WIRED ADDRESSES
INIM3A	((M-1) (BYTE-FIELD 5 8) MD)		;IF NOT AT EVEN 1ST LVL MAP BOUNDARY...
	(JUMP-EQUAL M-1 A-ZERO INIM3B)		; INITIALIZE REST OF 2ND LVL BLOCK TO
	((VMA-WRITE-MAP)			; MAP NOT SET UP.
	   (A-CONSTANT (BYTE-VALUE MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1)))
	(JUMP-XCT-NEXT INIM3A)
       ((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))

INIM3B						;INITIALIZE REVERSE 1ST LVL MAP
	((A-SECOND-LEVEL-MAP-REUSE-POINTER) A-SECOND-LEVEL-MAP-REUSE-POINTER-INIT)
					;REVERSE 1ST LVL MAP LOCS 40-77
	((WRITE-MEMORY-DATA) M-ZERO)	;VALUE TO GO IN WIRED ENTRIES
	((VMA) (A-CONSTANT 437))	;A-V-SYSTEM-COMMUNICATION-AREA IS 400
INIMAP5	((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	((WRITE-MEMORY-DATA) ADD WRITE-MEMORY-DATA (A-CONSTANT 20000))
	(JUMP-LESS-THAN WRITE-MEMORY-DATA A-A INIMAP6)	;JUMP IF STILL WIRED
	((M-A WRITE-MEMORY-DATA) (M-CONSTANT -1))	;REST OF ENTRYS ARE -1.
INIMAP6	(JUMP-LESS-THAN VMA (A-CONSTANT 477) INIMAP5)
	(POPJ)

;PHYSICAL MEMORY REFERENCING.
;THIS WORKS BY TEMPORARILY CLOBBERING LOCATION 0 OF THE SECOND-LEVEL MAP.
;A-TEM1, A-TEM2, AND A-TEM3 ARE USED AS TEMPORARIES.  ARGS ARE IN VMA AND MD.
PHYS-MEM-READ 
	((A-TEM1) VMA)				;SAVE ADDRESS
	((MD) A-ZERO)				;ADDRESS MAP LOCATION 0@2
	((A-TEM3) MAP-WRITE-SECOND-LEVEL-MAP	;SAVE IT (READ & WRITE THE SAME)
		  MEMORY-MAP-DATA
		  (A-CONSTANT (BYTE-VALUE MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1)))
	((VMA-WRITE-MAP) VMA-PHYS-PAGE-ADDR-PART VMA
		(A-CONSTANT (PLUS (BYTE-VALUE MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1)
				  (BYTE-VALUE MAP-ACCESS-CODE 3))))
	((VMA-START-READ) DPB M-ZERO		;READ, USING LOC WITHIN PAGE ZERO
		ALL-BUT-VMA-LOW-BITS A-TEM1)
	(ILLOP-IF-PAGE-FAULT)			;FOO, I JUST SET UP THE MAP
	((A-TEM2) READ-MEMORY-DATA)		;GET RESULT TO BE RETURNED
	((MD) A-ZERO)				;RESTORE THE MAP
	((VMA-WRITE-MAP) A-TEM3)
	(POPJ-AFTER-NEXT (VMA) A-TEM1)		;RETURN CORRECT VALUES IN VMA AND MD
       ((MD) A-TEM2)

PHYS-MEM-WRITE 
	((A-TEM1) VMA)				;SAVE ADDRESS
	((A-TEM2) MD)				;AND DATA
	((MD) A-ZERO)				;ADDRESS MAP LOCATION 0@2
	((A-TEM3) MAP-WRITE-SECOND-LEVEL-MAP	;SAVE IT (READ & WRITE THE SAME)
		  MEMORY-MAP-DATA
		  (A-CONSTANT (BYTE-VALUE MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1)))
	((VMA-WRITE-MAP) VMA-PHYS-PAGE-ADDR-PART VMA
		(A-CONSTANT (PLUS (BYTE-VALUE MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE 1)
				  (BYTE-VALUE MAP-ACCESS-CODE 3))))
	((MD) A-TEM2)				;RESTORE THE DATA TO BE WRITTEN
	((VMA-START-WRITE) DPB M-ZERO		;WRITE, USING LOC WITHIN PAGE ZERO
		ALL-BUT-VMA-LOW-BITS A-TEM1)
	(ILLOP-IF-PAGE-FAULT)			;FOO, I JUST SET UP THE MAP
	((MD) A-ZERO)				;RESTORE THE MAP
	((VMA-WRITE-MAP) A-TEM3)
	(POPJ-AFTER-NEXT (VMA) A-TEM1)		;RETURN CORRECT VALUES IN VMA AND MD
       ((MD) A-TEM2)

;;; COLD BOOT, %DISK-RESTORE and %DISK-SAVE code

;(%DISK-SAVE main-memory-size high-16-bits-of-partition-name low-16-bits)
;The second and third arguments may be zero to specify the current partition.
DISK-SAVE (MISC-INST-ENTRY %DISK-SAVE)
	((M-4) C-PDL-BUFFER-POINTER-POP)
	((M-4) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 20 20) A-4)
	((M-S) Q-POINTER C-PDL-BUFFER-POINTER-POP)
	(CALL SWAP-OUT-ALL-PAGES)		;Make sure disk has valid data for all pages.
	(CALL COLD-READ-LABEL)			;Find the specified partition, and PAGE.
	((M-A) M-I)				;Interchange their starts and sizes
	((M-I) M-Q)				;so that we copy from PAGE to the other.
	((M-Q) M-A)
	((M-A) M-J)
	((M-J) M-R)
	((M-R) M-A)
	(CALL DISK-COPY)			;Copy.
	(JUMP COLD-SWAP-IN)			;Physical core now clobbered, so re-swap-in.

;Make sure all pages are correct on disk.
;Requires that M-S contain the number of words of physical main memory.
;Has the side-effect of destroying the page hash table.
;For %DISK-SAVE, that doesn't matter since we just re-boot anyway.
SWAP-OUT-ALL-PAGES
	((C-PDL-BUFFER-POINTER-PUSH) M-S)
	((M-S) LDB (BYTE-FIELD 16. 8) M-S A-ZERO)	;Number of physical pages.
	((VMA-START-READ) (A-CONSTANT (PLUS 400 (EVAL %SYS-COM-WIRED-SIZE))))
	(ILLOP-IF-PAGE-FAULT)
	((M-T) (BYTE-FIELD 16. 8) READ-MEMORY-DATA)	;Number of wired pages.
	((C-PDL-BUFFER-POINTER-PUSH) M-T)
	((M-T) SUB M-S (A-CONSTANT 1))		;First page to do is highest in core
;Swap out all unwired pages first, using %DELETE-PHYSICAL-PAGE and updating the PHT normally.
SWAP-OUT-ALL-PAGES-1
	((C-PDL-BUFFER-POINTER-PUSH) M-T)	;Save current page
	((C-PDL-BUFFER-POINTER-PUSH) DPB M-T VMA-PAGE-ADDR-PART A-ZERO)  ;arg
	(CALL XDPPG)
	((M-T) SUB C-PDL-BUFFER-POINTER-POP (A-CONSTANT 1))
	(JUMP-GREATER-OR-EQUAL M-T A-ZERO SWAP-OUT-ALL-PAGES-1)
;Now swap out all the wired pages
	((M-A) (A-CONSTANT 200000))		;Direct-map the first 64K
	(CALL INITIAL-MAP-A)
	((M-1) A-DISK-OFFSET)			;Disk address of virtual location 0
	((M-2) C-PDL-BUFFER-POINTER-POP)	;Number of wired pages
	((M-B) M-ZERO)				;Physical memory location 0
	((M-C) DPB M-2 VMA-PAGE-ADDR-PART A-ZERO)	;Put CCW list in high memory
	((M-S) C-PDL-BUFFER-POINTER-POP)
COLD-DISK-WRITE
	((VMA) A-DISK-RUN-LIGHT)
	((WRITE-MEMORY-DATA) Q-POINTER (M-CONSTANT 0))
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 2))	;Turn off run bar
	((M-T) (A-CONSTANT DISK-WRITE-COMMAND))
;;; Start the disk and wait for completion.
COLD-RUN-DISK
	(CALL START-DISK-N-PAGES)
	((A-DISK-SAVE-PGF-A) M-A)
	((A-DISK-SAVE-PGF-B) M-B)
COLD-AWAIT-DISK
	(CALL DISK-RECALIBRATE-WAIT)		;Wait for hardware completion
	(CALL DISK-COMPLETION)
	(JUMP-NOT-EQUAL A-DISK-BUSY M-ZERO COLD-AWAIT-DISK)  ;Not done, must have been error
	(POPJ-AFTER-NEXT (M-B) A-DISK-SAVE-PGF-B)
       ((M-A) A-DISK-SAVE-PGF-A)

COLD-DISK-READ-1				;1 page read
	((M-2) (A-CONSTANT 1))
	((M-C) (A-CONSTANT 777))
COLD-DISK-READ
	((VMA) A-DISK-RUN-LIGHT)
	((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1)
		BOXED-NUM-EXCEPT-SIGN-BIT A-ZERO)
	((VMA-START-WRITE) ADD VMA (A-CONSTANT 2))	;Turn on run bar
	((M-T) (A-CONSTANT DISK-READ-COMMAND))
	(JUMP COLD-RUN-DISK)

COLD-BOOT
	((M-4) A-ZERO)				;0 => use current band.
	(JUMP DISK-RESTORE-1)			;Load world from there

;(%DISK-RESTORE high-16-bits-of-partition-name low-16-bits)
;The first and second arguments may be zero to specify the current partition.
DISK-RESTORE (MISC-INST-ENTRY %DISK-RESTORE)
	((M-4) C-PDL-BUFFER-POINTER-POP)
	((M-4) DPB C-PDL-BUFFER-POINTER-POP (BYTE-FIELD 20 20) A-4)
DISK-RESTORE-1
	((WRITE-MEMORY-DATA) (A-CONSTANT 200000))	;64K to be direct-mapped
	(CALL-XCT-NEXT PHYS-MEM-WRITE)
       ((VMA) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-WIRED-SIZE))))
	(CALL RESET-MACHINE)
	(CALL DISK-RECALIBRATE)			;For marksman

;;; Determine size of main memory
	((MD) (A-CONSTANT 40))			;Turn off ERROR-STOP-ENABLE
	(CALL-XCT-NEXT PHYS-MEM-WRITE)		;40 is PROM-DISABLE
       ((VMA) (A-CONSTANT 17773005))		;Unibus 766012
	((M-S) SETZ)
MEM-SIZE-LOOP
	((VMA M-S) ADD M-S (A-CONSTANT 40000))	;Memory comes in 16K increments
	(CALL-XCT-NEXT PHYS-MEM-WRITE)
       ((MD) (A-CONSTANT 37))			;Some 1's, some 0's
	(CALL PHYS-MEM-READ)
	(JUMP-EQUAL MD (A-CONSTANT 37) MEM-SIZE-LOOP)
	;M-S now has the first non-existent location
	((MD) (A-CONSTANT 46))			;Turn ERROR-STOP-ENABLE back on
	(CALL-XCT-NEXT PHYS-MEM-WRITE)		;40 is PROM-DISABLE, 2 is NORMAL speed.
       ((VMA) (A-CONSTANT 17773005))		;Unibus 766012
	(CALL-XCT-NEXT PHYS-MEM-WRITE)		;Clear bus error indicators
       ((VMA) (A-CONSTANT 17773022))		;Unibus 766044
	(CALL COLD-READ-LABEL)			;Find PAGE partition and specified partition.
	(CALL DISK-COPY)			;Copy that partition into PAGE.

;;; Initialize physical memory from its swapped-out image on disk.
;;; First, read in page zero, the system communication area, and the scratchpad-init-area
COLD-SWAP-IN
	((M-1) A-DISK-OFFSET)			;From start of page partition
	((M-2) (A-CONSTANT 3))			;Core pages 0, 1, and 2
	((M-B) (A-CONSTANT 0))			;..
	((M-C) (A-CONSTANT 2400))		;CCW list after MICRO-CODE-SYMBOL-AREA
	(CALL COLD-DISK-READ)
;;; Read in the rest of wired memory (the sys comm area has its size).
;;; Don't clobber the MICRO-CODE-SYMBOL-AREA
	(CALL-XCT-NEXT PHYS-MEM-READ)
       ((VMA) (A-CONSTANT (PLUS 400 (EVAL %SYS-COM-WIRED-SIZE))))
	((M-2) VMA-PAGE-ADDR-PART READ-MEMORY-DATA)	;Number of wired pages
	((M-C) Q-POINTER READ-MEMORY-DATA)	;Save for later, also put CCW list there
	((M-B) (A-CONSTANT 5))			;First page after MICRO-CODE-SYMBOL-AREA
	((M-1) ADD M-B A-DISK-OFFSET)
	((M-2) SUB M-2 (A-CONSTANT 5))
	(CALL COLD-DISK-READ)
;;; Set things up according to actual main memory size
	((WRITE-MEMORY-DATA) Q-POINTER M-S (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) (A-CONSTANT (PLUS 400 (EVAL %SYS-COM-MEMORY-SIZE))))
	(ILLOP-IF-PAGE-FAULT)
;;; Now set up the table of area addresses
	(CALL GET-AREA-ORIGINS)
;;; Reinitialize the page hash table to be completely empty;
;;; permanently wired pages have no entries.
;;; Decide the size of the PHT from the size of main memory; it should
;;; have 4 words in it for each page of main memory (thus will be 1/2 full).
	((M-1) VMA-PAGE-ADDR-PART M-S)		;Number of pages of main memory
	((M-1) ADD M-1 A-1 OUTPUT-SELECTOR-LEFTSHIFT-1)	;Times 4
	((M-1) ADD M-1 (A-CONSTANT (EVAL (1- PAGE-SIZE))))	;Round up to multiple of page
	((M-1) AND M-1 (A-CONSTANT (EVAL (MINUS PAGE-SIZE))))
	((M-TEM) A-V-PHYSICAL-PAGE-DATA)	;But not bigger than available space
	((M-TEM) SUB M-TEM A-V-PAGE-TABLE-AREA)
	(JUMP-LESS-OR-EQUAL M-1 A-TEM COLD-REINIT-PHT-0)
	((M-1) A-TEM)
COLD-REINIT-PHT-0
	((A-PHT-INDEX-LIMIT) M-1)		;Size of page hash table
	((WRITE-MEMORY-DATA) Q-POINTER M-1 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((VMA-START-WRITE) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-PAGE-TABLE-SIZE))))
	(ILLOP-IF-PAGE-FAULT)
	((M-J VMA) ADD M-1 A-V-PAGE-TABLE-AREA)	;Address above PHT
	(CALL SET-PHT-INDEX-MASK)
	((WRITE-MEMORY-DATA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;Fill PHT with 0
COLD-REINIT-PHT-2
	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	(JUMP-GREATER-THAN VMA A-V-PAGE-TABLE-AREA COLD-REINIT-PHT-2)
;;; Initialize physical-page-data.  First make it all completely null.
	((WRITE-MEMORY-DATA) (M-CONSTANT -1))
	((VMA) A-V-REGION-ORIGIN)
COLD-REINIT-PPD-0
	((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
	(ILLOP-IF-PAGE-FAULT)
	(JUMP-GREATER-THAN VMA A-V-PHYSICAL-PAGE-DATA COLD-REINIT-PPD-0)
;;; Make magic PHYSICAL-PAGE-DATA entries for the wired pages and
;;; free entries in PPD and PHT for the available main memory.
;;; M-J has the upper-bound address of the PHT.  M-I gets same for PPD.
	((M-1) VMA-PAGE-ADDR-PART M-S)			;Number of pages of main memory
	((M-I) ADD M-1 A-V-PHYSICAL-PAGE-DATA)
	((M-R) A-V-RESIDENT-SYMBOL-AREA)		;Address doing
	((M-K) ADD M-S A-R)				;Size of memory
	((M-C) M-J)					;Address for filling in PHT
COLD-REINIT-PPD-1
	(JUMP-GREATER-OR-EQUAL M-R A-V-REGION-FREE-POINTER COLD-REINIT-PPD-3)	;free
	(JUMP-GREATER-OR-EQUAL M-R A-V-REGION-ORIGIN COLD-REINIT-PPD-2)	;wired
	(JUMP-GREATER-OR-EQUAL M-R A-I COLD-REINIT-PPD-3)	;free part of PPD
	(JUMP-GREATER-OR-EQUAL M-R A-V-PHYSICAL-PAGE-DATA COLD-REINIT-PPD-2)	;wired
	(JUMP-GREATER-OR-EQUAL M-R A-J COLD-REINIT-PPD-3)	;free part of PHT
COLD-REINIT-PPD-2
	((WRITE-MEMORY-DATA) (A-CONSTANT 177777))	;Wired page, no PHT entry
	((VMA-START-WRITE) (BYTE-FIELD 8 8) M-R A-V-PHYSICAL-PAGE-DATA)
	(ILLOP-IF-PAGE-FAULT)
	(JUMP COLD-REINIT-PPD-4)

COLD-REINIT-PPD-3
	((VMA M-C) SUB M-C (A-CONSTANT 4))		;Put in a PHT entry for free page
	(CALL-XCT-NEXT XCPPG1)				;Create physical page
       ((C-PDL-BUFFER-POINTER-PUSH) M-R)		;At this address
COLD-REINIT-PPD-4
	((M-R) ADD M-R (A-CONSTANT (EVAL PAGE-SIZE)))
	(JUMP-LESS-THAN M-R A-K COLD-REINIT-PPD-1)
	(JUMP BEG0000)					;Done, go start up world

SET-PHT-INDEX-MASK				;Given A-PHT-INDEX-SIZE in M-1
	((M-2) A-ZERO)				;Build mask with same haulong
SET-PHT-INDEX-MASK-1
	((M-2) M+A+1 M-2 A-2)			;Shift left bringing in 1
	((M-1) (BYTE-FIELD 37 1) M-1)		;Shift right bringing in 0
	(POPJ-AFTER-NEXT (A-PHT-INDEX-MASK) DPB M-ZERO (BYTE-FIELD 1 0) A-2) ;clear low bit
       (CALL-NOT-EQUAL M-1 (A-CONSTANT 0) SET-PHT-INDEX-MASK-1)

;;; Read the disk label and find the main load partition to be used,
;;; and the PAGE partition.  The main load to be used is either the
;;; one whose name is in M-4, or the current one if M-4 is zero.
;;; Also set A-LOADED-BAND for later macrocode use.
COLD-READ-LABEL 
	((M-B) A-ZERO)				;Core address
	((M-1) A-ZERO)				;Disk address
	(CALL COLD-DISK-READ-1)
	;Location 7 contains the name of the main load partition.
	;Location 200 contains the partition table.
	;We must also find the PAGE partition and set up A-DISK-OFFSET and A-DISK-MAXIMUM
	(CALL-XCT-NEXT PHYS-MEM-READ)		; Read the number of blocks per track
       ((VMA) (A-CONSTANT 4))
	((A-DISK-BLOCKS-PER-TRACK) Q-POINTER READ-MEMORY-DATA
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-XCT-NEXT PHYS-MEM-READ)		; Read the number of heads
       ((VMA) (A-CONSTANT 3))
	((Q-R) READ-MEMORY-DATA)		; Get number of blocks per cylinder
	(CALL-XCT-NEXT MPY)			; Blocks/track * tracks/cylinder
       ((M-1) DPB M-ZERO Q-ALL-BUT-POINTER A-DISK-BLOCKS-PER-TRACK)
	((A-DISK-BLOCKS-PER-CYLINDER) Q-POINTER Q-R
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL-XCT-NEXT COLD-FIND-PARTITION)
       ((M-3) (A-CONSTANT 10521640520))		; PAGE = 105 107 101 120 = 10521640520
	((A-DISK-OFFSET) M-I)
	((A-DISK-MAXIMUM) M-J)
	((M-Q) M-I)
	((M-R) M-J)
	(CALL-XCT-NEXT PHYS-MEM-READ)
       ((VMA) (A-CONSTANT 7))
	((M-3) READ-MEMORY-DATA)		;Current Band
	(JUMP-EQUAL M-4 A-ZERO COLD-READ-LABEL-1)
	((M-3) M-4)
COLD-READ-LABEL-1
	((A-LOADED-BAND) (BYTE-FIELD 30 10) M-3 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL COLD-FIND-PARTITION)		;Set up M-I, M-J for partition to load.
	(POPJ)

;;; Here on a warm boot, we have to read the label in order to find where the
;;; PAGE partition is.  But we mustn't bash core page 0.
;;; Also have to set up A-V-PHYSICAL-PAGE-DATA-END based on main memory size
;;; and set up PHT size parameters
WARM-READ-LABEL
	((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-MEMORY-SIZE))))
	(ILLOP-IF-PAGE-FAULT)
	((M-TEM) VMA-PAGE-ADDR-PART READ-MEMORY-DATA)
	((A-V-PHYSICAL-PAGE-DATA-END) ADD M-TEM A-V-PHYSICAL-PAGE-DATA)
	((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-PAGE-TABLE-SIZE))))
	(ILLOP-IF-PAGE-FAULT)
	((M-1) Q-POINTER READ-MEMORY-DATA)
	((A-PHT-INDEX-LIMIT) M-1)
	(CALL SET-PHT-INDEX-MASK)
	((M-B) A-ZERO)				;Core address
	((M-1) (A-CONSTANT 1))			;Disk address
	((M-2) (A-CONSTANT 1))			;1 block
	((M-C) (A-CONSTANT 777))
	(CALL COLD-DISK-WRITE)			;Save page 0
	(CALL-XCT-NEXT COLD-READ-LABEL)		;Go get the label
       ((M-4) SETZ)				;not worrying about load partition
	((A-LOADED-BAND)			;We don't know which band this is
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((M-1) (A-CONSTANT 1))			;Disk address (restore page 0)
	(JUMP COLD-DISK-READ-1)

;Copy one sequence of disk blocks into another.
;M-I and M-J now have the start and size of the partition to be copied from.
;M-Q and M-R have the start and size of the partition to be copied into.
;M-S has the size of main memory (in words)
;Leaves first 10 pages of main memory alone, to avoid clobbering system
;communication area and micro code symbol area.  (Actually, currently 6 pages
;would be sufficient.)  Pages 10 and 11 are used for the command list, allowing
;transferring 512. pages (6 T-80 cylinders, 128K words) at a time.
;The size is computed from %SYS-COM-VALID-SIZE in the source band.
DISK-COPY
	((M-B) (A-CONSTANT 12))			;Core address
	((M-1) ADD M-I (A-CONSTANT 1))		;Disk address
	(CALL COLD-DISK-READ-1)			;Read 1 block
	(CALL-XCT-NEXT PHYS-MEM-READ)		;Get useful size of partition, in words
       ((VMA) DPB M-B VMA-PAGE-ADDR-PART (A-CONSTANT (EVAL %SYS-COM-VALID-SIZE)))
	((M-K) (BYTE-FIELD 16. 8) MD)		;Number of valid pages
	(JUMP-LESS-OR-EQUAL M-J A-K DISK-COPY-PART-1)
	((M-J) M-K)				;M-J is number of pages to copy (min sizes)
DISK-COPY-PART-1
	(CALL-GREATER-THAN M-J A-R ILLOP)	;Not enough room in destination partition
	((M-K) (BYTE-FIELD 14. 8) M-S)		;Number of pages in main memory
	((M-K) SUB M-K (A-CONSTANT 12))		;Don't use first 12 for buffer
	(JUMP-LESS-THAN M-K (A-CONSTANT 1000) DISK-COPY-PART-2)
	((M-K) (A-CONSTANT 1000))		;At most 1000 pages at a time since that is
						; size of 2-page command list
DISK-COPY-PART-2
	;Here M-I is the from-address, M-Q is the to-address, M-J is the
	;number of blocks to transfer, and M-K is the number of blocks to
	;transfer at a whack.
	(POPJ-EQUAL M-J A-ZERO)			;If done.
	(JUMP-GREATER-OR-EQUAL-XCT-NEXT M-J A-K DISK-COPY-PART-3)
       ((M-2) M-K)				;Number to do this time
	((M-2) M-J)
DISK-COPY-PART-3
	((M-D) M-2)
	((M-B) (A-CONSTANT 12))			;Page 12 is first page to use as buffer
	((M-1) M-I)				;Read some in
	((M-C) (A-CONSTANT 4000))		;CCW list address
	(CALL COLD-DISK-READ)
	((M-2) M-D)
	((M-1) M-Q)				;Write some out
	(CALL COLD-DISK-WRITE)
	((M-I) ADD M-I A-D)			;Advance pointers
	((M-Q) ADD M-Q A-D)
	((M-J) SUB M-J A-D)
	(JUMP DISK-COPY-PART-2)

;;; With the label in location 0, this routine finds a partition whose name is in M-3
;;; and returns its start and size (in blocks) in M-I and M-J.
COLD-FIND-PARTITION
	(CALL-XCT-NEXT PHYS-MEM-READ)		;Get number of partitions
       ((VMA) (A-CONSTANT 200))
	((M-I) READ-MEMORY-DATA)
	(CALL-XCT-NEXT PHYS-MEM-READ)		;Get words per partition
       ((VMA) ADD VMA (A-CONSTANT 1))
	((M-J) READ-MEMORY-DATA)
	((VMA) ADD VMA (A-CONSTANT 1))
COLD-FIND-PART-LOOP
	(CALL-EQUAL M-I A-ZERO ILLOP)		;Out of partitions, not found, die
	(CALL PHYS-MEM-READ)			;Get name of a partition
	((M-I) SUB M-I (A-CONSTANT 1))
	(JUMP-NOT-EQUAL-XCT-NEXT READ-MEMORY-DATA A-3 COLD-FIND-PART-LOOP)
       ((VMA) ADD VMA A-J)
	((VMA) SUB VMA A-J)
	(CALL-XCT-NEXT PHYS-MEM-READ)		;Found it, get start and size
       ((VMA) ADD VMA (A-CONSTANT 1))
	((M-I) READ-MEMORY-DATA)
	(CALL-XCT-NEXT PHYS-MEM-READ)
       ((VMA) ADD VMA (A-CONSTANT 1))
	(POPJ-AFTER-NEXT (M-J) READ-MEMORY-DATA)
       (NO-OP)

))
;;---					T H E   E N D