home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / tlev.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  33.4 KB  |  1,085 lines
  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))
  1085.