1 ;;; Guile Scheme specification
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
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)
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.
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.
22 (define-module (language scheme translate)
23 #:use-module (system base pmatch)
24 #:use-module (system base language)
25 #:use-module (language ghil def)
26 #:use-module (language scheme inline)
27 #:use-module (system vm objcode)
28 #:use-module (ice-9 receive)
29 #:use-module (ice-9 optargs)
30 #:use-module ((ice-9 syncase) #:select (sc-macro))
31 #:use-module ((system base compile) #:select (syntax-error))
32 #:export (translate translate-1
33 *translate-table* define-scheme-translator))
39 ;;; compile-env := (MODULE LEXICALS . EXTERNALS)
40 (define (cenv-module env)
43 ((and (pair? env) (module? (car env))) (car env))
44 (else (error "bad environment" env))))
46 (define (cenv-ghil-env env)
47 (cond ((not env) (make-ghil-toplevel-env))
48 ((module? env) (make-ghil-toplevel-env))
50 (ghil-env-dereify (cadr env)))
51 (else (error "bad environment" env))))
53 (define (cenv-externals env)
56 ((pair? env) (cddr env))
57 (else (error "bad environment" env))))
62 (define (translate x e opts)
63 (save-module-excursion
65 (and=> (cenv-module e) set-current-module)
66 (call-with-ghil-environment (cenv-ghil-env e) '()
68 (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
70 (cons* (cenv-module e)
72 (cenv-externals e)))))))))
79 (define *forbidden-primitives*
80 ;; Guile's `procedure->macro' family is evil because it crosses the
81 ;; compilation boundary. One solution might be to evaluate calls to
82 ;; `procedure->memoizing-macro' at compilation time, but it may be more
83 ;; compicated than that.
84 '(procedure->syntax procedure->macro))
86 ;; Looks up transformers relative to the current module at
87 ;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
89 ;; FIXME shadowing lexicals?
90 (define (lookup-transformer head retrans)
91 (let* ((mod (current-module))
92 (val (and (symbol? head)
93 (and=> (module-variable mod head)
95 ;; unbound vars can happen if the module
96 ;; definition forward-declared them
97 (and (variable-bound? var) (variable-ref var)))))))
99 ((hashq-ref *translate-table* val))
102 (lambda (env loc exp)
103 (retrans (apply (defmacro-transformer val) (cdr exp)))))
107 (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
108 (eec (module-ref the-syncase-module 'expansion-eval-closure))
109 (sc-expand3 (module-ref the-syncase-module 'sc-expand3)))
110 (lambda (env loc exp)
112 (with-fluids ((eec (module-eval-closure mod)))
113 (sc-expand3 exp 'c '(compile load eval)))))))
115 ((primitive-macro? val)
116 (syntax-error #f "unhandled primitive macro" head))
119 (syntax-error #f "unknown kind of macro" head))
123 (define (translate-1 e l x)
124 (let ((l (or l (location x))))
125 (define (retrans x) (translate-1 e #f x))
127 (let ((head (car x)) (tail (cdr x)))
129 ((lookup-transformer head retrans)
130 => (lambda (t) (t e l x)))
132 ;; FIXME: lexical/module overrides of forbidden primitives
133 ((memq head *forbidden-primitives*)
134 (syntax-error l (format #f "`~a' is forbidden" head)
138 (let ((tail (map retrans tail)))
139 (or (and (symbol? head)
140 (try-inline-with-env e l (cons head tail)))
141 (make-ghil-call e l (retrans head) tail)))))))
144 (make-ghil-ref e l (ghil-var-for-ref! e x)))
146 ;; fixme: non-self-quoting objects like #<foo>
148 (make-ghil-quote e l #:obj x)))))
150 (define (valid-bindings? bindings . it-is-for-do)
151 (define (valid-binding? b)
153 ((,sym ,var) (guard (symbol? sym)) #t)
154 ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
156 (and (list? bindings) (and-map valid-binding? bindings)))
158 (define *translate-table* (make-hash-table))
160 (define-macro (define-scheme-translator sym . clauses)
161 `(hashq-set! (@ (language scheme translate) *translate-table*)
165 ((@ (language scheme translate) translate-1) e #f x))
166 (define syntax-error (@ (system base compile) syntax-error))
170 (syntax-error l (format #f "bad ~A" ',sym) exp))))))
172 (define-scheme-translator quote
174 ((,obj) (make-ghil-quote e l #:obj obj)))
176 (define-scheme-translator quasiquote
178 ((,obj) (make-ghil-quasiquote e l #:exp (trans-quasiquote e l obj 0))))
180 (define-scheme-translator define
182 ((,name ,val) (guard (symbol? name)
183 (ghil-toplevel-env? (ghil-env-parent e)))
184 (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name)
185 (maybe-name-value! (retrans val) name)))
186 ;; (define (NAME FORMALS...) BODY...)
187 (((,name . ,formals) . ,body) (guard (symbol? name))
188 ;; -> (define NAME (lambda FORMALS BODY...))
189 (retrans `(define ,name (lambda ,formals ,@body)))))
191 (define-scheme-translator set!
193 ((,name ,val) (guard (symbol? name))
194 (make-ghil-set e l (ghil-var-for-set! e name) (retrans val)))
196 ;; FIXME: Would be nice to verify the values of @ and @@ relative
197 ;; to imported modules...
198 (((@ ,modname ,name) ,val) (guard (symbol? name)
200 (and-map symbol? modname)
201 (not (ghil-var-is-bound? e '@)))
202 (make-ghil-set e l (ghil-var-at-module! e modname name #t)
205 (((@@ ,modname ,name) ,val) (guard (symbol? name)
207 (and-map symbol? modname)
208 (not (ghil-var-is-bound? e '@@)))
209 (make-ghil-set e l (ghil-var-at-module! e modname name #f)
212 ;; (set! (NAME ARGS...) VAL)
213 (((,name . ,args) ,val) (guard (symbol? name))
214 ;; -> ((setter NAME) ARGS... VAL)
215 (retrans `((setter ,name) . (,@args ,val)))))
217 (define-scheme-translator if
218 ;; (if TEST THEN [ELSE])
220 (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
222 (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
224 (define-scheme-translator and
226 (,tail (make-ghil-and e l (map retrans tail))))
228 (define-scheme-translator or
230 (,tail (make-ghil-or e l (map retrans tail))))
232 (define-scheme-translator begin
234 (,tail (make-ghil-begin e l (map retrans tail))))
236 (define-scheme-translator let
237 ;; (let NAME ((SYM VAL) ...) BODY...)
238 ((,name ,bindings . ,body) (guard (symbol? name)
239 (valid-bindings? bindings))
240 ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
241 (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
242 (,name ,@(map cadr bindings)))))
246 ;; Note: this differs from `begin'
247 (make-ghil-begin e l (list (trans-body e l body))))
249 ;; (let ((SYM VAL) ...) BODY...)
250 ((,bindings . ,body) (guard (valid-bindings? bindings))
251 (let ((vals (map retrans (map cadr bindings))))
252 (call-with-ghil-bindings e (map car bindings)
254 (make-ghil-bind e l vars vals (trans-body e l body)))))))
256 (define-scheme-translator let*
257 ;; (let* ((SYM VAL) ...) BODY...)
259 (retrans `(let () ,@body)))
260 ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
261 (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
263 (define-scheme-translator letrec
264 ;; (letrec ((SYM VAL) ...) BODY...)
265 ((,bindings . ,body) (guard (valid-bindings? bindings))
266 (call-with-ghil-bindings e (map car bindings)
268 (let ((vals (map retrans (map cadr bindings))))
269 (make-ghil-bind e l vars vals (trans-body e l body)))))))
271 (define-scheme-translator cond
272 ;; (cond (CLAUSE BODY...) ...)
273 (() (retrans '(begin)))
274 (((else . ,body)) (retrans `(begin ,@body)))
275 (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
276 (((,test => ,proc) . ,rest)
278 (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
279 (((,test . ,body) . ,rest)
280 (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
282 (define-scheme-translator case
283 ;; (case EXP ((KEY...) BODY...) ...)
288 ,(let loop ((ls clauses))
289 (cond ((null? ls) '(begin))
290 ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
291 (else `(if (memv _t ',(caar ls))
293 ,(loop (cdr ls))))))))))
295 (define-scheme-translator do
296 ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
297 ((,bindings (,test . ,result) . ,body)
298 (let ((sym (map car bindings))
299 (val (map cadr bindings))
300 (update (map cddr bindings)))
301 (define (next s x) (if (pair? x) (car x) s))
304 `(letrec ((_l (lambda ,sym
308 (_l ,@(map next sym update)))))))
311 (define-scheme-translator lambda
312 ;; (lambda FORMALS BODY...)
314 (receive (syms rest) (parse-formals formals)
315 (call-with-ghil-environment e syms
317 (receive (meta body) (parse-lambda-meta body)
318 (make-ghil-lambda env l vars rest meta
319 (trans-body env l body))))))))
321 (define-scheme-translator delay
322 ;; FIXME not hygienic
324 (retrans `(make-promise (lambda () ,expr)))))
326 (define-scheme-translator @
328 (make-ghil-ref e l (ghil-var-at-module! e modname sym #t))))
330 (define-scheme-translator @@
332 (make-ghil-ref e l (ghil-var-at-module! e modname sym #f))))
334 (define *the-compile-toplevel-symbol* 'compile-toplevel)
335 (define-scheme-translator eval-case
339 ;; Compilation of toplevel units is always wrapped in a lambda
340 ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
341 (let loop ((seen '()) (in clauses) (runtime '()))
347 (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
348 (primitive-eval `(begin ,@body)))
349 (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
352 ((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
353 (for-each (lambda (k)
355 (syntax-error l "eval-case condition seen twice" k)))
357 (if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
358 (primitive-eval `(begin ,@body)))
359 (loop (append keys seen)
361 (if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
362 (append runtime body)
364 (else (syntax-error l "bad eval-case clause" (car in))))))))))))
366 (define-scheme-translator apply
367 ;; FIXME: not hygienic, relies on @apply not being shadowed
368 (,args (retrans `(@apply ,@args))))
370 (define-scheme-translator @apply
371 ((,proc ,arg1 . ,args)
372 (let ((args (cons (retrans arg1) (map retrans args))))
373 (cond ((and (symbol? proc)
374 (not (ghil-var-is-bound? e proc))
375 (and=> (module-variable (current-module) proc)
377 (and (variable-bound? var)
378 (lookup-apply-transformer (variable-ref var))))))
379 ;; that is, a variable, not part of this compilation
380 ;; unit, but defined in the toplevel environment, and has
381 ;; an apply transformer registered
382 => (lambda (t) (t e l args)))
383 (else (make-ghil-inline e l 'apply
384 (cons (retrans proc) args)))))))
386 (define-scheme-translator call-with-values
387 ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
388 ((,producer ,consumer)
389 (retrans `(@call-with-values ,producer ,consumer)))
392 (define-scheme-translator @call-with-values
393 ((,producer ,consumer)
394 (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
396 (define-scheme-translator call-with-current-continuation
397 ;; FIXME: not hygienic, relies on @call-with-current-continuation
398 ;; not being shadowed
400 (retrans `(@call-with-current-continuation ,proc)))
403 (define-scheme-translator @call-with-current-continuation
405 (make-ghil-inline e l 'call/cc (list (retrans proc)))))
407 (define-scheme-translator receive
408 ((,formals ,producer-exp . ,body)
409 ;; Lovely, self-referential usage. Not strictly necessary, the
410 ;; macro would do the trick; but it's good to test the mv-bind
412 (receive (syms rest) (parse-formals formals)
413 (let ((producer (retrans `(lambda () ,producer-exp))))
414 (call-with-ghil-bindings e syms
416 (make-ghil-mv-bind e l producer
417 vars rest (trans-body e l body))))))))
419 (define-scheme-translator values
421 (,args (make-ghil-values e l (map retrans args))))
423 (define-scheme-translator compile-time-environment
424 ;; (compile-time-environment)
425 ;; => (MODULE LEXICALS . EXTERNALS)
426 (() (make-ghil-inline
428 (list (retrans '(current-module))
431 (list (make-ghil-reified-env e l)
432 (make-ghil-inline e l 'externals '())))))))
434 (define (lookup-apply-transformer proc)
435 (cond ((eq? proc values)
437 (make-ghil-values* e l args)))
440 (define (trans-quasiquote e l x level)
441 (cond ((not (pair? x)) x)
442 ((memq (car x) '(unquote unquote-splicing))
443 (let ((l (location x)))
448 (if (eq? (car x) 'unquote)
449 (make-ghil-unquote e l (translate-1 e l obj))
450 (make-ghil-unquote-splicing e l (translate-1 e l obj))))
452 (list (car x) (trans-quasiquote e l obj (1- level))))))
453 (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
454 ((eq? (car x) 'quasiquote)
455 (let ((l (location x)))
457 ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
458 (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
459 (else (cons (trans-quasiquote e l (car x) level)
460 (trans-quasiquote e l (cdr x) level)))))
462 (define (trans-body e l body)
463 (define (define->binding df)
465 ((,name ,val) (guard (symbol? name)) (list name val))
466 (((,name . ,formals) . ,body) (guard (symbol? name))
467 (list name `(lambda ,formals ,@body)))
468 (else (syntax-error (location df) "bad define" df))))
470 (let loop ((ls body) (ds '()))
472 (() (syntax-error l "bad body" body))
474 (loop (cdr ls) (cons (car ls) ds)))
477 (translate-1 e l `(begin ,@ls))
478 (translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
480 (define (parse-formals formals)
483 ((symbol? formals) (values (list formals) #t))
484 ;; (lambda (x y z) ...)
485 ((list? formals) (values formals #f))
486 ;; (lambda (x y . z) ...)
488 (let loop ((l formals) (v '()))
490 (loop (cdr l) (cons (car l) v))
491 (values (reverse! (cons l v)) #t))))
492 (else (syntax-error (location formals) "bad formals" formals))))
494 (define (parse-lambda-meta body)
495 (cond ((or (null? body) (null? (cdr body))) (values '() body))
496 ((string? (car body))
497 (values `((documentation . ,(car body))) (cdr body)))
498 (else (values '() body))))
500 (define (maybe-name-value! val name)
503 (if (not (assq-ref (ghil-lambda-meta val) 'name))
504 (set! (ghil-lambda-meta val)
505 (acons 'name name (ghil-lambda-meta val))))))
510 (let ((props (source-properties x)))
511 (and (not (null? props))
512 (vector (assq-ref props 'line)
513 (assq-ref props 'column)
514 (assq-ref props 'filename))))))