home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_c / schem2c1.lzh / Scheme2C / Scheme-src.lzh / scsc / compile.sc < prev    next >
Encoding:
Text File  |  1991-10-11  |  17.6 KB  |  513 lines
  1. ;;; The top level of the Scheme compiler is implemented by this module.  The
  2. ;;; variables that are used outside this module are:
  3. ;;;
  4.  
  5. ;*              Copyright 1989 Digital Equipment Corporation
  6. ;*                         All Rights Reserved
  7. ;*
  8. ;* Permission to use, copy, and modify this software and its documentation is
  9. ;* hereby granted only under the following terms and conditions.  Both the
  10. ;* above copyright notice and this permission notice must appear in all copies
  11. ;* of the software, derivative works or modified versions, and any portions
  12. ;* thereof, and both notices must appear in supporting documentation.
  13. ;*
  14. ;* Users of this software agree to the terms and conditions set forth herein,
  15. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  16. ;* right and license under any changes, enhancements or extensions made to the
  17. ;* core functions of the software, including but not limited to those affording
  18. ;* compatibility with other hardware or software environments, but excluding
  19. ;* applications which incorporate this software.  Users further agree to use
  20. ;* their best efforts to return to Digital any such changes, enhancements or
  21. ;* extensions that they make and inform Digital of noteworthy uses of this
  22. ;* software.  Correspondence should be provided to Digital at:
  23. ;* 
  24. ;*                       Director of Licensing
  25. ;*                       Western Research Laboratory
  26. ;*                       Digital Equipment Corporation
  27. ;*                       100 Hamilton Avenue
  28. ;*                       Palo Alto, California  94301  
  29. ;* 
  30. ;* This software may be distributed (but not offered for sale or transferred
  31. ;* for compensation) to third parties, provided such third parties agree to
  32. ;* abide by the terms and conditions of this notice.  
  33. ;* 
  34. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  35. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  36. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  37. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  38. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  39. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  40. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  41. ;* SOFTWARE.
  42.  
  43. (module compile)
  44.  
  45. ;;; External and in-line declarations.
  46.  
  47. (include "plist.sch")
  48. (include "expform.sch")
  49. (include "lambdaexp.sch")
  50. (include "miscexp.sch")
  51.  
  52. ;;; Top-level variables.
  53.  
  54. (define SC-INPUT '())        ; List of open input files.
  55.  
  56. (define SC-SPLICE '())        ; List of forms to "splice" into input.
  57.  
  58. (define SC-SOURCE-NAME '())    ; Initial source file name.
  59.  
  60. (define SC-INCLUDE-DIRS '(""))    ; List of directories for include to search.
  61.  
  62. (define SC-ICODE '())        ; C written to this file.
  63.  
  64. (define SC-ERROR '())        ; true ->  log errors to ICODE file.
  65.                     ; false -> log errors to STANDARD-OUPUT.
  66.     
  67. (define SC-ERROR-CNT 0)        ; # of error messages reported.
  68.  
  69. (define SC-LOG '())        ; List of events to log to the SC-ICODE file.
  70.                     ; The possible events are:
  71.                 ;
  72.                 ; SOURCE - source text.
  73.                        ; MACRO - source following macro expansion.
  74.                     ; EXPAND - initial tree.
  75.                 ; CLOSED - closed procedures and variables
  76.                 ; TRANSFORM - tree following boolean transform.
  77.                 ; LAMBDA - lambda analysis information.
  78.                     ; TREE - final tree and constants.
  79.                 ; LAP - lap code.
  80.                 ; PEEP - peep-hole optimization.
  81.  
  82. (define SC-STACK-TRACE #t)    ; true -> emit stack tracing code
  83.                 ; false -> don't emit stack tracing code.
  84.  
  85. (define SC-INTERPRETER #f)    ; true -> building an interpreter, so ignore
  86.                 ;         main clause in module.
  87.                 ; false -> process module normally.
  88.  
  89. (define SC-LOG-DEFAULT '(source macro expand closed transform lambda tree))
  90.                 ; Default list of events to log.
  91.  
  92. (define MODULE-NAME "")     ; Module name.
  93.  
  94. (define MODULE-NAME-UPCASE "")    ; Upper case version of the module name.
  95.  
  96. (define MAIN-PROGRAM-NAME '())    ; Main program name.
  97.  
  98. (define HEAP-SIZE 0)        ; Default size of heap.
  99.  
  100. (define CURRENT-DEFINE-NAME 'top-level)
  101.                     ; Name of current DEFINE being processed.
  102.  
  103. (define TOP-LEVEL-SYMBOLS #t)    ; List of top-level symbols.
  104.  
  105. (define WITH-MODULES '())    ; List of additional modules used.
  106.  
  107. (define RESTORE-PLIST '())    ; Function to restore default initial values.
  108.  
  109. (define TRUE-ALPHA 'true-alpha) ; Alpha variable for #t
  110.  
  111. (define FALSE-ALPHA 'false-alpha)
  112.                     ; Alpha variable for #f
  113.  
  114. (define EMPTY-LIST-ALPHA 'empty-list-alpha)
  115.                     ; Alpha variable for ()
  116.  
  117. (define CONS-ALPHA '())        ; Alpha variable for cons
  118.  
  119. (define UNDEFINED-ALPHA '())    ; Alpha variable for undefined value
  120.  
  121. ;;; Initialization of the entire compiler is triggered by the following
  122. ;;; function.  It is normally called once at the start of each compilation.
  123.  
  124. (define (INITIALIZE-COMPILE)
  125.     ;;; Initialize the variables in expand.sc
  126.     (set! lexical-free-vars '())
  127.     (set! lexical-bound-vars '())
  128.     (set! current-lambda-id 'top-level)
  129.     
  130.     ;;; Initialize the variables in miscexp.sc
  131.     (set! quote-constants '())
  132.     
  133.     ;;; Initialize the variables in lap.sc
  134.     (set! lap-code '())
  135.     
  136.     ;;; Initialize some of the variables in compile.sc
  137.     (set! sc-log '())
  138.     (set! sc-stack-trace #t)
  139.     (set! sc-interpreter #f)
  140.  
  141.     ;;; Initialize the property list.
  142.     (if restore-plist
  143.     (restore-plist)
  144.     (begin (create-plist predef-default)
  145.            (copy-plist 'scc 'initial-scc)    
  146.            (set! restore-plist
  147.              (let ((init-globals global-free-vars)
  148.                (init-seq     make-alpha-seq))
  149.               (lambda ()                          
  150.                   (set! global-free-vars init-globals)
  151.                   (set! make-alpha-seq init-seq)
  152.                   (copy-plist 'initial-scc 'scc))))))
  153.     
  154.     ;;; Initialize the rest of the variables in compile.sc
  155.     (set! sc-input '())
  156.     (set! sc-splice '())
  157.     (set! sc-include-dirs '(""))
  158.     (set! sc-icode '())
  159.     (set! sc-error '())
  160.     (set! sc-error-cnt 0)
  161.     (set! module-name "")
  162.     (set! main-program-name '())
  163.     (set! heap-size 0)
  164.     (set! current-define-name 'top-level)
  165.     (set! top-level-symbols #t)
  166.     (set! with-modules '())
  167.     (set! undefined-alpha (bound '$_undefined))
  168.     (set! cons-alpha (bound 'cons))
  169.     (set! module-name ""))
  170.  
  171. ;;; As property list initialization takes a while, it is done only once and a
  172. ;;; copy is saved.
  173.  
  174. (define (CREATE-PLIST predef-file)
  175.     (set! module-name "*initialize*")
  176.     (copy-plist 'null-property 'scc)
  177.     (set! global-free-vars '())
  178.     (set! make-alpha-seq 0)
  179.  
  180.     ;;; Initialize for #T, #F, and ().
  181.     (set-id-vname! 'true-alpha "TRUEVALUE")
  182.     (set-id-use! 'true-alpha 'constant)
  183.     (set-id-value! 'true-alpha #t)
  184.     (set-id-vname! 'false-alpha "FALSEVALUE")
  185.     (set-id-use! 'false-alpha 'constant)
  186.     (set-id-value! 'false-alpha #f)
  187.     (set-id-vname! 'empty-list-alpha "EMPTYLIST")
  188.     (set-id-use! 'empty-list-alpha 'constant)
  189.     (set-id-value! 'empty-list-alpha '())
  190.     
  191.     ;;; Initialize for miscexp.t
  192.     (put 'lap          'expand lap-exp   )
  193.     (put 'quote          'expand quote-exp )
  194.     (put 'set!        'expand set!-exp  )
  195.     (put 'if          'expand if-exp    )
  196.     (put 'define      'expand define-exp)
  197.     
  198.     ;;; Initialize for macros.t
  199.     (put 'quasiquote          'macro (old-macro quasiquote-macro))
  200.     (put 'cond                  'macro (old-macro cond-macro))
  201.     (put 'case                  'macro (old-macro case-macro))
  202.     (put 'and                  'macro (old-macro and-macro))
  203.     (put 'or                  'macro (old-macro or-macro))
  204.     (put 'not            'macro (old-macro not-macro))
  205.     (put 'begin                  'macro (old-macro begin-macro))
  206.     (put 'let                  'macro (old-macro let-macro))
  207.     (put 'let*                'macro (old-macro let*-macro))
  208.     (put 'letrec            'macro (old-macro letrec-macro))
  209.     (put 'do               'macro (old-macro do-macro))
  210.     (put 'when            'macro (old-macro when-macro))
  211.     (put 'unless        'macro (old-macro unless-macro))
  212.     (put 'quote               'macro quote-macro)
  213.     (put 'lap               'macro lap-macro)
  214.     (put 'module            'macro quote-macro)
  215.     (put 'include           'macro quote-macro)
  216.     (put 'define-external   'macro quote-macro)
  217.     (put 'define-c-external 'macro quote-macro)
  218.     (put 'define        'macro define-macro)
  219.     (put 'define-macro      'macro define-macro-macro)
  220.     (put 'define-constant   'macro define-constant-macro)
  221.     (put 'eval-when        'macro eval-when-macro)
  222.     (put 'lambda        'macro lambda-macro)
  223.     
  224.     ;;; Initialize for lambdaexp.sc
  225.     (put 'lambda 'expand lambda-exp)
  226.     
  227.     ;;; Initialize for lap.sc
  228.     (load-plist-lap)
  229.     
  230.     ;;; Initialize using the predef file.
  231.     (set! sc-input (list (open-input-file predef-file)))
  232.     (let ((x (read-text)))
  233.      (if (not (eof-object? x))
  234.          (report-error "Illegal predefinition form:" x)))
  235.     (close-port (car sc-input))
  236.     (set! sc-input '())
  237.     (set! make-alpha-seq (max make-alpha-seq 1000))
  238.     
  239.     ;;; Initialize alpha variables which point into the predef file.
  240.     (set! undefined-alpha (bound '$_undefined))
  241.     (set! cons-alpha (bound 'cons))
  242.     (set! module-name ""))
  243.  
  244. ;;; The  compiler is invoked by the procedure SC which takes the following
  245. ;;; required argument:
  246. ;;;
  247. ;;;    input        source file name to compile.  The suffix ".sc"  is 
  248. ;;;            added to it to form the actual file name.
  249. ;;;
  250. ;;; and the following optional arguments:
  251. ;;;
  252. ;;;    icode        file for C intermediate code.  If it is supplied,
  253. ;;;            then the suffix ".c" will be added to form the file
  254. ;;;            name.  If it is not supplied then it will be
  255. ;;;            constructed by appending the suffix ".c" to the source
  256. ;;;            file name.
  257. ;;;
  258. ;;;    ERROR         error messages are to be written to the icode file.  If
  259. ;;;            it is not supplied, then errors will be written to the
  260. ;;;            standard output device.
  261. ;;;
  262. ;;;    LOG        log the default events to the icode file.  If it is
  263. ;;;            not specified, then no events will be logged.
  264. ;;;
  265. ;;;    (LOG events...)    log the specified events to the icode file.  If it is
  266. ;;;            not specified, then no events will be logged.
  267. ;;;
  268. ;;;    NOTRACE        don't emit code for stack back stack.  If it is not
  269. ;;;            specified, then stack trace back code will be emitted.
  270. ;;;
  271. ;;;    PREDEF file    source file for predefined functions.  If it is
  272. ;;;            specified, then a suffix of ".sc" will be
  273. ;;;            appended.  If is is not specified, then the "standard"
  274. ;;;            predefinition file will be used.        
  275.         
  276. (define (SC input . output) 
  277.     (initialize-compile)
  278.     (if (symbol? input) (set! input (string-downcase (symbol->string input))))
  279.     (set! sc-source-name (string-append input ".sc"))
  280.     (set! sc-input (list (open-input-file sc-source-name)))
  281.     (cond ((and output (output-port? (car output)))
  282.        (set! sc-icode (car output))
  283.        (set! output (cdr output)))
  284.           ((or (null? output) (pair? (car output))
  285.            (memq (car output) '(error log profile predef)))
  286.        (set! sc-icode (open-output-file (string-append input ".c"))))
  287.       ((or (symbol? (car output)) (string? (car output)))
  288.        (set! sc-icode
  289.          (open-output-file (string-append (if (symbol? (car output))
  290.                       (string-downcase
  291.                           (symbol->string (car output)))
  292.                       (car output)) ".c")))
  293.        (set! output (cdr output))))
  294.     (do ((output output (cdr output))
  295.      (flag '())
  296.      (options '() (cons flag options)))
  297.     ((null? output) (docompile))
  298.     (set! flag (car output))
  299.     (cond ((memq flag options)
  300.            (report-error "Duplicate option:" flag))
  301.           ((eq? flag 'error)
  302.            (set! sc-error #t))
  303.           ((eq? flag 'log)
  304.            (set! sc-log sc-log-default))
  305.           ((and (pair? flag) (eq? (car flag) 'log))
  306.            (set! sc-log (cdr flag))
  307.            (set! flag 'log))
  308.           ((eq? flag 'notrace)
  309.            (set! sc-stack-trace #f))
  310.           ((and (eq? flag 'predef) (cdr output))
  311.            (create-plist
  312.            (string-append (if (symbol? (cadr output))
  313.                       (string-downcase
  314.                       (symbol->string (cadr output)))
  315.                       (cadr output))
  316.                ".sc"))
  317.            (set! output (cdr output)))
  318.           (else (report-error "Unrecognized option:" flag))))
  319.     (close-sc-files)
  320.     'sc-done)
  321.  
  322. ;;; The following function is called to assure that all the files used by SC
  323. ;;; are closed.
  324.  
  325. (define (CLOSE-SC-FILES)
  326.     (let ((cifo (lambda (f)
  327.             (if (and f (not (eq? f (current-output-port))))
  328.                 (close-port f)))))
  329.      (for-each cifo sc-input)
  330.      (set! sc-input '())
  331.      (set! sc-splice '())
  332.      (set! sc-include-dirs '(""))
  333.      (cifo sc-icode)
  334.      (set! sc-icode '())))
  335.  
  336. ;;; SCL is an alternative to SC and is provided for testing.  It allows one to
  337. ;;; specify a list of expressions to compile.  They will be written to the file
  338. ;;; "scltext.sc" and then SC will be invoked.  The default logging will be
  339. ;;; enabled.
  340.  
  341. (define (SCL . expl)
  342.     (let ((file 'scltext))
  343.      (cond ((and expl (pair? (car expl)))
  344.         (let ((port (open-output-file "scltext.sc")))
  345.              (write '(module test) port)
  346.              (newline port)
  347.              (for-each (lambda (exp) (write exp port) (newline port))
  348.                 expl)
  349.              (close-output-port port)))
  350.            (expl
  351.         (set! file (car expl))))
  352.      (sc file (current-output-port) 'log)))
  353.  
  354. ;;; Event logging is tested for the by the following boolean.
  355.  
  356. (define (LOG? event) (memq event sc-log))
  357.  
  358. ;;; Once all the files are open, the actual compilation is directed by the
  359. ;;; following function.
  360.               
  361. (define (DOCOMPILE)
  362.     (let ((forms '()))
  363.      (if sc-log (format sc-icode "/* ***** Expand Forms *****~%"))
  364.      (set! forms (expand-forms))
  365.      (if (log? 'expand) (pp$t-list forms sc-icode))
  366.  
  367.      (if sc-log (format sc-icode "   ***** Transformations *****~%"))
  368.      (for-each analyze-closures1a forms)
  369.      (for-each analyze-closures1b forms)
  370.      (set! forms (map transform forms))
  371.      
  372.      (if sc-log (format sc-icode "   ***** Closure Analysis *****~%"))
  373.      (for-each analyze-closures2 forms)
  374.      (if (log? 'lambda)
  375.          (for-each
  376.          (lambda (tree)
  377.              (walk-$tree
  378.                  (lambda (l)
  379.                      (if ($lambda? l)
  380.                      (begin (print-lambda-info
  381.                             ($lambda-id l)
  382.                             sc-icode)
  383.                         (newline sc-icode))))
  384.                  tree))
  385.          forms))
  386.      (if (log? 'tree)
  387.          (begin (pp$t-list forms sc-icode)
  388.             (newline sc-icode)
  389.             (pretty-print-$tree quote-constants sc-icode)
  390.             (newline sc-icode)))
  391.      
  392.      (if sc-log (format sc-icode "   ***** Code Generation ***** */~%"))
  393.      (if (zero? sc-error-cnt) (generate-code forms))))
  394.  
  395. ;;; Error messages are written in a standard form to the error file by the
  396. ;;; following function.  It will also keep a count of the number of errors.
  397.  
  398. (define (REPORT-ERROR msg . ls)
  399.     (if (not sc-error) (set! sc-error (current-output-port)))
  400.     (format sc-error "***** ERROR - ~a ~a" current-define-name msg)
  401.     (for-each (lambda (l) (format sc-error " ~a" l)) ls)
  402.     (newline sc-error)
  403.     (set! sc-error-cnt (+ 1 sc-error-cnt)))
  404.  
  405. ;;; Warning messages are written in a standard form to the error file by the
  406. ;;; following function.
  407.  
  408. (define (REPORT-WARNING msg . ls)
  409.     (if (not sc-error) (set! sc-error (current-output-port)))
  410.     (format sc-error "***** WARNING - ~a ~a" current-define-name msg)
  411.     (for-each (lambda (l) (format sc-error " ~a" l)) ls)
  412.     (newline sc-error))
  413.  
  414. ;;; $TREE pretty-printer.
  415.  
  416. (define (PRETTY-PRINT-$TREE tree out)
  417.     (let ((indent (write-count out))
  418.       (left (- (write-width out) (write-count out))))
  419.      (cond ((and ($call? tree) ($lambda? ($call-func tree)))
  420.         (let ((lid  ($lambda-id ($call-func tree))))
  421.              (pretty-print-$tree
  422.               `(<apply>
  423.                    ,($call-tail tree)
  424.                    ,lid
  425.                    ,@(pp$t-lambda-bind (lambda-reqvars lid)
  426.                      (lambda-optvars lid) ($call-argl tree))
  427.                    ,@($lambda-body ($call-func tree)))
  428.               out)))
  429.            ((or (not (pair? tree)) (>= (print-in tree left) 0))
  430.         (write tree out))
  431.            ((and (eq? (car tree) '<apply>)
  432.              (>= (print-in (list (car tree) (cadr tree) (caddr tree))
  433.                  left)
  434.              0))
  435.         (format out "(~S ~S ~S" (car tree) (cadr tree) (caddr tree))
  436.         (for-each
  437.             (lambda (x)
  438.                 (newline out)
  439.                 (set-write-count! out (+ indent 1))
  440.                 (pretty-print-$tree x out))
  441.             (cdddr tree))
  442.         (format out ")"))
  443.            ((and (memq (car tree) '($define $if $lambda))
  444.              (>= (print-in (list (car tree) (cadr tree)) left) 0))
  445.         (format out "(~S ~S" (car tree) (cadr tree))
  446.         (for-each
  447.             (lambda (x)
  448.                 (newline out)
  449.                 (set-write-count! out (+ indent 5))
  450.                 (pretty-print-$tree x out))
  451.             (cddr tree))
  452.         (format out ")"))
  453.            (else
  454.             (format out "(")
  455.             (pretty-print-$tree (car tree) out)
  456.             (let loop ((tree (cdr tree)))
  457.              (cond ((pair? tree)
  458.                 (newline out)
  459.                 (set-write-count! out (+ indent 2))
  460.                 (pretty-print-$tree (car tree) out)
  461.                 (loop (cdr tree)))
  462.                    (tree
  463.                 (newline out)
  464.                 (set-write-count! out (+ indent 2))
  465.                 (display ". " out)
  466.                 (pretty-print-$tree tree out))))
  467.             (format out ")")))))
  468.  
  469. (define (PP$T-LAMBDA-BIND reqvars optvars vals)
  470.     (cond ((null? reqvars)
  471.        (if optvars
  472.            `((,(car optvars) <- ,vals))
  473.            '()))
  474.       (else
  475.        (cons `(,(car reqvars) <- ,(car vals))
  476.          (pp$t-lambda-bind (cdr reqvars) optvars (cdr vals))))))
  477.  
  478. (define (PP$T-LIST forms out)
  479.     (for-each (lambda (form) (pretty-print-$tree form out) (newline out))
  480.     forms))
  481.  
  482. ;;; Space out to a certain column on an output port.
  483.  
  484. (define (SET-WRITE-COUNT! out cnt)
  485.     (do ((i (- cnt (write-count out)) (- i 1)))
  486.     ((<= i 0))
  487.     (write-char #\space out)))
  488.  
  489. ;;; See if an object "s" will print in "len" characters or less.  It will
  490. ;;; return the number of characters left, or a negative number if the object
  491. ;;; won't fit.
  492.  
  493. (define (PRINT-IN s len)
  494.     (if (not (negative? len))
  495.     (begin (if (vector? s) (set! s (vector->list s)))
  496.            (if (pair? s)
  497.            (print-in (cdr s) (- (print-in (car s) len) 1))
  498.            (- len (string-length (format "~s" s)))))
  499.     len))
  500.  
  501. ;;; Down case a string.
  502.  
  503. (define (STRING-DOWNCASE s)
  504.     (do ((i (- (string-length s) 1) (- i 1))
  505.      (t (make-string (string-length s))))
  506.     ((= i -1) t)
  507.     (string-set! t i (char-downcase (string-ref s i)))))
  508.  
  509. ;;; Return the first "n" items of list "l".
  510.  
  511. (define (LIST-HEAD l n)
  512.     (if (zero? n) '() (cons (car l) (list-head (cdr l) (- n 1)))))
  513.