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