![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tlev.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 tlev.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 tlev ! 3: "$Header: tlev.l,v 1.17 87/12/15 17:08:51 sklower Exp $") ! 4: ! 5: ;;; ---- t l e v top level interface ! 6: ;;; ! 7: ;;; -[Tue Nov 22 09:21:27 1983 by jkf]- ! 8: ! 9: ;--- lisztinit : called upon compiler startup. If there are any args ! 10: ; on the command line, we build up a call to liszt, which ! 11: ; will do the compile. Afterwards we exit. ! 12: ; ! 13: (def lisztinit ! 14: (lambda nil ! 15: (setq fl-asm nil) ; insure it as correct value in case of int ! 16: (let ((args (command-line-args))) ! 17: (if args ! 18: then (signal 2 'liszt-interrupt-signal) ; die on int ! 19: (signal 15 'liszt-interrupt-signal) ; die on sigterm ! 20: (setq user-top-level nil) ! 21: (exit (apply 'liszt args)) ! 22: else (patom compiler-name) ! 23: (patom " [")(patom franz-minor-version-number)(patom "]") ! 24: (terpr poport) ! 25: (setq user-top-level nil))))) ! 26: ! 27: (setq user-top-level 'lisztinit) ! 28: ! 29: ;--- liszt - v-x : list containing file name to compile and optionaly ! 30: ; and output file name for the assembler source. ! 31: ; ! 32: (def liszt ! 33: (nlambda (v-x) ! 34: (prog (piport v-root v-ifile v-sfile v-ofile ! 35: vp-ifile vp-sfile vps-crap ! 36: vps-include vns-include ! 37: asm-exit-status ntem temgc temcp ! 38: rootreal g-arrayspecs out-path ! 39: g-decls g-stdref pre-eval include-files ! 40: g-fname g-trueop g-falseop g-didvectorcode ! 41: tem temr starttime startptime startgccount ! 42: fl-asm fl-warn fl-warnfatal fl-verb fl-inter ! 43: fl-xref fl-uci fl-run fl-case fl-anno g-optionalp ! 44: liszt-process-forms in-line-lambda-number ! 45: g-skipcode g-dropnpcnt g-complrname g-fname) ! 46: ! 47: ;in case "S" switch given, set asm-exit-status ! 48: ; to 0 (so garbage won't be returned). ! 49: (setq asm-exit-status 0) ! 50: ! 51: ; turn on monitoring if it exists ! 52: #+monitoring ! 53: (errset (progn (monitor t) ; turn it on ! 54: (print 'monitor-on) ! 55: (terpr)) ! 56: nil) ! 57: (setq starttime (sys:time) ; real time in seconds ! 58: startptime (ptime) ! 59: startgccount $gccount$) ! 60: (setq in-line-lambda-number (sys:time)) ! 61: (cond ((null (boundp 'internal-macros)) ! 62: (setq internal-macros nil))) ! 63: (cond ((null (boundp 'macros)) ! 64: (setq macros nil))) ! 65: (setq er-fatal 0 er-warn 0) ! 66: (setq vps-include nil ! 67: vns-include nil) ;stack of ports and names ! 68: (setq twa-list nil) ! 69: (setq liszt-eof-forms nil) ! 70: ! 71: ; look for lisztrc file and return if error occured ! 72: ; in reading it ! 73: (cond ((eq (do-lisztrc-check) 'error) ! 74: (return 1))) ! 75: ! 76: ; set up once only g variables ! 77: (setq g-comments nil ! 78: g-current nil ; current function name ! 79: g-funcs nil ! 80: g-lits nil ! 81: g-trueloc nil ! 82: g-tran nil ! 83: g-allf nil ; used in xrefs ! 84: g-reguse #+(or for-vax for-tahoe) ! 85: (copy '((r4 0 . nil) (r3 0 . nil) ! 86: (r2 0 . nil); (r7 0 . nil) ! 87: (r1 0 . nil))) ! 88: #+for-68k (copy '((a0 0 . nil) (a1 0 . nil) ! 89: (d1 0 . nil) (d2 0 . nil) ! 90: (d4 0 . nil) (d5 0 . nil))) ! 91: g-trancnt 0 ! 92: g-ignorereg nil ! 93: g-trueop #+(or for-vax for-tahoe) 'jneq ;used in e-gotot ! 94: #+for-68k 'jne ! 95: g-falseop #+(or for-vax for-tahoe) 'jeql ;u. in e-gotonil ! 96: #+for-68k 'jeq ! 97: g-compfcn nil ! 98: g-litcnt 0) ! 99: (setq g-spec (gensym 'S)) ; flag for special atom ! 100: (setq g-fname "") ; no function yet ! 101: (setq special nil) ; t if all vrbs are special ! 102: (setq g-functype (gensym) ! 103: g-vartype (gensym) ! 104: g-bindtype (gensym) ! 105: g-calltype (gensym) ! 106: g-bindloc (gensym) ! 107: g-localf (gensym) ! 108: g-arrayspecs (gensym) ! 109: g-tranloc (gensym) ! 110: g-stdref (gensym) ! 111: g-optionalp (gensym)) ! 112: ! 113: ; declare these special ! 114: ! 115: (sstatus feature complr) ! 116: (d-makespec 't) ; always special ! 117: ! 118: ; process input form ! 119: (setq fl-asm t ; assembler file assembled ! 120: fl-warn t ; print warnings ! 121: fl-warnfatal nil ; warnings are fatal ! 122: fl-verb t ; be verbose ! 123: fl-macl nil ; compile maclisp file ! 124: fl-anno nil ; annotate ! 125: fl-inter nil ; do interlisp compatablity ! 126: fl-tty nil ; put .s on tty ! 127: fl-comments nil ; put in comments ! 128: fl-profile nil ; profiling ! 129: fl-tran t ; use transfer tables ! 130: fl-vms nil ; vms hacks ! 131: fl-case nil ; trans uc to lc ! 132: fl-xref nil ; xrefs ! 133: fl-run nil ; autorun capability ! 134: fl-uci nil ; uci lisp compatibility ! 135: ) ! 136: ! 137: ; look in the environment for a LISZT variable ! 138: ; if it exists, make it the first argument ! 139: (if (not (eq '|| (setq tem (getenv 'LISZT)))) ! 140: then (setq v-x (cons (concat "-" tem) v-x))) ! 141: ! 142: (do ((i v-x (cdr i))) ; for each argument ! 143: ((null i)) ! 144: (setq tem (aexplodec (car i))) ! 145: ! 146: (cond ((eq '- (car tem)) ; if switch ! 147: (do ((j (cdr tem) (cdr j))) ! 148: ((null j)) ! 149: (cond ((eq 'S (car j)) (setq fl-asm nil)) ! 150: ((eq 'C (car j)) (setq fl-comments t)) ! 151: ((eq 'm (car j)) (setq fl-macl t)) ! 152: ((eq 'o (car j)) (setq v-ofile (cadr i) ! 153: i (cdr i))) ! 154: ((eq 'e (car j)) (setq pre-eval (cadr i) ! 155: i (cdr i))) ! 156: ((eq 'i (car j)) (push (cadr i) ! 157: include-files) ! 158: (pop i)) ! 159: ((eq 'w (car j)) (setq fl-warn nil)) ! 160: ((eq 'W (car j)) (setq fl-warnfatal t)) ! 161: ((eq 'q (car j)) (setq fl-verb nil)) ! 162: ((eq 'Q (car j)) (setq fl-verb t)) ! 163: ((eq 'T (car j)) (setq fl-tty t)) ! 164: ((eq 'a (car j)) (setq fl-anno t)) ! 165: ((eq 'i (car j)) (setq fl-inter t)) ! 166: ((eq 'p (car j)) (setq fl-profile t)) ! 167: ((eq 'F (car j)) (setq fl-tran nil)) ! 168: ((eq 'v (car j)) (setq fl-vms t)) ! 169: ((eq 'r (car j)) (setq fl-run t)) ! 170: ((eq 'x (car j)) (setq fl-xref t)) ! 171: ((eq 'c (car j)) (setq fl-case t)) ! 172: ((eq 'u (car j)) (setq fl-uci t)) ! 173: ((eq '- (car j))) ; ignore extra -'s ! 174: (t (comp-gerr "Unknown switch: " ! 175: (car j)))))) ! 176: ((null v-root) ! 177: (setq temr (reverse tem)) ! 178: (cond ((and (eq 'l (car temr)) ! 179: (eq '\. (cadr temr))) ! 180: (setq rootreal nil) ! 181: (setq v-root ! 182: (apply 'concat ! 183: (reverse (cddr temr))))) ! 184: (t (setq v-root (car i) ! 185: rootreal t)))) ! 186: ! 187: (t (comp-gerr "Extra input file name: " (car i))))) ! 188: ! 189: ;no transfer tables in vms ! 190: (cond (fl-vms (setq fl-tran nil))) ! 191: ! 192: ; if verbose mode, print out the gc messages and ! 193: ; fasl messages, else turn them off. ! 194: (cond (fl-verb (setq $gcprint t ! 195: $ldprint t)) ! 196: (t (setq $gcprint nil ! 197: $ldprint nil))) ! 198: ! 199: ; eval arg after -e ! 200: (if pre-eval ! 201: then (if (null (errset ! 202: (eval (readlist (exploden pre-eval))))) ! 203: then (comp-gerr "-e form caused error: " ! 204: pre-eval))) ! 205: ! 206: ; load file after -i arg ! 207: (if include-files ! 208: then (catch ! 209: (mapc ! 210: '(lambda (file) ! 211: (if (null (errset (load file))) ! 212: then (comp-err ! 213: "error when loading -i file: " ! 214: file))) ! 215: include-files) ! 216: Comp-error)) ! 217: ! 218: ; -c says set reader to xlate uc to lc ! 219: (cond (fl-case (sstatus uctolc t))) ! 220: ! 221: ; If we are a cross compiler, then don't try to ! 222: ; assemble our output... ! 223: ; ! 224: #+for-vax ! 225: (if (or (status feature 68k) (status feature tahoe)) ! 226: then (setq fl-asm nil)) ! 227: #+for-tahoe ! 228: (if (or (status feature vax) (status feature 68k)) ! 229: then (setq fl-asm nil)) ! 230: #+for-68k ! 231: (if (or (status feature vax) (status feature tahoe)) ! 232: then (setq fl-asm nil)) ! 233: ! 234: ; now see what the arguments have left us ! 235: (cond ((null v-root) ! 236: (comp-gerr "No file for input")) ! 237: ((or (portp ! 238: (setq vp-ifile ! 239: (car (errset (infile ! 240: (setq v-ifile ! 241: (concat v-root '".l"))) ! 242: nil)))) ! 243: (and rootreal ! 244: (portp ! 245: (setq vp-ifile ! 246: (car (errset ! 247: (infile (setq v-ifile v-root)) ! 248: nil))))))) ! 249: (t (comp-gerr "Couldn't open the source file :" ! 250: (or v-ifile)))) ! 251: ! 252: ! 253: ; determine the name of the .s file ! 254: ; strategy: if fl-asm is t (assemble) use (v-root).s ! 255: ; else use /tmp/(PID).s ! 256: ; ! 257: ; direct asm to tty temporarily ! 258: (setq v-sfile "tty") ! 259: (setq vp-sfile nil) ! 260: (if (null fl-tty) then ! 261: (cond (fl-asm (setq v-sfile ! 262: (concat '"/tmp/Lzt" ! 263: (boole 1 65535 ! 264: (sys:getpid)) ! 265: '".s"))) ! 266: (t (setq v-sfile ! 267: (if v-ofile ! 268: then v-ofile ! 269: else (concat v-root '".s"))))) ! 270: ! 271: (cond ((not (portp (setq vp-sfile ! 272: (car (errset (outfile v-sfile) ! 273: nil))))) ! 274: (comp-gerr "Couldn't open the .s file: " ! 275: (or v-sfile))))) ! 276: ! 277: ! 278: ; determine the name of the .o file (object file) ! 279: ; strategy: if we aren't supposed to assemble the .s file ! 280: ; don't worry about a name ! 281: ; else if a name is given, use it ! 282: ; else if use (v-root).o ! 283: ; if profiling, use .o ! 284: (cond ((or v-ofile (null fl-asm))) ;ignore ! 285: ((null fl-profile) (setq v-ofile (concat v-root ".o"))) ! 286: (t (setq v-ofile (concat v-root ".o")))) ! 287: ! 288: ; determine the name of the .x file (xref file) ! 289: ; strategy: if fl-xref and v-ofile is true, then use ! 290: ; v-ofile(minus .o).x, else use (v-root).x ! 291: ; ! 292: (if fl-xref ! 293: then ; check for ending with .X for any X ! 294: (setq v-xfile ! 295: (if v-ofile ! 296: then (let ((ex (nreverse ! 297: (exploden v-ofile)))) ! 298: (if (eq #/. (cadr ex)) ! 299: then (implode ! 300: (nreverse ! 301: `(#/x #/. ! 302: ,@(cddr ex)))) ! 303: else (concat v-ofile ".x"))) ! 304: else (concat v-root ".x"))) ! 305: (if (portp ! 306: (setq vp-xfile ! 307: (car (errset (outfile v-xfile))))) ! 308: thenret ! 309: else (comp-gerr "Can't open the .x file: " ! 310: v-xfile))) ! 311: (cond ((checkfatal) (return 1))) ! 312: ! 313: ; g-complrname is a symbol which should be unique to ! 314: ; each fasl'ed file. It will contain the string which ! 315: ; describes the name of this file and the compiler ! 316: ; version. ! 317: (if fl-anno ! 318: then (setq g-complrname (concat "fcn-in-" v-ifile)) ! 319: (Push g-funcs ! 320: `(eval (setq ,g-complrname ! 321: ,(get_pname ! 322: (concat v-ifile ! 323: " compiled by " ! 324: compiler-name ! 325: " on " ! 326: (status ctime))))))) ! 327: ! 328: ! 329: (setq readtable (makereadtable nil)) ; use new readtable ! 330: ! 331: ! 332: ; if the macsyma flag is set, change the syntax to the ! 333: ; maclisp standard syntax. We must be careful that we ! 334: ; dont clobber any syntax changes made by files preloaded ! 335: ; into the compiler. ! 336: ! 337: (cond (fl-macl (setsyntax '\/ 'vescape) ; 143 = vesc ! 338: ! 339: (cond ((eq 'vescape (getsyntax '\\)) ! 340: (setsyntax '\\ 'vcharacter))) ! 341: ! 342: (cond ((eq 'vleft-bracket (getsyntax '\[)) ! 343: (setsyntax '\[ 'vcharacter) ! 344: (setsyntax '\] 'vcharacter))) ! 345: (setq ibase 8.) ! 346: (sstatus uctolc t) ! 347: ! 348: (d-makespec 'ibase) ; to be special ! 349: (d-makespec 'base) ! 350: (d-makespec 'tty) ! 351: ! 352: (errset (cond ((null (getd 'macsyma-env)) ! 353: (load 'machacks))) ! 354: nil)) ! 355: (fl-uci (load "ucifnc") ! 356: (cvttoucilisp))) ! 357: ! 358: (cond (fl-inter (putprop '* 'cc-ignore 'fl-exprcc) ;comment ! 359: (remprop '* 'fl-expr) ! 360: )) ! 361: ! 362: (cond ((checkfatal) (return 1))) ; leave if fatal errors ! 363: ! 364: (if fl-verb ! 365: then (comp-msg "Compilation begins with " compiler-name ) ! 366: (comp-msg "source: " v-ifile ", result: " ! 367: (cond (fl-asm v-ofile) (t v-sfile)))) ! 368: ! 369: (setq piport vp-ifile) ; set to standard input ! 370: (setq liszt-root-name v-root ! 371: liszt-file-name v-ifile) ! 372: ! 373: ! 374: (if fl-run then (d-printautorun)) ! 375: ! 376: (if fl-profile then (e-write1 '".globl mcount")) ! 377: loop ! 378: ! 379: ; main loop of the compiler. It reads a form and ! 380: ; compiles it. It continues to compile forms from ! 381: ; liszt-process-forms was long at that list is ! 382: ; non-empty. This allows one form to spawn off other ! 383: ; forms to be compiled (an alternative to (progn 'compile)) ! 384: ; ! 385: (cond ((atom (list ; list for debugging, ! 386: ; errset for production. ! 387: (do ((i (read piport '<<end-of-file>>) ! 388: (read piport '<<end-of-file>>))) ! 389: ((eq i '<<end-of-file>>) nil) ! 390: (setq liszt-process-forms ! 391: (cons i liszt-process-forms)) ! 392: (do ((this (car liszt-process-forms) ! 393: (car liszt-process-forms))) ! 394: ((null liszt-process-forms)) ! 395: (unpush liszt-process-forms) ! 396: (catch (liszt-form this) Comp-error))))) ! 397: (catch (comp-err "Lisp error during compilation") ! 398: Comp-error) ! 399: (setq piport nil) ! 400: (setq er-fatal (1+ er-fatal)) ! 401: (return 1))) ! 402: ! 403: (close piport) ! 404: ! 405: ; if doing special character stuff (maclisp) reassert ! 406: ; the state ! 407: ! 408: (cond (vps-include ! 409: (comp-note " done include") ! 410: (setq piport (car vps-include) ! 411: vps-include (cdr vps-include) ! 412: v-ifile (car vns-include) ! 413: vns-include (cdr vns-include)) ! 414: (go loop))) ! 415: ! 416: (cond (liszt-eof-forms ! 417: (do ((ll liszt-eof-forms (cdr ll))) ! 418: ((null ll)) ! 419: (cond ((atom (errset (liszt-form (car ll)))) ! 420: (catch ! 421: (comp-note "Lisp error during eof forms") ! 422: Comp-error) ! 423: (setq piport nil) ! 424: (return 1)))))) ! 425: ! 426: ; reset input base ! 427: (setq ibase 10.) ! 428: (setq readtable (makereadtable t)) ! 429: (sstatus uctolc nil) ; turn off case conversion ! 430: ; so bindtab will not have |'s ! 431: ; to quote lower case ! 432: (d-bindtab) ! 433: ! 434: (d-printdocstuff) ; describe this compiler ! 435: ! 436: (cond ((portp vp-sfile) ! 437: (close vp-sfile))) ; close assembler language file ! 438: ! 439: ; if warnings are to be considered fatal, and if we ! 440: ; have seen to many warnings, make it fatal ! 441: (cond ((and fl-warnfatal (> er-warn 0)) ! 442: (comp-gerr "Too many warnings"))) ! 443: ! 444: ; check for fatal errors and don't leave if so ! 445: (cond ((checkfatal) ! 446: (if fl-asm ; unlink .s file ! 447: then (sys:unlink v-sfile)) ; if it is a tmp ! 448: (return 1))) ; and ret with error status ! 449: ! 450: (comp-note "Compilation complete") ! 451: ! 452: (setq tem (Divide (difference (sys:time) starttime) 60)) ! 453: (setq ntem (ptime)) ! 454: ! 455: (setq temcp (Divide (difference (car ntem) (car startptime)) ! 456: 3600)) ! 457: ! 458: (setq temgc (Divide (difference (cadr ntem) (cadr startptime)) ! 459: 3600)) ! 460: ! 461: (comp-note " Time: Real: " (car tem) ":" (cadr tem) ! 462: ", CPU: " (car temcp) ":" (quotient (cadr temcp) 60.0) ! 463: ", GC: " (car temgc) ":" (quotient (cadr temgc) 60.0) ! 464: " for " ! 465: (difference $gccount$ startgccount) ! 466: " gcs") ! 467: ! 468: (cond (fl-xref ! 469: (comp-note "Cross reference being generated") ! 470: (print (list 'File v-ifile) vp-xfile) ! 471: (terpr vp-xfile) ! 472: (do ((ii g-allf (cdr ii))) ! 473: ((null ii)) ! 474: (print (car ii) vp-xfile) ! 475: (terpr vp-xfile)) ! 476: (close vp-xfile))) ! 477: ! 478: ! 479: ; the assember we use must generate the new a.out format ! 480: ; with a string table. We will assume that the assembler ! 481: ; is in /usr/lib/lisp/as so that other sites can run ! 482: ; the new assembler without installing the new assembler ! 483: ; as /bin/as ! 484: (cond (fl-asm ; assemble file ! 485: (comp-note "Assembly begins") ! 486: (cond ((not ! 487: (zerop ! 488: (setq asm-exit-status ! 489: (*process ! 490: (concat ! 491: lisp-library-directory ! 492: "/as " ! 493: #+(or for-vax for-tahoe) "-V" ; use virt mem ! 494: " -o " ! 495: v-ofile ! 496: " " ! 497: v-sfile))))) ! 498: (comp-gerr "Assembler detected error, code: " ! 499: asm-exit-status) ! 500: (comp-note "Assembler temp file " v-sfile ! 501: " is not unlinked")) ! 502: (t (comp-note "Assembly completed successfully") ! 503: (errset (sys:unlink v-sfile)); unlink tmp ! 504: ; file ! 505: (if fl-run ! 506: then (errset ! 507: (sys:chmod v-ofile #O775))))))) ! 508: ! 509: #+(and sun (not unisoft)) ! 510: (if (and v-ofile fl-run) ! 511: then (if (null ! 512: (errset (let ((port (fileopen v-ofile "r+"))) ! 513: (fseek port 20 0) ! 514: (tyo 0 port) ! 515: (tyo 0 port) ! 516: (tyo 128 port) ! 517: (tyo 0 port) ! 518: (close port)))) ! 519: then (comp-err ! 520: "Error while fixing offset in object file: " ! 521: v-ofile))) ! 522: ! 523: (setq readtable original-readtable) ! 524: #+monitoring ! 525: (errset (progn (monitor) ; turn off monitoring ! 526: (print 'monitor-off)) ! 527: nil) ! 528: (sstatus nofeature complr) ! 529: (return asm-exit-status)))) ! 530: ! 531: (def checkfatal ! 532: (lambda nil ! 533: (cond ((greaterp er-fatal 0) ! 534: (catch (comp-err "Compilation aborted due to previous errors") ! 535: Comp-error) ! 536: t)))) ! 537: ! 538: ;--- do-lisztrc-check ! 539: ; look for a liszt init file named ! 540: ; .lisztrc or lisztrc or $HOME/.lisztrc or $HOME/lisztrc ! 541: ; followed by .o or .l or nothing ! 542: ; return the symbol 'error' if an error occured while reading. ! 543: ; ! 544: (defun do-lisztrc-check nil ! 545: (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs)) ! 546: (val) ! 547: ($gcprint nil) ! 548: ($ldprint nil)) ! 549: ((null dirs)) ! 550: (if (setq val ! 551: (do ((name '(".lisztrc" "lisztrc") (cdr name)) ! 552: (val)) ! 553: ((null name)) ! 554: (if (setq val ! 555: (do ((ext '(".o" ".l" "") (cdr ext)) ! 556: (file)) ! 557: ((null ext)) ! 558: (if (probef ! 559: (setq file (concat (car dirs) ! 560: "/" ! 561: (car name) ! 562: (car ext)))) ! 563: then (if (atom (errset (load file))) ! 564: then (comp-msg ! 565: "Error loading liszt init file " ! 566: file N ! 567: "Compilation aborted" N) ! 568: (return 'error) ! 569: else (return t))))) ! 570: then (return val)))) ! 571: then (return val)))) ! 572: ! 573: ! 574: ;--- liszt-form - i : form to compile ! 575: ; This compiles one form. ! 576: ; ! 577: (def liszt-form ! 578: (lambda (i) ! 579: (prog (tmp v-x) ! 580: ; macro expand ! 581: loop ! 582: (setq i (d-macroexpand i)) ! 583: ; now look at what is left ! 584: (cond ((not (dtpr i)) (Push g-funcs `(eval ,i))) ! 585: ((eq (car i) 'def) ! 586: (cond (fl-verb (print (cadr i)) (terpr)(drain))) ! 587: (d-dodef i)) ! 588: ((memq (car i) '(liszt-declare declare)) ! 589: (funcall 'liszt-declare (cdr i))) ! 590: ((eq (car i) 'eval-when) (doevalwhen i)) ! 591: ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile))) ! 592: ((lambda (internal-macros) ; compile macros too ! 593: (mapc 'liszt-form (cddr i))) ! 594: t)) ! 595: ((or (and (eq (car i) 'includef) (setq tmp (eval (cadr i)))) ! 596: (and (eq (car i) 'include ) (setq tmp (cadr i)))) ! 597: (cond ((or (portp (setq v-x ! 598: (car (errset (infile tmp) nil)))) ! 599: (portp (setq v-x ! 600: (car ! 601: (errset ! 602: (infile ! 603: (concat ! 604: lisp-library-directory ! 605: "/" ! 606: tmp)) ! 607: nil)))) ! 608: (portp (setq v-x ! 609: (car (errset (infile (concat tmp ! 610: '".l")) ! 611: nil))))) ! 612: (setq vps-include (cons piport vps-include)) ! 613: (setq piport v-x) ! 614: (comp-note " INCLUDEing file: " tmp) ! 615: (setq vns-include (cons v-ifile vns-include) ! 616: v-ifile tmp)) ! 617: (t (comp-gerr "Cannot open include file: " tmp)))) ! 618: ((eq (car i) 'comment) nil) ; just ignore comments ! 619: (t ; we have to macro expand ! 620: ; certain forms we would normally ! 621: ; just dump in the eval list. This is due to hacks in ! 622: ; the mit lisp compiler which are relied upon by certain ! 623: ; code from mit. ! 624: (setq i (d-fullmacroexpand i)) ! 625: ! 626: (Push g-funcs `(eval ,i))))))) ! 627: ! 628: ;--- d-dodef :: handle the def form ! 629: ; - form : a def form: (def name (type args . body)) ! 630: ; ! 631: (defun d-dodef (form) ! 632: (prog (g-ftype g-args body lambdaform symlab g-arginfo g-compfcn g-decls) ! 633: ! 634: ! 635: (setq g-arginfo 'empty) ! 636: ! 637: loop ! 638: ; extract the components of the def form ! 639: (setq g-fname (cadr form)) ! 640: (if (dtpr (caddr form)) ! 641: then (setq g-ftype (caaddr form) ! 642: g-args (cadaddr form) ! 643: body (cddaddr form) ! 644: lambdaform (caddr form) ! 645: symlab (gensym 'F)) ! 646: else (comp-gerr "bad def form " form)) ! 647: ! 648: ; check for a def which uses the mit hackish &xxx forms. ! 649: ; if seen, convert to a standard form and reexamine ! 650: ; the vax handles these forms in a special way. ! 651: #+for-68k ! 652: (if (or (memq '&rest g-args) ! 653: (memq '&optional g-args) ! 654: (memq '&aux g-args)) ! 655: then (setq form ! 656: `(def ,(cadr form) ,(lambdacvt (cdr lambdaform)))) ! 657: (go loop)) ! 658: ! 659: ; check for legal function name. ! 660: ; then look at the type of the function and update the data base. ! 661: (if (null (atom g-fname)) ! 662: then (comp-err "bad function name") ! 663: else (setq g-flocal (get g-fname g-localf)) ; check local decl. ! 664: ; macros are special, they are always evaluated ! 665: ; and sometimes compiled. ! 666: (if (and (not g-flocal) (eq g-ftype 'macro)) ! 667: then (eval form) ! 668: (if (and (null macros) ! 669: (null internal-macros)) ! 670: then (comp-note g-fname ! 671: " macro will not be compiled") ! 672: (return nil)) ! 673: (Push g-funcs `(macro ,symlab ,g-fname)) ! 674: (if fl-anno then (setq g-arginfo nil)) ; no arg info ! 675: elseif g-flocal ! 676: then (if (null (or (eq g-ftype 'lambda) ! 677: (eq g-ftype 'nlambda))) ! 678: then (comp-err ! 679: "bad type for local fcn: " g-ftype)) ! 680: (if (or (memq '&rest g-args) ! 681: (memq '&optional g-args) ! 682: (memq '&aux g-args)) ! 683: then (comp-err ! 684: "local functions can't use &keyword's " ! 685: g-fname)) ! 686: elseif (or (eq g-ftype 'lambda) ! 687: (eq g-ftype 'lexpr)) ! 688: then (push `(lambda ,symlab ,g-fname) g-funcs) ! 689: (putprop g-fname 'lambda g-functype) ! 690: elseif (eq g-ftype 'nlambda) ! 691: then (Push g-funcs `(nlambda ,symlab ,g-fname)) ! 692: (putprop g-fname 'nlambda g-functype) ! 693: else (comp-err " bad function type " g-ftype))) ! 694: (setq g-skipcode nil) ;make sure we aren't skipping code ! 695: (forcecomment `(fcn ,g-ftype ,g-fname)) ! 696: (if g-flocal ! 697: then (comp-note g-fname " is a local function") ! 698: (e-writel (car g-flocal)) ! 699: else (if (null fl-vms) then (e-write2 '".globl" symlab)) ! 700: (e-writel symlab)) ! 701: (setq g-locs nil g-loccnt 0 g-labs nil g-loc 'reg g-cc nil ! 702: g-ret t g-topsym (d-genlab)) ! 703: (if fl-xref then (setq g-refseen (gensym) g-reflst nil)) ! 704: (d-clearreg) ! 705: #+for-68k (init-regmaskvec) ! 706: ; set up global variables which maintain knowledge about ! 707: ; the stack. these variables are set up as if the correct ! 708: ; number of args were passed. ! 709: (setq g-compfcn t) ; now compiling a function ! 710: (push nil g-labs) ; no labels in a lambda ! 711: (setq g-currentargs (length g-args)) ! 712: (d-prelude) ; do beginning stuff ! 713: ! 714: ; on the vax, we handle & keywords in a special way in ! 715: ; d-outerlambdacomp. This function also sets g-arginfo. ! 716: #+(or for-vax for-tahoe) ! 717: (d-outerlambdacomp g-fname g-args (cddr lambdaform)) ! 718: ! 719: #+for-68k ! 720: (progn ! 721: (push (cons 'lambda 0) g-locs) ! 722: (mapc '(lambda (x) ! 723: (push nil g-locs) ! 724: (incr g-loccnt)) ! 725: g-args) ! 726: ; set g-arginfo if this is a lambda. If it is a lexpr, then ! 727: ; we don't give all the info we could. ! 728: (setq g-arginfo ! 729: (if (eq g-ftype 'lambda) ! 730: then (cons g-loccnt g-loccnt))) ! 731: (d-lambbody lambdaform)) ! 732: ! 733: (d-fini) ! 734: (setq g-compfcn nil) ; done compiling a fcn ! 735: (if fl-xref then ! 736: (Push g-allf ! 737: (cons g-fname ! 738: (cons (cond (g-flocal (cons g-ftype 'local)) ! 739: (t g-ftype)) ! 740: g-reflst)))) ! 741: (if (and fl-anno (not (eq 'empty g-arginfo))) ! 742: then (Push g-funcs `(eval (putprop ! 743: ',g-fname ! 744: (list ',g-arginfo ! 745: ,g-complrname) ! 746: 'fcn-info)))) ! 747: ; by storing argument count information during compilation ! 748: ; we can arg number check calls to this function which occur ! 749: ; further on. ! 750: (if (not (eq 'empty g-arginfo)) ! 751: then (putprop g-fname (list g-arginfo) 'fcn-info)))) ! 752: ! 753: ;--- d-lambdalistcheck :: scan lambda var list for & forms ! 754: ; return ! 755: ; (required optional rest op-p body) ! 756: ; required - list of required args ! 757: ; optional - list of (variable default [optional-p]) ! 758: ; rest - either nil or the name of a variable for optionals ! 759: ; op-p - list of variables set to t or nil depending if optional exists ! 760: ; body - body to compile (has &aux's wrapped around it in lambdas) ! 761: ; ! 762: #+(or for-vax for-tahoe) ! 763: (defun d-lambdalistcheck (list body) ! 764: (do ((xx list (cdr xx)) ! 765: (state 'req) ! 766: (statechange) ! 767: (arg) ! 768: (req)(optional)(rest)(op-p)(aux)) ! 769: ((null xx) ! 770: (list (nreverse req) ! 771: (nreverse optional) ! 772: rest ! 773: (nreverse op-p) ! 774: (d-lambda-aux-body-convert body (nreverse aux)))) ! 775: (setq arg (car xx)) ! 776: (if (memq arg '(&optional &rest &aux)) ! 777: then (setq statechange arg) ! 778: else (setq statechange nil)) ! 779: (caseq state ! 780: (req ! 781: (if statechange ! 782: then (setq state statechange) ! 783: elseif (and (symbolp arg) arg) ! 784: then (push arg req) ! 785: else (comp-err " illegal lambda variable " arg))) ! 786: (&optional ! 787: (if statechange ! 788: then (if (memq statechange '(&rest &aux)) ! 789: then (setq state statechange) ! 790: else (comp-err "illegal form in lambda list " ! 791: xx)) ! 792: elseif (symbolp arg) ! 793: then ; optional which defaults to nil ! 794: (push (list arg nil) optional) ! 795: elseif (dtpr arg) ! 796: then (if (and (symbolp (car arg)) ! 797: (symbolp (caddr arg))) ! 798: then ; optional with default ! 799: (push arg optional) ! 800: ; save op-p ! 801: (if (cddr arg) ! 802: then (push (caddr arg) op-p))) ! 803: else (comp-err "illegal &optional form " ! 804: arg))) ! 805: (&rest ! 806: (if statechange ! 807: then (if (eq statechange '&aux) ! 808: then (setq state statechange) ! 809: else (comp-err "illegal lambda variable form " ! 810: xx)) ! 811: elseif rest ! 812: then (comp-err ! 813: "more than one rest variable in lambda list" ! 814: arg) ! 815: else (setq rest arg))) ! 816: (&aux ! 817: (if statechange ! 818: then (comp-err "illegal lambda form " xx) ! 819: elseif (and (symbolp arg) arg) ! 820: then (push (list arg nil) aux) ! 821: elseif (and (dtpr arg) (and (symbolp (car arg)) ! 822: (car arg))) ! 823: then (push arg aux))) ! 824: (t (comp-err "bizzarro internal compiler error "))))) ! 825: ! 826: ;--- d-lambda-aux-body-convert :: convert aux's to lambdas ! 827: ; give a function body and a list of aux variables ! 828: ; and their inits, place a lambda initializing body around body ! 829: ; for each lambda (basically doing a let*). ! 830: ; ! 831: #+(or for-vax for-tahoe) ! 832: (defun d-lambda-aux-body-convert (body auxlist) ! 833: (if (null auxlist) ! 834: then body ! 835: else `(((lambda (,(caar auxlist)) ! 836: ,@(d-lambda-aux-body-convert body (cdr auxlist))) ! 837: ,(cadar auxlist))))) ! 838: ! 839: ;--- d-outerlambdacomp :: compile a functions outer lambda body ! 840: ; This function compiles the lambda expression which defines ! 841: ; the function. This lambda expression differs from the kind that ! 842: ; appears within a function because ! 843: ; 1. we aren't sure that the correct number of arguments have been stacked ! 844: ; 2. the keywords &optional, &rest, and &aux may appear ! 845: ; ! 846: ; funname - name of function ! 847: ; lambdalist - the local argument list, (with possible keywords) ! 848: ; body - what follows the lambdalist ! 849: ; ! 850: ; ! 851: ; ! 852: #+(or for-vax for-tahoe) ! 853: (defun d-outerlambdacomp (funname lambdalist body) ! 854: (let (((required optional rest op-p newbody) ! 855: (d-lambdalistcheck lambdalist body)) ! 856: (g-decls g-decls) ! 857: (reqnum 0) maxwithopt labs (maxnum -1) args) ! 858: (d-scanfordecls body) ! 859: ; if this is a declared lexpr, we aren't called ! 860: ; ! 861: (if (and (null optional) (null rest)) ! 862: then ; simple, the number of args is required ! 863: ; if lexpr or local function, then don't bother ! 864: (if (and (not g-flocal) ! 865: (not (eq g-ftype 'lexpr))) ! 866: then (d-checkforfixedargs ! 867: funname ! 868: (setq reqnum (setq maxnum (length required))))) ! 869: else ; complex, unknown number of args ! 870: ; cases: ! 871: ; optional, no rest ! 872: ; optional, with rest ! 873: ; no optional, rest + required ! 874: ; no optional, rest + no required ! 875: (setq reqnum (length required) ! 876: maxwithopt (+ reqnum (length optional)) ! 877: maxnum (if rest then -1 else maxwithopt)) ! 878: ; determine how many args were given ! 879: (e-sub3 '#.lbot-reg '#.np-reg '#.lbot-reg) ! 880: #+for-vax (e-write4 'ashl '$-2 '#.lbot-reg '#.lbot-reg) ! 881: #+for-tahoe (e-write4 'shar '$2 '#.lbot-reg '#.lbot-reg) ! 882: ; ! 883: (if (null optional) ! 884: then ; just a rest ! 885: (let ((oklab (d-genlab)) ! 886: (lllab (d-genlab)) ! 887: (nopushlab (d-genlab))) ! 888: (if (> reqnum 0) ! 889: then (e-cmp '#.lbot-reg `($ ,reqnum)) ! 890: (e-write2 'jgeq oklab) ! 891: ; not enough arguments given ! 892: (d-wnaerr funname reqnum -1) ! 893: (e-label oklab)) ! 894: (e-pushnil 1) ! 895: (if (> reqnum 0) ! 896: then (e-sub `($ ,reqnum) '#.lbot-reg) ! 897: else (e-tst '#.lbot-reg)) ! 898: (e-write2 'jleq nopushlab) ! 899: (e-label lllab) ! 900: (e-quick-call '_qcons) ! 901: (d-move 'reg 'stack) ! 902: #+for-vax (e-write3 'sobgtr '#.lbot-reg lllab) ! 903: #+for-tahoe (progn (e-sub '($ 1) '#.lbot-reg) ! 904: (e-write2 'bgtr lllab)) ! 905: (e-label nopushlab)) ! 906: else ; has optional args ! 907: ; need one label for each optional plus 2 ! 908: (do ((xx optional (cdr xx)) ! 909: (res (list (d-genlab) (d-genlab)))) ! 910: ((null xx) (setq labs res)) ! 911: (push (d-genlab) res)) ! 912: ; push nils for missing optionals ! 913: ; one case for required amount and one for ! 914: ; each possible number of optionals ! 915: (e-write4 'casel ! 916: '#.lbot-reg `($ ,reqnum) ! 917: `($ ,(- maxwithopt reqnum))) ! 918: #+for-tahoe (e-write2 '.align '1) ! 919: (e-label (car labs)) ! 920: (do ((xx (cdr labs) (cdr xx)) ! 921: (head (car labs))) ! 922: ((null xx)) ! 923: (e-write2 '.word (concat (car xx) "-" head))) ! 924: ; get here (when running code) if there are more ! 925: ; than the optional number of args or if there are ! 926: ; too few args. If &rest is given, it is permitted ! 927: ; to have more than the required number ! 928: (let ((dorest (d-genlab)) ! 929: (again (d-genlab)) ! 930: (afterpush (d-genlab))) ! 931: (if rest ! 932: then ; check if there are greater than ! 933: ; the required number ! 934: ; preserve arg # ! 935: (C-push '#.lbot-reg) ! 936: (e-sub `($ ,maxwithopt) '#.lbot-reg) ! 937: (e-write2 'jgtr dorest) ! 938: (C-pop '#.lbot-reg)) ! 939: ; wrong number of args ! 940: (d-wnaerr funname reqnum maxnum) ! 941: (if rest ! 942: then ; now cons the rest forms ! 943: (e-label dorest) ! 944: (e-pushnil 1) ; list ends with nil ! 945: (e-label again) ! 946: (e-quick-call '_qcons) ! 947: (d-move 'reg 'stack) ! 948: ; and loop ! 949: #+for-vax (e-write3 'sobgtr '#.lbot-reg again) ! 950: #+for-tahoe (progn (e-sub '($ 1) '#.lbot-reg) ! 951: (e-write2 'bgtr again)) ! 952: ; arg # ! 953: (C-pop '#.lbot-reg) ! 954: (e-goto afterpush)) ! 955: ; push the nils on the optionals ! 956: (do ((xx (cdr labs) (cdr xx))) ! 957: ((null xx)) ! 958: (e-label (car xx)) ! 959: ; if we have exactly as many arguments given ! 960: ; as the number of optionals, then we stack ! 961: ; a nil if there is a &rest after ! 962: ; the optionals ! 963: (if (null (cdr xx)) ! 964: then (if rest ! 965: then (e-pushnil 1)) ! 966: else (e-pushnil 1))) ! 967: (e-label afterpush)))) ! 968: ; for optional-p's stack t's ! 969: (mapc '(lambda (form) (d-move 'T 'stack)) op-p) ! 970: ! 971: ; now the variables must be shallow bound ! 972: ; creat a list of all arguments ! 973: (setq args (append required ! 974: (mapcar 'car optional) ! 975: (if rest then (list rest)) ! 976: op-p)) ! 977: ! 978: (push (cons 'lambda 0) g-locs) ! 979: (mapc '(lambda (x) ! 980: (push nil g-locs)) ! 981: args) ! 982: (setq g-loccnt (length args)) ! 983: (d-bindlamb args) ; do shallow binding if necessary ! 984: ; ! 985: ; if any of the optionals have non null defaults or ! 986: ; optional-p's, we have to evaluate their defaults ! 987: ; or set their predicates. ! 988: ; first, see if it is necessary ! 989: (if (do ((xx optional (cdr xx))) ! 990: ((null xx) nil) ! 991: (if (or (cadar xx) ; if non null default ! 992: (caddar xx)); or predicate ! 993: then (return t))) ! 994: then (makecomment '(do optional defaults and preds)) ! 995: ; create labels again ! 996: ; need one label for each optional plus 1 ! 997: (do ((xx optional (cdr xx)) ! 998: (res (list (d-genlab) ))) ! 999: ((null xx) (setq labs res)) ! 1000: (push (d-genlab) res)) ! 1001: ; we need to do something if the argument count ! 1002: ; is between the number of required arguments and ! 1003: ; the maximum number of args with optional minus 1. ! 1004: ; we have one case for the required number and ! 1005: ; one for each optional except the last optional number ! 1006: ; ! 1007: (let ((afterthis (d-genlab))) ! 1008: (e-write4 'casel ! 1009: '#.lbot-reg `($ ,reqnum) ! 1010: `($ ,(- maxwithopt reqnum 1))) ! 1011: #+for-tahoe (e-write2 '.align '1) ! 1012: (e-label (car labs)) ! 1013: (do ((xx (cdr labs) (cdr xx)) ! 1014: (head (car labs))) ! 1015: ((null xx)) ! 1016: (e-write2 '.word (concat (car xx) "-" head))) ! 1017: (e-goto afterthis) ! 1018: (do ((ll (cdr labs) (cdr ll)) ! 1019: (op optional (cdr op)) ! 1020: (g-loc nil) ! 1021: (g-cc nil) ! 1022: (g-ret nil)) ! 1023: ((null ll)) ! 1024: (e-label (car ll)) ! 1025: (if (caddar op) ! 1026: then (d-exp `(setq ,(caddar op) nil))) ! 1027: (if (cadar op) ! 1028: then (d-exp `(setq ,(caar op) ,(cadar op))))) ! 1029: (e-label afterthis))) ! 1030: ! 1031: ; now compile the function ! 1032: (d-clearreg) ! 1033: (setq g-arginfo ! 1034: (if (eq g-ftype 'nlambda) ! 1035: then nil ! 1036: else (cons reqnum (if (>& maxnum 0) then maxnum else nil)))) ! 1037: (makecomment '(begin-fcn-body)) ! 1038: (d-exp (do ((ll newbody (cdr ll)) ! 1039: (g-loc) ! 1040: (g-cc) ! 1041: (g-ret)) ! 1042: ((null (cdr ll)) (car ll)) ! 1043: (d-exp (car ll)))) ! 1044: (d-unbind))) ! 1045: ! 1046: #+(or for-vax for-tahoe) ! 1047: (defun d-checkforfixedargs (fcnname number) ! 1048: (let ((oklab (d-genlab))) ! 1049: (makecomment `(,fcnname should-have-exactly ,number args)) ! 1050: ; calc -4*# of args ! 1051: (e-sub '#.np-reg '#.lbot-reg) ! 1052: (e-cmp '#.lbot-reg `($ ,(- (* number 4)))) ! 1053: (e-write2 'jeql oklab) ! 1054: (d-wnaerr fcnname number number) ! 1055: (e-label oklab))) ! 1056: ! 1057: ;--- d-wnaerr :: generate code to call wrong number of args error ! 1058: ; name is the function name, ! 1059: ; min is the minumum number of args for this function ! 1060: ; max is the maximum number (-1 if there is no maximum) ! 1061: ; we encode the min and max in the way shown below. ! 1062: ; ! 1063: #+(or for-vax for-tahoe) ! 1064: (defun d-wnaerr (name min max) ! 1065: (makecomment `(arg error for fcn ,name min ,min max ,max)) ! 1066: (e-move 'r10 '#.lbot-reg) ! 1067: (C-push `($ ,(+ (* min 1000) (+ max 1)))) ! 1068: (C-push (e-cvt (d-loclit name nil))) ! 1069: #+for-vax (e-write3 'calls '$2 '_wnaerr) ! 1070: #+for-tahoe (e-write3 'callf '$12 '_wnaerr)) ! 1071: ! 1072: ;--- d-genlab :: generate a pseudo label ! 1073: ; ! 1074: (defun d-genlab nil ! 1075: (gensym 'L)) ! 1076: ! 1077: ;--- liszt-interrupt-signal ! 1078: ; if we receive a interrupt signal (commonly a ^C), then ! 1079: ; unlink the .s file if we are generating a temporary one ! 1080: ; and exit ! 1081: (defun liszt-interrupt-signal (sig) ! 1082: (if (and fl-asm (boundp 'v-sfile) v-sfile) ! 1083: then (sys:unlink v-sfile)) ! 1084: (exit 1))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.