![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to car.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / liszt|
Return to car.l CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / liszt |
1.1 ! root 1: ; l i s z t v 4 ! 2: ; ! 3: ; ! 4: ; ! 5: ; A compiler for Franz lisp ! 6: ; ! 7: ; Copyright (c) 1980 , The Regents of the University of California. ! 8: ; All rights reserved. ! 9: ; author: j. foderaro ! 10: ; ! 11: ; Section INIT -- initialization and macros ! 12: ! 13: (include "caspecs.l") ! 14: ! 15: (eval-when (compile eval) ! 16: (cond ((not (getd 'If)) ! 17: (fasl 'camacs)))) ! 18: ! 19: ;the version number is maintained by hand, and is written twice ! 20: ; once for the benefit of the user ! 21: (setq compiler-name "Lisp Compiler 5.0") ! 22: ; and the other time for SCCS's what command ! 23: (setq sccs-compiler-name "@(#)Liszt version 5.0") ! 24: ! 25: (setq sectioncarid "@(#)car.l 5.4 11/11/80") ; id for SCCS ! 26: ! 27: (setq original-readtable readtable) ! 28: (setq raw-readtable (makereadtable t)) ! 29: ! 30: ;--- special handlers ! 31: (putprop 'and 'cc-and 'fl-exprcc) ! 32: (putprop 'arg 'cc-arg 'fl-exprcc) ! 33: (putprop 'atom 'cc-atom 'fl-exprcc) ! 34: (putprop 'bigp 'cc-bigp 'fl-exprcc) ! 35: (putprop 'bcdp 'cc-bcdp 'fl-exprcc) ! 36: (putprop '*catch 'c-*catch 'fl-expr) ! 37: (putprop 'comment 'cc-ignore 'fl-exprcc) ! 38: (putprop 'cond 'c-cond 'fl-expr) ! 39: (putprop 'cons 'c-cons 'fl-expr) ! 40: (putprop 'cxr 'c-cxr 'fl-exprcc) ! 41: (putprop 'declare 'c-declare 'fl-expr) ! 42: (putprop 'do 'c-do 'fl-expr) ! 43: (putprop 'dtpr 'cc-dtpr 'fl-exprcc) ! 44: (putprop 'eq 'cc-eq 'fl-exprcc) ! 45: (putprop 'equal 'cc-equal 'fl-exprcc) ! 46: (putprop '= 'cc-equal 'fl-exprcc) ! 47: (putprop 'errset 'c-errset 'fl-expr) ! 48: (putprop 'fixp 'cc-fixp 'fl-exprcc) ! 49: (putprop 'floatp 'cc-floatp 'fl-exprcc) ! 50: (putprop 'get 'c-get 'fl-expr) ! 51: (putprop 'go 'c-go 'fl-expr) ! 52: (putprop 'list 'c-list 'fl-expr) ! 53: (putprop 'map 'cm-map 'fl-exprm) ! 54: (putprop 'mapc 'cm-mapc 'fl-exprm) ! 55: (putprop 'mapcan 'cm-mapcan 'fl-exprm) ! 56: (putprop 'mapcar 'cm-mapcar 'fl-exprm) ! 57: (putprop 'mapcon 'cm-mapcon 'fl-exprm) ! 58: (putprop 'maplist 'cm-maplist 'fl-exprm) ! 59: (putprop 'memq 'cc-memq 'fl-exprcc) ! 60: (putprop 'not 'cc-not 'fl-exprcc) ! 61: (putprop 'null 'cc-not 'fl-exprcc) ! 62: (putprop 'numberp 'cc-numberp 'fl-exprcc) ! 63: (putprop 'or 'cc-or 'fl-exprcc) ! 64: (putprop 'prog 'c-prog 'fl-expr) ! 65: (putprop 'progn 'cm-progn 'fl-exprm) ! 66: (putprop 'prog1 'cm-prog1 'fl-exprm) ! 67: (putprop 'prog2 'cm-prog2 'fl-exprm) ! 68: (putprop 'quote 'cc-quote 'fl-exprcc) ! 69: (putprop 'return 'c-return 'fl-expr) ! 70: (putprop 'rplaca 'c-rplaca 'fl-expr) ! 71: (putprop 'rplacd 'c-rplacd 'fl-expr) ! 72: (putprop 'setarg 'c-setarg 'fl-expr) ! 73: (putprop 'setq 'cc-setq 'fl-exprcc) ! 74: (putprop 'stringp 'cc-stringp 'fl-exprcc) ! 75: (putprop 'symbolp 'cc-symbolp 'fl-exprcc) ! 76: (putprop 'symeval 'cm-symeval 'fl-exprm) ! 77: (putprop '*throw 'c-*throw 'fl-expr) ! 78: (putprop 'typep 'cc-typep 'fl-exprcc) ! 79: (putprop 'zerop 'cm-zerop 'fl-exprm) ! 80: ! 81: (putprop '1+ 'c-1+ 'fl-expr) ! 82: (putprop '1- 'c-1- 'fl-expr) ! 83: (putprop '+ 'c-+ 'fl-expr) ! 84: (putprop '- 'c-- 'fl-expr) ! 85: (putprop '* 'c-* 'fl-expr) ! 86: (putprop '/ 'c-/ 'fl-expr) ! 87: (putprop '\\ 'c-\\ 'fl-expr) ! 88: ! 89: ! 90: ! 91: ! 92: ; Section INTERF -- user interface ! 93: ! 94: ! 95: ;--- lisztinit : called upon compiler startup. If there are any args ! 96: ; on the command line, we build up a call to lcf, which ! 97: ; will do the compile. Afterwards we exit. ! 98: ; ! 99: (def lisztinit ! 100: (lambda nil ! 101: (cond ((greaterp (argv -1) 1) ; build up list of args ! 102: (do ((i (1- (argv -1)) (1- i)) (arglis)) ! 103: ((lessp i 1) ! 104: (setq user-top-level nil) ! 105: (exit (apply 'liszt arglis))) ! 106: (setq arglis (cons (argv i) arglis)))) ! 107: (t (patom compiler-name) ! 108: (terpr poport) ! 109: (setq user-top-level nil))))) ! 110: ! 111: (setq user-top-level 'lisztinit) ! 112: ! 113: ! 114: ! 115: ;--- lcf - v-x : list containing file name to compile and optionaly ! 116: ; and output file name for the assembler source. ! 117: ; ! 118: (def liszt ! 119: (nlambda (v-x) ! 120: (prog (piport v-root v-ifile v-sfile v-ofile ! 121: vp-ifile vp-sfile vps-crap ! 122: vps-include ! 123: tmp rootreal ! 124: g-fname ! 125: tem temr starttime startptime startgccount ! 126: fl-asm fl-warn fl-verb fl-inter fl-xref fl-uci ! 127: g-skipcode g-dropnpcnt) ! 128: ! 129: ; turn on monitoring if it exists ! 130: #+monitoring ! 131: (errset (progn (monitor t) ; turn it on ! 132: (print 'monitor-on) ! 133: (terpr)) ! 134: nil) ! 135: (setq starttime (syscall 13) ; real time in seconds ! 136: startptime (ptime) ! 137: startgccount $gccount$) ! 138: (cond ((null (boundp 'internal-macros)) ! 139: (setq internal-macros nil))) ! 140: (cond ((null (boundp 'macros)) ! 141: (setq macros nil))) ! 142: (setq er-fatal 0) ! 143: (setq vps-include nil) ! 144: (setq twa-list nil) ! 145: (setq liszt-eof-forms nil) ! 146: ! 147: ; set up once only g variables ! 148: (setq g-comments nil ! 149: g-current nil ; current function name ! 150: g-funcs nil ! 151: g-lits nil ! 152: g-trueloc nil ! 153: g-tran nil ! 154: g-allf nil ; used in xrefs ! 155: g-reguse '((r5 0 . nil) (r4 0 . nil) (r3 0 . nil) ! 156: (r2 0 . nil) (r7 0 . nil) (r1 0 . nil)) ! 157: g-trancnt 0 ! 158: g-ignorereg nil ! 159: g-litcnt 0) ! 160: (setq g-spec (gensym 'S)) ; flag for special atom ! 161: (setq special nil) ; t if all vrbs are special ! 162: (setq g-functype (gensym) ! 163: g-bindloc (gensym) ! 164: g-localf (gensym) ! 165: g-tranloc (gensym)) ! 166: ! 167: ; declare these special ! 168: ! 169: (sstatus feature complr) ! 170: (d-makespec 't) ; always special ! 171: ! 172: ; process input form ! 173: (setq fl-asm t ; assembler file assembled ! 174: fl-warn t ; print warnings ! 175: fl-verb t ; be verbose ! 176: fl-macl nil ; compile maclisp file ! 177: fl-inter nil ; do interlisp compatablity ! 178: fl-tty nil ; put .s on tty ! 179: fl-comments nil ; put in comments ! 180: fl-profile nil ; profiling ! 181: fl-tran t ; use transfer tables ! 182: fl-vms nil ; vms hacks ! 183: fl-xref nil ; xrefs ! 184: fl-uci nil ; uci lisp compatibility ! 185: ) ! 186: ! 187: (do ((i v-x (cdr i))) ; for each argument ! 188: ((null i)) ! 189: (setq tem (aexplodec (car i))) ! 190: ! 191: (cond ((eq '- (car tem)) ; if switch ! 192: (do ((j (cdr tem) (cdr j))) ! 193: ((null j)) ! 194: (cond ((eq 'S (car j)) (setq fl-asm nil)) ! 195: ((eq 'C (car j)) (setq fl-comments t)) ! 196: ((eq 'm (car j)) (setq fl-macl t)) ! 197: ((eq 'o (car j)) (setq v-ofile (cadr i) ! 198: i (cdr i))) ! 199: ((eq 'w (car j)) (setq fl-warn nil)) ! 200: ((eq 'q (car j)) (setq fl-verb nil)) ! 201: ((eq 'T (car j)) (setq fl-tty t)) ! 202: ((eq 'i (car j)) (setq fl-inter t)) ! 203: ((eq 'p (car j)) (setq fl-profile t)) ! 204: ((eq 'F (car j)) (setq fl-tran nil)) ! 205: ((eq 'v (car j)) (setq fl-vms t)) ! 206: ((eq 'x (car j)) (setq fl-xref t)) ! 207: ((eq 'u (car j)) (setq fl-uci t)) ! 208: (t (comp-gerr "Unknown switch: " ! 209: (car j)))))) ! 210: ((null v-root) ! 211: (setq temr (reverse tem)) ! 212: (cond ((and (eq 'l (car temr)) ! 213: (eq '\. (cadr temr))) ! 214: (setq rootreal nil) ! 215: (setq v-root (apply 'concat (reverse (cddr temr))))) ! 216: (t (setq v-root (car i) ! 217: rootreal t)))) ! 218: ! 219: (t (comp-gerr "Extra input file name: " (car i))))) ! 220: ! 221: ! 222: (cond (fl-vms (setq fl-tran nil))) ; no transfer tables in vms ! 223: ! 224: ; now see what the arguments have left us ! 225: ! 226: (cond ((null v-root) ! 227: (comp-gerr "No file for input")) ! 228: ((or (portp ! 229: (setq vp-ifile ! 230: (car (errset (infile ! 231: (setq v-ifile ! 232: (concat v-root '".l"))) ! 233: nil)))) ! 234: (and rootreal ! 235: (portp ! 236: (setq vp-ifile ! 237: (car (errset ! 238: (infile (setq v-ifile v-root)) ! 239: nil))))))) ! 240: (t (comp-gerr "Couldn't open the source file :" ! 241: (or v-ifile)))) ! 242: ! 243: ! 244: ; determine the name of the .s file ! 245: ; strategy: if fl-asm is t (only assemble) use (v-root).s ! 246: ; else use /tmp/(PID).s ! 247: ; ! 248: ; direct asm to tty temporarily ! 249: (setq v-sfile '"tty") ! 250: (setq vp-sfile nil) ! 251: (If (null fl-tty) then ! 252: (cond (fl-asm (setq v-sfile (concat '"/tmp/jkf" ! 253: (boole 1 65535 ! 254: (syscall 20)) ! 255: '".s"))) ! 256: (t (setq v-sfile (concat v-root '".s")))) ! 257: ! 258: (cond ((not (portp (setq vp-sfile ! 259: (car (errset (outfile v-sfile) ! 260: nil))))) ! 261: (comp-gerr "Couldn't open the .s file: " ! 262: (or v-sfile))))) ! 263: ! 264: ! 265: ; determine the name of the .o file (object file) ! 266: ; strategy: if we aren't supposed to assemble the .s file ! 267: ; don't worry about a name ! 268: ; else if a name is given, use it ! 269: ; else if use (v-root).o ! 270: ; if profiling, use .o ! 271: (cond ((or v-ofile (null fl-asm))) ;ignore ! 272: ((null fl-profile) (setq v-ofile (concat v-root '".o"))) ! 273: (t (setq v-ofile (concat v-root ".o")))) ! 274: ! 275: ; determine the name of the .x file (xref file) ! 276: ; strategy: if fl-xref is true, then use (v-root).x ! 277: ; ! 278: (cond (fl-xref ! 279: (cond ((not ! 280: (portp ! 281: (setq vp-xfile ! 282: (car (errset (outfile (setq v-xfile ! 283: (concat v-root ".x")))))))) ! 284: (comp-gerr "Can't open the .x file" (or v-xfile)))))) ! 285: (cond ((checkfatal) (return 1))) ! 286: ! 287: (setq readtable (makereadtable nil)) ; use new readtable ! 288: ! 289: ! 290: ; if the macsyma flag is set, change the syntax to the ! 291: ; maclisp standard syntax. We must be careful that we ! 292: ; dont clobber any syntax changes made by files preloaded ! 293: ; into the compiler. ! 294: ! 295: (cond (fl-macl (setsyntax '\/ 143) ; 143 = vesc ! 296: ! 297: (cond ((equal 143 (status syntax \\)) ! 298: (setsyntax '\\ 2))) ! 299: ! 300: (setsyntax '\| 138) ; 138 = vdq ! 301: (cond ((equal 198 (status syntax \[)) ! 302: (setsyntax '\[ 2) ! 303: (setsyntax '\] 2))) ! 304: (setq ibase 8.) ! 305: (sstatus uctolc t) ! 306: ! 307: (d-makespec 'ibase) ; to be special ! 308: (d-makespec 'base) ! 309: (d-makespec 'tty) ! 310: ! 311: (errset (cond ((null (getd 'macsyma-env)) ! 312: (fasl '/usr/lib/lisp/machacks))) ! 313: nil)) ! 314: (fl-uci (load "/usr/lib/lisp/ucifnc") ! 315: (cvttoucilisp))) ! 316: ! 317: (cond (fl-inter (putprop '* 'cc-ignore 'fl-exprcc) ;comment ! 318: (remprop '* 'fl-expr) ! 319: )) ! 320: ! 321: (cond ((checkfatal) (return 1))) ; leave if fatal errors ! 322: ! 323: (comp-note "Compilation begins with " compiler-name) ! 324: (comp-note "source: " v-ifile ", result: " ! 325: (cond (fl-asm v-ofile) (t v-sfile))) ! 326: (setq piport vp-ifile) ; set to standard input ! 327: (setq liszt-root-name v-root ! 328: liszt-file-name v-ifile) ! 329: ! 330: ! 331: (If fl-profile then (e-write1 '".globl mcount")) ! 332: loop ! 333: ! 334: (cond ((atom (errset ; list for debugging, ! 335: ; errset for production. ! 336: (do ((i (read piport '<<end-of-file>>) ! 337: (read piport '<<end-of-file>>))) ! 338: ((eq i '<<end-of-file>>) nil) ! 339: (catch (liszt-form i) Comp-error)))) ! 340: (comp-note "Lisp error during compilation") ! 341: (setq piport nil) ! 342: (setq er-fatal (1+ er-fatal)) ! 343: (return 1))) ! 344: ! 345: (close piport) ! 346: ! 347: (cond ((checkfatal) (return 1))) ! 348: ! 349: ; if doing special character stuff (maclisp) reassert ! 350: ; the state ! 351: ! 352: (cond (vps-include ! 353: (comp-note " done include") ! 354: (setq piport (car vps-include)) ! 355: (setq vps-include (cdr vps-include)) ! 356: (go loop))) ! 357: ! 358: (cond (liszt-eof-forms ! 359: (do ((ll liszt-eof-forms (cdr ll))) ! 360: ((null ll)) ! 361: (cond ((atom (errset (liszt-form (car ll)))) ! 362: (comp-note "Lisp error during eof forms") ! 363: (setq piport nil) ! 364: (return 1)))))) ! 365: ! 366: ; reset input base ! 367: (setq ibase 10.) ! 368: (setq readtable (makereadtable t)) ! 369: (d-bindtab) ! 370: ! 371: ! 372: (close vp-sfile) ; close assembler language file ! 373: (comp-note "Compilation complete") ! 374: ! 375: (setq tem (Divide (difference (syscall 13) starttime) 60)) ! 376: (comp-note " Real time: " (car tem) " minutes, " ! 377: (cadr tem) " seconds") ! 378: (setq tem (ptime)) ! 379: (setq temr (Divide (difference (car tem) (car startptime)) ! 380: 3600)) ! 381: (comp-note " CPU time: " (car temr) " minutes, " ! 382: (quotient (cadr temr) 60.0) " seconds") ! 383: (setq temr (Divide (difference (cadr tem) (cadr startptime)) ! 384: 3600)) ! 385: (comp-note " of which " (car temr) " minutes and " ! 386: (quotient (cadr temr) 60.0) ! 387: " seconds were for the " ! 388: (difference $gccount$ startgccount) ! 389: " gcs which were done") ! 390: ! 391: (cond (fl-xref ! 392: (comp-note "Cross reference being generated") ! 393: (print (list 'File v-ifile) vp-xfile) ! 394: (terpr vp-xfile) ! 395: (do ((ii g-allf (cdr ii))) ! 396: ((null ii)) ! 397: (print (car ii) vp-xfile) ! 398: (terpr vp-xfile)) ! 399: (close vp-xfile))) ! 400: ! 401: ! 402: ; the assember we use must generate the new a.out format ! 403: ; with a string table. We will assume that the assembler ! 404: ; is in /usr/lib/lisp/as so that other sites can run ! 405: ; the new assembler without installing the new assembler ! 406: ; as /bin/as ! 407: (cond (fl-asm ; assemble file ! 408: (comp-note "Assembly begins") ! 409: (cond ((not ! 410: (zerop ! 411: (setq tmp ! 412: (apply 'process ! 413: (ncons (concat ! 414: "/usr/lib/lisp/as -o " ! 415: v-ofile ! 416: '" " ! 417: v-sfile)))))) ! 418: (comp-gerr "Assembler detected error, code: " ! 419: tmp) ! 420: (comp-note "Assembler temp file " v-sfile ! 421: " is not unlinked")) ! 422: (t (comp-note "Assembly completed successfully") ! 423: (syscall 10 v-sfile))))) ; unlink tmp file ! 424: ! 425: (setq readtable original-readtable) ! 426: #+monitoring ! 427: (errset (progn (monitor) ; turn off monitoring ! 428: (print 'monitor-off)) ! 429: nil) ! 430: (return 0)))) ! 431: ! 432: (def checkfatal ! 433: (lambda nil ! 434: (cond ((greaterp er-fatal 0) ! 435: (comp-note "Compilation aborted") ! 436: t)))) ! 437: ! 438: ;--- liszt-form - i : form to compile ! 439: ; This compiles one form. ! 440: ; ! 441: (def liszt-form ! 442: (lambda (i) ! 443: (prog (tmp v-x) ! 444: ; macro expand ! 445: loop ! 446: (If (and (dtpr i) (eq 'macro (d-functyp (car i)))) ! 447: then (setq i (apply (car i) i)) ! 448: (go loop)) ! 449: ; now look at what is left ! 450: (cond ((eq (car i) 'def) ; jkf mod ! 451: (cond (fl-verb (print (cadr i)) (terpr)(drain))) ! 452: (d-dodef i)) ! 453: ((eq (car i) 'declare) (funcall 'complr-declare (cdr i))) ! 454: ((eq (car i) 'eval-when) (doevalwhen i)) ! 455: ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile))) ! 456: ((lambda (internal-macros) ; compile macros too ! 457: (mapc 'liszt-form (cddr i))) ! 458: t)) ! 459: ((or (and (eq (car i) 'includef) (setq tmp (eval (cadr i)))) ! 460: (and (eq (car i) 'include ) (setq tmp (cadr i)))) ! 461: (cond ((or (portp (setq v-x ! 462: (car (errset (infile tmp) nil)))) ! 463: (portp (setq v-x ! 464: (car (errset (infile (concat '"/usr/lib/lisp" ! 465: tmp)) ! 466: nil)))) ! 467: (portp (setq v-x ! 468: (car (errset (infile (concat tmp ! 469: '".l")) ! 470: nil))))) ! 471: (setq vps-include (cons piport vps-include)) ! 472: (setq piport v-x) ! 473: (comp-note " INCLUDEing file: " tmp)) ! 474: (t (comp-gerr "Cannot open include file: " tmp)))) ! 475: ((eq (car i) 'comment) nil) ; just ignore comments ! 476: (t (Push g-funcs `(eval ,i))))))) ! 477: ! 478: ;--- d-dodef :: handle the def form ! 479: ; - form : a def form: (def name (type args . body)) ! 480: ; ! 481: (defun d-dodef (form) ! 482: (prog nil ! 483: ! 484: loop ! 485: ! 486: (let ( ((g-fname (g-ftype g-args . body)) (cdr form)) ! 487: (lambdaform (caddr form)) ! 488: (symlab (gensym 'F))) ! 489: (If (or (memq '&rest g-args) ! 490: (memq '&optional g-args) ! 491: (memq '&aux g-args)) ! 492: then (setq form ! 493: `(def ,(cadr form) ,(lambdacvt (cdr lambdaform)))) ! 494: (go loop)) ! 495: (If (null (atom g-fname)) ! 496: then (comp-err "bad function name") ! 497: else (setq g-flocal (get g-fname g-localf)) ! 498: (If (eq g-ftype 'macro) ! 499: then (eval form) ! 500: (If (and (null macros) ! 501: (null internal-macros)) ! 502: then (comp-note " macro will not be compiled") ! 503: (return nil)) ! 504: (Push g-funcs `(macro ,symlab ,g-fname)) ! 505: elseif g-flocal ! 506: then (If (null (or (eq g-ftype 'lambda) ! 507: (eq g-ftype 'nlambda))) ! 508: then (comp-err "bad type for fcn" (or g-ftype))) ! 509: elseif (or (eq g-ftype 'lambda) ! 510: (eq g-ftype 'lexpr)) ! 511: then (Push g-funcs `(lambda ,symlab ,g-fname)) ! 512: elseif (eq g-ftype 'nlambda) ! 513: then (Push g-funcs `(nlambda ,symlab ,g-fname)) ! 514: else (comp-err " bad function type " g-ftype))) ! 515: (setq g-skipcode nil) ;make sure we aren't skipping code ! 516: (forcecomment `(fcn ,g-ftype ,g-fname)) ! 517: (If g-flocal ! 518: then (comp-note "is a local function") ! 519: (e-writel (car g-flocal)) ! 520: else ! 521: (If (null fl-vms) then (e-write2 '".globl" symlab)) ! 522: (e-writel symlab)) ! 523: (setq g-locs nil g-loccnt 0 g-labs nil g-loc 'reg g-cc nil ! 524: g-ret t g-topsym (d-genlab)) ! 525: (If fl-xref then (setq g-refseen (gensym) g-reflst nil)) ! 526: (d-clearreg) ! 527: (Push g-locs (cons 'lambda 0)) ! 528: (setq g-currentargs (length g-args)) ! 529: (mapc '(lambda (x) (Push g-locs nil) (incr g-loccnt)) ! 530: g-args) ! 531: (d-prelude) ; do beginning stuff ! 532: (d-lambbody lambdaform) ; emit code ! 533: (d-fini) ! 534: (If fl-xref then ! 535: (Push g-allf ! 536: (cons g-fname ! 537: (cons (cond (g-flocal (cons g-ftype 'local)) ! 538: (t g-ftype)) ! 539: g-reflst))))))) ! 540: ! 541: ! 542: ;--- d-prelude :: emit code common to beginning of all functions ! 543: ; ! 544: (defun d-prelude nil ! 545: (If g-flocal ! 546: then (e-write3 'movl 'r10 '"-(sp)") ; (faster than pushl) ! 547: (e-write3 'movab `(,(* -4 g-currentargs) r6) 'r10) ! 548: (e-writel g-topsym) ! 549: else ! 550: (e-write2 '".word" '0x5c0) ! 551: (If fl-profile ! 552: then (e-write3 'movab 'mcounts 'r0) ! 553: (e-write2 'jsb 'mcount)) ! 554: (e-write3 'movab 'linker '#.bind-reg) ! 555: (If (eq g-ftype 'lexpr) ! 556: then ! 557: (e-write4 'subl3 '$4 Lbot-reg '"-(sp)") ; set up base for (arg) ! 558: (e-writel g-topsym) ! 559: (e-write3 'movl Np-reg oLbot-reg) ; will stack num of args ! 560: (e-write4 'subl3 Lbot-reg Np-reg 'r0) ; arg cnt again ! 561: (e-write3 'movab '"0x1400(r0)" np-plus) ; stack lispval ! 562: (e-write3 'movl '(0 #.oLbot-reg) '"-(sp)") ; also on runtime stk ! 563: else ! 564: ; set up old lbot register, base register for variable ! 565: ; references ! 566: (e-write3 'movl '#.Lbot-reg '#.oLbot-reg) ! 567: ; make sure the np register points where it should since ! 568: ; the caller might have given too few or too many args ! 569: (e-write3 'movab `(,(* 4 g-currentargs) #.oLbot-reg) ! 570: '#.Np-reg) ! 571: (e-writel g-topsym)))) ! 572: ! 573: ;--- d-fini :: emit code at end of function ! 574: ! 575: (defun d-fini nil ! 576: (If g-flocal then (e-write3 'movl '"(sp)+" 'r10) ! 577: (e-write1 'rsb) ! 578: else (e-return))) ! 579: ! 580: ! 581: ;--- d-bindtab :: emit binder table when all functions compiled ! 582: ; ! 583: (defun d-bindtab nil ! 584: (setq g-skipcode nil) ; make sure this isnt ignored ! 585: (e-writel "bind_org") ! 586: (e-write2 ".set linker_size," (length g-lits)) ! 587: (e-write2 ".set trans_size," (length g-tran)) ! 588: (do ((ll (setq g-funcs (nreverse g-funcs)) (cdr ll))) ! 589: ((null ll)) ! 590: (If (memq (caar ll) '(lambda nlambda macro eval)) ! 591: then (e-write2 '".long" (cdr (assoc (caar ll) ! 592: '((lambda . 0) ! 593: (nlambda . 1) ! 594: (macro . 2) ! 595: (eval . 99))))) ! 596: else (comp-err " bad type in lit list " (car ll)))) ! 597: ! 598: (e-write1 ".long -1") ! 599: (e-write1 '"lit_org:") ! 600: (d-asciiout (nreverse g-lits)) ! 601: (If g-tran then (d-asciiout (nreverse g-tran))) ! 602: (d-asciiout (mapcar '(lambda (x) (If (eq (car x) 'eval) ! 603: then (cadr x) ! 604: else (caddr x))) ! 605: g-funcs)) ! 606: ! 607: (e-write1 '"lit_end:")) ! 608: ! 609: ;--- d-asciiout :: print a list of asciz strings ! 610: ; ! 611: (defun d-asciiout (args) ! 612: (do ((lits args (cdr lits)) ! 613: (form)) ! 614: ((null lits)) ! 615: (setq form (explode (car lits)) ! 616: formsiz (length form)) ! 617: (do ((remsiz formsiz) ! 618: (curform form) ! 619: (thissiz)) ! 620: ((zerop remsiz)) ! 621: (If (greaterp remsiz 60) then (sfilewrite '".ascii \"") ! 622: else (sfilewrite '".asciz \"")) ! 623: (setq thissiz (min 60 remsiz)) ! 624: (do ((count thissiz (1- count))) ! 625: ((zerop count) ! 626: (sfilewrite (concat '\" (ascii 10))) ! 627: (setq remsiz (difference remsiz thissiz))) ! 628: (If (eq ch-newline (car curform)) ! 629: then (sfilewrite '\\012) ! 630: else (If (or (eq '\\ (car curform)) ! 631: (eq '\" (car curform))) ! 632: then (sfilewrite '\\)) ! 633: (sfilewrite (car curform))) ! 634: (setq curform (cdr curform)))))) ! 635: ! 636: ;--- doevalwhen, process evalwhen directive. This is inadequate. ! 637: ; ! 638: (def doevalwhen ! 639: (lambda (v-f) ! 640: (prog (docom dolod) ! 641: (setq docom (memq 'compile (cadr v-f)) ! 642: ! 643: dolod (memq 'load (cadr v-f))) ! 644: (mapc '(lambda (frm) (cond (docom (eval frm))) ! 645: (cond (dolod ! 646: ((lambda (internal-macros) ! 647: (liszt-form frm)) ! 648: t)))) ! 649: (cddr v-f))))) ! 650: ! 651: ! 652: ;---- dodcl - forms declare form ! 653: ; process the declare form given. We evaluate each arg ! 654: ; ! 655: (defun complr-declare fexpr (forms) ! 656: (do ((i forms (cdr i))) ! 657: ((null i)) ! 658: (cond ((and (atom (caar i)) ! 659: (getd (caar i))) ! 660: (eval (car i))) ; if this is a function ! 661: (t (comp-warn "Unknown declare attribute: " (car i)))))) ! 662: ! 663: ;---> handlers for declare forms ! 664: ; ! 665: (def *fexpr ! 666: (nlambda (args) ! 667: (mapc '(lambda (v-a) ! 668: (putprop v-a 'nlambda g-functype)) ! 669: args))) ! 670: ! 671: (def nlambda ! 672: (nlambda (args) ! 673: (mapc '(lambda (v-a) ! 674: (putprop v-a 'nlambda g-functype)) ! 675: args))) ! 676: ! 677: (def special ! 678: (nlambda (v-l) ! 679: (mapc '(lambda (v-a) ! 680: (putprop v-a t g-spec) ) ! 681: v-l) ! 682: t)) ! 683: (def unspecial ! 684: (nlambda (v-l) ! 685: (mapc '(lambda (v-a) ! 686: (putprop v-a nil g-spec)) ! 687: v-l) ! 688: t)) ! 689: ! 690: (def *expr ! 691: (nlambda (args) ! 692: (mapc ! 693: '(lambda (v-a) ! 694: (cond ((atom v-a) (putprop v-a 'lambda g-functype)) ! 695: (t (comp-warn "Bad declare form " v-a ! 696: " in list " args)))) ! 697: args) ! 698: t)) ! 699: ! 700: (def *lexpr ! 701: (nlambda (args) ! 702: (mapc '(lambda (v-a) ! 703: (putprop v-a 'lexpr g-functype)) ! 704: args) ! 705: t)) ; ignore ! 706: ! 707: (def fixnum ! 708: (nlambda (args) ! 709: nil)) ; ignore ! 710: ! 711: (def flonum ! 712: (nlambda (args) ! 713: nil)) ; ignore ! 714: ! 715: (def macros ! 716: (nlambda (args) (setq macros (car args)))) ! 717: ! 718: (def localf ! 719: (nlambda (args) (mapc '(lambda (ar) ! 720: (If (null (get ar g-localf)) ! 721: then (putprop ar ! 722: (cons (d-genlab) -1) ! 723: g-localf))) ! 724: args))) ! 725: ;---> end declare form handlers ! 726: ! 727: ! 728: ! 729: ! 730: ! 731: ! 732: ! 733: ! 734: ! 735: ;--- lambdacvt ! 736: ; converts a lambda expression with &optional, &rest and &aux forms in ! 737: ; the argument list into a lexpr which will do the desired function. ! 738: ; method of operation ! 739: ; the argument list is examined and the following lists are made: ! 740: ; vbs - list of variables to be lambda bound ! 741: ; opl - list of optional forms ! 742: ; vals - list of values to be assigned to the vbs ! 743: ; ! 744: (def lambdacvt ! 745: (lambda (exp) ! 746: (prog (arg vbs vals opl rest opflg restflg narg narg2 narg3 auxflg ! 747: avbs) ! 748: (do ((ll (car exp) (cdr ll)) ! 749: (count 1 (1+ count))) ! 750: ((null ll)) ! 751: (cond ((eq '&rest (car ll)) ! 752: (setq restflg t opflg nil count (1- count))) ! 753: ((eq '&optional (car ll)) ! 754: (setq opflg t count (1- count))) ! 755: ((eq '&aux (car ll)) ! 756: (setq auxflg t ! 757: opflg nil ! 758: restflg nil ! 759: count (1- count))) ! 760: (opflg ! 761: (cond ((atom (setq arg (car ll))) ! 762: (setq opl (cons (cons (ncons arg) count) opl) ! 763: vbs (cons arg vbs) ! 764: vals (cons nil vals))) ! 765: ((cddr arg) ! 766: (setq vbs (cons (car arg) ! 767: (cons (caddr arg) ! 768: vbs)) ! 769: vals (cons nil ! 770: (cons nil vals)) ! 771: opl (cons (cons arg count) opl))) ! 772: (t (setq vbs (cons (car arg) vbs) ! 773: vals (cons nil vals) ! 774: opl (cons (cons arg count) opl))))) ! 775: (restflg ! 776: (setq vbs (cons (car ll) vbs) ! 777: vals (cons nil vals) ! 778: rest (cons (car ll) count))) ! 779: (auxflg ! 780: (setq count (1- count)) ! 781: (cond ((atom (setq arg (car ll))) ! 782: (setq avbs (cons (ncons arg) avbs))) ! 783: (t (setq avbs (cons arg avbs))))) ! 784: (t (setq vbs (cons (car ll) vbs) ! 785: vals (cons `(arg ,count) vals))))) ! 786: (setq narg (gensym)) ! 787: ! 788: (return ! 789: `(lexpr (,narg) ! 790: ((lambda ,(nreverse vbs) ! 791: ,@(mapcar ! 792: '(lambda (arg) ! 793: `(cond ((greaterp ,(cdr arg) ! 794: ,narg) ! 795: ,@(cond ((cadar arg) ! 796: `((setq ,(caar arg) ! 797: ,(cadar arg)))))) ! 798: (t (setq ,(caar arg) (arg ,(cdr arg))) ! 799: ,@(cond ((cddar arg) ! 800: `((setq ,(caddar arg) ! 801: t))))))) ! 802: (nreverse opl)) ! 803: ,@(cond (rest (setq narg2 (gensym) ! 804: narg3 (gensym)) ! 805: `((do ((,narg2 ,narg (1- ,narg2)) ! 806: (,narg3 nil (cons (arg ,narg2) ! 807: ,narg3))) ! 808: ((lessp ,narg2 ,(cdr rest)) ! 809: (setq ,(car rest) ,narg3)))))) ! 810: ,@(cond (auxflg `((let* ,(nreverse avbs) ! 811: ,@(cdr exp)))) ! 812: (t (cdr exp)))) ! 813: ,@(nreverse vals))))))) ! 814: ! 815: ; this routine is copied from ccb.l so we can make it a local function ! 816: ; in both files ! 817: ! 818: ;--- d-genlab :: generate a pseudo label ! 819: ; ! 820: (defun d-genlab nil ! 821: (gensym 'L)) ! 822:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.