home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / io.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  17.8 KB  |  655 lines
  1. (include-if (null (get 'chead 'version)) "../chead.l")
  2. (Liszt-file io
  3.    "$Header: io.l,v 1.17 87/12/15 17:03:20 sklower Exp $")
  4.  
  5. ;;; ----     i o                input output
  6. ;;;
  7. ;;;                -[Fri Sep  2 21:37:05 1983 by layer]-
  8.  
  9.  
  10. ;--- d-prelude :: emit code common to beginning of all functions
  11. ;
  12. (defun d-prelude nil
  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))
  17.        #+for-68k (setq g-stackspace (d-genlab) g-masklab (d-genlab))
  18.        (if g-flocal
  19.        then #+for-tahoe (e-write2 '".word" '0x0)
  20.         (C-push '#.olbot-reg)
  21.         (e-write3 loada-op
  22.               `(,(* -4 g-currentargs) #.np-reg) '#.olbot-reg)
  23.         (e-writel g-topsym)
  24.        else #+(or for-vax for-tahoe) (e-write2 '".word" '0x5c0)
  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
  33.             then (e-write3 loada-op 'mcnts
  34.                    #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
  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)))))
  80.  
  81. ;--- d-fini :: emit code  at end of function
  82. ;
  83. (defun d-fini nil
  84.    (if g-flocal
  85.        then (C-pop '#.olbot-reg)
  86.         (e-write1 #+for-vax 'rsb #+for-tahoe 'ret #+for-68k 'rts)
  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)))
  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")
  99.   #+(or for-vax for-tahoe)
  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)))
  107.   (do ((ll (setq g-funcs (nreverse g-funcs)) (cdr ll)))
  108.       ((null ll))
  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)))))
  114.       else (comp-err " bad type in lit list " (car ll))))
  115.   
  116.   (e-write1 ".long -1")
  117.   (e-writel "lit_org")
  118.   (d-asciiout (nreverse g-lits))
  119.   (if g-tran then (d-asciiout (nreverse g-tran)))
  120.   (d-asciiout (mapcar '(lambda (x) (if (eq (car x) 'eval)
  121.                        then (cadr x)
  122.                        else (caddr x)))
  123.               g-funcs))
  124.   (e-writel "lit_end"))
  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))
  138.            (if (greaterp remsiz 60) then (sfilewrite '".ascii \"")
  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)))
  145.            (if (eq '#.ch-newline (car curform))
  146.                then (sfilewrite '\\012)
  147.             else (if (or (eq '\\ (car curform))
  148.                  (eq '\" (car curform)))
  149.                  then (sfilewrite '\\))
  150.              (sfilewrite (car curform)))
  151.            (setq curform (cdr curform))))))
  152.  
  153. ;--- d-autorunhead
  154. ;
  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. ;
  168. (defun d-printautorun nil
  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"
  174.                 #+for-tahoe "/autorun/tahoe"
  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))))
  181.  
  182. (defun e-cvt (arg)
  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
  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)
  192.     elseif (eq 'unstack arg) then (progn #+for-tahoe (e-sub '($ 4) '#.np-reg)
  193.                      '(- #.np-reg))
  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))))
  207.  
  208. ;--- e-uncvt :: inverse of e-cvt, used for making comments pretty
  209. ;
  210. (defun e-uncvt (arg)
  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))
  231.  
  232. ;--- e-cvtas :: convert an EIADR to vax unix assembler fmt and print it
  233. ;    - form : an EIADR form
  234. ;
  235. #+(or for-vax for-tahoe)
  236. (defun e-cvtas (form)
  237.   (if (atom form)
  238.       then (sfilewrite form)
  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))
  256.             (sfilewrite '")")
  257.             #-for-tahoe (sfilewrite '"+")
  258.         elseif (eq '- (car form))
  259.            then #-for-tahoe (sfilewrite '"-")
  260.             (sfilewrite '"(")
  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)))))
  306.  
  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.  
  316. ;--- e-docomment :: print any comment lines
  317. ;
  318. (defun e-docomment nil
  319.   (if g-comments
  320.       then (do ((ll (nreverse g-comments) (cdr ll)))
  321.            ((null ll))
  322.            (sfilewrite "    ")
  323.            (sfilewrite #.comment-char)
  324.            (do ((ll (exploden (car ll)) (cdr ll)))
  325.            ((null ll))
  326.            (tyo (car ll) vp-sfile)
  327.            (cond ((eq #\newline (car ll))
  328.               (sfilewrite #.comment-char))))
  329.            (terpr vp-sfile))
  330.        (setq g-comments nil)
  331.      else (terpr vp-sfile)))
  332.  
  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.  
  352. ;--- e-pop :: pop the given number of args from the stack
  353. ; g-locs is not! fixed
  354. ;
  355. (defun e-pop (nargs)
  356.   (if (greaterp nargs 0)
  357.       then (e-dropnp nargs)))
  358.  
  359. ;--- e-pushnil :: push a given number of nils on the stack
  360. ;
  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.  
  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.  
  379. #+for-68k
  380. (defun e-pushnil (nargs)
  381.   (do ((i nargs))
  382.       ((zerop i))
  383.       (L-push '#.nil-reg)
  384.       (setq i (1- i))))
  385.  
  386. ;--- e-setupbind :: setup for shallow binding
  387. ;
  388. (defun e-setupbind nil
  389.   (e-move '#.bnp-sym '#.bnp-reg))
  390.  
  391. ;--- e-unsetupbind :: restore temp value of bnp to real loc
  392. ;
  393. (defun e-unsetupbind nil
  394.   (e-move '#.bnp-reg '#.bnp-sym))
  395.  
  396. ;--- e-shallowbind :: shallow bind value of variable and initialize it
  397. ;    - name : variable name
  398. ;    - val : IADR value for variable
  399. ;
  400. #+(or for-vax for-68k)
  401. (defun e-shallowbind (name val)
  402.   (let ((vloc (d-loclit name t)))
  403.        (e-move (e-cvt vloc) '(+ #.bnp-reg))    ; store old val
  404.        (e-move (e-cvt `(lbind ,@(cdr vloc)))
  405.                '(+ #.bnp-reg))        ; now name
  406.        (d-move val vloc)))        
  407.  
  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.  
  418. ;--- e-unshallowbind :: un shallow bind n variable from top of stack
  419. ;
  420. #+(or for-vax for-tahoe)
  421. (defun e-unshallowbind (n)
  422.   (e-setupbind)        ; set up binding register
  423.   (do ((i 1 (1+ i)))
  424.       ((greaterp i n))
  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"))
  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)
  450.   (if (not g-skipcode)
  451.       then (setq g-dropnpcnt (+ n (if g-dropnpcnt thenret else 0)))))
  452.  
  453. ;--- em-checknpdrop :: check if we have a pending npdrop
  454. ; and do it if so.
  455. ;
  456. (defmacro em-checknpdrop nil
  457.    `(if g-dropnpcnt
  458.     then (let ((dr g-dropnpcnt))
  459.          (setq g-dropnpcnt nil)
  460.          (e-sub `($ ,(* dr 4)) '#.np-reg))))
  461.  
  462. ;--- em-checkskip :: check if we are skipping this code due to jump
  463. ;
  464. (defmacro em-checkskip nil
  465.   '(if g-skipcode then (sfilewrite #.comment-char)))
  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)
  474.   (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra l)
  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
  481.   #+(or for-vax for-tahoe) (e-write1 'ret)
  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))))
  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)
  495.   (sfilewrite ":")
  496.   (e-docomment))
  497.  
  498. ;--- e-write1 :: write out one litteral
  499. ;
  500. (defun e-write1 (lit)
  501.   (em-checkskip)
  502.   (em-checknpdrop)
  503.   (sfilewrite "    ")
  504.   (sfilewrite lit)
  505.   (e-docomment))
  506.  
  507. ;--- e-write2 :: write one one litteral, and one operand
  508. ;
  509. #+(or for-vax for-tahoe)
  510. (defun e-write2 (lit frm)
  511.   (em-checkskip)
  512.   (em-checknpdrop)
  513.   (sfilewrite "    ")
  514.   (sfilewrite lit)
  515.   (sfilewrite "    ")
  516.   (e-cvtas frm)
  517.   (e-docomment)
  518.   #+for-tahoe (e-postinc frm))
  519.  
  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.  
  536. ;--- e-write3 :: write one one litteral, and two operands
  537. ;
  538. #+(or for-vax for-tahoe)
  539. (defun e-write3 (lit frm1 frm2)
  540.   (em-checkskip)
  541.   (em-checknpdrop)
  542.   (sfilewrite "    ")
  543.   (sfilewrite lit)
  544.   (sfilewrite "    ")
  545.   (e-cvtas frm1)
  546.   (sfilewrite ",")
  547.   (e-cvtas frm2)
  548.   (e-docomment)
  549.   #+for-tahoe (e-postinc frm1)
  550.   #+for-tahoe (e-postinc frm2))
  551.  
  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.  
  597. ;--- e-write4 :: write one one litteral, and three operands
  598. ;
  599. #+(or for-vax for-tahoe)
  600. (defun e-write4 (lit frm1 frm2 frm3)
  601.   (em-checkskip)
  602.   (em-checknpdrop)
  603.   (sfilewrite "    ")
  604.   (sfilewrite lit)
  605.   (sfilewrite "    ")
  606.   (e-cvtas frm1)
  607.   (sfilewrite ",")
  608.   (e-cvtas frm2)
  609.   (sfilewrite ",")
  610.   (e-cvtas frm3)
  611.   (e-docomment)
  612.   #+for-tahoe (e-postinc frm1)
  613.   #+for-tahoe (e-postinc frm2)
  614.   #+for-tahoe (e-postinc frm3))
  615.  
  616.  
  617. ;--- e-write5 :: write one one litteral, and four operands
  618. ;
  619. #+(or for-vax for-tahoe)
  620. (defun e-write5 (lit frm1 frm2 frm3 frm4)
  621.   (em-checkskip)
  622.   (em-checknpdrop)
  623.   (sfilewrite "    ")
  624.   (sfilewrite lit)
  625.   (sfilewrite "    ")
  626.   (e-cvtas frm1)
  627.   (sfilewrite ",")
  628.   (e-cvtas frm2)
  629.   (sfilewrite ",")
  630.   (e-cvtas frm3)
  631.   (sfilewrite ",")
  632.   (e-cvtas frm4)
  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))
  638.  
  639. ;--- d-printdocstuff
  640. ;
  641. ; describe this version
  642. ;
  643. (defun d-printdocstuff nil
  644.    (sfilewrite (concat ".data "
  645.                #.comment-char
  646.                " this is just for documentation "))
  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)))
  655.