[unix-history] / usr / src / usr.bin / lisp / liszt / io.l

(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file io
   "$Header: io.l,v 1.17 87/12/15 17:03:20 sklower Exp $")

;;; ---- 	i o				input output
;;;
;;;				-[Fri Sep  2 21:37:05 1983 by layer]-


;--- d-prelude :: emit code common to beginning of all functions
;
(defun d-prelude nil
   (let ((loada-op #+(or for-vax for-tahoe) 'movab #+for-68k 'lea)
	 (sub2-op  #+(or for-vax for-tahoe) 'subl2 #+for-68k 'subl)
	 (add2-op  #+(or for-vax for-tahoe) 'addl2 #+for-68k 'addl)
	 (temp-reg #+(or for-vax for-tahoe) '#.fixnum-reg #+for-68k 'a5))
       #+for-68k (setq g-stackspace (d-genlab) g-masklab (d-genlab))
       (if g-flocal
	   then #+for-tahoe (e-write2 '".word" '0x0)
		(C-push '#.olbot-reg)
		(e-write3 loada-op
			  `(,(* -4 g-currentargs) #.np-reg) '#.olbot-reg)
		(e-writel g-topsym)
	   else #+(or for-vax for-tahoe) (e-write2 '".word" '0x5c0)
		#+for-68k
		(progn
		    (e-write3 'link 'a6 (concat "#-" g-stackspace))
		    (e-write2 'tstb '(-132 sp))
		    (e-write3 'moveml `($ ,g-masklab)
			      (concat "a6@(-" g-stackspace ")"))
		    (e-move '#.Nilatom '#.nil-reg))
		(if fl-profile
		    then (e-write3 loada-op 'mcnts
				   #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
			 (e-quick-call 'mcount))
		(e-write3 loada-op 'linker '#.bind-reg)
		(if (eq g-ftype 'lexpr)
		    then ; Here is the method:
			 ;  We push the number of arguments, nargs,
			 ; on the name stack twice, setting olbot-reg
			 ; to point to the second one, so that the user
			 ; has a copy that he can set, and we have
			 ; one that we can use for address calcs.
			 ;  So, the stack will look like this, after
			 ; the setup:
			 ;np    ->
			 ;olbot -> nargs (II)
			 ;      -> nargs (I)
			 ;      -> (arg nargs)
			 ;      -> (arg nargs-1)
			 ;...
			 ;      -> (arg 1)
			 ;
			 (if (null $global-reg$)
			     then (e-move '#.np-sym '#.np-reg))
			 (e-writel g-topsym)
			 (e-move '#.np-reg temp-reg)
			 (e-write3 sub2-op
				   (if $global-reg$
				       then '#.lbot-reg
				       else '#.lbot-sym) temp-reg)
			 (e-write3 add2-op (e-cvt '(fixnum 0)) temp-reg)
			 (L-push temp-reg)
			 (e-move '#.np-reg '#.olbot-reg)
			 (L-push temp-reg)
		    else ;   Set up old lbot register, base reg for variable
			 ; references, and make sure the np points where
			 ; it should since the caller might
			 ; have given too few or too many args.
			 (e-move
				   (if $global-reg$
				       then '#.lbot-reg
				       else '#.lbot-sym)
				   '#.olbot-reg)
			 #+for-68k
			 (e-write3 loada-op
				   `(,(* 4 g-currentargs) #.olbot-reg)
				   '#.np-reg)
			 (e-writel g-topsym)))))

;--- d-fini :: emit code  at end of function
;
(defun d-fini nil
   (if g-flocal
       then (C-pop '#.olbot-reg)
	    (e-write1 #+for-vax 'rsb #+for-tahoe 'ret #+for-68k 'rts)
       else #+for-68k
	    (progn
		(e-write3 'moveml (concat "a6@(-" g-stackspace ")")
			  `($ ,g-masklab))
		(e-write2 'unlk 'a6))
	    (e-return)))

;--- d-bindtab :: emit binder table when all functions compiled
;
(defun d-bindtab nil
  (setq g-skipcode nil)	  ; make sure this isnt ignored	
  (e-writel "bind_org")
  #+(or for-vax for-tahoe)
  (progn
      (e-write2 ".set linker_size," (length g-lits))
      (e-write2 ".set trans_size," (length g-tran)))
  #+for-68k
  (progn
      (e-write2 "linker_size = " (length g-lits))
      (e-write2 "trans_size = " (length g-tran)))
  (do ((ll (setq g-funcs (nreverse g-funcs)) (cdr ll)))
      ((null ll))
      (if (memq (caar ll) '(lambda nlambda macro eval))
	  then (e-write2 '".long"
			 (cdr (assoc (caar ll)
				     '((lambda . 0) (nlambda . 1)
				       (macro . 2) (eval . 99)))))
	  else (comp-err " bad type in lit list " (car ll))))
  
  (e-write1 ".long -1")
  (e-writel "lit_org")
  (d-asciiout (nreverse g-lits))
  (if g-tran then (d-asciiout (nreverse g-tran)))
  (d-asciiout (mapcar '(lambda (x) (if (eq (car x) 'eval)
				       then (cadr x)
				       else (caddr x)))
		      g-funcs))
  (e-writel "lit_end"))

;--- d-asciiout :: print a list of asciz strings
;
(defun d-asciiout (args)
       (do ((lits args (cdr lits))
	    (form))
	   ((null lits))
	   (setq form (explode (car lits))
		 formsiz (length form))
	   (do ((remsiz formsiz)
		(curform form)
		(thissiz))
	       ((zerop remsiz))
	       (if (greaterp remsiz 60) then (sfilewrite '".ascii \"")
		   else (sfilewrite '".asciz \""))
	       (setq thissiz (min 60 remsiz))
	       (do ((count thissiz (1- count)))
		   ((zerop count)
		    (sfilewrite (concat '\" (ascii 10)))
		    (setq remsiz (difference remsiz thissiz)))
		   (if (eq '#.ch-newline (car curform))
		       then (sfilewrite '\\012)
		    else (if (or (eq '\\ (car curform))
				 (eq '\" (car curform)))
			     then (sfilewrite '\\))
			 (sfilewrite (car curform)))
		   (setq curform (cdr curform))))))

;--- d-autorunhead
;
; Here is the C program to generate the assembly language:
;	(after some cleaning up)
;
;main(argc,argv,arge)
;register char *argv[];
;register char **arge;
;{
;	*--argv = "-f";
;	*--argv = "/usr/ucb/lisp";
;	execve("/usr/ucb/lisp",argv,arge);
;	exit(0);
;}
;
(defun d-printautorun nil
   (let ((readtable (makereadtable t))	; in raw readtable
	 tport ar-file)
      (setsyntax #/; 'vsplicing-macro 'zapline)
      (setq ar-file (concat lisp-library-directory
			    #+for-vax "/autorun/vax"
			    #+for-tahoe "/autorun/tahoe"
			    #+for-68k "/autorun/68k"))
      (if (null (errset (setq tport (infile ar-file))))
	 then (comp-err "Can't open autorun header file " ar-file))
      (do ((x (read tport '<eof>) (read tport '<eof>)))
	  ((eq '<eof> x) (close tport))
	  (sfilewrite x))))

(defun e-cvt (arg)
   (if     (eq 'reg arg) then #+(or for-vax for-tahoe) 'r0 #+for-68k 'd0
    elseif (eq 'areg arg) then #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0
    elseif (eq 'Nil arg) then #+(or for-vax for-tahoe) '($ 0)
    			      #+for-68k '#.nil-reg
    elseif (eq 'T arg)
       then (if g-trueloc
		thenret
		else (setq g-trueloc (e-cvt (d-loclit t nil))))
    elseif (eq 'stack arg) then '(+ #.np-reg)
    elseif (eq 'unstack arg) then (progn #+for-tahoe (e-sub '($ 4) '#.np-reg)
					 '(- #.np-reg))
    elseif (or (atom arg) (symbolp arg)) then arg
    elseif (dtpr arg)
       then (caseq (car arg)
		   (stack	`(,(* 4 (1- (cadr arg))) #.olbot-reg))
		   (vstack	`(* ,(* 4 (1- (cadr arg))) #.olbot-reg))
		   (bind	`(* ,(* 4 (1- (cadr arg))) #.bind-reg))
		   (lbind	`(,(* 4 (1- (cadr arg))) #.bind-reg))
		   (fixnum	`(\# ,(cadr arg)))
		   (immed	`($ ,(cadr arg)))
		   (racc	(cdr arg))
		   (t		(comp-err " bad arg to e-cvt : "
					  (or arg))))
       else  (comp-warn "bad arg to e-cvt : " (or arg))))

;--- e-uncvt :: inverse of e-cvt, used for making comments pretty
;
(defun e-uncvt (arg)
   (if (atom arg)
       then (if (eq 'Nil arg)
		then nil
		else arg)
    elseif (eq 'stack (car arg))
       then (do ((i g-loccnt)
		 (ll g-locs))
		((and (equal i (cadr arg)) (atom (car ll))) (car ll))
		(if (atom (car ll))
		    then (setq ll (cdr ll)
			       i (1- i))
		    else (setq ll (cdr ll))))
    elseif (or (eq 'bind (car arg)) (eq 'lbind (car arg)))
       then (do ((i g-litcnt (1- i))
		 (ll g-lits (cdr ll)))
		((equal i (cadr arg))
		 (cond ((eq 'lbind (car arg))
			(list 'quote (car ll)))
		       (t (car ll)))))
       else arg))

;--- e-cvtas :: convert an EIADR to vax unix assembler fmt and print it
;	- form : an EIADR form
;
#+(or for-vax for-tahoe)
(defun e-cvtas (form)
  (if (atom form)
      then (sfilewrite form)
      else (if (eq '* (car form))
	       then (if (eq '\# (cadr form))
			then (setq form `($ ,(caddr form)))
			else (sfilewrite "*")
			     (setq form (cdr form))))
	   (if (numberp (car form))
	       then (sfilewrite (car form))
		    (sfilewrite "(")
		    (sfilewrite (cadr form))
		    (sfilewrite ")")
		    (if (caddr form)
			then (sfilewrite "[")
			     (sfilewrite (caddr form))
			     (sfilewrite "]"))
	    elseif (eq '+ (car form))
	       then (sfilewrite '"(")
		    (sfilewrite (cadr form))
		    (sfilewrite '")")
		    #-for-tahoe (sfilewrite '"+")
	    elseif (eq '- (car form))
	       then #-for-tahoe (sfilewrite '"-")
		    (sfilewrite '"(")
		    (sfilewrite (cadr form))
		    (sfilewrite '")")
	    elseif (eq '\# (car form))	; 5120 is base of small fixnums
	       then (sfilewrite (concat "$" (+ (* (cadr form) 4) 5120)))
	    elseif (eq '$ (car form))
	       then (sfilewrite '"$")
		    (sfilewrite (cadr form)))))

#+for-68k
(defun e-cvtas (form)
   (if (atom form)
       then (sfilewrite form)
       else (if (eq '* (car form))
		then (if (eq '\# (cadr form))
			 then (setq form `($ ,(caddr form)))))
	    (if (numberp (car form))
		then (sfilewrite (cadr form))
		     (sfilewrite "@")
		     (if (not (zerop (car form)))
			 then (sfilewrite "(")
			      (sfilewrite (car form))
			      (sfilewrite ")"))
	    elseif (eq '% (car form))
	       then (setq form (cdr form))
		    (sfilewrite (cadr form))
		    (sfilewrite "@(")
		    (sfilewrite (car form))
		    (sfilewrite ",")
		    (sfilewrite (caddr form))
		    (sfilewrite ":L)")
	     elseif (eq '+ (car form))
		then (sfilewrite (cadr form))
		     (sfilewrite '"@+")
	     elseif (eq '- (car form))
		then (sfilewrite (cadr form))
		     (sfilewrite '"@-")
	     elseif (eq '\# (car form))
		then (sfilewrite (concat '#.Nilatom "+0x1400"
					 (if (null (signp l (cadr form)))
					     then "+" else "")
					 (* (cadr form) 4)))
	     elseif (eq '$ (car form))
		then (sfilewrite '"#")
		     (sfilewrite (cadr form))
	       else (comp-err " bad arg to e-cvtas : " (or form)))))

;--- e-postinc :: handle postincrement for the tahoe machine
;

#+for-tahoe
(defun e-postinc (addr)
   (if (and (dtpr addr) (eq (car addr) '+))
       (e-add '($ 4) (cadr addr))))


;--- e-docomment :: print any comment lines
;
(defun e-docomment nil
  (if g-comments
      then (do ((ll (nreverse g-comments) (cdr ll)))
	       ((null ll))
	       (sfilewrite "	")
	       (sfilewrite #.comment-char)
	       (do ((ll (exploden (car ll)) (cdr ll)))
		   ((null ll))
		   (tyo (car ll) vp-sfile)
		   (cond ((eq #\newline (car ll))
			  (sfilewrite #.comment-char))))
	       (terpr vp-sfile))
	   (setq g-comments nil)
     else (terpr vp-sfile)))

;--- e-goto :: emit code to jump to the location given
;
(defun e-goto (lbl)
  (e-jump lbl))

;--- e-gotonil :: emit code to jump if nil was last computed
;
(defun e-gotonil (lbl)
  (e-write2 g-falseop lbl))

;--- e-gotot :: emit code to jump if t was last computed
(defun e-gotot (lbl)
  (e-write2  g-trueop lbl))

;--- e-label :: emit a label
(defun e-label (lbl)
  (setq g-skipcode nil)
  (e-writel lbl))

;--- e-pop :: pop the given number of args from the stack
; g-locs is not! fixed
;
(defun e-pop (nargs)
  (if (greaterp nargs 0)
      then (e-dropnp nargs)))

;--- e-pushnil :: push a given number of nils on the stack
;
#+for-vax
(defun e-pushnil (nargs)
   (do ((i nargs))
       ((zerop i))
       (if (>& i 1)
	   then (e-write2 'clrq '#.np-plus)
		(setq i (- i 2))
	elseif (equal i 1)
	   then (e-write2 'clrl '#.np-plus)
		(setq i (1- i)))))

#+for-tahoe
(defun e-pushnil (nargs)
  (do ((i nargs))
      ((zerop i))
      (e-write2 'clrl '#.np-plus)
      (setq i (1- i))))

#+for-68k
(defun e-pushnil (nargs)
  (do ((i nargs))
      ((zerop i))
      (L-push '#.nil-reg)
      (setq i (1- i))))

;--- e-setupbind :: setup for shallow binding
;
(defun e-setupbind nil
  (e-move '#.bnp-sym '#.bnp-reg))

;--- e-unsetupbind :: restore temp value of bnp to real loc
;
(defun e-unsetupbind nil
  (e-move '#.bnp-reg '#.bnp-sym))

;--- e-shallowbind :: shallow bind value of variable and initialize it
;	- name : variable name
;	- val : IADR value for variable
;
#+(or for-vax for-68k)
(defun e-shallowbind (name val)
  (let ((vloc (d-loclit name t)))
       (e-move (e-cvt vloc) '(+ #.bnp-reg))	; store old val
       (e-move (e-cvt `(lbind ,@(cdr vloc)))
		       '(+ #.bnp-reg))		; now name
       (d-move val vloc)))		

#+for-tahoe
(defun e-shallowbind (name val)
  (let ((vloc (d-loclit name t)))
       (e-move (e-cvt vloc) '(0 #.bnp-reg))	; store old val
       (e-add '($ 4) '#.bnp-reg)
       (e-move (e-cvt `(lbind ,@(cdr vloc)))
		       '(0 #.bnp-reg))		; now name
       (e-add '($ 4) '#.bnp-reg)
       (d-move val vloc)))		

;--- e-unshallowbind :: un shallow bind n variable from top of stack
;
#+(or for-vax for-tahoe)
(defun e-unshallowbind (n)
  (e-setupbind)		; set up binding register
  (do ((i 1 (1+ i)))
      ((greaterp i n))
      (e-move `(,(* -8 i) #.bnp-reg) `(* ,(+ 4 (* -8 i)) #.bnp-reg)))
  (e-sub3 `($ ,(* 8 n)) '#.bnp-reg '#.bnp-sym))

#+for-68k
(defun e-unshallowbind (n)
  (makecomment "e-unshallowbind begin...")
  (e-setupbind)		; set up binding register
  (do ((i 1 (1+ i)))
      ((greaterp i n))
      (e-move `(,(* -8 i) #.bnp-reg) `(* ,(+ 4 (* -8 i)) #.bnp-reg)))
  (e-move '#.bnp-reg '#.bnp-sym)
  (e-sub `($ ,(* 8 n)) '#.bnp-sym)
  (makecomment "...end e-unshallowbind"))

;----------- very low level routines
; all output to the assembler file goes through these routines.
; They filter out obviously extraneous instructions as well as 
; combine sequential drops of np.

;--- e-dropnp :: unstack n values from np.
; rather than output the instruction now, we just remember that it
; must be done before any other instructions are done.  This will
; enable us to catch sequential e-dropnp's
;
(defun e-dropnp (n)
  (if (not g-skipcode)
      then (setq g-dropnpcnt (+ n (if g-dropnpcnt thenret else 0)))))

;--- em-checknpdrop :: check if we have a pending npdrop
; and do it if so.
;
(defmacro em-checknpdrop nil
   `(if g-dropnpcnt
	then (let ((dr g-dropnpcnt))
		 (setq g-dropnpcnt nil)
		 (e-sub `($ ,(* dr 4)) '#.np-reg))))

;--- em-checkskip :: check if we are skipping this code due to jump
;
(defmacro em-checkskip nil
  '(if g-skipcode then (sfilewrite #.comment-char)))


;--- e-jump :: jump to given label
; and set g-skipcode so that all code following until the next label
; will be skipped.
;
(defun e-jump (l)
  (em-checknpdrop)
  (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra l)
  (setq g-skipcode t))

;--- e-return :: do return, and dont check for np drop
;
(defun e-return nil
  (setq g-dropnpcnt nil)  ; we dont need to worry about nps
  #+(or for-vax for-tahoe) (e-write1 'ret)
  #+for-68k (progn  (e-write1 'rts)
		    (sfilewrite
		       (concat g-masklab " = " (d-makemask) '#.ch-newline))
		    (sfilewrite
		       (concat g-stackspace " = "
			       (Cstackspace) '#.ch-newline))))

;--- e-writel :: write out a label
;
(defun e-writel (label)
  (setq g-skipcode nil)
  (em-checknpdrop)
  (sfilewrite label)
  (sfilewrite ":")
  (e-docomment))

;--- e-write1 :: write out one litteral
;
(defun e-write1 (lit)
  (em-checkskip)
  (em-checknpdrop)
  (sfilewrite "	")
  (sfilewrite lit)
  (e-docomment))

;--- e-write2 :: write one one litteral, and one operand
;
#+(or for-vax for-tahoe)
(defun e-write2 (lit frm)
  (em-checkskip)
  (em-checknpdrop)
  (sfilewrite "	")
  (sfilewrite lit)
  (sfilewrite "	")
  (e-cvtas frm)
  (e-docomment)
  #+for-tahoe (e-postinc frm))

#+for-68k
(defun e-write2 (lit frm)
  (em-checkskip)
  (em-checknpdrop)
  (if (and (dtpr frm) (eq (car frm) '*))
      then (e-move (cdr frm) 'a5)
	   (sfilewrite "	")
	   (sfilewrite lit)
	   (sfilewrite '"	")
	   (e-cvtas '(0 a5))
      else (sfilewrite "	")
	   (sfilewrite lit)
	   (sfilewrite '"	")
	   (e-cvtas frm))
  (e-docomment))

;--- e-write3 :: write one one litteral, and two operands
;
#+(or for-vax for-tahoe)
(defun e-write3 (lit frm1 frm2)
  (em-checkskip)
  (em-checknpdrop)
  (sfilewrite "	")
  (sfilewrite lit)
  (sfilewrite "	")
  (e-cvtas frm1)
  (sfilewrite ",")
  (e-cvtas frm2)
  (e-docomment)
  #+for-tahoe (e-postinc frm1)
  #+for-tahoe (e-postinc frm2))

#+for-68k
(defun e-write3 (lit frm1 frm2)
   (em-checkskip)
   (em-checknpdrop)
   (if (and (dtpr frm1) (eq (car frm1) '*)
	    (not (and (dtpr frm2) (eq (car frm2) '*))))
       then (e-move (cdr frm1) 'a5)
	    (sfilewrite "	")
	    (sfilewrite lit)
	    (sfilewrite '"	")
	    (e-cvtas '(0 a5))
	    (sfilewrite '",")
	    (e-cvtas frm2)
	    (e-docomment)
    elseif (and (not (and (dtpr frm1) (eq (car frm1) '*)))
		(dtpr frm2) (eq (car frm2) '*))
       then (e-move (cdr frm2) 'a5)
	    (sfilewrite "	")
	    (sfilewrite lit)
	    (sfilewrite '"	")
	    (e-cvtas frm1)
	    (sfilewrite '",")
	    (e-cvtas '(0 a5))
	    (e-docomment)
    elseif (and (dtpr frm1) (eq (car frm1) '*)
		(dtpr frm2) (eq (car frm2) '*))
       then (d-regused 'd6)
	    (e-move (cdr frm1) 'a5)
	    (e-move '(0 a5) 'd6)
	    (e-move (cdr frm2) 'a5)
	    (sfilewrite "	")
	    (sfilewrite lit)
	    (sfilewrite '"	")
	    (e-cvtas 'd6)
	    (sfilewrite '",")
	    (e-cvtas '(0 a5))
	    (e-docomment)
       else (sfilewrite "	")
	    (sfilewrite lit)
	    (sfilewrite '"	")
	    (e-cvtas frm1)
	    (sfilewrite '",")
	    (e-cvtas frm2)
	    (e-docomment)))

;--- e-write4 :: write one one litteral, and three operands
;
#+(or for-vax for-tahoe)
(defun e-write4 (lit frm1 frm2 frm3)
  (em-checkskip)
  (em-checknpdrop)
  (sfilewrite "	")
  (sfilewrite lit)
  (sfilewrite "	")
  (e-cvtas frm1)
  (sfilewrite ",")
  (e-cvtas frm2)
  (sfilewrite ",")
  (e-cvtas frm3)
  (e-docomment)
  #+for-tahoe (e-postinc frm1)
  #+for-tahoe (e-postinc frm2)
  #+for-tahoe (e-postinc frm3))


;--- e-write5 :: write one one litteral, and four operands
;
#+(or for-vax for-tahoe)
(defun e-write5 (lit frm1 frm2 frm3 frm4)
  (em-checkskip)
  (em-checknpdrop)
  (sfilewrite "	")
  (sfilewrite lit)
  (sfilewrite "	")
  (e-cvtas frm1)
  (sfilewrite ",")
  (e-cvtas frm2)
  (sfilewrite ",")
  (e-cvtas frm3)
  (sfilewrite ",")
  (e-cvtas frm4)
  (e-docomment)
  #+for-tahoe (e-postinc frm1)
  #+for-tahoe (e-postinc frm2)
  #+for-tahoe (e-postinc frm3)
  #+for-tahoe (e-postinc frm4))

;--- d-printdocstuff
;
; describe this version
;
(defun d-printdocstuff nil
   (sfilewrite (concat ".data "
		       #.comment-char
		       " this is just for documentation "))
   (terpr vp-sfile)
   (sfilewrite (concat ".asciz \"@(#)Compiled by " compiler-name
                " on " (status ctime) '\"))
   (terpr vp-sfile)
   (do ((xx Liszt-file-names (cdr xx)))
       ((null xx))
       (sfilewrite (concat ".asciz \"" (car xx) '\"))
       (terpr vp-sfile)))
Commit	Line	Data
0f4556f1	1	(include-if (null (get 'chead 'version)) "../chead.l")
e804469b	2	(Liszt-file io
ca67e7b4	3	"$Header: io.l,v 1.17 87/12/15 17:03:20 sklower Exp $")
4b9ccde7 C	4
	5	;;; ---- i o input output
	6	;;;
0f4556f1	7	;;; -[Fri Sep 2 21:37:05 1983 by layer]-
4b9ccde7 C	8
	9
	10	;--- d-prelude :: emit code common to beginning of all functions
	11	;
	12	(defun d-prelude nil
ca67e7b4 C	13	(let ((loada-op #+(or for-vax for-tahoe) 'movab #+for-68k 'lea)
	14	(sub2-op #+(or for-vax for-tahoe) 'subl2 #+for-68k 'subl)
	15	(add2-op #+(or for-vax for-tahoe) 'addl2 #+for-68k 'addl)
	16	(temp-reg #+(or for-vax for-tahoe) '#.fixnum-reg #+for-68k 'a5))
0f4556f1 C	17	#+for-68k (setq g-stackspace (d-genlab) g-masklab (d-genlab))
0f4556f1 C	18	(if g-flocal
ca67e7b4 C	19	then #+for-tahoe (e-write2 '".word" '0x0)
ca67e7b4 C	20	(C-push '#.olbot-reg)
0f4556f1 C	21	(e-write3 loada-op
	22	`(,(* -4 g-currentargs) #.np-reg) '#.olbot-reg)
	23	(e-writel g-topsym)
ca67e7b4	24	else #+(or for-vax for-tahoe) (e-write2 '".word" '0x5c0)
0f4556f1 C	25	#+for-68k
	26	(progn
	27	(e-write3 'link 'a6 (concat "#-" g-stackspace))
	28	(e-write2 'tstb '(-132 sp))
	29	(e-write3 'moveml `($ ,g-masklab)
	30	(concat "a6@(-" g-stackspace ")"))
	31	(e-move '#.Nilatom '#.nil-reg))
	32	(if fl-profile
95f51977	33	then (e-write3 loada-op 'mcnts
ca67e7b4	34	#+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
0f4556f1 C	35	(e-quick-call 'mcount))
	36	(e-write3 loada-op 'linker '#.bind-reg)
	37	(if (eq g-ftype 'lexpr)
	38	then ; Here is the method:
	39	; We push the number of arguments, nargs,
	40	; on the name stack twice, setting olbot-reg
	41	; to point to the second one, so that the user
	42	; has a copy that he can set, and we have
	43	; one that we can use for address calcs.
	44	; So, the stack will look like this, after
	45	; the setup:
	46	;np ->
	47	;olbot -> nargs (II)
	48	; -> nargs (I)
	49	; -> (arg nargs)
	50	; -> (arg nargs-1)
	51	;...
	52	; -> (arg 1)
	53	;
	54	(if (null $global-reg$)
	55	then (e-move '#.np-sym '#.np-reg))
	56	(e-writel g-topsym)
	57	(e-move '#.np-reg temp-reg)
	58	(e-write3 sub2-op
	59	(if $global-reg$
	60	then '#.lbot-reg
	61	else '#.lbot-sym) temp-reg)
	62	(e-write3 add2-op (e-cvt '(fixnum 0)) temp-reg)
	63	(L-push temp-reg)
	64	(e-move '#.np-reg '#.olbot-reg)
	65	(L-push temp-reg)
	66	else ; Set up old lbot register, base reg for variable
	67	; references, and make sure the np points where
	68	; it should since the caller might
	69	; have given too few or too many args.
	70	(e-move
	71	(if $global-reg$
	72	then '#.lbot-reg
	73	else '#.lbot-sym)
	74	'#.olbot-reg)
	75	#+for-68k
	76	(e-write3 loada-op
	77	`(,(* 4 g-currentargs) #.olbot-reg)
	78	'#.np-reg)
	79	(e-writel g-topsym)))))
4b9ccde7 C	80
4b9ccde7 C	81	;--- d-fini :: emit code at end of function
0f4556f1	82	;
4b9ccde7	83	(defun d-fini nil
0f4556f1 C	84	(if g-flocal
0f4556f1 C	85	then (C-pop '#.olbot-reg)
ca67e7b4	86	(e-write1 #+for-vax 'rsb #+for-tahoe 'ret #+for-68k 'rts)
0f4556f1 C	87	else #+for-68k
	88	(progn
	89	(e-write3 'moveml (concat "a6@(-" g-stackspace ")")
	90	`($ ,g-masklab))
	91	(e-write2 'unlk 'a6))
	92	(e-return)))
4b9ccde7 C	93
	94	;--- d-bindtab :: emit binder table when all functions compiled
	95	;
	96	(defun d-bindtab nil
	97	(setq g-skipcode nil) ; make sure this isnt ignored
	98	(e-writel "bind_org")
ca67e7b4	99	#+(or for-vax for-tahoe)
0f4556f1 C	100	(progn
	101	(e-write2 ".set linker_size," (length g-lits))
	102	(e-write2 ".set trans_size," (length g-tran)))
	103	#+for-68k
	104	(progn
	105	(e-write2 "linker_size = " (length g-lits))
	106	(e-write2 "trans_size = " (length g-tran)))
4b9ccde7 C	107	(do ((ll (setq g-funcs (nreverse g-funcs)) (cdr ll)))
4b9ccde7 C	108	((null ll))
0f4556f1 C	109	(if (memq (caar ll) '(lambda nlambda macro eval))
	110	then (e-write2 '".long"
	111	(cdr (assoc (caar ll)
	112	'((lambda . 0) (nlambda . 1)
	113	(macro . 2) (eval . 99)))))
4b9ccde7 C	114	else (comp-err " bad type in lit list " (car ll))))
	115
	116	(e-write1 ".long -1")
0f4556f1	117	(e-writel "lit_org")
4b9ccde7	118	(d-asciiout (nreverse g-lits))
0f4556f1 C	119	(if g-tran then (d-asciiout (nreverse g-tran)))
0f4556f1 C	120	(d-asciiout (mapcar '(lambda (x) (if (eq (car x) 'eval)
4b9ccde7 C	121	then (cadr x)
	122	else (caddr x)))
	123	g-funcs))
0f4556f1	124	(e-writel "lit_end"))
4b9ccde7 C	125
	126	;--- d-asciiout :: print a list of asciz strings
	127	;
	128	(defun d-asciiout (args)
	129	(do ((lits args (cdr lits))
	130	(form))
	131	((null lits))
	132	(setq form (explode (car lits))
	133	formsiz (length form))
	134	(do ((remsiz formsiz)
	135	(curform form)
	136	(thissiz))
	137	((zerop remsiz))
0f4556f1	138	(if (greaterp remsiz 60) then (sfilewrite '".ascii \"")
4b9ccde7 C	139	else (sfilewrite '".asciz \""))
	140	(setq thissiz (min 60 remsiz))
	141	(do ((count thissiz (1- count)))
	142	((zerop count)
	143	(sfilewrite (concat '\" (ascii 10)))
	144	(setq remsiz (difference remsiz thissiz)))
0f4556f1	145	(if (eq '#.ch-newline (car curform))
4b9ccde7	146	then (sfilewrite '\\012)
0f4556f1	147	else (if (or (eq '\\ (car curform))
4b9ccde7 C	148	(eq '\" (car curform)))
	149	then (sfilewrite '\\))
	150	(sfilewrite (car curform)))
	151	(setq curform (cdr curform))))))
	152
	153	;--- d-autorunhead
	154	;
0f4556f1 C	155	; Here is the C program to generate the assembly language:
	156	; (after some cleaning up)
	157	;
	158	;main(argc,argv,arge)
	159	;register char *argv[];
	160	;register char **arge;
	161	;{
	162	; *--argv = "-f";
	163	; *--argv = "/usr/ucb/lisp";
	164	; execve("/usr/ucb/lisp",argv,arge);
	165	; exit(0);
	166	;}
	167	;
4b9ccde7	168	(defun d-printautorun nil
0f4556f1 C	169	(let ((readtable (makereadtable t)) ; in raw readtable
	170	tport ar-file)
	171	(setsyntax #/; 'vsplicing-macro 'zapline)
	172	(setq ar-file (concat lisp-library-directory
	173	#+for-vax "/autorun/vax"
ca67e7b4	174	#+for-tahoe "/autorun/tahoe"
0f4556f1 C	175	#+for-68k "/autorun/68k"))
	176	(if (null (errset (setq tport (infile ar-file))))
	177	then (comp-err "Can't open autorun header file " ar-file))
	178	(do ((x (read tport '<eof>) (read tport '<eof>)))
	179	((eq '<eof> x) (close tport))
	180	(sfilewrite x))))
4b9ccde7	181
0f4556f1	182	(defun e-cvt (arg)
ca67e7b4 C	183	(if (eq 'reg arg) then #+(or for-vax for-tahoe) 'r0 #+for-68k 'd0
	184	elseif (eq 'areg arg) then #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0
	185	elseif (eq 'Nil arg) then #+(or for-vax for-tahoe) '($ 0)
	186	#+for-68k '#.nil-reg
0f4556f1 C	187	elseif (eq 'T arg)
	188	then (if g-trueloc
	189	thenret
	190	else (setq g-trueloc (e-cvt (d-loclit t nil))))
	191	elseif (eq 'stack arg) then '(+ #.np-reg)
ca67e7b4 C	192	elseif (eq 'unstack arg) then (progn #+for-tahoe (e-sub '($ 4) '#.np-reg)
ca67e7b4 C	193	'(- #.np-reg))
0f4556f1 C	194	elseif (or (atom arg) (symbolp arg)) then arg
	195	elseif (dtpr arg)
	196	then (caseq (car arg)
	197	(stack `(,(* 4 (1- (cadr arg))) #.olbot-reg))
	198	(vstack `(* ,(* 4 (1- (cadr arg))) #.olbot-reg))
	199	(bind `(* ,(* 4 (1- (cadr arg))) #.bind-reg))
	200	(lbind `(,(* 4 (1- (cadr arg))) #.bind-reg))
	201	(fixnum `(\# ,(cadr arg)))
	202	(immed `($ ,(cadr arg)))
	203	(racc (cdr arg))
	204	(t (comp-err " bad arg to e-cvt : "
	205	(or arg))))
	206	else (comp-warn "bad arg to e-cvt : " (or arg))))
4b9ccde7 C	207
	208	;--- e-uncvt :: inverse of e-cvt, used for making comments pretty
	209	;
	210	(defun e-uncvt (arg)
0f4556f1 C	211	(if (atom arg)
	212	then (if (eq 'Nil arg)
	213	then nil
	214	else arg)
	215	elseif (eq 'stack (car arg))
	216	then (do ((i g-loccnt)
	217	(ll g-locs))
	218	((and (equal i (cadr arg)) (atom (car ll))) (car ll))
	219	(if (atom (car ll))
	220	then (setq ll (cdr ll)
	221	i (1- i))
	222	else (setq ll (cdr ll))))
	223	elseif (or (eq 'bind (car arg)) (eq 'lbind (car arg)))
	224	then (do ((i g-litcnt (1- i))
	225	(ll g-lits (cdr ll)))
	226	((equal i (cadr arg))
	227	(cond ((eq 'lbind (car arg))
	228	(list 'quote (car ll)))
	229	(t (car ll)))))
	230	else arg))
4b9ccde7 C	231
	232	;--- e-cvtas :: convert an EIADR to vax unix assembler fmt and print it
	233	; - form : an EIADR form
	234	;
ca67e7b4	235	#+(or for-vax for-tahoe)
4b9ccde7	236	(defun e-cvtas (form)
0f4556f1	237	(if (atom form)
4b9ccde7	238	then (sfilewrite form)
0f4556f1 C	239	else (if (eq '* (car form))
	240	then (if (eq '\# (cadr form))
	241	then (setq form `($ ,(caddr form)))
	242	else (sfilewrite "*")
	243	(setq form (cdr form))))
	244	(if (numberp (car form))
	245	then (sfilewrite (car form))
	246	(sfilewrite "(")
	247	(sfilewrite (cadr form))
	248	(sfilewrite ")")
	249	(if (caddr form)
	250	then (sfilewrite "[")
	251	(sfilewrite (caddr form))
	252	(sfilewrite "]"))
	253	elseif (eq '+ (car form))
	254	then (sfilewrite '"(")
	255	(sfilewrite (cadr form))
ca67e7b4 C	256	(sfilewrite '")")
ca67e7b4 C	257	#-for-tahoe (sfilewrite '"+")
0f4556f1	258	elseif (eq '- (car form))
ca67e7b4 C	259	then #-for-tahoe (sfilewrite '"-")
ca67e7b4 C	260	(sfilewrite '"(")
0f4556f1 C	261	(sfilewrite (cadr form))
	262	(sfilewrite '")")
	263	elseif (eq '\# (car form)) ; 5120 is base of small fixnums
	264	then (sfilewrite (concat "$" (+ (* (cadr form) 4) 5120)))
	265	elseif (eq '$ (car form))
	266	then (sfilewrite '"$")
	267	(sfilewrite (cadr form)))))
	268
	269	#+for-68k
	270	(defun e-cvtas (form)
	271	(if (atom form)
	272	then (sfilewrite form)
	273	else (if (eq '* (car form))
	274	then (if (eq '\# (cadr form))
	275	then (setq form `($ ,(caddr form)))))
	276	(if (numberp (car form))
	277	then (sfilewrite (cadr form))
	278	(sfilewrite "@")
	279	(if (not (zerop (car form)))
	280	then (sfilewrite "(")
	281	(sfilewrite (car form))
	282	(sfilewrite ")"))
	283	elseif (eq '% (car form))
	284	then (setq form (cdr form))
	285	(sfilewrite (cadr form))
	286	(sfilewrite "@(")
	287	(sfilewrite (car form))
	288	(sfilewrite ",")
	289	(sfilewrite (caddr form))
	290	(sfilewrite ":L)")
	291	elseif (eq '+ (car form))
	292	then (sfilewrite (cadr form))
	293	(sfilewrite '"@+")
	294	elseif (eq '- (car form))
	295	then (sfilewrite (cadr form))
	296	(sfilewrite '"@-")
	297	elseif (eq '\# (car form))
	298	then (sfilewrite (concat '#.Nilatom "+0x1400"
	299	(if (null (signp l (cadr form)))
	300	then "+" else "")
	301	(* (cadr form) 4)))
	302	elseif (eq '$ (car form))
	303	then (sfilewrite '"#")
	304	(sfilewrite (cadr form))
	305	else (comp-err " bad arg to e-cvtas : " (or form)))))
4b9ccde7	306
ca67e7b4 C	307	;--- e-postinc :: handle postincrement for the tahoe machine
	308	;
	309
	310	#+for-tahoe
	311	(defun e-postinc (addr)
	312	(if (and (dtpr addr) (eq (car addr) '+))
	313	(e-add '($ 4) (cadr addr))))
	314
	315
4b9ccde7 C	316	;--- e-docomment :: print any comment lines
	317	;
	318	(defun e-docomment nil
0f4556f1	319	(if g-comments
4b9ccde7 C	320	then (do ((ll (nreverse g-comments) (cdr ll)))
4b9ccde7 C	321	((null ll))
0f4556f1 C	322	(sfilewrite " ")
0f4556f1 C	323	(sfilewrite #.comment-char)
4b9ccde7 C	324	(do ((ll (exploden (car ll)) (cdr ll)))
	325	((null ll))
	326	(tyo (car ll) vp-sfile)
	327	(cond ((eq #\newline (car ll))
0f4556f1	328	(sfilewrite #.comment-char))))
4b9ccde7 C	329	(terpr vp-sfile))
4b9ccde7 C	330	(setq g-comments nil)
0f4556f1	331	else (terpr vp-sfile)))
e804469b	332
4b9ccde7 C	333	;--- e-goto :: emit code to jump to the location given
	334	;
	335	(defun e-goto (lbl)
	336	(e-jump lbl))
	337
	338	;--- e-gotonil :: emit code to jump if nil was last computed
	339	;
	340	(defun e-gotonil (lbl)
	341	(e-write2 g-falseop lbl))
	342
	343	;--- e-gotot :: emit code to jump if t was last computed
	344	(defun e-gotot (lbl)
	345	(e-write2 g-trueop lbl))
	346
	347	;--- e-label :: emit a label
	348	(defun e-label (lbl)
	349	(setq g-skipcode nil)
	350	(e-writel lbl))
	351
4b9ccde7 C	352	;--- e-pop :: pop the given number of args from the stack
	353	; g-locs is not! fixed
	354	;
	355	(defun e-pop (nargs)
0f4556f1	356	(if (greaterp nargs 0)
4b9ccde7 C	357	then (e-dropnp nargs)))
4b9ccde7 C	358
4b9ccde7 C	359	;--- e-pushnil :: push a given number of nils on the stack
4b9ccde7 C	360	;
0f4556f1 C	361	#+for-vax
	362	(defun e-pushnil (nargs)
	363	(do ((i nargs))
	364	((zerop i))
	365	(if (>& i 1)
	366	then (e-write2 'clrq '#.np-plus)
	367	(setq i (- i 2))
	368	elseif (equal i 1)
	369	then (e-write2 'clrl '#.np-plus)
	370	(setq i (1- i)))))
	371
ca67e7b4 C	372	#+for-tahoe
	373	(defun e-pushnil (nargs)
	374	(do ((i nargs))
	375	((zerop i))
	376	(e-write2 'clrl '#.np-plus)
	377	(setq i (1- i))))
	378
0f4556f1	379	#+for-68k
4b9ccde7 C	380	(defun e-pushnil (nargs)
	381	(do ((i nargs))
	382	((zerop i))
0f4556f1 C	383	(L-push '#.nil-reg)
0f4556f1 C	384	(setq i (1- i))))
e804469b	385
4b9ccde7 C	386	;--- e-setupbind :: setup for shallow binding
	387	;
	388	(defun e-setupbind nil
0f4556f1	389	(e-move '#.bnp-sym '#.bnp-reg))
4b9ccde7 C	390
	391	;--- e-unsetupbind :: restore temp value of bnp to real loc
	392	;
	393	(defun e-unsetupbind nil
0f4556f1	394	(e-move '#.bnp-reg '#.bnp-sym))
4b9ccde7 C	395
	396	;--- e-shallowbind :: shallow bind value of variable and initialize it
	397	; - name : variable name
	398	; - val : IADR value for variable
	399	;
ca67e7b4	400	#+(or for-vax for-68k)
4b9ccde7 C	401	(defun e-shallowbind (name val)
4b9ccde7 C	402	(let ((vloc (d-loclit name t)))
0f4556f1 C	403	(e-move (e-cvt vloc) '(+ #.bnp-reg)) ; store old val
	404	(e-move (e-cvt `(lbind ,@(cdr vloc)))
	405	'(+ #.bnp-reg)) ; now name
4b9ccde7 C	406	(d-move val vloc)))
4b9ccde7 C	407
ca67e7b4 C	408	#+for-tahoe
	409	(defun e-shallowbind (name val)
	410	(let ((vloc (d-loclit name t)))
	411	(e-move (e-cvt vloc) '(0 #.bnp-reg)) ; store old val
	412	(e-add '($ 4) '#.bnp-reg)
	413	(e-move (e-cvt `(lbind ,@(cdr vloc)))
	414	'(0 #.bnp-reg)) ; now name
	415	(e-add '($ 4) '#.bnp-reg)
	416	(d-move val vloc)))
	417
4b9ccde7 C	418	;--- e-unshallowbind :: un shallow bind n variable from top of stack
4b9ccde7 C	419	;
ca67e7b4	420	#+(or for-vax for-tahoe)
4b9ccde7 C	421	(defun e-unshallowbind (n)
	422	(e-setupbind) ; set up binding register
	423	(do ((i 1 (1+ i)))
	424	((greaterp i n))
0f4556f1 C	425	(e-move `(,(* -8 i) #.bnp-reg) `(* ,(+ 4 (* -8 i)) #.bnp-reg)))
	426	(e-sub3 `($ ,(* 8 n)) '#.bnp-reg '#.bnp-sym))
	427
	428	#+for-68k
	429	(defun e-unshallowbind (n)
	430	(makecomment "e-unshallowbind begin...")
	431	(e-setupbind) ; set up binding register
	432	(do ((i 1 (1+ i)))
	433	((greaterp i n))
	434	(e-move `(,(* -8 i) #.bnp-reg) `(* ,(+ 4 (* -8 i)) #.bnp-reg)))
	435	(e-move '#.bnp-reg '#.bnp-sym)
	436	(e-sub `($ ,(* 8 n)) '#.bnp-sym)
	437	(makecomment "...end e-unshallowbind"))
4b9ccde7 C	438
	439	;----------- very low level routines
	440	; all output to the assembler file goes through these routines.
	441	; They filter out obviously extraneous instructions as well as
	442	; combine sequential drops of np.
	443
	444	;--- e-dropnp :: unstack n values from np.
	445	; rather than output the instruction now, we just remember that it
	446	; must be done before any other instructions are done. This will
	447	; enable us to catch sequential e-dropnp's
	448	;
	449	(defun e-dropnp (n)
0f4556f1 C	450	(if (not g-skipcode)
0f4556f1 C	451	then (setq g-dropnpcnt (+ n (if g-dropnpcnt thenret else 0)))))
4b9ccde7 C	452
	453	;--- em-checknpdrop :: check if we have a pending npdrop
	454	; and do it if so.
	455	;
	456	(defmacro em-checknpdrop nil
0f4556f1 C	457	`(if g-dropnpcnt
	458	then (let ((dr g-dropnpcnt))
	459	(setq g-dropnpcnt nil)
	460	(e-sub `($ ,(* dr 4)) '#.np-reg))))
4b9ccde7 C	461
	462	;--- em-checkskip :: check if we are skipping this code due to jump
	463	;
	464	(defmacro em-checkskip nil
0f4556f1	465	'(if g-skipcode then (sfilewrite #.comment-char)))
4b9ccde7 C	466
	467
	468	;--- e-jump :: jump to given label
	469	; and set g-skipcode so that all code following until the next label
	470	; will be skipped.
	471	;
	472	(defun e-jump (l)
	473	(em-checknpdrop)
ca67e7b4	474	(e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra l)
4b9ccde7 C	475	(setq g-skipcode t))
	476
	477	;--- e-return :: do return, and dont check for np drop
	478	;
	479	(defun e-return nil
	480	(setq g-dropnpcnt nil) ; we dont need to worry about nps
ca67e7b4	481	#+(or for-vax for-tahoe) (e-write1 'ret)
0f4556f1 C	482	#+for-68k (progn (e-write1 'rts)
	483	(sfilewrite
	484	(concat g-masklab " = " (d-makemask) '#.ch-newline))
	485	(sfilewrite
	486	(concat g-stackspace " = "
	487	(Cstackspace) '#.ch-newline))))
4b9ccde7 C	488
	489	;--- e-writel :: write out a label
	490	;
	491	(defun e-writel (label)
	492	(setq g-skipcode nil)
	493	(em-checknpdrop)
	494	(sfilewrite label)
0f4556f1	495	(sfilewrite ":")
4b9ccde7 C	496	(e-docomment))
	497
	498	;--- e-write1 :: write out one litteral
	499	;
	500	(defun e-write1 (lit)
	501	(em-checkskip)
	502	(em-checknpdrop)
0f4556f1	503	(sfilewrite " ")
4b9ccde7 C	504	(sfilewrite lit)
	505	(e-docomment))
	506
	507	;--- e-write2 :: write one one litteral, and one operand
	508	;
ca67e7b4	509	#+(or for-vax for-tahoe)
4b9ccde7 C	510	(defun e-write2 (lit frm)
	511	(em-checkskip)
	512	(em-checknpdrop)
0f4556f1	513	(sfilewrite " ")
4b9ccde7	514	(sfilewrite lit)
0f4556f1	515	(sfilewrite " ")
4b9ccde7	516	(e-cvtas frm)
ca67e7b4 C	517	(e-docomment)
ca67e7b4 C	518	#+for-tahoe (e-postinc frm))
4b9ccde7	519
0f4556f1 C	520	#+for-68k
	521	(defun e-write2 (lit frm)
	522	(em-checkskip)
	523	(em-checknpdrop)
	524	(if (and (dtpr frm) (eq (car frm) '*))
	525	then (e-move (cdr frm) 'a5)
	526	(sfilewrite " ")
	527	(sfilewrite lit)
	528	(sfilewrite '" ")
	529	(e-cvtas '(0 a5))
	530	else (sfilewrite " ")
	531	(sfilewrite lit)
	532	(sfilewrite '" ")
	533	(e-cvtas frm))
	534	(e-docomment))
	535
4b9ccde7 C	536	;--- e-write3 :: write one one litteral, and two operands
4b9ccde7 C	537	;
ca67e7b4	538	#+(or for-vax for-tahoe)
4b9ccde7 C	539	(defun e-write3 (lit frm1 frm2)
	540	(em-checkskip)
	541	(em-checknpdrop)
0f4556f1	542	(sfilewrite " ")
4b9ccde7	543	(sfilewrite lit)
0f4556f1	544	(sfilewrite " ")
4b9ccde7	545	(e-cvtas frm1)
0f4556f1	546	(sfilewrite ",")
4b9ccde7	547	(e-cvtas frm2)
ca67e7b4 C	548	(e-docomment)
	549	#+for-tahoe (e-postinc frm1)
	550	#+for-tahoe (e-postinc frm2))
4b9ccde7	551
0f4556f1 C	552	#+for-68k
	553	(defun e-write3 (lit frm1 frm2)
	554	(em-checkskip)
	555	(em-checknpdrop)
	556	(if (and (dtpr frm1) (eq (car frm1) '*)
	557	(not (and (dtpr frm2) (eq (car frm2) '*))))
	558	then (e-move (cdr frm1) 'a5)
	559	(sfilewrite " ")
	560	(sfilewrite lit)
	561	(sfilewrite '" ")
	562	(e-cvtas '(0 a5))
	563	(sfilewrite '",")
	564	(e-cvtas frm2)
	565	(e-docomment)
	566	elseif (and (not (and (dtpr frm1) (eq (car frm1) '*)))
	567	(dtpr frm2) (eq (car frm2) '*))
	568	then (e-move (cdr frm2) 'a5)
	569	(sfilewrite " ")
	570	(sfilewrite lit)
	571	(sfilewrite '" ")
	572	(e-cvtas frm1)
	573	(sfilewrite '",")
	574	(e-cvtas '(0 a5))
	575	(e-docomment)
	576	elseif (and (dtpr frm1) (eq (car frm1) '*)
	577	(dtpr frm2) (eq (car frm2) '*))
	578	then (d-regused 'd6)
	579	(e-move (cdr frm1) 'a5)
	580	(e-move '(0 a5) 'd6)
	581	(e-move (cdr frm2) 'a5)
	582	(sfilewrite " ")
	583	(sfilewrite lit)
	584	(sfilewrite '" ")
	585	(e-cvtas 'd6)
	586	(sfilewrite '",")
	587	(e-cvtas '(0 a5))
	588	(e-docomment)
	589	else (sfilewrite " ")
	590	(sfilewrite lit)
	591	(sfilewrite '" ")
	592	(e-cvtas frm1)
	593	(sfilewrite '",")
	594	(e-cvtas frm2)
	595	(e-docomment)))
	596
4b9ccde7 C	597	;--- e-write4 :: write one one litteral, and three operands
4b9ccde7 C	598	;
ca67e7b4	599	#+(or for-vax for-tahoe)
4b9ccde7 C	600	(defun e-write4 (lit frm1 frm2 frm3)
	601	(em-checkskip)
	602	(em-checknpdrop)
0f4556f1	603	(sfilewrite " ")
4b9ccde7	604	(sfilewrite lit)
0f4556f1	605	(sfilewrite " ")
4b9ccde7	606	(e-cvtas frm1)
0f4556f1	607	(sfilewrite ",")
4b9ccde7	608	(e-cvtas frm2)
0f4556f1	609	(sfilewrite ",")
4b9ccde7	610	(e-cvtas frm3)
ca67e7b4 C	611	(e-docomment)
	612	#+for-tahoe (e-postinc frm1)
	613	#+for-tahoe (e-postinc frm2)
	614	#+for-tahoe (e-postinc frm3))
4b9ccde7 C	615
	616
	617	;--- e-write5 :: write one one litteral, and four operands
	618	;
ca67e7b4	619	#+(or for-vax for-tahoe)
4b9ccde7 C	620	(defun e-write5 (lit frm1 frm2 frm3 frm4)
	621	(em-checkskip)
	622	(em-checknpdrop)
0f4556f1	623	(sfilewrite " ")
4b9ccde7	624	(sfilewrite lit)
0f4556f1	625	(sfilewrite " ")
4b9ccde7	626	(e-cvtas frm1)
0f4556f1	627	(sfilewrite ",")
4b9ccde7	628	(e-cvtas frm2)
0f4556f1	629	(sfilewrite ",")
4b9ccde7	630	(e-cvtas frm3)
0f4556f1	631	(sfilewrite ",")
4b9ccde7	632	(e-cvtas frm4)
ca67e7b4 C	633	(e-docomment)
	634	#+for-tahoe (e-postinc frm1)
	635	#+for-tahoe (e-postinc frm2)
	636	#+for-tahoe (e-postinc frm3)
	637	#+for-tahoe (e-postinc frm4))
4b9ccde7	638
4b9ccde7 C	639	;--- d-printdocstuff
	640	;
	641	; describe this version
	642	;
	643	(defun d-printdocstuff nil
0f4556f1 C	644	(sfilewrite (concat ".data "
	645	#.comment-char
	646	" this is just for documentation "))
4b9ccde7 C	647	(terpr vp-sfile)
	648	(sfilewrite (concat ".asciz \"@(#)Compiled by " compiler-name
	649	" on " (status ctime) '\"))
	650	(terpr vp-sfile)
	651	(do ((xx Liszt-file-names (cdr xx)))
	652	((null xx))
	653	(sfilewrite (concat ".asciz \"" (car xx) '\"))
	654	(terpr vp-sfile)))