From 7aa1fbaca16c4ecd0310b843290512ebabc21af5 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 25 Feb 2017 21:04:45 +0100 Subject: [PATCH 4/5] Change the way LET bodies are macro-expanded. A macro might expand into a define. That means we need to keep expanding the body and restart the main expansion process when we encounter a define. Instead of returning the original expressions when wrapping up, we should return the macro-expanded expressions, because macros should be called exactly once to be safe in the presence of side-effects. We now also treat ##core#begin as a reason to restart the expansion process, because nested begins can contain definitions as well. The expansion will recursively eliminate those nested begins. There is some special treatment for ##core#module and "import", because those do all kinds of nasty side-effecting things which ensure we can't simply expand the body in one go. Import is one of those aforementioned side-effecting macros, and the core module form is also side-effecting in a way: we can't refer to the module until it has been processed by the compiler. There could be other macros and special forms that are allowed in let bodies but need special processing. This situation needs to be addressed properly and fixed in general, but for now we can fix them by adding more special cases. Note that this is not a newly introduced problem: there have always been such issues, but due to the obscure workings of ##sys#canonicalize-body they would only surface under very specific conditions. --- expand.scm | 103 ++++++++++++++++++++++++++++++------------------- tests/syntax-tests.scm | 4 ++ 2 files changed, 68 insertions(+), 39 deletions(-) diff --git a/expand.scm b/expand.scm index 9ee0140..b1a91eb 100644 --- a/expand.scm +++ b/expand.scm @@ -480,6 +480,7 @@ (define define-definition) (define define-syntax-definition) (define define-values-definition) +(define import-definition) (define ##sys#canonicalize-body (lambda (body #!optional (se (##sys#current-environment)) cs?) @@ -490,24 +491,52 @@ ((define) (if f (eq? f define-definition) (eq? s id))) ((define-syntax) (if f (eq? f define-syntax-definition) (eq? s id))) ((define-values) (if f (eq? f define-values-definition) (eq? s id))) + ((import) (if f (eq? f import-definition) (eq? s id))) (else (eq? s id)))))) (define (fini vars vals mvars body) (if (and (null? vars) (null? mvars)) - (let loop ([body2 body] [exps '()]) - (if (not (pair? body2)) - (cons + ;; Macro-expand body, and restart when defines are found. + (let loop ((body body) (exps '())) + (if (not (pair? body)) + (cons '##core#begin - body) ; no more defines, otherwise we would have called `expand' - (let ((x (car body2))) - (if (and (pair? x) - (let ((d (car x))) - (and (symbol? d) - (or (comp 'define d) - (comp 'define-values d))))) - (cons - '##core#begin - (##sys#append (reverse exps) (list (expand body2)))) - (loop (cdr body2) (cons x exps)) ) ) ) ) + (reverse exps)) ; no more defines, otherwise we would have called `expand' + (let loop2 ((body body)) + (let ((x (car body)) + (rest (cdr body))) + (if (and (pair? x) + (let ((d (car x))) + (and (symbol? d) + (or (comp 'define d) + (comp 'define-values d) + (comp 'define-syntax d) + (comp '##core#begin d) + (comp 'import d))))) + ;; Stupid hack to avoid expanding imports + (if (comp 'import (car x)) + (loop rest (cons x exps)) + (cons + '##core#begin + (##sys#append (reverse exps) (list (expand body))))) + (let ((x2 (##sys#expand-0 x se cs?))) + (if (eq? x x2) + ;; Modules must be registered before we + ;; can continue with other forms, so + ;; hand back control to the compiler + (if (and (pair? x) + (symbol? (car x)) + (comp '##core#module (car x))) + `(##core#begin + ,@(reverse exps) + ,x + ,@(if (null? rest) + '() + `((##core#let () ,@rest)))) + (loop rest (cons x exps))) + (loop2 (cons x2 rest)) )) ))) )) + ;; We saw defines. Translate to letrec, and let compiler + ;; call us again for the remaining body by wrapping the + ;; remaining body forms in a ##core#let. (let* ((result `(##core#let ,(##sys#map @@ -549,6 +578,8 @@ (defjam-error def)) (loop (cdr body) (cons def defs) #f))) (else (loop body defs #t)))))) + ;; Expand a run of defines or define-syntaxes into letrec. As + ;; soon as we encounter something else, finish up. (define (expand body) ;; Each #t in "mvars" indicates an MV-capable "var". Non-MV ;; vars (#f in mvars) are 1-element lambda-lists for simplicity. @@ -598,14 +629,7 @@ (loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars))) ((comp '##core#begin head) (loop (##sys#append (cdr x) rest) vars vals mvars)) - (else - (if (member (list head) vars) - (fini vars vals mvars body) - (let ((x2 (##sys#expand-0 x se cs?))) - (if (eq? x x2) - (fini vars vals mvars body) - (loop (cons x2 rest) - vars vals mvars))))))))))) + (else (fini vars vals mvars body)))))))) (expand body) ) ) @@ -959,23 +983,24 @@ ##sys#current-environment ##sys#macro-environment #f #t 'reexport))) -(##sys#extend-macro-environment - 'import '() - (##sys#er-transformer - (lambda (x r c) - `(##core#begin - ,@(map (lambda (x) - (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import))) - (if (not spec) - (##sys#syntax-error-hook - 'import "cannot import from undefined module" name) - (##sys#import - spec v s i - ##sys#current-environment ##sys#macro-environment #f #f 'import)) - (if (not lib) - '(##core#undefined) - `(##core#require ,lib ,(module-requirement name))))) - (cdr x)))))) +(set! chicken.expand#import-definition + (##sys#extend-macro-environment + 'import '() + (##sys#er-transformer + (lambda (x r c) + `(##core#begin + ,@(map (lambda (x) + (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import))) + (if (not spec) + (##sys#syntax-error-hook + 'import "cannot import from undefined module" name) + (##sys#import + spec v s i + ##sys#current-environment ##sys#macro-environment #f #f 'import)) + (if (not lib) + '(##core#undefined) + `(##core#require ,lib ,(module-requirement name))))) + (cdr x))))))) (##sys#extend-macro-environment 'begin-for-syntax '() diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index 1da12c3..6cbb751 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -794,6 +794,10 @@ (define-record-type foo (make-foo bar) foo? (bar foo-bar)) (foo-bar (make-foo 1))))) +;; Nested begins inside definitions were not treated correctly +(t 3 (eval '(let () (begin 1 (begin 2 (define internal-def 3) internal-def))))) +(f (eval '(let () internal-def))) + ;;; renaming of keyword argument (#277) (define-syntax foo1 -- 2.1.4