module/system/base/language.scm

   1 ;;; Multi-language support
   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 language)
  23   :use-module (oop goops)
  24   :use-syntax (system base syntax)
  25   :use-module (system base module)
  26   :use-module (system il compile)
  27   :use-module (system vm assemble)
  28   :use-module (ice-9 regex)
  29   :export (define-language lookup-language
  30             read-in compile-in print-in compile-file-in load-file-in))
  31
  32 \f
  33 ;;;
  34 ;;; Language class
  35 ;;;
  36
  37 (define-vm-class <language> ()
  38   name title version environment
  39   (reader)
  40   (expander (lambda (x) x))
  41   (translator (lambda (x) x))
  42   (evaler #f)
  43   (printer)
  44   )
  45
  46 (define-method (write (lang <language>) port)
  47   (display "#<language " port)
  48   (display lang.name port)
  49   (display ">"))
  50
  51 (define-macro (define-language name . spec)
  52   `(define ,name (,make ,<language> :name ',name ,@spec)))
  53
  54 (define (lookup-language name)
  55   (let ((m (resolve-module `(language ,name spec))))
  56     (if (module-bound? m name)
  57         (module-ref m name)
  58         (error "No such language:" name))))
  59
  60 \f
  61 ;;;
  62 ;;; Evaluation interface
  63 ;;;
  64
  65 (define (read-in lang . port)
  66   (lang.reader (if (null? port) (current-input-port) (car port))))
  67
  68 (define (compile-in form env lang . opts)
  69   (catch 'result
  70     (lambda ()
  71       ;; expand
  72       (set! form (lang.expander form))
  73       (if (memq :e opts) (throw 'result form))
  74       ;; translate
  75       (set! form (lang.translator form))
  76       (if (memq :t opts) (throw 'result form))
  77       ;; compile
  78       (set! form (apply compile form env opts))
  79       (if (memq :c opts) (throw 'result form))
  80       ;; assemble
  81       (apply assemble form env opts))
  82     (lambda (key val) val)))
  83
  84 (define (print-in val lang . port)
  85   (lang.printer val (if (null? port) (current-output-port) (car port))))
  86
  87 (define (compile-file-in file env lang . opts)
  88   (let* ((code (call-with-input-file file
  89                  (lambda (in)
  90                    (do ((x (read-in lang in) (read-in lang in))
  91                         (l '() (cons (lang.translator (lang.expander x)) l)))
  92                        ((eof-object? x) (reverse! l))))))
  93          (asm (apply compile (cons '@begin code) env opts))
  94          (bytes (apply assemble asm env opts)))
  95     (call-with-output-file (object-file-name file)
  96       (lambda (out) (uniform-vector-write bytes out)))))
  97
  98 (define (load-file-in file env lang)
  99   (let ((compiled (object-file-name file)))
 100     (if (or (not (file-exists? compiled))
 101             (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
 102         (compile-file-in file env lang))
 103     (call-with-input-file compiled
 104       (lambda (p)
 105         (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
 106           (uniform-vector-read! bytes p)
 107           bytes)))))
 108
 109 (define (object-file-name file)
 110   (let ((m (string-match "\\.[^.]*$" file)))
 111     (string-append (if m (match:prefix m) file) ".go")))