;;; Code:
(define-module (language scheme translate)
- :use-module (system base pmatch)
- :use-module (system base language)
- :use-module (system il ghil)
- :use-module (system il inline)
- :use-module (ice-9 receive)
- :use-module (srfi srfi-39)
- :use-module ((system base compile) :select (syntax-error))
- :export (translate))
+ #:use-module (system base pmatch)
+ #:use-module (system base language)
+ #:use-module (system il ghil)
+ #:use-module (system il inline)
+ #:use-module (ice-9 receive)
+ #:use-module ((system base compile) #:select (syntax-error))
+ #:export (translate))
(define (translate x e)
- (call-with-ghil-environment (make-ghil-mod e) '()
+ (call-with-ghil-environment (make-ghil-toplevel-env) '()
(lambda (env vars)
- (make-ghil-lambda env #f vars #f (trans env #f x)))))
+ (make-ghil-lambda env #f vars #f '() (trans env (location x) x)))))
\f
;;;
;;; Translator
;;;
-(define %forbidden-primitives
+(define *forbidden-primitives*
;; Guile's `procedure->macro' family is evil because it crosses the
;; compilation boundary. One solution might be to evaluate calls to
;; `procedure->memoizing-macro' at compilation time, but it may be more
;; compicated than that.
- '(procedure->syntax procedure->macro procedure->memoizing-macro))
-
-(define (lookup-transformer e head retrans)
- (let* ((mod (ghil-mod-module (ghil-env-mod e)))
- (val (and=> (module-variable mod head)
- (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))))
+ '(procedure->syntax procedure->macro))
+
+;; Looks up transformers relative to the current module at
+;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
+(define (lookup-transformer head retrans)
+ (let* ((mod (current-module))
+ (val (and (symbol? head)
+ (and=> (module-variable mod head)
+ (lambda (var)
+ ;; unbound vars can happen if the module
+ ;; definition forward-declared them
+ (and (variable-bound? var) (variable-ref var)))))))
(cond
- ((or (primitive-macro? val) (eq? val eval-case))
- (or (assq-ref primitive-syntax-table head)
- (syntax-error #f "unhandled primitive macro" head)))
+ ((assq-ref custom-transformer-table val))
((defmacro? val)
(lambda (env loc exp)
(with-fluids ((eec (module-eval-closure mod)))
(sc-expand3 exp 'c '(compile load eval)))))))
+ ((primitive-macro? val)
+ (syntax-error #f "unhandled primitive macro" head))
+
((macro? val)
(syntax-error #f "unknown kind of macro" head))
(else #f))))
(define (trans e l x)
- (define (retrans x) (trans e l x))
+ (define (retrans x) (trans e (location x) x))
(cond ((pair? x)
(let ((head (car x)) (tail (cdr x)))
(cond
- ((lookup-transformer e head retrans)
+ ((lookup-transformer head retrans)
=> (lambda (t) (t e l x)))
;; FIXME: lexical/module overrides of forbidden primitives
- ((memq head %forbidden-primitives)
+ ((memq head *forbidden-primitives*)
(syntax-error l (format #f "`~a' is forbidden" head)
(cons head tail)))
(else
(let ((tail (map retrans tail)))
- (or (try-inline-with-env e l (cons head tail))
+ (or (and (symbol? head)
+ (try-inline-with-env e l (cons head tail)))
(make-ghil-call e l (retrans head) tail)))))))
((symbol? x)
(define (make1 clause)
(let ((sym (car clause))
(clauses (cdr clause)))
- `(cons ',sym
+ `(cons ,sym
(lambda (,env ,loc ,exp)
- (define (,retranslate x) (trans ,env ,loc x))
+ (define (,retranslate x) (trans ,env (location x) x))
(pmatch (cdr ,exp)
,@clauses
(else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
(define *the-compile-toplevel-symbol* 'compile-toplevel)
-(define primitive-syntax-table
+(define custom-transformer-table
(make-pmatch-transformers
e l retrans
(quote
(quasiquote
;; (quasiquote OBJ)
- ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj))))
+ ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
(define
;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e))
+ ((,name ,val) (guard (symbol? name)
+ (ghil-toplevel-env? (ghil-env-parent e)))
(make-ghil-define e l (ghil-define (ghil-env-parent e) name)
- (retrans val)))
+ (maybe-name-value! (retrans val) name)))
;; (define (NAME FORMALS...) BODY...)
(((,name . ,formals) . ,body) (guard (symbol? name))
;; -> (define NAME (lambda FORMALS BODY...))
((,formals . ,body)
(receive (syms rest) (parse-formals formals)
(call-with-ghil-environment e syms
- (lambda (env vars)
- (make-ghil-lambda env l vars rest (trans-body env l body)))))))
+ (lambda (env vars)
+ (receive (meta body) (parse-lambda-meta body)
+ (make-ghil-lambda env l vars rest meta
+ (trans-body env l body))))))))
(eval-case
(,clauses
(retrans
`(begin
- ,@(let ((toplevel? (ghil-env-toplevel? e)))
+ ;; Compilation of toplevel units is always wrapped in a lambda
+ ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
(let loop ((seen '()) (in clauses) (runtime '()))
(cond
((null? in) runtime)
(if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
(append runtime body)
runtime)))
- (else (syntax-error l "bad eval-case clause" (car in))))))))))))))
-
-(define (trans-quasiquote e l x)
+ (else (syntax-error l "bad eval-case clause" (car in))))))))))))
+
+ ;; FIXME: make this actually do something
+ (start-stack
+ ((,tag ,expr) (retrans expr)))
+
+ ;; FIXME: not hygienic, relies on @apply not being shadowed
+ (apply
+ (,args (retrans `(@apply ,@args))))
+
+ (@apply
+ ((,proc ,arg1 . ,args)
+ (let ((args (cons (retrans arg1) (map retrans args))))
+ (cond ((and (symbol? proc)
+ (not (ghil-lookup e proc #f))
+ (and=> (module-variable (current-module) proc)
+ (lambda (var)
+ (and (variable-bound? var)
+ (lookup-apply-transformer (variable-ref var))))))
+ ;; that is, a variable, not part of this compilation
+ ;; unit, but defined in the toplevel environment, and has
+ ;; an apply transformer registered
+ => (lambda (t) (t e l args)))
+ (else (make-ghil-inline e l 'apply
+ (cons (retrans proc) args)))))))
+
+ ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
+ (call-with-values
+ ((,producer ,consumer)
+ (retrans `(@call-with-values ,producer ,consumer)))
+ (else #f))
+
+ (@call-with-values
+ ((,producer ,consumer)
+ (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
+
+ ;; FIXME: not hygienic, relies on @call-with-current-continuation
+ ;; not being shadowed
+ (call-with-current-continuation
+ ((,proc)
+ (retrans `(@call-with-current-continuation ,proc)))
+ (else #f))
+
+ (@call-with-current-continuation
+ ((,proc)
+ (make-ghil-inline e l 'call/cc (list (retrans proc)))))
+
+ (receive
+ ((,formals ,producer-exp . ,body)
+ ;; Lovely, self-referential usage. Not strictly necessary, the
+ ;; macro would do the trick; but it's good to test the mv-bind
+ ;; code.
+ (receive (syms rest) (parse-formals formals)
+ (call-with-ghil-bindings e syms
+ (lambda (vars)
+ (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
+ vars rest (trans-body e l body)))))))
+
+ (values
+ ((,x) (retrans x))
+ (,args (make-ghil-values e l (map retrans args))))))
+
+(define (lookup-apply-transformer proc)
+ (cond ((eq? proc values)
+ (lambda (e l args)
+ (make-ghil-values* e l args)))
+ (else #f)))
+
+(define (trans-quasiquote e l x level)
(cond ((not (pair? x)) x)
((memq (car x) '(unquote unquote-splicing))
(let ((l (location x)))
(pmatch (cdr x)
((,obj)
- (if (eq? (car x) 'unquote)
- (make-ghil-unquote e l (trans e l obj))
- (make-ghil-unquote-splicing e l (trans e l obj))))
+ (cond
+ ((zero? level)
+ (if (eq? (car x) 'unquote)
+ (make-ghil-unquote e l (trans e l obj))
+ (make-ghil-unquote-splicing e l (trans e l obj))))
+ (else
+ (list (car x) (trans-quasiquote e l obj (1- level))))))
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (trans-quasiquote e l (car x))
- (trans-quasiquote e l (cdr x))))))
+ ((eq? (car x) 'quasiquote)
+ (let ((l (location x)))
+ (pmatch (cdr x)
+ ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ (else (cons (trans-quasiquote e l (car x) level)
+ (trans-quasiquote e l (cdr x) level)))))
(define (trans-body e l body)
(define (define->binding df)
(values (reverse! (cons l v)) #t))))
(else (syntax-error (location formals) "bad formals" formals))))
+(define (parse-lambda-meta body)
+ (cond ((or (null? body) (null? (cdr body))) (values '() body))
+ ((string? (car body))
+ (values `((documentation . ,(car body))) (cdr body)))
+ (else (values '() body))))
+
+(define (maybe-name-value! val name)
+ (cond
+ ((ghil-lambda? val)
+ (if (not (assq-ref (ghil-lambda-meta val) 'name))
+ (set! (ghil-lambda-meta val)
+ (acons 'name name (ghil-lambda-meta val))))))
+ val)
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
- (cons (assq-ref props 'line) (assq-ref props 'column))))))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))
HCoop / bpt / guile.git / blobdiff