![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cddr.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / liszt|
Return to cddr.l CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / liszt |
1.1 ! root 1: (include "caspecs.l") ! 2: (eval-when (compile) ! 3: (fasl 'camacs)) ! 4: ! 5: (setq sectioncddrid "@(#)cddr.l 5.4 11/11/80") ; id for SCCS ! 6: ! 7: ; cc-not :: compile a "not" or "null" expression = cc-not = ! 8: ; ! 9: (defun cc-not nil ! 10: (makecomment '(beginning not)) ! 11: (If (null g-loc) ! 12: then (let ((g-cc (cons (cdr g-cc) (car g-cc))) ! 13: (g-ret nil)) ! 14: (d-exp (cadr v-form))) ! 15: else (let ((finlab (d-genlab)) ! 16: (finlab2 (d-genlab)) ! 17: (g-ret nil)) ! 18: ; eval arg and jump to finlab if nil ! 19: (let ((g-cc (cons finlab nil)) ! 20: g-loc) ! 21: (d-exp (cadr v-form))) ! 22: ; didn't jump, answer must be t ! 23: (d-move 'T g-loc) ! 24: (If (car g-cc) then (e-goto (car g-cc)) ! 25: else (e-goto finlab2)) ! 26: (e-label finlab) ! 27: ; answer is nil ! 28: (d-move 'Nil g-loc) ! 29: (If (cdr g-cc) then (e-goto (cdr g-cc))) ! 30: (e-label finlab2)))) ! 31: ! 32: ! 33: ;--- cc-numberp :: check for numberness = cc-numberp = ! 34: ; ! 35: (defun cc-numberp nil ! 36: (d-typecmplx (cadr v-form) ! 37: '#.(concat '$ (plus 1_2 1_4 1_9)))) ! 38: ! 39: ! 40: ;--- cc-or :: compile an "or" expression = cc-or = ! 41: ; ! 42: (defun cc-or nil ! 43: (let ((finlab (d-genlab)) ! 44: (finlab2) ! 45: (exps (If (cdr v-form) thenret else '(nil)))) ; (or) => nil ! 46: (If (null (car g-cc)) ! 47: then (d-exp (do ((g-cc (cons finlab nil)) ! 48: (g-loc (If g-loc then 'reg)) ! 49: (g-ret nil) ! 50: (ll exps (cdr ll))) ! 51: ((null (cdr ll)) (car ll)) ! 52: (d-exp (car ll)))) ! 53: (If g-loc then (setq finlab2 (d-genlab)) ! 54: (e-goto finlab2) ! 55: (e-label finlab) ! 56: (d-move 'reg g-loc) ! 57: (e-label finlab2) ! 58: else (e-label finlab)) ! 59: else (If (null g-loc) then (setq finlab (car g-cc))) ! 60: (d-exp (do ((g-cc (cons finlab nil)) ! 61: (g-loc (If g-loc then 'reg)) ! 62: (g-ret nil) ! 63: (ll exps (cdr ll))) ! 64: ((null (cdr ll)) (car ll)) ! 65: (d-exp (car ll)))) ! 66: (If g-loc then (setq finlab2 (d-genlab)) ! 67: (e-goto finlab2) ! 68: (e-label finlab) ! 69: (d-move 'reg g-loc) ! 70: (e-goto (car g-cc)) ; result is t ! 71: (e-label finlab2))) ! 72: (d-clearreg))) ; we are not sure of the state due to possible branches. ! 73: ! 74: ! 75: ;--- c-prog :: compile a "prog" expression = c-prog = ! 76: ; ! 77: ; for interlisp compatibility, we allow the formal variable list to ! 78: ; contain objects of this form (vrbl init) which gives the initial value ! 79: ; for that variable (instead of nil) ! 80: ; ! 81: (defun c-prog nil ! 82: (let (g-loc g-cc seeninit initf ((spcs locs initsv . initsn) ! 83: (d-classify (cadr v-form))) ! 84: (p-rettrue g-ret) (g-ret nil)) ! 85: ! 86: (e-pushnil (length locs)) ; locals initially nil ! 87: (d-bindprg spcs locs) ; bind locs and specs ! 88: ! 89: (cond (initsv (d-pushargs initsv) ! 90: (mapc '(lambda (x) ! 91: (d-move 'unstack (d-loc x)) ! 92: (decr g-loccnt) ! 93: (unpush g-locs)) ! 94: (nreverse initsn)))) ! 95: ! 96: ; determine all possible labels ! 97: (do ((ll (cddr v-form) (cdr ll)) ! 98: (labs nil)) ! 99: ((null ll) (setq g-labs `((,(d-genlab) ,@labs) ! 100: ,@g-labs))) ! 101: (If (and (car ll) (symbolp (car ll))) ! 102: then (If (assq (car ll) labs) ! 103: then (comp-err "label is mulitiply defined " (car ll)) ! 104: else (setq labs (cons (cons (car ll) (d-genlab)) ! 105: labs))))) ! 106: ! 107: ; compile each form which is not a label ! 108: (d-clearreg) ; unknown state after binding ! 109: (do ((ll (cddr v-form) (cdr ll))) ! 110: ((null ll)) ! 111: (If (or (null (car ll)) (not (symbolp (car ll)))) ! 112: then (d-exp (car ll)) ! 113: else (e-label (cdr (assq (car ll) (cdar g-labs)))) ! 114: (d-clearreg)))) ; dont know state after label ! 115: ! 116: ; result is nil if fall out and care about value ! 117: (If (or g-cc g-loc) then (d-move 'Nil 'reg)) ! 118: ! 119: (e-label (caar g-labs)) ; return to label ! 120: (setq g-labs (cdr g-labs)) ! 121: (d-unbind)) ; unbind our frame ! 122: ! 123: ! 124: ;--- d-bindprg :: do binding for a prog expression ! 125: ; - spcs : list of special variables ! 126: ; - locs : list of local variables ! 127: ; - specinit : init values for specs (or nil if all are nil) ! 128: ; ! 129: (defun d-bindprg (spcs locs) ! 130: ! 131: ! 132: ; place the local vrbls and prog frame entry on the stack ! 133: (setq g-loccnt (+ g-loccnt (length locs)) ! 134: g-locs (nconc locs `((prog . ,(length spcs)) ,@g-locs))) ! 135: ! 136: ; now bind the specials, if any, to nil ! 137: (If spcs then (e-setupbind) ! 138: (mapc '(lambda (vrb) ! 139: (e-shallowbind vrb 'Nil)) ! 140: spcs) ! 141: (e-unsetupbind))) ! 142: ! 143: ;--- d-unbind :: remove one frame from g-locs ! 144: ; ! 145: (defun d-unbind nil ! 146: (do ((count 0 (1+ count))) ! 147: ((dtpr (car g-locs)) ! 148: (If (not (zerop (cdar g-locs))) ! 149: then (e-unshallowbind (cdar g-locs))) ! 150: (cond ((not (zerop count)) ! 151: (e-dropnp count) ! 152: ! 153: (setq g-loccnt (- g-loccnt count)))) ! 154: (setq g-locs (cdr g-locs))) ! 155: (setq g-locs (cdr g-locs)))) ! 156: ! 157: ! 158: ;--- d-classify :: seperate variable list into special and non-special ! 159: ; - lst : list of variables ! 160: ; returns ( xxx yyy zzz . aaa) ! 161: ; where xxx is the list of special variables and ! 162: ; yyy is the list of local variables ! 163: ; zzz are the non nil initial values for prog variables ! 164: ; aaa are the names corresponding to the values in zzz ! 165: ; ! 166: (defun d-classify (lst) ! 167: (do ((ll lst (cdr ll)) ! 168: (locs) (spcs) (init) (initsv) (initsn) ! 169: (name)) ! 170: ((null ll) (cons spcs (cons locs (cons initsv initsn)))) ! 171: (If (atom (car ll)) then (setq name (car ll)) ! 172: else (setq name (caar ll)) ! 173: (Push initsn name) ! 174: (Push initsv (cadar ll))) ! 175: (If (d-specialp name) ! 176: then (Push spcs name) ! 177: else (Push locs name)))) ! 178: ! 179: ; cm-progn :: compile a "progn" expression = cm-progn = ! 180: ; ! 181: (defun cm-progn nil ! 182: `((lambda nil ,@(cdr v-form)))) ! 183: ! 184: ! 185: ; cm-prog1 :: compile a "prog1" expression = cm-prog1 = ! 186: ; ! 187: (defun cm-prog1 nil ! 188: (let ((gl (d-genlab))) ! 189: `((lambda (,gl) ! 190: ,@(cddr v-form) ! 191: ,gl) ! 192: ,(cadr v-form)))) ! 193: ! 194: ! 195: ; cm-prog2 :: compile a "prog2" expression = cm-prog2 = ! 196: ; ! 197: (defun cm-prog2 nil ! 198: (let ((gl (d-genlab))) ! 199: `((lambda (,gl) ,(cadr v-form) ! 200: (setq ,gl ,(caddr v-form)) ! 201: ,@(cdddr v-form) ! 202: ,gl) ! 203: nil))) ! 204: ! 205: ! 206: ;--- cc-quote : compile a "quote" expression = cc-quote = ! 207: ; ! 208: ; if we are just looking to set the ; cc, we just make sure ! 209: ; we set the cc depending on whether the expression quoted is ! 210: ; nil or not. ! 211: (defun cc-quote nil ! 212: (let ((arg (cadr v-form)) ! 213: argloc) ! 214: ! 215: (If (null g-loc) ! 216: then (If (and (null arg) (cdr g-cc) ! 217: then (e-goto (cdr g-cc)) ! 218: elseif (and arg (car g-cc)) ! 219: then (e-goto (car g-cc))) ! 220: elseif (null g-cc) ! 221: then (comp-warn "losing the value of this expression " (or v-form))) ! 222: else (d-move (d-loclit arg nil) g-loc) ! 223: (d-handlecc)))) ! 224: ! 225: ! 226: ;--- d-loc :: return the location of the variable or value in IADR form ! 227: ; - form : form whose value we are to locate ! 228: ; ! 229: ; if we are given a xxx as form, we check yyy; ! 230: ; xxx yyy ! 231: ; -------- --------- ! 232: ; nil Nil is always returned ! 233: ; symbol return the location of the symbols value, first looking ! 234: ; in the registers, then on the stack, then the bind list. ! 235: ; If g-ingorereg is t then we don't check the registers. ! 236: ; We would want to do this if we were interested in storing ! 237: ; something in the symbol's value location. ! 238: ; number always return the location of the number on the bind ! 239: ; list (as a (lbind n)) ! 240: ; other always return the location of the other on the bind ! 241: ; list (as a (lbind n)) ! 242: ; ! 243: (defun d-loc (form) ! 244: (If (null form) then 'Nil ! 245: elseif (numberp form) then ! 246: (If (and (fixp form) (greaterp form -1025) (lessp form 1024)) ! 247: then `(fixnum ,form) ; small fixnum ! 248: else (d-loclit form nil)) ! 249: elseif (symbolp form) ! 250: then (If (and (null g-ignorereg) (car (d-bestreg form nil))) thenret ! 251: else (If (d-specialp form) then (d-loclit form t) ! 252: else ! 253: (do ((ll g-locs (cdr ll)) ; check stack ! 254: (n g-loccnt)) ! 255: ((null ll) ! 256: (comp-warn (or form) " declared special by compiler") ! 257: (d-makespec form) ! 258: (d-loclit form t)) ! 259: (If (atom (car ll)) ! 260: then (If (eq form (car ll)) ! 261: then (return `(stack ,n)) ! 262: else (setq n (1- n))))))) ! 263: else (d-loclit form nil))) ! 264: ! 265: ! 266: ;--- d-loclit :: locate or add litteral to bind list ! 267: ; - form : form to check for and add if not present ! 268: ; - flag : if t then if we are given a symbol, return the location of ! 269: ; its value, else return the location of the symbol itself ! 270: ; ! 271: ; scheme: we share the locations of atom (symbols,numbers,string) but always ! 272: ; create a fresh copy of anything else. ! 273: (defun d-loclit (form flag) ! 274: (prog (loc onplist symboltype) ! 275: (If (null form) ! 276: then (return 'Nil) ! 277: elseif (symbolp form) ! 278: then (setq symboltype t) ! 279: (cond ((setq loc (get form g-bindloc)) ! 280: (setq onplist t))) ! 281: elseif (atom form) ! 282: then (do ((ll g-lits (cdr ll)) ; search for atom on list ! 283: (n g-litcnt (1- n))) ! 284: ((null ll)) ! 285: (If (eq form (car ll)) ! 286: then (setq loc n) ; found it ! 287: (return)))) ; leave do ! 288: (If (null loc) ! 289: then (Push g-lits form) ! 290: (setq g-litcnt (1+ g-litcnt) ! 291: loc g-litcnt) ! 292: (cond ((and symboltype (null onplist)) ! 293: (putprop form loc g-bindloc)))) ! 294: ! 295: (return (If (and flag symboltype) then `(bind ,loc) ! 296: else `(lbind ,loc))))) ! 297: ! 298: ! 299: ! 300: ;--- d-locv :: find the location of a value cell, and dont return a register ! 301: ; ! 302: (defun d-locv (sm) ! 303: (let ((g-ignorereg t)) ! 304: (d-loc sm))) ! 305: ! 306: ! 307: ;--- c-setarg :: set a lexpr's arg = cc-setarg = ! 308: ; form is (setarg index value) ! 309: ; ! 310: (defun c-setarg nil ! 311: (If (not (eq 'lexpr g-ftype)) ! 312: then (comp-err "setarg only allowed in lexprs")) ! 313: (If (and fl-inter (eq (length (cdr v-form)) 3)) ; interlisp setarg ! 314: then (If (not (eq (cadr v-form) (car g-args))) ! 315: then (comp-err "setarg: can only compile local setargs " v-form) ! 316: else (setq v-form (cdr v-form)))) ! 317: (d-pushargs (list (cadr v-form))) ; stack index ! 318: (let ((g-loc 'reg) ! 319: (g-cc nil) ! 320: (g-ret nil)) ! 321: (d-exp (caddr v-form))) ! 322: (d-clearreg 'r1) ; indicate we are clobbering r1 ! 323: (e-write3 'movl `(* -4 #.Np-reg) 'r1) ; actual number to r1 ! 324: (e-write3 'movl 'r0 "*-4(fp)[r1]") ; store value in ! 325: (e-pop 1) ! 326: (unpush g-locs) ! 327: (decr g-loccnt)) ! 328: ! 329: ;--- cc-stringp :: check for string ness = cc-stringp = ! 330: ; ! 331: (defun cc-stringp nil ! 332: (d-typesimp (cadr v-form) '$0)) ! 333: ! 334: ! 335: ;--- cc-symbolp :: check for symbolness = cc-symbolp = ! 336: ; ! 337: (defun cc-symbolp nil ! 338: (d-typesimp (cadr v-form) '$1)) ! 339: ! 340: ! 341: ! 342: ;--- c-return :: compile a "return" statement = c-return = ! 343: ; ! 344: (defun c-return nil ! 345: ; value is always put in r0 ! 346: (let ((g-loc 'reg) ! 347: g-cc ! 348: g-ret) ! 349: (d-exp (cadr v-form))) ! 350: ! 351: ; if we are doing a non local return, compute number of specials to unbind ! 352: ; and locals to pop ! 353: (If (car g-labs) then (e-goto (caar g-labs)) ! 354: else (do ((loccnt 0) ! 355: (speccnt 0) ! 356: (ll g-labs (cdr ll)) ! 357: (locs g-locs)) ! 358: ((null ll) (comp-err "return used not within a prog or do")) ! 359: (If (car ll) then (comp-warn " non local return used ") ! 360: ; unbind down to but not including ! 361: ; this frame. ! 362: (If (greaterp loccnt 0) ! 363: then (e-pop loccnt)) ! 364: (If (greaterp speccnt 0) ! 365: then (e-unshallowbind speccnt)) ! 366: (e-goto (caar ll)) ! 367: (return) ! 368: else ; determine number of locals and special on ! 369: ; stack for this frame, add to running ! 370: ; totals ! 371: (do () ! 372: ((dtpr (car locs)) ! 373: (setq speccnt (+ speccnt (cdar locs)) ! 374: locs (cdr locs))) ! 375: (incr loccnt) ! 376: (setq locs (cdr locs))))))) ! 377: ! 378: ! 379: ; c-rplaca :: compile a "rplaca" expression = c-rplaca = ! 380: ; ! 381: (defun c-rplaca nil ! 382: (let ((ssimp (d-simple (caddr v-form))) ! 383: (g-ret nil)) ! 384: (let ((g-loc (If ssimp then 'reg else 'stack)) ! 385: (g-cc nil)) ! 386: (d-exp (cadr v-form))) ! 387: (If (null ssimp) then (Push g-locs nil) ! 388: (incr g-loccnt) ! 389: (let ((g-loc 'r1) ! 390: (g-cc nil)) ! 391: (d-exp (caddr v-form))) ! 392: (d-move 'unstack 'reg) ! 393: (unpush g-locs) ! 394: (decr g-loccnt) ! 395: (e-move 'r1 '(4 r0)) ! 396: else (e-move (e-cvt ssimp) '(4 r0))) ! 397: (d-clearreg))) ; cant tell what we are clobbering ! 398: ! 399: ! 400: ; c-rplacd :: compile a "rplacd" expression = c-rplacd = ! 401: ; ! 402: (defun c-rplacd nil ! 403: (let ((ssimp (d-simple (caddr v-form))) ! 404: (g-ret nil)) ! 405: (let ((g-loc (If ssimp then 'reg else 'stack)) ! 406: (g-cc nil)) ! 407: (d-exp (cadr v-form))) ! 408: (If (null ssimp) then (Push g-locs nil) ! 409: (incr g-loccnt) ! 410: (let ((g-loc 'r1) ! 411: (g-cc nil)) ! 412: (d-exp (caddr v-form))) ! 413: (d-move 'unstack 'reg) ! 414: (unpush g-locs) ! 415: (decr g-loccnt) ! 416: (e-move 'r1 '(0 r0)) ! 417: else (e-move (e-cvt ssimp) '(0 r0))) ! 418: (d-clearreg))) ! 419: ! 420: ; c-set :: compile a "set" expression = c-set = ! 421: ! 422: ! 423: ;--- cc-setq :: compile a "setq" expression = c-setq = ! 424: ; ! 425: (defun cc-setq nil ! 426: (let (tmp) ! 427: (If (oddp (length (cdr v-form))) ! 428: then (comp-err "wrong number of args to setq " ! 429: (or v-form)) ! 430: elseif (cdddr v-form) ; if multiple setq's ! 431: then (do ((ll (cdr v-form) (cddr ll)) ! 432: (g-loc) ! 433: (g-cc nil)) ! 434: ((null (cddr ll)) (setq tmp ll)) ! 435: (setq g-loc (d-locv (car ll))) ! 436: (d-exp (cadr ll)) ! 437: (d-clearuse (car ll))) ! 438: else (setq tmp (cdr v-form))) ! 439: ! 440: ; do final setq ! 441: (let ((g-loc (d-locv (car tmp))) ! 442: (g-cc (If g-loc then nil else g-cc)) ! 443: (g-ret nil)) ! 444: (d-exp (cadr tmp)) ! 445: (d-clearuse (car tmp))) ! 446: (If g-loc then (d-move (d-locv (car tmp)) g-loc) ! 447: (If g-cc then (d-handlecc))))) ! 448: ! 449: ! 450: ! 451: ; cc-typep :: compile a "typep" expression = cc-typep = ! 452: ; ! 453: ; this returns the type of the expression, it is always non nil ! 454: ; ! 455: (defun cc-typep nil ! 456: (let ((argloc (d-simple (cadr v-form))) ! 457: (g-ret)) ! 458: (If (null argloc) then (let ((g-loc 'reg) g-cc) ! 459: (d-exp (cadr v-form))) ! 460: (setq argloc 'reg)) ! 461: (If g-loc then (e-write4 'ashl '$-9 (e-cvt argloc) 'r0) ! 462: (e-write3 'cvtbl "_typetable+1[r0]" 'r0) ! 463: (e-write3 'movl "_tynames+4[r0]" 'r0) ! 464: (e-write3 'movl "(r0)" (e-cvt g-loc))) ! 465: (If (car g-cc) then (e-goto (car g-cc))))) ! 466: ! 467: ! 468: ! 469: ; cm-symeval :: compile a symeval expression. ! 470: ; the symbol cell in franz lisp is just the cdr. ! 471: ; ! 472: (defun cm-symeval nil ! 473: `(cdr ,(cadr v-form))) ! 474: ! 475: ! 476: ; c-*throw :: compile a "*throw" expression =c-*throw = ! 477: ; ! 478: ; the form of *throw is (*throw 'tag 'val) . ! 479: ; we calculate and stack the value of tag, then calculate val ! 480: ; we call Idothrow to do the actual work, and only return if the ! 481: ; throw failed. ! 482: ; ! 483: (defun c-*throw nil ! 484: (let ((arg2loc (d-simple (caddr v-form))) ! 485: g-cc ! 486: g-ret ! 487: arg1loc) ! 488: (If arg2loc then (If (setq arg1loc (d-simple (cadr v-form))) ! 489: then (e-write2 'pushl (e-cvt arg2loc)) ! 490: (e-write2 'pushl (e-cvt arg1loc)) ! 491: else (let ((g-loc 'reg)) ! 492: (d-exp (cadr v-form)) ; calc tag ! 493: (e-write2 'pushl (e-cvt arg2loc)) ! 494: (e-write2 'pushl (e-cvt 'reg)))) ! 495: else (let ((g-loc 'stack)) ! 496: (d-exp (cadr v-form)) ; calc tag to stack ! 497: (Push g-locs nil) ! 498: (incr g-loccnt) ! 499: (setq g-loc 'reg) ! 500: (d-exp (caddr v-form)) ; calc value into r0 ! 501: (e-write2 'pushl (e-cvt 'reg)) ! 502: (e-write2 'pushl (e-cvt 'unstack)) ! 503: (unpush g-locs) ! 504: (decr g-loccnt))) ! 505: (e-write3 'calls '$0 '_Idothrow) ! 506: (e-write2 'clrl '"-(sp)") ; non contuable error ! 507: (e-write2 'pushab '__erthrow) ; string to print ! 508: (e-write3 'calls '$2 '_error))) ! 509: ! 510: ! 511: ! 512: ;--- cm-zerop :: convert zerop to a quick test = cm-zerop = ! 513: ; zerop is only allowed on fixnum and flonum arguments. In both cases, ! 514: ; if the value of the first 32 bits is zero, then we have a zero. ! 515: ; thus we can define it as a macro: ! 516: (defun cm-zerop nil ! 517: (cond ((atom (cadr v-form)) ! 518: `(and (null (cdr ,(cadr v-form))) (not (bigp ,(cadr v-form))))) ! 519: (t (let ((gnsy (gensym))) ! 520: `((lambda (,gnsy) ! 521: (and (null (cdr ,gnsy)) ! 522: (not (bigp ,gnsy)))) ! 523: ,(cadr v-form)))))) ! 524: ! 525: ! 526: ! 527: ;------- FIXNUM arithmetic section --------- ! 528: ; beware all ye who read this section ! 529: ; ! 530: ! 531: ! 532: ! 533: (declare (localf d-upordown d-fixop)) ! 534: ! 535: ;--- c-1+ :: fixnum add1 function ! 536: ; ! 537: (defun c-1+ nil ! 538: (d-upordown 'addl3)) ! 539: ! 540: ;--- c-1- :: fixnum sub1 function ! 541: ; ! 542: (defun c-1- nil ! 543: (d-upordown 'subl3)) ! 544: ! 545: (defun d-upordown (opcode) ! 546: (let ((arg (cadr v-form)) ! 547: argloc) ! 548: (If (setq argloc (d-simple `(cdr ,arg))) ! 549: then (e-write4 opcode '$1 (e-cvt argloc) 'r5) ! 550: else (let ((g-loc 'reg) ! 551: g-ret ! 552: g-cc) ! 553: (d-exp arg)) ! 554: (e-write4 opcode '$1 "(r0)" 'r5)) ! 555: (e-write2 "jsb" "_qnewint") ! 556: (d-clearreg))) ! 557: ! 558: ! 559: ;--- c-+ :: fixnum add = c-+ = ! 560: ; ! 561: (defun c-+ nil ! 562: (d-fixop 'addl3 'plus)) ! 563: ! 564: (defun c-- nil ! 565: (d-fixop 'subl3 'difference)) ! 566: ! 567: (defun c-* nil ! 568: (d-fixop 'mull3 'times)) ! 569: ! 570: (defun c-/ nil ! 571: (d-fixop 'divl3 'quotient)) ! 572: ! 573: (defun c-\\ nil ! 574: (d-fixop 'ediv 'remainder)) ! 575: ! 576: (defun d-fixop (opcode lispopcode) ! 577: (prog (op1 op2 rop1 rop2 simpleop1) ! 578: (If (not (eq 3 (length v-form))) ; only handle two ops for now ! 579: then (d-callbig lispopcode (cdr v-form)) ! 580: else (setq op1 (cadr v-form) ! 581: op2 (caddr v-form)) ! 582: (If (fixp op1) ! 583: then (setq rop1 (concat '$ op1) ; simple int ! 584: simpleop1 t) ! 585: else (If (setq rop1 (d-simple `(cdr ,op1))) ! 586: then (setq rop1 (e-cvt rop1)) ! 587: else (let ((g-loc 'reg) g-cc g-ret) ! 588: (d-exp op1)) ! 589: (setq rop1 '|(r0)|))) ! 590: (If (fixp op2) ! 591: then (setq rop2 (concat '$ op2)) ! 592: else (If (setq rop2 (d-simple `(cdr ,op2))) ! 593: then (setq rop2 (e-cvt rop2)) ! 594: else (e-write3 'movl rop1 "-(sp)") ! 595: (setq rop1 "(sp)+") ! 596: (let ((g-loc 'reg) ! 597: g-cc g-ret) ! 598: (d-exp op2)) ! 599: (setq rop2 '|(r0)|))) ! 600: (If (eq opcode 'ediv) ! 601: then (If (not simpleop1) then (e-write3 'movl rop1 'r2) ; need quad ! 602: (e-write4 'ashq '$-32 'r1 'r1) ! 603: (setq rop1 'r1)) ; word div. ! 604: (e-write5 'ediv rop2 rop1 'r0 'r5) ! 605: else (e-write4 opcode rop2 rop1 'r5)) ! 606: ! 607: (e-write2 'jsb "_qnewint") ! 608: (d-clearreg)))) ! 609: ! 610: ! 611: ! 612: ! 613: ;---- d routines (general ones, others are near function using them) ! 614: ! 615: ! 616: ! 617: ;--- d-cmp :: compare two IADR values ! 618: ; ! 619: (defun d-cmp (arg1 arg2) ! 620: (e-write3 'cmpl (e-cvt arg1) (e-cvt arg2))) ! 621: ! 622: ! 623: ;--- d-handlecc :: handle g-cc ! 624: ; at this point the Z condition code has been set up and if g-cc is ! 625: ; non nil, we must jump on condition to the label given in g-cc ! 626: ; ! 627: (defun d-handlecc nil ! 628: (If (car g-cc) then (e-gotot (car g-cc)) ! 629: elseif (cdr g-cc) then (e-gotonil (cdr g-cc)))) ! 630: ! 631: ! 632: ;--- d-invert :: handle inverted condition codes ! 633: ; this routine is called if a result has just be computed which alters ! 634: ; the condition codes such that Z=1 if the result is t, and Z=0 if the ! 635: ; result is nil (this is the reverse of the usual sense). The purpose ! 636: ; of this routine is to handle g-cc and g-loc. That is if g-loc is ! 637: ; specified, we must convert the value of the Z bit of the condition ! 638: ; code to t or nil and store that in g-loc. After handling g-loc we ! 639: ; must handle g-cc, that is if the part of g-cc is non nil which matches ! 640: ; the inverse of the current condition code, we must jump to that. ! 641: ; ! 642: (defun d-invert nil ! 643: (If (null g-loc) ! 644: then (If (car g-cc) then (e-gotonil (car g-cc)) ! 645: elseif (cdr g-cc) then (e-gotot (cdr g-cc))) ! 646: else (let ((lab1 (d-genlab)) ! 647: (lab2 (If (cdr g-cc) thenret else (d-genlab)))) ! 648: (e-gotonil lab1) ! 649: ; Z=1, but remember that this implies nil due to inversion ! 650: (d-move 'Nil g-loc) ! 651: (e-goto lab2) ! 652: (e-label lab1) ! 653: ; Z=0, which means t ! 654: (d-move 'T g-loc) ! 655: (If (car g-cc) then (e-goto (car g-cc))) ! 656: (If (null (cdr g-cc)) then (e-label lab2))))) ! 657: ! 658: ! 659: ;--- d-noninvert :: handle g-cc and g-loc assuming cc non inverted ! 660: ; ! 661: ; like d-invert except Z=0 implies nil, and Z=1 implies t ! 662: ; ! 663: (defun d-noninvert nil ! 664: (If (null g-loc) ! 665: then (If (car g-cc) then (e-gotot (car g-cc)) ! 666: elseif (cdr g-cc) then (e-gotonil (cdr g-cc))) ! 667: else (let ((lab1 (d-genlab)) ! 668: (lab2 (If (cdr g-cc) thenret else (d-genlab)))) ! 669: (e-gotot lab1) ! 670: ; Z=0, this implies nil ! 671: (d-move 'Nil g-loc) ! 672: (e-goto lab2) ! 673: (e-label lab1) ! 674: ; Z=1, which means t ! 675: (d-move 'T g-loc) ! 676: (If (car g-cc) then (e-goto (car g-cc))) ! 677: (If (null (cdr g-cc)) then (e-label lab2))))) ! 678: ! 679: ;--- d-macroexpand :: macro expand a form as much as possible ! 680: ; ! 681: (defun d-macroexpand (form) ! 682: (prog nil ! 683: loop ! 684: (If (and (dtpr form) ! 685: (symbolp (car form)) ! 686: (eq 'macro (d-functyp (car form)))) ! 687: then (setq form (apply (car form) form)) ! 688: (go loop)) ! 689: (return form))) ! 690: ! 691: ;--- d-makespec :: declare a variable to be special ! 692: ; ! 693: (defun d-makespec (vrb) ! 694: (putprop vrb t g-spec)) ! 695: ! 696: ! 697: ;--- d-move :: emit instructions to move value from one place to another ! 698: ; ! 699: (defun d-move (from to) ! 700: (makecomment `(from ,(e-uncvt from) to ,(e-uncvt to))) ! 701: (cond ((eq 'Nil from) (e-write2 'clrl (e-cvt to))) ! 702: (t (e-write3 'movl (e-cvt from) (e-cvt to))))) ! 703: ! 704: ! 705: ;--- d-simple :: see of arg can be addresses in one instruction ! 706: ; we define simple and really simple as follows ! 707: ; <rsimple> ::= number ! 708: ; quoted anything ! 709: ; local symbol ! 710: ; t ! 711: ; nil ! 712: ; <simple> ::= <rsimple> ! 713: ; (cdr <rsimple>) ! 714: ; global symbol ! 715: ; ! 716: (defun d-simple (arg) ! 717: (let (tmp) ! 718: (If (d-rsimple arg) thenret ! 719: elseif (symbolp arg) then (d-loc arg) ! 720: elseif (and (memq (car arg) '(cdr car cddr cdar)) ! 721: (setq tmp (d-rsimple (cadr arg)))) ! 722: then (If (eq 'Nil tmp) then tmp ! 723: elseif (atom tmp) ! 724: then (If (eq 'car (car arg)) then `(racc 4 ,tmp) ! 725: elseif (eq 'cdr (car arg)) then `(racc 0 ,tmp) ! 726: elseif (eq 'cddr (car arg)) then `(racc * 0 ,tmp) ! 727: elseif (eq 'cdar (car arg)) then `(racc * 4 ,tmp)) ! 728: elseif (not (eq 'cdr (car arg))) then nil ! 729: elseif (eq 'lbind (car tmp)) then `(bind ,(cadr tmp)) ! 730: elseif (eq 'stack (car tmp)) then `(vstack ,(cadr tmp)) ! 731: elseif (eq 'fixnum (car tmp)) then `(immed ,(cadr tmp)) ! 732: elseif (atom (car tmp)) then `(0 ,(cadr tmp)) ! 733: else (comp-err "bad arg to d-simple: " (or arg)))))) ! 734: ! 735: (defun d-rsimple (arg) ! 736: (If (atom arg) then ! 737: (If (null arg) then 'Nil ! 738: elseif (eq t arg) then 'T ! 739: elseif (or (numberp arg) ! 740: (memq arg g-locs)) ! 741: then (d-loc arg) ! 742: else (car (d-bestreg arg nil))) ! 743: elseif (eq 'quote (car arg)) then (d-loclit (cadr arg) nil))) ! 744: ! 745: ;--- d-movespec :: move from loc to loc where the first addr given is ! 746: ; an EIADR ! 747: ; - from : EIADR ! 748: ; - to : IADR ! 749: ; ! 750: (defun d-movespec (from to) ! 751: (makecomment `(fromspec ,from to ,(e-uncvt to))) ! 752: (e-write3 'movl from (e-cvt to))) ! 753: ! 754: ! 755: ;--- d-specialp :: check if a variable is special ! 756: ; a varible is special if it has been declared as such, or if ! 757: ; the variable special is t ! 758: (defun d-specialp (vrb) ! 759: (or special (get vrb g-spec))) ! 760: ! 761: ! 762: ;--- d-tst :: test the given value (set the cc) ! 763: ; ! 764: (defun d-tst (arg) ! 765: (e-write2 'tstl (e-cvt arg))) ! 766: ! 767: ;--- d-typesimp :: determine the type of the argument ! 768: ; ! 769: (defun d-typesimp (arg val) ! 770: (let ((argloc (d-simple arg))) ! 771: (If (null argloc) then (let ((g-loc 'reg) ! 772: g-cc g-ret) ! 773: (d-exp arg)) ! 774: (setq argloc 'reg)) ! 775: (e-write4 'ashl '$-9 (e-cvt argloc) 'r0) ! 776: (e-write3 'cmpb '"_typetable+1[r0]" val) ! 777: (d-invert))) ! 778: ! 779: ;--- d-typecmplx :: determine if arg has one of many types ! 780: ; - arg : lcode argument to be evaluated and checked ! 781: ; - vals : fixnum with a bit in position n if we are to check type n ! 782: ; ! 783: (defun d-typecmplx (arg vals) ! 784: (let ((argloc (d-simple arg)) ! 785: (reg)) ! 786: (If (null argloc) then (let ((g-loc 'reg) ! 787: g-cc g-ret) ! 788: (d-exp arg)) ! 789: (setq argloc 'reg)) ! 790: (setq reg 'r0) ! 791: (e-write4 'ashl '$-9 (e-cvt argloc) reg) ! 792: (e-write3 'cvtbl (concat "_typetable+1[" reg "]") reg) ! 793: (e-write4 'ashl reg '$1 reg) ! 794: (e-write3 'bitw vals reg) ! 795: (d-noninvert))) ! 796: ! 797: ! 798: ;---- register handling routines. ! 799: ! 800: ;--- d-allocreg :: allocate a register ! 801: ; name - the name of the register to allocate or nil if we should ! 802: ; allocate the least recently used. ! 803: ; ! 804: (defun d-allocreg (name) ! 805: (If name ! 806: then (let ((av (assoc name g-reguse))) ! 807: (If av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count ! 808: name) ! 809: else ; find smallest used count ! 810: (do ((small (car g-reguse)) ! 811: (smc (cadar g-reguse)) ! 812: (lis (cdr g-reguse) (cdr lis))) ! 813: ((null lis) ! 814: (rplaca (cdr small) (1+ smc)) ! 815: (car small)) ! 816: (If (< (cadar lis) smc) ! 817: then (setq small (car lis) ! 818: smc (cadr small)))))) ! 819: ! 820: ! 821: ;--- d-bestreg :: determine the register which is closest to what we have ! 822: ; name - name of variable whose subcontents we want ! 823: ; pat - list of d's and a's which tell which part we want ! 824: ; ! 825: (defun d-bestreg (name pat) ! 826: (do ((ll g-reguse (cdr ll)) ! 827: (val) ! 828: (best) ! 829: (tmp) ! 830: (bestv -1)) ! 831: ((null ll) (If best then (rplaca (cdr best) (1+ (cadr best))) ! 832: (list (car best) ! 833: (If (> bestv 0) ! 834: then (rplacd (nthcdr (1- bestv) ! 835: (setq tmp ! 836: (copy pat))) ! 837: nil) ! 838: tmp ! 839: else nil) ! 840: (nthcdr bestv pat)))) ! 841: (If (and (setq val (cddar ll)) ! 842: (eq name (car val))) ! 843: then (If (> (setq tmp (d-matchcnt pat (cdr val))) ! 844: bestv) ! 845: then (setq bestv tmp ! 846: best (car ll)))))) ! 847: ! 848: ;--- d-matchcnt :: determine how many parts of a pattern match ! 849: ; want - pattern we want to achieve ! 850: ; have - pattern whose value exists in a register ! 851: ; ! 852: ; we return a count of the number of parts of the pattern match. ! 853: ; If this pattern will be any help at all, we return a value from ! 854: ; 0 to the length of the pattern. ! 855: ; If this pattern will not work at all, we return a number smaller ! 856: ; than -1. ! 857: ; For `have' to be useful for `want', `have' must be a substring of ! 858: ; `want'. If it is a substring, we return the length of `have'. ! 859: ; ! 860: (defun d-matchcnt (want have) ! 861: (let ((length 0)) ! 862: (If (do ((hh have (cdr hh)) ! 863: (ww want (cdr ww))) ! 864: ((null hh) t) ! 865: (If (or (null ww) (not (eq (car ww) (car hh)))) ! 866: then (return nil) ! 867: else (incr length))) ! 868: then length ! 869: else -2))) ! 870: ! 871: ! 872: ! 873: ;--- d-clearreg :: clear all values in registers or just one ! 874: ; if no args are given, clear all registers. ! 875: ; if an arg is given, clear that register ! 876: ; ! 877: (defun d-clearreg n ! 878: (cond ((zerop n) ! 879: (mapc '(lambda (x) (rplaca (cdr x) 0) ! 880: (rplacd (cdr x) nil)) ! 881: g-reguse)) ! 882: (t (let ((av (assoc (arg 1) g-reguse))) ! 883: (If av then (rplaca (cdr av) 0) ! 884: (rplacd (cdr av) nil)))))) ! 885: ! 886: ! 887: ;--- d-clearuse :: clear all register which reference a given variable ! 888: ; ! 889: (defun d-clearuse (varib) ! 890: (mapc '(lambda (x) ! 891: (If (eq (caddr x) varib) then (rplacd (cdr x) nil))) ! 892: g-reguse)) ! 893: ! 894: ! 895: ;--- d-inreg :: declare that a value is in a register ! 896: ; name - register name ! 897: ; value - value in a register ! 898: ; ! 899: (defun d-inreg (name value) ! 900: (let ((av (assoc name g-reguse))) ! 901: (If av then (rplacd (cdr av) value)) ! 902: name)) ! 903: ! 904: ! 905: ;---- e routines ! 906: ! 907: ! 908: ! 909: (defun e-cvt (arg) ! 910: (If (eq 'reg arg) then 'r0 ! 911: elseif (eq 'Nil arg) then '$0 ! 912: elseif (eq 'T arg) then (If g-trueloc thenret ! 913: else (setq g-trueloc (e-cvt (d-loclit t nil)))) ! 914: elseif (eq 'stack arg) then '(+ #.Np-reg) ! 915: elseif (eq 'unstack arg) then '(- #.Np-reg) ! 916: elseif (atom arg) then arg ! 917: elseif (dtpr arg) then (If (eq 'stack (car arg)) ! 918: then `(,(* 4 (1- (cadr arg))) #.oLbot-reg) ! 919: elseif (eq 'vstack (car arg)) ! 920: then `(* ,(* 4 (1- (cadr arg))) #.oLbot-reg) ! 921: elseif (eq 'bind (car arg)) ! 922: then `(* ,(* 4 (1- (cadr arg))) #.bind-reg) ! 923: elseif (eq 'lbind (car arg)) ! 924: then `( ,(* 4 (1- (cadr arg))) #.bind-reg) ! 925: elseif (eq 'fixnum (car arg)) ! 926: then `(\# ,(cadr arg)) ! 927: elseif (eq 'immed (car arg)) ! 928: then `($ ,(cadr arg)) ! 929: elseif (eq 'racc (car arg)) ! 930: then (cdr arg) ! 931: else (comp-err " bad arg to e-cvt : " ! 932: (or arg))) ! 933: else (comp-warn "bad arg to e-cvt : " (or arg)))) ! 934: ! 935: ! 936: ;--- e-uncvt :: inverse of e-cvt, used for making comments pretty ! 937: ; ! 938: (defun e-uncvt (arg) ! 939: (If (atom arg) then (If (eq 'Nil arg) then nil ! 940: else arg) ! 941: elseif (eq 'stack (car arg)) ! 942: then (do ((i g-loccnt) ! 943: (ll g-locs)) ! 944: ((and (equal i (cadr arg)) (atom (car ll))) (car ll)) ! 945: (If (atom (car ll)) then (setq ll (cdr ll) ! 946: i (1- i)) ! 947: else (setq ll (cdr ll)))) ! 948: elseif (or (eq 'bind (car arg)) (eq 'lbind (car arg))) ! 949: then (do ((i g-litcnt (1- i)) ! 950: (ll g-lits (cdr ll))) ! 951: ((equal i (cadr arg)) (cond ((eq 'lbind (car arg)) ! 952: (list 'quote (car ll))) ! 953: (t (car ll))))) ! 954: else arg)) ! 955: ! 956: ;--- e-cvtas :: convert an EIADR to vax unix assembler fmt and print it ! 957: ; - form : an EIADR form ! 958: ; ! 959: (defun e-cvtas (form) ! 960: (If (atom form) ! 961: then (sfilewrite form) ! 962: else (If (eq '* (car form)) then (If (eq '\# (cadr form)) ! 963: then (setq form `($ ,(caddr form))) ! 964: else (sfilewrite "*") ! 965: (setq form (cdr form)))) ! 966: (If (numberp (car form)) ! 967: then (sfilewrite (car form)) ! 968: (sfilewrite "(") ! 969: (sfilewrite (cadr form)) ! 970: (sfilewrite ")") ! 971: (If (caddr form) ! 972: then (sfilewrite "[") ! 973: (sfilewrite (caddr form)) ! 974: (sfilewrite "]")) ! 975: elseif (eq '+ (car form)) ! 976: then (sfilewrite '"(") ! 977: (sfilewrite (cadr form)) ! 978: (sfilewrite '")+") ! 979: elseif (eq '- (car form)) ! 980: then (sfilewrite '"-(") ! 981: (sfilewrite (cadr form)) ! 982: (sfilewrite '")") ! 983: elseif (eq '\# (car form)) ; 5120 is base of small fixnums ! 984: then (sfilewrite (concat "$" (+ (* (cadr form) 4) 5120))) ! 985: elseif (eq '$ (car form)) ! 986: then (sfilewrite '"$") ! 987: (sfilewrite (cadr form))))) ! 988: ;--- e-cmp :: emit code to compare the two given args ! 989: ; - arg1, arg2 : EIADRs ! 990: ; ! 991: (defun e-cmp (arg1 arg2) ! 992: (e-write3 'cmpl arg1 arg2)) ! 993: ! 994: ;--- e-docomment :: print any comment lines ! 995: ; ! 996: (defun e-docomment nil ! 997: (If g-comments ! 998: then (do ((ll (nreverse g-comments) (cdr ll))) ! 999: ((null ll)) ! 1000: (sfilewrite '" #") ! 1001: (sfilewrite (car ll)) ! 1002: (terpr vp-sfile)) ! 1003: (setq g-comments nil) ! 1004: else (terpr vp-sfile))) ! 1005: ;--- e-goto :: emit code to jump to the location given ! 1006: ; ! 1007: (defun e-goto (lbl) ! 1008: (e-jump lbl)) ! 1009: ! 1010: ;--- e-gotonil :: emit code to jump if nil was last computed ! 1011: ; ! 1012: (defun e-gotonil (lbl) ! 1013: (e-write2 'jeql lbl)) ! 1014: ! 1015: ;--- e-gotot :: emit code to jump if t was last computed ! 1016: (defun e-gotot (lbl) ! 1017: (e-write2 'jneq lbl)) ! 1018: ! 1019: ;--- e-label :: emit a label ! 1020: (defun e-label (lbl) ! 1021: (setq g-skipcode nil) ! 1022: (e-writel lbl)) ! 1023: ! 1024: ;--- e-move :: move value from one place to anther ! 1025: ; this corresponds to d-move except the args are EIADRS ! 1026: ; ! 1027: (defun e-move (from to) ! 1028: (If (equal 0 from) then (e-write2 'clrl to) ! 1029: else (e-write3 'movl from to))) ! 1030: ! 1031: ;--- e-pop :: pop the given number of args from the stack ! 1032: ; g-locs is not! fixed ! 1033: ; ! 1034: (defun e-pop (nargs) ! 1035: (If (greaterp nargs 0) ! 1036: then (e-dropnp nargs))) ! 1037: ! 1038: ! 1039: ;--- e-pushnil :: push a given number of nils on the stack ! 1040: ; ! 1041: (defun e-pushnil (nargs) ! 1042: (do ((i nargs)) ! 1043: ((zerop i)) ! 1044: (If (greaterp i 1) then (e-write2 'clrq np-plus) ! 1045: (setq i (- i 2)) ! 1046: elseif (equal i 1) then (e-write2 'clrl np-plus) ! 1047: (setq i (1- i))))) ! 1048: ! 1049: ;--- e-tst :: test a value, arg is an EIADR ! 1050: ; ! 1051: (defun e-tst (arg) ! 1052: (e-write2 'tstl arg)) ! 1053: ;--- e-setupbind :: setup for shallow binding ! 1054: ; ! 1055: (defun e-setupbind nil ! 1056: (e-write3 'movl '#.Bnp-val '#.bNp-reg)) ! 1057: ! 1058: ;--- e-unsetupbind :: restore temp value of bnp to real loc ! 1059: ; ! 1060: (defun e-unsetupbind nil ! 1061: (e-write3 'movl '#.bNp-reg '#.Bnp-val)) ! 1062: ! 1063: ;--- e-shallowbind :: shallow bind value of variable and initialize it ! 1064: ; - name : variable name ! 1065: ; - val : IADR value for variable ! 1066: ; ! 1067: (defun e-shallowbind (name val) ! 1068: (let ((vloc (d-loclit name t))) ! 1069: (e-write3 'movl (e-cvt vloc) '(+ #.bNp-reg)) ; store old val ! 1070: (e-write3 'movl (e-cvt `(lbind ,@(cdr vloc))) ! 1071: '(+ #.bNp-reg)) ; now name ! 1072: (d-move val vloc))) ! 1073: ! 1074: ;--- e-unshallowbind :: un shallow bind n variable from top of stack ! 1075: ; ! 1076: (defun e-unshallowbind (n) ! 1077: (e-setupbind) ; set up binding register ! 1078: (do ((i 1 (1+ i))) ! 1079: ((greaterp i n)) ! 1080: (e-write3 'movl `(,(* -8 i) ,bNp-reg) `(* ,(+ 4 (* -8 i)) ,bNp-reg))) ! 1081: (e-write4 'subl3 `($ ,(* 8 n)) bNp-reg Bnp-val)) ! 1082: ! 1083: ;----------- very low level routines ! 1084: ; all output to the assembler file goes through these routines. ! 1085: ; They filter out obviously extraneous instructions as well as ! 1086: ; combine sequential drops of np. ! 1087: ! 1088: ;--- e-dropnp :: unstack n values from np. ! 1089: ; rather than output the instruction now, we just remember that it ! 1090: ; must be done before any other instructions are done. This will ! 1091: ; enable us to catch sequential e-dropnp's ! 1092: ; ! 1093: (defun e-dropnp (n) ! 1094: (If (not g-skipcode) ! 1095: then (setq g-dropnpcnt (+ n (If g-dropnpcnt thenret else 0))))) ! 1096: ! 1097: ;--- em-checknpdrop :: check if we have a pending npdrop ! 1098: ; and do it if so. ! 1099: ; ! 1100: (defmacro em-checknpdrop nil ! 1101: `(If g-dropnpcnt then (let ((dr g-dropnpcnt)) ! 1102: (setq g-dropnpcnt nil) ! 1103: (e-write3 'subl2 `($ ,(* dr 4)) Np-reg)))) ! 1104: ! 1105: ;--- em-checkskip :: check if we are skipping this code due to jump ! 1106: ; ! 1107: (defmacro em-checkskip nil ! 1108: '(If g-skipcode then (sfilewrite "# "))) ! 1109: ! 1110: ! 1111: ;--- e-jump :: jump to given label ! 1112: ; and set g-skipcode so that all code following until the next label ! 1113: ; will be skipped. ! 1114: ; ! 1115: (defun e-jump (l) ! 1116: (em-checknpdrop) ! 1117: (e-write2 'jbr l) ! 1118: (setq g-skipcode t)) ! 1119: ! 1120: ;--- e-return :: do return, and dont check for np drop ! 1121: ; ! 1122: (defun e-return nil ! 1123: (setq g-dropnpcnt nil) ; we dont need to worry about nps ! 1124: (e-write1 'ret)) ! 1125: ! 1126: ! 1127: ;--- e-writel :: write out a label ! 1128: ; ! 1129: (defun e-writel (label) ! 1130: (setq g-skipcode nil) ! 1131: (em-checknpdrop) ! 1132: (sfilewrite label) ! 1133: (sfilewrite '":") ! 1134: (e-docomment)) ! 1135: ! 1136: ;--- e-write1 :: write out one litteral ! 1137: ; ! 1138: (defun e-write1 (lit) ! 1139: (em-checkskip) ! 1140: (em-checknpdrop) ! 1141: (sfilewrite lit) ! 1142: (e-docomment)) ! 1143: ! 1144: ;--- e-write2 :: write one one litteral, and one operand ! 1145: ; ! 1146: (defun e-write2 (lit frm) ! 1147: (em-checkskip) ! 1148: (em-checknpdrop) ! 1149: (sfilewrite lit) ! 1150: (sfilewrite '" ") ! 1151: (e-cvtas frm) ! 1152: (e-docomment)) ! 1153: ! 1154: ;--- e-write3 :: write one one litteral, and two operands ! 1155: ; ! 1156: (defun e-write3 (lit frm1 frm2) ! 1157: (em-checkskip) ! 1158: (em-checknpdrop) ! 1159: (sfilewrite lit) ! 1160: (sfilewrite '" ") ! 1161: (e-cvtas frm1) ! 1162: (sfilewrite '",") ! 1163: (e-cvtas frm2) ! 1164: (e-docomment)) ! 1165: ! 1166: ;--- e-write4 :: write one one litteral, and three operands ! 1167: ; ! 1168: (defun e-write4 (lit frm1 frm2 frm3) ! 1169: (em-checkskip) ! 1170: (em-checknpdrop) ! 1171: (sfilewrite lit) ! 1172: (sfilewrite '" ") ! 1173: (e-cvtas frm1) ! 1174: (sfilewrite '",") ! 1175: (e-cvtas frm2) ! 1176: (sfilewrite '",") ! 1177: (e-cvtas frm3) ! 1178: (e-docomment)) ! 1179: ! 1180: ! 1181: ;--- e-write5 :: write one one litteral, and four operands ! 1182: ; ! 1183: (defun e-write5 (lit frm1 frm2 frm3 frm4) ! 1184: (em-checkskip) ! 1185: (em-checknpdrop) ! 1186: (sfilewrite lit) ! 1187: (sfilewrite '" ") ! 1188: (e-cvtas frm1) ! 1189: (sfilewrite '",") ! 1190: (e-cvtas frm2) ! 1191: (sfilewrite '",") ! 1192: (e-cvtas frm3) ! 1193: (sfilewrite '",") ! 1194: (e-cvtas frm4) ! 1195: (e-docomment))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.