![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to funa.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt|
Return to funa.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt |
1.1 ! root 1: (include-if (null (get 'chead 'version)) "../chead.l") ! 2: (Liszt-file funa ! 3: "$Header: funa.l,v 1.11 83/08/28 17:14:35 layer Exp $") ! 4: ! 5: ;;; ---- f u n a function compilation ! 6: ;;; ! 7: ;;; -[Mon Aug 22 22:01:01 1983 by layer]- ! 8: ! 9: ! 10: ;--- cc-and :: compile an and expression ! 11: ; We evaluate forms from left to right as long as they evaluate to ! 12: ; a non nil value. We only have to worry about storing the value of ! 13: ; the last expression in g-loc. ! 14: ; ! 15: (defun cc-and nil ! 16: (let ((finlab (d-genlab)) ! 17: (finlab2) ! 18: (exps (if (cdr v-form) thenret else '(t)))) ; (and) ==> t ! 19: (if (null (cdr g-cc)) ! 20: then (d-exp (do ((g-cc (cons nil finlab)) ! 21: (g-loc) ! 22: (g-ret) ! 23: (ll exps (cdr ll))) ! 24: ((null (cdr ll)) (car ll)) ! 25: (d-exp (car ll)))) ! 26: (if g-loc ! 27: then (setq finlab2 (d-genlab)) ! 28: (e-goto finlab2) ! 29: (e-label finlab) ! 30: (d-move 'Nil g-loc) ! 31: (e-label finlab2) ! 32: else (e-label finlab)) ! 33: else ;--- cdr g-cc is non nil, thus there is ! 34: ; a quick escape possible if one of the ! 35: ; expressions evals to nil ! 36: ! 37: (if (null g-loc) then (setq finlab (cdr g-cc))) ! 38: (d-exp (do ((g-cc (cons nil finlab)) ! 39: (g-loc) ! 40: (g-ret) ! 41: (ll exps (cdr ll))) ! 42: ((null (cdr ll)) (car ll)) ! 43: (d-exp (car ll)))) ! 44: ; if g-loc is non nil, then we have evaled the and ! 45: ; expression to yield nil, which we must store in ! 46: ; g-loc and then jump to where the cdr of g-cc takes us ! 47: (if g-loc ! 48: then (setq finlab2 (d-genlab)) ! 49: (e-goto finlab2) ! 50: (e-label finlab) ! 51: (d-move 'Nil g-loc) ! 52: (e-goto (cdr g-cc)) ! 53: (e-label finlab2)))) ! 54: (d-clearreg)) ; we cannot predict the state of the registers ! 55: ! 56: ;--- cc-arg :: get the nth arg from the current lexpr ! 57: ; ! 58: ; the syntax for Franz lisp is (arg i) ! 59: ; for interlisp the syntax is (arg x i) where x is not evaluated and is ! 60: ; the name of the variable bound to the number of args. We can only handle ! 61: ; the case of x being the variable for the current lexpr we are compiling ! 62: ; ! 63: (defun cc-arg nil ! 64: (prog (nillab finlab) ! 65: (setq nillab (d-genlab) ! 66: finlab (d-genlab)) ! 67: (if (not (eq 'lexpr g-ftype)) ! 68: then (comp-err " arg only allowed in lexprs")) ! 69: (if (and (eq (length (cdr v-form)) 2) fl-inter) ! 70: then (if (not (eq (car g-args) (cadr v-form))) ! 71: then (comp-err " arg expression is for non local lexpr " ! 72: v-form) ! 73: else (setq v-form (cdr v-form)))) ! 74: (if (and (null g-loc) (null g-cc)) ! 75: then ;bye bye, wouldn't do anything ! 76: (return nil)) ! 77: (if (and (fixp (cadr v-form)) (>& (cadr v-form) 0)) ! 78: then ; simple case (arg n) for positive n ! 79: (d-move `(fixnum ,(cadr v-form)) 'reg) ! 80: #+for-68k ! 81: (progn ! 82: (e-sub `(-4 #.olbot-reg) 'd0) ! 83: (if g-loc ! 84: then (e-move '(% -8 #.olbot-reg d0) (e-cvt g-loc))) ! 85: (if g-cc then (e-cmpnil '(% -8 #.olbot-reg d0)))) ! 86: #+for-vax ! 87: (progn ! 88: (e-sub3 '(* -4 #.olbot-reg) '(0 r0) 'r0) ! 89: (if g-loc ! 90: then (e-move '(-8 #.olbot-reg r0) (e-cvt g-loc)) ! 91: elseif g-cc ! 92: then (e-tst '(-8 #.olbot-reg r0)))) ! 93: (d-handlecc) ! 94: elseif (or (null (cadr v-form)) ! 95: (and (fixp (cadr v-form)) (=& 0 (cadr v-form)))) ! 96: then ;---the form is: (arg nil) or (arg) or (arg 0). ! 97: ; We have a private copy of the number of args right ! 98: ; above the arguments on the name stack, so that ! 99: ; the user can't clobber it... (0 olbot) points ! 100: ; to the user setable copy, and (-4 olbot) to our ! 101: ; copy. ! 102: (if g-loc then (e-move '(-4 #.olbot-reg) (e-cvt g-loc))) ! 103: ; Will always return a non nil value, so ! 104: ; don't even test it. ! 105: (if (car g-cc) then (e-goto (car g-cc))) ! 106: else ; general (arg <form>) ! 107: (let ((g-loc 'reg) ! 108: (g-cc (cons nil nillab)) ! 109: (g-ret)) ! 110: (d-exp (cadr v-form))) ;boxed fixnum or nil ! 111: ; (arg 0) returns nargs (compiler only!) ! 112: (d-cmp 'reg '(fixnum 0)) ! 113: (e-gotonil nillab) ! 114: ! 115: ; ... here we are doing (arg <number>), <number> != 0 ! 116: #+for-68k ! 117: (progn ! 118: (e-sub '(-4 #.olbot-reg) 'd0) ! 119: (if g-loc ! 120: then (e-move '(% -8 #.olbot-reg d0) (e-cvt g-loc))) ! 121: (if g-cc then (e-cmpnil '(% -8 #.olbot-reg d0)))) ! 122: #+for-vax ! 123: (progn ! 124: (e-sub3 `(* -4 #.olbot-reg) '(0 r0) 'r0) ! 125: (if g-loc ! 126: then (e-move '(-8 #.olbot-reg r0) (e-cvt g-loc)) ! 127: elseif g-cc ! 128: then (e-tst '(-8 #.olbot-reg r0)))) ! 129: (d-handlecc) ! 130: (e-goto finlab) ! 131: (e-label nillab) ! 132: ; here we are doing (arg nil) which ! 133: ; returns the number of args ! 134: ; which is always true if anyone is testing ! 135: (if g-loc ! 136: then (e-move '(-4 #.olbot-reg) (e-cvt g-loc)) ! 137: #+for-68k (if g-cc then (e-cmpnil '(-4 #.olbot-reg))) ! 138: (d-handlecc) ! 139: elseif (car g-cc) ! 140: then (e-goto (car g-cc))) ;always true ! 141: (e-label finlab)))) ! 142: ! 143: ;--- c-assembler-code ! 144: ; the args to assembler-code are a list of assembler language ! 145: ; statements. This statements are put directly in the code ! 146: ; stream produced by the compiler. Beware: The interpreter cannot ! 147: ; interpret the assembler-code function. ! 148: ; ! 149: (defun c-assembler-code nil ! 150: (setq g-skipcode nil) ; turn off code skipping ! 151: (makecomment '(assembler code start)) ! 152: (do ((xx (cdr v-form) (cdr xx))) ! 153: ((null xx)) ! 154: (e-write1 (car xx))) ! 155: (makecomment '(assembler code end))) ! 156: ! 157: ;--- cm-assq :: assoc with eq for testing ! 158: ; ! 159: ; form: (assq val list) ! 160: ; ! 161: (defun cm-assq nil ! 162: `(do ((xx-val ,(cadr v-form)) ! 163: (xx-lis ,(caddr v-form) (cdr xx-lis))) ! 164: ((null xx-lis)) ! 165: (cond ((eq xx-val (caar xx-lis)) (return (car xx-lis)))))) ! 166: ! 167: ;--- cc-atom :: test for atomness ! 168: ; ! 169: (defun cc-atom nil ! 170: (d-typecmplx (cadr v-form) ! 171: #.(immed-const (plus 1_0 1_1 1_2 1_4 1_5 1_6 1_7 1_9 1_10)))) ! 172: ! 173: ;--- c-bcdcall :: do a bcd call ! 174: ; ! 175: ; a bcdcall is the franz equivalent of the maclisp subrcall. ! 176: ; it is called with ! 177: ; (bcdcall 'b_obj 'arg1 ...) ! 178: ; where b_obj must be a binary object. no type checking is done. ! 179: ; ! 180: (defun c-bcdcall nil ! 181: (d-callbig 1 (cdr v-form) t)) ! 182: ! 183: ;--- cc-bcdp :: check for bcdpness ! 184: ; ! 185: (defun cc-bcdp nil ! 186: (d-typesimp (cadr v-form) #.(immed-const 5))) ! 187: ! 188: ;--- cc-bigp :: check for bignumness ! 189: ; ! 190: (defun cc-bigp nil ! 191: (d-typesimp (cadr v-form) #.(immed-const 9))) ! 192: ! 193: ;--- c-boole :: compile ! 194: ; ! 195: #+for-vax ! 196: (progn 'compile ! 197: (defun c-boole nil ! 198: (cond ((fixp (cadr v-form)) ! 199: (setq v-form (d-boolexlate (d-booleexpand v-form))))) ! 200: (cond ((eq 'boole (car v-form)) ;; avoid recursive calls to d-exp ! 201: (d-callbig 'boole (cdr v-form) nil)) ! 202: (t (let ((g-loc 'reg) (g-cc nil) (g-ret nil)) ; eval answer ! 203: (d-exp v-form))))) ! 204: ! 205: ;--- d-booleexpand :: make sure boole only has three args ! 206: ; we use the identity (boole k x y z) == (boole k (boole k x y) z) ! 207: ; to make sure that there are exactly three args to a call to boole ! 208: ; ! 209: (defun d-booleexpand (form) ! 210: (if (and (dtpr form) (eq 'boole (car form))) ! 211: then (if (< (length form) 4) ! 212: then (comp-err "Too few args to boole : " form) ! 213: elseif (= (length form) 4) ! 214: then form ! 215: else (d-booleexpand ! 216: `(boole ,(cadr form) ! 217: (boole ,(cadr form) ! 218: ,(caddr form) ! 219: ,(cadddr form)) ! 220: ,@(cddddr form)))) ! 221: else form)) ! 222: ! 223: (declare (special x y)) ! 224: (defun d-boolexlate (form) ! 225: (if (atom form) ! 226: then form ! 227: elseif (and (eq 'boole (car form)) ! 228: (fixp (cadr form))) ! 229: then (let ((key (cadr form)) ! 230: (x (d-boolexlate (caddr form))) ! 231: (y (d-boolexlate (cadddr form))) ! 232: (res)) ! 233: (makecomment `(boole key = ,key)) ! 234: (if (eq key 0) ;; 0 ! 235: then `(progn ,x ,y 0) ! 236: elseif (eq key 1) ;; x * y ! 237: then `(fixnum-BitAndNot ,x (fixnum-BitXor ,y -1)) ! 238: elseif (eq key 2) ;; !x * y ! 239: then `(fixnum-BitAndNot (fixnum-BitXor ,x -1) ! 240: (fixnum-BitXor ,y -1)) ! 241: elseif (eq key 3) ;; y ! 242: then `(progn ,x ,y) ! 243: elseif (eq key 4) ;; x * !y ! 244: then `(fixnum-BitAndNot ,x ,y) ! 245: elseif (eq key 5) ;; x ! 246: then `(prog1 ,x ,y) ! 247: elseif (eq key 6) ;; x xor y ! 248: then `(fixnum-BitXor ,x ,y) ! 249: elseif (eq key 7) ;; x + y ! 250: then `(fixnum-BitOr ,x ,y) ! 251: elseif (eq key 8) ;; !(x xor y) ! 252: then `(fixnum-BitXor (fixnum-BitOr ,x ,y) -1) ! 253: elseif (eq key 9) ;; !(x xor y) ! 254: then `(fixnum-BitXor (fixnum-BitXor ,x ,y) -1) ! 255: elseif (eq key 10) ;; !x ! 256: then `(prog1 (fixnum-BitXor ,x -1) ,y) ! 257: elseif (eq key 11) ;; !x + y ! 258: then `(fixnum-BitOr (fixnum-BitXor ,x -1) ,y) ! 259: elseif (eq key 12) ;; !y ! 260: then `(progn ,x (fixnum-BitXor ,y -1)) ! 261: elseif (eq key 13) ;; x + !y ! 262: then `(fixnum-BitOr ,x (fixnum-BitXor ,y -1)) ! 263: elseif (eq key 14) ;; !x + !y ! 264: then `(fixnum-BitOr (fixnum-BitXor ,x -1) ! 265: (fixnum-BitXor ,y -1)) ! 266: elseif (eq key 15) ;; -1 ! 267: then `(progn ,x ,y -1) ! 268: else form)) ! 269: else form)) ! 270: ! 271: (declare (unspecial x y)) ! 272: ) ;; end for-vax ! 273: ! 274: ! 275: ;--- c-*catch :: compile a *catch expression ! 276: ; ! 277: ; the form of *catch is (*catch 'tag 'val) ! 278: ; we evaluate 'tag and set up a catch frame, and then eval 'val ! 279: ; ! 280: (defun c-*catch nil ! 281: (let ((g-loc 'reg) ! 282: (g-cc nil) ! 283: (g-ret nil) ! 284: (finlab (d-genlab)) ! 285: (beglab (d-genlab))) ! 286: (d-exp (cadr v-form)) ; calculate tag into 'reg ! 287: (d-pushframe #.F_CATCH 'reg 'Nil) ; the Nil is a don't care ! 288: (push nil g-labs) ; disallow labels ! 289: ; retval will be non 0 if we were thrown to, in which case the value ! 290: ; thrown is in _lispretval. ! 291: ; If we weren't thrown-to the value should be calculated in r0. ! 292: (e-tst '_retval) ! 293: (e-write2 #+for-vax 'jeql #+for-68k 'jeq beglab) ! 294: (e-move '_lispretval (e-cvt 'reg)) ! 295: (e-write2 #+for-vax 'jbr #+for-68k 'jra finlab) ! 296: (e-label beglab) ! 297: (d-exp (caddr v-form)) ! 298: (e-label finlab) ! 299: (d-popframe) ; remove catch frame from stack ! 300: (unpush g-locs) ; remove (catcherrset . 0) ! 301: (unpush g-labs) ; allow labels again ! 302: (d-clearreg))) ! 303: ! 304: ;--- d-pushframe :: put an evaluation frame on the stack ! 305: ; ! 306: ; This is equivalant in the C system to 'errp = Pushframe(class,arg1,arg2);' ! 307: ; We stack a frame which describes the class (will always be F_CATCH) ! 308: ; and the other option args. ! 309: ; 2/10/82 - it is a bad idea to stack a variable number of arguments, since ! 310: ; this makes it more complicated to unstack frames. Thus we will always ! 311: ; stack the maximum --jkf ! 312: (defun d-pushframe (class arg1 arg2) ! 313: (C-push (e-cvt arg2)) ! 314: (C-push (e-cvt arg1)) ! 315: (C-push `($ ,class)) ! 316: (if (null $global-reg$) ! 317: then (e-move '#.np-reg '#.np-sym) ! 318: (e-move '#.np-reg '#.lbot-sym)) ! 319: (e-quick-call '_qpushframe) ! 320: (e-move (e-cvt 'reg) '_errp) ! 321: (push '(catcherrset . 0) g-locs)) ! 322: ! 323: ;--- d-popframe :: remove an evaluation frame from the stack ! 324: ; ! 325: ; This is equivalent in the C system to 'errp = Popframe();' ! 326: ; n is the number of arguments given to the pushframe which ! 327: ; created this frame. We have to totally remove this frame from ! 328: ; the stack only if we are in a local function, but for now, we just ! 329: ; do it all the time. ! 330: ; ! 331: (defun d-popframe () ! 332: (let ((treg #+for-vax 'r1 #+for-68k 'a5)) ! 333: (e-move '_errp treg) ! 334: (e-move `(#.OF_olderrp ,treg) '_errp) ! 335: ; there are always 3 arguments pushed, and the frame contains 5 ! 336: ; longwords. We should make these parameters into manifest ! 337: ; constants --jkf ! 338: (e-add3 `($ ,(+ (* 3 4) (* 5 4))) treg 'sp))) ! 339: ! 340: ;--- c-cond :: compile a "cond" expression ! 341: ; ! 342: ; not that this version of cond is a 'c' rather than a 'cc' . ! 343: ; this was done to make coding this routine easier and because ! 344: ; it is believed that it wont harm things much if at all ! 345: ; ! 346: (defun c-cond nil ! 347: (makecomment '(beginning cond)) ! 348: (do ((clau (cdr v-form) (cdr clau)) ! 349: (finlab (d-genlab)) ! 350: (nxtlab) ! 351: (save-reguse) ! 352: (seent)) ! 353: ((or (null clau) seent) ! 354: ; end of cond ! 355: ; if haven't seen a t must store a nil in `reg' ! 356: (if (null seent) then (d-move 'Nil 'reg)) ! 357: (e-label finlab)) ! 358: ! 359: ; case 1 - expr ! 360: (if (atom (car clau)) ! 361: then (comp-err "bad cond clause " (car clau)) ! 362: ; case 2 - (expr) ! 363: elseif (null (cdar clau)) ! 364: then (let ((g-loc (if (or g-cc g-loc) then 'reg)) ! 365: (g-cc (cons finlab nil)) ! 366: (g-ret (and g-ret (null (cdr clau))))) ! 367: (d-exp (caar clau))) ! 368: ; case 3 - (t expr1 expr2 ...) ! 369: elseif (or (eq t (caar clau)) ! 370: (equal ''t (caar clau))) ! 371: then (let ((g-loc (if (or g-cc g-loc) then 'reg)) ! 372: g-cc) ! 373: (d-exps (cdar clau))) ! 374: (setq seent t) ! 375: ; case 4 - (expr1 expr2 ...) ! 376: else (let ((g-loc nil) ! 377: (g-cc (cons nil (setq nxtlab (d-genlab)))) ! 378: (g-ret nil)) ! 379: (d-exp (caar clau))) ! 380: (setq save-reguse (copy g-reguse)) ! 381: (let ((g-loc (if (or g-cc g-loc) then 'reg)) ! 382: g-cc) ! 383: (d-exps (cdar clau))) ! 384: (if (or (cdr clau) (null seent)) then (e-goto finlab)) ! 385: (e-label nxtlab) ! 386: (setq g-reguse save-reguse))) ! 387: ! 388: (d-clearreg)) ! 389: ! 390: ;--- c-cons :: do a cons instruction quickly ! 391: ; ! 392: (defun c-cons nil ! 393: (d-pushargs (cdr v-form)) ; there better be 2 args ! 394: (e-quick-call '_qcons) ! 395: (setq g-locs (cddr g-locs)) ! 396: (setq g-loccnt (- g-loccnt 2)) ! 397: (d-clearreg)) ! 398: ! 399: ;--- c-cxr :: compile a cxr instruction ! 400: ; ! 401: ; ! 402: (defun cc-cxr nil ! 403: (d-supercxr t nil)) ! 404: ! 405: ;--- d-supercxr :: do a general struture reference ! 406: ; type - one of fixnum-block,flonum-block,<other-symbol> ! 407: ; the type is that of an array, so <other-symbol> could be t, nil ! 408: ; or anything else, since anything except *-block is treated the same ! 409: ; ! 410: ; the form of a cxr is (cxr index hunk) but supercxr will handle ! 411: ; arrays too, so hunk could be (getdata (getd 'arrayname)) ! 412: ; ! 413: ; offsetonly is t if we only care about the offset of this element from ! 414: ; the beginning of the data structure. If offsetonly is t then type ! 415: ; will be nil. ! 416: ; ! 417: ; Note: this takes care of g-loc and g-cc ! 418: ! 419: #+for-vax ! 420: (defun d-supercxr (type offsetonly) ! 421: (let ((arg1 (cadr v-form)) ! 422: (arg2 (caddr v-form)) ! 423: lop rop semisimple) ! 424: ! 425: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 426: else (d-fixnumexp arg1) ; calculate index into r5 ! 427: (setq lop 'r5)) ; and remember that it is there ! 428: ! 429: ; before we calculate the second expression, we may have to save ! 430: ; the value just calculated into r5. To be safe we stack away ! 431: ; r5 if the expression is not simple or semisimple. ! 432: (if (not (setq rop (d-simple arg2))) ! 433: then (if (and (eq lop 'r5) ! 434: (not (setq semisimple (d-semisimple arg2)))) ! 435: then (C-push (e-cvt lop))) ! 436: (let ((g-loc 'reg) g-cc) ! 437: (d-exp arg2)) ! 438: (setq rop 'r0) ! 439: ! 440: (if (and (eq lop 'r5) (not semisimple)) ! 441: then (C-pop (e-cvt lop)))) ! 442: ! 443: (if (eq type 'flonum-block) ! 444: then (setq lop (d-structgen lop rop 8)) ! 445: (e-write3 'movq lop 'r4) ! 446: (e-quick-call '_qnewdoub) ; box number ! 447: (d-clearreg) ; clobbers all regs ! 448: (if (and g-loc (not (eq g-loc 'reg))) ! 449: then (d-move 'reg g-loc)) ! 450: (if (car g-cc) then (e-goto (car g-cc))) ! 451: else (setq lop (d-structgen lop rop 4) ! 452: rop (if g-loc then ! 453: (if (eq type 'fixnum-block) then 'r5 ! 454: else (e-cvt g-loc)))) ! 455: (if rop ! 456: then (if offsetonly ! 457: then (e-write3 'moval lop rop) ! 458: else (e-move lop rop)) ! 459: (if (eq type 'fixnum-block) ! 460: then (e-call-qnewint) ! 461: (d-clearreg) ! 462: (if (not (eq g-loc 'reg)) ! 463: then (d-move 'reg g-loc)) ! 464: ; result is always non nil. ! 465: (if (car g-cc) then (e-goto (car g-cc))) ! 466: else (d-handlecc)) ! 467: elseif g-cc ! 468: then (if (eq type 'fixnum-block) ! 469: then (if (car g-cc) ! 470: then (e-goto (car g-cc))) ! 471: else (e-tst lop) ! 472: (d-handlecc)))))) ! 473: ! 474: #+for-68k ! 475: (defun d-supercxr (type offsetonly) ! 476: (let ((arg1 (cadr v-form)) ! 477: (arg2 (caddr v-form)) ! 478: lop rop semisimple) ! 479: (makecomment `(Starting d-supercxr: vform: ,v-form)) ! 480: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 481: else (d-fixnumexp arg1) ; calculate index into fixnum-reg ! 482: (d-regused '#.fixnum-reg) ! 483: (setq lop '#.fixnum-reg)) ; and remember that it is there ! 484: ; ! 485: ; before we calculate the second expression, we may have to save ! 486: ; the value just calculated into fixnum-reg. To be safe we stack away ! 487: ; fixnum-reg if the expression is not simple or semisimple. ! 488: (if (not (setq rop (d-simple arg2))) ! 489: then (if (and (eq lop '#.fixnum-reg) ! 490: (not (setq semisimple (d-semisimple arg2)))) ! 491: then (C-push (e-cvt lop))) ! 492: (let ((g-loc 'areg) g-cc) ! 493: (d-exp arg2)) ! 494: (setq rop 'a0) ! 495: ; ! 496: (if (and (eq lop '#.fixnum-reg) (not semisimple)) ! 497: then (C-pop (e-cvt lop)))) ! 498: ; ! 499: (if (eq type 'flonum-block) ! 500: then (setq lop (d-structgen lop rop 8)) ! 501: (break " d-supercxr : flonum stuff not done.") ! 502: (e-write3 'movq lop 'r4) ! 503: (e-quick-call '_qnewdoub) ; box number ! 504: (d-clearreg) ; clobbers all regs ! 505: (if (and g-loc (not (eq g-loc 'areg))) ! 506: then (d-move 'areg g-loc)) ! 507: (if (car g-cc) then (e-goto (car g-cc))) ! 508: else (if (and (dtpr rop) (eq 'stack (car rop))) ! 509: then (e-move (e-cvt rop) 'a1) ! 510: (setq rop 'a1)) ! 511: (setq lop (d-structgen lop rop 4) ! 512: rop (if g-loc then ! 513: (if (eq type 'fixnum-block) ! 514: then '#.fixnum-reg ! 515: else (e-cvt g-loc)))) ! 516: (if rop ! 517: then (if offsetonly ! 518: then (e-write3 'lea lop 'a5) ! 519: (e-move 'a5 rop) ! 520: else (e-move lop rop)) ! 521: (if (eq type 'fixnum-block) ! 522: then (e-call-qnewint) ! 523: (d-clearreg) ! 524: (if (not (eq g-loc 'areg)) ! 525: then (d-move 'areg g-loc)) ! 526: ; result is always non nil. ! 527: (if (car g-cc) then (e-goto (car g-cc))) ! 528: else (e-cmpnil lop) ! 529: (d-handlecc)) ! 530: elseif g-cc ! 531: then (if (eq type 'fixnum-block) ! 532: then (if (car g-cc) ! 533: then (e-goto (car g-cc))) ! 534: else (if g-cc ! 535: then (e-cmpnil lop) ! 536: (d-handlecc))))) ! 537: (makecomment "Done with d-supercxr"))) ! 538: ! 539: ;--- d-semisimple :: check if result is simple enough not to clobber r5 ! 540: ; currently we look for the case of (getdata (getd 'foo)) ! 541: ; since we know that this will only be references to r0. ! 542: ; More knowledge can be added to this routine. ! 543: ; ! 544: (defun d-semisimple (form) ! 545: (or (d-simple form) ! 546: (and (dtpr form) ! 547: (eq 'getdata (car form)) ! 548: (dtpr (cadr form)) ! 549: (eq 'getd (caadr form)) ! 550: (dtpr (cadadr form)) ! 551: (eq 'quote (caadadr form))))) ! 552: ! 553: ;--- d-structgen :: generate appropriate address for indexed access ! 554: ; index - index address, must be (immed n) or r5 (which contains int) ! 555: ; base - address of base ! 556: ; width - width of data element ! 557: ; want to calculate appropriate address for base[index] ! 558: ; may require emitting instructions to set up registers ! 559: ; returns the address of the base[index] suitable for setting or reading ! 560: ; ! 561: ; the code sees the base as a stack value as a special case since it ! 562: ; can generate (perhaps) better code for that case. ! 563: ! 564: #+for-vax ! 565: (defun d-structgen (index base width) ! 566: (if (and (dtpr base) (eq (car base) 'stack)) ! 567: then (if (dtpr index) ; i.e if index = (immed n) ! 568: then (d-move index 'r5)) ; get immed in register ! 569: ; the result is always *n(r6)[r5] ! 570: (append (e-cvt `(vstack ,(cadr base))) '(r5)) ! 571: else (if (not (atom base)) ; i.e if base is not register ! 572: then (d-move base 'r0) ; (if nil gets here we will fail) ! 573: (d-clearreg 'r0) ! 574: (setq base 'r0)) ! 575: (if (dtpr index) then `(,(* width (cadr index)) ;immed index ! 576: ,base) ! 577: else `(0 ,base r5)))) ! 578: ! 579: #+for-68k ! 580: (defun d-structgen (index base width) ! 581: (if (and (dtpr base) (eq (car base) 'stack)) ! 582: then (break "d-structgen: bad args(1)") ! 583: else (if (not (atom base)) ; i.e if base is not register ! 584: then (d-move base 'a0) ; (if nil gets here we will fail) ! 585: (d-clearreg 'a0) ! 586: (setq base 'a0)) ! 587: (if (dtpr index) ! 588: then `(,(* width (cadr index)) ,base) ! 589: else (d-regused 'd6) ! 590: (e-move index 'd6) ! 591: (e-write3 'asll '($ 2) 'd6) ! 592: `(% 0 ,base d6)))) ! 593: ! 594: ;--- c-rplacx :: complile a rplacx expression ! 595: ; ! 596: ; This simple calls the general structure hacking function, d-superrplacx ! 597: ; The argument, hunk, means that the elements stored in the hunk are not ! 598: ; fixum-block or flonum-block arrays. ! 599: (defun c-rplacx nil ! 600: (d-superrplacx 'hunk)) ! 601: ! 602: ;--- d-superrplacx :: handle general setting of things in structures ! 603: ; type - one of fixnum-block, flonum-block, hunk ! 604: ; see d-supercxr for comments ! 605: ; form of rplacx is (rplacx index hunk valuetostore) ! 606: #+for-vax ! 607: (defun d-superrplacx (type) ! 608: (let ((arg1 (cadr v-form)) ! 609: (arg2 (caddr v-form)) ! 610: (arg3 (cadddr v-form)) ! 611: lop rop semisimple) ! 612: ! 613: ; calulate index and put it in r5 if it is not an immediate ! 614: ; set lop to the location of the index ! 615: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 616: else (d-fixnumexp arg1) ! 617: (setq lop 'r5)) ! 618: ! 619: ; set rop to the location of the hunk. If we have to ! 620: ; calculate the hunk, we may have to save r5. ! 621: ; If we are doing a rplacx (type equals hunk) then we must ! 622: ; return the hunk in r0. ! 623: (if (or (eq type 'hunk) (not (setq rop (d-simple arg2)))) ! 624: then (if (and (eq lop 'r5) ! 625: (not (setq semisimple (d-semisimple arg2)))) ! 626: then (d-move lop '#.Cstack)) ! 627: (let ((g-loc 'r0) g-cc) ! 628: (d-exp arg2)) ! 629: (setq rop 'r0) ! 630: ! 631: (if (and (eq lop 'r5) (not semisimple)) ! 632: then (d-move '#.unCstack lop))) ! 633: ! 634: ; now that the index and data block locations are known, we ! 635: ; caclulate the location of the index'th element of hunk ! 636: (setq rop ! 637: (d-structgen lop rop ! 638: (if (eq type 'flonum-block) then 8 else 4))) ! 639: ! 640: ; the code to calculate the value to store and the actual ! 641: ; storing depends on the type of data block we are storing in. ! 642: (if (eq type 'flonum-block) ! 643: then (if (setq lop (d-simple `(cdr ,arg3))) ! 644: then (e-write3 'movq (e-cvt lop) rop) ! 645: else ; preserve rop since it may be destroyed ! 646: ; when arg3 is calculated ! 647: (e-write3 'movaq rop '#.Cstack) ! 648: (let ((g-loc 'r0) g-cc) ! 649: (d-exp arg3)) ! 650: (d-clearreg 'r0) ! 651: (e-write3 'movq '(0 r0) "*(sp)+")) ! 652: elseif (and (eq type 'fixnum-block) ! 653: (setq arg3 `(cdr ,arg3)) ! 654: nil) ! 655: ; fixnum-block is like hunk except we must grab the ! 656: ; fixnum value out of its box, hence the (cdr arg3) ! 657: thenret ! 658: else (if (setq lop (d-simple arg3)) ! 659: then (e-move (e-cvt lop) rop) ! 660: else ; if we are dealing with hunks, we must save ! 661: ; r0 since that contains the value we want to ! 662: ; return. ! 663: (if (eq type 'hunk) then (d-move 'reg 'stack) ! 664: (Push g-locs nil) ! 665: (incr g-loccnt)) ! 666: (e-write3 'moval rop '#.Cstack) ! 667: (let ((g-loc "*(sp)+") g-cc) ! 668: (d-exp arg3)) ! 669: (if (eq type 'hunk) then (d-move 'unstack 'reg) ! 670: (unpush g-locs) ! 671: (decr g-loccnt)) ! 672: (d-clearreg 'r0))))) ! 673: ! 674: #+for-68k ! 675: (defun d-superrplacx (type) ! 676: (let ((arg1 (cadr v-form)) ! 677: (arg2 (caddr v-form)) ! 678: (arg3 (cadddr v-form)) ! 679: lop rop semisimple) ! 680: (makecomment `(starting d-superrplacx ,type :: v-form = ,v-form)) ! 681: ; ! 682: ; calulate index and put it in '#.fixnum-reg if it is not an immediate ! 683: ; set lop to the location of the index ! 684: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 685: else (d-fixnumexp arg1) ! 686: (d-regused '#.fixnum-reg) ! 687: (setq lop '#.fixnum-reg)) ! 688: ; ! 689: ; set rop to the location of the hunk. If we have to ! 690: ; calculate the hunk, we may have to save '#.fixnum-reg. ! 691: ; If we are doing a rplacx (type equals hunk) then we must ! 692: ; return the hunk in d0. ! 693: (if (or (eq type 'hunk) (not (setq rop (d-simple arg2)))) ! 694: then (if (and (eq lop '#.fixnum-reg) ! 695: (not (setq semisimple (d-semisimple arg2)))) ! 696: then (d-move lop '#.Cstack)) ! 697: (let ((g-loc 'a0) g-cc) ! 698: (d-exp arg2)) ! 699: (setq rop 'a0) ! 700: (if (and (eq lop '#.fixnum-reg) (not semisimple)) ! 701: then (d-move '#.unCstack lop))) ! 702: ; ! 703: ; now that the index and data block locations are known, we ! 704: ; caclulate the location of the index'th element of hunk ! 705: (setq rop ! 706: (d-structgen lop rop ! 707: (if (eq type 'flonum-block) then 8 else 4))) ! 708: ; ! 709: ; the code to calculate the value to store and the actual ! 710: ; storing depends on the type of data block we are storing in. ! 711: (if (eq type 'flonum-block) ! 712: then (break "flonum stuff not in yet") ! 713: (if (setq lop (d-simple `(cdr ,arg3))) ! 714: then (e-write3 'movq (e-cvt lop) rop) ! 715: else ; preserve rop since it may be destroyed ! 716: ; when arg3 is calculated ! 717: (e-write3 'movaq rop '#.Cstack) ! 718: (let ((g-loc 'd0) g-cc) ! 719: (d-exp arg3)) ! 720: (d-clearreg 'd0) ! 721: (e-write3 'movq '(0 d0) "*(sp)+")) ! 722: elseif (and (eq type 'fixnum-block) ! 723: (setq arg3 `(cdr ,arg3)) ! 724: nil) ! 725: ; fixnum-block is like hunk except we must grab the ! 726: ; fixnum value out of its box, hence the (cdr arg3) ! 727: thenret ! 728: else (if (setq lop (d-simple arg3)) ! 729: then (e-move (e-cvt lop) rop) ! 730: else ; if we are dealing with hunks, we must save ! 731: ; d0 since that contains the value we want to ! 732: ; return. ! 733: (if (eq type 'hunk) ! 734: then (L-push 'a0) ! 735: (push nil g-locs) ! 736: (incr g-loccnt)) ! 737: (e-write3 'lea rop 'a5) ! 738: (C-push 'a5) ! 739: (let ((g-loc '(racc * 0 sp)) g-cc) ! 740: (d-exp arg3)) ! 741: (if (eq type 'hunk) ! 742: then (L-pop 'd0) ! 743: (unpush g-locs) ! 744: (decr g-loccnt)))) ! 745: (makecomment '(d-superrplacx done)))) ! 746: ! 747: ;--- cc-cxxr :: compile a "c*r" instr where * ! 748: ; is any sequence of a's and d's ! 749: ; - arg : argument of the cxxr function ! 750: ; - pat : a list of a's and d's in the reverse order of that ! 751: ; which appeared between the c and r ! 752: ; ! 753: #+for-vax ! 754: (defun cc-cxxr (arg pat) ! 755: (prog (resloc loc qloc sofar togo keeptrack) ! 756: ; check for the special case of nil, since car's and cdr's ! 757: ; are nil anyway ! 758: (if (null arg) ! 759: then (if g-loc then (d-move 'Nil g-loc) ! 760: (d-handlecc) ! 761: elseif (cdr g-cc) then (e-goto (cdr g-cc))) ! 762: (return)) ! 763: ! 764: (if (and (symbolp arg) (setq qloc (d-bestreg arg pat))) ! 765: then (setq resloc (car qloc) ! 766: loc resloc ! 767: sofar (cadr qloc) ! 768: togo (caddr qloc)) ! 769: else (setq resloc ! 770: (if (d-simple arg) ! 771: thenret ! 772: else (let ((g-loc 'reg) ! 773: (g-cc nil) ! 774: (g-ret nil)) ! 775: (d-exp arg)) ! 776: 'r0)) ! 777: (setq sofar nil togo pat)) ! 778: ! 779: (if (and arg (symbolp arg)) then (setq keeptrack t)) ! 780: ! 781: ; if resloc is a global variable, we must move it into a register ! 782: ; right away to be able to do car's and cdr's ! 783: (if (and (dtpr resloc) (or (eq (car resloc) 'bind) ! 784: (eq (car resloc) 'vstack))) ! 785: then (d-move resloc 'reg) ! 786: (setq resloc 'r0)) ! 787: ! 788: ; now do car's and cdr's . Values are placed in r0. We stop when ! 789: ; we can get the result in one machine instruction. At that point ! 790: ; we see whether we want the value or just want to set the cc's. ! 791: ; If the intermediate value is in a register, ! 792: ; we can do : car cdr cddr cdar ! 793: ; If the intermediate value is on the local vrbl stack or lbind ! 794: ; we can do : cdr ! 795: (do ((curp togo newp) ! 796: (newp)) ! 797: ((null curp) (if g-loc then (d-movespec loc g-loc) ! 798: elseif g-cc then (e-tst loc)) ! 799: (d-handlecc)) ! 800: (if (symbolp resloc) ! 801: then (if (eq 'd (car curp)) ! 802: then (if (or (null (cdr curp)) ! 803: (eq 'a (cadr curp))) ! 804: then (setq newp (cdr curp) ; cdr ! 805: loc `(0 ,resloc) ! 806: sofar (append sofar (list 'd))) ! 807: else (setq newp (cddr curp) ; cddr ! 808: loc `(* 0 ,resloc) ! 809: sofar (append sofar ! 810: (list 'd 'd)))) ! 811: else (if (or (null (cdr curp)) ! 812: (eq 'a (cadr curp))) ! 813: then (setq newp (cdr curp) ; car ! 814: loc `(4 ,resloc) ! 815: sofar (append sofar (list 'a))) ! 816: else (setq newp (cddr curp) ; cdar ! 817: loc `(* 4 ,resloc) ! 818: sofar (append sofar ! 819: (list 'a 'd))))) ! 820: elseif (and (eq 'd (car curp)) ! 821: (not (eq '* (car (setq loc (e-cvt resloc)))))) ! 822: then (setq newp (cdr curp) ; (cdr <local>) ! 823: loc (cons '* loc) ! 824: sofar (append sofar (list 'd))) ! 825: else (setq loc (e-cvt resloc) ! 826: newp curp)) ! 827: (if newp ; if this is not the last move ! 828: then (setq resloc ! 829: (d-allocreg (if keeptrack then nil else 'r0))) ! 830: (d-movespec loc resloc) ! 831: (if keeptrack then (d-inreg resloc (cons arg sofar))))))) ! 832: ! 833: #+for-68k ! 834: (defun cc-cxxr (arg pat) ! 835: (prog (resloc loc qloc sofar togo keeptrack) ! 836: (makecomment '(starting cc-cxxr)) ! 837: ; check for the special case of nil, since car's and cdr's ! 838: ; are nil anyway ! 839: (if (null arg) ! 840: then (if g-loc then (d-move 'Nil g-loc)) ! 841: (if (cdr g-cc) then (e-goto (cdr g-cc))) ! 842: (return)) ! 843: (if (and (symbolp arg) (setq qloc (d-bestreg arg pat))) ! 844: then (setq resloc (car qloc) ! 845: loc resloc ! 846: sofar (cadr qloc) ! 847: togo (caddr qloc)) ! 848: else (setq resloc ! 849: (if (d-simple arg) thenret ! 850: else (d-clearreg 'a0) ! 851: (let ((g-loc 'areg) ! 852: (g-cc nil) ! 853: (g-ret nil)) ! 854: (d-exp arg)) ! 855: 'a0)) ! 856: (setq sofar nil togo pat)) ! 857: (if (and arg (symbolp arg)) then (setq keeptrack t)) ! 858: ; ! 859: ; if resloc is a global variable, we must move it into a register ! 860: ; right away to be able to do car's and cdr's ! 861: (if (and (dtpr resloc) (or (eq (car resloc) 'bind) ! 862: (eq (car resloc) 'vstack))) ! 863: then (d-move resloc 'areg) ! 864: (setq resloc 'a0)) ! 865: ; now do car's and cdr's . Values are placed in a0. We stop when ! 866: ; we can get the result in one machine instruction. At that point ! 867: ; we see whether we want the value or just want to set the cc's. ! 868: ; If the intermediate value is in a register, ! 869: ; we can do : car cdr cddr cdar ! 870: ; If the intermediate value is on the local vrbl stack or lbind ! 871: ; we can do : cdr ! 872: (do ((curp togo newp) ! 873: (newp)) ! 874: ((null curp) ! 875: (if g-loc then (d-movespec loc g-loc)) ! 876: ; ! 877: ;;;important: the below kludge is needed!! ! 878: ;;;consider the compilation of the following: ! 879: ; ! 880: ;;; (cond ((setq c (cdr c)) ...)) ! 881: ;;; the following instructions are generated: ! 882: ;;; movl a4@(N),a5 ; the setq ! 883: ;;; movl a5@,a4@(N) ! 884: ;;; movl a4@,a5 ; the last two are generated if g-cc ! 885: ;;; cmpl a5@,d7 ; is non-nil ! 886: ; ! 887: ;;; observe that the original value the is supposed to set ! 888: ;;; the cc's is clobered in the operation!! ! 889: ;(msg "g-loc: " (e-cvt g-loc) N "loc: " loc N) ! 890: (if g-cc ! 891: then (if (and (eq '* (car loc)) ! 892: (equal (caddr loc) (cadr (e-cvt g-loc)))) ! 893: then (e-cmpnil '(0 a5)) ! 894: else (e-cmpnil loc))) ! 895: (d-handlecc)) ! 896: (if (symbolp resloc) ! 897: then (if (eq 'd (car curp)) ! 898: then (if (or (null (cdr curp)) ! 899: (eq 'a (cadr curp))) ! 900: then (setq newp (cdr curp) ; cdr ! 901: loc `(0 ,resloc) ! 902: sofar (append sofar (list 'd))) ! 903: else (setq newp (cddr curp) ; cddr ! 904: loc `(* 0 ,resloc) ! 905: sofar (append sofar ! 906: (list 'd 'd)))) ! 907: else (if (or (null (cdr curp)) ! 908: (eq 'a (cadr curp))) ! 909: then (setq newp (cdr curp) ; car ! 910: loc `(4 ,resloc) ! 911: sofar (append sofar (list 'a))) ! 912: else (setq newp (cddr curp) ; cdar ! 913: loc `(* 4 ,resloc) ! 914: sofar (append sofar ! 915: (list 'a 'd))))) ! 916: elseif (and (eq 'd (car curp)) ! 917: (not (eq '* (car (setq loc (e-cvt resloc)))))) ! 918: then (setq newp (cdr curp) ; (cdr <local>) ! 919: loc (cons '* loc) ! 920: sofar (append sofar (list 'd))) ! 921: else (setq loc (e-cvt resloc) ! 922: newp curp)) ! 923: (if newp ; if this is not the last move ! 924: then (setq resloc ! 925: (d-alloc-register 'a ! 926: (if keeptrack then nil else 'a1))) ! 927: (d-movespec loc resloc) ! 928: ;(if keeptrack then (d-inreg resloc (cons arg sofar))) ! 929: )) ! 930: (makecomment '(done with cc-cxxr))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.