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