~ chicken-core (chicken-5) 83198fca2a540203d11542312c5e1bf7ba915396
commit 83198fca2a540203d11542312c5e1bf7ba915396
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri Jun 17 17:17:01 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Jun 23 21:47:27 2016 +1200
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 f5948cec..2a2268ca 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,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 79251957..ec9aff31 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -723,7 +723,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 . _))
@@ -736,17 +738,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 3739d609..133bd258 100644
--- a/expand.scm
+++ b/expand.scm
@@ -336,17 +336,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 48e2116f..1004f71a 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -247,7 +247,7 @@
;;; strip-syntax on renamed module identifiers, as well as core identifiers
(module foo (bar)
- (import chicken scheme)
+ (import scheme)
(define bar 1))
@@ -489,7 +489,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
@@ -517,7 +517,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))
@@ -627,7 +627,7 @@
(module m2 (s3 s4)
- (import chicken scheme)
+ (import scheme)
(define-syntax s3 (syntax-rules () ((_ x) (list x))))
@@ -844,18 +844,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 ()
@@ -1047,7 +1060,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)
@@ -1106,7 +1119,7 @@ take
;; 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)))))
@@ -1118,7 +1131,7 @@ take
;; 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