~ chicken-core (chicken-5) 7d88987859ba7d67da491723f2602696622c9903
commit 7d88987859ba7d67da491723f2602696622c9903
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri Jun 17 17:17:01 2016 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Fri Jun 17 17:17:01 2016 +0200
Fix several hygiene issues in DSSSL expansions (#806).
The expansion of DSSSL lambda list would take "optional", "let*" and
"let-optionals*" from the current syntactic environment, which might
not have it or a different definition, depending on the user's import
statements.
Now we explicitly take them from the default macro environment or
the chicken macro environment, depending on the macro to use.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 8436d1eb..793c99a8 100644
--- a/NEWS
+++ b/NEWS
@@ -55,6 +55,12 @@
- The default error handler now truncates very long condition
messages (thanks to Lemonboy).
+- Syntax expander
+ - DSSSL lambda lists have improved hygiene, so they don't need
+ the chicken or scheme modules to be imported in full (#806).
+ - The let-optionals* macro no longer needs "quote", "car" and "cdr"
+ to be imported and bound to their default values (#806).
+
4.11.0
- Security fixes
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 1621120c..b30e8205 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -728,7 +728,9 @@
(##sys#extend-macro-environment
'let-optionals*
- `((null? . ,(##sys#primitive-alias 'null?)))
+ `((null? . ,(##sys#primitive-alias 'null?))
+ (car . ,(##sys#primitive-alias 'car))
+ (cdr . ,(##sys#primitive-alias 'cdr)))
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'let-optionals* form '(_ _ list . _))
@@ -741,17 +743,17 @@
(let ((rvar (r 'tmp)))
`(##core#let
((,rvar ,args))
- ,(let loop ([args rvar] [vardefs var/defs])
+ ,(let loop ((args rvar) (vardefs var/defs))
(if (null? vardefs)
`(##core#let () ,@body)
- (let ([head (car vardefs)])
+ (let ((head (car vardefs)))
(if (pair? head)
(let ((rvar2 (r 'tmp2)))
`(##core#let ((,(car head) (##core#if (,%null? ,args)
,(cadr head)
(,%car ,args)))
(,rvar2 (##core#if (,%null? ,args)
- '()
+ (##core#quote ())
(,%cdr ,args))) )
,(loop rvar2 (cdr vardefs)) ) )
`(##core#let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
diff --git a/expand.scm b/expand.scm
index 52ed7198..d96477da 100644
--- a/expand.scm
+++ b/expand.scm
@@ -340,17 +340,18 @@
[else (loop (cdr llist))] ) ) ) )
(define ##sys#expand-extended-lambda-list
- (let ([reverse reverse])
+ (let ((reverse reverse))
(lambda (llist0 body errh se)
(define (err msg) (errh msg llist0))
(define (->keyword s) (string->keyword (##sys#slot s 1)))
- (let ([rvar #f]
- [hasrest #f]
- (%let* (macro-alias 'let* se))
+ (let ((rvar #f)
+ (hasrest #f)
+ ;; These might not exist in se, use default or chicken env:
+ (%let* (macro-alias 'let* ##sys#default-macro-environment))
(%lambda '##core#lambda)
- (%opt (macro-alias 'optional se))
- (%let-optionals* (macro-alias 'let-optionals* se))
- (%let (macro-alias 'let se)))
+ (%opt (macro-alias 'optional ##sys#chicken-macro-environment))
+ (%let-optionals* (macro-alias 'let-optionals* ##sys#chicken-macro-environment))
+ (%let '##core#let))
(let loop ([mode 0] ; req=0, opt=1, rest=2, key=3, end=4
[req '()]
[opt '()]
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index da626ab7..a43b20ed 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -246,7 +246,7 @@
;;; strip-syntax on renamed module identifiers, as well as core identifiers
(module foo (bar)
- (import chicken scheme)
+ (import scheme)
(define bar 1))
@@ -488,7 +488,7 @@
;;; incorrect lookup for keyword variables in DSSSL llists
(module broken-keyword-var ()
- (import scheme chicken)
+ (import scheme (only chicken assert))
((lambda (#!key string) (assert (not string))))) ; refered to R5RS `string'
;;; Missing check for keyword and optional variable types in DSSSL llists
@@ -516,7 +516,7 @@
(define x 99)
(module primitive-assign ()
- (import scheme chicken)
+ (import scheme (only chicken assert setter))
(let ((x 100)) (set! x 20) (assert (= x 20)))
(set! setter 123))
@@ -626,7 +626,7 @@
(module m2 (s3 s4)
- (import chicken scheme)
+ (import scheme)
(define-syntax s3 (syntax-rules () ((_ x) (list x))))
@@ -843,18 +843,31 @@
(f (eval '(lambda ((x 0) #!rest r1) 'foo)))
(f (eval '(lambda (x #!rest (r1 0)) 'foo)))
+;; "optional" expansion should not rely on user imports (hygiene)
+(t '(1 2)
+ (eval '(module x ()
+ (import (only scheme lambda list))
+ ((lambda (x #!optional (y 0)) (list x y)) 1 2))))
+
;; Dotted list syntax can be mixed in
(t '(1 2 3 4 (5 6))
((lambda (x y #!optional o1 o2 . r) (list x y o1 o2 r))
1 2 3 4 5 6))
+;; More DSSSL hygiene issues, from #806
+(module dsssl-extended-lambda-list-hygiene ()
+ (import (prefix scheme s/))
+ (s/define (foo #!optional bar #!rest qux #!key baz)
+ (s/list bar baz qux)))
+
;;; import not seen, if explicitly exported and renamed:
(module rfoo (rbar rbaz)
-(import scheme chicken)
+(import scheme)
(define (rbaz x)
- (print x))
+ (display x)
+ (newline) )
(define-syntax rbar
(syntax-rules ()
@@ -1046,7 +1059,7 @@
;; an identifier to something imported for the runtime environment
(module foonumbers (+)
- (import (except scheme +) chicken)
+ (import (except scheme +) (only chicken error))
(define (+ . _) (error "failed.")))
(import foonumbers)
@@ -1111,7 +1124,7 @@ other-eval
;; definitions, causing the module to be unresolvable.
(module foo ()
- (import chicken scheme)
+ (import scheme)
(define-syntax bar
(syntax-rules ()
((_) (begin (define req 1) (display req) (newline)))))
@@ -1123,7 +1136,7 @@ other-eval
;; and some Schemes (at least Gauche) behave the same way. I think it's
;; broken, since it's unhygienic.
#;(module foo ()
- (import chicken scheme)
+ (import scheme)
(define req 1)
(define-syntax bar
(syntax-rules ()
Trap