![[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] / 43BSDReno / pgrm / lisp / liszt|
Return to funa.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / liszt |
1.1 ! root 1: (include-if (null (get 'chead 'version)) "../chead.l") ! 2: (Liszt-file funa ! 3: "$Header: funa.l,v 1.12 87/12/15 17:02:01 sklower 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: #+(or for-vax for-tahoe) ! 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: #+(or for-vax for-tahoe) ! 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: #+(or for-vax for-tahoe) ! 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 #+for-vax `(fixnum-BitAndNot ,x (fixnum-BitXor ,y -1)) ! 238: #+for-tahoe `(fixnum-BitAnd ,x ,y) ! 239: elseif (eq key 2) ;; !x * y ! 240: then #+for-vax `(fixnum-BitAndNot (fixnum-BitXor ,x -1) ! 241: (fixnum-BitXor ,y -1)) ! 242: #+for-tahoe `(fixnum-BitAnd (fixnum-BitXor ,x -1) ,y) ! 243: elseif (eq key 3) ;; y ! 244: then `(progn ,x ,y) ! 245: elseif (eq key 4) ;; x * !y ! 246: then #+for-vax `(fixnum-BitAndNot ,x ,y) ! 247: #+for-tahoe `(fixnum-BitAnd ,x (fixnum-BitXor ,y -1)) ! 248: elseif (eq key 5) ;; x ! 249: then `(prog1 ,x ,y) ! 250: elseif (eq key 6) ;; x xor y ! 251: then `(fixnum-BitXor ,x ,y) ! 252: elseif (eq key 7) ;; x + y ! 253: then `(fixnum-BitOr ,x ,y) ! 254: elseif (eq key 8) ;; !(x xor y) ! 255: then `(fixnum-BitXor (fixnum-BitOr ,x ,y) -1) ! 256: elseif (eq key 9) ;; !(x xor y) ! 257: then `(fixnum-BitXor (fixnum-BitXor ,x ,y) -1) ! 258: elseif (eq key 10) ;; !x ! 259: then `(prog1 (fixnum-BitXor ,x -1) ,y) ! 260: elseif (eq key 11) ;; !x + y ! 261: then `(fixnum-BitOr (fixnum-BitXor ,x -1) ,y) ! 262: elseif (eq key 12) ;; !y ! 263: then `(progn ,x (fixnum-BitXor ,y -1)) ! 264: elseif (eq key 13) ;; x + !y ! 265: then `(fixnum-BitOr ,x (fixnum-BitXor ,y -1)) ! 266: elseif (eq key 14) ;; !x + !y ! 267: then `(fixnum-BitOr (fixnum-BitXor ,x -1) ! 268: (fixnum-BitXor ,y -1)) ! 269: elseif (eq key 15) ;; -1 ! 270: then `(progn ,x ,y -1) ! 271: else form)) ! 272: else form)) ! 273: ! 274: (declare (unspecial x y)) ! 275: ) ;; end for-vax ! 276: ! 277: ! 278: ;--- c-*catch :: compile a *catch expression ! 279: ; ! 280: ; the form of *catch is (*catch 'tag 'val) ! 281: ; we evaluate 'tag and set up a catch frame, and then eval 'val ! 282: ; ! 283: (defun c-*catch nil ! 284: (let ((g-loc 'reg) ! 285: (g-cc nil) ! 286: (g-ret nil) ! 287: (finlab (d-genlab)) ! 288: (beglab (d-genlab))) ! 289: (d-exp (cadr v-form)) ; calculate tag into 'reg ! 290: (d-pushframe #.F_CATCH 'reg 'Nil) ; the Nil is a don't care ! 291: (push nil g-labs) ; disallow labels ! 292: ; retval will be non 0 if we were thrown to, in which case the value ! 293: ; thrown is in _lispretval. ! 294: ; If we weren't thrown-to the value should be calculated in r0. ! 295: (e-tst '_retval) ! 296: (e-write2 #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq beglab) ! 297: (e-move '_lispretval (e-cvt 'reg)) ! 298: (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra finlab) ! 299: (e-label beglab) ! 300: (d-exp (caddr v-form)) ! 301: (e-label finlab) ! 302: (d-popframe) ; remove catch frame from stack ! 303: (unpush g-locs) ; remove (catcherrset . 0) ! 304: (unpush g-labs) ; allow labels again ! 305: (d-clearreg))) ! 306: ! 307: ;--- d-pushframe :: put an evaluation frame on the stack ! 308: ; ! 309: ; This is equivalant in the C system to 'errp = Pushframe(class,arg1,arg2);' ! 310: ; We stack a frame which describes the class (will always be F_CATCH) ! 311: ; and the other option args. ! 312: ; 2/10/82 - it is a bad idea to stack a variable number of arguments, since ! 313: ; this makes it more complicated to unstack frames. Thus we will always ! 314: ; stack the maximum --jkf ! 315: (defun d-pushframe (class arg1 arg2) ! 316: (C-push (e-cvt arg2)) ! 317: (C-push (e-cvt arg1)) ! 318: (C-push `($ ,class)) ! 319: (if (null $global-reg$) ! 320: then (e-move '#.np-reg '#.np-sym) ! 321: (e-move '#.np-reg '#.lbot-sym)) ! 322: (e-quick-call '_qpushframe) ! 323: (e-move (e-cvt 'reg) '_errp) ! 324: (push '(catcherrset . 0) g-locs)) ! 325: ! 326: ;--- d-popframe :: remove an evaluation frame from the stack ! 327: ; ! 328: ; This is equivalent in the C system to 'errp = Popframe();' ! 329: ; n is the number of arguments given to the pushframe which ! 330: ; created this frame. We have to totally remove this frame from ! 331: ; the stack only if we are in a local function, but for now, we just ! 332: ; do it all the time. ! 333: ; ! 334: (defun d-popframe () ! 335: (let ((treg #+(or for-vax for-tahoe) 'r1 #+for-68k 'a5)) ! 336: (e-move '_errp treg) ! 337: (e-move `(#.OF_olderrp ,treg) '_errp) ! 338: ; there are always 3 arguments pushed, and the frame contains 5 ! 339: ; longwords. We should make these parameters into manifest ! 340: ; constants --jkf ! 341: (e-add3 `($ ,(+ (* 3 4) (* 5 4))) treg 'sp))) ! 342: ! 343: ;--- c-cond :: compile a "cond" expression ! 344: ; ! 345: ; not that this version of cond is a 'c' rather than a 'cc' . ! 346: ; this was done to make coding this routine easier and because ! 347: ; it is believed that it wont harm things much if at all ! 348: ; ! 349: (defun c-cond nil ! 350: (makecomment '(beginning cond)) ! 351: (do ((clau (cdr v-form) (cdr clau)) ! 352: (finlab (d-genlab)) ! 353: (nxtlab) ! 354: (save-reguse) ! 355: (seent)) ! 356: ((or (null clau) seent) ! 357: ; end of cond ! 358: ; if haven't seen a t must store a nil in `reg' ! 359: (if (null seent) then (d-move 'Nil 'reg)) ! 360: (e-label finlab)) ! 361: ! 362: ; case 1 - expr ! 363: (if (atom (car clau)) ! 364: then (comp-err "bad cond clause " (car clau)) ! 365: ; case 2 - (expr) ! 366: elseif (null (cdar clau)) ! 367: then (let ((g-loc (if (or g-cc g-loc) then 'reg)) ! 368: (g-cc (cons finlab nil)) ! 369: (g-ret (and g-ret (null (cdr clau))))) ! 370: (d-exp (caar clau))) ! 371: ; case 3 - (t expr1 expr2 ...) ! 372: elseif (or (eq t (caar clau)) ! 373: (equal ''t (caar clau))) ! 374: then (let ((g-loc (if (or g-cc g-loc) then 'reg)) ! 375: g-cc) ! 376: (d-exps (cdar clau))) ! 377: (setq seent t) ! 378: ; case 4 - (expr1 expr2 ...) ! 379: else (let ((g-loc nil) ! 380: (g-cc (cons nil (setq nxtlab (d-genlab)))) ! 381: (g-ret nil)) ! 382: (d-exp (caar clau))) ! 383: (setq save-reguse (copy g-reguse)) ! 384: (let ((g-loc (if (or g-cc g-loc) then 'reg)) ! 385: g-cc) ! 386: (d-exps (cdar clau))) ! 387: (if (or (cdr clau) (null seent)) then (e-goto finlab)) ! 388: (e-label nxtlab) ! 389: (setq g-reguse save-reguse))) ! 390: ! 391: (d-clearreg)) ! 392: ! 393: ;--- c-cons :: do a cons instruction quickly ! 394: ; ! 395: (defun c-cons nil ! 396: (d-pushargs (cdr v-form)) ; there better be 2 args ! 397: (e-quick-call '_qcons) ! 398: (setq g-locs (cddr g-locs)) ! 399: (setq g-loccnt (- g-loccnt 2)) ! 400: (d-clearreg)) ! 401: ! 402: ;--- c-cxr :: compile a cxr instruction ! 403: ; ! 404: ; ! 405: (defun cc-cxr nil ! 406: (d-supercxr t nil)) ! 407: ! 408: ;--- d-supercxr :: do a general struture reference ! 409: ; type - one of fixnum-block,flonum-block,<other-symbol> ! 410: ; the type is that of an array, so <other-symbol> could be t, nil ! 411: ; or anything else, since anything except *-block is treated the same ! 412: ; ! 413: ; the form of a cxr is (cxr index hunk) but supercxr will handle ! 414: ; arrays too, so hunk could be (getdata (getd 'arrayname)) ! 415: ; ! 416: ; offsetonly is t if we only care about the offset of this element from ! 417: ; the beginning of the data structure. If offsetonly is t then type ! 418: ; will be nil. ! 419: ; ! 420: ; Note: this takes care of g-loc and g-cc ! 421: ! 422: #+(or for-vax for-tahoe) ! 423: (defun d-supercxr (type offsetonly) ! 424: (let ((arg1 (cadr v-form)) ! 425: (arg2 (caddr v-form)) ! 426: lop rop semisimple) ! 427: ! 428: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 429: else (d-fixnumexp arg1) ; calculate index into r5 ! 430: (setq lop 'r5)) ; and remember that it is there ! 431: ! 432: ; before we calculate the second expression, we may have to save ! 433: ; the value just calculated into r5. To be safe we stack away ! 434: ; r5 if the expression is not simple or semisimple. ! 435: (if (not (setq rop (d-simple arg2))) ! 436: then (if (and (eq lop 'r5) ! 437: (not (setq semisimple (d-semisimple arg2)))) ! 438: then (C-push (e-cvt lop))) ! 439: (let ((g-loc 'reg) g-cc) ! 440: (d-exp arg2)) ! 441: (setq rop 'r0) ! 442: ! 443: (if (and (eq lop 'r5) (not semisimple)) ! 444: then (C-pop (e-cvt lop)))) ! 445: ! 446: (if (eq type 'flonum-block) ! 447: then (setq lop (d-structgen lop rop 8)) ! 448: (e-write3 'movq lop 'r4) ! 449: (e-quick-call '_qnewdoub) ; box number ! 450: (d-clearreg) ; clobbers all regs ! 451: (if (and g-loc (not (eq g-loc 'reg))) ! 452: then (d-move 'reg g-loc)) ! 453: (if (car g-cc) then (e-goto (car g-cc))) ! 454: else (setq lop (d-structgen lop rop 4) ! 455: rop (if g-loc then ! 456: (if (eq type 'fixnum-block) then 'r5 ! 457: else (e-cvt g-loc)))) ! 458: (if rop ! 459: then (if offsetonly ! 460: then (e-write3 'moval lop rop) ! 461: else (e-move lop rop)) ! 462: (if (eq type 'fixnum-block) ! 463: then (e-call-qnewint) ! 464: (d-clearreg) ! 465: (if (not (eq g-loc 'reg)) ! 466: then (d-move 'reg g-loc)) ! 467: ; result is always non nil. ! 468: (if (car g-cc) then (e-goto (car g-cc))) ! 469: else (d-handlecc)) ! 470: elseif g-cc ! 471: then (if (eq type 'fixnum-block) ! 472: then (if (car g-cc) ! 473: then (e-goto (car g-cc))) ! 474: else (e-tst lop) ! 475: (d-handlecc)))))) ! 476: ! 477: #+for-68k ! 478: (defun d-supercxr (type offsetonly) ! 479: (let ((arg1 (cadr v-form)) ! 480: (arg2 (caddr v-form)) ! 481: lop rop semisimple) ! 482: (makecomment `(Starting d-supercxr: vform: ,v-form)) ! 483: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 484: else (d-fixnumexp arg1) ; calculate index into fixnum-reg ! 485: (d-regused '#.fixnum-reg) ! 486: (setq lop '#.fixnum-reg)) ; and remember that it is there ! 487: ; ! 488: ; before we calculate the second expression, we may have to save ! 489: ; the value just calculated into fixnum-reg. To be safe we stack away ! 490: ; fixnum-reg if the expression is not simple or semisimple. ! 491: (if (not (setq rop (d-simple arg2))) ! 492: then (if (and (eq lop '#.fixnum-reg) ! 493: (not (setq semisimple (d-semisimple arg2)))) ! 494: then (C-push (e-cvt lop))) ! 495: (let ((g-loc 'areg) g-cc) ! 496: (d-exp arg2)) ! 497: (setq rop 'a0) ! 498: ; ! 499: (if (and (eq lop '#.fixnum-reg) (not semisimple)) ! 500: then (C-pop (e-cvt lop)))) ! 501: ; ! 502: (if (eq type 'flonum-block) ! 503: then (setq lop (d-structgen lop rop 8)) ! 504: (break " d-supercxr : flonum stuff not done.") ! 505: (e-write3 'movq lop 'r4) ! 506: (e-quick-call '_qnewdoub) ; box number ! 507: (d-clearreg) ; clobbers all regs ! 508: (if (and g-loc (not (eq g-loc 'areg))) ! 509: then (d-move 'areg g-loc)) ! 510: (if (car g-cc) then (e-goto (car g-cc))) ! 511: else (if (and (dtpr rop) (eq 'stack (car rop))) ! 512: then (e-move (e-cvt rop) 'a1) ! 513: (setq rop 'a1)) ! 514: (setq lop (d-structgen lop rop 4) ! 515: rop (if g-loc then ! 516: (if (eq type 'fixnum-block) ! 517: then '#.fixnum-reg ! 518: else (e-cvt g-loc)))) ! 519: (if rop ! 520: then (if offsetonly ! 521: then (e-write3 'lea lop 'a5) ! 522: (e-move 'a5 rop) ! 523: else (e-move lop rop)) ! 524: (if (eq type 'fixnum-block) ! 525: then (e-call-qnewint) ! 526: (d-clearreg) ! 527: (if (not (eq g-loc 'areg)) ! 528: then (d-move 'areg g-loc)) ! 529: ; result is always non nil. ! 530: (if (car g-cc) then (e-goto (car g-cc))) ! 531: else (e-cmpnil lop) ! 532: (d-handlecc)) ! 533: elseif g-cc ! 534: then (if (eq type 'fixnum-block) ! 535: then (if (car g-cc) ! 536: then (e-goto (car g-cc))) ! 537: else (if g-cc ! 538: then (e-cmpnil lop) ! 539: (d-handlecc))))) ! 540: (makecomment "Done with d-supercxr"))) ! 541: ! 542: ;--- d-semisimple :: check if result is simple enough not to clobber r5 ! 543: ; currently we look for the case of (getdata (getd 'foo)) ! 544: ; since we know that this will only be references to r0. ! 545: ; More knowledge can be added to this routine. ! 546: ; ! 547: (defun d-semisimple (form) ! 548: (or (d-simple form) ! 549: (and (dtpr form) ! 550: (eq 'getdata (car form)) ! 551: (dtpr (cadr form)) ! 552: (eq 'getd (caadr form)) ! 553: (dtpr (cadadr form)) ! 554: (eq 'quote (caadadr form))))) ! 555: ! 556: ;--- d-structgen :: generate appropriate address for indexed access ! 557: ; index - index address, must be (immed n) or r5 (which contains int) ! 558: ; base - address of base ! 559: ; width - width of data element ! 560: ; want to calculate appropriate address for base[index] ! 561: ; may require emitting instructions to set up registers ! 562: ; returns the address of the base[index] suitable for setting or reading ! 563: ; ! 564: ; the code sees the base as a stack value as a special case since it ! 565: ; can generate (perhaps) better code for that case. ! 566: ! 567: #+(or for-vax for-tahoe) ! 568: (defun d-structgen (index base width) ! 569: (if (and (dtpr base) (eq (car base) 'stack)) ! 570: then (if (dtpr index) ; i.e if index = (immed n) ! 571: then (d-move index 'r5)) ; get immed in register ! 572: ; the result is always *n(r6)[r5] ! 573: (append (e-cvt `(vstack ,(cadr base))) '(r5)) ! 574: else (if (not (atom base)) ; i.e if base is not register ! 575: then (d-move base 'r0) ; (if nil gets here we will fail) ! 576: (d-clearreg 'r0) ! 577: (setq base 'r0)) ! 578: (if (dtpr index) then `(,(* width (cadr index)) ;immed index ! 579: ,base) ! 580: else `(0 ,base r5)))) ! 581: ! 582: #+for-68k ! 583: (defun d-structgen (index base width) ! 584: (if (and (dtpr base) (eq (car base) 'stack)) ! 585: then (break "d-structgen: bad args(1)") ! 586: else (if (not (atom base)) ; i.e if base is not register ! 587: then (d-move base 'a0) ; (if nil gets here we will fail) ! 588: (d-clearreg 'a0) ! 589: (setq base 'a0)) ! 590: (if (dtpr index) ! 591: then `(,(* width (cadr index)) ,base) ! 592: else (d-regused 'd6) ! 593: (e-move index 'd6) ! 594: (e-write3 'asll '($ 2) 'd6) ! 595: `(% 0 ,base d6)))) ! 596: ! 597: ;--- c-rplacx :: complile a rplacx expression ! 598: ; ! 599: ; This simple calls the general structure hacking function, d-superrplacx ! 600: ; The argument, hunk, means that the elements stored in the hunk are not ! 601: ; fixum-block or flonum-block arrays. ! 602: (defun c-rplacx nil ! 603: (d-superrplacx 'hunk)) ! 604: ! 605: ;--- d-superrplacx :: handle general setting of things in structures ! 606: ; type - one of fixnum-block, flonum-block, hunk ! 607: ; see d-supercxr for comments ! 608: ; form of rplacx is (rplacx index hunk valuetostore) ! 609: #+(or for-vax for-tahoe) ! 610: (defun d-superrplacx (type) ! 611: (let ((arg1 (cadr v-form)) ! 612: (arg2 (caddr v-form)) ! 613: (arg3 (cadddr v-form)) ! 614: lop rop semisimple) ! 615: ! 616: ; calulate index and put it in r5 if it is not an immediate ! 617: ; set lop to the location of the index ! 618: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 619: else (d-fixnumexp arg1) ! 620: (setq lop 'r5)) ! 621: ! 622: ; set rop to the location of the hunk. If we have to ! 623: ; calculate the hunk, we may have to save r5. ! 624: ; If we are doing a rplacx (type equals hunk) then we must ! 625: ; return the hunk in r0. ! 626: (if (or (eq type 'hunk) (not (setq rop (d-simple arg2)))) ! 627: then (if (and (eq lop 'r5) ! 628: (not (setq semisimple (d-semisimple arg2)))) ! 629: then (d-move lop '#.Cstack)) ! 630: (let ((g-loc 'r0) g-cc) ! 631: (d-exp arg2)) ! 632: (setq rop 'r0) ! 633: ! 634: (if (and (eq lop 'r5) (not semisimple)) ! 635: then (d-move '#.unCstack lop))) ! 636: ! 637: ; now that the index and data block locations are known, we ! 638: ; caclulate the location of the index'th element of hunk ! 639: (setq rop ! 640: (d-structgen lop rop ! 641: (if (eq type 'flonum-block) then 8 else 4))) ! 642: ! 643: ; the code to calculate the value to store and the actual ! 644: ; storing depends on the type of data block we are storing in. ! 645: (if (eq type 'flonum-block) ! 646: then (if (setq lop (d-simple `(cdr ,arg3))) ! 647: then (e-write3 'movq (e-cvt lop) rop) ! 648: else ; preserve rop since it may be destroyed ! 649: ; when arg3 is calculated ! 650: (e-write3 'movaq rop '#.Cstack) ! 651: (let ((g-loc 'r0) g-cc) ! 652: (d-exp arg3)) ! 653: (d-clearreg 'r0) ! 654: (e-write3 'movq '(0 r0) "*(sp)+")) ! 655: elseif (and (eq type 'fixnum-block) ! 656: (setq arg3 `(cdr ,arg3)) ! 657: nil) ! 658: ; fixnum-block is like hunk except we must grab the ! 659: ; fixnum value out of its box, hence the (cdr arg3) ! 660: thenret ! 661: else (if (setq lop (d-simple arg3)) ! 662: then (e-move (e-cvt lop) rop) ! 663: else ; if we are dealing with hunks, we must save ! 664: ; r0 since that contains the value we want to ! 665: ; return. ! 666: (if (eq type 'hunk) then (d-move 'reg 'stack) ! 667: (Push g-locs nil) ! 668: (incr g-loccnt)) ! 669: (e-write3 'moval rop '#.Cstack) ! 670: (let ((g-loc "*(sp)+") g-cc) ! 671: (d-exp arg3)) ! 672: (if (eq type 'hunk) then (d-move 'unstack 'reg) ! 673: (unpush g-locs) ! 674: (decr g-loccnt)) ! 675: (d-clearreg 'r0))))) ! 676: ! 677: #+for-68k ! 678: (defun d-superrplacx (type) ! 679: (let ((arg1 (cadr v-form)) ! 680: (arg2 (caddr v-form)) ! 681: (arg3 (cadddr v-form)) ! 682: lop rop semisimple) ! 683: (makecomment `(starting d-superrplacx ,type :: v-form = ,v-form)) ! 684: ; ! 685: ; calulate index and put it in '#.fixnum-reg if it is not an immediate ! 686: ; set lop to the location of the index ! 687: (if (fixp arg1) then (setq lop `(immed ,arg1)) ! 688: else (d-fixnumexp arg1) ! 689: (d-regused '#.fixnum-reg) ! 690: (setq lop '#.fixnum-reg)) ! 691: ; ! 692: ; set rop to the location of the hunk. If we have to ! 693: ; calculate the hunk, we may have to save '#.fixnum-reg. ! 694: ; If we are doing a rplacx (type equals hunk) then we must ! 695: ; return the hunk in d0. ! 696: (if (or (eq type 'hunk) (not (setq rop (d-simple arg2)))) ! 697: then (if (and (eq lop '#.fixnum-reg) ! 698: (not (setq semisimple (d-semisimple arg2)))) ! 699: then (d-move lop '#.Cstack)) ! 700: (let ((g-loc 'a0) g-cc) ! 701: (d-exp arg2)) ! 702: (setq rop 'a0) ! 703: (if (and (eq lop '#.fixnum-reg) (not semisimple)) ! 704: then (d-move '#.unCstack lop))) ! 705: ; ! 706: ; now that the index and data block locations are known, we ! 707: ; caclulate the location of the index'th element of hunk ! 708: (setq rop ! 709: (d-structgen lop rop ! 710: (if (eq type 'flonum-block) then 8 else 4))) ! 711: ; ! 712: ; the code to calculate the value to store and the actual ! 713: ; storing depends on the type of data block we are storing in. ! 714: (if (eq type 'flonum-block) ! 715: then (break "flonum stuff not in yet") ! 716: (if (setq lop (d-simple `(cdr ,arg3))) ! 717: then (e-write3 'movq (e-cvt lop) rop) ! 718: else ; preserve rop since it may be destroyed ! 719: ; when arg3 is calculated ! 720: (e-write3 'movaq rop '#.Cstack) ! 721: (let ((g-loc 'd0) g-cc) ! 722: (d-exp arg3)) ! 723: (d-clearreg 'd0) ! 724: (e-write3 'movq '(0 d0) "*(sp)+")) ! 725: elseif (and (eq type 'fixnum-block) ! 726: (setq arg3 `(cdr ,arg3)) ! 727: nil) ! 728: ; fixnum-block is like hunk except we must grab the ! 729: ; fixnum value out of its box, hence the (cdr arg3) ! 730: thenret ! 731: else (if (setq lop (d-simple arg3)) ! 732: then (e-move (e-cvt lop) rop) ! 733: else ; if we are dealing with hunks, we must save ! 734: ; d0 since that contains the value we want to ! 735: ; return. ! 736: (if (eq type 'hunk) ! 737: then (L-push 'a0) ! 738: (push nil g-locs) ! 739: (incr g-loccnt)) ! 740: (e-write3 'lea rop 'a5) ! 741: (C-push 'a5) ! 742: (let ((g-loc '(racc * 0 sp)) g-cc) ! 743: (d-exp arg3)) ! 744: (if (eq type 'hunk) ! 745: then (L-pop 'd0) ! 746: (unpush g-locs) ! 747: (decr g-loccnt)))) ! 748: (makecomment '(d-superrplacx done)))) ! 749: ! 750: ;--- cc-cxxr :: compile a "c*r" instr where * ! 751: ; is any sequence of a's and d's ! 752: ; - arg : argument of the cxxr function ! 753: ; - pat : a list of a's and d's in the reverse order of that ! 754: ; which appeared between the c and r ! 755: ; ! 756: #+(or for-vax for-tahoe) ! 757: (defun cc-cxxr (arg pat) ! 758: (prog (resloc loc qloc sofar togo keeptrack) ! 759: ; check for the special case of nil, since car's and cdr's ! 760: ; are nil anyway ! 761: (if (null arg) ! 762: then (if g-loc then (d-move 'Nil g-loc) ! 763: (d-handlecc) ! 764: elseif (cdr g-cc) then (e-goto (cdr g-cc))) ! 765: (return)) ! 766: ! 767: (if (and (symbolp arg) (setq qloc (d-bestreg arg pat))) ! 768: then (setq resloc (car qloc) ! 769: loc resloc ! 770: sofar (cadr qloc) ! 771: togo (caddr qloc)) ! 772: else (setq resloc ! 773: (if (d-simple arg) ! 774: thenret ! 775: else (let ((g-loc 'reg) ! 776: (g-cc nil) ! 777: (g-ret nil)) ! 778: (d-exp arg)) ! 779: 'r0)) ! 780: (setq sofar nil togo pat)) ! 781: ! 782: (if (and arg (symbolp arg)) then (setq keeptrack t)) ! 783: ! 784: ; if resloc is a global variable, we must move it into a register ! 785: ; right away to be able to do car's and cdr's ! 786: (if (and (dtpr resloc) (or (eq (car resloc) 'bind) ! 787: (eq (car resloc) 'vstack))) ! 788: then (d-move resloc 'reg) ! 789: (setq resloc 'r0)) ! 790: ! 791: ; now do car's and cdr's . Values are placed in r0. We stop when ! 792: ; we can get the result in one machine instruction. At that point ! 793: ; we see whether we want the value or just want to set the cc's. ! 794: ; If the intermediate value is in a register, ! 795: ; we can do : car cdr cddr cdar ! 796: ; If the intermediate value is on the local vrbl stack or lbind ! 797: ; we can do : cdr ! 798: (do ((curp togo newp) ! 799: (newp)) ! 800: ((null curp) (if g-loc then (d-movespec loc g-loc) ! 801: elseif g-cc then (e-tst loc)) ! 802: (d-handlecc)) ! 803: (if (symbolp resloc) ! 804: then (if (eq 'd (car curp)) ! 805: then (if (or (null (cdr curp)) ! 806: (eq 'a (cadr curp))) ! 807: then (setq newp (cdr curp) ; cdr ! 808: loc `(0 ,resloc) ! 809: sofar (append sofar (list 'd))) ! 810: else (setq newp (cddr curp) ; cddr ! 811: loc `(* 0 ,resloc) ! 812: sofar (append sofar ! 813: (list 'd 'd)))) ! 814: else (if (or (null (cdr curp)) ! 815: (eq 'a (cadr curp))) ! 816: then (setq newp (cdr curp) ; car ! 817: loc `(4 ,resloc) ! 818: sofar (append sofar (list 'a))) ! 819: else (setq newp (cddr curp) ; cdar ! 820: loc `(* 4 ,resloc) ! 821: sofar (append sofar ! 822: (list 'a 'd))))) ! 823: elseif (and (eq 'd (car curp)) ! 824: (not (eq '* (car (setq loc (e-cvt resloc)))))) ! 825: then (setq newp (cdr curp) ; (cdr <local>) ! 826: loc (cons '* loc) ! 827: sofar (append sofar (list 'd))) ! 828: else (setq loc (e-cvt resloc) ! 829: newp curp)) ! 830: (if newp ; if this is not the last move ! 831: then (setq resloc ! 832: (d-allocreg (if keeptrack then nil else 'r0))) ! 833: (d-movespec loc resloc) ! 834: (if keeptrack then (d-inreg resloc (cons arg sofar))))))) ! 835: ! 836: #+for-68k ! 837: (defun cc-cxxr (arg pat) ! 838: (prog (resloc loc qloc sofar togo keeptrack) ! 839: (makecomment '(starting cc-cxxr)) ! 840: ; check for the special case of nil, since car's and cdr's ! 841: ; are nil anyway ! 842: (if (null arg) ! 843: then (if g-loc then (d-move 'Nil g-loc)) ! 844: (if (cdr g-cc) then (e-goto (cdr g-cc))) ! 845: (return)) ! 846: (if (and (symbolp arg) (setq qloc (d-bestreg arg pat))) ! 847: then (setq resloc (car qloc) ! 848: loc resloc ! 849: sofar (cadr qloc) ! 850: togo (caddr qloc)) ! 851: else (setq resloc ! 852: (if (d-simple arg) thenret ! 853: else (d-clearreg 'a0) ! 854: (let ((g-loc 'areg) ! 855: (g-cc nil) ! 856: (g-ret nil)) ! 857: (d-exp arg)) ! 858: 'a0)) ! 859: (setq sofar nil togo pat)) ! 860: (if (and arg (symbolp arg)) then (setq keeptrack t)) ! 861: ; ! 862: ; if resloc is a global variable, we must move it into a register ! 863: ; right away to be able to do car's and cdr's ! 864: (if (and (dtpr resloc) (or (eq (car resloc) 'bind) ! 865: (eq (car resloc) 'vstack))) ! 866: then (d-move resloc 'areg) ! 867: (setq resloc 'a0)) ! 868: ; now do car's and cdr's . Values are placed in a0. We stop when ! 869: ; we can get the result in one machine instruction. At that point ! 870: ; we see whether we want the value or just want to set the cc's. ! 871: ; If the intermediate value is in a register, ! 872: ; we can do : car cdr cddr cdar ! 873: ; If the intermediate value is on the local vrbl stack or lbind ! 874: ; we can do : cdr ! 875: (do ((curp togo newp) ! 876: (newp)) ! 877: ((null curp) ! 878: (if g-loc then (d-movespec loc g-loc)) ! 879: ; ! 880: ;;;important: the below kludge is needed!! ! 881: ;;;consider the compilation of the following: ! 882: ; ! 883: ;;; (cond ((setq c (cdr c)) ...)) ! 884: ;;; the following instructions are generated: ! 885: ;;; movl a4@(N),a5 ; the setq ! 886: ;;; movl a5@,a4@(N) ! 887: ;;; movl a4@,a5 ; the last two are generated if g-cc ! 888: ;;; cmpl a5@,d7 ; is non-nil ! 889: ; ! 890: ;;; observe that the original value the is supposed to set ! 891: ;;; the cc's is clobered in the operation!! ! 892: ;(msg "g-loc: " (e-cvt g-loc) N "loc: " loc N) ! 893: (if g-cc ! 894: then (if (and (eq '* (car loc)) ! 895: (equal (caddr loc) (cadr (e-cvt g-loc)))) ! 896: then (e-cmpnil '(0 a5)) ! 897: else (e-cmpnil loc))) ! 898: (d-handlecc)) ! 899: (if (symbolp resloc) ! 900: then (if (eq 'd (car curp)) ! 901: then (if (or (null (cdr curp)) ! 902: (eq 'a (cadr curp))) ! 903: then (setq newp (cdr curp) ; cdr ! 904: loc `(0 ,resloc) ! 905: sofar (append sofar (list 'd))) ! 906: else (setq newp (cddr curp) ; cddr ! 907: loc `(* 0 ,resloc) ! 908: sofar (append sofar ! 909: (list 'd 'd)))) ! 910: else (if (or (null (cdr curp)) ! 911: (eq 'a (cadr curp))) ! 912: then (setq newp (cdr curp) ; car ! 913: loc `(4 ,resloc) ! 914: sofar (append sofar (list 'a))) ! 915: else (setq newp (cddr curp) ; cdar ! 916: loc `(* 4 ,resloc) ! 917: sofar (append sofar ! 918: (list 'a 'd))))) ! 919: elseif (and (eq 'd (car curp)) ! 920: (not (eq '* (car (setq loc (e-cvt resloc)))))) ! 921: then (setq newp (cdr curp) ; (cdr <local>) ! 922: loc (cons '* loc) ! 923: sofar (append sofar (list 'd))) ! 924: else (setq loc (e-cvt resloc) ! 925: newp curp)) ! 926: (if newp ; if this is not the last move ! 927: then (setq resloc ! 928: (d-alloc-register 'a ! 929: (if keeptrack then nil else 'a1))) ! 930: (d-movespec loc resloc) ! 931: ;(if keeptrack then (d-inreg resloc (cons arg sofar))) ! 932: )) ! 933: (makecomment '(done with cc-cxxr))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.