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

upgrade to #lang scheme

Browse Source 
svn: r15344
This commit is contained in:
Jon Rafkind 2009-06-30 20:57:23 +00:00
parent 616630f862
commit 3d356123cf
1 changed files with 43 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/honu/private/util.ss
View File

@ -1,54 +1,52 @@
#lang scheme
(module util mzscheme (provide delim-identifier=?
(provide delim-identifier=? extract-until)
extract-until)
(require syntax/stx) (require syntax/stx)
(define (delim-identifier=? a b) (define (delim-identifier=? a b)
(eq? (syntax-e a) (syntax-e b))) (eq? (syntax-e a) (syntax-e b)))
(define extract-until (define extract-until
(case-lambda (case-lambda
[(r ids keep?) [(r ids keep?)
(let loop ([r r][val-stxs null]) (let loop ([r r][val-stxs null])
(cond (cond
[(stx-null? r) [(stx-null? r)
(values #f #f #f)] (values #f #f #f)]
[(and (identifier? (stx-car r)) [(and (identifier? (stx-car r))
(ormap (lambda (id) (ormap (lambda (id)
(delim-identifier=? id (stx-car r))) (delim-identifier=? id (stx-car r)))
ids)) ids))
(values (reverse (if keep? (values (reverse (if keep?
(cons (stx-car r) val-stxs) (cons (stx-car r) val-stxs)
val-stxs)) val-stxs))
r r
(stx-car r))] (stx-car r))]
[else [else
(loop (stx-cdr r) (cons (stx-car r) val-stxs))]))] (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
[(r ids) (extract-until r ids #f)])) [(r ids) (extract-until r ids #f)]))
(define (test) (define (test)
(let* ([original #'(a b c d e)] (let* ([original #'(a b c d e)]
[delimiter #'c] [delimiter #'c]
[expected-before #'(a b)] [expected-before #'(a b)]
[expected-rest #'(c d e)] [expected-rest #'(c d e)]
[expected-delimiter #'c] [expected-delimiter #'c]
) )
(let-values ([(before rest hit) (extract-until original (list delimiter))]) (let-values ([(before rest hit) (extract-until original (list delimiter))])
;; is there a better way to test equality between two syntaxes? ;; is there a better way to test equality between two syntaxes?
(when (not (and (equal? (syntax-object->datum expected-before) (when (not (and (equal? (syntax->datum expected-before)
(map syntax-object->datum before)) (map syntax->datum before))
(equal? (syntax-object->datum expected-rest) (equal? (syntax->datum expected-rest)
(map syntax-object->datum rest)) (map syntax->datum rest))
(equal? (syntax-object->datum expected-delimiter) (equal? (syntax->datum expected-delimiter)
(syntax-object->datum hit)))) (syntax->datum hit))))
(printf "failure: original ~a until ~a\n" (syntax-object->datum original) (map syntax-object->datum (list delimiter))) (printf "failure: original ~a until ~a\n" (syntax->datum original) (map syntax->datum (list delimiter)))
(printf " before expected ~a actual ~a\n" (syntax-object->datum expected-before) (map syntax-object->datum before)) (printf " before expected ~a actual ~a\n" (syntax->datum expected-before) (map syntax->datum before))
(printf " rest expected ~a actual ~a\n" (syntax-object->datum expected-rest) (map syntax-object->datum rest)) (printf " rest expected ~a actual ~a\n" (syntax->datum expected-rest) (map syntax->datum rest))
(printf " delimiter expected ~a actual ~a\n" (syntax-object->datum expected-delimiter) (syntax-object->datum hit)) (printf " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
)))) ))))
(test) (test)
)