Return to io.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt

Annotation of 42BSD/ucb/lisp/liszt/io.l, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.