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

better code organization

Browse Source 
svn: r15152
This commit is contained in:
Eli Barzilay 2009-06-12 14:33:22 +00:00
parent e53fa0ce2b
commit 81d8c97800
1 changed files with 21 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,7 +26,7 @@
... ...
[else (err "got an unknown keyword" (car body))]))))) [else (err "got an unknown keyword" (car body))])))))
checks ... checks ...
(set! var (or var default)) ...)) (unless var (set! var default)) ...))
(define (construct-reader lang body) (define (construct-reader lang body)
(keywords body (keywords body
[#:language ~lang lang] [#:language ~lang lang]
@ -45,30 +45,26 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(#%module-begin (#%module-begin
#,@body #,@body
(#%provide (rename *read read) (rename *read-syntax read-syntax)) (#%provide (rename lang:read read) (rename lang:read-syntax read-syntax))
(define-values (*read *read-syntax) (define lang #,~lang)
(let* ([lang #,~lang] (define rd #,~read)
[rd #,~read] (define rds #,~read-syntax)
[rds #,~read-syntax] (define w1 #,~wrapper1)
[w1 #,~wrapper1] (define w2 #,~wrapper2)
[w2 #,~wrapper2] (define 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))]))
[whole? #,~whole-body-readers?]) (define whole? #,~whole-body-readers?)
(values (define (lang:read in modpath line col pos)
(lambda (in modpath line col pos) (w2* in (lambda (in)
(w2 in
(lambda (in)
(wrap-internal lang in rd whole? (wrap-internal lang 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) (define (lang:read-syntax src in modpath line col pos)
(w2 in (w2* in (lambda (in)
(lambda (in)
(wrap-internal lang in (lambda (in) (rds src in)) whole? (wrap-internal lang in (lambda (in) (rds src in)) whole?
w1 #t modpath src line col pos)) w1 #t modpath src line col pos))
#t)))))))) #t)))))
(syntax-case stx () (syntax-case stx ()
[(_ lang body ...) [(_ lang body ...)
(not (keyword? (syntax-e #'lang))) (not (keyword? (syntax-e #'lang)))