suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

bugfix commit from Jens Axel

Browse Source 
svn: r12489
This commit is contained in:
Eli Barzilay 2008-11-18 14:49:31 +00:00
parent 2b17f505e5
commit 96075e9793
2 changed files with 55 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/srfi/42/expansion.scm
View File

@ -27,15 +27,33 @@
(generator? (syntax-local-value #'name (lambda () #f))))]
[_ #f]))
(require (lib "stx.ss" "syntax"))
(define (filter-clause? clause-stx)
(syntax-case* clause-stx (if not and or) module-or-top-identifier=?
[(if . more) #t]
[(not . more) #t]
[(and . more) #t]
[(or . more) #t]
[_ #f]))
(require (lib "stx.ss" "syntax"))
(require (prefix base: scheme)
(for-meta 1 (prefix base: scheme)))
(define (if-filter? stx)
(syntax-case stx ()
[(head expr)
(and (identifier? #'head)
(eq? 'if (syntax-e #'head)))]
[else #f]))
(require (prefix new- scheme))
#;(define (if-filter? stx)
(syntax-case* stx (if new-if) module-or-top-identifier=?
[(if expr) #t]
[(new-if expr) #t]
[_ #f]))
(define (filter-clause? clause-stx)
(or (if-filter? clause-stx)
(syntax-case* clause-stx (if base:if not and or) module-or-top-identifier=?
[(not . more) #t]
[(and . more) #t]
[(or . more) #t]
[_ #f])))
(define (begin-clause? clause-stx)
(syntax-case clause-stx (begin)
[(begin . more) #t]
@ -115,18 +133,26 @@
(loop2... body-stx)))]
[(filter-clause? #'clause1)
(let ([loop2... (expand-clauses #'(clause2 ...))])
(syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not
[(if expr)
#`(if expr #,(loop2... body-stx))]
[(not expr)
#`(if (not expr) #,(loop2... body-stx))]
[(or expr ...)
#`(if (or expr ...) #,(loop2... body-stx))]
[(and expr ...)
#`(if (and expr ...) #,(loop2... body-stx))]
[_
(raise-syntax-error 'expand-clauses
"unimplemented <filter>" #'clause1)]))]
(cond
[(if-filter? #'clause1)
(syntax-case #'clause1 ()
[(the-if expr)
#`(if expr #,(loop2... body-stx))]
[else (raise-syntax-error 'expand-clauses
"internal error: <if-filter> expected" #'clause1)])]
[else
(syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not
#;[(if expr)
#`(if expr #,(loop2... body-stx))]
[(not expr)
#`(if (not expr) #,(loop2... body-stx))]
[(or expr ...)
#`(if (or expr ...) #,(loop2... body-stx))]
[(and expr ...)
#`(if (and expr ...) #,(loop2... body-stx))]
[_
(raise-syntax-error 'expand-clauses
"unimplemented <filter>" #'clause1)])]))]
[(begin-clause? #'clause1)
(let ([loop2... (expand-clauses #'(clause2 ...))])
(syntax-case #'clause1 ()
@ -192,4 +218,4 @@
stx)]
[_
(raise-syntax-error 'add-index "think" stx)]))
)
)

10
collects/srfi/42/extra-generators.scm
View File

@ -10,11 +10,17 @@
:vector-combinations
:do-until
:pairs
:pairs-by
:list-by
:alist
:hash-table
:hash-table-keys
:hash-table-values)
:hash-table-values
indices->list
indices->vector
last-combination?
next-combination
first-combination)
(require "ec-core.scm")
(require-for-syntax "ec-core.scm")
@ -367,4 +373,4 @@
'match
"expected (:match <pattern> <expr>)"
stx)]))
)
)