4,887,235
	553	554
		(goto rplaca1)
	        (drop-through)))
(parallel (start-memory read)
	  (assign a-temp top-of-stack-a)
	  (decrement-stack-pointer))
(for-effect (popval))			;Adjust stack during memory wait
(parallel (transport cdr)		;Follow any forwarding pointer
	;Can’t do with temporary memory control
	;(incrment-pma)			;Access cdr cell
	  (if (cdr-code? memory-data cdr-normal)
	      (sequential
	        ;Extra code inserted for temporary memory control
	        (assign vma (1+ vma))
		(parallel	;Note second cell not transported
		 (store-contents a-temp cdr-nil)
		 (next-instruction))
		);extra parenthesis for temporary memory control (slow RPU)
	    (drop-through)))
;; This is the abnormal case. Trap out to macrocode to allocate a new
;; 2-word cons cell and forward the old one to it. But first, check
;; for rplacd’ing something to nil, which we can do.
(if (not (data-type? a-temp dtp-nil))
    (take-post-trap rplacd-escape restore-stack)
  (drop-through))
(assign vma (amem (stack-pointer 1))) ;PMIA was already changed, restart
(start-memory read write)
(nop)
(parallel (assign memory-data (set-cdr memory-data cdr-nil))
	  (start-memory write)
	  (next-instruction)))

F:>lmach>ucode>array.lisp.94

;;; -*- Mode:Lisp; Package:Micro: Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Simple array referencing/storing microcode












; These are written assuming that AS-1 and related instructions
; are known by the compiler to destroy the TOS register. The cases
; where this matters are both rare and easily recognized in the
; final-assembly phase; it doesn’t seem worth spending either time
; or hardware to fix this architectural messiness.

; This is written assuming the presence of the mapping prom on the
; input to the R register, so that the index can be shifted right
; before adding to the base address, when accessing a byte array.
; Removing this from the hardware would simply make byte arrays one
; cycle slower.

; Note: we depend on the maximum number of bits in an array subscript
; to be 27. This is because when LDB’ ing out the word-offset part we
; have to use a fixed byte-size, and when DPB’ing the byte-offset part
; we can’t afford to have bits rotated around from the high end come in
; at the bottom (this is because we have to use ROTATE rather than DPB
; due to a conflict for the magic-number field when loading BYTE-R.)
; The limitation to 27 bits is only serious for bit arrays, which can
; be a maximum of 16 megabytes long.

; We assume that instruction pclsring can set back the stack-pointer.

; I made storing into a Q-type array do a read pause write rather
; than just a write. This costs one extra cycle, but allows there
; to be an invisible pointer in the array. (In fact, putting an
; invisible pointer there does not work an the A machine, but I
; suspect the MAR is going to be implemented with invisible pointers
; in the L.) This also means that Q-list arrays do not need a separate
; dispatch code.

;Get defmicro and all his hosts
#M
(declare (muzzled t)	;bitches about haulong
	 (cond ((not (status feature lmucode))
		     (load 'udcls)
		     (loop while nil)
		     (format nil "~{~<~>~}" nil))))

;More kludges for temporary memory control
(reserve-scratchpad-memory 2430 2434)
4,887,235
	555	556

(defareg a-memory-data)		;Save memaory-data here until we have the real
				;memory control which doesn’t require such exquisite timing
(defareg a-array-base)		;Used in 2-D array code
(defareg a-index-offset)

;Define the basics of the array format, see <LMARCH>DATA third page
;The definitions are in SYSDEF now.

;Set up the symbolic names of the field values for dispatching
(associate-dispatch-cues array-dispatch-field *array-dispatch-codes*)
(associate-dispatch-cues array-register-dispatch-field *array-register-dispatch-codes*)
(associate-dispatch-cues array-type-field *array-type-codes*)

;We need symbolic sources for setting up array registers
(define-enumerated-value-constants *array-register-dispatch-codes*)
(define-enumerated-value-constants *array-dispatch-codes*)

;Hardware simulation

;Given an array-dispatch-field or array-register-dispatch-field,
;generates the 40-reflected byte rotate
;which will extract the word part of the subscript.
;This is only allowed to depend on the low 3 bits of the field,
;due to PAL pinout limitations.
(defun array-index-shift-prom (dispatch)
  (nth (logand 7 dispatch) '(33 34 35 36 37 0 0 0)))

;;--- New scheme of things ---

;;;Subroutines on this page are called to decode an array, except in the
;;;special optimized cases which are open-coded,

;;;Decode a 1-dimensional array. Entered with the array in the vma and b-vma
;;;(it has been type-checked) and the subscript in the top-of-stack
;;;register. Returns with the following stored off the end of the stack:
;;;	(amem (stack-pointer 1))	Control word, as used with array registers
;;;					This encodes the format of array elements
;;;	(amem (stack-pointer 2))	Base pointer
;;;	(amem (stack-pointer 3))	Upper bound
;;;top-of-stack contains the subscript which has been adjusted by the
;;;index-offset and lower bound, if any. Thus this is a zero-origin
;;;subscript relative to the base pointer. Ths subscript has been
;;;checked against the lower bound if it is non-zero, so that an
;;;unsigned comparison against the upper bound will do all necessary
;;;bounds checking. top-of-stack is not copied into top-of-stack-a.
;;;Since the state is all stored off the end of the stack, this is
;;;freely pclsrable.
;;;See also array-setup-nd, for n-dimensional arrays.

;Micro to make the source code more concise
(defmicro array-setupx (type-code)
  `(parallel
    (assign (array-register-dispatch-field (amem (stack-pointer 1))) ,type-code)
    (return)))

(defucode array-setup-1d
  ;Fetch first word of array prefix
  (parallel (start-memory read)
	    (assign (amem (stack-pointer 1)) array-register-event-count))
  (parallel (nop)		;Time for memory
	    (jump array-setup-1d-a)))

;Similar but initializes the subscript in TOS to zero during free time
(defucode array-setup-1d-zero
  ;Fetch first word of array prefinx
  (parallel (start-memory read)
	    (assign (amem (stack-pointer 1)) array-register-event-count))
  (parallel (assign top-of-stack (set-type (b-constant 0) dtp-fix))
	    (jump array-setup-1d-a)))

;Similar for when stuff has already been fetched from memory
(defucode array-setup-1d-mem
  (parallel (assign (amem (stack-pointer 1)) array-register-event-count)
	    (jump array-setup-1d-a)))

(defucode array-setup-1d-a
  ;Extract length from header, assuming fast case, and dispatch on kind
  (parallel
   (declare-memory-timing data-cycle)	;entered with cycle in progress
   (transport header)
   (assign a-memory-data memory-data))	;temporary memory control
  (parallel
   (assign (amem (stack-pointer 3))
	   (set-type (array-normal-length-field a-memory-data) dtp-fix))
   (dispatch-after-next (array-dispatch-field a-memory-data)
     ((%array-dispatch-1-bit) (array-setupx %array-register-dispatch-1-bit))
     ((%array-dispatch-2-bit) (array-setupx %array-register-dispatch-2-bit))
     ((%array-dispatch-4-bit) (array-setupx %array-register-dispatch-4-bit))
     ((%array-dispatch-8-bit) (array-setupx %array-register-dispatch-8-bit))
     ((%array-dispatch-16-bit) (array-setupx %array-register-dispatch-16-bit))
     ((%array-dispatch-word) (array-setupx %array-register-dispatch-word))
     ((%array-dispatch-boolean) (array-setupx %array-register-dispatch-boolean))
4,887,235
	557	558
     ((%array-dispatch-leader) array-setup-with-leader) ;Short array with leader
     ((%array-dispatch-short-indirect) array-setup-short-indirect) ;Displaced or indirect
     ((%array-dispatch-long) array-setup-long)		;General long form
     (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Set basepointer to word containing first array element, assuming fast case
  (parallel (assign (amem (stack-pointer 2))
		    (set-type (1+ vma) dtp-locative))
	    (take-dispatch)))

(defucode array-setup-with-leader
  ;Find the correct length and base address, dispatch on type
  (assign b-temp-2		;Can’t overlap this due to # conflict
	  (+ b-vma (array-leader-length-field a-memory-data) 1))
     ;--- Above conflict might be fixed by exploiting the fact(?)
     ;--- that b-vma already contains a dtp-locative tag, so that
     ;--- we need only set tne high part of the type field.
     ;--- Wouid gave to add a new macro for this.
  (parallel
   (assign (amem (stack-pointer 3))
	   (set-type (array-short-length-field a-memory-data) dtp-fix))
   (dispatch-after-next (array-type-field a-memory-data)
     ((art-1b) (array-setupx %array-register-dispatch-1-bit))
     ((art-2b) (array-setupx %array-register-dispatch-2-bit))
     ((art-4b) (array-setupx %array-register-dispatch-4-bit))
     ((art-8b art-string) (array-setupx %array-register-dispatch-8-bit))
     ((art-16b art-fat-string) (array-setupx %array-register-dispatch-16-bit))
     ((art-q art-q-list) (array-setupx %array-register-dispatch-word))
     ((art-boolean) (array-setupx %array-register-dispatch-boolean))
     (otherwise (signal-error unimplemented-or-illegal-array-type))))
  (parallel
   (assign (amem (stack-pointer 2))
	   (set-type b-temp-2 dtp-locative))
   (take-dispatch)))

(defucode array-setup-short-indirect
  ;Error if negative inubsoript
  (parallel
   (error-if (minus-fixnum top-of-stack) illegal-subscript)
   (assign b-temp a-memory-data))	;To free up AMWA in cycle after next
  ;Get the length
  (assign (amem (stack-pointer 3))
	  (set-type (array-short-indirect-length-field a-memory-data)
		    dtp-fix))
  ;Get the index offset and add it in to the subscript and upper bound
  (parallel	;This instruction can’t be flushed, t-o-s .ne. t-o-s-a
   (assign a-temp (array-short-indirect-offset-field b-temp))
   (assign b-temp obus))
  (assign (amem (stack-pointer 3))
	  (set-type (+ (amem (stack-pointer 3)) b-temp) dtp-fix))
  (assign top-of-stack
	  (set-type (+ a-temp top-of-stack) dtp-fix))
  ;Advance to second word of prefix (indirect pointer or displace
  ;address), and copy first word for dispatch in next cycle
  (parallel
   (assign b-temp-2 a-memory-data)
   ;tempcrary memory control can’t do this
   ;(increment-pma)
   )
;For temporary memory control, read second word the slow way
  (assign vma (1+ vma))
  (start-memory read)
  (nop)
  (assign a-memory-data memory-data)	;temporary memory control
  ;Decide whether displaced or indirect, dispatch assuming displaced.
  (parallel
   (if (data-type? a-memory-data dtp-locative dtp-fix)
       (parallel (assign (amem (stack-pointer 2)) a-memory-data)
		 (take-dispatch))
       (parallel (assign (amem (stack-pointer 2)) a-memory-data)
		 (call-and-dispatch-upon-return array-setup-1d-indirect)))
   (dispatch-after-next (array-type-field b-temp-2)
     ((art-1b) (array-setupx %array-register-dispatch-1-bit))
     ((art-2b) (array-setupx %array-register-dispatch-2-bit))
     ((art-4b) (array-setupx %array-register-dispatch-4-bit))
     ((art-8b art-string) (array-setupx %array-register-dispatch-8-bit))
     ((art-16b art-fat-string) (array-setupx %array-register-dispatch-16-bit))
     ((art-q art-q-list) (array-setupx %array-register-dispatch-word))
     ((art-boolean) (array-setupx %array-register-dispatch-boolean))
     (otherwise (signal-error unimplemented-or-illegal-array-type)))))

(defucode array-setup-long
  ;Rewrite this code later when temporary memory control is flushed
  ;Advance to second word of prefix (indirect pointer/base address)
  ;and copy first word for later dispatch. b-temp must be left around for 2d-array-index
  (parallel
   (assign b-temp a-memory-data)
   ;temporary memory control can’t do this
   ;(increment-pma)
   )
  ;For temporary memoru control, read second word the slow uay
  (assign vma (1+ vma))
4,887,235
	559	560
  (start-memory read)
  (nop)
  ;Decide whether it’s indirect pointer or base address and stash it
  (parallel
   (assign (amem (stack-pointer 2)) memory-data)
   (if (data-type? memory-data dtp-locative dtp-fix)
       ;In this case there is no index offset
       (sequential
        ;Get the length the slow way
	(assign vma (1+ vma))
	(start-memory read)
	(dispatch-after-next (arrray-type-field b-temp)
	  ((art-1b) (array-setupx %array-register-dispatch-1-bit))
	  ((art-2b) (array-setupx %array-register-dispatch-2-bit))
	  ((art-4b) (array-setupx %array-register-dispatch-4-bit))
	  ((art-8b art-string) (array-setupx %array-register-dispatch-8-bit))
	  ((art-16b art-fat-string) (array-setupx %array-register-dispatch-16-bit))
	  ((art-q art-q-list) (array-setupx %array-register-dispatch-word))
	  ((art-boolean) (array-setupx %array-register-dispatch-boolean))
	  (otherwise (signal-error unimplemented-or-illegal-array-type)))
	(parallel
	 (assign (amem (stack-pointer 3)) memory-data)
	 (take-dispatch)))
     ;Indirect cace, with index offset
     (sequential
      ;Get the length the slow way
      (assign vma (1+ vma))
      (start-memory read)
	;Error if negative subscript
	(error-if (minus-fixnum top-of-stack) illegal-subscript)
	(assign b-temp-2 memory-data)
	;Get the index offset and add it in to the subscript and upper bound
	(assign vma (1+ vma))
	(start-memory read)
	(nop)
	(assign a-memory-data memory-data)
	(assign (amem (stack-pointer 3))
		(set-type (+ a-memory-data b-temp-2) dtp-fix))
	(dispatch-after-next (array-type-field b-temp)
	  ((art-1b) (array-setupx %array-register-dispatch-1-bit))
	  ((art-2b) (array-setupx %array-register-dispatch-2-bit))
	  ((art-4b) (array-setupx %array-register-dispatch-4-bit))
	  ((art-8b art-string) (array-setupx %array-register-dispatch-8-bit))
	  ((art-16b art-fat-string) (array-setupx %array-register-dispatch-16-bit))
	  ((art-q art-q-list) (array-setupx %array-register-dispatch-word))
	  ((art-boolean) (array-setupx %array-register-dispatch-boolean))
	  (otherwise (signal-error unimplemented-or-illegal-array-type)))
	(parallel
	 (assign top-of-stack
		 (set-type (+ a-memory-data top-of-stack) dtp-fix))
	 (call-and-dispatch-upon-return array-setup-1d-indirect))))))


;This is a modified version of the above (array-setup-1d-a) which handles the
;recursion into a short-indirect array, We only want the corrected
;base address and any associated index offset.
;The A-machine sometimes checks the length of the two arrays
;against each other; we will never do that and assume things
;were correctly set up by make-array, and that no one adjusts
;the size of an indirected-to array downward. The check is
;very difficult when the array types differ.
(defcode array-setup-1d-indirect
  (parallel (check-arg-type array (amem (stack-pointer 2)) dtp-array)
	    (assign vma (amem (stack-pointer 2)))
	    (assign b-vma (amem (stack-pointer 2))))
  ;Fetch first word of array prefix
  (parallel (start-memory read)
	    (assign (amem (stack-pointer 1)) array-register-event-count))
  (nop)					;Time for memory
  ;Dispatch on kind
  (parallel
   (transport header)
   (assign a-memory-data memory-data)		;temporary memory control
   (dispatch-after-next (array-dispatch-field memory-data)
     ((%array-dispatch-1-bit %array-dispatch-2-bit %array-dispatch-4-bit
       %array-dispatch-8-bit %array-dispatch-16-bit %array-dispatch-word
       %array-dispatch-boolean) (return))	;Arrays of the first kind
     ((%array-dispatch-short-2d) (return))	;Base address same as first kind
     ((%array-dispatch-leader)			;Short array with leader
      ;Adjust base address
      (assign b-temp-2		;Can’t overlap this due to # conflict
	      (+ b-vma (array-leader-length-field a-memory-data) 1))
      (parallel
       (assign (amem (stack-pointer 2))
	       (set-type b-temp-2 dtp-locative))
       (return)))
      ((%array-dispatch-short-indirect)		;Displaced or indirect
       ;Error if negative subscript
       (parallel
	(error-if (minus-fixnum top-of-stack) illegal-subscript)
	(assign b-temp-2 a-memory-data))	;To free up AMWA in next cycle
       ;Get the index offset and add it in to the subscript and upper bound
4,887,235
	561	562
	(parallel
	 (assign a-temp (array-short-indirect-offset-field b-temp-2))
	 (assign b-temp-2 obus))
	(assign (amem (stack-pointer 3))
		(set-type (+ (amem (stack-pointer 3)) b-temp-2) dtp-fix))
	(parallel
	 (assign top-of-stack (set-type (+ a-temp top-of-stack) dtp-fix))
	 ;temporary memory control can’t do this
	 ;(increment-psa)
	 )
	;For temporary memory control, read second word the slow way
	(assign vma (1+ vma))
	(start-memory read)
	(nop)
	;Decide whether displaced or indirect.
	(parallel
	 (assign a-memory-data memory-data)	;temporary memory control
	 (if (data-type? memory-data dtp-locative dtp-fix)
	     (parallel (assign (amem (stack-pointer 2)) a-memory-data)
		       (return))
	     (parallel (assign (amem (stack-pointer 2)) a-memory-data)
		       (jump array-setup-1d-indirect)))))	;Indirect loop
      ((%array-dispatch-long %array-dispatch-long-multidimensional) ;General long form
	;Note that we don’t care how many dimensions the indirected-to array has.
	;Rewriite this code later when tempnrary memory control is flushed
	;Advance to second word of prefix (indirect pointer/base address)
         ;temporary memory control can’t do this
         ;(incrcment-pma)
       ;For temporary memory control, read second word the slow way
       (assign vma (1+ vma))
       (start-memory read)
       (nop)
       ;Decide whether it’s indirect pointer or bass address and stash it
       (parallel
	(assign (amem (stack-pointer 2)) memory-data)
	(if (data-type? memory-data dtp-locative dtp-fix)
	;In this case there is no index offset
	(sequential
	 ;Get the length the slow way
	 (assign vma (1+ vma))
	 (start-memory read)
	 (nop)
	 (parallel
	  (assign (amem (stack-pointer 3)) memory-data)
	  (return)))
	;Indirect case, with index cffset
	(sequential
	;Get the length the slow way
	 (assign vma (1+ vma))
	 (start-memory read)
	 ;Error if necative subacript
	 (error-if (minus-fixnum top-of-stack) illegal-subscript)
	 (assign b-temp-2 memory-data)
	 ;Get tne index offset and add it in to the subscript and upper bound
	 (assign vma (1+ vma))
	 (start-memory read)
	 (nop)
	 (assign a-memory-data memory-data)
	 (assign (amem (stack-pointer 3))
		 (set-type (+ a-memory-data b-temp-2) dtp-fix))
	 (parallel
	  (assign top-of-stack
		  (set-type (+ a-memory-data top-of-stack) dtp-fix))
	  (jump array-setup-1d-indirect))))))
      (otherwise (signal-error unimplemented-or-illegal-array-type))))
   ;Set basepointer to word containing first array element, assuming fast case
   (parallel (assign (amem (stack-pointer 2))
		     (set-type (1+ vma) dtp-locative))
	     (take-dispatch)))

;Set up an array leader as a "Q" array. If no leader, make it zero
;long since some things call this to test for the presence of a leader.
;Things that really want a leader will then get an error.
;top-of-stack is not touched, since indirection and offset don’t
;apply to leaders.
(defucode array-setup-leader
  ;Fetch first word of array prefix
  (parallel (start-memory read)
	    (assign (amem (stack-pointer 1)) array-register-event-count))
  ;Set up type as Q
  (assign (array-register-dispatch-field (amem (stack-pointer 1)))
	  %array-register-dispatch-word)
  ;Dispatch on kind
  (parallel
   (transport header)
   (assign b-temp memory-data)
   ;Initialize length to zero, assuming no leader is present
   (assign (amem (stack-pointer 3)) (set-type (b-constant 0) dtp-fix))
   (dispatch-after-next (array-dispatch-field memory-data)
     ((%array-dispatch-1-bit %array-dispatch-2-bit %array-dispatch-4-bit
       %array-dispatch-8-bit %array-dispatch-16-bit %array-dispatch-word
4,887,235
	563	564
       %array-dispatch-boolean) (return))	;Arrays of the first kind
     ((%array-dispatch-leader)			;Short array with leader
      (parallel
       (assign (amem (stack-pointer 3))
	       (set-type (array-leader-length-field b-temp) dtp-fix))
       (return)))
     ((%array-dispatch-short-indirect %array-dispatch-short-2d) (return)) ;no leader
     ((%array-dispatch-long %array-dispatch-long-multidimensional)
      (assign (amem (stack-pointer 3))		;Long array, may have leader
	      (set-type (array-long-leader-length-field b-temp) dtp-fix))
      (parallel
       (assign (amem (stack-pointer 2))
	       (set-type (+ vma (array-long-prefix-length-field b-temp)) dtp-fix))
       (return)))
     (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Set basepointer to word containing first leader element, assuming fast case
  (parallel (assign (amem (stack-pointer 2))
		    (set-type (1+ vma) dtp-locative))
	    (take-dispatch)))

;Setup an array as if it were 1-dimensional, no matter how many dimensions
;it really has
(defucode array-setup-force-1d
  ;Fetch first word of array prefix
  (parallel (start-memory read)
	    (assign (amem (stack-pointer 1)) array-register-event-count))
  (nop)			;time for memory
  ;Extract length from header, assuming fast case, and dispatch on kind
  (parallel
   (declare-memory-timing data-cycle)	;entered with cycle in progress
   (transport header)
   (assign a-memory-data memory-data))	;temporary memory control
  (parallel
   (assign (amem (stack-pointer 3))
	   (set-type (array-normal-length-field a-memory-data) dtp-fix))
   (dispatch-after-next (array-dispatch-field a-memory-data)
     ((%array-dispatch-1-bit) (array-setupx %array-register-dispatch-1-bit))
     ((%array-dispatch-2-bit) (array-setupx %array-register-dispatch-2-bit))
     ((%array-dispatch-4-bit) (array-setupx %array-register-dispatch-4-bit))
     ((%array-dispatch-8-bit) (array-setupx %array-register-dispatch-8-bit))
     ((%array-dispatch-16-bit) (array-setupx %array-register-dispatch-16-bit))
     ((%array-dispatch-word) (array-setupx %array-register-dispatch-word))
     ((%array-dispatch-boolean) (array-setupx %array-register-dispatch-boolean))
     ((%array-dispatch-leader) array-setup-with-leader) ;Short array with leader
     ((%array-dispatch-short-indirect) array-setup-short-indirect) ;Displaced or indirect
     ((%array-dispatch-long %array-dispatch-long-multidimensional) array-setup-long)
     ((%array-dispatch-short-2d) arroy-setup-short-2d-as-1d)
     (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Set basepointer to word containinq first array element, assuming fast case
  (parallel (assign (amem (stack-pointer 2))
		    (set-type (1+ vma) dtp-locative))
	    (take-dispatch)))

(defucode array-setup-short-2d-as-1d
  ;; Must compute length by multiplication
  (assign b-temp (array-columns-field a-memory-data))
  (write-mpy-x b-tem’p unsigned)
  (assign b-temp (dpb a-memory-data 9 16. 0)) ;array-rows-field in left half
  (write-mpy-y-from-high b-temp unsigned)
  (dispatch-after-next (array-type-field a-memory-data)
    ((art-1b) (array-setupx %array-register-dispatch-1-bit))
    ((art-2b) (array-setupx %array-register-dispatch-2-bit))
    ((art-4b) (array-setupx %array-register-dispatch-4-bit))
    ((art-8b art-string) (array-setupx %array-register-dispatch-8-bit))
    ((art-16b art-fat-string) (array-setupx array-register-dispatch-16-bit))
    ((art-q art-q-list) (array-setupx %array-register-dispatch-word))
    ((art-boolean) (array-setupx %array-register-dispatch-boolean))
    (otherwise (signal-error unimplemented-or-illegal-array-type)))
  (parallel
   (assign (amem (stack-pointer 3)) (set-type mpy-product dtp-fix))
   (take-dispatch)))

;;; 1-dimensional array accessing instructions

;Format 3: Array and subscript on the stack
(definst ar-1 (no-operand needs-stack)
  ;First step is to check operand types and fetch array header
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack))
  (parallel (start-memory read)
	    (check-arg-type subscript top-of-stack-a dtp-fix)
	    (jump ar-1-common)))

;Format 1: Array on the stack, subscript as unsigned immediate argument
(definst ar-1-immed unsigned-immediate-operand
  ;First step is to check operand types and fetch array header
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a))
  (parallel (start-memory read)
4,887,235
	565	566
	    (pushval macro-unsigned-immediate)
	    (jump ar-1-common)))

;Format 2: Array on the stack, subscript in local variable
(definst ar-1-local address-operand
  ;First step is to check operand types and fetch array header
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a))
  (parallel (start-memory read)
	    (check-arg-type subscript address-operand dtp-fix)
	    (pushval address-operand)
	    (jump ar-1-common)))

;This micro is used inside the dispatch table below. Must be defined
;first due to 1-pass microcomiler.
(defmicro ar-1-ucode (byte-size &optional boolean-hack (bounds 'a-temp))
  `(array-ucode-read ,byte-size ,boolean-hack top-of-stack ,bounds pop2push))

;This is the version for the slow case
(defmicro ar-1-hair (byte-size &optional boolean-hack (bounds (amem (stock-pointer 3))))
  `(array-ucode-read ,byte-size ,boolean-hack top-of-stack ,bounds pop2push))

;Microcode shared with array registers, see below
(defmicro array-ucode-read (byte-size boolean-hack index bounds result)
  `(sequential
    ;Run the memory, start read, check bounds
    (parallel
     (start-memory read)
     ,@(and bounds
	    `((check-fixnum-b ,index)		;Error if bad
	      (error-if (lesser-or-equal-fixnum-unsigned ,bounds ,index)
			illegal-subscript))))
    ;Set up byte-r register from low bits of index
    ,(if (eq byte-size 'Word) '(nop)
       `(assign byte-r
		(- (a-constant 40)
		   (rotate ,index ,(1- (haulong byte-size)))
		   ;(dpb ,index				;byte source
		   ;    ,(- 6 (haulong byte-size))	;ss
		   ;    ,(1- (haulong byte-size))	;pp
		   ;    0)				;no merge
		   )))
    ;Extract answer and return it as result of instruction
    ,(if (not boolean-hack)
	 `(parallel (transport data) 	;Even If byte, in case of MAR invz
		    (,result
		     ,(if (eq byte-size 'Word)
			  'memory-data
			  `(set-type (ldb memory-data ,byte-size byte-r)
				     dtp-fix)))
		    (next-instruction))
       `(if (ldb-bit-test memory-data byte-r)
	    (parallel (,result quote-t) (next-instruction))
	    (parallel (,result quote-nil) (next-instruction))))))

;Common microcode for all AR-1 instructions
;Memory is reading array header, top-of-stack register has subscript.
;Weird hacks:
;There are two arguments on the stack (in some cases one was put there bogusly
; and must be popped off again if we pclsr out).
;array-index-shift-prom is a function of current dispatch
; and gives the proper left rotation to extract the word part
; of the index.
;The byte length for the word part of the index is 27. This
; makes the maximum array size 1/2 of virtual memory, which is plenty.

(defucode ar-1-common
  (parallel (nop)				;Time for memory cycle
	    (declare-memory-timing active-cycle))
  ;Extract length from header, assuming fast case
;;XXXbrad - oops; page obviously out of place
3600 Microcode	19	Traps


The machine also provides several special-case dispatches, which were added to speed up
various critical operations. The dispatch-after-next micro recognizes these automatically;
they need not be programmed specially. When one of the special-case fields of the Abus is
dispatched upon, the byte-extraction hardware is left free, allowing a different byte to be
operated on simultaneously, or avoiding the usurpation of microinstruction fields used to
control both byte extraction and other things. See the hardware documentation for a list
of the special-case fields.
4,887,235
	567	568
take-dispatch	Micro
dispatch-after-next only takes effect if take-dispatch is executed in the following
cycle. In the hardware, dispatching works by storing the address of the selected clause in
the NPC register, and take-dispatch means to take the next microinstruction from the
address in the NPC.
long-dispatch address	Micra
Jump to the control-memory address given by the low 14 bits of the datum, address. The
address is stored in the NPC register and the jump only happens if take-dispatch is used
in the following cycle, long-dispatch allows dispatches on more than 4 bits to be done,
although usually more slowly. Currently the dispatch clauses must be defined with
defucode-at-loc.


5.4	Traps
trap-if predicate true	Micro
If predicate is true, take the next microinstruction from true; otherwise take the next
microinstruction normally (either from the normal successor or under the control of any
other flow-of-control micros done in parallel). The true clause is exactly like an If clause
(of course (drop-through) is almost useless here).

The difference between trap-If and If is threefold: It is legal to do trap-If in parallel
with other flow-of-control micros, most commonly next-Instruction. If the predicate is
true, the side-effects of the current microinstruction are suppressed. If the trap is taken,
the current microinstruction takes twice as long to execute as it normally would.


A very important thing to note is that trapping pushes the NPC register onto the
microcode subroutine stack. Thus trap-It is not equivalent to an If and a goto. The trap
handler should either discard the saved NPC by using the trap-no-save micro, or use the
trap-save micro to save the rest of the machine state (the CPC), in which case the
trap-restore micro may be used to retry the trapped microinstruction.

Traps are used to program exception cases while allowing the normal case to run at
maximum speed, with no overhead for checking for the exception.

;Dispatch to appropriate accessing routine
(parallel (transport header)
(assign a-temp (array-normal-length-field memory-data))
(assign byte-r array-index-shift-prom)
(dispatch-after-next (array-dispatch-field memory-data)
  ((%array-dispatch-1-bit) (ar-1-ucode 1))
  ((%array-dispatch-2-bit) (ar-1-ucode 2))
  ((%array-dispatch-4-bit) (ar-1-ucode 4))
  ((%array-dispatch-8-bit) (ar-1-ucode 8))
  ((%array-dispatch-16-bit) (ar-1-ucode 16.))
  ((%array-dispatch-word) (ar-1-ucode Word))
  ((%array-dispatch-boolean) (ar-1-ucode 1 t))
  ((%array-dispatch-leader) (goto ar-1-with-leader))
  ((%array-dispatch-short-indirect) (goto ar-1-hair))	;all others
  ((%array-dispatch-long) (goto ar-1-hair))
  (otherwise (signal-error unimplemented-or-illegal-array-type))))
;Set VMA to word containing array element, assuming fast case,
;but leave B-VMA pointing to the original array header.
(parallel (assign vma (+ vma (ldb top-of-stack 27. byte-r) 1))
	  (take-dispatch)))

;AR-1 of a short 1-dimensional array that has a leader.
;3 cycles slower than fast case
(defucode ar-1-with-leader
  ;For temporary memory control, must retrieved goddamn memory data
  ;which there weren’t the data paths to save earlier
  (assign vma b-vma)
  (start-memory read)
  (nop)
  (assign a-memory-data memory-data)
  ;Point vma at the first data word in the array
  (assign vma a-memory-data) ;Kludqe for temporary memory control (field overlap)
  (assign vma (+ (array-leader-length-field vma) b-vma 1))
4,887,235
	569	570
;Dispatch on the array type field
              (parallel (assign a-temp (array-short-length-field a-memory-data))
			(assign byte-r array-index-shift-prom)
			(dispatch-after-next (array-type-field a-memory-data)
			  ((art-1b) (ar-1-ucode 1))
			  ((art-2b) (ar-1-ucode 2))
			  ((art-4b) (ar-1-ucode 4))
			  ((art-8b art-string) (ar-1-ucode 8))
			  ((art-16b art-fat-string) (ar-1-ucode 16.))
			  ((art-q art-q-list) (ar-1-ucode Word))
			  ((art-boolean) (ar-1-ucode 1 t))
			  (otherwise (signal-error unimplemented-or-illegal-array-type))))
;Point vma at the addressed data word
(parallel (assign vma (+ vma (ldb top-of-stack 27. byte-r)))
	  (take-dispatch)))

;Hairier cases of AR-1.
(defucode ar-1-hair
  (parallel (assign vma b-vma)			;Find out everything about this array
	    (call-and-return-to array-setup-1d ar-1-hair-a)))

(defucode ar-1-hair-a
  (parallel
   (assign byte-r array-index-shift-prom)
   (dispatch-after-next
         (array-register-dispatch-field (amem (stack-pointer 1)))
     ((%array-register-dispatch-1-bit) (ar-1-hair 1))
     ((%array-register-dispatch-2-bit) (ar-1-hair 2))
     ((%array-register-dispatch-4-bit) (ar-1-hair 4))
     ((%array-register-dispatch-8-bit) (ar-1-hair 8))
     ((%array-register-dispatch-16-bit) (ar-1-hair 16.))
     ((%array-register-dispatch-word) (ar-1-hair Word))
     ((%array-register-dispatch-boolean) (ar-1-hair 1 t))
     (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Set the VMA
  (parallel
   (assign vma (+ (amem (stack-pointer 2)) (ldb top-of-stack 27. byte-r)))
   (take-dispatch)))

;1-dimensional array-storing instructions

;Format 3: Value, array, and subscript on the stack
(definst as-1 (no-operand needs-stack smashes-stack)
  ;First step is to check operand type’s and fetch array header
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack))
  (parallel (start-memory read)
	    (check-arg-type subscript top-of-stack-a dtp-fix)
	    (jump as-1-common)))

;Format 1: Value and array on the stack, subscript as unsigned immediate
(definst as-1-immed (unsigned-immediate-operand smashes-stack)
  ;First step is to check operand types and fetch array header
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a))
  (parallel (start-memory read)
	    (pushval macro-unsigned-immediate)
	    (jump as-1-common))

;Format 2: Value and array on the stack, subscript in local variable
(definst as-1-local (address-operand smashes-stack)
  ;First step is to check operand types and fetch array header
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a))
  (parallel (start-memory read)
	    (check-arg-type subscript address-operand dtp-fix)
	    (pushval address-operand)
	    (jump as-1-common)))

;This micro is used inside the dispatch table below. Must be defined
;first due to 1-pass microcompiler.
;Note that since there are three values on the stack and
;we don’t return any values the stack-pointer gets decremented three times.
(defmicro as-1-ucode (byte-size &optional boolean-hack (bounds 'a-temp))
  `(parallel
    (decrement-stack-pointer)
    (array-ucode-write ,byte-size ,boolean-hack top-of-stack
		       ,bounds next-on-stack))) ;after stack-pointer decremented

;This is the version for the slow case
;--- This biter has to know that bounds checkinq in array-ucode-write
;--- happens in the first microcycle. hence *BEFORE* the
;--- decrement-stack-pointer that is done in parallel.
(defmicro as-1-hair (byte-size &optional boolean-hack (bounds '(amem (stack-pointer 3))))
  `(parallel
    (decrement-stack-pointer)
    (array-ucode-write ,byte-size ,boolean-hack top-of-stack
		       ,bounds next-on-stack)))		;..
4,887,235
	571	572
;Common microcode with array registers, see below
(defmicro array-ucode-write (byte-size boolean-hack index bounds value)
  `(sequential
    ;Run the memory, start read of word to be stored into. check bounds and subscript type
    ;Note: page fault can happen later, when write-data stored
    ;We can't check write-access here due to conflict for spec field
    (parallel
     (start-memory read)
     ,@(and bounds
	    `((check-fixnum-b ,index)		;Error if bad
	      (error-if (lesser-or-equal-fixnum-unsigned ,bounds ,index)
			illegal-subscript))))
    (parallel
     ;Get value to be stored into b-temp if numeric, a-temp if pointer
     ;Next line commented out. ses "Okay. I give in" below.
     ;(assign ,(if (eq byte-size 'Word) 'a-temp 'b-temp) ,value)
     (assign b-temp ,value)
     ;Type-check value if byte array
     ,(if (and (neq byte-size 'Word) (not boolean-hack))
	  `(check-arg-type 0 ,value dtp-fix))
     ;If boolean array, take extra cycle to get desired store data
     ,(if boolean-hack
	  `(if (data-type? ,value dtp-nil)
	       (assign b-temp (b-constant 0))
	       (assign b-temp (b-constant 1))))
     ;Set up byte-r register from low bits of index
     ,(if (neq byte-size 'Word)
	  '(assign byte-r
		   (rotate ,index ,(1- (haulong byte-size)))
		   ;(dpb ,index				;byte source
		   ;    ,(- 6 (haulong byte-size))	;ss
		   ;    ,(1- (haulong byte-size))	;pp
		   ;    0)				;no merge
		   ))
     (decrement-stack-pointer))
    ;Merge result into word read from memory and write it back.
    (parallel ,(if (eq byte-size 'Word)
		   `(sequential
	;Okay, I give in. Take an extra cycle. This allows transporting
	;in order to make it possible to set the MAR in an array, and also
	;makes it possiblo to preserve the cdr-code, for art-q-list arrays.
	;(MC ABUS to cdr-code feature could be used to preserve the cdr-code
	;for arrays that are known not to be in A-memory)
	;--- Maybe consider changing this back?
	;--- Maybe an extra dispatch code which MARs an entire array?
	(parallel (transport write)
		  (assign a-temp (merge-cdr b-temp memory-data)))
	(store-contents a-temp))
		 `(assign memory-data
			  (merge-cdr (set-type (dpb b-temp
						    ,byte-size
						    byte-r
						    memory-data)
					       dtp-fix)
				     memory-data)))
	      (start-memory write)	
	      (decrement-stack-pointer)
	      (next-instruction))))

;Common processing for AS-1.
;Value, array and subscript on the stack, array header being fetched,
(defucode as-1-common
  (parallel (nop)				;Time for memory cycle
	    (declare-memory-timing active-cycle))
  ;Extract length from header, assuming fast case
  ;Dispatch to appropriate storing routine
  (parallel (transport header)
	    (assign a-temp (array-normal-length-field memory-data))
	    (assign byte-r array-index-shift-prom)
	    (dispatch-after-next (array-dispatch-field memory-data)
	      ((%array-dispatch-1-bit) (as-1-ucode 1))
	      ((%array-dispatch-2-bit) (as-1-ucode 2))
	      ((%array-dispatch-4-bit) (as-1-ucode 4))
	      ((%array-dispatch-8-bit) (as-1-ucode 8))
	      ((%array-dispatch-16-bit) (as-1-ucode 16.))
	      ((%array-dispatch-word) (as-1-ucode Word))
	      ((%array-dispatch-boolean) (as-1-ucode 1 t))
	      ((%array-dispatch-leader) (goto as-1-with-leader))
	      ((%array-dispatch-short-indirect) (goto as-1-hair))	;all others
	      ((%array-dispatch-long) (goto as-1-hair))
	      (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Set VMA to word containing array element, assuming fast case,
  ;but leave B-VMA pointing at the original array header,
  (parallel (assign vma (+ vma (ldb top-of-stack 27. byte-r) 1))
	    (take-dispatch)))

;AS-1 of a short 1-dimensional array that has a leader,
;3 cycles slower than fast case
(defucode as-1-with-leader
;For temporary memory control, must retrieved goddamn memory data
;which there weren’t the data paths to save earlier