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

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

@ -28,13 +28,31 @@
[_ #f])) [_ #f]))
(require (lib "stx.ss" "syntax")) (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) (define (filter-clause? clause-stx)
(syntax-case* clause-stx (if not and or) module-or-top-identifier=? (or (if-filter? clause-stx)
[(if . more) #t] (syntax-case* clause-stx (if base:if not and or) module-or-top-identifier=?
[(not . more) #t] [(not . more) #t]
[(and . more) #t] [(and . more) #t]
[(or . more) #t] [(or . more) #t]
[_ #f])) [_ #f])))
(define (begin-clause? clause-stx) (define (begin-clause? clause-stx)
(syntax-case clause-stx (begin) (syntax-case clause-stx (begin)
@ -115,18 +133,26 @@
(loop2... body-stx)))] (loop2... body-stx)))]
[(filter-clause? #'clause1) [(filter-clause? #'clause1)
(let ([loop2... (expand-clauses #'(clause2 ...))]) (let ([loop2... (expand-clauses #'(clause2 ...))])
(syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not (cond
[(if expr) [(if-filter? #'clause1)
#`(if expr #,(loop2... body-stx))] (syntax-case #'clause1 ()
[(not expr) [(the-if expr)
#`(if (not expr) #,(loop2... body-stx))] #`(if expr #,(loop2... body-stx))]
[(or expr ...) [else (raise-syntax-error 'expand-clauses
#`(if (or expr ...) #,(loop2... body-stx))] "internal error: <if-filter> expected" #'clause1)])]
[(and expr ...) [else
#`(if (and expr ...) #,(loop2... body-stx))] (syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not
[_ #;[(if expr)
(raise-syntax-error 'expand-clauses #`(if expr #,(loop2... body-stx))]
"unimplemented <filter>" #'clause1)]))] [(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) [(begin-clause? #'clause1)
(let ([loop2... (expand-clauses #'(clause2 ...))]) (let ([loop2... (expand-clauses #'(clause2 ...))])
(syntax-case #'clause1 () (syntax-case #'clause1 ()

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

@ -10,11 +10,17 @@
:vector-combinations :vector-combinations
:do-until :do-until
:pairs :pairs
:pairs-by
:list-by :list-by
:alist :alist
:hash-table :hash-table
:hash-table-keys :hash-table-keys
:hash-table-values) :hash-table-values
indices->list
indices->vector
last-combination?
next-combination
first-combination)
(require "ec-core.scm") (require "ec-core.scm")
(require-for-syntax "ec-core.scm") (require-for-syntax "ec-core.scm")