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-syntax (system base syntax)
  24   :use-module (system base language)
  25   :use-module (system il compile)
  26   :use-module (system il glil)
  27   :use-module (system vm objcode)
  28   :use-module (system vm vm) ;; for compile-time evaluation
  29   :use-module (system vm assemble)
  30   :use-module (ice-9 regex)
  31   :export (syntax-error compile-file load-source-file load-file
  32            compiled-file-name
  33            scheme-eval read-file-in compile-in
  34            load/compile))
  35
  36 ;;;
  37 ;;; Compiler environment
  38 ;;;
  39
  40 (define (syntax-error loc msg exp)
  41   (throw 'syntax-error loc msg exp))
  42
  43 (define-macro (call-with-compile-error-catch thunk)
  44   `(catch 'syntax-error
  45          ,thunk
  46          (lambda (key loc msg exp)
  47            (if (pair? loc)
  48                (format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
  49                (format #t "unknown location: ~A: ~A~%" msg exp)))))
  50
  51 (export-syntax  call-with-compile-error-catch)
  52
  53
  54 \f
  55 ;;;
  56 ;;; Compiler
  57 ;;;
  58
  59 (define (scheme) (lookup-language 'scheme))
  60
  61 (define (compile-file file . opts)
  62   (let ((comp (compiled-file-name file))
  63         (scheme (scheme)))
  64     (catch 'nothing-at-all
  65       (lambda ()
  66         (call-with-compile-error-catch
  67          (lambda ()
  68            (call-with-output-file comp
  69              (lambda (port)
  70                (let* ((source (read-file-in file scheme))
  71                       (objcode (apply compile-in source (current-module)
  72                                       scheme opts)))
  73                  (if (memq :c opts)
  74                    (pprint-glil objcode port)
  75                    (uniform-vector-write (objcode->u8vector objcode) port)))))
  76            (format #t "wrote `~A'\n" comp))))
  77       (lambda (key . args)
  78         (format #t "ERROR: during compilation of ~A:\n" file)
  79         (display "ERROR: ")
  80         (apply format #t (cadr args) (caddr args))
  81         (newline)
  82         (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
  83         (delete-file comp)))))
  84
  85 ; (let ((c-f compile-file))
  86 ;   ;; XXX:  Debugging output
  87 ;   (set! compile-file
  88 ;       (lambda (file . opts)
  89 ;         (format #t "compile-file: ~a ~a~%" file opts)
  90 ;         (let ((result (apply c-f (cons file opts))))
  91 ;           (format #t "compile-file: returned ~a~%" result)
  92 ;           result))))
  93
  94 (define (load-source-file file . opts)
  95   (let ((source (read-file-in file (scheme))))
  96     (apply compile-in source (current-module) (scheme) opts)))
  97
  98 (define (load-file file . opts)
  99   (let ((comp (compiled-file-name file)))
 100     (if (file-exists? comp)
 101         (load-objcode comp)
 102         (apply load-source-file file opts))))
 103
 104 (define (compiled-file-name file)
 105   (let ((base (basename file)))
 106     (let ((m (string-match "\\.scm$" base)))
 107       (string-append (if m (match:prefix m) base) ".go"))))
 108
 109 (define (scheme-eval x e)
 110   (vm-load (the-vm) (compile-in x e (scheme))))
 111
 112 \f
 113 ;;;
 114 ;;; Scheme compiler interface
 115 ;;;
 116
 117 (define (read-file-in file lang)
 118   (call-with-input-file file (language-read-file lang)))
 119
 120 (define (compile-in x e lang . opts)
 121   (save-module-excursion
 122    (lambda ()
 123      (catch 'result
 124       (lambda ()
 125         ;; expand
 126         (set! x ((language-expander lang) x e))
 127         (if (memq :e opts) (throw 'result x))
 128         ;; translate
 129         (set! x ((language-translator lang) x e))
 130         (if (memq :t opts) (throw 'result x))
 131         ;; compile
 132         (set! x (apply compile x e opts))
 133         (if (memq :c opts) (throw 'result x))
 134         ;; assemble
 135         (apply assemble x e opts))
 136       (lambda (key val) val)))))
 137
 138 ;;;
 139 ;;;
 140 ;;;
 141
 142 (define (compile-and-load file . opts)
 143   (let ((comp (object-file-name file)))
 144     (if (or (not (file-exists? comp))
 145             (> (stat:mtime (stat file)) (stat:mtime (stat comp))))
 146         (compile-file file))
 147     (load-compiled-file comp)))
 148
 149 (define (load/compile file . opts)
 150   (let* ((file (file-full-name file))
 151          (compiled (object-file-name file)))
 152     (if (or (not (file-exists? compiled))
 153             (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
 154         (apply compile-file file #f opts))
 155     (if (memq #:b opts)
 156         (apply vm-trace (the-vm) (load-objcode compiled) opts)
 157         ((the-vm) (load-objcode compiled)))))
 158
 159 (define (file-full-name filename)
 160   (let* ((port (current-load-port))
 161          (oldname (and port (port-filename port))))
 162     (if (and oldname
 163              (> (string-length filename) 0)
 164              (not (char=? (string-ref filename 0) #\/))
 165              (not (string=? (dirname oldname) ".")))
 166         (string-append (dirname oldname) "/" filename)
 167         filename)))