;; 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,
;;; 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 match)
: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)
- (call-with-ghil-environment (make-ghil-mod e) '()
- (lambda (env vars)
- (<ghil-lambda> env #f vars #f (trans env #f x)))))
+ (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
+(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 (macroexpand 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))))
+ (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)
- (<ghil-ref> e l (ghil-lookup e y))
- (trans e l y))))
- (else (<ghil-quote> e l x))))
+ (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)))
`(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) (<ghil-void> e l))
+ (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)
- (match tail
+ (pmatch tail
(() (make:void))
(else (bad-syntax))))
;; (quote OBJ)
((quote)
- (match tail
- ((obj) (<ghil-quote> e l obj))
+ (pmatch tail
+ ((,obj) (make-ghil-quote e l obj))
(else (bad-syntax))))
;; (quasiquote OBJ)
((quasiquote)
- (match tail
- ((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj)))
+ (pmatch tail
+ ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))
(else (bad-syntax))))
- ((define define-private)
- (match tail
+ ((define)
+ (pmatch tail
;; (define NAME VAL)
- (((? symbol? name) val)
- (<ghil-define> e l (ghil-lookup e name) (trans:x val)))
+ ((,name ,val) (guard (symbol? name))
+ (make-ghil-define e l (ghil-lookup e name) (trans:x val)))
;; (define (NAME FORMALS...) BODY...)
- ((((? symbol? name) . formals) . body)
- ;; -> (define NAME (lambda FORMALS BODY...))
- (let ((val (trans:x `(lambda ,formals ,@body))))
- (<ghil-define> e l (ghil-lookup e name) val)))
+ (((,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!)
- (match tail
+ (pmatch tail
;; (set! NAME VAL)
- (((? symbol? name) val)
- (<ghil-set> e l (ghil-lookup e name) (trans:x val)))
+ ((,name ,val) (guard (symbol? name))
+ (make-ghil-set e l (ghil-lookup e name) (trans:x val)))
;; (set! (NAME ARGS...) VAL)
- ((((? symbol? name) . args) val)
- ;; -> ((setter NAME) ARGS... VAL)
- (trans:pair `((setter ,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)
- (match tail
- ((test then)
- (<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
- ((test then else)
- (<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
+ (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)
- (<ghil-and> e l (map trans:x tail)))
+ (make-ghil-and e l (map trans:x tail)))
;; (or EXPS...)
((or)
- (<ghil-or> e l (map trans:x tail)))
+ (make-ghil-or e l (map trans:x tail)))
;; (begin EXPS...)
((begin)
- (<ghil-begin> e l (map trans:x tail)))
+ (make-ghil-begin e l (map trans:x tail)))
((let)
- (match tail
+ (pmatch tail
;; (let NAME ((SYM VAL) ...) BODY...)
- (((? symbol? name) (((? symbol? sym) val) ...) body ...)
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (trans:pair `(letrec ((,name (lambda ,sym ,@body))) (,name ,@val))))
+ ((,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'
- (<ghil-begin> e l (list (trans:body body))))
+ ((() . ,body)
+ ;; Note: this differs from `begin'
+ (make-ghil-begin e l (list (trans:body body))))
;; (let ((SYM VAL) ...) BODY...)
- (((((? symbol? sym) val) ...) body ...)
- (let ((vals (map trans:x val)))
- (call-with-ghil-bindings e sym
- (lambda (vars)
- (<ghil-bind> e l vars vals (trans:body 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*)
- (match tail
- (((def ...) body ...)
- (if (null? def)
- (trans:pair `(let () ,@body))
- (trans:pair `(let (,(car def)) (let* ,(cdr def) ,@body)))))
+ (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)
- (match tail
- (((((? symbol? sym) val) ...) body ...)
- (call-with-ghil-bindings e sym
- (lambda (vars)
- (let ((vals (map trans:x val)))
- (<ghil-bind> e l vars vals (trans:body body))))))
+ (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)
- (match tail
+ (pmatch tail
(() (make:void))
- ((('else . body)) (trans:body body))
- (((test) . rest) (trans:pair `(or ,test (cond ,@rest))))
- (((test '=> proc) . rest)
- (trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
- (((test . body) . rest)
- (trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
+ (((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)
- (match tail
- ((exp . clauses)
- (trans:pair
- `(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)))))))))
+ (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)
- (let ()
- (define (next s x) (if (pair? x) (car x) s))
- (match tail
- ((((sym init . update) ...) (test . result) body ...)
- (trans:pair
- `(letrec ((_l (lambda ,sym
- (if ,test
- (let () (void) ,@result)
- (let () (void) ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@init))))
- (else (bad-syntax)))))
+ (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)
- (match tail
- ((formals body ...)
- (receive (syms rest) (parse-formals formals)
- (call-with-ghil-environment e syms
- (lambda (env vars)
- (<ghil-lambda> env l vars rest (trans-body env l body))))))
+ (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))
- (match x
- (() (make:void))
- ((('else . body)) (trans:pair `(begin ,@body)))
- (((((? symbol? key) ...) body ...) rest ...)
- (if (memq 'load-toplevel key)
- (begin
- (primitive-eval `(begin ,@(copy-tree body)))
- (trans:pair `(begin ,@body)))
- (loop rest)))
- (else (bad-syntax)))))
+ (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)
- (<ghil-inline> e l head (map trans:x tail))
- (<ghil-call> e l (trans:x head) (map trans:x tail))))))
+ (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)))
- (match (cdr x)
- ((obj)
+ (pmatch (cdr x)
+ ((,obj)
(if (eq? (car x) 'unquote)
- (<ghil-unquote> e l (trans e l obj))
- (<ghil-unquote-splicing> e l (trans e l obj))))
+ (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)
- (match (cdr df)
- (((? symbol? name) val) (list name val))
- ((((? symbol? name) . formals) . body)
+ (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)))))))
+ (pmatch ls
+ (() (syntax-error l "bad body" body))
+ (((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
HCoop / bpt / guile.git / blobdiff