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 core)
  28   :use-module (system vm assemble)
  29   :use-module (ice-9 regex))
  30
  31 ;;;
  32 ;;; Compiler environment
  33 ;;;
  34
  35 (define-record (<cenv> vm language module))
  36
  37 (define-public (make-cenv . rest)
  38   (apply <cenv> rest))
  39
  40 (define-public (syntax-error loc msg exp)
  41   (throw 'syntax-error loc msg exp))
  42
  43 (define-public (call-with-compile-error-catch thunk)
  44   (catch 'syntax-error
  45          (thunk)
  46          (lambda (key loc msg exp)
  47            (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
  48
  49 \f
  50 ;;;
  51 ;;; Compiler
  52 ;;;
  53
  54 (define scheme (lookup-language 'scheme))
  55
  56 (define-public (compile-file file . opts)
  57   (let ((comp (compiled-file-name file)))
  58     (catch #t
  59       (lambda ()
  60         (call-with-compile-error-catch
  61          (lambda ()
  62            (call-with-output-file comp
  63              (lambda (port)
  64                (let* ((source (read-file-in file scheme))
  65                       (objcode (apply compile-in source (current-module)
  66                                       scheme opts)))
  67                  (if (memq :c opts)
  68                    (pprint-glil objcode port)
  69                    (uniform-array-write (objcode->string objcode) port)))))
  70            (format #t "Wrote ~A\n" comp))))
  71       (lambda (key . args)
  72         (format #t "ERROR: During compiling ~A:\n" file)
  73         (display "ERROR: ")
  74         (apply format #t (cadr args) (caddr args))
  75         (newline)
  76         (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
  77         (delete-file comp)))))
  78
  79 (define-public (load-source-file file . opts)
  80   (let ((source (read-file-in file scheme)))
  81     (apply compile-in source (current-module) scheme opts)))
  82
  83 (define-public (load-file file . opts)
  84   (let ((comp (compiled-file-name file)))
  85     (if (file-exists? comp)
  86         (load-objcode comp)
  87         (apply load-source-file file opts))))
  88
  89 (define-public (compiled-file-name file)
  90   (let ((m (string-match "\\.[^.]*$" file)))
  91     (string-append (if m (match:prefix m) file) ".go")))
  92
  93 (define-public (scheme-eval x e)
  94   (vm-load (the-vm) (compile-in x e scheme)))
  95
  96 \f
  97 ;;;
  98 ;;; Scheme compiler interface
  99 ;;;
 100
 101 (define-public (read-file-in file lang)
 102   (call-with-input-file file lang.read-file))
 103
 104 (define-public (compile-in x e lang . opts)
 105   (catch 'result
 106     (lambda ()
 107       ;; expand
 108       (set! x (lang.expander x e))
 109       (if (memq :e opts) (throw 'result x))
 110       ;; translate
 111       (set! x (lang.translator x e))
 112       (if (memq :t opts) (throw 'result x))
 113       ;; compile
 114       (set! x (apply compile x e opts))
 115       (if (memq :c opts) (throw 'result x))
 116       ;; assemble
 117       (apply assemble x e opts))
 118     (lambda (key val) val)))
 119
 120 ;;;
 121 ;;;
 122 ;;;
 123
 124 (define (compile-and-load file . opts)
 125   (let ((comp (object-file-name file)))
 126     (if (or (not (file-exists? comp))
 127             (> (stat:mtime (stat file)) (stat:mtime (stat comp))))
 128         (compile-file file))
 129     (load-compiled-file comp)))
 130
 131 (define (load/compile file . opts)
 132   (let* ((file (file-full-name file))
 133          (compiled (object-file-name file)))
 134     (if (or (not (file-exists? compiled))
 135             (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
 136         (apply compile-file file #f opts))
 137     (if (memq #:b opts)
 138         (apply vm-trace (the-vm) (load-objcode compiled) opts)
 139         ((the-vm) (load-objcode compiled)))))
 140
 141 (define (file-full-name filename)
 142   (let* ((port (current-load-port))
 143          (oldname (and port (port-filename port))))
 144     (if (and oldname
 145              (> (string-length filename) 0)
 146              (not (char=? (string-ref filename 0) #\/))
 147              (not (string=? (dirname oldname) ".")))
 148         (string-append (dirname oldname) "/" filename)
 149         filename)))