Commit | Line | Data |
---|---|---|
17e90c5e KN |
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) | |
17e90c5e | 25 | :use-module (system il compile) |
4b24d33c | 26 | :use-module (system vm core) |
17e90c5e KN |
27 | :use-module (system vm assemble) |
28 | :use-module (ice-9 regex) | |
29 | :export (define-language lookup-language | |
d4ae3ae6 | 30 | read-in compile-in print-in compile-file-in load-file-in)) |
17e90c5e KN |
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"))) |