Commit | Line | Data |
---|---|---|
cb4cca12 KN |
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) | |
8f5cfc81 | 23 | :use-syntax (system base syntax) |
cb4cca12 | 24 | :use-module (system base language) |
8f5cfc81 | 25 | :use-module (system il compile) |
ac99cb0c | 26 | :use-module (system il glil) |
8f5cfc81 KN |
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 | ||
ac99cb0c | 35 | (define-record (<cenv> vm language module)) |
8f5cfc81 KN |
36 | |
37 | (define-public (make-cenv . rest) | |
ac99cb0c | 38 | (apply <cenv> rest)) |
8f5cfc81 KN |
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) | |
d8eeb67c LC |
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)))) | |
8f5cfc81 KN |
48 | |
49 | \f | |
50 | ;;; | |
51 | ;;; Compiler | |
52 | ;;; | |
cb4cca12 KN |
53 | |
54 | (define scheme (lookup-language 'scheme)) | |
55 | ||
8f5cfc81 KN |
56 | (define-public (compile-file file . opts) |
57 | (let ((comp (compiled-file-name file))) | |
58 | (catch #t | |
59 | (lambda () | |
054599f1 LC |
60 | ; (call-with-compile-error-catch |
61 | ; (lambda () | |
cb4cca12 KN |
62 | (call-with-output-file comp |
63 | (lambda (port) | |
8f5cfc81 KN |
64 | (let* ((source (read-file-in file scheme)) |
65 | (objcode (apply compile-in source (current-module) | |
66 | scheme opts))) | |
ac99cb0c KN |
67 | (if (memq :c opts) |
68 | (pprint-glil objcode port) | |
054599f1 LC |
69 | (uniform-vector-write (objcode->u8vector objcode) port))))) |
70 | (format #t "Wrote ~A\n" comp)) | |
8f5cfc81 | 71 | (lambda (key . args) |
f21dfea6 | 72 | (format #t "ERROR: During compiling ~A:\n" file) |
8f5cfc81 | 73 | (display "ERROR: ") |
f21dfea6 | 74 | (apply format #t (cadr args) (caddr args)) |
8f5cfc81 | 75 | (newline) |
f21dfea6 | 76 | (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args)) |
8f5cfc81 KN |
77 | (delete-file comp))))) |
78 | ||
054599f1 LC |
79 | ; (let ((c-f compile-file)) |
80 | ; ;; XXX: Debugging output | |
81 | ; (set! compile-file | |
82 | ; (lambda (file . opts) | |
83 | ; (format #t "compile-file: ~a ~a~%" file opts) | |
84 | ; (let ((result (apply c-f (cons file opts)))) | |
85 | ; (format #t "compile-file: returned ~a~%" result) | |
86 | ; result)))) | |
87 | ||
8f5cfc81 KN |
88 | (define-public (load-source-file file . opts) |
89 | (let ((source (read-file-in file scheme))) | |
f21dfea6 | 90 | (apply compile-in source (current-module) scheme opts))) |
8f5cfc81 KN |
91 | |
92 | (define-public (load-file file . opts) | |
93 | (let ((comp (compiled-file-name file))) | |
94 | (if (file-exists? comp) | |
f21dfea6 | 95 | (load-objcode comp) |
8f5cfc81 KN |
96 | (apply load-source-file file opts)))) |
97 | ||
98 | (define-public (compiled-file-name file) | |
cb4cca12 KN |
99 | (let ((m (string-match "\\.[^.]*$" file))) |
100 | (string-append (if m (match:prefix m) file) ".go"))) | |
8f5cfc81 | 101 | |
7a0d0cee KN |
102 | (define-public (scheme-eval x e) |
103 | (vm-load (the-vm) (compile-in x e scheme))) | |
104 | ||
8f5cfc81 KN |
105 | \f |
106 | ;;; | |
107 | ;;; Scheme compiler interface | |
108 | ;;; | |
109 | ||
110 | (define-public (read-file-in file lang) | |
111 | (call-with-input-file file lang.read-file)) | |
112 | ||
113 | (define-public (compile-in x e lang . opts) | |
114 | (catch 'result | |
115 | (lambda () | |
116 | ;; expand | |
117 | (set! x (lang.expander x e)) | |
118 | (if (memq :e opts) (throw 'result x)) | |
119 | ;; translate | |
120 | (set! x (lang.translator x e)) | |
121 | (if (memq :t opts) (throw 'result x)) | |
122 | ;; compile | |
123 | (set! x (apply compile x e opts)) | |
124 | (if (memq :c opts) (throw 'result x)) | |
125 | ;; assemble | |
126 | (apply assemble x e opts)) | |
127 | (lambda (key val) val))) | |
128 | ||
129 | ;;; | |
130 | ;;; | |
131 | ;;; | |
132 | ||
133 | (define (compile-and-load file . opts) | |
134 | (let ((comp (object-file-name file))) | |
135 | (if (or (not (file-exists? comp)) | |
136 | (> (stat:mtime (stat file)) (stat:mtime (stat comp)))) | |
137 | (compile-file file)) | |
138 | (load-compiled-file comp))) | |
139 | ||
140 | (define (load/compile file . opts) | |
141 | (let* ((file (file-full-name file)) | |
142 | (compiled (object-file-name file))) | |
143 | (if (or (not (file-exists? compiled)) | |
144 | (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) | |
145 | (apply compile-file file #f opts)) | |
146 | (if (memq #:b opts) | |
147 | (apply vm-trace (the-vm) (load-objcode compiled) opts) | |
148 | ((the-vm) (load-objcode compiled))))) | |
149 | ||
150 | (define (file-full-name filename) | |
151 | (let* ((port (current-load-port)) | |
152 | (oldname (and port (port-filename port)))) | |
153 | (if (and oldname | |
154 | (> (string-length filename) 0) | |
155 | (not (char=? (string-ref filename 0) #\/)) | |
156 | (not (string=? (dirname oldname) "."))) | |
157 | (string-append (dirname oldname) "/" filename) | |
158 | filename))) |