Commit | Line | Data |
---|---|---|
c7228382 KN |
1 | ;;; Guile Scheme specification |
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. | |
2335fb97 | 9 | ;; |
c7228382 KN |
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. | |
2335fb97 | 14 | ;; |
c7228382 KN |
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 (language scheme translate) | |
f245e62c | 23 | :use-module (system base pmatch) |
c7228382 KN |
24 | :use-module (system base language) |
25 | :use-module (system il ghil) | |
c7228382 | 26 | :use-module (ice-9 receive) |
2335fb97 | 27 | :use-module (srfi srfi-39) |
48302624 | 28 | :use-module ((system base compile) :select (syntax-error)) |
c7228382 KN |
29 | :export (translate)) |
30 | ||
2335fb97 | 31 | |
c7228382 | 32 | (define (translate x e) |
7d1c45d3 AW |
33 | (call-with-ghil-environment (make-ghil-mod e) '() |
34 | (lambda (env vars) | |
35 | (make-ghil-lambda env #f vars #f (trans env #f x))))) | |
c7228382 KN |
36 | |
37 | \f | |
38 | ;;; | |
39 | ;;; Translator | |
40 | ;;; | |
41 | ||
2335fb97 | 42 | (define %scheme-primitives |
8f5cfc81 KN |
43 | '(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!)) |
44 | ||
2335fb97 LC |
45 | (define %forbidden-primitives |
46 | ;; Guile's `procedure->macro' family is evil because it crosses the | |
47 | ;; compilation boundary. One solution might be to evaluate calls to | |
48 | ;; `procedure->memoizing-macro' at compilation time, but it may be more | |
49 | ;; compicated than that. | |
50 | '(procedure->syntax procedure->macro procedure->memoizing-macro)) | |
51 | ||
7d1c45d3 | 52 | (define (lookup-transformer e head retrans) |
1b8abe55 | 53 | (let* ((mod (ghil-mod-module (ghil-env-mod e))) |
9246a486 AW |
54 | (val (and=> (module-variable mod head) |
55 | (lambda (var) | |
56 | ;; unbound vars can happen if the module | |
57 | ;; definition forward-declared them | |
58 | (and (variable-bound? var) (variable-ref var)))))) | |
7d1c45d3 AW |
59 | (cond |
60 | ((or (primitive-macro? val) (eq? val eval-case)) | |
61 | (or (assq-ref primitive-syntax-table head) | |
62 | (syntax-error #f "unhandled primitive macro" head))) | |
63 | ||
64 | ((defmacro? val) | |
65 | (lambda (env loc exp) | |
66 | (retrans (apply (defmacro-transformer val) (cdr exp))))) | |
67 | ||
a52b96a7 AW |
68 | ((and (macro? val) (eq? (macro-name val) 'sc-macro)) |
69 | ;; syncase! | |
8f43eb2b AW |
70 | (let* ((the-syncase-module (resolve-module '(ice-9 syncase))) |
71 | (eec (module-ref the-syncase-module 'expansion-eval-closure)) | |
72 | (sc-expand3 (module-ref the-syncase-module 'sc-expand3))) | |
a52b96a7 | 73 | (lambda (env loc exp) |
8f43eb2b | 74 | (retrans |
1b8abe55 | 75 | (with-fluids ((eec (module-eval-closure mod))) |
8f43eb2b | 76 | (sc-expand3 exp 'c '(compile load eval))))))) |
a52b96a7 | 77 | |
7d1c45d3 AW |
78 | ((macro? val) |
79 | (syntax-error #f "unknown kind of macro" head)) | |
80 | ||
81 | (else #f)))) | |
82 | ||
c7228382 | 83 | (define (trans e l x) |
7d1c45d3 | 84 | (define (retrans x) (trans e l x)) |
c7228382 | 85 | (cond ((pair? x) |
7d1c45d3 AW |
86 | (let ((head (car x)) (tail (cdr x))) |
87 | (cond | |
88 | ((lookup-transformer e head retrans) | |
89 | => (lambda (t) (t e l x))) | |
90 | ||
91 | ;; FIXME: lexical/module overrides of scheme primitives | |
92 | ((memq head %scheme-primitives) | |
93 | (make-ghil-inline e l head (map retrans tail))) | |
94 | ||
95 | ;; FIXME: lexical/module overrides of forbidden primitives | |
96 | ((memq head %forbidden-primitives) | |
97 | (syntax-error l (format #f "`~a' is forbidden" head) | |
98 | (cons head tail))) | |
99 | (else | |
100 | (make-ghil-call e l (retrans head) (map retrans tail)))))) | |
101 | ||
f21dfea6 | 102 | ((symbol? x) |
540d9d87 | 103 | (make-ghil-ref e l (ghil-lookup e x))) |
7d1c45d3 | 104 | |
7d1c45d3 AW |
105 | ;; fixme: non-self-quoting objects like #<foo> |
106 | (else | |
10be7025 | 107 | (make-ghil-quote e l #:obj x)))) |
c7228382 | 108 | |
f245e62c AW |
109 | (define (valid-bindings? bindings . it-is-for-do) |
110 | (define (valid-binding? b) | |
111 | (pmatch b | |
112 | ((,sym ,var) (guard (symbol? sym)) #t) | |
113 | ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) | |
114 | (else #f))) | |
115 | (and (list? bindings) (and-map valid-binding? bindings))) | |
116 | ||
7d1c45d3 AW |
117 | (define-macro (make-pmatch-transformers env loc retranslate . body) |
118 | (define exp (gensym)) | |
119 | (define (make1 clause) | |
120 | (let ((sym (car clause)) | |
121 | (clauses (cdr clause))) | |
122 | `(cons ',sym | |
123 | (lambda (,env ,loc ,exp) | |
124 | (define (,retranslate x) (trans ,env ,loc x)) | |
125 | (pmatch (cdr ,exp) | |
126 | ,@clauses | |
127 | (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp))))))) | |
128 | `(list ,@(map make1 body))) | |
129 | ||
d79d908e | 130 | (define *the-compile-toplevel-symbol* 'compile-toplevel) |
bd76c6d3 | 131 | |
7d1c45d3 AW |
132 | (define primitive-syntax-table |
133 | (make-pmatch-transformers | |
134 | e l retrans | |
135 | (quote | |
c7228382 | 136 | ;; (quote OBJ) |
7d1c45d3 AW |
137 | ((,obj) (make-ghil-quote e l obj))) |
138 | ||
139 | (quasiquote | |
c7228382 | 140 | ;; (quasiquote OBJ) |
7d1c45d3 AW |
141 | ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))) |
142 | ||
143 | (define | |
144 | ;; (define NAME VAL) | |
145 | ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e)) | |
146 | (make-ghil-define e l (ghil-define (ghil-env-parent e) name) | |
147 | (retrans val))) | |
148 | ;; (define (NAME FORMALS...) BODY...) | |
149 | (((,name . ,formals) . ,body) (guard (symbol? name)) | |
150 | ;; -> (define NAME (lambda FORMALS BODY...)) | |
151 | (retrans `(define ,name (lambda ,formals ,@body))))) | |
152 | ||
153 | (set! | |
154 | ;; (set! NAME VAL) | |
155 | ((,name ,val) (guard (symbol? name)) | |
156 | (make-ghil-set e l (ghil-lookup e name) (retrans val))) | |
157 | ||
158 | ;; (set! (NAME ARGS...) VAL) | |
159 | (((,name . ,args) ,val) (guard (symbol? name)) | |
160 | ;; -> ((setter NAME) ARGS... VAL) | |
161 | (retrans `((setter ,name) . (,@args ,val))))) | |
162 | ||
163 | (if | |
c7228382 | 164 | ;; (if TEST THEN [ELSE]) |
7d1c45d3 AW |
165 | ((,test ,then) |
166 | (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) | |
167 | ((,test ,then ,else) | |
168 | (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) | |
c7228382 | 169 | |
7d1c45d3 | 170 | (and |
c7228382 | 171 | ;; (and EXPS...) |
7d1c45d3 | 172 | (,tail (make-ghil-and e l (map retrans tail)))) |
c7228382 | 173 | |
7d1c45d3 | 174 | (or |
c7228382 | 175 | ;; (or EXPS...) |
7d1c45d3 AW |
176 | (,tail (make-ghil-or e l (map retrans tail)))) |
177 | ||
178 | (begin | |
179 | ;; (begin EXPS...) | |
180 | (,tail (make-ghil-begin e l (map retrans tail)))) | |
181 | ||
182 | (let | |
183 | ;; (let NAME ((SYM VAL) ...) BODY...) | |
184 | ((,name ,bindings . ,body) (guard (symbol? name) | |
185 | (valid-bindings? bindings)) | |
186 | ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) | |
187 | (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) | |
188 | (,name ,@(map cadr bindings))))) | |
189 | ||
190 | ;; (let () BODY...) | |
191 | ((() . ,body) | |
192 | ;; Note: this differs from `begin' | |
193 | (make-ghil-begin e l (list (trans-body e l body)))) | |
194 | ||
195 | ;; (let ((SYM VAL) ...) BODY...) | |
196 | ((,bindings . ,body) (guard (valid-bindings? bindings)) | |
197 | (let ((vals (map retrans (map cadr bindings)))) | |
198 | (call-with-ghil-bindings e (map car bindings) | |
199 | (lambda (vars) | |
200 | (make-ghil-bind e l vars vals (trans-body e l body))))))) | |
201 | ||
202 | (let* | |
c7228382 | 203 | ;; (let* ((SYM VAL) ...) BODY...) |
7d1c45d3 AW |
204 | ((() . ,body) |
205 | (retrans `(let () ,@body))) | |
206 | ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) | |
207 | (retrans `(let ((,sym ,val)) (let* ,rest ,@body))))) | |
c7228382 | 208 | |
7d1c45d3 | 209 | (letrec |
c7228382 | 210 | ;; (letrec ((SYM VAL) ...) BODY...) |
7d1c45d3 AW |
211 | ((,bindings . ,body) (guard (valid-bindings? bindings)) |
212 | (call-with-ghil-bindings e (map car bindings) | |
213 | (lambda (vars) | |
214 | (let ((vals (map retrans (map cadr bindings)))) | |
215 | (make-ghil-bind e l vars vals (trans-body e l body))))))) | |
c7228382 | 216 | |
7d1c45d3 | 217 | (cond |
c7228382 | 218 | ;; (cond (CLAUSE BODY...) ...) |
7d1c45d3 | 219 | (() (retrans '(begin))) |
cd702346 | 220 | (((else . ,body)) (retrans `(begin ,@body))) |
7d1c45d3 AW |
221 | (((,test) . ,rest) (retrans `(or ,test (cond ,@rest)))) |
222 | (((,test => ,proc) . ,rest) | |
223 | ;; FIXME hygiene! | |
224 | (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))) | |
225 | (((,test . ,body) . ,rest) | |
226 | (retrans `(if ,test (begin ,@body) (cond ,@rest))))) | |
227 | ||
228 | (case | |
c7228382 | 229 | ;; (case EXP ((KEY...) BODY...) ...) |
7d1c45d3 AW |
230 | ((,exp . ,clauses) |
231 | (retrans | |
232 | ;; FIXME hygiene! | |
233 | `(let ((_t ,exp)) | |
234 | ,(let loop ((ls clauses)) | |
235 | (cond ((null? ls) '(begin)) | |
236 | ((eq? (caar ls) 'else) `(begin ,@(cdar ls))) | |
237 | (else `(if (memv _t ',(caar ls)) | |
238 | (begin ,@(cdar ls)) | |
239 | ,(loop (cdr ls)))))))))) | |
240 | ||
241 | (do | |
242 | ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) | |
243 | ((,bindings (,test . ,result) . ,body) | |
244 | (let ((sym (map car bindings)) | |
245 | (val (map cadr bindings)) | |
246 | (update (map cddr bindings))) | |
247 | (define (next s x) (if (pair? x) (car x) s)) | |
248 | (retrans | |
f245e62c | 249 | ;; FIXME hygiene! |
7d1c45d3 AW |
250 | `(letrec ((_l (lambda ,sym |
251 | (if ,test | |
252 | (begin ,@result) | |
253 | (begin ,@body | |
254 | (_l ,@(map next sym update))))))) | |
255 | (_l ,@val)))))) | |
256 | ||
257 | (lambda | |
258 | ;; (lambda FORMALS BODY...) | |
259 | ((,formals . ,body) | |
260 | (receive (syms rest) (parse-formals formals) | |
261 | (call-with-ghil-environment e syms | |
262 | (lambda (env vars) | |
263 | (make-ghil-lambda env l vars rest (trans-body env l body))))))) | |
264 | ||
265 | (eval-case | |
e0092405 | 266 | (,clauses |
7d1c45d3 | 267 | (retrans |
e0092405 AW |
268 | `(begin |
269 | ,@(let ((toplevel? (ghil-env-toplevel? e))) | |
270 | (let loop ((seen '()) (in clauses) (runtime '())) | |
271 | (cond | |
272 | ((null? in) runtime) | |
273 | (else | |
274 | (pmatch (car in) | |
275 | ((else . ,body) | |
bd76c6d3 | 276 | (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen))) |
e0092405 | 277 | (primitive-eval `(begin ,@body))) |
bd76c6d3 | 278 | (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen) |
e0092405 AW |
279 | runtime |
280 | body)) | |
281 | ((,keys . ,body) (guard (list? keys) (and-map symbol? keys)) | |
282 | (for-each (lambda (k) | |
283 | (if (memq k seen) | |
284 | (syntax-error l "eval-case condition seen twice" k))) | |
285 | keys) | |
bd76c6d3 | 286 | (if (and toplevel? (memq *the-compile-toplevel-symbol* keys)) |
e0092405 AW |
287 | (primitive-eval `(begin ,@body))) |
288 | (loop (append keys seen) | |
289 | (cdr in) | |
290 | (if (memq (if toplevel? 'load-toplevel 'evaluate) keys) | |
291 | (append runtime body) | |
292 | runtime))) | |
293 | (else (syntax-error l "bad eval-case clause" (car in)))))))))))))) | |
c7228382 KN |
294 | |
295 | (define (trans-quasiquote e l x) | |
296 | (cond ((not (pair? x)) x) | |
297 | ((memq (car x) '(unquote unquote-splicing)) | |
298 | (let ((l (location x))) | |
f245e62c AW |
299 | (pmatch (cdr x) |
300 | ((,obj) | |
c7228382 | 301 | (if (eq? (car x) 'unquote) |
849cefac AW |
302 | (make-ghil-unquote e l (trans e l obj)) |
303 | (make-ghil-unquote-splicing e l (trans e l obj)))) | |
c7228382 KN |
304 | (else (syntax-error l (format #f "bad ~A" (car x)) x))))) |
305 | (else (cons (trans-quasiquote e l (car x)) | |
306 | (trans-quasiquote e l (cdr x)))))) | |
307 | ||
308 | (define (trans-body e l body) | |
309 | (define (define->binding df) | |
f245e62c AW |
310 | (pmatch (cdr df) |
311 | ((,name ,val) (guard (symbol? name)) (list name val)) | |
312 | (((,name . ,formals) . ,body) (guard (symbol? name)) | |
c7228382 KN |
313 | (list name `(lambda ,formals ,@body))) |
314 | (else (syntax-error (location df) "bad define" df)))) | |
315 | ;; main | |
316 | (let loop ((ls body) (ds '())) | |
be852e52 AW |
317 | (pmatch ls |
318 | (() (syntax-error l "bad body" body)) | |
319 | (((define . _) . _) | |
320 | (loop (cdr ls) (cons (car ls) ds))) | |
321 | (else | |
322 | (if (null? ds) | |
7d1c45d3 AW |
323 | (trans e l `(begin ,@ls)) |
324 | (trans e l `(letrec ,(map define->binding ds) ,@ls))))))) | |
c7228382 KN |
325 | |
326 | (define (parse-formals formals) | |
327 | (cond | |
328 | ;; (lambda x ...) | |
329 | ((symbol? formals) (values (list formals) #t)) | |
330 | ;; (lambda (x y z) ...) | |
331 | ((list? formals) (values formals #f)) | |
332 | ;; (lambda (x y . z) ...) | |
333 | ((pair? formals) | |
334 | (let loop ((l formals) (v '())) | |
335 | (if (pair? l) | |
336 | (loop (cdr l) (cons (car l) v)) | |
337 | (values (reverse! (cons l v)) #t)))) | |
338 | (else (syntax-error (location formals) "bad formals" formals)))) | |
339 | ||
340 | (define (location x) | |
341 | (and (pair? x) | |
342 | (let ((props (source-properties x))) | |
343 | (and (not (null? props)) | |
344 | (cons (assq-ref props 'line) (assq-ref props 'column)))))) |