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