![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt|
Return to io.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt |
1.1 ! root 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)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.