diff --git a/scheme/eval.sld b/scheme/eval.sld index 7c6260b5..ca57f27f 100644 --- a/scheme/eval.sld +++ b/scheme/eval.sld @@ -859,9 +859,15 @@ ; expand : exp -> exp (define (expand exp env rename-env) - (_expand exp env rename-env '())) + (_expand exp env rename-env '() '())) -(define (_expand exp env rename-env local-env) +;; Internal implementation of expand +;; exp - Expression to expand +;; env - Environment of the expression +;; rename-env - Environment of variables renamed directly by macros +;; local-env - Local macro definitions, used by let-syntax +;; local-renamed - Renamed local variables introduced by lambda expressions +(define (_expand exp env rename-env local-env local-renamed) (define (log e) (display (list 'expand e 'env @@ -878,28 +884,42 @@ ((prim? exp) exp) ((ref? exp) exp) ((quote? exp) exp) -TODO: rename all lambda formals and update rename-env accordingly. -will also require renaming refs later on here in expand... -can we use Cyc-er-rename to do this? maybe just use gensym directly as a first-cut -TODO: also need to figure out how to deep-copy rename-env and associate it with -any defined macro. would need to pull that out when macro is expanded later - ((lambda? exp) `(lambda ,(lambda->formals exp) - ,@(_expand-body '() (lambda->exp exp) env rename-env local-env) - ;,@(map - ; ;; TODO: use extend env here? - ; (lambda (expr) (_expand expr env rename-env local-env)) - ; (lambda->exp exp)) - )) +;; TODO: rename all lambda formals and update rename-env accordingly. +;; will also require renaming refs later on here in expand... +;; can we use Cyc-er-rename to do this? maybe just use gensym directly as a first-cut +;; TODO: also need to figure out how to deep-copy rename-env and associate it with +;; any defined macro. would need to pull that out when macro is expanded later + ((lambda? exp) + (let* ((args (lambda-formals->list exp)) + (ltype (lambda-formals-type exp)) + (a-lookup (map (lambda (a) (cons a (gensym a))) args)) + (new-formals + (list->lambda-formals + (map cdr a-lookup) + ltype)) + ) + `(lambda ,(lambda->formals exp) + ;; TODO: want this line instead of the above, but need to solve a crash + ;; when compiling unit tests first (!!!) + ;`(lambda ,new-formals ;,(lambda->formals exp) + ,@(_expand-body + '() + (lambda->exp exp) + env + rename-env + local-env + (append a-lookup local-renamed)) + ))) ((define? exp) (if (define-lambda? exp) - (_expand (define->lambda exp) env rename-env local-env) - `(define ,(_expand (define->var exp) env rename-env local-env) - ,@(_expand (define->exp exp) env rename-env local-env)))) - ((set!? exp) `(set! ,(_expand (set!->var exp) env rename-env local-env) - ,(_expand (set!->exp exp) env rename-env local-env))) - ((if-syntax? exp) `(if ,(_expand (if->condition exp) env rename-env local-env) - ,(_expand (if->then exp) env rename-env local-env) + (_expand (define->lambda exp) env rename-env local-env local-renamed) + `(define ,(_expand (define->var exp) env rename-env local-env local-renamed) + ,@(_expand (define->exp exp) env rename-env local-env local-renamed)))) + ((set!? exp) `(set! ,(_expand (set!->var exp) env rename-env local-env local-renamed) + ,(_expand (set!->exp exp) env rename-env local-env local-renamed))) + ((if-syntax? exp) `(if ,(_expand (if->condition exp) env rename-env local-env local-renamed) + ,(_expand (if->then exp) env rename-env local-env local-renamed) ,(if (if-else? exp) - (_expand (if->else exp) env rename-env local-env) + (_expand (if->else exp) env rename-env local-env local-renamed) ;; Insert default value for missing else clause ;; FUTURE: append the empty (unprinted) value ;; instead of #f @@ -913,8 +933,8 @@ any defined macro. would need to pull that out when macro is expanded later (cond ((macro:syntax-rules? (env:lookup (car trans) env #f)) ;; Handles renamed 'syntax-rules' identifier (_expand - `(define-syntax ,name ,(_expand trans env rename-env local-env)) - env rename-env local-env)) + `(define-syntax ,name ,(_expand trans env rename-env local-env local-renamed)) + env rename-env local-env local-renamed)) (else ;; TODO: for now, do not let a compiled macro be re-defined. ;; this is a hack for performance compiling (scheme base) @@ -936,7 +956,7 @@ any defined macro. would need to pull that out when macro is expanded later ;; TODO: may run into issues with expanding now, before some ;; of the macros are defined. may need to make a special pass ;; to do loading or expansion of macro bodies - `(define ,name ,(_expand body env rename-env local-env))))))) + `(define ,name ,(_expand body env rename-env local-env local-renamed))))))) ((let-syntax? exp) (let* ((body (cons 'begin (cddr exp))) (bindings (cadr exp)) @@ -962,13 +982,13 @@ any defined macro. would need to pull that out when macro is expanded later ;; Broken for renames, replace w/below: (if (tagged-list? 'syntax-rules binding) (if (macro:syntax-rules? (env:lookup (car binding) env #f)) ;; TODO: is this ok? - (cadr (_expand binding env rename-env local-env)) + (cadr (_expand binding env rename-env local-env local-renamed)) binding-body))))) bindings)) (new-local-macro-env (append bindings-as-macros local-env)) ) ;(trace:error `(let-syntax ,new-local-macro-env)) - (_expand body env rename-env new-local-macro-env) ;; TODO: new-local-macro-env + (_expand body env rename-env new-local-macro-env local-renamed) ;; TODO: new-local-macro-env )) ((letrec-syntax? exp) (let* ((body (cons 'begin (cddr exp))) @@ -984,11 +1004,11 @@ any defined macro. would need to pull that out when macro is expanded later (list 'macro (if (macro:syntax-rules? (env:lookup (car binding) body-env #f)) - (cadr (_expand binding body-env rename-env local-env)) + (cadr (_expand binding body-env rename-env local-env local-renamed)) binding-body)))) (env:define-variable! name macro-val) body-env)) bindings) - (_expand body body-env rename-env local-env) + (_expand body body-env rename-env local-env local-renamed) )) ((app? exp) (cond @@ -1012,13 +1032,13 @@ any defined macro. would need to pull that out when macro is expanded later (macro:expand exp val env rename-env) env rename-env - local-env)) + local-env local-renamed)) ((Cyc-macro? val) (_expand ; Could expand into another macro (macro:expand exp (list 'macro val) env rename-env) env rename-env - local-env)) + local-env local-renamed)) ;; TODO: if we are doing this, only want to do so if the original variable is a macro. ;; this is starting to get overly complicated though. ;; if nothing else should encapsulate the above lookup into a function and call that @@ -1033,10 +1053,10 @@ any defined macro. would need to pull that out when macro is expanded later ;;(newline) ;; (_expand ;; (cons val (cdr exp)) -;; env rename-env local-env)) +;; env rename-env local-env local-renamed)) (else (map - (lambda (expr) (_expand expr env rename-env local-env)) + (lambda (expr) (_expand expr env rename-env local-env local-renamed)) exp))))) (else ;; TODO: note that map does not guarantee that expressions are @@ -1044,7 +1064,7 @@ any defined macro. would need to pull that out when macro is expanded later ;; in reverse order. Might be better to use a fold here and ;; elsewhere in (expand). (map - (lambda (expr) (_expand expr env rename-env local-env)) + (lambda (expr) (_expand expr env rename-env local-env local-renamed)) exp)))) (else (error "unknown exp: " exp)))) @@ -1062,9 +1082,9 @@ any defined macro. would need to pull that out when macro is expanded later ;; Helper to expand a lambda body, so we can splice in any begin's (define (expand-body result exp env rename-env) - (_expand-body result exp env rename-env '())) + (_expand-body result exp env rename-env '() '())) -(define (_expand-body result exp env rename-env local-env) +(define (_expand-body result exp env rename-env local-env local-renamed) (define (log e) (display (list 'expand-body e 'env (env:frame-variables (env:first-frame env))) @@ -1083,7 +1103,7 @@ any defined macro. would need to pull that out when macro is expanded later (quote? this-exp) (define-c? this-exp)) ;(log this-exp) - (_expand-body (cons this-exp result) (cdr exp) env rename-env local-env)) + (_expand-body (cons this-exp result) (cdr exp) env rename-env local-env local-renamed)) ((define? this-exp) ;(log this-exp) (_expand-body @@ -1093,7 +1113,7 @@ any defined macro. would need to pull that out when macro is expanded later (cdr exp) env rename-env - local-env)) + local-env local-renamed)) ((or (define-syntax? this-exp) (letrec-syntax? this-exp) (let-syntax? this-exp) @@ -1103,12 +1123,12 @@ any defined macro. would need to pull that out when macro is expanded later ;(log (car this-exp)) (_expand-body (cons - (_expand this-exp env rename-env local-env) + (_expand this-exp env rename-env local-env local-renamed) result) (cdr exp) env rename-env - local-env)) + local-env local-renamed)) ;; Splice in begin contents and keep expanding body ((begin? this-exp) (let* ((expr this-exp) @@ -1119,7 +1139,7 @@ any defined macro. would need to pull that out when macro is expanded later (append begin-exprs (cdr exp)) env rename-env - local-env))) + local-env local-renamed))) ((app? this-exp) (cond ((symbol? (caar exp)) @@ -1141,7 +1161,7 @@ any defined macro. would need to pull that out when macro is expanded later (cdr exp)) env rename-env - local-env)) + local-env local-renamed)) ;; No macro, use main expand function to process (_expand-body (cons @@ -1152,7 +1172,7 @@ any defined macro. would need to pull that out when macro is expanded later (cdr exp) env rename-env - local-env)))) + local-env local-renamed)))) (else ;(log 'app) (_expand-body @@ -1164,10 +1184,30 @@ any defined macro. would need to pull that out when macro is expanded later (cdr exp) env rename-env - local-env)))) + local-env local-renamed)))) (else (error "unknown exp: " this-exp)))))) +;; TODO: this is copied from (scheme cyclone transforms) need to relocate both into a common place +(define (list->lambda-formals args type) + (cond + ((eq? type 'args:fixed) args) + ((eq? type 'args:fixed-with-varargs) (list->pair args)) + ((eq? type 'args:varargs) + (if (> (length args) 1) + (error `(Too many args for varargs ,args)) + (car args))) + (else (error `(Unexpected type ,type))))) +(define (list->pair l) + (let loop ((lst l)) + (cond + ((not (pair? lst)) + lst) + ((null? (cdr lst)) + (car lst)) + (else + (cons (car lst) (loop (cdr lst))))))) + ;; Container for built-in macros (define (get-macros) *defined-macros*) (define *defined-macros* (list)) diff --git a/tests/let-syntax.scm b/tests/let-syntax.scm index a13ac537..f5b02837 100644 --- a/tests/let-syntax.scm +++ b/tests/let-syntax.scm @@ -1,166 +1,172 @@ (import (scheme base) (scheme write) (scheme cyclone pretty-print)) -;; Just testing, may want to remove this one once the recursive macro expansion works -; (define-syntax my-or2 (syntax-rules () -; ((my-or2) #f) -; ((my-or2 e) e) -; ((my-or2 e1 e2 ...) -; (let ((temp e1)) (if temp temp (my-or2 e2 ...)))))) -;(write (my-or2 #t)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; (define-syntax my-or (syntax-rules () -; ((my-or) #f) -; ((my-or e) e) -; ((my-or e1 e2 ...) -; (let ((temp e1)) (if temp temp (my-or e2 ...)))))) -; (write -; (let ((x #f) -; (y 7) -; (temp 8) -; (my-let odd?) -; (my-if even?)) -; (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 -; -; (define-syntax foo (syntax-rules () -; ((_ b) -; (bar a b)))) -; (define-syntax bar (syntax-rules () ((_ c d) -; (cons c (let ((c 3)) -; (list d c 'c)))))) -; (write -; (let ((a 2)) -; (foo a))) - -;; Chibi also fails with the same error when this is a let-synatx macro, -;; so it may be that Cyclone works just fine here! Obviously it needs -;; to be able to handle this macro in letrec-syntax form, though -#;(let-syntax - ((my-or (syntax-rules () - ((my-or) #f) - ((my-or e) e) - ((my-or e1 e2 ...) - (let ((temp e1)) (if temp temp (my-or e2 ...))))))) - (let ((x #f) - (y 7) - (temp 8) - (my-let odd?) - (my-if even?)) - (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 - -;; TODO: below should work with "let" and "if" instead of "my-let" and "my-if" -;; TODO: below does not work in eval - WTF? -(write -(letrec-syntax - ((my-or (syntax-rules () - ((my-or) #f) - ((my-or e) e) - ((my-or e1 e2 ...) - (let ((temp e1)) (if temp temp (my-or e2 ...))))))) - (let ((x #f) - (y 7) - (temp 8) - (my-let odd?) - (my-if even?)) - (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 -) - - -;; From Chibi - isn't this a bug though? -;(write -;(let () -; (letrec-syntax () -; (define internal-def 'ok)) -; internal-def) -;) - -;; From Husk: -;; -; Examples from the source to R5RS pitfall 3.3 -;; (assert/equal -;; (let ((a 1)) -;; (letrec-syntax -;; ((foo (syntax-rules () -;; ((_ b) -;; (bar a b)))) -;; (bar (syntax-rules () -;; ((_ c d) -;; (cons c (let ((c 3)) -;; (list d c 'c))))))) -;; (let ((a 2)) -;; (foo a)))) -;; '(1 2 3 a)) -;; -;; ; Examples from/based on pitfall 8.3 (assert/equal 1 -;; (let ((x 1)) -;; (let-syntax ((foo (syntax-rules () ((_) 2)))) -;; (define x (foo)) -;; 3) -;; x)) -;; (assert/equal 1 -;; (let ((x 1)) -;; (letrec-syntax ((foo (syntax-rules () ((_) 2)))) (define x (foo)) -;; 3) -;; x)) -;; -;; ; Issue #151 - Preserve hygiene across syntax-rules and ER macros -;; (assert/equal -;; (let ((unquote 'foo)) `(,'bar)) -;; '(,'bar)) - - -#;(let ((a 1)) - (let-syntax - ;;(letrec-syntax - ((foo (syntax-rules () - ((_ b) - (bar a b)))) - (bar (syntax-rules () ((_ c d) - (cons c (let ((c 3)) - (list d c 'c))))))) - (let ((a 2)) - (foo a)))) - - -(define-syntax my-let - (syntax-rules - () - ((my-let ((name val) ...) body1 body2 ...) - ((lambda (name ...) body1 body2 ...) val ...)) - ((my-let tag ((name val) ...) body1 body2 ...) - ((letrec ((tag (lambda (name ...) body1 body2 ...))) - tag) - val ...)))) -(write -(my-let ((x 'outer)) - (let-syntax ((m (syntax-rules () ((m) x)))) - (my-let ((x 'inner)) - (m)))) ;; Should be outer - ) - - -;; (let-syntax ((given-that (syntax-rules () -;; ((given-that test stmt1 stmt2 ...) -;; (if test -;; (begin stmt1 -;; stmt2 ...)))))) -;; (let ((if #t)) -;; (given-that if (set! if 'now)) -;; if)) ;; => now - (write (let ((x 'outer)) - (let-syntax ((m (syntax-rules () ((m) x)))) + ;(let-syntax ((m (syntax-rules () ((m) x)))) (let ((x 'inner)) - (m)))) ;; Should be outer - ) - -;(write -;(let ((x 'outer)) -; (define-syntax m ;; Testing this out, but let-syntax needs to work, too -; (syntax-rules () ((m) x))) -; (let ((x 'inner)) -; (m))) ;; Should be outer -; ) -; -;(write (m)) ;; Should be an error, of course + (list)))) ;; Should be outer + ; ) +;;;; Just testing, may want to remove this one once the recursive macro expansion works +;;; (define-syntax my-or2 (syntax-rules () +;;; ((my-or2) #f) +;;; ((my-or2 e) e) +;;; ((my-or2 e1 e2 ...) +;;; (let ((temp e1)) (if temp temp (my-or2 e2 ...)))))) +;;;(write (my-or2 #t)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; (define-syntax my-or (syntax-rules () +;;; ((my-or) #f) +;;; ((my-or e) e) +;;; ((my-or e1 e2 ...) +;;; (let ((temp e1)) (if temp temp (my-or e2 ...)))))) +;;; (write +;;; (let ((x #f) +;;; (y 7) +;;; (temp 8) +;;; (my-let odd?) +;;; (my-if even?)) +;;; (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 +;;; +;;; (define-syntax foo (syntax-rules () +;;; ((_ b) +;;; (bar a b)))) +;;; (define-syntax bar (syntax-rules () ((_ c d) +;;; (cons c (let ((c 3)) +;;; (list d c 'c)))))) +;;; (write +;;; (let ((a 2)) +;;; (foo a))) +;; +;;;; Chibi also fails with the same error when this is a let-synatx macro, +;;;; so it may be that Cyclone works just fine here! Obviously it needs +;;;; to be able to handle this macro in letrec-syntax form, though +;;#;(let-syntax +;; ((my-or (syntax-rules () +;; ((my-or) #f) +;; ((my-or e) e) +;; ((my-or e1 e2 ...) +;; (let ((temp e1)) (if temp temp (my-or e2 ...))))))) +;; (let ((x #f) +;; (y 7) +;; (temp 8) +;; (my-let odd?) +;; (my-if even?)) +;; (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 +;; +;;;; TODO: below should work with "let" and "if" instead of "my-let" and "my-if" +;;;; TODO: below does not work in eval - WTF? +;;(write +;;(letrec-syntax +;; ((my-or (syntax-rules () +;; ((my-or) #f) +;; ((my-or e) e) +;; ((my-or e1 e2 ...) +;; (let ((temp e1)) (if temp temp (my-or e2 ...))))))) +;; (let ((x #f) +;; (y 7) +;; (temp 8) +;; (my-let odd?) +;; (my-if even?)) +;; (my-or x (my-let temp) (my-if y) y))) ;; ==> 7 +;;) +;; +;; +;;;; From Chibi - isn't this a bug though? +;;;(write +;;;(let () +;;; (letrec-syntax () +;;; (define internal-def 'ok)) +;;; internal-def) +;;;) +;; +;;;; From Husk: +;;;; +;;; Examples from the source to R5RS pitfall 3.3 +;;;; (assert/equal +;;;; (let ((a 1)) +;;;; (letrec-syntax +;;;; ((foo (syntax-rules () +;;;; ((_ b) +;;;; (bar a b)))) +;;;; (bar (syntax-rules () +;;;; ((_ c d) +;;;; (cons c (let ((c 3)) +;;;; (list d c 'c))))))) +;;;; (let ((a 2)) +;;;; (foo a)))) +;;;; '(1 2 3 a)) +;;;; +;;;; ; Examples from/based on pitfall 8.3 (assert/equal 1 +;;;; (let ((x 1)) +;;;; (let-syntax ((foo (syntax-rules () ((_) 2)))) +;;;; (define x (foo)) +;;;; 3) +;;;; x)) +;;;; (assert/equal 1 +;;;; (let ((x 1)) +;;;; (letrec-syntax ((foo (syntax-rules () ((_) 2)))) (define x (foo)) +;;;; 3) +;;;; x)) +;;;; +;;;; ; Issue #151 - Preserve hygiene across syntax-rules and ER macros +;;;; (assert/equal +;;;; (let ((unquote 'foo)) `(,'bar)) +;;;; '(,'bar)) +;; +;; +;;#;(let ((a 1)) +;; (let-syntax +;; ;;(letrec-syntax +;; ((foo (syntax-rules () +;; ((_ b) +;; (bar a b)))) +;; (bar (syntax-rules () ((_ c d) +;; (cons c (let ((c 3)) +;; (list d c 'c))))))) +;; (let ((a 2)) +;; (foo a)))) +;; +;; +;;(define-syntax my-let +;; (syntax-rules +;; () +;; ((my-let ((name val) ...) body1 body2 ...) +;; ((lambda (name ...) body1 body2 ...) val ...)) +;; ((my-let tag ((name val) ...) body1 body2 ...) +;; ((letrec ((tag (lambda (name ...) body1 body2 ...))) +;; tag) +;; val ...)))) +;;(write +;;(my-let ((x 'outer)) +;; (let-syntax ((m (syntax-rules () ((m) x)))) +;; (my-let ((x 'inner)) +;; (m)))) ;; Should be outer +;; ) +;; +;; +;;;; (let-syntax ((given-that (syntax-rules () +;;;; ((given-that test stmt1 stmt2 ...) +;;;; (if test +;;;; (begin stmt1 +;;;; stmt2 ...)))))) +;;;; (let ((if #t)) +;;;; (given-that if (set! if 'now)) +;;;; if)) ;; => now +;; +;;(write +;;(let ((x 'outer)) +;; (let-syntax ((m (syntax-rules () ((m) x)))) +;; (let ((x 'inner)) +;; (m)))) ;; Should be outer +;; ) +;; +;;;(write +;;;(let ((x 'outer)) +;;; (define-syntax m ;; Testing this out, but let-syntax needs to work, too +;;; (syntax-rules () ((m) x))) +;;; (let ((x 'inner)) +;;; (m))) ;; Should be outer +;;; ) +;;; +;;;(write (m)) ;; Should be an error, of course