4,887,235
	55	56
APPENDIX
F:>lmach>ucode>BETTER-SPRINTER.LISP.17

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

; "If I have seen less far and less clearly than others, it is because
; giants were standing on my shoulders." -- Sir Isaac Oldfield

(defvar *bs-widths*)
(defvar	*bs-sem-miser-widths*)
(defvar *bs-miser-widths*)
(defvar *bs-flatsizes*)
#Q
(defvar *bs-lines* 95.)

(defun better-sprinter (form)
  (terpri)
  (better-sprinter-1 form))

(defun better-sprinter-1 (form)
  (let ((*bs-widths* nil)
	(*bs-semi-miser-widths* nil)
	(*bs-miser-widths* nil)
	(*bs-flatsizes* nil)
	#M (stream (if ^r (car outfiles) tyo)))
    (bs-print form (bs-charpos) #M (line1 stream) #Q *bs-line1*)
    '*))

4,887,235
	57	58
(defun bs-charpos ()
	#M (charpos (if ^r (car outfiles) tyo))
	#Q (funcall standard-output ':read-cursorpos ':character))

(defun bs-flatsize (form &aux tem)
  (cond ((setq tem (assq form *bs-flatsizes*))
	(cdr tem))
	(t (setq tem (flatsize form))
	(push (cons form tem) *bs-flatsizes*)
	tem)))

(defun bs-width (form &aux tem)
  (cond ((atom form) (bs-flatsize form))
	((setq tem (assq form *bs-semi-miser-widths*))
	 (car tem))
	(t (setq tem (bs-width-3 form tem))
	   (push (cons form tem) *bs-semi-miser-widths*)
	   tem)))

(defun bs-semi-miser-width (form &aux tem)
  (cond ((atom form) (bs-flatsize form))
	((setq tem (assq form *bs-semi-miser-widths*))
	 (cdr tem))
	((null (setq tem (bs-format form)))
	 (bs-width form))
	(t (setq tem (bs-width-3 form tem))
	   (push (cons form tem) *bs-semi-miser-widths*)
	   tem)))

(defun bs-miser-width (form &aux tem)
  (cond ((atom form) (bs-flatsize form))
	((setq tem (assq form *bs-miser-widths*))
	 (cdr tem))
	(t (setq tem (bs-width-2 form))
	   (push (cons form tem) *bs-miser-widths*)
	   tem)))

(defun bs-width-2 (form)
  (1+ (loop for l = form then (cdr l) ;1+ for leading open paren or apace
	    when (and (atom l) (not (null l)))
	    maximize (+ (bs-width l) 3) fixnum	;dot sp close
	    while (not (atom l))
	    when (cdr l)
	    maximize (bs-width (car l)) fixnum
	    else maximize (1+ (bs-width (car l))) fixnum)))	;+1i for close

(defun bs-width-1 (form &aux (fmt (bs-format form)))
  (cond ((null fmt)
	 (+ (bs-width (car form)) 2	;2 for open paren and space
	    (loop for l = (cdr form) then (cdr l)
		  when (and (atom l) (not (null l)))
		  maximize (+ (bs-width l) 3) fixnum ;dot sp close
		  while (nor (atom l))
		  when (cdr l)
		  maximize (bs-width (car l)) fixnum
		  else maximize (1+ (bs-width (car l))) ;1+ for close paren
		  fixnum)))
	(t (let ((head (car fmt))
		 (n-per-line (cadr fmt)))
	     (+	(loop for x in form repeat head
		      sum (1+ (bs-flatsize x)) fixnum)
		(if (zerop head) 0 1)
		(loop for l = (nthcdr head form) then ll until (null l)
		      as ll = (nthcdr n-per-line l)
		      maximize (+ (if ll -1 0) ;for close paren
				  (loop for x in l repeat n-per-line))))))))

(defun bs-width-3 (form fmt)
  (let ((head (car fmt))
	(n-per-line (cadr fmt))
	(indentation (caddr fmt)))
    (max (loop for x in form repeat head
	       sum (1+ (bs-flatsize x)) fixnum)
	 (+ indentation
	    (loop for l = (nthcdr head form) then ll until (null l)
		  as ll = (nthcdr n-per-line l)
		  maximize (+ (if ll -1	0) 	;for close paren
			      (loop for	x in l repeat n-per-line
				    sum	(1+ (bs-semi-miser-width x)) fixnum))
		  fixnum)))))

(defun bs-format (form)
  (and (not (atom form))
       (not (dotted-p form))
       (if (symbolp (car form))
	   (get (car form) 'bs-format)
	 '(0 1 1))))	;Good for selectq clauses at least

4,887,235
	59	60
(defun bs-print	(form indent line1)
  (if (atom form) (prin1 form)
    (let ((fmt (bs-format form))
	  (space (- line1 indent)))
	  (cond ((and (or (null fmt) (not (symbolp (car form))))
		      (<= (bs-flatsize form) space))
		 (prin1 form))
		((<= (bs-width form) space)
		 (bs-print-1 form indent line1 fmt))
		((and fmt (<=- (bs-semi-miser-width form) space))
		 (bs-print-3 form indent line1 fmt))
		(t (bs-miser form indent line1))))))

(defun bs-print-1 (form indent line1 fmt)
  (princ "(")
  (cond ((null fmt)
	 (bs-print (car form) (1+ indent) line1)
	 (princ " ")
	 (setq indent (bs-charpos))
	 (loop for l = (cdr form) then (cdr l)
	       when (and (atom l) (not (null l)))
	       do (princ ",  ") (bs-print l (+ indent 2) line1)
	       while (not (atom l))
	       do (bs-print (car l) indent line1)
	       when (cdr l) do (bs-terpri indent)))
	(t (let ((head (car fmt))
		 (n-per-line (cadr fmt)))
	     (bs-row-of form head (1+ indent) line1)
	     (or (zerop head) (princ " "))
	     (setq indent (bs-charpos))
	     (loop for l = (nthcdr head form) then ll until (null l)
		   as ll = (nthcdr n-per-line l)
		   do (bs-row-of l n-per-line indent line1)
		   unless (null ll) do (bs-terpri indent)))))
  (princ ")"))

(defun bs-print-3 (form indent line1 fmt)
  (princ "(")
  (let ((head (car fmt))
	(n-per-line (cadr fmt))
	(indentation (caddr fmt)))
    (bs-row-of form head (1+ indent) line1)
    (setq indent (+ indent indentation))
    (or (zerop head) (null (nthcdr head form)) (bs-terpri indent))
    (loop for l = (nthcdr head form) then ll until (null l)
	  as l = (nthcdr n-per-line l)
	  do (bs-row-of l n-per-line indent line1)
	  unless (null ll) do (bs-terpri indent)))
  (princ ")"))

(defun bs-row-of (list n indent line1)
  (or (zerop n)
      (loop for x in list as i upfrom 1
	    do (bs-print x indent line1)
	    until (= i n)
	    do (princ " ") (setq indent (bs-charpos)))))

(defun bs-terpri (indent)
  (terpri)
  (loop repeat (// indent 8) do (tyo #\tab))
  (loop repeat (\ indent 8) do (tyo #\sp)))

(defun bs-miser (form indent line1)
  (cond ((atom form) (prin1 form))
	(t (princ "(")
	   (setq indent (1+ indent))
	   (loop for l = form then (cdr l)
		 when (and (atom l) (not (null l)))
;XXXbrad end missing!
		 ))))
F:>lmach>ucode>check.lisp.116

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

; Microcode Syntax Checking

;This is an alist of all fields.
;car of an entry is the name of the field
;cadr is a list of other fields required: elements are either names
; of fields, or lists of name and acceptable values
;caddr is value checking for this field: nil to accept any value, or
; a predicate which returns t if the v3lue is OK. or a list of valid values.
;Note that some values for some of these fields are redundant with
; the spec and/or magic fields.
(defconst valid-microcode
  '((abus () (amem memory-data frame-pointer stack-pointer lbus
	      memory-data-force vma pc map	;on TMC machine
	      ))
    (amem-read-addr ((abus amem memory-data)) check-amem-addr)
    (bbus () (bmem macro-signed-immediate macro-unsigned-immediate))
4,887,235
	61	62
    (bmem-read-addr ((bbus bmem)) check-bmem-addr)
    (write-amem (amem-write-addr) (obus))
    (amem-write-addr () check-amem-non-constant-addr)
    (write-bmem (bmem-write-addr) (xbus obus))
    (bmem-write-addr (write-bmem) numberp)
    (write-lbus () (obus memory-data junk))
    (lbus-dev-addr () check-lbus-dev-addr)
    (xbus () (abus bbus product))
    (ybus () (abus bbus ybus-crocks-1 ybus-crocks-2))
    (alu () check-alu-func)
    (byte-func () check-byte-func)
    (force-obus<34-34> () (0 1 2 3 abus bbus bbus<7-6>))
    (force-obus<33-32> () (0 1 2 3 abus bbus bbus<5-4>))
    (force-obus<3l-28> () (0 1 2 3 4 5 6 7 10 11 12 13 14 15 16 17))
    (type-map () check-type-map)
    (stack-pointer () (increment decrement))
    (spec () (load-byte-r load-byte-s load-stkp load-frmp
			  load-xbas load-control load-special-maps clear-stack-adjustment
			  arthmetic-trap-enb trap-if-type-cond
			  trap-if-type-cond-or-bbus-not-fixnum multiply-and-type-check
			  crocks alub-sign-hack crocks-to-ybus multiply
			  addr-from-abus inhibit-page-tags dma address-phtc
			  check-write-access increment-inst ifu-control
			  arithmetic-trap-with-dispatch halt npc-magic awaken-task
			  write-task disable-tasking))
    (magic () (0 1 2 3 4 5 6 7 10 11 12 13 14 15 16 17))
    (magic-mask (magic) (1 2 3 4 5 6 7 10 11 12 13 14 15 16))
    (dispatch (dispatch-table magic)
	      (alub cdr-code abus<31-28> abus<25-22>
		    abus<21-18> abus<2-0> bbus<31-30>-abus<31-30>))
    (mem () (write-vma start-cycle	;proto
		       microdevice start-read start-write write-vma block-read block-write)) ;TMC
    (escape-to-lisp () nil)
    (error-table () nil)
    (declare-memory-timing () nil)
    (condition ()
	       (not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3
			  type-condition bbus-not-fixnum alub-0 ybus-31
			  not-gc-condemned-temp not-gc-this-stack not-gc-other-stack
			  equal-pointer
			  not-equal-fixnum not-equal-typed-pointer
			  not-greater-pointer not-greater-fixnum-unsigned
			  alu-31 sequence-break trace-flag-1 trace-flag-2
			  not-lbus-dev-cond mc-cond not-ctos-came-from-ifu
			  ))
    (sequencer () (popj next-instruction pushj pop push-npc pop-npc
			dismiss pop-npc-and-cpc-from-npc
			take-dispatch pushj-return-dispatch))
    (trap-enables () check-trap-enables)
    (skip-true-sequence (condition skip-false-sequence)
			check-skip-sequence)
    (skip-false-sequence (condition skip-true-sequence)
			 check-skip-sequence)
    (return-true-sequence (return-false-sequence)
			  check-skip-sequence)
    (return-false-sequence (return-true-sequence)
			   check-skip-sequence)
    (return-skip () (t))
    (jump-sequence () check-next-sequence)
    (next-sequence () check-next-sequence)
    (trap-sequence (trap-enables) check-trap-sequence)
    (dispatch-table (dispatch) check-dispatch-table)
    (arith-trap-dispatch-table (spec trap-enables) check-dispatch-table)
    (unique () (t))
    (speed () (slow-first-half slow-second-half slow very-slow))))

;Each element is a list of (field value) pairs where if the first
;one is present, the others are disallowed.
(defconst microcode-field-conflicts
  '(((xbus abus) (ybus abus) "Xbus and Ybus sources not independently selectable")
    ((xbus bbus) (ybus bbus) "Xbus and Ybus sources not independently selectable")
    ((sequencer next-instruction) (spec ifu-control) "Next inst not ready")
    ((abus vma) (mem start-read start-write block-read block-write)
     "Reading YMA uses ADDR outputs")
    ((abus lbus) (ybus abus)
     "Microdevice read is just too slow, must go into the fast side of the ALU")
))

#M (declare (*expr fieldp))  ;in UU

(declare (special *backtrace*)) ;in UU
(defvar *code*)		;So I can see the microinstruction being checkod

#M
(defun check-loses (format &rest args)
  (declare (special args))
  (let ((^w nil) (^r nil) (^q nil))
    (terpri msgfiles)
    (lexpr-funcall #'format msgfiles format args)
    (format msgfiles "~&;~{~<~%;~:; in ~S~>~)~%" *backtrace*)
    (format msgfiles "~&; Do (PPX *CODE*) to see instruction.")
    (break check-loses)))

4,887,235
	63	64
#Q
(defflavor check-loses (format-string format-args code)
  (sys:no-action-mixin dbg:special-commands-mixin error)
  :initable-instance-variables)
#Q
(defmethod (check-loses :report) (stream)
  (lexpr-funcall #'format stream format-string format-args))
#Q
(defmethod (check-loses :case :special-command :show-failing-microinstruction) ()
  "Pretty-print the microinstruction that failed"
  (ppx code)
  nil) ;NIL means stay in the debugger
#Q
(push '(:show-failing-microinstruction #\c-sh-P) dbg::*special-command-special-keys*)
#Q
(compile-flavor-methods check-loses)
#Q
(defprop check-loses t :error-reporter)
#Q
(defun check-loses (format-string &rest args)
  (signal 'check-loses ':format-string format-string
	  	       ':format-args (copylist args)
		       ':code *code*))

(defun check-conflict (code field1 field2 &optional message)
  (check-loses "~e[~A~%~](~S ~S) conflicts with (~S ~S)"
	       message field1 (get code field1) field2 (get code field2)))

(defun check-amem-addr (addr)
  (if (atom addr)
      (and (eq (typep addr) 'fixnum) (<= 0 addr) (<= addr 3777))
    (selectq (car addr)
      ((frame-pointer stack-pointer xbas) (eq (typep (cadr addr)) 'fixnum))
      (macrocode (null (cdr addr)))
      (constant (valid-constant (cadr addr)))
      (bus-address (null (cdr addr))))))

(defun check-amem-non-constant-addr (addr)
  (if (atom addr)
      (and (eq (typep addr) 'fixnum) (<= 0 addr) (<= addr 3777))
    (selectq (car addr)
      ((frame-pointer stack-pointer xbas) (eq (typep (cadr addr)) 'fixnum))
      (macrocode (null (cdr addr)))
      (bus-address (null (cdr addr))))))

(defun check-bmem-addr (addr)
  (if (atom addr)
      (and (eq (typep addr) 'fixnum) (<= 0 addr) (<= addr 377))
    (and (eq (car addr) 'constant)
	 (valid-constant (cadr addr)))))

(defun valid-constant (val)
  (or (numberp val)
      (and (listp val)
	   (eq (car val) 'build-task-state))))

(defun check-lbus-dev-addr (addr)
  (or (numberp addr)
      ;; Also used to select MC destinations
      (memq addr (selectq *machine-version*
		   ((sim proto) '(write-memory))
		   ((tmc) '(write-phta-and-asn write-vma-and-pc
			    write-lru-map write-map-a write-map-b write-both-maps))
		   ((tmc5 ifu) '(write-phta-and-asn
				 write-map-a write-map-b write-both-maps))))
      ;; Also synbol 0 card slots
      (and (listp addr)	(get (car addr)	'symbolic-lbus-slot))))

(declare (special normal-alu-functions weird-alu-functions))	;in UU

(defun check-alu-func (func)
  (cond ((memq func (if (and (or (fieldp *code* 'spec 'arithmetic-trap-enb)
				 (fieldp *code* 'spec 'arithmetic-trap-with-dispatch))
			     (bit-test 4 (get *code* 'magic)))
			weird-alu-functions
		        normal-alu-functions)))
	((memq func weird-alu-functions)
	 (check-conflict *code* 'alu 'spec
			 "ALU function is wierd, but special function and # not specified")
	 t)
	((memq func normal-alu-functions)
	 (check-conflict *code* 'alu 'spec
			 "ALU function is normal, but spec says /"weird ALU function/"")
	 t)))

(defun check-byte-func (func)
  (or (eq func 'ybus)				;Function 0
      (and (listp func)
	   (memp (first func) '(ldb dpb))	;Other funcs, decided later
	   (let ((rot (secord func)) (mask (third func)))
	     (or (and (eq (typep rot) 'fixnum) (<= 0 rot) (<= rot 37)
4,887,235
	65	66
		      (eq (typep mask) 'fixnum) (<= 1 mask) (<= mask 40))
		 (and (eq rot 'byte-r)
		      (or (eq mask 'byte-s)
			  (eq (typep mask) 'fixnum) (<= 1 mask) (<= mask 40)))
		 (and (eq rot 'macro) (eq mask 'macro))))
	   (or (null (cdddr fund))
	       (eq (cadddr func) 'merge)))))


(declare (special *data-types* *cdr-codes*))	;in SIM

;Check that types are valid, outputs are one of the 8 possible combinations,
;and no types are duplicated
(defconst type-map-possibilities
  '(() (cond) (pointer) (pointer cond)
    (trap-0) (trap-1) (trap-2 pointer) (trap-3 pointer)
    ;Alternate spellings
    (cond pointer) (pointer trap-2 (pointer trap-3)))
;XXXbrad added closing paren - missing?
  )

(defun check-type-map (x)
  (loop for ((types . outputs) . rest) on x
	always (loop for tp in types
		     always (memq tp *data-types*)
		     always (loop for (t2 . o2) in rest
				  never (memq tp t2)))
	always (member outputs type-map-possibilities)))

;This is not one field in the real machine. Some of these are inside the
;type map, also.
(defun check-trap-enables (x)
  (loop for en in x
	always (memq en '(condition-true condition-false any-stack other-stack
					 type-condition bbus-non-fixnum overflow
					 transport map-miss))))

;Try to propogate memory timing through skips.
;This is smart enough to get it in, but too dumb to know how to get it out again
(defun check-skip-sequence (seq memory-timing)
  (cond ((null seq))		;drop-through
	((symbolp seq))		;jump tag
	(t (check-microcode seq 'skip-sequence memory-timing) ;literal code
	   t)))

(defun check-next-sequence (seq)
  (cond ((symbolp seq))				;jump tag
	(t (check-microcode seq 'next-sequence) ;literal code
	   t)))

(defun check-trap-sequence (seq)
  (cond ((symbolp seq))				;jump tag
	(t (check-microcode seq 'trap-sequence)	;literal code
	   t)))

(defun check-dispatch-table (table)
  (setq table (cdr table))			;Ignore field specifier at front
  (if (not (listp table))
      (check-loses "Not table of dispatch clauses: ~S" table)
    (loop for clause in table
	  unless (eq (car clause) 'otherwise)
	  do (loop for cue in (car cause)
		   unless (numberp cue)		;good enough check for now
		   do (check-loses "~S invalid dispatch cue" cue))
	  do (cond ((atom (cadr clause)))	;goto
		   (t (check-microcode (cadr clause)
				       `(dispatch ,(car clause)))))))
  t)

(defun check-microcode (*code* where &optional memory-timing)
  (let ((*backtrace* (cons where *backtrace*)))
    (cond ((and (not (atom *code*)) (eq (car *code*) 'microinstruction))
	   (check-microcode1 *code* memory-timing))
	  ((and (not (atom *code*)) (eq (car *code*) 'microsequence))
	   (push 'microsequence *backtrace*)
	   (loop for x in (cdr *code*)
		 do (if	(and (not (atom x)) (eq (car x) 'microinstruction))
			(let ((*code* x))
			  (setq memory-timing (check-microcode1 x memory-timing)))
		      (check-loses "Invalid microcode: ~S x"))))
	  (t (check-loses "Unrecognizable microcode: ~S" *code*)))))

(defun check-microcode1 (code memory-timing &aux declared-memory-timing)
  ;; First make sure there aren't any misspelled field names, since
  ;; those typically cause spurious other messagee
  (loop for (field value) on (cdr code) by 'cddr
	when (null (assq field valid-microcode))
	do (check-loses "~S invalid microcode field name" field))
  ;; Now check inter-field consistency
  (check-field-conflicts code)
  (check-spec-and-magic-fields code)
  (check-next-address-field-consistency code)
  ;; Check the memory timing for temporary memory control
4,887,235
	67	68
  (if (setq declared-memory-timing (get code 'declare-memory-timing))
      (setq memory-timing declared-memory-timing))
  (and (fieldp code 'abus 'memory-data)
       (not (memq 'data-cycle memory-timing))
       (check-loses "Reading MD but memory is not in data-cycle (it's in ~S)" memory-timing))
  (and (fieldp code 'lbus-dev-addr 'write-memory)
       (not (memq (get code 'mem) '(start-cycle start-write block-write)))
       (check-loses "Storing into memory without starting a cycle"))
  ;; Compute memory-timing value for following cycle
  (let ((next-active (or (member '(next active-cycle) declared-memory-timing)
			 (memq (get code 'mem) '(start-cycle start-read block-read))))
	(next-data (or (member '(next data-cycle) declared-memory-timing)
		       (memq 'active-cycle memory-timing))))
    (setq memory-timing (if next-active
			    (if next-data '(active-cycle data-cycle) '(active-cycle))
			  (if next-data '(data-cycle) nil))))
  ;; On TMC machine, make sure that microdevice read/write is going in the proper
  ;; direction. Using Lbus as the Abus source implies microdevice read.
  (cond ((memq *machine-version* '(tmc tmc5 ifu))
	 (and (get code 'write-lbus)
	      (fieldp code 'abus 'lbus)
	      (check-loses "Lbus as Abus source incompatible with microdevice//VMA write"))
	 (and (get code 'write-lbus)
	      (not (memq (get code 'mem) '(microdevice write-vma)))
	      (check-loses "WRITE-LBUS without MEM// MICRODEVICE or WRITE-VMA"))
	 (and (neq *machine-version* 'ifu)
	      (fieldp code 'write-lbus 'obus)
	      (fieldp code 'abus 'memory-data)
	      (check-loses "WRITE-LBUS from OBUS but ABUS source is MEMORY-DATA;~e
			   TMC machine will write from MD rather than OBUS!"))))
  ;; Now check field values, and successor instructions
  (loop for (field value) on (cdr code) by 'cddr with tem
    as d = (assq field valid-microcode)
    when (null value)
    unless (memq field '(skip-true-sequence skip-false-sequence)) ;drop-thr
    do (check-loses "~S field has NIL value" field)
    do (loop for c in (cadr d)
	     when (atom c)
	     do (or (loop for f in (cdr code) by 'cddr thereis (eq f c))
		    (check-loses "~S field missing when ~S ~S present"
				 c field value))
	     else do (or (member (setq tem (get code (car c))) (cdr c))
			 (check-loses
			  "~S field has value ~S, invalid when ~S ~S present"
			  (car C) tem field value)))
    as checker = (caddr d)
    unless (cond ((null checker))
		 ((symbolp checker)
		  (if (memq field '(skip-true-sequence skip-false-sequence
				    return-true-sequence return-false-sequence))
		      (funcall checker value memory-timing)
		    (funcall checker value)))
		 (t (member value checker)))
    do (check-loses "~S illegal value for ~S field" value field))
  memory-timing)

(defun check-field-conflicts (code)
  (loop for ((f1 v1) (f2 . exclusions) reason) in microcode-field-conflicts
	when (eq (get code f1) v1)
	when (memq (get code f2) exclusions)
	do (check-conflict code f2 f1 reason)))

;If other fields imply values of these, check that they are really there
(defun check-spec-and-magic-fields (code &aux tem tem1)
  (and (setq tem (get code 'force-obus<31-28>))
       (not (fieldp code 'magic tem))
       (check-conflict code force-obus<31-28> 'magic))
  (cond ((or (fieldp code 'ybus 'ybus-crocks-1)
	     (fieldp code 'ybus 'ybus-crocks-2))
	 (or (fieldp code 'spec 'crocks-to-ybus)
	     (check-conflict code 'ybus 'spec))
         ;U AMWA <11> must also be free
	 (if (get code 'stack-pointer)
	     (check-conflict code 'ybus 'stack-pointer "U AMWA <11> conflict"))
	 (if (numberp (get code 'amem-write-addr))
	     (check-conflict code 'ybus 'amem-write-addr "U AMWA <11> conflict"))))
  (cond ((fieldp code 'xbus 'product)
	 (or (fieldp code 'spec 'multiply)
	     (fieldp code 'spec 'multiply-and-type-check)
	     (check-conflict code 'xbus 'spec))
	 (or (= (logand (get code 'magic) 6) 4)
	     (check-conflict code 'xbus 'magic))))
  (cond ((setq tem (get code 'trap-enables))
	 (cond ((memq 'other-stack tem)
		(or (fieldp code 'spec 'crocks)
		    (check-conflict code 'trap-enables 'spec
				    "spec//crocks needed to enable GC traps"))
		(or (equal (get code 'magic) 2)
		    (check-conflict code 'trap-enables 'magic
				    "magic number needed to enable GC traps")))
4,887,235
	69	70
	       ((memq 'any-stack tem)
		(or (fieldp code 'spec 'crocks)
		    (check-conflict code 'trap-enables 'spec
				    "spec//crocks needed to enable GC traps"))
		(or (equal (get code 'magic) 1)
		    (check-conflict code 'trap-enables 'magic
				    "magic number needed to enable GC traps")))
	       ((memq 'type-condition tem)
		(cond ((memq (get code 'spec)
			     '(arithmetic-trap-enb arithmetic-trap-with-dispatch))
		       (or (bit-test 1 (get code 'magic))
			   (check-conflict code 'trap-enables 'magic
					   "Magic number needed to enable type cond trap")))
		      ((memq (get code 'spec)
			     '(trap-if-type-cond
			       trap-if-type-cond-or-bbus-not-fixnum
			       multiply-and-type-check)))
		      (t (check-conflict code 'trap-enables 'spec
					 "Spec needed to enable type cond trap"))))
	       ((memq 'bbus-non-fixnum tem)
		(cond ((memq (get code 'spec)
			     '(arithmetic-trap-enb
			       arithmetic-trap-with-dispatch))
		       (or (bit-test 2 (get code 'magic))
			   (check-conflict code 'trap-enables 'magic
					   "Magic number needed to enable bbus type trap")))
		      ((memq (get code 'spec)
			     '(trap-if-type-cond-or-bbus-not-fixnum
			       multiply-and-type-check)))
		      (t (check-conflict code 'trap-enables 'spec
					 "Spec needed to enable bbus type trap"))))
	       ((memq 'overflow tem) 
		(or (memq (get code 'alu)
			  '(X+1-overflow X-1-overflow X+Y-overflow X-Y-overflow))
		    (check-conflict code 'trap-enables 'alu)))
	       ((memq 'map-miss tem)
		(or (fieldp code 'mem 'start-cycle)
		    (check-conflict code 'trap-enables 'mem
				    "Start-cycle not specified in MEM field"))))))

;; dispatch and magic assumed made consistent at the source
;; Decide how to encode the byte func and check for AMWA conflicts
(multiple-value-bind (byte-func magic)
     (choose-byte-func-encoding code)
  (let ((amem-uses-amwa (and (get code 'write-amem)
			     (setq tem (get code 'amem-write-addr))
			     (not (equal tem '(bus-address))) ;only uses bit 10
			     (or (setq tem1 (get code 'amem-read-addr))
				 (setq tem1 (get code 'abus)))
			     (not (equal tem tem1))))
	(bmem-uses-amwa (and (fieldp code 'spec 'crocks) (fieldp code 'magic 10)))
	(byte-uses-amwa (and (= byte-func 3) (not (bit-test 3 magic))))
	(lbus-uses-amwa (get code 'lbus-dev-addr))
	(stack-pointer-uses-amwa-11 (get code 'stack-pointer))
	(crocks-uses-amwa-11 (fieldp code 'spec 'crocks-to-ybus)))
    (if (and amem-uses-amwa bmem-uses-amwa)
	(check-conflict code 'amem-write-addr 'bmem-write-addr
			"Conflict for AMWA field"))
    (if (and amem-uses-amwa byte-uses-amwa)
	(check-conflict code 'amem-write-addr 'byte-func
			"Conflict for AMWA field"))
    (if (and amem-uses-amwa lbus-uses-amwa)
	(check-conflict code 'amem-write-addr 'lbus-dev-addr
			"Conflict for AMWA field"))
    (if (and bmem-uses-amwa byte-uses-amwa)
	(check-conflict code 'bmem-write-addr 'byte-func
			"Conflict for AMWA field"))
    (if (and bmem-uses-amwa lbus-uses-amwa)
	(check-conflict code 'bmem-write-addr 'lbus-dev-addr
			"Conflict for AMWA field"))
    (if (and byte-uses-amwa lbus-uses-amwa)
	(check-conflict	code 'byte-func 'lbus-dev-addr
			"Conflict for AMWA field"))
    ;; Unfortunately. AMWA<11> conflicts happen all over the place unless
    ;; we allow both parties to specify the same bit value. This means
    ;; that the Amem variables you write into while decrementing the
    ;; stack pointer must go in a specific half of Amem.
    (and amem-uses-amwa crocks-uses-amwa-11
	 (atom (setq tem (get code 'amem-write-addr)))
	 (neg (if (bit-test 4000 tem) 'ybus-crocks-2 'ybus-crocks-1)
	      (get code 'ybus))
	 (check-conflict code 'ybus 'amem-write-addr
			 "Conflict for AMWA <11>"))
    (and amem-uses-amwa stack-pointer-uses-amwa-11
	 (atom (setq tem (get code 'amem-write-addr)))
	 (neq (if (bit-test 4000 tem) 'increment 'decrement)
	      stack-pointer-uses-amwa-11)
	 (check-conflict code 'stack-pointer 'amem-write-addr
			 "Conflict for AMWA <11>")))))

4,887,235
	71	72
;; decide how to encode the byte-func
(defun choose-byte-func-encoding (code &aux tem)
  ;Returns byte-func field, magic field, magic-mask field, cond field, and amwa
  (if (atom (setq tem (get code 'byte-func)))
      (values 0)		;Pass Ybus
      (let ((r (second tem))
	    (s (third tem))	;Really S+1
	    (rm (eq (first tem) 'dpb))
	    (mrg (eq (fourth tem) 'merge))
	    (magic (get code 'magic)))
	(cond ;; Byte function 0 taken care of already (byte-func = ybus)
	  ;; Byte function 2 (S from COND field)
	 ((and (equal r 0) (numberp s) (not mrg) (not (get code 'condition)))
	  (values 2 nil nil (1- s)))
	  ;: Byte function 1, #2=1 case
	 ((and (equal r 20) (equal as20) (not mrg)
	       (or (not magic) (bit-test 4 magic))
	       (or (not magic)
		   (and (or (fieldp code 'spec 'multiply)
			    (fieldp code 'spec 'multiply-and-type-check))
			(not (bit-test 10 magic)))	;#3 free
		   (eq rm (bit-test 10 magic))))
	  (values 1 (if rm 14 4) 14))
	 ;; Byte function 1, #2=0 case
	 ((and (not magic) (not rm) (not mrg) (equal s 40)
	       (member r '(0 1 37)))			;Could add more...
	  (values 1 (cdr (assoc r '((0 . 3) (1 . 2) (37 . 10)))) 17))
	 ;; More of that, kludge for first cycle of multiply. Is there a better way?
	 ((and (equal magic 13) (equal r 20) (equal s 20) rm (not mrg))
	  (values 1 13 17))
	 :; Otherwise use byte function 3. requires magic number field
	 (t (let ((mage (+ (if rm 10 0) (if mrg 4 O)))
		  (cond nil)
		  (amwa nil))
	      (cond ;; Byte function 3, case 0 (R and S from AMWA)
	       ((and (numberp r) (numberp s))
		(setq amwa (dpb (1- s) 0505 r)))
	       ;; Byte function 3, case 1 (R from RREG, S from COND)
	       ((and (eq r 'byte-r) (numberp s))
		(setq cond (1- s) mage (+ mage 1)))
	       ;; Byte function 3. case 2 (R from RREG, S from SREG)
	       ((and (eq r 'byte-r) (eq s 'byte-s))
		(setq mage (+ mage 2)))
	       ;; Byte function 3, case 3 (R,S from macroinstruction,
	       ;; high S bits from COND)
	       ((and (eq r 'macro) (eq s 'macro))
		(setq mage (+ mage 3)
		      cond 'macro))	;Must fill in from opcode
	       (t (check-loses "I can find no way to encode this byte function!")))
	      (and cond (get code 'condition)
		   (check-loses "Unable to encode this byte function without using COND (func 3)"))
	      (and magic (not (= mage magic))
		   (check-loses "Unable to encode this byte function without using MAGIC (func 3)"))
	      (values 3 mage 17 cond amwa)))))))

;Make sure that anything which uses the next-address field has an explicit one
;so that the assembler doesn't try to use it to link to the next instruction
;and knows that it must use NPC instead.
(defun check-next-address-field-consistency (code &aux tem)
  ;; Arithmetic traps require either a single trap routine or a dispatch table
  (and (setq tem (get code 'trap-enables))
       (or (memq 'type-condition tem)
	   (memq 'bbus-non-fixnum tem)
	   (memq 'overflow tem))
       (not (getl code '(trap-sequence arith-trap-dispatch-table)))
       (check-loses "Arithmetic trap enabled but no trap handler specified"))
  ;; Other NAF traps require a single trap routine
  (and (setq tem (get code 'trap-enables))
       (or (memq 'condition-true tem)
	   (memq 'condition-false tem)
	   (memq 'any-stack tem)
	   (memq 'other-stack tem))
       (not (get code 'trap-sequence))
       (check-conflict code 'trap-enables 'trap-sequence
		       "NAF trap enabled but no trap handler specified"))
;; Subroutine calling requires a subroutine (separate from return to .+1)
(and (memq (get code 'sequencer) '(pushj pushj-return-dispatch))
     (not (get code 'jump-sequence))
     (not (get code 'skip-true-sequence)) ;for call-select micro
     (check-conflict code 'sequencer 'jump-sequence
		     "Subroutine call but no subroutine specified"))
;; Look for multiple demands on NAF. Note that skipping can be done
;; to .+1 if necessary (NAF otherwise tied up)
;; next-sequence can always be done by duplicating the target at the
;; next successive control memory location.
(let ((jump (get code 'jump-sequence))
      (trap (get code 'trap-sequence))
      (disp (get code 'dispatch-table))
      (arith (get code 'arith-trap-dispatch-table)))
  (and jump trap