4,887,235
	173	174
F:>lmach>ucode>ZWEI.LISP.2

;;; -*- Mode:LISP; Package:ZWEI; Base:8; Lowercase: T -*-
(login-eval (set-comtab-return-undo *standard-comtab*
	    (#\Hyper-Super-X com-micro-expand-sexp)))

(defcom com-micro-expand-sexp
	"Microexpand S-expression.  With region, microexpand region" ()
  (let ((stream (rest-of-interval-stream (point))))
    (let ((form (read stream '*eof*)))
      (and (eq form '*eof*) (barf))
      (micro:better-sprinter (micro:microexpand form))))
  dis-none)
F:>lmach>ucode>uux.lisp.8

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

; This file contains stuff that would be in UU except that it cannot be
; loaded until after the system definition file has been read in

(defconst *unduplicated-data-types*
  (remq 'dtp-fix (remq 'dtp-float *data-types* 15.) 15.))

;The type map for normal arithmetic, which has cond for non-fixnum numbers
;and bad-argument trap for non-numbers.
(defconst *arithmtic-type-map*
  `(((dtp-fix))
    ((dtp-float dtp-extended-number) cond)
    (,(types-other-than '(dtp-fix dtp-float dtp-extended-number)) trap-0)))

;Arithmetic trap dispatches on ABUS<33:32>|BBUS<33:32>.
;3 in either field can't happen, if a type check was done
;Unfortunately this isn't really true, since Bbus type checking incomplete
(defconst *arithmetic-trap-dispatch-cues-alist*
  '((extnum-extnum . 0)
    (extnum-fixnum . 1)
    (extnum-flonum . 2)
    (fixnum-extnum . 4)
    (fixnum-fixnum . 5)
    (fixnum-flonum . 6)
    (flonum-extnum . 10)
    (flonum-fixnum . 11)
    (flonum-flonum . 12)))

;Storing into memory
;The type map for normal storing, which simply identifies whether or
;not a pointer is being stored. This is what enables the gc tag hardware.
(defconst *storing-type-map*
  '(((dtp-null dtp-nil dtp-symbol dtp-extended-number
	       dtp-external-value-cell-pointer dtp-locative
	       dtp-list dtp-compiled-function dtp-array dtp-closure
	       dtp-instance dtp-header-p dtp-even-pc
	       dtp-one-q-forward dtp-header-forward dtp-odd-pc dtp-monitor-forward)
     pointer)))

;Element 0 is always the no-trap type map
(if (null *type-maps*)
    (assign-type-map nil))

F:>lmach>ucode>uu.lisp.429

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

;Primitive forms of microcode:
;	(microinstruction field value field value...)
;	(microsequence instruction instruction...)
;	  microsequence always contains at least two instructions
;	(microdata place code)
;	  place is where in the machine the data is (typically a bus)
;	  code is microcode to put it there (instruction or sequence)
;	(microcondition condition sense code)
;	  condition is the name of a skip condition in the machine
;	  and code is microcode to put a boolean condition into it
;	  sense is one of the symbols true, false
;	
;For non-primitive forms of microcode, see the defmicros below.
;Particularly important are:
;	(sequential code code code...)
;	  Generates a microsequence. Note that the last piece of code
;	  may be a microdata/uicrocondition and the right thing will happen.
;	(parallel code code code...)
;	  Does all the operations in parallel, barfing if that is impossible.
;	  When sequences are done "in parallel", the result is a sequence;
;	  the first state of a sequence is done in parallel with what comes
;	  before it in the "parallel" form, and the last state is done in
;	  parallel with what coocs after it.
4,887,235
	175	176
;-----------------------------------------------
;To do: More primitive operations
;	ALU operations need to have word length (28 or 32)
;		(actually I don't think they do)
;	ASSIGN to a byte trashes the cdr code of the word assigned to.
;	  Ought to preserve it unless it is bbus or set-cdr-code is done.
;	Can IF inside of a microdata be made to work (turn inside out)??
;	Can (PARALLEL (IF ...) FOO) move the FOO into each arm of cond?
;	Can ASSIGN be table-driven?
;	Semi-open subroutines, where the first instruction is open coded
;	and it calls off to the rest
;-----------------------------------------------

;;; Variables associated with storing the results

(defvar *ucode-alist-alist* nil)
	;Each element is (machine-version . alist)
	;Each element of that alist is (tag microcode assembled-microcode)

(defvar *top-level-code*)	;For when the compiler fondles ursines

;see *machine-version*

(defvar *need-to-link* nil)	;Set to T when new microcode defined, to NIL by linker
;;; Debugging Tools
(defvar *microexpand-trace* nil)	;Set this to T for debugging
(defvar *backtrace* nil)
(defconst non-backtraced-forms '(parallel sequential))

(defprop microinstruction (1 2 2) bs-format)
(defprop microsequence (1 1 2) bs-format)
(defprop microdata (2 2 2) bs-format)
(defprop microcondition (3 2 2) bs-format)
#M (defprop better-sprinter ((dsk lmucode) better-sprinter fasl) autoload)
(declare (*expr better-sprinter))	;Well, maybe a little better

(defvar ppf) ;Last input
(defvar ppx) ;Last output

(defun ppx (&optional (form ppf) (*microexpand-trace* *microexpand-trace*))
  (better-sprinter (setq ppx (microexpand (setq ppf form)))))

(declare (special defucode-alist))	;defvar'ed later in the file
(defun ppu (defucode)
  (better-sprinter (cadr (assp defucode (cdr (assq *machine-version* *ucode-alist-alist*))))))

#M
(defun retch (format-string &rest args)
  (declare (special args))			;For accessibility from breakpoint
  (let ((^w nil) (^r nil) (^q nil))
    (format msgfiles "~&>>Error: ")
    (lexpr-funcall #'format msgfiles format-string args)
    (format msgfiles "~& Microexpand backtrace: ~{~<~%    ~2:;~A~>~^, ~}~%"
	    *backtrace*)
    (break retch t)))

#Q
(defflavor microexpansion-error (format-string format-args backtrace)
  				(sys:no-action-mixin error)
  :initable-instance-variables)
#Q
(defmethod (microexpansion-error :report) (stream)
  (lexpr-funcall #'format stream format-string format-args)
  (format stream "~&  Microexpand backtrace: ~{~<~%    ~2:;~A~>~^, ~}~%" backtrace))
#Q
(compile-flavor-methods microexpansion-error)
#Q
(defprop retch t :error-reporter)
#Q
(defun retch (format-string &rest args)
  (signal 'microexpansion-error ':format-string format-string
	  			':format-args (copylist args)
				':backtrace *backtrace*)
  nil)

(eval-when (compile load eval)
(defun fintern (string &rest args)
  (intern (lexpr-funcall #'format nil string args))))
;;; Implementation of micros

(defun microexpand (form)
  (let ((*backtrace* *backtrace*))
    (loop as new-form = (microexpand-1 form)
	  when (eq new-form form) return form
	  do (setq form new-form))))

(defun microexpand-1 (form &aux tem)
  (cond ((atom form)
4,887,235
	177	178
	(cond ((and (symbolp form) (setq tem (get form 'atomic-micro)))
	       (push form *backtrace*)
	       tem)
	      (t form)))
	((setq tem (get (car form) 'micro))
	 (or (memq (car form) non-backtraced-forms)
	     (push (car form) *backtrace*))
	 (setq tem (funcall tem form))
	 (cond (*microexpand-trace*
		(format t "~& Microexpand of:")
		(better-sprinter form)
		(format t "~& into:")
		(better-sprinter tem)))
	 tem)
	(t form)))

(defun microexpand-to-parallel (form)
  (let ((*backtrace* *backtrace*))
    (loop as new-form = (microexpand-1 form)
	  when (eq new-form form) return form
	  do (setq form new-form)
	  when (and (not (atom form)) (eq (car form) 'parallel))
	  return form)))

(defmacro defmicro (name args &body body)
  `(eval-when (compile load eval)
  #Q (si:record-source-file-name ',name 'defmicro)
     (defun (,name micro) (+form+)
       ,(defmicro-nargs-check args)		;Check number of arguments
       (let* ,(defmicro-args args)		;Bind argument variables
	 . ,body))))

(eval-when (compile load eval)
(defun defmicro-nargs-check (pattern)	;Return code to check nargs
  (loop for p in pattern with optional = nil with required = t
	when (eq p '&optional)
	  do (setq required nil optional t)
	else when (memq p '(&rest &body))
	  return `(and (< (length +form+) ,(1+ nreq))
		       (defmicro-wrong-number-of-args +form+))
	else when (eq p '&aux)
	  do (setq required nil optional nil)
	else count optional into nopt
	 and count required into nreq
	finally (return `(or (lessp ,nreq (length +form+) ,(+ nreq nopt 2))
			     (defmicro-wrong-number-of-args +form+)))))

(defun defmicro-args (pattern)			;Return arg binding let clauses
  (loop for p in pattern with kind = '&required with idx = 0
	when (eq p '&optional)
	  do (setq kind '&optional)
	else when (eq p '&aux)
	  do (setq kind '&aux)
	else when (memq p '(&rest &body))
	  do (setq kind '&rest)
	else do (incf idx)
	  and when (atom p)
	    collect `(,p ,(selectq kind
				   ((&required &optional) `(nth ,idx +form+))
				   ((&rest) `(nthcdr ,idx +form+))
				   (otherwise nil)))
	  else collect `(,(car p)
			 ,(selectq kind
				   ((&required) `(nth ,idx +form+))
				   ((&optional) `(if (nthcdr ,idx +form+)
						     (nth ,idx +form+)
						   ,(cadr p)))
				   ((&rest) `(nthcdr ,idx +form+))
				   (otherwise (cadr p))))))

(defun defmicro-wrong-number-of-args (x)
  (retch "A defmicro was called with too many or too few arguments:~%  ~S" x))
);eval-when
;Expansion IC microcode, not Lisp: no backquotes, please.
(defmacro defatomicro (name expansion)
  `(eval-when (compile load eval)
  #Q (si:record-source-file-name ',name 'defatomicro)
     (defprop ,name ,expansion atomic-micro)))

;For internal use from other forms: don't record a source file name
(eval-when (compile load eval)
(defun add-atomicro (name expansion)
  (putprop name expansion 'atomic-micro))
); eval-when (compile load eval)

;;; Primitive micros

(declare (*lexpr paralyze))

(defmicro sequential (&body forms)
  (microsequencize (mapcar #'microexpand forms)))

4,887,235
	179	180
(defun microsequencize (list)
       (cond ((null list) nil)
	     ((null (cdr list)) (car list))
	     ((memq (caar (last list)) '(microdata microcondition))
	      (let ((data (car (last list)))
		    (*backtrace* (cons ' (microsequencize-inside-out) *backtrace*)))
		(let ((code (microsequencize (nconc (nbutlast list)
						    (ncons (car (last data)))))))
		  (if (eq (car data) 'microdata)
		      (make-microdata (cadr data) code)
		      (make-microcondition (cadr data) (caddr data) code)))))
	     (t (cons 'microsequence
		      (loop for form in list
			    when (atom form)
			      do (or (null form)
				     (retch "~S where microinstruction expected"
					    form))
			      else when (eq (car form) 'microinstruction)
			        collect form
			      else when (eq (car form) 'microsequence)
			        append (cdr form)
			      else do (retch "~S where microinstruction expected"
					     form))))))




(defmicro parallel (&body forms)
  ;Start by expanding and flattening, then merge together instructions
  ;that are supposed to be done in parallel. If we see a sequence, pick
  ;out its first and last instructions and merge them with the things
  ;before and the things after.
  (microsequencize
    (loop with current = (ncons 'microinstruction)
	  for form in (flatten-parallels forms)
	  when (atom form)
	    do (and form (retch "~S garbage in parallel construction" form))
	    else when (eq (car form) 'microsequence)
	      when (cddr form)
	        collect (merge-instructions current (cadr form)) into res
		and do (setq current (copylist (car (last form))))
;;XXXbrad (caddr form)? 
		and when (cdddr form)
		      collect (microsequencize (butlast (cddr form))) into res
		    else do nil 		;no middle
	      else do (setq current (merge-instructions current (cadr form)))
	    else do (setq current (merge-instructions current form))
	    finally (return (nconc res (ncons current))))))

(defun flatten-parallels (forms)
  (loop for form in forms
	do (setq form (microexpand-to-parallel form))
	when (and (not (atom form)) (eq (car form) 'parallel))
	  nconc (flatten-parallels (cdr form))
	else collect form))

;Smash one instruction with another, and return the result.
;Note that plist-1 is actually modified, because that's what parallel wants.
;Note that either plist can be microdata/microcondition rather than a
;micromnstruction plist. In that case, we want to return a microdata
;as our result. Both plists being data is illegal, we don't do
;nondeterministic joins. (You should store one someplace first.)
;I don't know how to merge data and conditions that could actually be useful.
;By the way, we preserve the order of operations in the plists even
;at the cost of somewhat slower computation, just to make debugging nicer.
(defun merge-instructions (plist-1 plist-2)
  (cond ((eq (car plist-1) 'microdata)
	 (cond ((eq (car plist-2) 'microdata)
		(retch "Trying two merge two pieces of data: ~S and ~S"
		       plist-1 plist-2)
		plist-1)
	       ((eq (car plist-2) 'microinstruction)
		(merge-instruction-and-data plist-2 plist-1))
	       (t (retch "~S invalid - merge-instructions" plist-2))))
	((eq (car plist-1) 'microcondition)
	 (cond ((eq (car plist-2) 'microinstruction)
		(merge-instruction-and-condition plist-2 plist-1))
	       (t (retch "~S invalid - merge-instructions" plist-2))))
	((neq (car plist-1) 'microinstruction)
	 (retch "~S invalid - merge-instructions" plist-1))
	((eq (car plist-2) 'microdata)
	 (merge-instruction-and-data plist-1 plist-2))
	((eq (car plist-2) 'microcondition)
	 (merge-instruction-and-condition plist-1 plist-2))
	((eq (car plist-2) 'microinstruction)
	 (let ((xb1 (get plist-1 'xbus)) (yb1 (get plist-1 'ybus))
	       (xb2 (get plist-2 'xbus)) (yb2 (get plist-2 'ybus)))
	   (if (or (and xb1 (eq xb1 yb2))
		   (and xb2 (eq xb2 yb1)))
	       (multiple-value (plist-1 plist-2)
4,887,235
	181	182
	   (merge-bus-scheduling plist-1 plist-2))))
	 (nconc plist-1
		(loop for (prop val2) on (cdr plist-2) by 'cddr with fcn
		      as val1 = (get plist-1 prop)
		      when (not val1)
		        collect prop and collect val2	;i,e. putprop
		      else when (equal val1 val2)
		        do nil
		      else when (setq fcn (get prop 'merge-fields))
		        do (putprop plist-1 (funcall fcn val1 val2) prop)
		      ;This kludge is because arithrnetic-trap-enb has
		      ;two spec codes, one with dispatch and one without.
		      ;Takes care of other hair with magic bits, too.
		      else when (and (memq prop '(spec magic))
				     (merge-spec-magic plist-1 plist-2))
		        do nil ;already hacked by merge-spec-magic
		      else do (retch "Field conflict: ~S has ~S and ~S"
				     prop val1 val2))))
	(t (retch "~S invalid - merge-instructions" plist-2))))

;Return the same data, but do the instruction in parallel with it
(defun merge-instruction-and-data (instruction data)
  (let ((*backtrace* (cons '(merge-instruction-and-data) *backtrace*)))
    (make-microdata (cadr data) (paralyze (caddr data) instruction))))

;Return the same condition, but do the instruction in parallel with it
(defun merge-instruction-and-condition (instruction condition)
  (let ((*backtrace* (cons '(merge-instruction-and-condition) *backtrace*)))
    (make-microcondition (cadr condition)
			 (caddr condition)
			 (paralyze (cadddr condition) instruction))))

;This is sort of the subr version of parallel, or the map version of merge-instructions.
(defun paralyze (&rest instructions)
  ;if we see a sequence, pick out its first and last instructions
  ;and merge them with the things before and the things after.
  (microsequencize
    (loop with current = (ncons 'microinstruction)
	  for instr in instructions
	  when (atom instr)
	    do (and instr (retch "~S garbage in paralyze" instr))
	  else when (eq (car instr) 'microsequence)
	  when (cddr instr)
	    collect (merge-instructions current (cadr instr)) into res
	    and do (setq current (copylist (car (last instr))))
	    and when (cdddr instr)
	    	  collect (microsequencize (butlast (cddr instr))) into res
		  else do nil	;no middle
	  else do (setq current (merge-instructions current (cadr instr)))
	else do (setq current (merge-instructions current instr))
	finally (return (nconc res (ncons current))))))


;XXXbrad - looks like one line missing; comment?
;g.

(defun merge-spec-magic (plist-1 plist-2
				 &aux spec1 spec2 magic1 magic2 new-spec new-magic)
  (prog ()
    (setq spec1 (get plist-1 'spec) spec2 (get plist-2 'spec)
	  magic1 (get plist-1 'magic) magic2 (get plist-2 'magic))
    ;; If the spec fields differ, try to find a common value
    ;; If the spec fields are the same, still some magic-number merging to do
    (cond ((and (memq spec1 '(arithmetic-trap-enb arithmetic-trap-with-dispatch))
		(memq spec2 '(arithmetic-trap-enb arithmetic-trap-with-dispatch)))
	   (if (null magic1)
	       (retch "Missing magic number field in ~S" plist-1))
	   (if (null magic2)
	       (retch "Missing magic number field in ~S" plist-2))
	   (setq new-spec (if (and (eq spec1 'arithmetic-trap-enb)
				   (eq spec2 'arithmetic-trap-enb))
			      'arithmetic-trap-enb
			      'arithmetic-trap-with-dispatch)
		 new-magic (logior magic1 magic2)))
	  ((and (memq spec1 '(arithmtic-trap-enb arithmetic-trap-with-dispatch))
		(memq spec2 '(trap-if-type-cond
			      trap-if-type-cond-or-bbus-not-fixnum)))
	   (setq new-spec spec1
		 new-magic (logior (or magic1 0)
				   (if (eq spec2 'trap-if-type-cond) 1 3))))
	  ((and (memq spec2 '(arithmetic-trap-enb arithmetic-trap-with-dispatch))
		(memq spec1 '(trap-if-type-cond
			      trap-if-type-cond-or-bbus-not-fixnum)))
	   (setq new-spec spec2
		 new-magic (logior (or magic2 0)
				   (if (eq spec1 'trap-if-type-cond) 1 3))))
4,887,235
	183	184
	  ((and (memq spec1 '(trap-if-type-cond
			      trap-if-type-cond-or-bbus-not-fixnum))
		(memq spec2 '(trap-if-type-cond
			      trap-if-type-cond-or-bbus-not-fixnum)))
	   (putprop plist-1 'trap-if-type-cond-or-bbus-not-fixnum 'spec)
	   (return t))
	  ((and (or (and (eq spec1 'arithmetic-trap-enb) (= magic1 3))
		    (eq spec1 'trap-if-type-cond-or-bbus-not-fixnum))
		(memq spec2 '(multiply multiply-and-type-check)))
	   (setq new-spec 'multiply-and-type-check
		 new-magic magic2))
	  ((and (or (and (eq spec2 'arithmetic-trap-enb) (= magic2 3))
		    (eq spec2 'trap-if-type-cond-or-bbus-not-fixnum))
		(memq spec1 '(multiply multiply-and-type-check)))
	   (setq new-spec 'multiply-and-type-check
		 new-magic magic1))
	  ((and (memq spec1 '(multiply multiply-and-type-check))
		(memq spec2 '(multiply multiply-and-type-check)))
	   ;; Can ior the fields together except for Xbus read/write conflict
	   (if (or (and (bit-test 2 magic1)		;Magicl writes from xbus
			(not (bit-test 2 magic2))	;Magic2 reads onto xbus
			(bit-test 4 magic2))
		   (and (bit-test 2 magic2)
			(not (bit-test 2 magic1))
			(bit-test 4 magic1)))
	       (retch "Multiplier both reading and writing xbus, magic ~0 ~0"
		      magic1 magic2))
	   (setq new-spec (if (and (eq spec1 'multiply) (eq spec2 'multiply))
			      'multiply
			      'multiply-and-type-check)
		 new-magic (logior magic1 magic2)))
	  ((and magic1 magic2 (not (and spec1 spec2 (not (eq spec1 spec2))))
		(zerop (logand (setq spec1 (or (get plist-1 'magic-mask) 17))
			       (logxor magic1 (logior magic1 magic2))))
		(zerop (logand (setq spec2 (or (get plist-2 'magic-mask) 17))
			       (logxor (logior magic1 magic2) magic2))))
	   ;; Conflict in magic number field only, and the bits that differ
	   ;; are only bits that the magic-mask claims are not cared about.
	   (putprop plist-1 (logior magic1 magic2) 'magic)
	   (if (= (logior spec1 spec2) 17)
	       (remprop plist-1 'magic-mask)
	       (putprop plist-1 (logior spec1 spec2) 'magic-mask))
	   (return t))
	  (t (return nil)))	;Cannot resolve spec conflict
    ;; Now make any alterations called for
    (putprop plist-1 new-spec 'spec)
    (putprop plist-1 new-magic 'magic)
    (remprop plist-1 'magic-mask)
    (return t)))

;magic-mask better occur after maqic in the microinstructions
(defprop magic-mask logior merge-fields)

;Take care of some simple cases of lossage caused by Xbus select and Ybus select
;being the same bit. plist-1 is the one that can be modified.
(defun merge-bus-scheduling (plist-1 plist-2)
  (cond ((and (eq (get plist-2 'ybus) (get plist-1 'xbus))
	      (fieldp plist-2 'condition 'ybus-31)
	      (not (get plist-2 'byte-func))
	      (not (fieldp plist-2 'spec 'multiply))
	      (memq (get plist-2 'alu) '(nil xbus))
	      (memq (get plist-1 'alu) '(nil xbus)))
	 ;; plist-2 isn't doing anything with Ybus except testing the sign,
	 ;; and the ALU is available, so do the sign test there.
	 (setq plist-2 (copylist plist-2))
	 (remprop plist-2 'ybus)
	 (putprop plist-2 'xbus 'alu)
	 (putprop plist-2 'alu-31 'condition))
	((and (eq (get plist-1 'ybus) (get plist-2 'xbus))
	      (fieldp plist-1 'condition 'ybus-31)
	      (not (get plist-1 'byte-func))
	      (not (fieldp plist-1 'spec 'multiply))
	      (memq (get plist-1 'alu) '(nil xbus))
	      (memq (get plist-2 'alu) '(nil xbus)))
	 ;; plist-1 isn't doing anything with Ybus except testing the sign.
	 ;; and the ALU is available. so do the sign test there,
	 (remprop plist-1 'ybus)
	 (putprop plist-1 'xbus 'alu)
	 (putprop plist-1 'alu-31 'condition)))
  (values plist-1 plist-2))

(defun (speed merge-fields) (speed1 speed2)
  (cond ((eq speed1 'slow) speed2)	;slow and we don't care which half
	((eq speed2 'slow) speed1)
	((or (eq speed1 'very-slow) (eq speed2 'very-slow)) 'very-slow)
	(t 'very-slow)))	;must be both halves slow


;;; Micro and macro for machine-version conditionalization
(defmacro machine-version-case (&body clauses)
  (expand-machine-version-case clauses))
4,887,235
	185	186
(defmicro machine-version-case (&body clauses)
  (expand-machine-version-case clauses))

(defun expand-machine-version-case (clauses)
  (loop for clause in clauses do
	(or (= (length clause) 2)
	    (ferror nil "~S illegal clause in MACHINE-VERSION-CASE; must be (<ver> <code>)"
		    clause))
	(if (or (eq (car clause) 'otherwise)
		(if (atom (car clause))
		    (eq *machine-version* (car clause))
		  (memq *machine-version* (car clause))))
	    (return (cadr clause)))
	finally
	(ferror nil "No clause in MACHINE-VERSION-CASE for ~S" *machine-version*)))
;:; Flow of control micros
;If you want to know what the available tests are, don't look at these lists,
;look at the macros below. There are more possibilities than you think.

;There are also some IO and GC related skip conditions which I'm leaving out for now

;Skip (Choose one of two next instructions)
(eval-when (eval load compile)
(defconst valid-skip-conditions '(	;Add more as needed...
	;Comparisons of 28, 32, 34 bit fields (using X-Y-1 ALU function)
	equal-pointer not-equal-fixnum not-equal-typed-pointer
	;Unsigned comparisons, 28 and 32 bit fields (using X-Y-1 ALU function)
        not-greater-pointer not-greater-fixnum-unsigned
	;Type filter, cdr-code filter
	type-condition bbus-not-fixnum not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3
	ybus-31		;For division
	alu-31 alub-0 not-lbus-dev-cond mc-cond not-ctos-came-from-ifu
	)))

;One-argument ALU-status condition
(defmacro defalucondition1 (name skip-cond-name sense alu-func)
  (or (memq skip-cond-name valid-skip-conditions)
      (ferror nil "~S not a valid skip condition in ~S" skip-cond-name name))
  (or (memq sense '(true false))
      (ferror nil "~S not a valid skip sense in ~S" sense name))
  `(defmicro ,name (opnd)
     (make-microcondition ',skip-cond-name ',sense
       (get-to-obus32 . (selectq alu-func
				 (X 'opnd)
				 (X-1 `'(1- ,opnd))
				 (otherwise (retch "Unrecognized ALU function: ~S -- defalucondition1"
						   alu-func)))))))

;Two-argument ALU-status condition
(defmacro defalucondition2 (name skip-cond-name sense alu-func reverse-alu-func)
  (or (memq skip-cond-name valid-skip-conditions)
      (ferror nil "~S not a valid skip condition in ~S" skip-cond-name name))
  (or (memq sense '(true false))
      (ferror nil "~S not a valid skip sense in ~S" sense name))
  `(defmicro ,name (x-opnd y-opnd)
     (multiple-value-bind (operand-code operands-reversed)
	 (get-to-xbus-and-alub x-opnd y-opnd)
       (make-microcondition ',skip-cond-name
	 (if operands-reversed ',(cdr (assq sense '((true . false) (false . true)))) ',sense)
	 (alu-paralyze operand-code
		       (alu-microinstruction
			(if operands-reversed ,reverse-alu-func 'alu-func)))))))

;Commutative two-argument ALU-status condition
(defmacro defalucondition-commutative (name skip-cond-name sense alu-func)
  (or (memq skip-cond-name valid-skip-conditions)
	(ferror nil "~S not a valid skip condition in ~S" skip-cond-name name))
  (or (memq sense '(true false))
      (ferror nil "~S not a valid skip sense in ~S" sense name))
  `(defmicro ,name (x-opnd y-opnd)
     (make-microcondition ',skip-cond-name ',sense
			  (alu-paralyze (get-to-xbus-and-alub x-opnd y-opnd)
					(alu-microinstruction ',alu-func)))))

;Two-argument arithmetic comparisons
(defalucondition-commutative equal-pointer equal-pointer true X-Y-1)
(defalucondition-commutative equal-fixnum not-equal-fixnum false X-V-1)
(defalucondition-commutative equal-typed-pointer not-equal-typed-pointer false X-Y-1)
(defalucondition-commutative not-equal-pointer equal-pointer false X-Y-1)
(defalucondition-commutative not-equal-fixnum not-equal-fixnum true X-Y-1)
(defalucondition-commutative not-equal-typed-pointer not-equal-typed-pointer true X-Y-1)
(defalucondition2 greater-pointer not-greater-pointer false X-Y-1 X-Y)
(defalucondition2 greater-fixnum-unsigned not-greater-fixnum-unsigned false X-Y-1 X-Y)
(defalucondition2 greater-fixnum not-greater-fixnum-unsigned false X-Y-1-signed X-Y-signed)
(defalucondition2 greater-or-equal-pointer not-greater-pointer false X-Y X-Y-1)
(defalucondition2 greater-or-equal-fixnum-unsigned not-greater-fixnum-unsigned false
  		  X-Y X-Y-1)
(defalucondition2 greater-or-equal-fixnum not-greater-fixnum-unsigned false
  		  X-Y-signed X-Y-1-signed)
4,887,235
	187	188
(defalucondition2 lesser-pointer not-greater-pointer true X-Y X-Y-1)
(defalucondition2 lesser-fixnum-unsigned not-greater-fixnum-unsigned true X-Y X-Y-1)
(defalucondition2 lesser-fixnum not-greater-fixnum-unsigned true X-Y-signed X-Y-1-signed)
(defalucondition2 lesser-or-equal-pointer not-greater-pointer true X-Y-i X-Y)
(defalucondition2 lesser-or-equal-fixnum-unsigned not-greater-fixnum-unsigned true
		  X-Y-1 X-Y)
(defalucondition2 lesser-or-equal-fixnum not-greater-fixnum-unsigned true
		  X-Y-1-signed X-Y-signed)


;One-argument arithmetic test
(defalucondition1 zero-fixnum not-equal-fixnum false X-1)
(defalucondition1 not-zero-fixnum not-equal-fixnum true X-1)
;These two can be done in either the ALU or the YBUS
;(defalucondition1 minus-fixnum alu-31 true X)
;(defalucondition1 plus-or-zero-fixnum alu-31 false X)
(defmicro minus-fixnum (opnd)
  (let ((data (microexpand opnd)))
    (if (can-get-to-ybus data)
	(make-microcondition 'ybus-31 'true (get-to-ybus data))
        (make-microcondition 'alu-31 'true (get-to-obus32 data)))))

(defmicro plus-or-zero-fixnum (opnd)
  (let ((data (microexpand opnd)))
    (if (can-get-to-ybus data)
	(make-microcondition 'ybus-31 'false (get-to-ybus data))
        (make-microcondition 'alu-31 'false (get-to-obus32 data)))))


;;XXXbrad something missing here?
;  (defalucondition1 minus-or-zero-fixnum not-greater-fixnum-unsigned true X-1)
;  (defalucondition1 plus-fixnum not-greater-fixnum-unsigned false X-1)

;;XXXbrad something missing here?
(defalucondition1 minus-or-zero-fixnum alu-31 true X-1)
(defalucondition1 plus-fixnum alu-31 false X-1)


;  (defalucondition1 minus-or-zero-fixnum not-alu-31-or-carry-32 true X-1-signed)
;  (defalucondition1 plus-fixnum not-alu-31-or-carry-32 false X-1-signed)
;  )

;Logical tests
(defmicro bit-test (x-opnd y-opnd)
  (make-microcondition not-equal-fixnum 'true ;i.e. not -1
    (get-to-obus32 `(lognand ,x-opnd ,y-opnd))))

;Same for 28-bit operands
(defmicro bit-test-pointer (x-opnd y-opnd)
  (make-microcondition 'equal-pointer false	;i.s. not-i
    (get-to-obus32 `(lognand ,x-opnd ,y-opnd))))

(defmicro ldb-bit-test (y-cpnd bit-number)
  (make-microcondition 'alub-0 'true
    (paralyze (get-to-ybus y-opnd)
	      (if (eq bit-number 'byte-r)
		  ;; Don't care how many bits in the byte, and can't use cond. Hence byte-s
		  '(microinstruction byte-func (ldb byte-r byte-s))
		  `(microinstruction byte-func (ldb ,(logand (- 40 bit-number) 37) 1))))))

(defmicro bit (byte-field)
  (let ((data (microexpand byte-field)) tem)
    (if (and (eq (car data) 'microdata)
	     (eq (cadr data) 'alub)
	     (setq tem (get (caddr data) 'byte-func))
	     (eq (car tem) 'ldb)
	     (equal (caddr tem) 1))
	(make-microcondition 'alub-0 'true (caddr data))
        (retch "~S == ~S is not a single bit datum" byte-field data))))

(defmicro all-ones (computation)
  (make-microcondition not-equal-fixnum 'false
     (get-to-obus32 computation)))

;Weird conditions
(defatomicro ybus-31
  (microcondition ybus-31 true nil))

;Alternate name for carry out of bit 31 of ALU
(defatomicro alu-carry
  (microcondition not-greater-fixnum-unsigned false nil))

(defatomicro micro-stack-empty
  (micro-stack-empty-kludge))

(defmicro micro-stack-empty-kludge ()
  (or (eq *machine-version* 'proto)
      (retch "micro-stack-empty doesn't exist any more"))
  '(microcondition not-ctos-came-from-ifu false nil))
(declare (special *cdr-codes* *data-types*))		;from sysdef
4,887,235
	189	190
(defmicro data-type? (val &rest types)
  (make-microcondition 'type-condition 'true
    `(parallel ,(get-to-abus val)
	       (microinstruction type-map ((,(copylist types) cond))))))

(defmicro not-data-type? (val &rest types)
  (make-microcondition 'type-condition 'false
    `(parallel ,(get-to-abus val)
	       (microinstruction type-map ((,(copylist types) cond))))))

;Merging rules for type maps;
;Note that the trap number overlaps with the pointer and cond bits.
;This when merging, anything that specifies trap overrides the pointer
;and cond bits from what it -is being merged with. Also, only one trap
;at a time can be specified; there is a priority ordering which says
;who gets control uhen both maps specify traps. Invisible pointers
;have priority over bad type traps.




;trap-2 is invisible pointer (highest priority)
;trap-0 is bad data type
;trap-1, trap-3 not defined yet, so I just stick them in at the end.
(defconst trap-priority-order '(trap-2 trap-0 trap-1 trap-3))

(declare (special *unduplicated-data-types*)) ;in UUX
(defprop type-map merge-type-maps merge-fields)

(defun merge-type-maps (map1 map2)
  (loop with (cond1 cond2 pointer1 pointer2) = nil
	for type in *unduplicated-data-types*
	as out1 = (type-map-lookup type map1)
	as out2 = (type-map-lookup type map2)
	as trap1 = (type-map-trap? out1)
	as trap2 = (type-map-trap? out2)
	as output =
	    (cond ((and trap1 trap2) (if (< trap2 trap1) out2 outi))
		  (trap1 out1)
		  (trap2 out2)
		  ((null out1) out2)
		  ((null out2) out1)
		  ((equal out1 out2) out1)
		  (t '(cond pointer)))	;both is Only other possibility
	    when output
	      unless (loop for ent in map
			   when (equal (cdr ent) output)
			     return (rplacd (last (car ent)) (ncons type)))
	        collect (cons (ncons type) output) into map
	      unless trap1
	        do (if (memq 'cond out1) (setq cond1 t))
		   (if (memq 'pointer out1) (setq pointer1 t))
	      unless trap2
	        do (if (memq 'cond out2) (setq cond2 t))
		   (if (memq 'pointer out2) (setq pointer2 t))
	      finally
	        (if (or (and cond1 cond2) (and pointer1 pointer2))
		    (retch "Conflict for cond and//or pointer field: ~S ~S"
			   map1 map2))
		(return map)))

(defun type-map-trap? (out)
  (loop for x in out
	when (find-position-in-list x trap-priority-order)
	  return it
	unless (memq x '(cond pointer))
	  do (retch "~S -- garbage in type map output ~S" x out)))

(defun type-map-lookup (type map)
  (loop for (types . outputs) in map
	when (memq type types) return outputs))

(defmicro cdr-code? (val cdr)
  (make-microcondition (nth (cond ((numberp cdr) cdr)
				  ((find-position-in-list cdr *cdr-codes*))
				  (t (retch "~S invalid cdr code" cdr)))
			    '(not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3))
		       'false
		       (get-to-abus val)))

(defmicro not-cdr-code? (val cdr)
  (make-microcondition (nth (cond ((numberp cdr) cdr)
				  ((find-position-in-list cdr *cdr-codes*))
				  (t (retch "~S invalid cdr code" cdt)))
			    '(not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3))
		       'true
		       (get-to-abus val1)))

(defmicro not (pred)
4,887,235
	191	192
  (setq pred (microexpand pred))
  (or (and (listp pred) (eq (car pred) 'microcondition))
      (ferror nil "Argument to NOT expanded into ~S which is not a microcondition"))
  (or (memq (caddr pred) '(true false))
      (ferror nil "Invalid sense in ~S" pred))
  `(microcondition ,(cadr pred) ,(if (eq (caddr pred) 'true) 'false 'true)
		   ,(cadddr pred)))

;Put this in the middle of a sequence and it splits the flow into
;one of two paths, which are sequences or single instructions. If
;there is anything more in the sequence the flow is assumed to rejoin.
;Note that instead of an immediate sequence you may also say "(goto tag)"
;where tag is scmething defired by a defucode. If you said "(jump tag)"
;you would get the same effect but one cycle slower. The assembler copies
;instructions as necessary to implement this. You may also say (drop-through)
;to avoid getting grossly deep in indentation in the source code.
(defmicro if (pred true false)
  (let* ((test (microexpand pred))
	 (skip (cond ((neq (car test) 'microcondition)
		      (retch "~S expanded into ~S, not a valid microcondition"
			     pred test))
		     ((memq (cadr test) valid-skip-conditions) (cadr test))
		     (t (retch "~S invalid skip condition in ~S"
			       (cadr test) pred)))))
    (if (eq (caddr test) 'false) (psetq true false false true))
    (paralyze
     (cadddr test)
     `(microinstruction condition ,skip
			skip-true-sequence ,(microexpand-if true)
			skip-false-sequence ,(microexpand-if false)))))

;The value of the skip-xxx-sequence field is a microinstruction, a
;microsequence, a defucode tag, or nil meaning drop-through.
(defun microexpand-if (form)		;Hacks goto, drop-through which aren't defmicros
  (setq form (microexpand form))	; however microexpand is known not to complain
  (cond ((and (not (atom form)) (= (length form) 2) (eq (cat form) 'goto))
	 (cadr form))
	((equal form '(drop-through))
	 nil)
	(t form)))


;Construct a microcondition out of a condition name and some microcode.
;The microcode is expanded now to make life simpler and to make
;the backtracing come out right.
(defun make-microcondition (condition sense code)
  (let ((expcode (microexpand code)))
    (if (or (atom expcode)
	    (not (memq (car expcode) '(microinstruction microsequence))))
	(ferror nil "not microinstruction in microcondition: ~S == ~S"
		code expcode))
    (or (memq condition valid-skip-conditions)
	(ferror nil "~S is not a valid skip condition" condition))
    (or (memq sense '(true false))
	(ferror nil "~S is not a valid skip sense" sense))
    `(microcondition ,condition ,sense ,expcode)))
;;; Data type checking and other trapping

;Trap if data type of val is not one of the specified types.
;This is the low-level version that traps to a fixed place, used for
;unbound variable checking and wrong-type-argument barfing.

;Location specifies to the error handler. It can be a number for a fixed argument;
;NIL for an unepecified place (in which case the first argument of a non-matching
;type will be printed);
;ARRAY for the array argument to various instructions;
;SUBBSCRIPT for	one (or more) of the subscript argument(s) to an array function;
;TOP-OF-STACK for things like funcall;
;REST-ARG for lexpr-funcall;
;RETURN-PC for returning;
;SELF-MAPPING-TABLE for instance stuff;
;INSTANCE (either self or argument to %INSTANCE-X) ditto;
;INSTANCE-SIZE ditto: INSTANCE-BINDING ditto;
;INSTANCE-HASH-TABLE ditto; INSTANCE-HASH-TABLE-ENTRY ditto;
;ANY for functions with several arguments of like type.
(defmicro check-arg-type (location val &rest types)
  `(parallel ,(get-to-abus val)
	     (microinstruction type-map ((,(types-other-than types) trap-0))
			       error-table (wrong-type-argument ,location ,types))))

;For simple cases, specify location as NIL
(defmicro check-data-type (val &rest types)
  `(check-arg-type nil ,val . ,types))

;Generate specified data-type trap if value is of one of the
;specified types.
(defmicro data-type-trap (val trap-name &rest types)
  `(parallel ,(get-to-abus val)
	     (microinstruction type-map ((,(copylist types) ,trap-name)))))