;;-*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;; (c) Copyright 1983, 1984,1985,1986 Lisp Machine, INC
;;
;; The purpose of this code is to be able to write a file of very formal
;; DEF-UTEST forms, which can be run and debugged on a Lisp Machine, and then have
;; SDU-TRANSLATE-FILE translate this into "C" code to be compiled by the 68000 Unix
;; machine into code for the SDU. -George Carrette 1/10/84 23:23:41
;; There are two parts, the LISP macrology, and the LISP -> C translation.

(defun getk (p l d)
  (cadr (or (getl p (list l))
	    (list p d))))

(DEFVAR *DEF-UTEST-DEBUG? NIL)

(DEFVAR *UTEST-RUN-BREAKS* NIL)

(declare (special *default-utest-initializers*
		  *default-utest-postializers*
		  *DEFAULT-UTEST-SWITCHES*))

;; the lisp macro and support

(defmacro def-utest (name description &body body)
  "This is used to define micro-coded tests of the LAMBDA hardware.
The NAME argument is defined as a lisp function to run the test.
The DESCRIPTION argument should be a string giving a medium sized multiple word name.
The BODY is made up of alternating keywords and values, meaning:
 :ARGUMENTS <list>
   Lambda variables, in order, for the LISP function.  Its not clear how this wins in C. --rg
 :INITIALIZERS <list> 
   Things to do to the lambda state before anything else>
 :POSTIALIZERS <list>
  Things to do after lambda stop and before register reads>
 :START <address>
 :ERROR-STOPS <list>
  A list of (<address> <error-string(s)>) where the error-string may be
  a string or list of strings.
 :GOOD-STOP <address>
 :INPUT-VALUES <list>
  A list of (<register-spec> <value>) where a register spec is usually
  a list (<name> <address>) e.g. (M-MEM 3).
 :OUTPUT-VALUES <list>
  A list of (<register-spec> <should-be-value> <error-string(s)>) where
  the error strings are printed if the value is not what it should be.
 :CONSTANTS <list>
  A list of (<symbol> <value>) constants which may be used as assembly time of
  the contained microcode.
 :CODE <list>
  A list of address labels and micro-instructions. A micro-instruction is
  a list of the form alternating <field-name> <value>.
 :UCODE <list> is microcode in regular assembler format.
 :SWITCHES"
  (push nil body)
  (let ((initializers (getk body ':initializers *default-utest-initializers*))
	(postializers (getk body ':postializers *default-utest-postializers*))
	(start (getk body ':start 0))
	(error-stops (getk body ':error-stops nil))
	(good-stop (getk body ':good-stop 0))
	(time-out (getk body ':time-out 10.))
	(input-values (getk body ':input-values nil))
	(output-values (getk body ':output-values nil))
	(code (getk body ':code nil))
	(ucode (getk body ':ucode nil))
	(constants (getk body ':constants nil))
	(ARGUMENTS (GETK BODY ':ARGUMENTS NIL))
	(SWITCHES (GETK BODY ':SWITCHES *DEFAULT-UTEST-SWITCHES*)))
    (cond ((and code ucode)
	   (ferror nil "Both :CODE and :UCODE given"))
	  (code
	   (progw constants
	     (multiple-value-bind (alist symtab max-loc)
		 (uass-code-lisp constants code)
	       (PROGV (MAPCAR #'CAR SYMTAB)
		      (MAPCAR #'CDR SYMTAB)
		 `(defun ,name (,@arguments &aux temp PC)
		    ,description
		    TEMP
		    (PROGW ',SWITCHES
		      (utest-message "~&; Running ~A" ,description)
		      ,@(mapcar #'(lambda (x) (list x)) initializers)
		      (utest-lam-break ':initializers)
		      ,@(mapcar #'lisp-code-for-register-write input-values)
		      (utest-lam-break ':input-values)
		      (SETQ PC
			    (UTEST-LOAD-AND-GO ,(1+ (// MAX-LOC #o20))
					       ',ALIST
					       ,(uass-load-eval-atom start symtab)
					       ,TIME-OUT))
		      (cond ((= pc ,(uass-load-eval-atom good-stop symtab))
			     (utest-message ".....;OK~%"))
			    ,@(mapcar #'(lambda (stop)
					  `((= pc ,(uass-load-eval-atom (car stop) symtab))
					    (utest-error-message
					      "~&; ERROR: ~{~A~%~}"
					      ,(utest-message-string-normalize (cadr stop)))))
				      error-stops)
			    ('else
			     (utest-error-message "~&;   Unknown stop with PC = ~S" pc)))
		      ,@(mapcar #'(lambda (x) (list x)) postializers)
		      ,@(mapcar #'code-for-register-read-check output-values)))))))
	  (ucode
	   (progw constants
	     (let ((assm (prog2 (format t "~&;Running assembly for ~S" name)
				(assemble-ulap-list ucode)
				(format t "~&;Done~%"))))
	       (putprop assm start 'start)
	       (putprop assm good-stop 'good-stop)
	       (putprop assm error-stops 'error-stops)
	       (progv (mapcar #'car (get assm 'symbols))
		      (mapcar #'cadr (get assm 'symbols))
		 `(progn 'compile
			 (defun ,name (,@arguments)
			   (let ((*utest-name* ',name))
			     (progw ',switches
			       (utest-load-ucode)
			       ,@(mapcar #'(lambda (x) (list x)) initializers)
			       ,(code-for-symbolic-refs 'utest-symbolic-input-values
							input-values)
			       (utest-run-test)
			       ,@(mapcar #'(lambda (x) (list x)) postializers)
			       ,(code-for-symbolic-refs 'utest-symbolic-output-values
							(mapcar
							  #'(lambda (x)
							      (list (cons (car x)
									  (cddr x))
								    (cadr x)))
							  output-values)))))
			 (defprop ,name ,assm assembled-ucode))))))

	  ('else
	   (ferror nil "neither :CODE or :UCODE given")))))

(defvar *utest-name* nil)

(defun code-for-symbolic-refs (f l)
  (cons f (mapcan #'(lambda (reg)
		      (list `',(car reg) (eval (cadr reg))))
		  l)))

;; when we are in "C" translation mode the intent will be to transform the :UCODE
;; spec into a :CODE spec.

(DEFUN UTEST-LOAD-AND-GO (CRAM-PAGES ALIST START-PC TIME-OUT)
  (declare (special *parity-enable-list*))
  (LOAD-STRAIGHT-CRAM-ADR-MAP CRAM-PAGES)
  (utest-lam-break 'LOAD-STRAIGHT-CRAM-ADR-MAP)
  (cond ((null *paranoid-mode*)
	 (DOLIST (X ALIST)
	   (WRITE-CRAM-WITH-GOOD-PARITY (CAR X) (CDR X))))
	(t
	 (DOLIST (X ALIST)
	   (WRITE-CRAM-WITH-GOOD-PARITY-and-check (CAR X) (CDR X)))
	 (dolist (x alist)
	   (let ((data (read-cram (car x)))
		 (tem (compute-parity-64 (cdr x))))
	     (cond ((not (= data tem))
		    (format t "~%failed on readback adr ~s, is ~s should be ~s, dfs in bits "
			    (car x) data tem)
		    (print-bits (logxor data tem))))))))
  (utest-lam-break 'write-cram)
  (setup-machine-to-start-at START-PC)
  (utest-lam-break 'setup-machine-to-start-at)
  (LET ((DEFAULT-PARITY-ENABLE-LIST *PARITY-ENABLE-LIST*))
    (enable-lambda)
    (process-wait-with-timeout "Hope for  stop" time-out 'lam-halted)
    (utest-lam-break 'about-to-stop)
    (disable-lambda-and-nu-master))
  (READ-PC))

(defun utest-lam-break (x)
  (if *utest-run-breaks* (print x))
  (if (memq x *UTEST-RUN-BREAKS*)
      (lam)))

(defun utest-message-string-normalize (list-or-string)
  (cond ((stringp list-or-string)
	 `'(,list-or-string))
	((and (listp list-or-string)
	      (not (memq nil (mapcar #'stringp list-or-string))))
	 `',list-or-string)
	('else
	 (ferror nil "UTEST message not a string or list of strings: ~S"
		 list-or-string))))

(defmacro utest-message (string &rest l)
  `(format standard-output ,string ,@l))

(defconst *utest-stop-on-errors* nil)

(defun utest-error-message (string &rest l)
  (if *utest-stop-on-errors*
      (lexpr-funcall 'ferror nil string l)
    (lexpr-funcall 'format standard-output string l)))


;;; for the symbolic ucode form the variable *UTEST-NAME* is bound to the name
;;; of the test, and the ASSEMBLED-UCODE property of that is a plist with
;;; the data I-MEM D-MEM A-MEM START GOOD-STOP ERROR-STOPS
;;; We must implement UTEST-LOAD-UCODE, UTEST-RUN-TEST, UTEST-SYMBOLIC-INPUT-VALUES, 
;;; UTEST-SYMBOLIC-OUTPUT-VALUES.

(defun utest-load-ucode (&optional reset-p &aux (d (get *utest-name* 'assembled-ucode)))
  (LAM-ZERO-ENTIRE-MACHINE RESET-P)	;THIS INCLUDES SETTING UP THE CAM
  (SETQ UCODE-COUNTER 0)
  (FAST-LOAD-STRAIGHT-CRAM-ADR-MAP)
  (LAM-EXECUTE-W IZERO-GOOD-PARITY T)
  (do ((adr 0 (1+ adr))
       (l (get d 'i-mem) (cdr l)))
      ((null l))
    (write-cram-fast-optimized adr (car l)))
  (do ((adr 0 (1+ adr))
       (l (get d 'd-mem) (cdr l)))
      ((null l))
    (write-a-mem adr (car l)))
  (do ((adr 0 (1+ adr))
       (l (get d 'a-mem) (cdr l)))
      ((null l))
    (IF (< ADR 100)
	(LAM-WRITE-M-MEM ADR (car l))
      (LAM-WRITE-A-MEM ADR (car l))))
  (do ((adr 0 (1+ adr))
       (l (get d 'm-mem) (cdr l)))
      ((null l))
    (WRITE-MID adr (car l)))
  (SETQ LAM-FILE-SYMBOLS-LOADED-FROM NIL)
  (LAM-INITIALIZE-SYMBOL-TABLE T LAM-INITIAL-SYMS)
  (do ((l (get d 'symbols) (cdr l)))
      ((null l)
       (LAM-END-ADDING-SYMBOLS))
    (lexpr-funcall #'LAM-ADD-TYPED-SYMBOL (car l)))
  (lam-record-symbol-table *utest-name*)
  (SETQ LAM-FILE-SYMBOLS-LOADED-FROM *utest-name*))


(defun utest-run-test (&aux (d (get *utest-name* 'assembled-ucode)) pc symbolic-pc)
  (lam-reset-cache)
  (enable-cache)
  (lam-select-symbol-table *utest-name*)
  (ENABLE-PARITY)
  (setq lam-passive-save-valid t
	LAM-FULL-SAVE-VALID T)
  (set-main-stat-counter-to-count-csm-stat)
  (SETQ LAM-UPDATE-DISPLAY-FLAG T)
  (LAM-REGISTER-DEPOSIT RASA (LAM-SYMBOLIC-CMEM-ADR (get d 'start)))
  (LAM-REGISTER-DEPOSIT RAGO 0)
  (PROCESS-SLEEP 60. "running ucode")
  (LAM-REGISTER-DEPOSIT RASTOP 0)
  (setq pc (LAM-REGISTER-EXAMINE RAPC))
  (cond ((not (= pc (1+ (lam-symbolic-cmem-adr (get d 'good-stop)))))
	 (utest-message "~%Did not halt a good stop~%")
	 (utest-message "~%Test halted at ~S (= ~O)  " SYMBOLIC-PC PC)
	 (do ((l (get d 'error-stops) (cdr l)))
	     ((null l)
	      (utest-message "~%Halt was at unknown pc"))
	   (cond ((equal (caar l) symbolic-pc)
		  (format t "~{~%~A~}" (cdar l))
		  (return t)))))))

(defun utest-symbolic-input-values (&rest vals)
  (do ((l vals (cddr l)))
      ((null l))
    (LAM-SYMBOLIC-DEPOSIT-REGISTER (car l) (cadr l))))


(defun utest-symbolic-output-values (&rest vals)
  (do ((l vals (cddr l)))
      ((null l))
    (let ((reg (caar l))
	  (message (cdar l))
	  (value (cadr l)))
      (cond ((not (= (LAM-SYMBOLIC-EXAMINE-REGISTER reg)
		     value))
	     (print message))))))

(defun get-reg-ref-form (l)
  (let ((r (car l)))
    (If (atom r) (list r) (cons (car r) (mapcar #'si:eval-special-ok (cdr r))))))

(defun get-reg-value-form (l &optional lisp-args c-args)
   (get-c-value (eval (cadr l)) lisp-args c-args))

(defun lisp-get-reg-value-form (l &optional lisp-args c-args)
   lisp-args c-args
   (eval (cadr l)))

(defvar throw-lossage t)

(defun throw-lossage ()
  (if throw-lossage (*throw 'lossage 'lossage) (ferror nil "lossage")))

(defun get-c-value (expr args c-args)
  (if (fixp expr)
      expr
    (get-c-value-1 expr args c-args)))

(defun get-c-value-1 (expr args c-args &aux subexpr1 subexpr2 subexpr3 subexprlist c-op)
  (cond ((fixp expr) (format nil "~DL" expr))
	((and (symbolp expr) expr)
	 (loop for a in args
	       for ca in c-args
	       when (eq a expr)
	       return ca
	       finally (format t "GET-C-VALUE: Unknown Argument ~A~%" expr)
	               (throw-lossage)))
	((listp expr)
	 (cond ((not (symbolp (first expr)))
		(format t "GET-C-VALUE: Can't translate expression ~A~%" expr)
		(throw-lossage))

	       ((setq c-op (get (first expr) 'sdu-unary-operator))
		(cond (( (length (cdr expr)) 1)
		       (format t "GET-C-VALUE: Unary Operator ~A given many arguments ~A~%"
			       c-op expr)
		       (throw-lossage))
		      (t 
		       (setq subexpr1 (get-c-value-1 (second expr) args c-args))
		       (list c-op subexpr1))))

	       ((setq c-op (get (first expr) 'sdu-binary-operator))
		(cond (( (length (cdr expr)) 2)
		       (format t "GET-C-VALUE: Binary Operator ~A given many arguments ~A~%"
			       c-op expr)
		       (throw-lossage))
		      (t 
		       (setq subexpr1 (get-c-value-1 (second expr) args c-args))
		       (setq subexpr2 (get-c-value-1 (third expr) args c-args))
		       (list subexpr1 c-op subexpr2))))

	       ((setq c-op (get (first expr) 'sdu-nary-operator))
		(setq subexprlist (cdr expr))
		(cond ((not subexprlist)
		       (setq subexprlist (list (cond ((eq c-op '*) 1) (t 0)))))
		      ((and (eq c-op '-) (not (cdr subexprlist)))
		       (setq subexprlist (cons 0 subexprlist))))
		(do ((l subexprlist (cdr l))
		     (subexpr)(c-subexpr)
		     (firstp t nil)
		     (v nil))
		    ((null l) (nreverse v))
		  (setq subexpr (car l))
		  (setq c-subexpr (get-c-value-1 subexpr args c-args))
		  (or firstp (push c-op v))
		  (push  c-subexpr v)))

	       ((eq (first expr) 'IF)
		(setq subexpr1 (get-c-value-1 (second expr) args c-args))
		(setq subexpr2 (get-c-value-1 (third expr) args c-args))
		(cond ((cdddr expr)
		       (setq subexpr3 (get-c-value-1 (fourth expr) args c-args))))
		(cond (subexpr3 (list subexpr1 '? subexpr2 '/: subexpr3))
		      (t (list subexpr1 '? subexpr2))))

	       ((memq (first expr) '(ASH))	; add others later
		(setq subexpr1 (get-c-value-1 (second expr) args c-args))
		(setq subexpr2 (get-c-value-1 (third expr) args c-args))
		(list (first expr) (list subexpr1 '/, subexpr2)))


	       (t (format t "GET-C-VALUE: Can't translate expression ~A~%" expr)
		  (throw-lossage))))

	(t (format t "GET-C-VALUE: Can't translate expression ~A~%" expr)
	   (throw-lossage))))

(defprop if t sdu-c-value-ok)
(defprop ash t sdu-c-value-ok)

(putprop 'plus '+ 'sdu-nary-operator)
(putprop '+ '+ 'sdu-nary-operator)
(putprop 'difference '- 'sdu-nary-operator)
(putprop '- '- 'sdu-nary-operator)
(putprop 'times '* 'sdu-nary-operator)
(putprop '* '* 'sdu-nary-operator)
(putprop 'quotient '// 'sdu-nary-operator)
(putprop '// '// 'sdu-nary-operator)
(putprop 'remainder '% 'sdu-nary-operator)
(putprop '\ '% 'sdu-nary-operator)
(putprop 'minus '- 'sdu-unary-operator)

(putprop 'and '/&/& 'sdu-nary-operator)
(putprop 'or '|'| 'sdu-nary-operator)
(putprop 'not '! 'sdu-unary-operator)

(putprop 'logand '/& 'sdu-nary-operator)
(putprop 'logior '/| 'sdu-nary-operator)
(putprop 'lognot '/~ 'sdu-unary-operator)

(putprop '= '== 'sdu-binary-operator)
(putprop 'lessp '< 'sdu-binary-operator)
(putprop '< '< 'sdu-binary-operator)
(putprop '<= '<= 'sdu-binary-operator)
(putprop ' '<= 'sdu-binary-operator)
(putprop 'greaterp '> 'sdu-binary-operator)
(putprop '> '> 'sdu-binary-operator)
(putprop '>= '>= 'sdu-binary-operator)
(putprop ' '>= 'sdu-binary-operator)
(putprop ' '!= 'sdu-binary-operator)



(defun code-for-register-write (l &optional lisp-args c-args)
  (let ((register (get-reg-ref-form l))
	(value (get-reg-value-form l lisp-args c-args)))
    `(,(get (car register) 'register-write-function) ,@(cdr register) ,value)))

;added 8/16/84 by RG.  other frob bombed out trying to hack C in FLD-SML2
(defun lisp-code-for-register-write (l &optional lisp-args c-args)
  (let ((register (get-reg-ref-form l))
	(value (lisp-get-reg-value-form l lisp-args c-args)))
    `(,(get (car register) 'register-write-function) ,@(cdr register) ,value)))

(defun code-for-register-read (register)
  `(,(get (car register) 'register-read-function) ,@(cdr register)))

(defun code-for-register-read-check (l)
  (let ((register (get-reg-ref-form l))
	(value (get-reg-value-form l))
	(error-string (caddr l)))
    `(or (= ,value
	    (setq temp ,(code-for-register-read register)))
	 (utest-message "~&ERROR: ~{~A~%~}; Expecting ~S, got ~S~%"
			,(utest-message-string-normalize error-string)
			,value temp))))

(defun uass-load-eval-atom (x symtab)
  (cond ((Numberp x) x)
	((symbolp x)
	 (cdr (or (assq x symtab)
		  (ferror nil "Undefined U symbol: ~S" x))))
	(t
	 (ferror nil "bad uass atom: ~S" x))))

(DEFUN PEEK-DEF-UTEST (MESSAGE EXP)
  (COND (*DEF-UTEST-DEBUG?
	 (FORMAT STANDARD-OUTPUT "~&; ~A~%" MESSAGE)
	 (GRIND-TOP-LEVEL EXP)))
  EXP)

(defun uass-code-lisp (constants code)
  ;; Budding Lisp Programmers: Do not call EVAL like this, if you can
  ;; help it. Modularity problem here in the way we want to get
  ;; access to the ULOAD macro's functionality.
  (PEEK-DEF-UTEST "INPUT UCODE" CODE)
  (si:eval-special-ok
    `(uass-code-lisp-sub ,@(PEEK-DEF-UTEST "ULOADABLE"
					   (uass (mapcar #'car constants)
						 code)))))

(DEFUN UASS-CODE-LISP-sub (&REST WD-LIST &AUX SYMTAB (MAX-LOC 0))
  (DO ((P WD-LIST (CDR P))
       (LOC #o100))
      ((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))
       (L)
       (LOC #o100))
      ((NULL P)
       (values (nreverse l) symtab max-loc))
    (LET ((S (CAR P)))
      (COND ((NUMBERP S)
	     (SETQ LOC S))
	    ((SYMBOLP S))	;symbol definition
	    (T
	     (push (cons loc (UASS-LOAD-EVAL (CAR S) SYMTAB)) L)
	     (SETQ LOC (1+ LOC)))))))

(defun assemble-ulap-list (list-of-instructions)
  "Calls internal functions of the assembler to get an assembly done"
  (lam-lap-initialize nil)
  (lam-lap nil list-of-instructions nil)
  (list 'assembly
	'i-mem (list-array-until-nil i-mem)
	'd-mem (list-array-until-nil d-mem)
	'a-mem (list-array-until-nil a-mem)
	'symbols (lam-dump-symbols-list)))


(DEFUN LAM-DUMP-SYMBOLS-LIST (&aux LAM-DUMP-SYMBOLS-LIST)
  (declare (special LAM-DUMP-SYMBOLS-LIST))
  (MAPATOMS #'(lambda (SYM)
		(PROG (VAL DMP-TYPE TEM)
		      (SETQ VAL (GET SYM 'LAM-LAP-USER-SYMBOL))
		   L
		      (COND ((NULL VAL) (RETURN NIL))
			    ((NUMBERP VAL)
			     (SETQ DMP-TYPE 'NUMBER))
			    ((ATOM VAL)
			     (SETQ VAL (LAM-LAP-SYMEVAL VAL))
			     (GO L))
			    ((AND (SETQ TEM (ASSQ (CAR VAL) 
						  '( (I-MEM JUMP-ADDRESS-MULTIPLIER)
						    (D-MEM DISPATCH-ADDRESS-MULTIPLIER)
						    (A-MEM A-SOURCE-MULTIPLIER)
						    (M-MEM M-SOURCE-MULTIPLIER))))
				  (EQ (CAADR VAL) 'FIELD)
				  (EQ (CADADR VAL) (CADR TEM)))
			     (SETQ DMP-TYPE (CAR VAL) VAL (CADDR (CADR VAL))))
			    (T (RETURN NIL)))
		      (push (list sym dmp-type val) lam-dump-symbols-list)
		      (RETURN T)))
	    "LAM")
  lam-dump-symbols-list)

(defun list-array-until-nil (array)
  (do ((n (array-dimension array 0))
       (j 0 (1+ j)))
      ((or (= j n) (null (aref array j)))
       (let ((l (make-list j)))
	 (setq j 0)
	 (do ((l l (cdr l)))
	     ((null l))
	   (setf (car l) (aref array j))
	   (setq j (1+ j)))
	 l))))


;; The LISP -> C translation, which calls some of the lisp macro support.

(defconst *sdu-translate-pathname-defaults* (fs:make-pathname-defaults))

(fs:merge-and-set-pathname-defaults (fs:make-pathname ':directory "LAMBDA-DIAG")
				    *sdu-translate-pathname-defaults*)

(defvar *sdu-gen-function-count* 0)

(defvar *sdu-translate-switches* (list '*sdu-translate-switches*))

(defvar *sdu-function-arg-alist* nil)

(defvar *sdu-untranslatable-functions* nil)

(defmacro sdu-function-argnum (funname)
  `(length (sdu-function-arglist ,funname)))

(defmacro sdu-function-arglist (funname)
  `(cond ((cdr (assq ,funname *sdu-function-arg-alist*)))
	 (t nil)))

(defun add-sdu-translate-switch (name value)
  (putprop *sdu-translate-switches* value name))

(defmacro define-sdu-translate-switch (name value documentation)
  `(progn 'compile
	  (defconst ,name ,value ,documentation)
	  (add-sdu-translate-switch ',name ,value)))

(define-sdu-translate-switch *output-main-prog? t "if NIL, no main is generated")


(defun sdu-c-compile (name &optional (machine "Capricorn")
			 &aux (unix-directory "//lmi//utest")
			      (unix-library "//lmi//utest//libregs86.a //lmi//utest//libc.a")
			      lm-c-source-file unix-c-source-file
			      unix-binary-file unix-name)

  (setq lm-c-source-file (fs:parse-pathname name))

  (setq unix-c-source-file 
	(fs:parse-pathname (format nil "~A:~A//~A.c" machine unix-directory
				   (setq unix-name 
					 (string-downcase (send lm-c-source-file ':name))))))
  (format t "~%")
  (format t "; Copying ~A to ~A~%" name unix-c-source-file)
  (fs:copy-file lm-c-source-file unix-c-source-file)
  (format t "; Writing compiler output to ~A~%"
	  (setq unix-binary-file (fs:parse-pathname (format nil "~A:~A//~A" 
						    machine unix-directory unix-name))))
  (format t "; Running 8086 C Compiler on ~A~%" machine)
  (simple-eval-connect machine
		       (format nil "cd ~A; rm ~A; cc86 -m -o ~A ~A.c ~A; "
			        unix-directory unix-name unix-name unix-name unix-library))

  (cond ((probef unix-binary-file) 
	 (format t "~%")
	 (format t "; The compilation was successful~%")
	 (cond ((y-or-n-p "Do you want to make a diagnostic tape ")
		(format t "~%; Load a blank tape into the tape drive on Capricorn~%")
		(format t "; Type any character to continue ")
		(tyi)		
		(format t "~%")
		(cond ((neq (si:parse-host machine) (si:parse-host "Capricorn"))
		       (format t "; Tapes can only be made on Capricorn at present~%"))
		      (t

		       (simple-eval-connect "Capricorn"
					    (format nil "cd ~A; //lmi//bin//maketape ~A; "
							 unix-directory unix-name))
		       (format t "; To run the diagnostic tape on an SDU, load the tape ")
		       (format t "and type '//tar//~A'~%" unix-name)))))
	 t)
	
	(t
	 (format t "~%")
	 (format t "; Output file ~A does not exist.~%" unix-binary-file)
	 (format t "; There must have been a compilation error~%")
	 nil)))




(defun simple-eval-connect (host command)
  (with-open-stream (s (chaos:open-stream host (format nil "EVAL ~a" command)))
    (format t "; ~A~%" command)
    (do ((c (send s ':tyi) (send s ':tyi)))
	((null c))
      (send standard-output ':tyo
	    (selectq c
	      ((12 15) #\return)
	      (11 #\tab)
	      (t c))))))


(defun sdu-translate-file (name)
  "Translates a file of lisp containing only DEF-UTEST forms into C code
to be compiled on the Unix system and run in the system diagnostic unit environment."
  (let ((*sdu-untranslatable-functions* nil) retval)

    (setq retval (file-worker #'sdu-translate-file-worker
			      name
			      *sdu-translate-pathname-defaults*
			      ':lisp
			      "C"))

    (cond (*sdu-untranslatable-functions*	   (format t "Could not translate the following definitions:")
	   (loop for x in *sdu-untranslatable-functions*
		 do (format t "~%	~A" x)
		 finally (format t "~%"))
	   (format t "Doing a second pass to get rid of garbage that was generated...~%")
	   (file-worker #'sdu-translate-file-worker
			name
			*sdu-translate-pathname-defaults*
			':lisp
			"C"))
	  (t retval))))


(defun sdu-translate-file-worker (i o)

  (progv (do ((l (cdr *sdu-translate-switches*) (cddr l))
	      (v nil (cons (car l) v)))
	     ((null l) v))
	 (do ((l (cdr *sdu-translate-switches*) (cddr l))
	      (v nil (cons (cadr l) v)))
	     ((null l) v))
    (let ((iname (send (send i ':truename) ':string-for-printing))
	  (oname (send (send o ':truename) ':string-for-printing)))
      (format standard-output
	      "~&; Reading from ~S~%; C code output to ~S~%"
	      iname
	      oname)
      (format o
	      "~
              ~70,,,'*<//~;~>~
              ~%~70< * Automatically generated C code for the LAMBDA SDU ~;*~>~
              ~%~70< * (C) Copyright 1984,1985,1986 LISP MACHINE, INC ~;*~>~
              ~%~70< * Compiled from ~S by ~S ~;*~>~
              ~%~70< * ~A ~;*~>~
              ~%~71,,,'*< *~;//~>~
              ~%~%#include <lam-regs.h>~%~%
              ~%~%long ASH(x, y) long x, y; { return(y >= 0 ? x << y : x >> -y);}~%~%
              ~%~%int Debug = 2;~%~%"
	      iname
	      (status userid)
	      (time:print-current-date nil)
	      )

      (let ((*sdu-gen-function-count* 0)
	    (*def-utest-debug? nil)
	    (*sdu-function-arg-alist* nil)
	    )
	(do ((form)(eof (list nil))(l))
	    ((eq eof (setq form (read i eof)))
	     (if *output-main-prog?
		 (output-main-prog (nreverse l) o)))
	  (let ((pair (translate-def-test-to-c form o)))
	    (if pair (push pair l)))))
      (send o ':truename))))


(defun file-worker (function name defaults input-type output-type)
  (let ((input-filename (fs:merge-pathname-defaults name defaults)))
    (with-open-stream (input-stream
			(file-retry-new-pathname (input-filename fs:file-error)
			  (send input-filename ':open-canonical-default-type input-type)))
      (setq input-filename (send input-stream ':pathname))
      (fs:set-default-pathname input-filename defaults)
      (let ((GENERIC-PATHNAME (SEND INPUT-FILENAME ':GENERIC-PATHNAME)))
	(FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME INPUT-STREAM)
	(MULTIPLE-VALUE-BIND (VARS VALS) (FS:FILE-ATTRIBUTE-BINDINGS GENERIC-PATHNAME)
	  (PROGV VARS VALS
	    (with-open-file (output-stream (send input-filename ':new-type output-type)
					   ':OUT)
	      (funcall function input-stream output-stream))))))))

(defun emit-c-function-call (exp stream &optional (left "   ") (right ";")
			     )
  "This is intended to take care of all uses of C function calls we need"
  ;; This does a rough-and-ready (i.e. poor) job of indentation pretty printing.
  ;; Pace told me he wants it indented "in the correct style," but foo
  ;; on that. He can hack this function if he wants to.
  (let ((f (car exp))
	(args (cdr exp))
	(yow)
	(fz 0))
    (let ((s (if (stringp f) f (get-sdu-c-function f))))
      (cond ((listp s)
	     (setq args (apply (cadr s) args))
	     (setq s (car s))))
      (format stream "~A~A(" left s)
      (setq fz (+ fz 1 (flatc left) (flatc s)))
      (let ((indentz fz))
	(do ((l args (cdr l)))
	    ((null l))
	  (let ((arg (car l)))
	    (cond ((fixp arg)
		   (format stream "~DL" arg)
		   (setq fz (+ fz (flatsize arg) 1)))
		  ((stringp arg)
		   ;; should make sure it has no funny characters in it.
		   (prin1 arg stream)
		   (setq fz (+ fz (flatsize arg))))
		  ((symbolp arg)
		   (princ arg stream)
		   (setq fz (+ fz (flatc arg))))
		  ((listp arg)
		   (princ arg stream)
		   (setq fz (+ fz (flatc arg))))
		  ('else
		   (ferror nil "Bad argument to a C function: ~S" arg)))
	    (when (cdr l)
	      (tyo #/, stream)
	      (setq fz (1+ fz))
	      (when (> fz 50.)
		(setq fz indentz)
		(or yow (setq yow (format nil "~VA" indentz "")))
		;; bug in format makes the reasonable (format stream "~&~VT" fz)
		;; work on terminal-io, but not to file output streams????
		;; but this kludge works.
		(format stream "~&~A" yow)))))))
    (format stream ")~A~%" right)))

(defun emit-c-long-array-init (name longs stream &optional f l)
  ;;(format stream "~&~%long ~A[~D] = {~%~{  ~DL~^,~%~}~%};"
  ;;  name (length longs) longs)
  (format stream "~&~%long ~A[~D] = {~%" name (length longs))
  (do ((l longs (cdr l))
       (v l (cdr v)))
      ((null l))
    (format stream "  ~DL" (car l))
    (princ (if (cdr l) "," " ") stream)
    (cond (f
	   (princ " //* " stream)
	   (funcall f (car v) stream)
	   (princ " *//" stream)))
    (terpri stream))
  (princ " };" stream)
  (terpri stream)
  (terpri stream))

(defun emit-compare-fclause (x stream left)
  (emit-c-function-call (list (cdr x))
			stream
			(format nil "        ~A (strcmp(~S,argv[i]) == 0) "
				left (string-downcase (car x)))))


;;; First, check how many arguments there are.
;;; If there are no arguments, add "*" to the arguement list (which indicates that
;;; it should run all the test that don't take any arguments).
;;; If there are any tests that do take arguments, print a message, but don't run them.
;;; 
;;; Skip the first element of argv.  
;;;
;;; Loop:
;;;
;;; The next element of argv is the current test name.  
;;; Determine how many numeric arguments, if any,
;;; have been passed via the command line.
;;;
;;; If the current test name is "*", then call all the tests that don't take any arguments.
;;;
;;; If the current test is one that doesn't take any arguments, then call it.
;;; Print an error message if any numeric arguments were passed to it.
;;;
;;; If the current test takes some arguments:  Call the test, unless the wrong number
;;; of arguments were passed to it, in which case print an error message.
;;;
;;; In the argv array, skip over the current test name, and its arguments if any.  Unless
;;; we are at the end of argv, go to Loop.
;;;
;;; The following is an example 'main' that would be generated if there were four tests:
;;; 'test1', 'test2', 'test3', and 'test4', which take 0, 0, 0, and 4 arguments respecively.
;;;
;;; main(argc, argv)
;;;   int argc; 
;;;   char *argv[]; 
;;;   {
;;;   int subargc;
;;;
;;;   laminit();
;;;
;;;   if (argc == 1)
;;;      {
;;;      printf("Not calling test 'test4', because it requires m arguments\n");
;;;      printf("Not calling test bar, because it requires n arguments\n");
;;;
;;;      argc = 1;
;;;      argv = &("*");
;;;      }
;;;   else
;;;      {
;;;      argc--;
;;;      argv++;
;;;      }
;;;
;;;   while(argc > 0)
;;;      {
;;;
;;;      for (subargc = 1 ; isanarg(argv[subargc]) ; subargc++);
;;;
;;;      if (strcmp(argv, "*"))
;;;          {
;;;          test1();
;;;          test2();
;;;          test3();
;;;          }
;;;      else if (strcmp(*argv, "test1"))
;;;          {
;;;          if (subargc > 0)
;;;             {
;;;             printf("Test 'test1' expects no arguments, but it received %d.\n", subargc);
;;;             printf("Extra arguments ignored\n");
;;;             }
;;;          test1();
;;;          }
;;;
;;; --- repeat the above 'else if' form for 'test2' and 'test3'
;;;
;;;      else if (strcmp(*argv, "test4"))
;;;          {
;;;          if (subargc != 4)
;;;             {
;;;             printf("Test 'test4' expects 4 arguments, but it received %d.\n", subargc);
;;;             printf("Aborting test\n");
;;;             }
;;;          else
;;;             test4(subargc+1, argv+1);
;;;          }
;;;
;;;      argc -= subargc;
;;;      argv += subargc;
;;;      }
;;;   }
;;;
;;;
;;;
;;;


(defun output-main-prog (l stream)

  (format stream "~%isanarg(str)~%")
  (format stream "   char *str;~%")
  (format stream "   {~%")
  (format stream "   while (*str)~%")
  (format stream "      if (*str < '0' || *str++ > '9')~%")
  (format stream "          return(0);~%")
  (format stream "   return(1);~%")
  (format stream "   }~%~%~%")

  (format stream "~%")
  (format stream "main(argc, argv)~%")
  (format stream "   int argc;~%")
  (format stream "   char *argv[];~%")
  (format stream "   {~%")
  (format stream "   int subargc;~%")
  (format stream "~%")
  (format stream "   laminit();~%")
  (format stream "~%")
  (format stream "   if (argc == 1)~%")
  (format stream "      {~%")
  (cond (*sdu-function-arg-alist*
	 (format stream "      printf(/"Calling all tests, except those which require arguments\n/");~%")
	 (loop for funspec in l
	       for funname =  (car funspec)
	       for argnum = (sdu-function-argnum funname)
	       when (> argnum 0)
	       do (format stream 
			  "      printf(/"(Not calling test ~A, because it takes ~D arguments)\n/");~%" (string-downcase funname) argnum)))
	(t
	 (format stream "      printf(/"Calling all tests\n/");~%")))

  (format stream "      argc = 1;~%")
  (format stream "      argv[0][0] = '*';~%")
  (format stream "      argv[0][1] = 0;~%")
  (format stream "      }~%")
  (format stream "   else~%")
  (format stream "      {~%")
  (format stream "      argc--;~%")
  (format stream "      argv++;~%")
  (format stream "      }~%")
  (format stream "~%")
  (format stream "   while(argc > 0)~%")
  (format stream "      {~%")
  (format stream "~%")

  (format stream "      for (subargc = 0 ; subargc+1 < argc && isanarg(argv[subargc+1]) ; subargc++);~%")
  (format stream "~%")
  (format stream "      if (strcmp(*argv, /"*/") == 0)~%")
  (format stream "         {~%")
  (loop for funspec in l
	when (zerop (sdu-function-argnum (car funspec)))
	do (emit-c-function-call (list (cdr funspec)) stream "         "))

  (format stream "         }~%")

  (format stream "      else if (strcmp(*argv, /"?/") == 0)~%")
  (format stream "         {~%")
  (loop for funspec in l
	for funname =  (car funspec)
        for arglist = (sdu-function-arglist funname)
	do (format stream "         printf(/"~A" (string-downcase funname))
	when arglist
	do (format stream " ~A" arglist)
	do (format stream "\n/");~%"))
  (format stream "         }~%")

  (loop for funspec in l
	for argnum = (sdu-function-argnum (car funspec))
	do
	(format stream "      else if (strcmp(*argv, /"~A/") == 0)~%" (string-downcase (car funspec)))
	(format stream "         {~%")
	when (zerop argnum)
	do
	(format stream "         if (subargc > 0)~%")
	(format stream "            {~%")
	(format stream "            printf(/"Test '~A' takes no arguments, but it got %d.\n/", subargc);~%" (string-downcase (car funspec)))
	(format stream "            printf(/"Extra arguments ignored\n/");~%")
	(format stream "            }~%")
	(emit-c-function-call (list (cdr funspec)) stream "         ")
	(format stream "         }~%")
	else
	do 
	(format stream "         if (subargc != ~D)~%" argnum)
	(format stream "            {~%")
	(format stream "            printf(/"Test '~A' takes ~D arguments, but it got %d.\n/", subargc);~%" (string-downcase (car funspec)) argnum)
	(format stream "            printf(/"Skipping test\n/");~%")
	(format stream "            }~%")
	(format stream "         else~%")
	(format stream "            ~a(subargc+1, argv);~%" (cdr funspec))
	(format stream "         }~%"))
  
  (format stream "      argc -= subargc+1;~%")
  (format stream "      argv += subargc+1;~%")
  (format stream "      }~%")
  (format stream "   }~%")
  (format stream "~%"))



(comment "Old definition"

 (defun output-main-prog (l stream)
  
  (format stream "~&~%main(argc,argv) int argc; char *argv[];~%{int i;~%")
  (format stream "   laminit();~%")
  (format stream "   if (argc == 1)~%    {~%")
  (mapc #'(lambda (x) (emit-c-function-call (list x) stream "    "))
	(mapcar #'cdr l))
  (format stream "    }~%   else for (i = 1; i < argc; i++)~%        {~%")
  (if l (emit-compare-fclause (car l) stream "if"))
  (mapc #'(lambda (x)
	    (emit-compare-fclause x stream "else if"))
	(cdr l))
  (if l (emit-c-function-call '("printf" "Undefined test: %s\n" |argv[i]|)
			      stream
			      "        else "))
  (format stream "        }}~%~%"))
 )

(defvar get-sdu-c-function ':default)

(defvar max-c-function-pname-length 7.)

(defun get-sdu-c-function (x)
  (cond ((get x 'sdu-c-function))
	(t (format t "Unknown function in SDU C code: ~S~%" x)
	   (cond ((eq ':default get-sdu-c-function)
		  (let ((l (del #'(lambda (ignore x)
				    (not (legal-c-pname-char x)))
				nil
				(sublis '((#/- . #/_))
					(listarray (get-pname x))))))
		    (if (> (length l) max-c-function-pname-length)
			(setq l (del #'(lambda (ignore x)
					 (memq (char-upcase x)
					       '(#/A #/E #/I #/O #/U)))
				     nil
				     l
				     (- (length l) max-c-function-pname-length))))
		    (if (> (length l) max-c-function-pname-length)
			(setq l (firstn max-c-function-pname-length l)))
		    (if (null l)
			(flossage "can't make a legal c name from: ~s" x))
		    (let ((a (make-array (length l) ':type 'art-string)))
		      (fillarray a l)
		      (format t "Assuming C name ~S for ~S~%" a x)
		      (putprop x a 'sdu-c-function)
		      a)))
		 (t (throw-lossage))))))

(defun gen-sdu-c-fname (root)
  (format nil "~A_~D"
	  root
	  (prog1 *sdu-gen-function-count*
		 (setq *sdu-gen-function-count* (1+ *sdu-gen-function-count*)))))

(defun gen-sdu-c-aname nil
  (intern (gen-sdu-c-fname 'X)))

(defun translate-def-test-to-c (form stream &aux (base 10.) (*nopoint t) (ibase 10.) retval)
  ;; Has been extended to translate other forms.
  (cond ((and (not (atom form))
	      (symbolp (car form))
	      (get (car form) 'lisp-to-c-toplevel))
	 (cond ((not (mem #'equal (cadr form) *sdu-untranslatable-functions*))
		(setq retval (funcall (get (car form) 'lisp-to-c-toplevel) form stream))
		(cond ((eq retval 'lossage)
		       (format t "Aborted C translation of ~A ~A~%" (car form) (cadr form))
		       (setq *sdu-untranslatable-functions* 
			     (cons (cadr form) *sdu-untranslatable-functions*))
		       nil)
		      (t retval)))))
	('else
	 (*catch 'lossage (flossage "Unhandled form: ~S" form))
	 nil)))

(defun (def-utest lisp-to-c-toplevel) (form stream)
  (*catch 'lossage
    
  ;; This should coorespond pretty much one-to-one with the code generation in DEF-UTEST.
  ;; It may look like fairly dense code but it isn't complicated.
  (let ((name (cadr form))
	(description (caddr form))
	(body (cddr form)))
    (format stream "~&~%//* Translation of DEF-UTEST ~S *//~%" name)
    (let ((initializers (getk body ':initializers *default-utest-initializers*))
	  (postializers (getk body ':postializers *default-utest-postializers*))
	  (start (getk body ':start 0))
	  (error-stops (getk body ':error-stops nil))
	  (good-stop (getk body ':good-stop 0))
	  (time-out (getk body ':time-out 10.))
	  (input-values (getk body ':input-values nil))
	  (output-values (getk body ':output-values nil))
	  (code (getk body ':code nil))
	  (constants (getk body ':constants nil))
	  (ARGUMENTS (GETK BODY ':ARGUMENTS NIL))
	  c-arguments)
;;;   (if arguments (*throw 'lossage nil))
      (if arguments (setq *sdu-function-arg-alist*
			  (cons (cons name arguments) *sdu-function-arg-alist*)))
      (progw constants 
	(multiple-value-bind (alist symtab max-loc)
	    (uass-code-lisp constants code)
	  (PROGV (MAPCAR #'CAR SYMTAB)		; CRUDE BUT EFFECTIVE.
		 (MAPCAR #'CDR SYMTAB)
	  (let ((aname1 (gen-sdu-c-fname "A"))
		(aname2 (gen-sdu-c-fname "A"))
		(aname3 (gen-sdu-c-fname "A"))
		(fname (gen-sdu-c-fname "F")))
	    (emit-c-long-array-init aname1
				    (mapcar #'car alist)
				    stream
				    #'(lambda (uinst stream)
					(let ((standard-output stream))
					  (lam-print-uinst uinst)))
				    (mapcar #'cdr alist))
	    (emit-c-long-array-init aname2 (mapcar #'(lambda (x)
						       (logand #o37777777777 (cdr x)))
						   alist) stream)
	    (emit-c-long-array-init aname3 (mapcar #'(lambda (x)
						       (logand #o37777777777
							       (ash (cdr x) -32.)))
						   alist) stream)
	    (format stream "~&~%~a(" fname)

	    (cond (arguments
		   (loop for n in (setq c-arguments (loop for arg in arguments
							  collect (gen-sdu-c-aname))))
		   (format stream "argc, argv")))
	    
	    (format stream ")~%")
	    (cond (arguments
		   (format stream "int argc; char *argv[];~%")))
	    (format stream "{long pc,temp;~% int j;~%")
	    (cond (arguments
		   (format stream "   unsigned long ")
		   (loop for arg in c-arguments
			 unless (eq arg (car c-arguments))
			 do (format stream ",")
			 do (format stream "~a" arg)
			 finally (format stream ";~%"))
		   (loop for arg in c-arguments
			 for arg-count from 1
			 do (format stream "   sscanf(argv[~d], /"%O/", &~a);~%" 
				    arg-count arg))))

	    (emit-c-function-call `("printf" "\nRunning %s\n" ,description) stream)
	    (mapc #'(lambda (x)
		      (emit-c-function-call `(,x) stream))
		  initializers)
	    (mapc #'(lambda (x)
		      (emit-c-function-call (code-for-register-write x arguments c-arguments)
					    stream))
		  input-values)
	    (emit-c-function-call `(LOAD-STRAIGHT-CRAM-ADR-MAP ,(1+ (// MAX-LOC #o20)))
				  stream)
	    (format stream "   for (j=0;j<~D;j++)~%" (length alist))
	    (format stream "    ~a(~a[j],~a[j],~a[j]);~%"
		    (get-sdu-c-function 'write-cram)
		    aname1
		    aname2
		    aname3)
	    (emit-c-function-call `(setup-machine-to-start-at
				     ,(uass-load-eval-atom start symtab))
				  stream)
	    (emit-c-function-call '(enable-lambda) stream)
	    (emit-c-function-call `(process-sleep ,time-out "Hope for stop")
				  stream
				  "   j = ")
	    (emit-c-function-call '("printf" "lambda stopped\n")
				  stream
				  "   if ( j == 0) ")
	    (emit-c-function-call '("printf" "timeout: lambda did not stop\n")
				  stream
				  "    else ")
	    (emit-c-function-call '(disable-lambda) stream)
	    (emit-c-function-call '(read-pc) stream "   pc = ")
	    (emit-c-function-call '("printf" "Passed the test\n")
				  stream
				  (format nil "   if (pc == ~D) "
					  (uass-load-eval-atom good-stop symtab)))
	    (mapc #'(lambda (stop)
		      (let ((mess (cadr (utest-message-string-normalize (cadr stop)))))
			(emit-c-function-call
			  `("printf"
			    ,(format nil "Error: ~{%s\n~*~}" mess)
			    ,@mess)
			  stream
			  (format nil "   else if (pc == ~D) "
				  (uass-load-eval-atom (car stop) symtab)))))
		  error-stops)
	    (emit-c-function-call '("printf" "Unknown stop with PC == %lo\n" |pc|)
				  stream
				  "   else ")
	    (mapc #'(lambda (x) (emit-c-function-call `(,x) stream))
		  postializers)
	    (mapc #'(lambda (l)
		      (let ((register (get-reg-ref-form l))
			    (value (get-reg-value-form l arguments c-arguments))
			    (es (cadr (utest-message-string-normalize (caddr l)))))
			(emit-c-function-call (code-for-register-read register)
					      stream
					      "   temp = ")
			(emit-c-function-call
			  `("printf"
			    ,(format nil "ERROR: ~{%s\n~*~}Expecting %lo, got %lo\n" es)
			    ,@es
			    ,value
			    |temp|)
			  stream
			  (format nil "   if ( temp != ~DL) " value))))
		  output-values)
	    (format stream "}~%~%")
	    (cons name fname)))))))))


;; random comment about functions which may be translated or be called
;; by the translated code.
;some lisp intialization functions:
;	init-tram  -  loads the tram with one of the available programs (1:1 , 2:2, etc)
;
;	setup-pmr  -  takes a list of fields and values for the processor mode register
;			computes and loads the specified value into the pmr
;
;	init-lambda - twiddles init bit in the configuration register: clears state in several
;			flops and clears the csmreg
;
;	load-csm -	loads the csm with a valid program: no options so far
;
;	wipe-csm  -	loads all locations in the csm with some value
;
;	force-uinst-clock-low - 	turns off allow-uinst-clocks, which forces t-hold
;				and then ticks sm-clock manually.  all bits in the tram
;				recirculate, but t.uinst.clock.next is ignored and t.uinst.
;				clock is loaded with 0
;
;	noop-uinst-clocks
;
;	noop-to-uinst-boundary
;
;	setup-dp-mode
;
;	setup-rg-mode
;
;	zero-ireg
;
;	enable-nu-master
;
;	disable-nu-master
;
;	setup-nubus-configuration


(defun (comment lisp-to-c-toplevel) (form stream)
  form stream
  nil)


;;; about general lisp->c translation 7/12/84 11:40:33 -gjc
;;; get-c-value provides a translation of "arithmetic" expressions over atoms.
;;; The textual result is obtained by PRINC, which is sufficient because the PAREN
;;; is syntactically benign in C. This routine combinded With EMIT-C-function call,
;;; allows the simple translation of primitive PROGIFIED lisp. e.g.
;;; (prog () (function-call <arithmetic> <arithmetic>))
;;; The statements in a progified form must be:
;;; <label>
;;; (return <function-call>)
;;; (go <label>)
;;; (if <function-call> (go <label>))
;;; (setq <arithmetic> <function-call>)
;;; <function-call>
;;; A <function-call> is (<lisp-function> <arithmetic> <arithmetic> ...)
;;; Some programmers may be writing code which is in this form already.
;;; Progification handles the bulk of the translation process, the rest
;;; is PNAME translation and formatting.

(defun legal-c-pname-char (c)
  (or (<= #/a c #/z)
      (<= #/A c #/Z)
      (<= #/0 c #/9)
      (= c #/_)))

(defun possibly-translated-aname (a)
  (do ((s (get-pname a))
       (j 0 (1+ j)))
      ((= j (string-length a))
       a)
    (cond ((not (and (legal-c-pname-char (aref s j))
		     (< j 10.)))
	   (return (gen-sdu-c-aname))))))

(defun possibly-translated-aname-l (l)
  (mapcar #'possibly-translated-aname l))


;; supporting &optional is hairy. if we know what functions are to be &optional
;; before translated calls to them then some null-arg value can be passed, or
;; the default value supplied, or what is hairier, set up a number-of-args
;; register, that is, don't use the C function call mechanism.
;; This we are open to do, since progification already gets rid of
;; nested function calls.
;; Since use of &optional is mostly for supplying of constant default value maybe
;; some kludge is called for.

(defun flossage (&rest l)
  (lexpr-funcall #'format t l)
  (throw-lossage))

(defun get-defun-form (name)
  (let ((x (and (symbolp name) (fboundp name) (not (atom (fsymeval name)))
		(eq (car (fsymeval name)) 'named-lambda)
		(fsymeval name))))
    (if x (cons 'defun (cdr x)))))

(defun l2c (name)
  (let ((x (get-defun-form name)))
    (if x
	(let ((throw-lossage nil))
	  (funcall (get 'defun 'lisp-to-c-toplevel) x standard-output))
      "can't translate")))

(defun lc (name)
  (terpri) (terpri)
  (eval `(grindef ,name))
  (terpri)
  (l2p name)
  (l2c name))


(defvar lisp-to ':c "set to :C or :fortran")

(defun (defun lisp-to-c-toplevel) (form stream)
  (*catch 'lossage
    (let ((name (cadr form))
	  (argl (caddr form))
	  (body (cdddr form)))
      (or (atom name) (setq name (apply #'string-append name)))
      (let ((c-argl
	      (mapcar
		#'(lambda (a)
		    (and (memq a lambda-list-keywords)
			 (flossage
			   "While translating ~A: No lambda list keywords supported ~A~%"
			   name a))
		    (possibly-translated-aname a))
		argl)))
	(format stream "~2%//* Translation of ~A *//~2%" name)
	(emit-c-function-call (cons name c-argl)
			      stream
			      "long "
			      (if argl (format nil " long ~{~a~^,~};" c-argl) ""))
	(let* ((progified-form (progify-function-body body))
	       (prog-vars (cadr progified-form))
	       (prog-c-vars (possibly-translated-aname-l prog-vars))
	       (labels (mapcan #'(lambda (x) (if (atom x) (list x))) (cddr progified-form)))
	       (c-label-alist (mapcar #'cons labels (possibly-translated-aname-l labels)))
	       (combined-vars (append argl prog-vars))
	       (combined-c-vars (append c-argl prog-c-vars)))
	  (if prog-vars
	      (format stream "{long ~{~a~^,~};~%" prog-c-vars)
	    (format stream "{~%"))
	  (dolist (x (cddr progified-form))
	    (if (atom x)
		(format stream " ~A:~%" (cdr (assq x c-label-alist)))
	      (selectq (car x)
		(return
		 (emit-c-function-call-t (cadr x)
					 combined-vars
					 combined-c-vars
					 stream
					 "   return "))
		(if
		 (emit-c-function-call-t (cadr x)
					 combined-vars
					 combined-c-vars
					 stream
					 "   if ("
					 (format nil ") goto ~A;"
						 (cdr (assq (cadr (caddr x))
							    c-label-alist)))))
		(go
		 (format stream "   goto ~A;~%" (cdr (assq (cadr x) c-label-alist))))
		(setq
		 (emit-c-function-call-t (caddr x)
					 combined-vars
					 combined-c-vars
					 stream
					 (format nil "   ~A = " (get-c-value (cadr x)
									  combined-vars
									  combined-c-vars))))
		(t
		 (emit-c-function-call-t x combined-vars combined-c-vars stream)))))
	  (format stream "}~%"))
    nil))))



(defun progify-function-body (l)
  (check-progified-form (progify-expression (if (null (cdr l)) (car l) (cons 'progn l)))))

(defun check-progified-form (x)
  "make sure we didn't loose in translation"
  (or (and (not (atom x)) (eq (car x) 'prog))
      (flossage "not a prog: ~S" x))
  (mapc #'(lambda (statement)
	    (cond ((atom statement)
		   (or (symbolp statement)
		       (flossage "non symbolic prog tag: ~S" statement)))
		  ((eq (car statement) 'return)
		   (check-args-c-arithmetic-p (the-args (cadr statement))))
		  ((eq (car statement) 'go))
		  ((eq (car statement) 'if)
		   (check-args-c-arithmetic-p (the-args (cadr statement)))
		   (or (and (Not (atom (caddr statement)))
			    (eq (car (caddr statement)) 'go))
		       (flossage "consequent of IF not a go: ~S" (caddr statement)))
		   (or (= (length statement) 3)
		       (flossage "IF only allowed with 2 args: ~S" statement)))
		  ((eq (car statement) 'setq)
		   (check-c-arithmetic-p (cadr statement))
		   (or (= (length statement) 3)
		       (flossage "SETQ only allowed with one var: ~S" statement))
		   (check-args-c-arithmetic-p (the-args (caddr statement))))
		  ((check-args-c-arithmetic-p (the-args statement)))))
	(cddr x))
  x)


(defun the-args (x)
  (if (or (atom x) (not (symbolp (car x))) (not (null (cdr (list x)))))
      (flossage "Not a legal lisp form with arguments: ~S" x)
    (cdr x)))

(defun check-c-arithmetic-p (x)
  (or (atom x)
      (do ((l '(sdu-unary-operator sdu-binary-operator sdu-nary-operator sdu-c-value-ok)
	      (cdr l)))
	  ((null l)
	   (flossage "not known as C arithmetic operator: ~S" (car x)))
	(and (get (car x) (car l))
	     (return (check-args-c-arithmetic-p (cdr x)))))))

(defun check-args-c-arithmetic-p (l)
  (mapc #'check-c-arithmetic-p l))

(defun emit-c-function-call-t (expression vars c-vars stream &rest l)
  (lexpr-funcall #'emit-c-function-call
		 (translate-c-function-call expression vars c-vars)
		 stream
		 l))

(defun translate-c-function-call (x l-vars c-vars)
  (cons (car x) (mapcar #'(lambda (exp) (get-c-value-t exp l-vars c-vars)) (cdr x))))  

(defun get-c-value-t (exp l-vars c-vars)
  (if (stringp exp) exp (get-c-value exp l-vars c-vars)))
  
(defun (eval-for-translation lisp-to-c-toplevel) (form stream)
  (mapc #'eval (cdr form))
  stream
  nil)

(defun eval-for-translation (&rest l)
  (car (last l)))


;;; The real compiler: PROGIFY-EXPRESSION.

;;; Progification is a call convention where the caller
;;; takes responsibility for creating temporaries for intermediate results and
;;; nested function calls, and might as well pass arguments to functions in registers.
;;; At this point, (7/14/84 10:37:52) no attempt will be made to do even the simplest
;;; kind of packing of generated temporaries other than that which falls naturally out
;;; of result-value targetting. This is because we have noticed that the code we want
;;; to translate is not at all deep in nested function calls, and in most cases will
;;; pass the progified-form-check conditions with little modification.
;;; (7/15/84 09:38:16 -gjc) easy enough to make a temporary available when we
;;; obviously know it isn't used any more, which we do in the compilation of
;;; function calls, LET, PROG, and a case of IF requiring a temporary. In this way
;;; we do as well as stack discipline.

(defvar needed-prog-vars nil)
(defvar available-prog-vars nil)
(defvar free-prog-var t "If true, make free'd ones available, if not, ignore them")
(defun free-prog-var (x)
  (if free-prog-var
      (push x available-prog-vars)))
(defun free-prog-vars (l)
  "called on a list of names or pairs of (<user-name> . <temp-name>)"
  (dolist (x l)
    (if (listp x) (free-prog-var (cdr x)) (free-prog-var x))))
  
(defvar prog-var-count 0)
(defun gen-prog-var ()
  (if available-prog-vars
      (pop available-prog-vars)
    (car (push (intern (format nil "p_~D" (setq prog-var-count (1+ prog-var-count))))
	       needed-prog-vars))))

(defvar prog-tag-count 0)
(defun gen-prog-tag ()
  (setq prog-tag-count (1+ prog-tag-count))
  (intern (format nil "tag_~D" prog-tag-count)))

(defvar name-environment-alist ())

(defvar emited-code ())

(defvar emit-breaks nil)

(defun emit-breaks (&optional (val (not emit-breaks)))
  (setq emit-breaks val))

(defun emit (&rest l)
  (dolist (x l)
    (if (and emit-breaks (progn (print x) (y-or-n-p "break?")))
	(cerror t nil nil "Break on emiting instruction: ~S" x))
    (push x emited-code)))
  

(defun l2p (name)
  (let ((x (get-defun-form name)))
    (if x (let ((throw-lossage nil))
	    (let ((e (progify-expression (cons 'progn (cdddr x)))))
	      (grind-top-level `(defun ,(cadr x) ,(caddr x) ,e))
	      (terpri)
	      (check-progified-form e)))
      "can't find named lambda")))

(defun progify-expression (exp)
  (let ((needed-prog-vars nil)
	(available-prog-vars nil)
	(prog-var-count 0)
	(prog-tag-count 0)
	(name-environment-alist nil)
	(emited-code nil))
    (let ((val (gen-prog-var)))
      (progen exp val)
      `(prog ,needed-prog-vars
	     ,.(nreverse emited-code)
	     (return (identity ,val))))))

(defun progen (expression target &aux temp)
  ;; this must generate legal prog statements which result in the value being
  ;; calculated and placed in the target.
  ;; TARGET is either a symbol, meaning a place to store the value.
  ;; or NIL meaning no value.
  ;; or a pair (<tag> . <tag>) meaning where to goto if return value would be TRUE
  ;; or FALSE.
  ;; Modification needed: a TARGET of T means we want a value but in an unspecified
  ;; place. return value is place actually put. and/or other things about the value.
  ;; Or. try putting the target onto available prog vars.
  ;; and then taking it off.
  (if (and free-prog-var target (symbolp target) (not (memq target available-prog-vars)))
      (push target available-prog-vars))
  (cond ((progen-primitive-p expression)
	 (let ((name (name-subst-primitive expression)))
	   (cond ((null target))
		 ((symbolp target)
		  (or (eq target name) 
		      ;; started to get asked for when availability optimizations
		      ;; got put in this function.
		      (emit `(setq ,target (identity ,name)))))
		 ('else
		  (emit `(if (identity ,name) (go ,(car target)))
			`(go ,(cdr target)))))))
	((and (listp (car expression)) (eq (caar expression) 'lambda))
	 (progen `(let ,(mapcar #'list (cadr (car expression)) (cdr expression))
		    ,@(cddr (car expression)))
		 target))
	((not (symbolp (car expression)))
	 (flossage "car of expression must be a symbol: ~S" expression))
	((setq temp (get (car expression) 'progen))
	 (funcall temp expression target))
	((get (car expression) 'sdu-c-function)
	 ;; since it is an sdu c function don't bother with macro expansion or anything else.
	 (progen-f expression target))
	((fboundp (car expression))
	 (let ((val (fsymeval (car expression))))
	   (cond ((atom val)
		  (cond ((memq '&quote (arglist val))
			 (flossage "un-handled special form: ~S" expression))
			('else
			 (progen-f expression target))))
		 ((eq (car val) 'macro)
		  (progen (funcall (cdr val) expression) target))
		 ('else
		  (progen-f expression target)))))
	('else
	 (progen-f expression target)))
  (setq available-prog-vars (delq target available-prog-vars)))

;; translation of vanilla function call.

(defun progen-operator-primitive-p (op)
  (do ((l '(sdu-unary-operator sdu-binary-operator sdu-nary-operator sdu-c-value-ok)
	  (cdr l)))
      ((null l) nil)
    (and (get op (car l)) (return t))))

(defun progen-primitive-p (x)
  (or (atom x)
      (and (progen-operator-primitive-p (car x))
	   (progen-args-primitive-p (cdr x)))))


(defun progen-args-primitive-p (l)
  (do ((l l (cdr l)))
      ((null l) t)
    (or (progen-primitive-p (car l)) (return nil))))

(defun name-subst-primitive (expression)
  (sublis name-environment-alist expression))

(defun progen-f (expression target)
  (cond ((progen-args-primitive-p (cdr expression))
	 (progen-f-primitive expression target))
	('else
	 (do ((temps)
	      (args)
	      (arg)
	      (temp)
	      (l (cdr expression) (cdr l)))
	     ((null l)
	      (progen (cons (car expression) args) target)
	      (free-prog-vars temps))
	   (setq arg (car l))
	   (cond ((compiler:constantp arg)
		  (setq args (nconc args (list arg))))
		 ('else
		  (setq temp (gen-prog-var))
		  (setq args (nconc args (list temp)))
		  (setq temps (nconc temps (list temp)))
		  (progen arg temp)))))))

(defun progen-f-primitive (expression target)
  (let ((new-expression (name-subst-primitive expression)))
    (cond ((null target)
	   (emit new-expression))
	  ((symbolp target)
	   (emit `(setq ,target ,new-expression)))
	  ('else
	   (emit `(if ,new-expression (go ,(car target)))
		 `(go ,(cdr target)))))))


;;; special forms.

(defun (block progen) (expression target)
  ;; for now, ignore
  (progen (cons 'progn (cddr expression)) target))

(defun (progn progen) (expression target)
  (do ((l (cdr expression) (cdr l)))		
      ((null (cdr l))
       (progen (car l) target))
    (progen (car l) nil)))

(defvar go-tag-renamings nil "an alist")
(defvar return-target nil "(<regular-target> <prog-end-tag>)")

(defun (go progen) (expression target)
  target
  (emit `(go ,(cdr (assq (cadr expression) go-tag-renamings)))))

(defun (return progen) (expression target)
  target
  (progen (cadr expression) (car return-target))
  (emit `(go ,(cadr return-target))))

(defun (prog progen) (expression target)
  (let ((new-name-env (mapcar #'(lambda (var) (cons var (gen-prog-var))) (cadr expression))))
    (let ((name-environment-alist (append new-name-env
					  name-environment-alist))
	  (return-target (list target (gen-prog-tag)))
	  (go-tag-renamings (mapcar #'(lambda (tag) (cons tag (gen-prog-tag)))
				    (mapcan #'(lambda (x)
						(if (symbolp x) (list x)))
					    (cddr expression)))))
      (do ((l (cddr expression) (cdr l)))
	  ((null l)
	   (progen '(return 0) nil) ; just in case no return, fall off end.
	   (emit (cadr return-target))
	   (free-prog-vars new-name-env))
	(if (symbolp (car l))
	    (emit (cdr (assq (car l) go-tag-renamings)))
	  (progen (car l) nil))))))

(defun (let progen) (expression target)
  (do ((l (cadr expression) (cdr l))
       (v-form)(temp)(var)(val)
       (new-homes))
      ((null l)
       (let ((name-environment-alist (append new-homes name-environment-alist)))
	 (progen `(progn ,@(cddr expression)) target)
	 (free-prog-vars new-homes)))
    (setq temp (gen-prog-var))
    (setq v-form (car l))
    (cond ((atom v-form)
	   (setq var v-form val 0))
	  ((null (cdr v-form))
	   (setq var (car v-form) val 0))
	  ('else
	   (setq var (car v-form) val (cadr v-form))))
    (push (cons var temp) new-homes)
    (progen val temp)))


(defun progen-primitive-normalize (expression)
  ;; should also be macro-expanding.
  (cond ((progen-primitive-p expression)
	 `(identity ,expression))
	((progen-args-primitive-p expression)
	 expression)))
	
(defun (if progen) (expression target &aux temp)
  (let ((pred (cadr expression))
	(if-true (caddr expression))
	(if-false (selectq (length expression)
		    (3 0)
		    (4 (cadddr expression))
		    (t `(progn ,(cdddr expression))))))
    (cond ((setq temp (progen-primitive-normalize pred))
	   (cond ((or (null target) (symbolp target))
		  (progen-primitive-if temp if-true if-false target))
		 ('else
		  (let ((v (gen-prog-var)))
		    (progen-primitive-if temp if-true if-false v)
		    (emit `(if (identity ,v) (go ,(car target)))
			  `(go ,(cdr target)))
		    (free-prog-var v)))))
	  ('else
	   (let ((t1 (gen-prog-tag))
		 (t2 (gen-prog-tag))
		 (t3 (gen-prog-tag)))
	     (progen pred (cons t1 t2))
	     (emit t1)
	     (progen if-true target)
	     (emit `(go ,t3)
		   t2)
	     (progen if-false target)
	     (emit t3))))))

(defun progen-primitive-if (pred if-true if-false target)
  (let ((t1 (gen-prog-tag))
	(t3 (gen-prog-tag)))
    (emit `(if ,(name-subst-primitive pred) (go ,t1)))
    (progen if-false target)
    (emit `(go ,t3)
	  t1)
    (progen if-true target)
    (emit t3)))


(defun (setq progen) (expression target)
  (do ((l (cdr expression) (cddr l)))
      ((null (cddr l))
       (setq-progen-1 (car l) (cadr l) target))
    (setq-progen-1 (car l) (cadr l) nil)))


(defun setq-progen-1 (var val target)
  ;; it seems that setq is rather built into the compilation scheme.
  (let ((real-var (name-subst-primitive var)))
    (progen val real-var)
    (progen real-var target)))


;;; transformational things.

(defmacro defprogen-scrw (name argl &body body)
  `(progn 'compile
	  (record-source-file-name ',name 'progen-scrw)
	  (defun (,name progen-scrw) ,argl ,@body)
	  (defprop ,name progen-scrw-driver progen)))

(defun progen-scrw-driver (expression target)
  (progen (apply (get (car expression) 'progen-scrw) (cdr expression))
	  target))

(defprogen-scrw cond (&rest clauses)
  (cond-clauses-to-ifs clauses))


(defun cond-clauses-to-ifs (clauses)
  ;; I'll only translate the regular cond with clauses of the form
  ;; (<predicate> ...). Otherwise you have to introduce icky temporaries
  ;; and transform (<predicate>) => ((setq temp predicate) temp)
  ;;(cond (a b)) => (if a b)
  ;;(cond (a b) (c d)) => (if a b (if c d))
  ;;(cond (a b) ...) => (if a b (translate ...))
  (if (null clauses)
        0
    (let ((clause (car clauses)))
      (if (or (eq (car clause) t)
	      (and (not (atom (car clause))) ;; catch 'else a GJC'ism
		   (eq (caar clause) 'quote)))
	  `(progn ,@(cdr clause))
	`(if ,(car clause)
	     (progn ,@(cdr clause))
	   ,(cond-clauses-to-ifs (cdr clauses)))))))


(defun (ferror progen) (expression target)
  target
  ;; this could be a scrw, but since we know about the exit, the target doesn't matter
  (progen `(progn (printf ,(translate-format-arg-to-printf (caddr expression))
			  ,@(cdddr expression))
		  (exit 0))
	  nil))

(defprogen-scrw format (ignore string &rest args)
  `(printf ,(translate-format-arg-to-printf string) ,@args))

(defun translate-format-arg-to-printf (string)
  (with-input-from-string (s-in string)
    (with-output-to-string (s-out)
      (do ((c))
	  ((null (setq c (send s-in ':tyi))))
	(cond ((= c #/~)
	       (selectq (setq c (send s-in ':tyi))
		 (#/~
		  (send s-out ':tyo c))
		 ((#/s #/S #/A #/a)
		  (send s-out ':tyo #/%)
		  (send s-out ':tyo #/O))
		 ((#/o #/O #/d #/D)
		  (send s-out ':tyo #/%)
		  (Send s-out ':tyo (char-upcase c)))
		 (#/%
		  (send s-out ':string-out "\n"))
		 (t
		  (flossage "unhandled format directive: ~~~C" c))))
	      ((= c #\return)
	       (send s-out ':string-out "\n"))
	      ('else
	       (Send s-out ':tyo c)))))))


;(defun expand-64-arguments (l)
  ;; some functions such as LAM-EXECUTE-R take a 64 bit bignum as argument
  ;; because control memory is 64 bits. the C long is 32 bits and won't
  ;; handle this of course. So, we could/should TARGET the arguments
  ;; to those functions to 64 bit quantities, e.g.
  ;; {char B_1[8];
  ;;  foo(B_1);
  ;;  bar(B_1);}
  ;; instead of (foo (bar)).
  ;; or perhaps keep two 32 bit quantities in longs around for this.
  ;; But of course this would be getting into some real hair that our little
  ;; compiler doesn't want to hack. Might as well implement lisp.
;; decided to hack this into emit-c-function-call.

(defprogen-scrw do (steppers end-clause &rest body)
  (if (atom steppers)
      ;; Old-style: (do x 1 (1+ x) (= x 9) ...)
      `(do ((,steppers ,end-clause ,(car body)))
	   (,(cadr body))
	 ,@(cddr body))
    `(let ,(mapcar #'(lambda (x)
		       (if (or (atom x) (null (cdr x)))
			   x
			 `(,(car x) ,(cadr x))))
		   steppers)
       (prog ()
	     do_loop
		(if ,(or (car end-clause) 1) (return ,(or (cadr end-clause) 0)))
		,@body
		(psetq ,@(mapcan #'(lambda (x)
				     (if (or (atom x) (null (cddr x)))
					 ()
				       `(,(car x) ,(caddr x))))
				 steppers))
		(go do_loop)))))

(defprogen-scrw psetq (&rest l)
  ;; in a good compiler this is amoung the hairier things to look at.
  ;; Should check for dependencies and reorderings, and transform
  ;; (psetq j (1+ j) n (* j n)) =>
  ;; (setq n (* j n) j (1+ j))
  ;; and probably done as a special form, not as a source-code-rewrite.
  (let ((gl (do ((l l (cddr l))
		 (j 0 (1+ j))
		 (v nil (cons `(,(car l) ,(intern (format nil "psetq!~D" j)) ,(cadr l)) v)))
		((null l)
		 (nreverse v)))))
    `(let ,(mapcar #'(lambda (x) `(,(cadr x) ,(caddr x))) gl)
       ,@(mapcar #'(lambda (x) `(setq ,(car x) ,(cadr x))) gl))))


(defprogen-scrw 1+ (x)
  `(+ 1 ,x))