;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;


;;this file contains the low level macros and loading functions to
;;create lambda microinstructions for debug purposes

;;this macro makes no attempt to avoid bignums, in contrast to the cc-excecute
;;macro that the cadr uses: a more efficient form may be written later
;; this should return the uinst as a bignum

(DEFUN LAM-EXECUTE MACRO (X)
  (LET ((INST 0)
	(FIELD NIL)
	(P NIL)
	(P+S NIL)
	(C-MEM-W-ADR NIL)
	(ARGUMENT NIL)
	(EXECUTOR NIL))
     ;DECODE OPERATION TYPE
     (SETQ EXECUTOR
	   (COND  ((EQUAL (CADR X) '(READ))
		   (SETQ X (CDR X))
		   'LAM-EXECUTE-R)
		  ((equal (cadr x) '(return))
		   (setq x (cdr x))
		   'identity)
		  ((EQUAL (CADR X) '(UINST-CLOCK))
		   (SETQ X (CDR X))
		   'LAM-EXECUTE-UINST-CLOCK)  ;make one uinst clock
		  ((EQUAL (CADR X) '(UINST-CLOCK-PLUS-UINST-CLOCK-LOW))
		   (SETQ X (CDR X))
		   'LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW)
		  ((EQUAL (CADR X) '(WRITE))
		   (SETQ X (CDR X))
		   'LAM-EXECUTE-W)	      ;also clock thru a no-op to assure writes happen
		  ((equal (cadr x) '(source))
		   (setq x (cdr x))
		   'lam-execute-source-cycle)
		  ((EQUAL (CADR X) '(NOCLOCKS))
		   (SETQ X (CDR X))
		   'LAM-EXECUTE-NOCLOCKS)
		  ((AND (NOT (ATOM (CADR X)))
			(EQ (CAADR X) 'W-C-MEM))
		   (SETQ C-MEM-W-ADR (CADADR X) X (CDR X))
		   'WRITE-CRAM-WITH-GOOD-PARITY)
		  ((AND (NOT (ATOM (CADR X)))
			(EQ (CAADR X) 'EXECUTOR))
		   (PROG1 (CADADR X) (SETQ X (CDR X))))
		  (T 'WRITE-IREG-and-check)))
     ;FIRST PASS DOES ALL THE CONSTANT ONES
     (DO X (CDR X) (CDDR X) (NULL X)
       (SETQ FIELD (SYMEVAL (CAR X)) ARGUMENT (CADR X)
	     P (LSH FIELD -6) P+S (+ P (LOGAND 77 FIELD)))
       (COND ((OR (NUMBERP ARGUMENT)			;CONSTANT ARG, DO AT COMPILE TIME
		  (AND (SYMBOLP ARGUMENT) (GET ARGUMENT 'CONSTANT)))
	      (AND (SYMBOLP ARGUMENT) (SETQ ARGUMENT (SYMEVAL ARGUMENT)))
	      (SETQ INST (DPB ARGUMENT FIELD INST)))))
     ;SECOND PASS FILLS IN THE NON-CONSTANT ONES
     (DO X (CDR X) (CDDR X) (NULL X)
       (SETQ FIELD (SYMEVAL (CAR X)) ARGUMENT (CADR X)
	     P (LSH FIELD -6) P+S (+ P (LOGAND 77 FIELD)))
       (COND ((NOT (OR (NUMBERP ARGUMENT) (AND (SYMBOLP ARGUMENT) (GET ARGUMENT 'CONSTANT))))
	      (SETQ INST `(DPB ,ARGUMENT ,FIELD ,INST)))))
;     (SETQ INST (COND ((NUMBERP INST)
;		       (COMPUTE-PARITY-64 INST))
;		      (T `(COMPUTE-PARITY-64 ,INST))))
     (setq inst `(compute-parity-for-ireg ,inst))
     (COND (C-MEM-W-ADR `(,EXECUTOR ,C-MEM-W-ADR ,INST)) 
	   (T `(,EXECUTOR ,INST)))))


(DEFUN LAM-EXECUTE-NOCLOCKS (UINST &OPTIONAL JUST-CLEARING-PIPE) ;just load ireg, no clocks.
  (COND ((NOOP-P)
	 (FERROR NIL "noop set at lam-execute-noclocks"))) ;the desired thing will not happen.
  (FORCE-SOURCE-CODEWORD)
  (COND ((AND (NOT JUST-CLEARING-PIPE)
	      (zerop (ldb tram.next.select (read-tram-adr)))
	      (NOT (ZEROP (ldb tram.state (READ-TRAM-ADR)))))
	 (PRINT-TICK-DATA)
	 (FERROR NIL  "~%PREVIOUS UINST DEST SEQ NONZERO AT LAM-EXECUTE-noclocks!")))
  (WRITE-IREG-AND-CHECK UINST)
  )

(DEFUN LAM-EXECUTE-R-BOMB ()
  (FORMAT T "~%Machine hung at lam-execute-r")
  (SM-STEP-LOOP ':CSM-PRINTOUT T))

(DEFUN LAM-EXECUTE-R (UINST &OPTIONAL JUST-CLEARING-PIPE)
				;clock UINST thru SOURCE cycle but dont 
				;clock final execute cycle.  For ALU and BYTE uinsts,
				;this leaves the result of the uinst on the MFO bus.
  (cond ((access-path-lmi-serial-protocol *proc*) ;*bus-communication-instance*
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 0040 uinst)))
	 (funcall *proc* ':tyo-cr #/L)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 4040 uinst)))
	 (funcall *proc* ':tyo-cr #/H)
	 (funcall *proc* ':tyo #/1)
	 (funcall *proc* ':tyo-cr #/I)
	 (funcall *proc* ':read-32)
	 )
	(t
	 (COND ((T-HOLD-P) (LAM-EXECUTE-R-BOMB)))
						;error if t-hold is on, can't tick uinst
	 
	 (COND ((AND (NOT JUST-CLEARING-PIPE)	;force noops clear unless you are just
		     (NOOP-P))			;clearing the pipeline
		(ASSURE-NOOP-CLEARED)))
	 
	 (COND ((NOT (UINST-CLOCK-LOW-P))	;uinst clock must be low to write ireg
		(force-uinst-clock-low)))

	 (cond ((< (send *proc* :major-version) 100.)
		(write-ireg-and-check IZERO-GOOD-PARITY)
		(FORCE-SOURCE-CODEWORD))
	       (t
		(FORCE-SOURCE-CODEWORD)
		(write-ireg-and-check IZERO-GOOD-PARITY)))
		
	 (COND ((AND (NOT JUST-CLEARING-PIPE)		
		     (= 0 (ldb tram.next.select (read-treg)))
		     (NOT (ZEROP (LOGAND 7 (READ-TRAM-ADR)))))
		(PRINT-TICK-DATA)
		(CERROR T NIL NIL "~%PREVIOUS UINST DEST SEQ NONZERO AT LAM-EXECUTE-R!")
		))
	 (WRITE-IREG-AND-CHECK UINST)
	 (SM-TICK)				;advance to first execute cycle.
	 (cond ((>= (send *proc* :major-version) 100.)
		(sm-tick)
		(sm-tick)))
	 (cond ((and *paranoid-mode* (= 1 (ldb tram.source.cycle (read-treg))))
		(ferror t "lam-execute-r failed to leave us in execute-cycle")))
	 )))


;THIS ONE DOESNT MAKE FUNNY ERROR CHECKS IF YOU REALLY KNOW WHAT YOU ARE DOING..
(DEFUN LAM-EXECUTE-R-NO-CHECK (UINST)
				;clock UINST thru SOURCE cycle but dont 
				;clock final execute cycle.  For ALU and BYTE uinsts,
				;this leaves the result of the uinst on the MFO bus.
  (if (>= (send *proc* :major-version) 100.) (ferror nil "foo"))
  (cond (NIL ;(access-path-lmi-serial-protocol *proc*)
	 (FERROR NIL "LAM-EXECUTE-R-NO-CHECK DOESNT WIN IN SERIAL MODE YET!!")
   ;	 (funcall *proc* ':prin1
   ;		  (if just-clearing-pipe 0 (ldb-big 0040 uinst)))
	 (funcall *proc* ':tyo-cr #/L)
   ;	 (funcall *proc* ':prin1
   ;		  (if just-clearing-pipe 0 (ldb-big 4040 uinst)))
	 (funcall *proc* ':tyo-cr #/H)
	 (funcall *proc* ':tyo #/1)
	 (funcall *proc* ':tyo-cr #/I)
	 (funcall *proc* ':read-32)
	 )
	(t
	 (COND ((T-HOLD-P) (LAM-EXECUTE-R-BOMB)))
						;error if t-hold is on, can't tick uinst
	 
	 (COND ((NOT (UINST-CLOCK-LOW-P))	;uinst clock must be low to write ireg
		(force-uinst-clock-low)))
	 (write-ireg-and-check IZERO-GOOD-PARITY)
	 (FORCE-SOURCE-CODEWORD)
	 (WRITE-IREG-AND-CHECK UINST)
	 (SM-TICK)				;advance to first execute cycle.
	 (cond ((and *paranoid-mode* (= 1 (ldb tram.source.cycle (read-treg))))
		(ferror t "lam-execute-r failed to leave us in execute-cycle")))
	 )))

(DEFUN LAM-EXECUTE-source-cycle (UINST &OPTIONAL JUST-CLEARING-PIPE)
				;clock UINST thru SOURCE cycle but dont 
				;clock final execute cycle.  For ALU and BYTE uinsts,
				;this leaves the result of the uinst on the MFO bus.
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 0040 uinst)))
	 (funcall *proc* ':tyo-cr #/L)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 4040 uinst)))
	 (funcall *proc* ':tyo-cr #/H)
	 (funcall *proc* ':tyo #/1)
	 (funcall *proc* ':tyo-cr #/I)
	 (funcall *proc* ':read-32)
	 )
	(t
	 (COND ((T-HOLD-P) (LAM-EXECUTE-R-BOMB)))
						;error if t-hold is on, can't tick uinst
	 
	 (COND ((AND (NOT JUST-CLEARING-PIPE)	;force noops clear unless you are just
		     (NOOP-P))			;clearing the pipeline
		(ASSURE-NOOP-CLEARED)))
	 
	 (COND ((NOT (UINST-CLOCK-LOW-P))	;uinst clock must be low to write ireg
		(force-uinst-clock-low)))
	 (cond ((< (send *proc* :major-version) 100.)
		(write-ireg-and-check IZERO-GOOD-PARITY)
		(FORCE-SOURCE-CODEWORD))
	       (t
		(FORCE-SOURCE-CODEWORD)
		(write-ireg-and-check IZERO-GOOD-PARITY)))

	 (COND ((AND (NOT JUST-CLEARING-PIPE)		
		     (= 0 (ldb tram.next.select (read-treg)))
		     (NOT (ZEROP (LOGAND 7 (READ-TRAM-ADR)))))
		(PRINT-TICK-DATA)
		(FERROR NIL  "~%PREVIOUS UINST DEST SEQ NONZERO AT LAM-EXECUTE-R!")
		))
	 (WRITE-IREG-AND-CHECK UINST)
	 ;;we want to stay in the source cycle
;	 (SM-TICK)				;advance to first execute cycle.
	 (cond ((>= (send *proc* :major-version) 100.)
		(sm-tick)
		(sm-tick)))
	 (cond ((and *paranoid-mode* (= 1 (ldb tram.source.cycle (read-treg))))
		(ferror t "lam-execute-r failed to leave us in execute-cycle")))
	 )))

(DEFUN LAM-EXECUTE-UINST-CLOCK (UINST &OPTIONAL JUST-CLEARING-PIPE
				(make-sure-source-cycle-bit-is-off t)
				)
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 0040 uinst)))
	 (funcall *proc* ':tyo-cr #/L)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 4040 uinst)))
	 (funcall *proc* ':tyo-cr #/H)
	 (funcall *proc* ':string-out "3I")
	 (funcall *proc* ':read-32))
	(*EXECUTE-SINGLE-UINST-MODE*
	  (LAM-EXECUTE-SINGLE-UINST UINST JUST-CLEARING-PIPE))
	(t
	 (LAM-EXECUTE-R UINST JUST-CLEARING-PIPE)
	 (cond ((= 0 (ldb allow-uinst-clocks (read-pmr)))
		(format t "uinst clocks not enabled, so this uinst shouldn't complete!")))
	 (advance-to-next-uinst-clock)
	 (if (and (> (send *proc* :major-version) 100.)
		  make-sure-source-cycle-bit-is-off)
	     (force-source-codeword))
	 )))

(DEFUN LAM-EXECUTE-SINGLE-UINST (UINST &OPTIONAL JUST-CLEARING-PIPE)
  (COND ((T-HOLD-P) (LAM-EXECUTE-R-BOMB)))
						;error if t-hold is on, can't tick uinst
  
  (COND ((AND (NOT JUST-CLEARING-PIPE)		;force noops clear unless you are just
	      (NOOP-P))				;clearing the pipeline
	 (ASSURE-NOOP-CLEARED)))
  
  (COND ((NOT (UINST-CLOCK-LOW-P))		;uinst clock must be low to write ireg
	 (force-uinst-clock-low)))
  (write-ireg-and-check IZERO-GOOD-PARITY)
  (ADVANCE-TO-UINST-BOUNDARY)
  (WRITE-IREG-AND-CHECK UINST)
  (FORCE-TRAM-TO-REDO-SOURCE-CYCLE)
  (LAM-SINGLE-STEP)
  (FORCE-UINST-CLOCK-LOW))

(defun advance-to-next-uinst-clock ()
  (DO ((COUNTS 1 (1+ COUNTS)))
	     ((> COUNTS 6.)
	      (FORMAT T "~%UINST DID NOT COMPLETE AFTER 6 SM CLOCKS")
	      (format t "~% - ~[note that the T.req.new.uinst bit is presently OFF in the treg~%~
			 -- maybe o.k., but it must be on the cycle BEFORE a Uinst tick~;~
			the T.req.new uinst bit is on in the Treg though..~]"
		      (ldb  tram.new.uinst (read-treg)))
	      (SM-STEP-LOOP ':CSM-PRINTOUT T))
	   (COND ((AT-UINST-BOUNDARY-P)
		  (RETURN COUNTS)))		;this is a UINST boundary.
	   (SM-TICK))
  )

 ;this function no longer returns a significant value
(DEFUN LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW (UINST &OPTIONAL JUST-CLEARING-PIPE
						     (make-sure-source-cycle-bit-is-off t)
						     )
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 0040 uinst)))
	 (funcall *proc* ':tyo-cr #/L)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 4040 uinst)))
	 (funcall *proc* ':tyo-cr #/H)
	 (funcall *proc* ':string-out "7I")
	 (funcall *proc* ':read-32))
	(t
	 (LAM-EXECUTE-UINST-CLOCK UINST JUST-CLEARING-PIPE make-sure-source-cycle-bit-is-off)
	 (FORCE-UINST-CLOCK-LOW);Avoid leaving uinst clock high.  This works by forcing T.HOLD
	 )))					; and ticking.

 ;this function no longer returns a significant value
(DEFUN LAM-EXECUTE-W (UINST &OPTIONAL JUST-CLEARING-PIPE)
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 0040 uinst)))
	 (funcall *proc* ':tyo-cr #/L)
	 (funcall *proc* ':prin1
		  (if just-clearing-pipe 0 (ldb-big 4040 uinst)))
	 (funcall *proc* ':tyo-cr #/H)
	 (funcall *proc* ':string-out "20I")
	 (funcall *proc* ':read-32))
	(t
	 
	 (LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW UINST JUST-CLEARING-PIPE nil)
						;allow write pulse memories to write.
	 (LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW IZERO-GOOD-PARITY T nil)
	 (cond ((and (= 0 (ldb tram.next.select (read-treg)))
		     (not (zerop (logand 7 (read-tram-adr)))))
		(ferror nil "clear pipe left previous uinst dest seq nonzero")))
	 (if (> (send *proc* :major-version) 100.)
	     (force-source-codeword))
	 (WRITE-IREG-and-check IZERO-GOOD-PARITY)
	 ;clear out garbage.  Note that since LAM-EXECUTE-R ticks thru
	 ;to uinst boundary, this can get executed by a following read.
	 ;ALSO WRITE GOOD PARITY AS LONG AS WE ARE CLEANING UP
;	 (when (>= (send *proc* :major-version) 100.)
;	   (zero-ireg)
;	   (force-source-codeword))
	 )))
				    
(DEFUN WRITE-IREG-AND-CHECK (UINST)
  (tagbody
   retry
 ;(if this-time (cerror :no-action nil nil "foo"))
      (WRITE-IREG UINST)
      (LET ((TEM (if *paranoid-mode* (read-ireg-and-check-uinst-clock)
		   (READ-IREG))))
	(COND ((NOT (= TEM UINST))
	       (FORMAT T "~%IREG failed to write, is ~O, should be ~O differs in bits:"
		       TEM UINST)
	       (print-bits (logxor tem uinst))
	       (cerror "Try again (and check again)." "IREG didn't write")
	       (go retry)
	       )))))

;symbols moved to a new file, lambda-diag;lambda-symbols.lisp

(COMMENT  ;make this work someday.
  (DEFMACRO LET-COLLECTION (VAR . BODY)
    (LET ((G1 (GENSYM)))
      `(LET* ((VAR NIL)
	      (,G1 (VALUE-CELL-LOCATION 'VAR)))
	 )))
  (LET-COLLECTION ANS
		  (DOLIST (S PRGM ANS)
		    (COND ((NUMBERP S)
			   (COLLECT ANS)
			   (SETQ L S))
			  ((SYMBOLP S)
			   )))
		  ))

(DEFMACRO ULOAD (VARLIST &rest X)
  `(progn (UASS-LOAD . ,(UASS VARLIST X))
	  ))

(DEFUN UASS (VARLIST PRGM)
  (LOOP FOR WD IN PRGM
	COLLECT (UASS-WD WD VARLIST)))

(DEFUN UASS-WD (X VARLIST)
  (COND ((NUMBERP X) X)
	((SYMBOLP X)
	 (COND ((MEMQ X VARLIST)
		X)
	       (T (LIST 'QUOTE X))))
	((NUMBERP (CAR X))
	 `'(,(CAR X)))
	(T (UASS-WD-1 X VARLIST))))

(DEFUN UASS-WD-1 (X VARLIST)
  (LET ((INST 0)
	(FIELD NIL)
	(P NIL)
	(P+S NIL)
	(ARGUMENT NIL)
	TEM)
     ;FIRST PASS DOES ALL THE CONSTANT ONES
     (DO X X (CDDR X) (NULL X)
       (SETQ FIELD (SYMEVAL (CAR X)) ARGUMENT (CADR X)
	     P (LSH FIELD -6) P+S (+ P (LOGAND 77 FIELD)))
       (COND ((SETQ TEM (UASS-WD-EVAL ARGUMENT))
	      (SETQ INST (DPB TEM FIELD INST)))))  ;CONSTANT ARG, DO AT COMPILE TIME
     ;SECOND PASS FILLS IN THE NON-CONSTANT ONES
     (DO X X (CDDR X) (NULL X)
       (SETQ FIELD (SYMEVAL (CAR X)) ARGUMENT (CADR X)
	     P (LSH FIELD -6) P+S (+ P (LOGAND 77 FIELD)))
       (COND ((AND (NULL (UASS-WD-EVAL ARGUMENT))
		   (UASS-RUNTIME-P ARGUMENT VARLIST))
	      (SETQ INST `(DPB ,ARGUMENT ,FIELD ,INST)))))
     ;THIRD PASS FILLS IN THE LOAD-TIME ONES
     (DO X X (CDDR X) (NULL X)
       (SETQ FIELD (SYMEVAL (CAR X)) ARGUMENT (CADR X)
	     P (LSH FIELD -6) P+S (+ P (LOGAND 77 FIELD)))
       (COND ((AND (NULL (UASS-WD-EVAL ARGUMENT))
		   (NULL (UASS-RUNTIME-P ARGUMENT VARLIST)))
	      (SETQ INST `(LIST 'UA-LOADTIME-DPB ',ARGUMENT ,FIELD ,INST)))))
     (COND ((NUMBERP INST)
	    `'(,INST))
	   (T
	    `(LIST ,INST)))))

(DEFUN UASS-RUNTIME-P (ARG VARLIST)
  (NOT (AND (SYMBOLP ARG)
	    (NOT (MEMQ ARG VARLIST)))))


(DEFUN UASS-WD-EVAL (ARGUMENT)
  (COND ((NUMBERP ARGUMENT) ARGUMENT)
	((AND (SYMBOLP ARGUMENT) (GET ARGUMENT 'CONSTANT))
	 (SYMEVAL ARGUMENT))
	(T NIL)))

(defun uass-load (&rest wd-list)
  (select current-processor-type
    (:lambda (apply 'uass-load-lambda wd-list))
    (:explorer (apply 'uass-load-explorer wd-list))
    (t (ferror nil "foo"))))

(DEFUN UASS-LOAD-lambda (&REST WD-LIST &AUX SYMTAB (MAX-LOC 0))
  (DO ((P WD-LIST (CDR P))
       (LOC 100))
      ((NULL P))
    (LET ((S (CAR P)))
      (COND ((NUMBERP S)
	     (SETQ LOC S))
	    ((SYMBOLP S)
	     (IF (ASSQ S SYMTAB)
		 (FERROR NIL "multiply defined loadtime symbol ~s" S)
	       (PUSH (CONS S LOC) SYMTAB)))
	    (T
	     (SETQ MAX-LOC (MAX MAX-LOC LOC))
	     (SETQ LOC (1+ LOC))))))
  (LOAD-STRAIGHT-CRAM-ADR-MAP (1+ (// MAX-LOC 20)))
  (DO ((P WD-LIST (CDR P))
       (LOC 100))
      ((NULL P))
    (LET ((S (CAR P)))
      (COND ((NUMBERP S)
	     (SETQ LOC S))
	    ((SYMBOLP S))	;symbol definition
	    (T (WRITE-CRAM-WITH-GOOD-PARITY LOC (UASS-LOAD-EVAL (CAR S) SYMTAB))
	       (SETQ LOC (1+ LOC))))))
  MAX-LOC)

(DEFUN UASS-LOAD-explorer (&REST WD-LIST &AUX SYMTAB (MAX-LOC 0))
  (DO ((P WD-LIST (CDR P))
       (LOC 100))
      ((NULL P))
    (LET ((S (CAR P)))
      (COND ((NUMBERP S)
	     (SETQ LOC S))
	    ((SYMBOLP S)
	     (IF (ASSQ S SYMTAB)
		 (FERROR NIL "multiply defined loadtime symbol ~s" S)
	       (PUSH (CONS S LOC) SYMTAB)))
	    (T
	     (SETQ MAX-LOC (MAX MAX-LOC LOC))
	     (SETQ LOC (1+ LOC))))))
  (DO ((P WD-LIST (CDR P))
       (LOC 100))
      ((NULL P))
    (LET ((S (CAR P)))
      (COND ((NUMBERP S)
	     (SETQ LOC S))
	    ((SYMBOLP S))	;symbol definition
	    (T (send *proc* :write-c-mem LOC (UASS-LOAD-EVAL (CAR S) SYMTAB))
	       (SETQ LOC (1+ LOC))))))
  MAX-LOC)

(DEFUN UASS-LOAD-EVAL (EXP SYMTAB)
  (COND ((NUMBERP EXP) EXP)
	((SYMBOLP EXP)
	 (LET ((TEM (ASSQ EXP SYMTAB)))
	   (COND (TEM (CDR TEM))
		 (T (FERROR NIL "~s stray symbol" EXP)))))
	((EQ (CAR EXP)
	     'UA-LOADTIME-DPB)
	 (DPB (UASS-LOAD-EVAL (CADR EXP) SYMTAB)
	      (UASS-LOAD-EVAL (CADDR EXP) SYMTAB)
	      (UASS-LOAD-EVAL (CADDDR EXP) SYMTAB)))
	(T (FERROR NIL "~s undefined loadtime function" (CAR EXP)))))
      


;(defun s-test ()
;  (let ((*EXECUTE-SINGLE-UINST-MODE* t))
;    (write-spy-reg 123)
;    (lam-execute (write)
;      lam-ir-op lam-op-alu
;      lam-ir-ob lam-ob-alu
;      lam-ir-aluf lam-alu-setm
;      lam-ir-m-src lam-m-src-spy-reg
;      lam-ir-m-mem-dest 1
;      )
;    (write-spy-reg 0)
;    (lam-execute (write)
;      lam-ir-op lam-op-alu
;      lam-ir-ob lam-ob-alu
;      lam-ir-aluf lam-alu-setm
;      lam-ir-m-src 1
;      ;lam-ir-func-dest lam-func-dest-spy-reg	;**doesnt appear to exist.
;      )					; - no, spy reg is NOT a destination. -dexter
;    ))   ;**incomplete**
;

(defun x-write-pc (n)
  (let ((*EXECUTE-SINGLE-UINST-MODE* t))
    (write-pc n)))

(comment
 (write-ireg		;*** this was at top level???
  (LAM-EXECUTE (return)
	       LAM-IR-OP LAM-OP-JUMP	;JUMP INSTRUCTION TO IR
	       LAM-IR-JUMP-ADDR 321
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)) )