module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001, 2009 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 (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 optargs)
  28   #:use-module (ice-9 receive)
  29   #:export (syntax-error
  30             *current-language*
  31             compiled-file-name compile-file compile-and-load
  32             compile compile-time-environment
  33             decompile)
  34   #:export-syntax (call-with-compile-error-catch))
  35
  36 ;;;
  37 ;;; Compiler environment
  38 ;;;
  39
  40 (define (syntax-error loc msg exp)
  41   (throw 'syntax-error-compile-time loc msg exp))
  42
  43 (define-macro (call-with-compile-error-catch thunk)
  44   `(catch 'syntax-error-compile-time
  45          ,thunk
  46          (lambda (key loc msg exp)
  47            (if (pair? loc)
  48                (format (current-error-port)
  49                        "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
  50                (format (current-error-port)
  51                        "unknown location: ~A: ~S~%" msg exp)))))
  52
  53 \f
  54 ;;;
  55 ;;; Compiler
  56 ;;;
  57
  58 (define *current-language* (make-fluid))
  59 (fluid-set! *current-language* 'scheme)
  60 (define (current-language)
  61   (fluid-ref *current-language*))
  62
  63 (define (call-once thunk)
  64   (let ((entered #f))
  65     (dynamic-wind
  66         (lambda ()
  67           (if entered
  68               (error "thunk may only be entered once: ~a" thunk))
  69           (set! entered #t))
  70         thunk
  71         (lambda () #t))))
  72
  73 (define (call-with-output-file/atomic filename proc)
  74   (let* ((template (string-append filename ".XXXXXX"))
  75          (tmp (mkstemp! template)))
  76     (call-once
  77      (lambda ()
  78        (with-throw-handler #t
  79          (lambda ()
  80            (proc tmp)
  81            (close-port tmp)
  82            (rename-file template filename))
  83          (lambda args
  84            (delete-file template)))))))
  85
  86 (define (ensure-language x)
  87   (if (language? x)
  88       x
  89       (lookup-language x)))
  90
  91 (define* (compile-file file #:key (to 'objcode) (opts '()))
  92   (let ((comp (compiled-file-name file))
  93         (lang (ensure-language (current-language)))
  94         (to (ensure-language to)))
  95     (catch 'nothing-at-all
  96       (lambda ()
  97         (call-with-compile-error-catch
  98          (lambda ()
  99            (call-with-output-file/atomic comp
 100              (lambda (port)
 101                (let ((print (language-printer to)))
 102                  (print (compile (read-file-in file lang)
 103                                  #:from lang #:to to #:opts opts)
 104                         port))))
 105            (format #t "wrote `~A'\n" comp))))
 106       (lambda (key . args)
 107         (format #t "ERROR: during compilation of ~A:\n" file)
 108         (display "ERROR: ")
 109         (apply format #t (cadr args) (caddr args))
 110         (newline)
 111         (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
 112         (delete-file comp)))))
 113
 114 (define* (compile-and-load file #:key (to 'value) (opts '()))
 115   (let ((lang (ensure-language (current-language))))
 116     (compile (read-file-in file lang) #:to 'value #:opts opts)))
 117
 118 (define (compiled-file-name file)
 119   (let ((base (basename file))
 120         (cext (cond ((or (null? %load-compiled-extensions)
 121                          (string-null? (car %load-compiled-extensions)))
 122                      (warn "invalid %load-compiled-extensions"
 123                            %load-compiled-extensions)
 124                      ".go")
 125                     (else (car %load-compiled-extensions)))))
 126     (let lp ((exts %load-extensions))
 127       (cond ((null? exts) (string-append file cext))
 128             ((string-null? (car exts)) (lp (cdr exts)))
 129             ((string-suffix? (car exts) base)
 130              (string-append
 131               (dirname file) "/"
 132               (substring base 0
 133                          (- (string-length base) (string-length (car exts))))
 134               cext))
 135             (else (lp (cdr exts)))))))
 136
 137 \f
 138 ;;;
 139 ;;; Compiler interface
 140 ;;;
 141
 142 (define (read-file-in file lang)
 143   (call-with-input-file file
 144     (or (language-read-file lang)
 145         (error "language has no #:read-file" lang))))
 146
 147 (define (compile-passes from to opts)
 148   (map cdr
 149        (or (lookup-compilation-order from to)
 150            (error "no way to compile" from "to" to))))
 151
 152 (define (compile-fold passes exp env opts)
 153   (if (null? passes)
 154       exp
 155       (receive (exp env) ((car passes) exp env opts)
 156         (compile-fold (cdr passes) exp env opts))))
 157
 158 (define (compile-time-environment)
 159   "A special function known to the compiler that, when compiled, will
 160 return a representation of the lexical environment in place at compile
 161 time. Useful for supporting some forms of dynamic compilation. Returns
 162 #f if called from the interpreter."
 163   #f)
 164
 165 (define* (compile x #:key
 166                   (env #f)
 167                   (from (current-language))
 168                   (to 'value)
 169                   (opts '()))
 170   (compile-fold (compile-passes from to opts)
 171                 x
 172                 env
 173                 opts))
 174
 175 \f
 176 ;;;
 177 ;;; Decompiler interface
 178 ;;;
 179
 180 (define (decompile-passes from to opts)
 181   (map cdr
 182        (or (lookup-decompilation-order from to)
 183            (error "no way to decompile" from "to" to))))
 184
 185 (define (decompile-fold passes exp env opts)
 186   (if (null? passes)
 187       (values exp env)
 188       (receive (exp env) ((car passes) exp env opts)
 189         (decompile-fold (cdr passes) exp env opts))))
 190
 191 (define* (decompile x #:key
 192                     (env #f)
 193                     (from 'value)
 194                     (to 'assembly)
 195                     (opts '()))
 196   (decompile-fold (decompile-passes from to opts)
 197                   x
 198                   env
 199                   opts))