-;;; Guile Scheme specification
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (language scheme translate)
- :use-module (system base pmatch)
- :use-module (system base language)
- :use-module (system il ghil)
- :use-module (ice-9 receive)
- :use-module (srfi srfi-39)
- :use-module ((system base compile) :select (syntax-error))
- :export (translate))
-
-
-;; Module in which compile-time code (macros) is evaluated.
-(define &compile-time-module (make-parameter #f))
-
-(define (eval-at-compile-time exp)
- "Evaluate @var{exp} in the current compile-time module."
- (catch #t
- (lambda ()
- (save-module-excursion
- (lambda ()
- (eval exp (&compile-time-module)))))
- (lambda (key . args)
- (syntax-error #f
- (format #f "~a: compile-time evaluation failed" exp)
- (cons key args)))))
-
-(define (translate x e)
- (parameterize ((&compile-time-module (make-module)))
-
- ;; Import only core bindings in the macro module.
- (module-use! (&compile-time-module) the-root-module)
-
- (call-with-ghil-environment (make-ghil-mod e) '()
- (lambda (env vars)
- (make-ghil-lambda env #f vars #f (trans env #f x))))))
-
-\f
-;;;
-;;; Macro tricks
-;;;
-
-(define (expand-macro e)
- ;; Similar to `macroexpand' in `boot-9.scm' except that it does not expand
- ;; `define-macro' and `defmacro'.
- (cond
- ((pair? e)
- (let* ((head (car e))
- (val (and (symbol? head)
- (false-if-exception
- (module-ref (&compile-time-module) head)))))
- (case head
- ((defmacro define-macro)
- ;; Normally, these are expanded as `defmacro:transformer' but we
- ;; don't want it to happen since they are handled by `trans-pair'.
- e)
-
- ((use-syntax)
- ;; `use-syntax' is used to express a compile-time dependency
- ;; (because we use a macro from that module, or because one of our
- ;; macros uses bindings from that module). Thus, we arrange to get
- ;; the current compile-time module to use it.
- (let* ((module-name (cadr e))
- (module (false-if-exception (resolve-module module-name))))
- (if (module? module)
- (let ((public-if (module-public-interface module)))
- (module-use! (&compile-time-module) public-if))
- (syntax-error #f "invalid `use-syntax' form" e)))
- '(void))
-
- ((begin let let* letrec lambda quote quasiquote if and or
- set! cond case eval-case define do)
- ;; All these built-in macros should not be expanded.
- e)
-
- (else
- ;; Look for a macro.
- (let ((ref (false-if-exception
- (module-ref (&compile-time-module) head))))
- (if (macro? ref)
- (expand-macro
- (save-module-excursion
- (lambda ()
- (let ((transformer (macro-transformer ref))
- (syntax-error syntax-error))
- (set-current-module (&compile-time-module))
- (catch #t
- (lambda ()
- (transformer (copy-tree e) (current-module)))
- (lambda (key . args)
- (syntax-error #f
- (format #f "~a: macro transformer failed"
- head)
- (cons key args))))))))
- e))))))
-
- (#t e)))
-
-\f
-;;;
-;;; Translator
-;;;
-
-(define %scheme-primitives
- '(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!))
-
-(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 (trans e l x)
- (cond ((pair? x)
- (let ((y (expand-macro x)))
- (if (eq? x y)
- (trans-pair e (or (location x) l) (car x) (cdr x))
- (trans e l y))))
- ((symbol? x)
- (let ((y (symbol-expand x)))
- (if (symbol? y)
- (make-ghil-ref e l (ghil-lookup e y))
- (trans e l y))))
- (else (make-ghil-quote e l x))))
-
-(define (symbol-expand x)
- (let loop ((s (symbol->string x)))
- (let ((i (string-rindex s #\.)))
- (if i
- (let ((sym (string->symbol (substring s (1+ i)))))
- `(slot ,(loop (substring s 0 i)) (quote ,sym)))
- (string->symbol s)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (pmatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? bindings) (and-map valid-binding? bindings)))
-
-(define (trans-pair e l head tail)
- (define (trans:x x) (trans e l x))
- (define (trans:pair x) (trans-pair e l (car x) (cdr x)))
- (define (trans:body body) (trans-body e l body))
- (define (make:void) (make-ghil-void e l))
- (define (bad-syntax)
- (syntax-error l (format #f "bad ~A" head) (cons head tail)))
- ;; have to use a case first, because pmatch treats e.g. (quote foo)
- ;; and (unquote foo) specially
- (case head
- ;; (void)
- ((void)
- (pmatch tail
- (() (make:void))
- (else (bad-syntax))))
-
- ;; (quote OBJ)
- ((quote)
- (pmatch tail
- ((,obj) (make-ghil-quote e l obj))
- (else (bad-syntax))))
-
- ;; (quasiquote OBJ)
- ((quasiquote)
- (pmatch tail
- ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))
- (else (bad-syntax))))
-
- ((define define-private) ;; what is define-private?
- (pmatch tail
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (make-ghil-define e l (ghil-lookup e name) (trans:x val)))
-
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (let ((val (trans:x `(lambda ,formals ,@body))))
- (make-ghil-define e l (ghil-lookup e name) val)))
-
- (else (bad-syntax))))
-
- ;; simple macros
- ((defmacro define-macro)
- ;; Evaluate the macro definition in the current compile-time module.
- (eval-at-compile-time (cons head tail))
-
- ;; FIXME: We need to evaluate them in the runtime module as well.
- (make:void))
-
- ((set!)
- (pmatch tail
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (make-ghil-set e l (ghil-lookup e name) (trans:x val)))
-
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name))
- ;; -> ((setter NAME) ARGS... VAL)
- (trans:pair `((setter ,name) . (,@args ,val))))
-
- (else (bad-syntax))))
-
- ;; (if TEST THEN [ELSE])
- ((if)
- (pmatch tail
- ((,test ,then)
- (make-ghil-if e l (trans:x test) (trans:x then) (make:void)))
- ((,test ,then ,else)
- (make-ghil-if e l (trans:x test) (trans:x then) (trans:x else)))
- (else (bad-syntax))))
-
- ;; (and EXPS...)
- ((and)
- (make-ghil-and e l (map trans:x tail)))
-
- ;; (or EXPS...)
- ((or)
- (make-ghil-or e l (map trans:x tail)))
-
- ;; (begin EXPS...)
- ((begin)
- (make-ghil-begin e l (map trans:x tail)))
-
- ((let)
- (pmatch tail
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (trans:pair `(letrec ((,name (lambda ,(map car bindings) ,@body)))
- (,name ,@(map cadr bindings)))))
-
- ;; (let () BODY...)
- ((() . ,body)
- ;; Note: this differs from `begin'
- (make-ghil-begin e l (list (trans:body body))))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (let ((vals (map trans:x (map cadr bindings))))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (make-ghil-bind e l vars vals (trans:body body))))))
- (else (bad-syntax))))
-
- ;; (let* ((SYM VAL) ...) BODY...)
- ((let*)
- (pmatch tail
- ((() . ,body)
- (trans:pair `(let () ,@body)))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (trans:pair `(let ((,sym ,val)) (let* ,rest ,@body))))
- (else (bad-syntax))))
-
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((letrec)
- (pmatch tail
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (let ((vals (map trans:x (map cadr bindings))))
- (make-ghil-bind e l vars vals (trans:body body))))))
- (else (bad-syntax))))
-
- ;; (cond (CLAUSE BODY...) ...)
- ((cond)
- (pmatch tail
- (() (make:void))
- (((else . ,body)) (trans:body body))
- (((,test) . ,rest) (trans:pair `(or ,test (cond ,@rest))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
- (((,test . ,body) . ,rest)
- (trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
- (else (bad-syntax))))
-
- ;; (case EXP ((KEY...) BODY...) ...)
- ((case)
- (pmatch tail
- ((,exp . ,clauses)
- (trans:pair
- ;; FIXME hygiene!
- `(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(void))
- ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
- (else `(if (memv _t ',(caar ls))
- (begin ,@(cdar ls))
- ,(loop (cdr ls)))))))))
- (else (bad-syntax))))
-
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((do)
- (pmatch tail
- ((,bindings (,test . ,result) . ,body)
- (let ((sym (map car bindings))
- (val (map cadr bindings))
- (update (map cddr bindings)))
- (define (next s x) (if (pair? x) (car x) s))
- (trans:pair
- ;; FIXME hygiene!
- `(letrec ((_l (lambda ,sym
- (if ,test
- (let () (void) ,@result)
- (let () (void) ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val)))))
- (else (bad-syntax))))
-
- ;; (lambda FORMALS BODY...)
- ((lambda)
- (pmatch tail
- ((,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))))))
- (else (bad-syntax))))
-
- ((eval-case)
- (let loop ((x tail))
- (pmatch x
- (() (make:void))
- (((else . ,body)) (trans:pair `(begin ,@body)))
- (((,keys . ,body) . ,rest) (guard (list? keys) (and-map symbol? keys))
- (if (memq 'load-toplevel keys)
- (begin
- (primitive-eval `(begin ,@(copy-tree body)))
- (trans:pair `(begin ,@body)))
- (loop rest)))
- (else (bad-syntax)))))
-
- (else
- (if (memq head %scheme-primitives)
- (make-ghil-inline e l head (map trans:x tail))
- (if (memq head %forbidden-primitives)
- (syntax-error l (format #f "`~a' is forbidden" head)
- (cons head tail))
- (make-ghil-call e l (trans:x head) (map trans:x tail)))))))
-
-(define (trans-quasiquote e l x)
- (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))))
- (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))))))
-
-(define (trans-body e l body)
- (define (define->binding df)
- (pmatch (cdr df)
- ((,name ,val) (guard (symbol? name)) (list name val))
- (((,name . ,formals) . ,body) (guard (symbol? name))
- (list name `(lambda ,formals ,@body)))
- (else (syntax-error (location df) "bad define" df))))
- ;; main
- (let loop ((ls body) (ds '()))
- (cond ((null? ls) (syntax-error l "bad body" body))
- ((and (pair? (car ls)) (eq? (caar ls) 'define))
- (loop (cdr ls) (cons (car ls) ds)))
- (else
- (if (null? ds)
- (trans-pair e l 'begin ls)
- (trans-pair e l 'letrec (cons (map define->binding ds) ls)))))))
-
-(define (parse-formals formals)
- (cond
- ;; (lambda x ...)
- ((symbol? formals) (values (list formals) #t))
- ;; (lambda (x y z) ...)
- ((list? formals) (values formals #f))
- ;; (lambda (x y . z) ...)
- ((pair? formals)
- (let loop ((l formals) (v '()))
- (if (pair? l)
- (loop (cdr l) (cons (car l) v))
- (values (reverse! (cons l v)) #t))))
- (else (syntax-error (location formals) "bad formals" formals))))
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- (cons (assq-ref props 'line) (assq-ref props 'column))))))
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; 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 ((system base compile) #:select (syntax-error))
+ #:export (translate))
+
+
+(define (translate x e)
+ (call-with-ghil-environment (make-ghil-toplevel-env) '()
+ (lambda (env vars)
+ (make-ghil-lambda env #f vars #f '() (trans env (location x) x)))))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(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))
+
+;; 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
+ ((assq-ref custom-transformer-table val))
+
+ ((defmacro? val)
+ (lambda (env loc exp)
+ (retrans (apply (defmacro-transformer val) (cdr exp)))))
+
+ ((and (macro? val) (eq? (macro-name val) 'sc-macro))
+ ;; syncase!
+ (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
+ (eec (module-ref the-syncase-module 'expansion-eval-closure))
+ (sc-expand3 (module-ref the-syncase-module 'sc-expand3)))
+ (lambda (env loc exp)
+ (retrans
+ (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 (location x) x))
+ (cond ((pair? x)
+ (let ((head (car x)) (tail (cdr x)))
+ (cond
+ ((lookup-transformer head retrans)
+ => (lambda (t) (t e l x)))
+
+ ;; FIXME: lexical/module overrides of 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 (and (symbol? head)
+ (try-inline-with-env e l (cons head tail)))
+ (make-ghil-call e l (retrans head) tail)))))))
+
+ ((symbol? x)
+ (make-ghil-ref e l (ghil-lookup e x)))
+
+ ;; fixme: non-self-quoting objects like #<foo>
+ (else
+ (make-ghil-quote e l #:obj x))))
+
+(define (valid-bindings? bindings . it-is-for-do)
+ (define (valid-binding? b)
+ (pmatch b
+ ((,sym ,var) (guard (symbol? sym)) #t)
+ ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
+ (else #f)))
+ (and (list? bindings) (and-map valid-binding? bindings)))
+
+(define-macro (make-pmatch-transformers env loc retranslate . body)
+ (define exp (gensym))
+ (define (make1 clause)
+ (let ((sym (car clause))
+ (clauses (cdr clause)))
+ `(cons ,sym
+ (lambda (,env ,loc ,exp)
+ (define (,retranslate x) (trans ,env (location x) x))
+ (pmatch (cdr ,exp)
+ ,@clauses
+ (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
+ `(list ,@(map make1 body)))
+
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
+
+(define custom-transformer-table
+ (make-pmatch-transformers
+ e l retrans
+ (quote
+ ;; (quote OBJ)
+ ((,obj) (make-ghil-quote e l obj)))
+
+ (quasiquote
+ ;; (quasiquote OBJ)
+ ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
+
+ (define
+ ;; (define NAME VAL)
+ ((,name ,val) (guard (symbol? name)
+ (ghil-toplevel-env? (ghil-env-parent e)))
+ (make-ghil-define e l (ghil-define (ghil-env-parent e) name)
+ (maybe-name-value! (retrans val) name)))
+ ;; (define (NAME FORMALS...) BODY...)
+ (((,name . ,formals) . ,body) (guard (symbol? name))
+ ;; -> (define NAME (lambda FORMALS BODY...))
+ (retrans `(define ,name (lambda ,formals ,@body)))))
+
+ (set!
+ ;; (set! NAME VAL)
+ ((,name ,val) (guard (symbol? name))
+ (make-ghil-set e l (ghil-lookup e name) (retrans val)))
+
+ ;; (set! (NAME ARGS...) VAL)
+ (((,name . ,args) ,val) (guard (symbol? name))
+ ;; -> ((setter NAME) ARGS... VAL)
+ (retrans `((setter ,name) . (,@args ,val)))))
+
+ (if
+ ;; (if TEST THEN [ELSE])
+ ((,test ,then)
+ (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
+ ((,test ,then ,else)
+ (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
+
+ (and
+ ;; (and EXPS...)
+ (,tail (make-ghil-and e l (map retrans tail))))
+
+ (or
+ ;; (or EXPS...)
+ (,tail (make-ghil-or e l (map retrans tail))))
+
+ (begin
+ ;; (begin EXPS...)
+ (,tail (make-ghil-begin e l (map retrans tail))))
+
+ (let
+ ;; (let NAME ((SYM VAL) ...) BODY...)
+ ((,name ,bindings . ,body) (guard (symbol? name)
+ (valid-bindings? bindings))
+ ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
+ (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
+ (,name ,@(map cadr bindings)))))
+
+ ;; (let () BODY...)
+ ((() . ,body)
+ ;; Note: this differs from `begin'
+ (make-ghil-begin e l (list (trans-body e l body))))
+
+ ;; (let ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (let ((vals (map retrans (map cadr bindings))))
+ (call-with-ghil-bindings e (map car bindings)
+ (lambda (vars)
+ (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+ (let*
+ ;; (let* ((SYM VAL) ...) BODY...)
+ ((() . ,body)
+ (retrans `(let () ,@body)))
+ ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
+ (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
+
+ (letrec
+ ;; (letrec ((SYM VAL) ...) BODY...)
+ ((,bindings . ,body) (guard (valid-bindings? bindings))
+ (call-with-ghil-bindings e (map car bindings)
+ (lambda (vars)
+ (let ((vals (map retrans (map cadr bindings))))
+ (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+ (cond
+ ;; (cond (CLAUSE BODY...) ...)
+ (() (retrans '(begin)))
+ (((else . ,body)) (retrans `(begin ,@body)))
+ (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
+ (((,test => ,proc) . ,rest)
+ ;; FIXME hygiene!
+ (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
+ (((,test . ,body) . ,rest)
+ (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
+
+ (case
+ ;; (case EXP ((KEY...) BODY...) ...)
+ ((,exp . ,clauses)
+ (retrans
+ ;; FIXME hygiene!
+ `(let ((_t ,exp))
+ ,(let loop ((ls clauses))
+ (cond ((null? ls) '(begin))
+ ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
+ (else `(if (memv _t ',(caar ls))
+ (begin ,@(cdar ls))
+ ,(loop (cdr ls))))))))))
+
+ (do
+ ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
+ ((,bindings (,test . ,result) . ,body)
+ (let ((sym (map car bindings))
+ (val (map cadr bindings))
+ (update (map cddr bindings)))
+ (define (next s x) (if (pair? x) (car x) s))
+ (retrans
+ ;; FIXME hygiene!
+ `(letrec ((_l (lambda ,sym
+ (if ,test
+ (begin ,@result)
+ (begin ,@body
+ (_l ,@(map next sym update)))))))
+ (_l ,@val))))))
+
+ (lambda
+ ;; (lambda FORMALS BODY...)
+ ((,formals . ,body)
+ (receive (syms rest) (parse-formals formals)
+ (call-with-ghil-environment e syms
+ (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
+ ;; 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)
+ (else
+ (pmatch (car in)
+ ((else . ,body)
+ (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
+ (primitive-eval `(begin ,@body)))
+ (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
+ runtime
+ body))
+ ((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
+ (for-each (lambda (k)
+ (if (memq k seen)
+ (syntax-error l "eval-case condition seen twice" k)))
+ keys)
+ (if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
+ (primitive-eval `(begin ,@body)))
+ (loop (append keys seen)
+ (cdr in)
+ (if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
+ (append runtime body)
+ runtime)))
+ (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)
+ (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)))))
+ ((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)
+ (pmatch (cdr df)
+ ((,name ,val) (guard (symbol? name)) (list name val))
+ (((,name . ,formals) . ,body) (guard (symbol? name))
+ (list name `(lambda ,formals ,@body)))
+ (else (syntax-error (location df) "bad define" df))))
+ ;; main
+ (let loop ((ls body) (ds '()))
+ (pmatch ls
+ (() (syntax-error l "bad body" body))
+ (((define . _) . _)
+ (loop (cdr ls) (cons (car ls) ds)))
+ (else
+ (if (null? ds)
+ (trans e l `(begin ,@ls))
+ (trans e l `(letrec ,(map define->binding ds) ,@ls)))))))
+
+(define (parse-formals formals)
+ (cond
+ ;; (lambda x ...)
+ ((symbol? formals) (values (list formals) #t))
+ ;; (lambda (x y z) ...)
+ ((list? formals) (values formals #f))
+ ;; (lambda (x y . z) ...)
+ ((pair? formals)
+ (let loop ((l formals) (v '()))
+ (if (pair? l)
+ (loop (cdr l) (cons (car l) v))
+ (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))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))
HCoop / bpt / guile.git / blobdiff