~ chicken-r7rs (master) 691b067f9f719fbab10c6ea8cb5d9e3b35a76691
commit 691b067f9f719fbab10c6ea8cb5d9e3b35a76691
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jun 15 16:11:40 2013 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sat Jun 15 16:11:40 2013 +0000
Implement syntax-rules in r7rs egg
diff --git a/r7rs.scm b/r7rs.scm
index 980f23b..b423eec 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -1,10 +1,10 @@
(module r7rs (define-library)
- (import scheme) ;XXX except ...
+ (import (except scheme syntax-rules)) ;XXX except ...
(import chicken) ;XXX except ...
(import numbers)
(import scheme.base)
- (include "scheme.base-interface.scm")
+ (include "scheme.base-interface.scm")
(begin-for-syntax
(require-library r7rs-compile-time numbers))
diff --git a/r7rs.setup b/r7rs.setup
index 1f2585f..2c65b9d 100644
--- a/r7rs.setup
+++ b/r7rs.setup
@@ -1,13 +1,14 @@
+;; -*- Scheme -*-
(use make)
-
(define scheme-modules
'("base" "process-context")) ;XXX
(make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
(compile -s -O3 -d1 r7rs-compile-time-module.scm -J -o r7rs-compile-time.so)
(compile -s -O3 -d0 r7rs-compile-time.import.scm))
- ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm")
+ ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm"
+ "synrules.scm")
(compile -s -O3 -d1 scheme.base.scm -J)
(compile -s -O3 -d0 scheme.base.import.scm)))
'("r7rs-compile-time.so" "scheme.base.so"))
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index d6805da..42e450d 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -38,7 +38,9 @@
current-input-port current-output-port current-error-port
define
define-record-type
+ |#
define-syntax
+ #|
define-values
denominator numerator
do
@@ -78,7 +80,7 @@
|#
import
#|
- ;; import-for-syntax XXX should we?
+ ;; import-for-syntax XXX should we? Probably not, it's not in r7rs...
include include-ci
|#
input-port-open? output-port-open?
@@ -90,8 +92,10 @@
let let*
letrec letrec*
let-values let*-values
+ |#
let-syntax
letrec-syntax
+ #|
library ; for "cond-expand"
list
list-copy
@@ -161,7 +165,9 @@
symbol=?
symbol?
syntax-error
- ;syntax-rules XXX???
+ |#
+ syntax-rules
+ #|
textual-port?
truncate
truncate-quotient truncate-remainder
diff --git a/scheme.base.scm b/scheme.base.scm
index b2c2b90..0eae03c 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,6 +1,6 @@
(module scheme.base ()
-(import (except scheme cond-expand))
+(import (except scheme syntax-rules cond-expand))
(import (except chicken with-exception-handler raise))
(include "scheme.base-interface.scm")
@@ -95,6 +95,10 @@
(lambda ()
(apply values args))))))))))))))
+;;;
+;;; 5.4. Syntax definitions
+;;;
+(include "synrules.scm")
;;;
;;; 6.11. Exceptions
diff --git a/synrules.scm b/synrules.scm
new file mode 100644
index 0000000..f8cf331
--- /dev/null
+++ b/synrules.scm
@@ -0,0 +1,324 @@
+;;
+;; This is a slightly modified copy of core syntax-rules, enhanced
+;; with underscore "wildcard" patterns and the ellipsis (... ...)
+;; "quoting" mechanism from R7RS.
+;;
+;; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees.
+;; All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. The name of the authors may not be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+; The syntax-rules macro (new in R5RS)
+
+;;; [Hacked slightly by Taylor R. Campbell to make it work in his
+;;; macro expander `riaxpander'.]
+
+;; [Hacked even more by Felix L. Winkelmann to make it work in his
+;; Hi-Lo expander]
+
+; Example:
+;
+; (define-syntax or
+; (syntax-rules ()
+; ((or) #f)
+; ((or e) e)
+; ((or e1 e ...) (let ((temp e1))
+; (if temp temp (or e ...))))))
+
+
+(define-syntax syntax-rules
+ (er-macro-transformer
+ (lambda (exp r c)
+ (##sys#check-syntax 'syntax-rules exp '#(_ 2))
+ (let ((subkeywords (cadr exp))
+ (rules (cddr exp))
+ (ellipsis '...))
+ (when (symbol? subkeywords)
+ (##sys#check-syntax 'syntax-rules exp '(_ _ list . #(_ 0)))
+ (set! ellipsis subkeywords)
+ (set! subkeywords (car rules))
+ (set! rules (cdr rules)))
+ (process-syntax-rules ellipsis rules subkeywords r c)))))
+
+(begin-for-syntax
+ (define (process-syntax-rules ellipsis rules subkeywords r c)
+
+ (define %append '##sys#append)
+ (define %apply '##sys#apply)
+ (define %and (r 'and))
+ (define %car '##sys#car)
+ (define %cdr '##sys#cdr)
+ (define %length '##sys#length)
+ (define %vector? '##sys#vector?)
+ (define %vector->list '##sys#vector->list)
+ (define %list->vector '##sys#list->vector)
+ (define %>= '##sys#>=)
+ (define %= '##sys#=)
+ (define %+ '##sys#+)
+ (define %compare (r 'compare))
+ (define %cond (r 'cond))
+ (define %cons '##sys#cons)
+ (define %else (r 'else))
+ (define %eq? '##sys#eq?)
+ (define %equal? '##sys#equal?)
+ (define %input (r 'input))
+ (define %l (r 'l))
+ (define %len (r 'len))
+ (define %lambda (r 'lambda))
+ (define %let (r 'let))
+ (define %let* (r 'let*))
+ (define %list? '##sys#list?)
+ (define %loop (r 'loop))
+ (define %map1 '##sys#map)
+ (define %map '##sys#map-n)
+ (define %pair? '##sys#pair?)
+ (define %quote (r 'quote))
+ (define %rename (r 'rename))
+ (define %tail (r 'tail))
+ (define %temp (r 'temp))
+ (define %syntax-error '##sys#syntax-error-hook)
+ (define %ellipsis (r ellipsis))
+
+ (define (ellipsis? x)
+ (c x %ellipsis))
+
+ ;; R7RS support: underscore matches anything
+ (define (underscore? x)
+ (c x (r '_)))
+
+ (define (make-transformer rules)
+ `(##sys#er-transformer
+ (,%lambda (,%input ,%rename ,%compare)
+ (,%let ((,%tail (,%cdr ,%input)))
+ (,%cond ,@(map process-rule rules)
+ (,%else
+ (,%syntax-error "no rule matches form" ,%input)))))))
+
+ (define (process-rule rule)
+ (if (and (pair? rule)
+ (pair? (cdr rule))
+ (null? (cddr rule)))
+ (let ((pattern (cdar rule))
+ (template (cadr rule)))
+ `((,%and ,@(process-match %tail pattern #f ellipsis?))
+ (,%let* ,(process-pattern pattern
+ %tail
+ (lambda (x) x) #f ellipsis?)
+ ,(process-template template
+ 0
+ ellipsis?
+ (meta-variables pattern 0 ellipsis? '() #f)))))
+ (%syntax-error "ill-formed syntax rule" rule)))
+
+ ;; Generate code to test whether input expression matches pattern
+
+ (define (process-match input pattern seen-segment? el?)
+ (cond ((symbol? pattern)
+ (if (memq pattern subkeywords)
+ `((,%compare ,input (,%rename (##core#syntax ,pattern))))
+ `()))
+ ((segment-pattern? pattern seen-segment? el?)
+ (process-segment-match input pattern el?))
+ ((pair? pattern)
+ `((,%let ((,%temp ,input))
+ (,%and (,%pair? ,%temp)
+ ,@(process-match `(,%car ,%temp) (car pattern) #f el?)
+ ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f el?)))))
+ ((vector? pattern)
+ `((,%let ((,%temp ,input))
+ (,%and (,%vector? ,%temp)
+ ,@(process-match `(,%vector->list ,%temp)
+ (vector->list pattern) #f el?)))))
+ ((or (null? pattern) (boolean? pattern) (char? pattern))
+ `((,%eq? ,input ',pattern)))
+ (else
+ `((,%equal? ,input ',pattern)))))
+
+ (define (process-segment-match input pattern el?)
+ (let ((conjuncts (process-match `(,%car ,%l) (car pattern) #f el?)))
+ `((,%and (,%list? ,input) ; Can't ask for its length if not a proper list
+ (,%let ((,%len (,%length ,input)))
+ (,%and (,%>= ,%len ,(length (cddr pattern)))
+ (,%let ,%loop ((,%l ,input)
+ (,%len ,%len))
+ (,%cond
+ ((,%= ,%len ,(length (cddr pattern)))
+ ,@(process-match %l (cddr pattern) #t el?))
+ (,%else
+ (,%and ,@conjuncts
+ (,%loop (,%cdr ,%l) (,%+ ,%len -1))))))))))))
+
+ ;; Generate code to take apart the input expression
+ ;; This is pretty bad, but it seems to work (can't say why).
+
+ (define (process-pattern pattern path mapit seen-segment? el?)
+ (cond ((symbol? pattern)
+ (if (or (memq pattern subkeywords) (underscore? pattern))
+ '()
+ (list (list pattern (mapit path)))))
+ ((segment-pattern? pattern seen-segment? el?)
+ (let* ((tail-length (length (cddr pattern)))
+ (%match (if (zero? tail-length) ; Simple segment?
+ path ; No list traversing overhead at runtime!
+ `(##sys#drop-right ,path ,tail-length))))
+ (append
+ (process-pattern (car pattern)
+ %temp
+ (lambda (x) ;temp is free in x
+ (mapit
+ (if (eq? %temp x)
+ %match ; Optimization: no map+lambda
+ `(,%map1 (,%lambda (,%temp) ,x) ,%match))))
+ #f el?)
+ (process-pattern (cddr pattern)
+ `(##sys#take-right ,path ,tail-length)
+ mapit #t el?))))
+ ((pair? pattern)
+ (append (process-pattern (car pattern) `(,%car ,path) mapit #f el?)
+ (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f el?)))
+ ((vector? pattern)
+ (process-pattern (vector->list pattern)
+ `(,%vector->list ,path) mapit #f el?))
+ (else '())))
+
+ ;; Generate code to compose the output expression according to template
+
+ (define (process-template template dim el? env)
+ (cond ((symbol? template)
+ (let ((probe (assq template env)))
+ (if probe
+ (if (<= (cdr probe) dim)
+ template
+ (%syntax-error "template dimension error (too few ellipses?)"
+ template))
+ `(,%rename (##core#syntax ,template)))))
+ ((ellipsis-escaped-pattern? template el?)
+ (if (or (not (pair? (cdr template))) (pair? (cddr template)))
+ (%syntax-error "Invalid escaped ellipsis template" template)
+ (process-template (cadr template) dim (lambda _ #f) env)))
+ ((segment-template? template el?)
+ (let* ((depth (segment-depth template el?))
+ (seg-dim (+ dim depth))
+ (vars
+ (free-meta-variables (car template) seg-dim el? env '())))
+ (if (null? vars)
+ (%syntax-error "too many ellipses" template)
+ (let* ((x (process-template (car template) seg-dim el? env))
+ (gen (if (and (pair? vars)
+ (null? (cdr vars))
+ (symbol? x)
+ (eq? x (car vars)))
+ x ;+++
+ `(,%map (,%lambda ,vars ,x)
+ ,@vars)))
+ (gen (do ((d depth (- d 1))
+ (gen gen `(,%apply ,%append ,gen)))
+ ((= d 1)
+ gen)))
+ (tail (segment-tail template el?)))
+ (if (null? tail)
+ gen ;+++
+ `(,%append ,gen ,(process-template tail dim el? env)))))))
+ ((pair? template)
+ `(,%cons ,(process-template (car template) dim el? env)
+ ,(process-template (cdr template) dim el? env)))
+ ((vector? template)
+ `(,%list->vector
+ ,(process-template (vector->list template) dim el? env)))
+ (else
+ `(,%quote ,template))))
+
+ ;; Return an association list of (var . dim)
+
+ (define (meta-variables pattern dim el? vars seen-segment?)
+ (cond ((symbol? pattern)
+ (if (or (memq pattern subkeywords) (underscore? pattern))
+ vars
+ (cons (cons pattern dim) vars)))
+ ((segment-pattern? pattern seen-segment? el?)
+ (meta-variables (car pattern) (+ dim 1) el?
+ (meta-variables (cddr pattern) dim el? vars #t) #f))
+ ((pair? pattern)
+ (meta-variables (car pattern) dim el?
+ (meta-variables (cdr pattern) dim el? vars #f) #f))
+ ((vector? pattern)
+ (meta-variables (vector->list pattern) dim el? vars #f))
+ (else vars)))
+
+ ;; Return a list of meta-variables of given higher dim
+
+ (define (free-meta-variables template dim el? env free)
+ (cond ((symbol? template)
+ (if (and (not (memq template free))
+ (let ((probe (assq template env)))
+ (and probe (>= (cdr probe) dim))))
+ (cons template free)
+ free))
+ ((segment-template? template el?)
+ (free-meta-variables (car template)
+ dim el? env
+ (free-meta-variables (cddr template)
+ dim el? env free)))
+ ((pair? template)
+ (free-meta-variables (car template)
+ dim el? env
+ (free-meta-variables (cdr template)
+ dim el? env free)))
+ ((vector? template)
+ (free-meta-variables (vector->list template) dim el? env free))
+ (else free)))
+
+ (define (ellipsis-escaped-pattern? pattern el?)
+ (and (pair? pattern) (el? (car pattern))))
+
+ (define (segment-pattern? p seen-segment? el?)
+ (and (segment-template? p el?)
+ (cond
+ (seen-segment?
+ (%syntax-error "Only one segment per level is allowed" p))
+ ((not (list? p)) ; Improper list
+ (%syntax-error "Cannot combine dotted tail and ellipsis" p))
+ (else #t))))
+
+ (define (segment-template? pattern el?)
+ (and (pair? pattern)
+ (pair? (cdr pattern))
+ (el? (cadr pattern))))
+
+ ;; Count the number of `...'s in PATTERN.
+
+ (define (segment-depth pattern el?)
+ (if (segment-template? pattern el?)
+ (+ 1 (segment-depth (cdr pattern) el?))
+ 0))
+
+ ;; Get whatever is after the `...'s in PATTERN.
+
+ (define (segment-tail pattern el?)
+ (let loop ((pattern (cdr pattern)))
+ (if (and (pair? pattern)
+ (el? (car pattern)))
+ (loop (cdr pattern))
+ pattern)))
+
+ (make-transformer rules)))
diff --git a/tests/run.scm b/tests/run.scm
index 9201b30..f5e48b7 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,5 +1,10 @@
(use r7rs test)
+;; XXX: This seems to be necessary in order to get the syntax-rules
+;; from r7rs rather than the built-in CHICKEN one. I'm not sure if
+;; that's correct or not...
+(import-for-syntax r7rs)
+
(define (read-from-string s)
(with-input-from-string s read))
@@ -116,6 +121,276 @@
(test-assert "It's ok to close input ports that are already closed"
(close-port the-string-port)))))
+;; This is for later. We can't define it inside a group because that
+;; would make it locally scoped (as a letrec rewrite), which breaks
+;; the syntax-rules underscore tests. Very subtle (and annoying), this!
+(define (_) 'underscore-procedure)
+(define ___ 'triple-underscore-literal)
+
+(test-group "syntax-rules"
+ (test "let-syntax w/ basic syntax-rules"
+ 100
+ (let-syntax ((foo (syntax-rules ()
+ ((_ x form)
+ (let ((tmp x))
+ (if (number? tmp)
+ form
+ (error "not a number" tmp)))))))
+ (foo 2 100)))
+ (let-syntax ((foo (syntax-rules ()
+ ((_ #(a ...)) (list a ...)))))
+ (test "Basic matching of vectors"
+ '(1 2 3) (foo #(1 2 3))))
+ ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
+ (let-syntax ((foo (syntax-rules ()
+ ((_ (a b) ...)
+ (list 'first '(a b) ...))
+ ((_ a ...)
+ (list 'second '(a) ...)))))
+ (test "Basic ellipsis match"
+ '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))
+ (test "Ellipsis match of length 1 does not match length 2"
+ '(second (1)) (foo 1))
+ (test "Ellipsis match of lists with mismatched lengths (used to fail)"
+ '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))
+
+ (test "letrec-syntax"
+ 34
+ (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
+ (bar (syntax-rules () ((_ x) (+ x 1)))))
+ (foo 33)))
+ (test "Basic hygienic rename of syntactic keywords"
+ 'now
+ (let-syntax ((when (syntax-rules ()
+ ((when test stmt1 stmt2 ...)
+ (if test
+ (begin stmt1
+ stmt2 ...))))))
+ (let ((if #t))
+ (when if (set! if 'now))
+ if)))
+ (test "Basic hygienic rename of shadowed outer let"
+ 'outer
+ (let ((x 'outer))
+ (let-syntax ((m (syntax-rules () ((m) x))))
+ (let ((x 'inner))
+ (m)))))
+ (test "Simple recursive letrec expansion"
+ 7
+ (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)
+ (let odd?)
+ (if even?))
+ (my-or x
+ (let temp)
+ (if y)
+ y))))
+ ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
+ (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))
+ (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))
+ (let-syntax
+ ((foo (syntax-rules ()
+ ((_)
+ '#(b)))))
+ (test "Quoted symbols inside vectors are stripped of syntactic info"
+ '#(b) (foo)))
+ (let-syntax ((kw (syntax-rules (baz)
+ ((_ baz) "baz")
+ ((_ any) "no baz"))))
+ (test "syntax-rules keywords match" "baz" (kw baz))
+ (test "syntax-rules keywords no match" "no baz" (kw xxx))
+ (let ((baz 100))
+ (test "keyword loses meaning if shadowed" "no baz" (kw baz))))
+ (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"
+ 'ok
+ (let ((=> #f))
+ (cond (#t => 'ok))))
+ (test "Nested identifier shadowing works correctly"
+ '(3 4)
+ (let ((foo 3))
+ (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
+ (let ((foo 4))
+ (bar foo)))))
+ (let-syntax ((c (syntax-rules ()
+ ((_)
+ (let ((x 10))
+ (let-syntax ((z (syntax-rules ()
+ ((_) (quote x)))))
+ (z))))))
+ (c2 (syntax-rules ()
+ ((_)
+ (let ((x 10))
+ (let-syntax
+ ((z (syntax-rules ()
+ ((_) (let-syntax
+ ((w (syntax-rules ()
+ ((_) (quote x)))))
+ (w))))))
+ (z)))))))
+ ;; Reported by Matthew Flatt
+ (test "strip-syntax cuts across three levels of syntax"
+ "x" (symbol->string (c)))
+ (test "strip-syntax cuts across four levels of syntax"
+ "x" (symbol->string (c2))))
+ (let-syntax ((foo (syntax-rules
+ ___ ()
+ ((_ vals ___) (list '... vals ___)))))
+ (test "Alternative ellipsis (from SRFI-46)"
+ '(... 1 2 3) (foo 1 2 3)))
+ (let-syntax ((let-alias (syntax-rules
+ ___ ()
+ ((_ new old code ___)
+ (let-syntax
+ ((new
+ (syntax-rules ()
+ ((_ args ...) (old args ...)))))
+ code ___)))))
+ (let-alias inc (lambda (x) (+ 1 x))
+ (test "Ellipsis rules are reset in new macro expansion phase"
+ 3 (inc 2))))
+ (let-syntax ((foo (syntax-rules ()
+ ((_ (a ... b) ... (c d))
+ (list (list (list a ...) ... b ...) c d))
+ ((_ #(a ... b) ... #(c d) #(e f))
+ (list (list (vector a ...) ... b ...) c d e f))
+ ((_ #(a ... b) ... #(c d))
+ (list (list (vector a ...) ... b ...) c d)))))
+ (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"
+ (test '(() 1 2) (foo (1 2)))
+ (test '(((1) 2) 3 4) (foo (1 2) (3 4)))
+ (test '(((1 2) (4) 3 5) 6 7)
+ (foo (1 2 3) (4 5) (6 7)))
+ (test '(() 1 2)
+ (foo #(1 2)))
+ (test '((#() 1) 2 3)
+ (foo #(1) #(2 3)))
+ (test '((#(1 2) 3) 4 5)
+ (foo #(1 2 3) #(4 5)))
+ (test '((#(1 2) 3) 4 5 6 7)
+ (foo #(1 2 3) #(4 5) #(6 7)))
+ (test '(() 1 2 3 4)
+ (foo #(1 2) #(3 4)))
+ (test '((#(1) 2) 3 4 5 6)
+ (foo #(1 2) #(3 4) #(5 6)))
+ (test '((#(1 2) #(4) 3 5) 6 7 8 9)
+ (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))
+ (let-syntax ((foo (syntax-rules ()
+ ((_ #((a) ...)) (list a ...)))))
+ (test "Bug discovered during implementation of rest patterns"
+ '(1)
+ (foo #((1)))))
+ ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
+ ;; occurrances of <ellipsis> inside the template.
+ (let-syntax ((be-like-begin
+ (syntax-rules ()
+ ((be-like-begin name)
+ (define-syntax name
+ (syntax-rules ()
+ ((name expr (... ...))
+ (begin expr (... ...)))))))))
+ (be-like-begin sequence)
+ (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"
+ 4 (sequence 1 2 3 4)))
+ (let-syntax ((ignore-underscores
+ (syntax-rules ()
+ ((_ _ _ _) (_)))))
+ (test "underscores are ignored in patterns"
+ 'underscore-procedure (ignore-underscores _ b c)))
+
+ (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"
+ (test-group "underscore as keyword literal"
+ (define-syntax match-literal-underscores ; for eval
+ (syntax-rules (_)
+ ((x a _ c) (_))
+ ((x _ b c) 1)))
+ (test-error "Missing literal underscore keyword causes syntax-error"
+ (eval '(match-literal-underscores d e f)))
+ (test "Literal underscore matches"
+ 1 (match-literal-underscores _ h i))
+ (test "Literal underscore matches even if it refers to toplevel binding"
+ 'underscore-procedure (match-literal-underscores g _ i)))
+
+ (test-group "underscore as ellipsis"
+ ;; It's undefined what this should do. Logically, it should be
+ ;; possible to bind _ as an ellipsis identifier.
+ (define-syntax match-ellipsis-underscores ; for eval
+ (syntax-rules _ () ((x a _ c) (list a _ c))))
+ (test-error "No rule matching if prefix is omitted"
+ (eval '(match-ellipsis-underscores)))
+ (test "Only prefix is supplied"
+ '(1) (match-ellipsis-underscores 1))
+ (test "Ellipsis does its work if multiple arguments given"
+ '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))
+
+ (test-group "underscore as ellipsis mixed with underscore literal"
+ ;; Even more undefined behaviour: mixing literals and ellipsis identifiers
+ ;; Currently, ellipsis identifiers have precedence over the other two.
+ (define-syntax match-ellipsis-and-literals-underscores ; for eval
+ (syntax-rules _ (_) ((x a _ c) (list a _ c))))
+ (test-error "No rule matching if prefix is omitted"
+ (eval '(match-ellipsis-and-literals-underscores)))
+ (test '(1) (match-ellipsis-and-literals-underscores 1))
+ (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
+ (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))
+
+ (test-group "\"custom\" ellipsis and literal of the same identifier"
+ ;; This is similar to the above, but maybe a little simpler because
+ ;; it does not use reserved names:
+ (define-syntax match-ellipsis-literals
+ (syntax-rules ___ (___)
+ ((_ x ___) (list x ___))))
+ (test "Ellipsis as literals"
+ '(1) (match-ellipsis-literals 1))
+ (test "Ellipsis as literals multiple args"
+ '(1 2) (match-ellipsis-literals 1 2))
+ (test "Toplevel binding of the same name as ellipsis"
+ '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))
+
+ (letrec-syntax ((usetmp
+ (syntax-rules ()
+ ((_ var)
+ (list var))))
+ (withtmp
+ (syntax-rules ()
+ ((_ val exp)
+ (let ((tmp val))
+ (exp tmp))))))
+ (test "Passing a macro as argument to macro"
+ '(99)
+ (withtmp 99 usetmp)))
+
+ ;; renaming of keyword argument (#277)
+ (let-syntax ((let-hello-proc
+ (syntax-rules ()
+ ((_ procname code ...)
+ (let ((procname (lambda (#!key (who "world"))
+ (string-append "hello, " who))))
+ code ...)))))
+ (let-hello-proc bar
+ ;; This is not R7RS, but R7RS should not interfere with other
+ ;; CHICKEN features!
+ (test "DSSSL keyword arguments aren't renamed (not R7RS)"
+ "hello, XXX" (bar who: "XXX")))))
+
(test-end "r7rs tests")
(test-exit)
Trap