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

better code layout (easier to add new options)

Browse Source 
svn: r11956
This commit is contained in:
Eli Barzilay 2008-10-07 07:53:50 +00:00
parent d2bd4c050e
commit da389b03a9
1 changed files with 59 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
collects/syntax/module-reader.ss
View File

@ -7,61 +7,66 @@
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
(define-syntax (provide-module-reader stx) (define-syntax (provide-module-reader stx)
(syntax-case stx () (define (construct-reader lib body)
[(_ lib body ...) (define (err str [sub #f])
(let ([key-args '()]) (raise-syntax-error 'syntax/module-reader str sub))
(define (err str [sub #f]) (define-syntax-rule (keywords -body [kwd var default] ... [checks ...])
(raise-syntax-error 'syntax/module-reader str sub)) (begin
(define -body (define var #f) ...
(let loop ([body (syntax->list #'(body ...))]) (define -body
(if (not (and (pair? body) (let loop ([body body])
(pair? (cdr body)) (if (not (and (pair? body)
(keyword? (syntax-e (car body))))) (pair? (cdr body))
(datum->syntax stx body stx) (keyword? (syntax-e (car body)))))
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) (datum->syntax stx body stx)
(cond (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
[(assq k* key-args) (err (format "got two ~s keywords" k*) k)] (case k*
[(not (memq k* '(#:read #:read-syntax #:wrapper1 #:wrapper2 [(kwd) (if var
#:whole-body-readers?))) (err (format "got two ~s keywords" k*) k)
(err "got an unknown keyword" (car body))] (begin (set! var v) (loop (cddr body))))]
[else (set! key-args (cons (cons k* v) key-args)) ...
(loop (cddr body))]))))) [else (err "got an unknown keyword" (car body))])))))
(define (get kwd [dflt #f]) checks ...
(cond [(assq kwd key-args) => cdr] [else dflt])) (set! var (or var default)) ...))
(unless (equal? (and (assq '#:read key-args) #t) (keywords -body
(and (assq '#:read-syntax key-args) #t)) [#:read ~read #'read]
[#:read-syntax ~read-syntax #'read-syntax]
[#:wrapper1 ~wrapper1 #'#f]
[#:wrapper2 ~wrapper2 #'#f]
[#:whole-body-readers? ~whole-body-readers? #'#f]
[(unless (equal? (and ~read #t) (and ~read-syntax #t))
(err "must specify either both #:read and #:read-syntax, or none")) (err "must specify either both #:read and #:read-syntax, or none"))
(when (and (assq '#:whole-body-readers? key-args) (when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
(not (assq '#:read key-args))) (err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
(err "got a #:whole-body-readers? without #:read and #:read-syntax")) (quasisyntax/loc stx
(quasisyntax/loc stx (#%module-begin
(#%module-begin #,@-body
#,@-body (#%provide (rename *read read) (rename *read-syntax read-syntax))
(#%provide (rename *read read) (rename *read-syntax read-syntax)) (define-values (*read *read-syntax)
(define-values (*read *read-syntax) (let* ([rd #,~read]
(let* ([rd #,(get '#:read #'read)] [rds #,~read-syntax]
[rds #,(get '#:read-syntax #'read-syntax)] [w1 #,~wrapper1]
[w1 #,(get '#:wrapper1 #'#f)] [w2 #,~wrapper2]
[w2 #,(get '#:wrapper2 #'#f)] [w2 (cond [(not w2) (lambda (in r _) (r in))]
[w2 (cond [(not w2) (lambda (in r _) (r in))] [(procedure-arity-includes? w2 3) w2]
[(procedure-arity-includes? w2 3) w2] [else (lambda (in r _) (w2 in r))])]
[else (lambda (in r _) (w2 in r))])] [base '#,lib]
[base 'lib] [whole? #,~whole-body-readers?])
[whole? #,(get '#:whole-body-readers? #'#f)]) (values
(values (lambda (in modpath line col pos)
(lambda (in modpath line col pos) (w2 in
(w2 in (lambda (in)
(lambda (in) (wrap-internal base in rd whole?
(wrap-internal base in rd whole? w1 #f modpath #f line col pos))
w1 #f modpath #f line col pos)) #f))
#f)) (lambda (src in modpath line col pos)
(lambda (src in modpath line col pos) (w2 in
(w2 in (lambda (in)
(lambda (in) (wrap-internal base in (lambda (in) (rds src in)) whole?
(wrap-internal w1 #t modpath src line col pos))
base in (lambda (in) (rds src in)) whole? #t))))))))
w1 #t modpath src line col pos)) (syntax-case stx ()
#t))))))))])) [(_ lib body ...) (construct-reader #'lib (syntax->list #'(body ...)))]))
(define (wrap-internal lib port read whole? wrapper stx? (define (wrap-internal lib port read whole? wrapper stx?
modpath src line col pos) modpath src line col pos)