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

Move some code outside of the main macro, a few other simplifications.

Browse Source 
svn: r17202
This commit is contained in:
Eli Barzilay 2009-12-05 08:35:37 +00:00
parent 3caf087c97
commit 2ea73bb1bd
1 changed files with 32 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -50,8 +50,8 @@
(err "must specify either both #:read and #:read-syntax, or none")) (err "must specify either both #:read and #:read-syntax, or none"))
(when (and ~whole-body-readers? (not (and ~read ~read-syntax))) (when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
(err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) (err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
;; FIXME: a lot of the generated code is constant and should be lifted ;; FIXME: some generated code is constant and should be lifted out of the
;; out of the template: ;; template:
(quasisyntax/loc stx (quasisyntax/loc stx
(#%module-begin (#%module-begin
#,@body #,@body
@ -87,31 +87,7 @@
'module-language 'module-language
(vector (syntax->datum modpath) 'get-info-getter props)) (vector (syntax->datum modpath) 'get-info-getter props))
r))) r)))
(define lang* (define read-properties (lang->read-properties #,~lang))
(let ([lang #,~lang])
(if (not (procedure? lang))
(list lang #f)
(cond [(ar? lang 5) lang]
[(ar? lang 1) (lambda (in . _) (lang in))]
[(ar? lang 0) (lambda _ (lang))]
[else (raise-type-error
'syntax/module-reader
"language+reader procedure of 5, 1, or 0 arguments"
lang)]))))
(define (read-properties in modpath line col pos)
(if (not (procedure? lang*))
lang*
(call-with-values
(lambda () (parameterize ([current-input-port in])
(lang* in modpath line col pos)))
(lambda xs
(case (length xs)
[(2) xs] [(1) (list (car xs) #f)]
[else (error 'syntax/module-reader
"wrong number of results from ~a, ~a ~e"
"the #:language function"
"expected 1 or 2 values, got"
(length xs))])))))
(define (get-info in modpath line col pos) (define (get-info in modpath line col pos)
(get-info-getter (read-properties in modpath line col pos))) (get-info-getter (read-properties in modpath line col pos)))
(define (get-info-getter props) (define (get-info-getter props)
@ -142,6 +118,35 @@
(construct-reader #''lang (syntax->list #'(body ...)))] (construct-reader #''lang (syntax->list #'(body ...)))]
[(_ body ...) (construct-reader #f (syntax->list #'(body ...)))])) [(_ body ...) (construct-reader #f (syntax->list #'(body ...)))]))
;; turns the language specification (either a language or some flavor of a
;; function that returns a language and some properties) into a function that
;; returns (list <lang> <props>)
(define (lang->read-properties lang)
(define lang*
(cond [(not (procedure? lang)) (list lang #f)]
[(ar? lang 5) lang]
[(ar? lang 1) (lambda (in . _) (lang in))]
[(ar? lang 0) (lambda _ (lang))]
[else (raise-type-error
'syntax/module-reader
"language+reader procedure of 5, 1, or 0 arguments"
lang)]))
(define (read-properties in modpath line col pos)
(if (not (procedure? lang*))
lang*
(parameterize ([current-input-port in])
(call-with-values
(lambda () (lang* in modpath line col pos))
(lambda xs
(case (length xs)
[(2) xs] [(1) (list (car xs) #f)]
[else (error 'syntax/module-reader
"wrong number of results from ~a, ~a ~e"
"the #:language function"
"expected 1 or 2 values, got"
(length xs))]))))))
read-properties)
;; Since there are users that wrap with `#%module-begin' in their reader ;; Since there are users that wrap with `#%module-begin' in their reader
;; or wrapper1 functions, we need to avoid double-wrapping. Having to do ;; or wrapper1 functions, we need to avoid double-wrapping. Having to do
;; this for #lang readers should be considered deprecated, and hopefully ;; this for #lang readers should be considered deprecated, and hopefully