![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to complrb.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / liszt|
Return to complrb.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / liszt |
1.1 ! root 1: ;--- file: complrb.l ! 2: (include "compmacs.l") ! 3: ! 4: (setq compiler-name '"Lisp Compiler V3.0") ! 5: ! 6: (setq old-top-level (getd 'top-level)) ! 7: (setq original-readtable readtable) ! 8: (setq raw-readtable (makereadtable t)) ! 9: ! 10: ;--- lcfinit : called upon compiler startup. If there are any args ! 11: ; on the command line, we build up a call to lcf, which ! 12: ; will do the compile. Afterwards we exit. ! 13: ; ! 14: (def lcfinit ! 15: (lambda nil ! 16: (cond ((greaterp (argv -1) 1) ; build up list of args ! 17: (do ((i (sub1 (argv -1)) (sub1 i)) (arglis)) ! 18: ((lessp i 1) ! 19: (exit (apply 'liszt arglis))) ! 20: (setq arglis (cons (argv i) arglis)))) ! 21: (t (patom compiler-name) ! 22: (terpr poport) ! 23: (putd 'top-level old-top-level))))) ! 24: ! 25: (putd 'top-level (getd 'lcfinit)) ! 26: ! 27: ! 28: ! 29: ! 30: ;--- lcf - v-x : list containing file name to compile and optionaly ! 31: ; and output file name for the assembler source. ! 32: ; ! 33: (def liszt ! 34: (nlambda (v-x) ! 35: (prog (piport v-root v-ifile v-sfile v-ofile ! 36: vp-ifile vp-sfile vps-crap ! 37: vps-include ! 38: k-pid v-crap tmp rootreal ! 39: tem temr starttime startptime startgccount ! 40: fl-asm fl-warn fl-verb fl-inter) ! 41: ! 42: (setq starttime (syscall 13) ; real time in seconds ! 43: startptime (ptime) ! 44: startgccount $gccount$) ! 45: (setq k-lams (setq k-nlams (setq k-macros nil))) ! 46: (cond ((null (boundp 'internal-macros)) ! 47: (setq internal-macros nil))) ! 48: (cond ((null (boundp 'macros)) ! 49: (setq macros nil))) ! 50: (setq k-free nil) ! 51: (setq er-fatal 0) ! 52: (setq k-ptrs nil) ! 53: (setq k-disp -4) ! 54: (setq k-fnum 0) ; function number ! 55: (setq w-bind nil) ! 56: (setq vps-include nil) ! 57: (setq twa-list nil) ! 58: ! 59: (setq x-spec (gensym 'S)) ; flag for special atom ! 60: ; declare these special ! 61: (flag nil x-spec) ! 62: (flag t x-spec) ! 63: ! 64: (sstatus feature complr) ! 65: ! 66: ; process input form ! 67: (setq fl-asm t ; assembler file assembled ! 68: fl-warn t ; print warnings ! 69: fl-verb t ; be verbose ! 70: fl-macl nil ; compile maclisp file ! 71: fl-inter nil ; print intermediate forms ! 72: ) ! 73: ! 74: (do ((i v-x (cdr i))) ; for each argument ! 75: ((null i)) ! 76: (setq tem (aexplodec (car i))) ! 77: ! 78: (cond ((eq '- (car tem)) ; if switch ! 79: (do ((j (cdr tem) (cdr j))) ! 80: ((null j)) ! 81: (cond ((eq 'S (car j)) (setq fl-asm nil)) ! 82: ((eq 'm (car j)) (setq fl-macl t)) ! 83: ((eq 'o (car j)) (setq v-ofile (cadr i) ! 84: i (cdr i))) ! 85: ((eq 'w (car j)) (setq fl-warn t)) ! 86: ((eq 'q (car j)) (setq fl-verb nil)) ! 87: ((eq 'i (car j)) (setq fl-inter t)) ! 88: (t (comp-gerr "Unknown switch: " ! 89: (car j)))))) ! 90: ((null v-root) ! 91: (setq temr (reverse tem)) ! 92: (cond ((and (eq 'l (car temr)) ! 93: (eq '"." (cadr temr))) ! 94: (setq rootreal nil) ! 95: (setq v-root (apply 'concat (reverse (cddr temr))))) ! 96: (t (setq v-root (car i) ! 97: rootreal t)))) ! 98: ! 99: (t (comp-gerr "Extra input file name: " (car i))))) ! 100: ! 101: ! 102: ! 103: ; now see what the arguments have left us ! 104: ! 105: (cond ((null v-root) ! 106: (comp-gerr "No file for input")) ! 107: ((or (portp ! 108: (setq vp-ifile ! 109: (car (errset (infile ! 110: (setq v-ifile ! 111: (concat v-root '".l"))) ! 112: nil)))) ! 113: (and rootreal ! 114: (portp ! 115: (setq vp-ifile ! 116: (car (errset ! 117: (infile (setq v-ifile v-root)) ! 118: nil))))))) ! 119: (t (comp-gerr "Couldn't open the source file :" ! 120: (or v-ifile)))) ! 121: ! 122: ! 123: (setq k-pid (apply 'concat (cons 'F (cvt (syscall 20))))) ! 124: ; determine the name of the .s file ! 125: ; strategy: if fl-asm is t (only assemble) use (v-root).s ! 126: ; else use /tmp/(k-pid).s ! 127: ; ! 128: (cond (fl-asm (setq v-sfile (concat '"/tmp/" ! 129: k-pid ! 130: '".s"))) ! 131: (t (setq v-sfile (concat v-root '".s")))) ! 132: ! 133: (cond ((not (portp (setq vp-sfile ! 134: (car (errset (outfile v-sfile) ! 135: nil))))) ! 136: (comp-gerr "Couldn't open the .s file: " ! 137: (or v-sfile)))) ! 138: ! 139: ! 140: ; determine the name of the .o file (object file) ! 141: ; strategy: if we aren't supposed to assemble the .s file ! 142: ; don't worry about a name ! 143: ; else if a name is given, use it ! 144: ; else if use (v-root).o ! 145: (cond ((or v-ofile (null fl-asm))) ;ignore ! 146: (t (setq v-ofile (concat v-root '".o")))) ! 147: ! 148: (cond ((checkfatal) (return 1))) ! 149: ! 150: (setq readtable (makereadtable nil)) ; use new readtable ! 151: ! 152: ! 153: ; make i/o descriptors to point to crap file then ! 154: ; unlink crap file so if we die while compiling the crap ! 155: ; file will disappear ! 156: (setq v-crap (concat k-pid k-fnum 'crap)) ! 157: (setq tmp (outfile v-crap)) ; create output first ! 158: (setq vps-crap (cons (infile v-crap) tmp)) ! 159: (apply 'syscall `(10 ',v-crap)) ; unlink it ! 160: ! 161: (emit1 `(".." ,k-pid ,k-fnum :)) ! 162: (emit1 '".long linker") ! 163: (emit1 '".long BINDER") ! 164: ! 165: ; if the macsyma flag is set, change the syntax to the ! 166: ; maclisp standard syntax. We must be careful that we ! 167: ; dont clobber any syntax changes made by files preloaded ! 168: ; into the compiler. ! 169: ! 170: (cond (fl-macl (setsyntax '\/ 143) ; 143 = vesc ! 171: ! 172: (cond ((equal 143 (status syntax \\)) ! 173: (setsyntax '\\ 2))) ! 174: ! 175: (setsyntax '\| 138) ; 138 = vdq ! 176: (cond ((equal 138 (status syntax \")) ! 177: (setsyntax '\" 2))) ! 178: (cond ((equal 198 (status syntax \[)) ! 179: (setsyntax '\[ 2) ! 180: (setsyntax '\] 2))) ! 181: (setq ibase 8.) ! 182: (sstatus uctolc t) ! 183: ! 184: (flag 'ibase x-spec) ; to be special ! 185: (flag 'base x-spec) ! 186: (flag 'tty x-spec) ! 187: ! 188: (errset (cond ((null (getd 'macsyma-env)) ! 189: (load 'machacks))) ! 190: nil))) ! 191: ! 192: (cond ((checkfatal) (return 1))) ; leave if fatal errors ! 193: ! 194: (comp-note "Compilation begins with " (or compiler-name)) ! 195: (comp-note "source: " (or v-ifile) ", result: " ! 196: (cond (fl-asm v-ofile) (t v-sfile))) ! 197: (setq piport vp-ifile) ; set to standard input ! 198: ! 199: loop ! 200: ;(cond ((atom (errset (do ((i (read) (read))) ! 201: ; ((eq i 'eof) nil) ! 202: ; (cleanup) ! 203: ; (lcfform i)))) ! 204: ; (patom '"error during compilation, I quit"))) ! 205: ! 206: (cond ((atom (errset ! 207: (do ((i (read piport '<<end-of-file>>) ! 208: (read piport '<<end-of-file>>))) ! 209: ((eq i '<<end-of-file>>) nil) ! 210: (cleanup) ! 211: (catch (lcfform i) Comp-error)))) ! 212: (comp-note "Lisp error during compilation") ! 213: (setq piport nil) ! 214: (setq er-fatal (add1 er-fatal)) ! 215: (return 1))) ! 216: ! 217: (close piport) ! 218: ! 219: (cond ((checkfatal) (return 1))) ! 220: ! 221: ; if doing special character stuff (maclisp) reassert ! 222: ; the state ! 223: ! 224: (cond (vps-include ! 225: (comp-note " done include") ! 226: (setq piport (car vps-include)) ! 227: (setq vps-include (cdr vps-include)) ! 228: (go loop))) ! 229: ! 230: ; reset input base ! 231: (setq ibase 10.) ! 232: ! 233: ! 234: (close (cdr vps-crap)) ! 235: ! 236: (setq vp-ifile (car vps-crap)) ; read crap file ! 237: ! 238: ((lambda (readtable) ! 239: (do ((i (read vp-ifile '<<end-of-file>>) ! 240: (read vp-ifile '<<end-of-file>>))) ! 241: ((eq i '<<end-of-file>>) nil) ! 242: (setq w-bind (cons (list 0 i 'Crap) w-bind))) ! 243: ! 244: (cm-alist)) ! 245: raw-readtable) ! 246: ! 247: (close vp-sfile) ; close assembler language file ! 248: (comp-note "Compilation complete") ! 249: ! 250: (setq tem (Divide (difference (syscall 13) starttime) 60)) ! 251: (comp-note " Real time: " (car tem) " minutes, " ! 252: (cadr tem) " seconds") ! 253: (setq tem (ptime)) ! 254: (setq temr (Divide (difference (car tem) (car startptime)) ! 255: 3600)) ! 256: (comp-note " CPU time: " (car temr) " minutes, " ! 257: (quotient (cadr temr) 60.0) " seconds") ! 258: (setq temr (Divide (difference (cadr tem) (cadr startptime)) ! 259: 3600)) ! 260: (comp-note " of which " (car temr) " minutes and " ! 261: (quotient (cadr temr) 60.0) ! 262: " seconds were for the " ! 263: (difference $gccount$ startgccount) ! 264: " gcs which were done") ! 265: ! 266: ! 267: (cond (fl-asm ; assemble file ! 268: (comp-note "Assembly begins") ! 269: (cond ((not ! 270: (zerop ! 271: (setq tmp ! 272: (apply 'process ! 273: (ncons (concat '"as -o " ! 274: v-ofile ! 275: '" " ! 276: v-sfile)))))) ! 277: (comp-gerr "Assembler detected error, code: " ! 278: (or tmp))) ! 279: (t (comp-note "Assembly completed successfully"))))) ! 280: (cond (fl-asm (apply 'syscall `(10 ',v-sfile)))) ! 281: ! 282: (setq readtable original-readtable) ! 283: (return 0)))) ! 284: ! 285: (def checkfatal ! 286: (lambda nil ! 287: (cond ((greaterp er-fatal 0) ! 288: (comp-note "Compilation aborted") ! 289: t)))) ! 290: ! 291: ! 292: ;--- lcfform - i : form to compile ! 293: ; This compiles one form. ! 294: ; ! 295: (def lcfform ! 296: (lambda (i) ! 297: (prog (tmp v-x) ! 298: ; macro expand ! 299: (setq i (cmacroexpand i)) ! 300: ; now look at what is left ! 301: (cond ((eq (car i) 'def) ; jkf mod ! 302: (cond (fl-verb (print (cadr i)) (terpr)(drain))) ! 303: (dodef i)) ! 304: ((eq (car i) 'declare) (dodcl i)) ! 305: ((eq (car i) 'eval-when) (doevalwhen i)) ! 306: ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile))) ! 307: ((lambda (internal-macros) ; compile macros too ! 308: (mapc 'lcfform (cddr i))) ! 309: t)) ! 310: ((or (eq (car i) '"%include") ! 311: (eq (car i) '"include")) ! 312: (cond ((or (portp (setq v-x ! 313: (car (errset (infile (cadr i)) nil)))) ! 314: (portp (setq v-x ! 315: (car (errset (infile (concat '"/usr/lib/lisp" ! 316: (cadr i))) ! 317: nil))))) ! 318: (setq vps-include (cons piport vps-include)) ! 319: (setq piport v-x) ! 320: (comp-note " INCLUDEing file: " (cadr i))) ! 321: (t (comp-gerr "Cannot open include file: " (cadr i))))) ! 322: (t ((lambda (readtable) ! 323: (print i (cdr vps-crap)) ! 324: (terpr (cdr vps-crap))) ! 325: raw-readtable)))))) ! 326: ! 327: ;--- cmacroexpand - i : functional form ! 328: ; the form is macro expanded on the top level as many times as ! 329: ; possible. ! 330: ; ! 331: (def cmacroexpand ! 332: (lambda (i) ! 333: (cond ((atom i) i) ! 334: (t (do ((j (ismacro (car i)) (ismacro (car i))) ! 335: (tmp)) ! 336: ((null j) i) ! 337: (cond ((bcdp j) ! 338: (putd (setq tmp (Gensym nil)) ! 339: (mfunction (getentry j) 'nlambda))) ! 340: (t (setq tmp (cons 'nlambda (cdr j))))) ! 341: (setq i (apply tmp i)) ! 342: (cond ((atom i) (return i)))))))) ! 343: ! 344: (def dodef ! 345: (lambda (v-f) ! 346: (prog (v-n v-t v-c w-save w-ret w-labs w-locs) ! 347: (setq k-current (setq v-n (cadr v-f))) ; v-n <= name of func ! 348: ; add function to approp. list ! 349: (cond ((or (eq (setq v-t (caaddr v-f)) 'lambda) ! 350: (eq v-t 'lexpr)) ! 351: (setq k-lams (cons (list v-n t) k-lams) ! 352: k-ftype v-t ! 353: v-t 'lambda)) ! 354: ((eq v-t 'nlambda) ! 355: (setq k-nlams (cons (list v-n t) k-nlams) ! 356: k-ftype 'nlambda)) ! 357: ((eq v-t 'macro) ! 358: (setq k-macros (cons (list v-n (caddr v-f)) k-macros)) ! 359: (setq k-ftype 'macro) ! 360: (eval v-f) ! 361: ; if macros is nil, we do not compile this macro ! 362: (cond ((and (null macros) ! 363: (null internal-macros)) ! 364: (return nil)))) ! 365: (t (comp-err (or v-n) " has an unknown function type" ! 366: (v-f)))) ! 367: ! 368: ! 369: (setq v-c (concat k-pid k-fnum)) ; v-c <= unique name ! 370: (setq k-fnum (add1 k-fnum)) ! 371: (cm-bind v-c v-n v-t) ; update k-regs ! 372: (setq v-t (f-func (cdaddr v-f))) ; do parse ! 373: (emit3 '# v-c v-n) ; put out header ! 374: (cm-alst4 v-n) ! 375: (cond (fl-inter (print v-t)(terpr))) ! 376: (cm-emit v-t v-c)))) ; emit code ! 377: ! 378: ;--- doevalwhen, process evalwhen directive. This is inadequate. ! 379: ; ! 380: (def doevalwhen ! 381: (lambda (v-f) ! 382: (prog (docom dolod) ! 383: (setq docom (member 'compile (cadr v-f)) ! 384: ! 385: dolod (member 'load (cadr v-f))) ! 386: (mapc '(lambda (frm) (cond (docom (eval frm))) ! 387: (cond (dolod ! 388: ((lambda (internal-macros) ! 389: (lcfform frm)) ! 390: t)))) ! 391: (cddr v-f))))) ! 392: ! 393: ! 394: ;---- dodcl - v-f declare form ! 395: ; process the declare form given. We evaluate each arg ! 396: ; ! 397: (def dodcl ! 398: (lambda (v-f) ! 399: (setq v-f (cdr v-f)) ! 400: (do ((i (car v-f) (car v-f))) ! 401: ((null i)) ! 402: (setq v-f (cdr v-f)) ! 403: (cond ((getd (car i)) (eval i)) ; if this is a function ! 404: (t (comp-warn "Unknown declare attribute: " (car i))))))) ! 405: ! 406: ;---> handlers for declare forms ! 407: ; ! 408: (def *fexpr ! 409: (nlambda (args) ! 410: (mapc '(lambda (v-x) ! 411: (setq k-nlams (cons (list v-x t) k-nlams))) ! 412: args))) ! 413: (def special ! 414: (nlambda (v-l) ! 415: (mapc '(lambda (v-a) ! 416: (unflag v-a x-con) ! 417: (flag v-a x-spec)) ! 418: v-l) ! 419: t)) ! 420: (def unspecial ! 421: (nlambda (v-l) ! 422: (mapc '(lambda (v-a) ! 423: (unflag v-a x-spec)) ! 424: v-l) ! 425: t)) ! 426: ! 427: (def *expr (nlambda (args) nil)) ; ignore ! 428: ! 429: (def macros (nlambda (args) (setq macros (car args)))) ! 430: ;---> end declare form handlers ! 431: ! 432: ! 433: (def cm-bind ! 434: (lambda (v-lab v-atm v-type) ! 435: (setq w-bind (cons (list v-lab v-atm v-type) w-bind)))) ! 436: ! 437: (def cm-emit ! 438: (lambda (v-t v-nm) ! 439: (setq k-back (setq k-regs nil)) ! 440: (setq k-code v-t) ! 441: (prog (v-i v-l) ! 442: (emit2 '".globl" v-nm) ! 443: (emit1 (list v-nm ':)) ! 444: next (cond ((null k-code) (return))) ! 445: (setq v-i (car k-code)) ! 446: (setq k-code (cdr k-code)) ! 447: (setq v-l (get (car v-i) x-emit)) ! 448: (cond ((null (cdr v-i)) ! 449: (funcall v-l) ! 450: (go next)) ! 451: ((ifflag (car v-i) x-asg) ! 452: (setq v-t (e-reg (cadr v-i) nil))) ! 453: (t (setq v-t (cadr v-i)))) ! 454: (apply v-l (rplaca (cdr v-i) v-t)) ! 455: (go next)))) ! 456: ! 457: ;--- cm-alist - print out the list of special lispvalues we reference ! 458: ; in compiled code ! 459: ; ! 460: ! 461: (def cm-alist ! 462: (lambda nil ! 463: (prog (cm-alv) ! 464: (cond (faslflag (emit1 '".text")) ! 465: (t (emit1 '".data"))) ! 466: (emit1 '".align 2") ! 467: (emit1 '"lbnp: .long _bnp") ! 468: (emit1 '"lfun: .long __qfuncl") ! 469: (emit1 '"lf4: .long __qf4") ! 470: (emit1 '"lf3: .long __qf3") ! 471: (emit1 '"lf2: .long __qf2") ! 472: (emit1 '"lf1: .long __qf1") ! 473: (emit1 '"lf0: .long __qf0") ! 474: (emit2 '"lgc: .long" 0) ! 475: (emit1 '"linker:" ) ! 476: (mapc 'cm-alst1 (reverse k-ptrs)) ! 477: (emit2 '".long" -1) ! 478: (cond (faslflag (emit1 '".data")) ! 479: (t (emit1 '".text"))) ! 480: (emit1 '".align 2") ! 481: (emit1 '"B:") ! 482: (emit1 '"BINDER:") ! 483: (mapc 'cm-alst2 (reverse w-bind)) ! 484: (emit4 '".long" -1 -1 -1) ! 485: (emit1 '"litstrt:") ! 486: (mapc 'cm-alst3 (reverse cm-alv)) ! 487: (emit1 '"litend:") ! 488: (cleanup)))) ! 489: ! 490: ! 491: (def cm-alst1 ! 492: (lambda (v-x) ! 493: (prog (v-g) ! 494: (setq v-g (Gensym 's)) ! 495: (emit2 '".long" (list v-g '-B)) ! 496: (putprop v-g (car v-x) 'label) ! 497: (setq cm-alv (cons v-g cm-alv))))) ! 498: ! 499: (def cm-alst2 ! 500: (lambda (v-x) ! 501: (prog (v-g) ! 502: (emit2 '".long" (car v-x)) ! 503: (setq v-g (Gensym 's)) ! 504: (emit2 '".long" (list v-g '-B)) ! 505: (putprop v-g (cadr v-x) 'label) ! 506: (setq cm-alv (cons v-g cm-alv)) ! 507: (setq v-g (caddr v-x)) ! 508: (emit2 '".long" ! 509: (cond ((eq v-g 'lambda) 0) ! 510: ((eq v-g 'nlambda) 1) ! 511: ((eq v-g 'macro) 2) ! 512: ((eq v-g 'Crap) 99) ! 513: (t 'UDEF_TYPE)))))) ! 514: ! 515: (def cm-alst3 ! 516: (lambda (v-x) ! 517: ($pr$ v-x) ! 518: ($pr$ '": ") ! 519: (setq v-x (get v-x 'label)) ! 520: (cm-alst4 v-x))) ! 521: ! 522: ;--- cm-alst4 - v-x : s-expression ! 523: ; the given expression is exploded and printed as a string to the ! 524: ; assembler, this requires that each character be individually ! 525: ; noted and that the number of bytes on a line be limited. ! 526: ; ! 527: (def cm-alst4 ! 528: (lambda (v-x) ! 529: ($pr$ '".byte ") ! 530: (do ((l (explode v-x) (cdr l)) ! 531: (cnt 1 (add1 cnt))) ! 532: ((null l) ($pr$ 0) ($terpri)) ! 533: ($pr$ '\') ! 534: ($pr$ (car l)) ! 535: (cond ((greaterp cnt 13) ($terpri) ($pr$ '".byte ") (setq cnt 0)) ! 536: (t ($pr$ '\,)))))) ! 537: ;--- w-save ! 538: ; stack the values of w-ret and w-labs ! 539: ; ! 540: (def w-save ! 541: (lambda nil (setq w-save (cons `(,w-ret ,w-labs ,w-locs) w-save)))) ! 542: ! 543: ;--- w-unsave ! 544: ; restore the values of w-ret and w-labs, popping them ! 545: ; off the w-save stack ! 546: ; ! 547: (def w-unsave ! 548: (lambda nil (setq w-ret (caar w-save) ! 549: w-labs (cadar w-save) ! 550: w-locs (caddar w-save) ! 551: w-save (cdr w-save)))) ! 552: ! 553: ! 554: ;--- f-exp - v-e form to evaluate ! 555: ; - v-r location to place result in. ! 556: ; - v-t restof stuff (intermidiate forms) ! 557: ; ! 558: ; This is the real workhorse of the compiler. ! 559: ; ! 560: (def f-exp ! 561: (lambda (v-e v-r v-t) ! 562: (prog (v-f v-i v-tem) ! 563: begin (cond ; atoms ! 564: ((f-one v-e) ! 565: ; if the symbol has not been declared special and is ! 566: ; not a local variable, we declare it special. ! 567: (g-specialchk v-e) ! 568: (return (f-addi (list 'get v-r v-e) v-t))) ! 569: ! 570: ; lambda expressions, we do the correct thing. ! 571: ; should check for bad forms here rather than call ! 572: ; f-chkf ! 573: ((not (atom (setq v-f (car v-e)))) ! 574: (setq v-f (cmacroexpand v-f)) ! 575: ; must check if the expression changes to an atom ! 576: (cond ((atom v-f) ! 577: (setq v-e (cons v-f (cdr v-e))) ! 578: (go begin))) ! 579: ! 580: (cond ((eq 'lambda (car v-f)) ! 581: (return (f-lambexp v-e v-r v-t))) ! 582: ; this case is necessary to compile ! 583: ; ('add 1 2) which the interpreter will ! 584: ; handle and I guess we should too ! 585: ((eq 'quote (car v-f)) ! 586: (comp-warn "Bizzare function name " (or v-f) N) ! 587: (setq v-e (cons (cadr v-f) (cdr v-e))) ! 588: (go begin)) ! 589: (t (comp-err " Illegal expression: " ! 590: (or v-f) ! 591: N)))) ! 592: ! 593: ; macro expand and continue ! 594: ((and (or (setq v-e (cmacroexpand v-e)) t) ! 595: (cond ((or (atom v-e) ! 596: (not (atom (car v-e)))) ! 597: (go begin)) ; if reduce to atom ! 598: ; or lambda exp ! 599: (t (setq v-f (car v-e)))) ! 600: nil)) ! 601: ! 602: ; special functions ! 603: ((setq v-i (get v-f x-spf)) (go special)) ! 604: ((setq v-i (get v-f x-spfq)) ! 605: (put v-f x-spfq nil) ! 606: (go special)) ! 607: ((setq v-i (get v-f x-spfn)) (go special)) ! 608: ((setq v-i (get v-f x-spfh)) ! 609: (setq v-e (funcall v-i v-e)) ! 610: (go normal)) ! 611: ! 612: ; macro within compiler ! 613: ((setq v-i (get v-f 'x-spfm)) ! 614: (setq v-e (funcall v-i v-e)) ! 615: (go begin)) ! 616: ! 617: ; nlambbdas, we quote the args ! 618: ((isnlam v-f) ! 619: (setq v-e (list v-f (list 'quote (cdr v-e)))) ! 620: (go normal)) ! 621: ! 622: ! 623: ; cxr form where x is elt of {a d} ! 624: ((setq v-i (chain v-f)) ! 625: (setq v-t (f-addi ! 626: (list 'chain ! 627: v-r ! 628: (setq v-r (f-use (Gensym nil))) ! 629: v-i) ! 630: v-t)) ! 631: (setq v-e (cadr v-e)) ; calc expr to new v-r ! 632: (go begin)) ! 633: ! 634: ; if this is not the last form before a return, ! 635: ; we go to normal to do a function invocation ! 636: ; otherwise we look to see if tail merging is ! 637: ; possible. ! 638: ((not (eq (caar v-t) 'return)) (go normal)) ! 639: ((or (eq (setq v-i w-bv) t) ! 640: (not (equal v-f w-name))) (go normal)) ! 641: ((not (f-iter (cdr v-e) (reverse v-i))) (go normal)) ) ! 642: ! 643: ; do tail merging. ! 644: (setq v-t (f-addi '(repeat) v-t)) ! 645: (setq v-e (reverse (cdr v-e))) ! 646: iterate (cond ((null v-e) (return v-t)) ! 647: ((equal (car v-e) (car v-i)) (go next))) ! 648: (setq v-t (f-addi (list 'set ! 649: (setq v-r (f-reg 'set)) ! 650: (car v-i)) ! 651: v-t)) ! 652: (setq v-t (f-exp (car v-e) v-r v-t)) ! 653: next (setq v-e (cdr v-e)) ! 654: (setq v-i (cdr v-i)) ! 655: (go iterate) ! 656: ! 657: ; the function will be handled specially by the compiler ! 658: special (cond ((setq v-i (funcall v-i (cdr v-e) v-r v-t)) ! 659: (return v-i))) ! 660: ! 661: ; normal handling, call function. ! 662: ; if this is a system function, do it quickly ! 663: normal (cond ((setq v-i (get (car v-e) 'x-sysf)) ; system fcn ! 664: (setq v-t ! 665: (f-pusha (cdr v-e) ! 666: (Gensym nil) ! 667: (f-addi `(call ,(f-make v-r r-xv) ! 668: ,v-i ! 669: ,(length (cdr v-e))) ! 670: v-t)))) ! 671: (t (setq v-t ! 672: (f-pusha `((quote ,(car v-e)) ,@(cdr v-e)) ! 673: (Gensym nil) ! 674: (f-addi `(call ,(f-make v-r r-xv) ! 675: nil ! 676: ,(length v-e)) ! 677: v-t))))) ! 678: ! 679: (return v-t)))) ! 680: ! 681: ;--- g-specialchk - v-e : expression ! 682: ; if v-e is a symbol and not declared special and not a local variable ! 683: ; we complain and delare it special ! 684: ; v-e is returned. ! 685: ; ! 686: (def g-specialchk ! 687: (lambda (v-e) ! 688: (cond ((and (symbolp v-e) ! 689: (not (get v-e x-spec)) ! 690: (not (member v-e w-locs))) ! 691: (flag v-e x-spec) ! 692: (comp-warn (or v-e) " declared special by compiler"))) ! 693: v-e)) ! 694: ! 695: ! 696: ;--- f-lambexp - v-e : lambda expression: ((lambda (x y z) exp) a b c) ! 697: ; - v-r : weather where result should be placed ! 698: ; - v-t : tail ! 699: ; ! 700: ; This compiled a lambda expression. This is a very simple do-expression ! 701: ; with the difference that returns are not allowed from within it. ! 702: ! 703: (def f-lambexp ! 704: (lambda (v-e v-r v-t) ! 705: (f-pusha (cdr v-e) ! 706: (Gensym nil) ! 707: (f-lambbody (cdar v-e) v-r (length (cadar v-e)) v-t)))) ! 708: ! 709: ;--- f-lambbody - v-e : args + body of lambda ((a b c) exp1 exp2 ...) ! 710: ; - v-ags : number of args pushed for this lambda, it will ! 711: ; normally equal the length of (cadr v-e) but ! 712: ; in the case of the top level lambda expression ! 713: ; in a function it will be 0 ! 714: ; - v-r : psreg to place result in ! 715: ; - v-t : tail ! 716: ; We emit the intermediate expressions necessary to evaluate the ! 717: ; lambda body ! 718: ; ! 719: (def f-lambbody ! 720: (lambda (v-e v-r v-ags v-t) ! 721: (w-save) ; stack old values ! 722: (prog (w-ret w-labs tmp) ! 723: (setq tmp `((begin ,v-ags) ! 724: ,@(mapcar '(lambda (arg) (setq w-locs ! 725: (cons arg w-locs)) ! 726: `(bind ,arg)) ! 727: (car v-e)) ! 728: ,@(f-seq (cdr v-e) ! 729: v-r ! 730: `((end nil) ! 731: ,@v-t)))) ! 732: (w-unsave) ! 733: (return tmp)))) ! 734: ! 735: ;--- f-func - v-l : function args and body. ! 736: ; ! 737: ; result is: (entry type) ; type is lambda,lexpr, macro ! 738: ; or nlambda ! 739: ; ..body.. ! 740: ; ! 741: ; (fini) ! 742: ; ! 743: (def f-func ! 744: (lambda (v-l) ! 745: `((entry ,k-ftype) ! 746: ,@(f-lambbody v-l 'xv 0 '((fini)))))) ! 747: ! 748: ! 749: ;--- f-prog - v-l : args + prog body ! 750: ; - v-r : psreg to store result in ! 751: ; - v-t : tail ! 752: ; ! 753: (def f-prog ! 754: (lambda (v-l v-r v-t) ! 755: (w-save) ! 756: (prog (w-ret tmp retlb w-labs) ! 757: (setq tmp (length (car v-l)) ; number of locals ! 758: retlb (Gensym nil) ; label to leave prog ! 759: w-labs (Gensym nil) ; hang labels here ! 760: w-ret `(,v-r . (go ,retlb))) ! 761: ! 762: (setq tmp `((pushnil ,tmp) ; start out with nils ! 763: (begin ,tmp) ; declare variables ! 764: ,@(mapcar '(lambda (arg) (setq w-locs ! 765: (cons arg w-locs)) ! 766: `(bind ,arg)) ! 767: (car v-l)) ; bind locals ! 768: ,@(f-seqp (cdr v-l) (Gensym nil) ! 769: `((get ,v-r nil) ! 770: (end ,retlb) ! 771: ,@v-t)))) ! 772: (w-unsave) ! 773: (return tmp)))) ! 774: ! 775:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.