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
  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 #:key
  96                        (output-file #f)
  97                        (env #f)
  98                        (from (current-language))
  99                        (to 'objcode)
 100                        (opts '()))
 101   (let ((comp (or output-file (compiled-file-name file)))
 102         (in (open-input-file file)))
 103     (call-with-output-file/atomic comp
 104       (lambda (port)
 105         ((language-printer (ensure-language to))
 106          (read-and-compile in #:env env #:from from #:to to #:opts opts)
 107          port)))
 108     comp))
 109
 110 (define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
 111   (read-and-compile (open-input-file file)
 112                     #:from from #:to to #: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 file cext))
 124             ((string-null? (car exts)) (lp (cdr exts)))
 125             ((string-suffix? (car exts) base)
 126              (string-append
 127               (dirname file) "/"
 128               (substring base 0
 129                          (- (string-length base) (string-length (car exts))))
 130               cext))
 131             (else (lp (cdr exts)))))))
 132
 133 \f
 134 ;;;
 135 ;;; Compiler interface
 136 ;;;
 137
 138 (define (compile-passes from to opts)
 139   (map cdr
 140        (or (lookup-compilation-order from to)
 141            (error "no way to compile" from "to" to))))
 142
 143 (define (compile-fold passes exp env opts)
 144   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 145     (if (null? passes)
 146         (values x e cenv)
 147         (receive (x e new-cenv) ((car passes) x e opts)
 148           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 149
 150 (define (find-language-joint from to)
 151   (let lp ((in (reverse (or (lookup-compilation-order from to)
 152                             (error "no way to compile" from "to" to))))
 153            (lang to))
 154     (cond ((null? in)
 155            (error "don't know how to join expressions" from to))
 156           ((language-joiner lang) lang)
 157           (else
 158            (lp (cdr in) (caar in))))))
 159
 160 (define* (read-and-compile port #:key
 161                            (env #f)
 162                            (from (current-language))
 163                            (to 'objcode)
 164                            (opts '()))
 165   (let ((from (ensure-language from))
 166         (to (ensure-language to)))
 167     (let ((joint (find-language-joint from to)))
 168       (with-fluids ((*current-language* from))
 169         (let lp ((exps '()) (env #f) (cenv env))
 170           (let ((x ((language-reader (current-language)) port)))
 171             (cond
 172              ((eof-object? x)
 173               (compile ((language-joiner joint) (reverse exps) env)
 174                        #:from joint #:to to #:env env #:opts opts))
 175              (else
 176               ;; compile-fold instead of compile so we get the env too
 177               (receive (jexp jenv jcenv)
 178                   (compile-fold (compile-passes (current-language) joint opts)
 179                                 x cenv opts)
 180                 (lp (cons jexp exps) jenv jcenv))))))))))
 181
 182 (define* (compile x #:key
 183                   (env #f)
 184                   (from (current-language))
 185                   (to 'value)
 186                   (opts '()))
 187   (receive (exp env cenv)
 188       (compile-fold (compile-passes from to opts) x env opts)
 189     exp))
 190
 191 \f
 192 ;;;
 193 ;;; Decompiler interface
 194 ;;;
 195
 196 (define (decompile-passes from to opts)
 197   (map cdr
 198        (or (lookup-decompilation-order from to)
 199            (error "no way to decompile" from "to" to))))
 200
 201 (define (decompile-fold passes exp env opts)
 202   (if (null? passes)
 203       (values exp env)
 204       (receive (exp env) ((car passes) exp env opts)
 205         (decompile-fold (cdr passes) exp env opts))))
 206
 207 (define* (decompile x #:key
 208                     (env #f)
 209                     (from 'value)
 210                     (to 'assembly)
 211                     (opts '()))
 212   (decompile-fold (decompile-passes from to opts)
 213                   x
 214                   env
 215                   opts))