module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (system base compile)
  23   #:use-module (system base syntax)
  24   #:use-module (system base language)
  25   #:use-module (language objcode spec)
  26   #:use-module (language value spec)
  27   #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
  28   #:use-module (ice-9 regex)
  29   #:use-module (ice-9 optargs)
  30   #:use-module (ice-9 receive)
  31   #:export (syntax-error
  32             *current-language*
  33             compiled-file-name compile-file compile-and-load
  34             compile compile-time-environment)
  35   #:export-syntax (call-with-compile-error-catch))
  36
  37 ;;;
  38 ;;; Compiler environment
  39 ;;;
  40
  41 (define (syntax-error loc msg exp)
  42   (throw 'syntax-error-compile-time loc msg exp))
  43
  44 (define-macro (call-with-compile-error-catch thunk)
  45   `(catch 'syntax-error-compile-time
  46          ,thunk
  47          (lambda (key loc msg exp)
  48            (if (pair? loc)
  49                (format (current-error-port)
  50                        "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
  51                (format (current-error-port)
  52                        "unknown location: ~A: ~A~%" msg exp)))))
  53
  54 \f
  55 ;;;
  56 ;;; Compiler
  57 ;;;
  58
  59 (define *current-language* (make-fluid))
  60 (define (current-language)
  61   (or (fluid-ref *current-language*)
  62       (begin (fluid-set! *current-language* (lookup-language 'scheme))
  63              (current-language))))
  64
  65 (define (call-once thunk)
  66   (let ((entered #f))
  67     (dynamic-wind
  68         (lambda ()
  69           (if entered
  70               (error "thunk may only be entered once: ~a" thunk))
  71           (set! entered #t))
  72         thunk
  73         (lambda () #t))))
  74
  75 (define (call-with-output-file/atomic filename proc)
  76   (let* ((template (string-append filename ".XXXXXX"))
  77          (tmp (mkstemp! template)))
  78     (call-once
  79      (lambda ()
  80        (with-throw-handler #t
  81          (lambda ()
  82            (with-output-to-port tmp
  83              (lambda () (proc (current-output-port))))
  84            (rename-file template filename))
  85          (lambda args
  86            (delete-file template)))))))
  87
  88 (define* (compile-file file #:key (to objcode) (opts '()))
  89   (let ((comp (compiled-file-name file))
  90         (lang (current-language)))
  91     (catch 'nothing-at-all
  92       (lambda ()
  93         (call-with-compile-error-catch
  94          (lambda ()
  95            (call-with-output-file/atomic comp
  96              (lambda (port)
  97                (let ((print (language-printer to)))
  98                  (print (compile (read-file-in file lang)
  99                                  #:from lang #:to to #:opts opts)
 100                         port))))
 101            (format #t "wrote `~A'\n" comp))))
 102       (lambda (key . args)
 103         (format #t "ERROR: during compilation of ~A:\n" file)
 104         (display "ERROR: ")
 105         (apply format #t (cadr args) (caddr args))
 106         (newline)
 107         (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
 108         (delete-file comp)))))
 109
 110 (define* (compile-and-load file #:key (to value) (opts '()))
 111   (let ((lang (current-language)))
 112     (compile (read-file-in file lang) #:to value #:opts opts)))
 113
 114 (define (compiled-file-name file)
 115   (let ((base (basename file))
 116         (cext (cond ((or (null? %load-compiled-extensions)
 117                          (string-null? (car %load-compiled-extensions)))
 118                      (warn "invalid %load-compiled-extensions"
 119                            %load-compiled-extensions)
 120                      ".go")
 121                     (else (car %load-compiled-extensions)))))
 122     (let lp ((exts %load-extensions))
 123       (cond ((null? exts) (string-append base cext))
 124             ((string-null? (car exts)) (lp (cdr exts)))
 125             ((string-suffix? (car exts) base)
 126              (string-append
 127               (substring base 0
 128                          (- (string-length base) (string-length (car exts))))
 129               cext))
 130             (else (lp (cdr exts)))))))
 131
 132 \f
 133 ;;;
 134 ;;; Compiler interface
 135 ;;;
 136
 137 (define (read-file-in file lang)
 138   (call-with-input-file file
 139     (or (language-read-file lang)
 140         (error "language has no #:read-file" lang))))
 141
 142 (define (compile-passes from to opts)
 143   (let lp ((langs (or (lookup-compilation-order from to)
 144                       (error "no way to compile" (language-name from)
 145                              "to" (language-name to))))
 146            (out '()))
 147     (if (null? (cdr langs))
 148         (reverse! out)
 149         (lp (cdr langs)
 150             (cons (assq-ref (language-compilers (car langs)) (cadr langs))
 151                   out)))))
 152
 153 (define (compile-fold passes exp env opts)
 154   (if (null? passes)
 155       exp
 156       (receive (exp env) ((car passes) exp env opts)
 157         (compile-fold (cdr passes) exp env opts))))
 158
 159 (define (compile-time-environment)
 160   "A special function known to the compiler that, when compiled, will
 161 return a representation of the lexical environment in place at compile
 162 time. Useful for supporting some forms of dynamic compilation. Returns
 163 #f if called from the interpreter."
 164   #f)
 165
 166 (define* (compile x #:key
 167                   (env #f)
 168                   (from (current-language))
 169                   (to value)
 170                   (opts '()))
 171   (compile-fold (compile-passes from to opts)
 172                 x
 173                 env
 174                 opts))