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

mostly reformatting

Browse Source 
svn: r17196
This commit is contained in:
Eli Barzilay 2009-12-05 03:49:24 +00:00
parent e76b516e1d
commit af998f0d56
5 changed files with 150 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/at-exp/lang/reader.ss
View File

@ -14,18 +14,19 @@
(apply p args))))
(define-values (at-read at-read-syntax at-get-info)
(make-meta-reader 'at-exp
"language path"
(lambda (str)
(let ([s (string->symbol
(string-append (bytes->string/latin-1 str)
"/lang/reader"))])
(and (module-path? s) s)))
wrap-reader
wrap-reader
(lambda (proc)
(lambda (key defval)
(case key
[(color-lexer)
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
[else (if proc (proc key defval) defval)]))))))
(make-meta-reader
'at-exp
"language path"
(lambda (str)
(let ([s (string->symbol
(string-append (bytes->string/latin-1 str)
"/lang/reader"))])
(and (module-path? s) s)))
wrap-reader
wrap-reader
(lambda (proc)
(lambda (key defval)
(case key
[(color-lexer)
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
[else (if proc (proc key defval) defval)]))))))

21
collects/planet/lang/reader.ss
View File

@ -6,13 +6,14 @@
[planet-get-info get-info]))
(define-values (planet-read planet-read-syntax planet-get-info)
(make-meta-reader 'planet
"planet path"
(lambda (str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
values
values
values)))
(make-meta-reader
'planet
"planet path"
(lambda (str)
(let ([str (bytes->string/latin-1 str)])
(if (module-path? `(planet ,(string->symbol str)))
`(planet ,(string->symbol (string-append str "/lang/reader")))
#f)))
values
values
values)))

16
collects/reader/lang/reader.ss
View File

@ -6,11 +6,11 @@
[-get-info get-info]))
(define-values (-read -read-syntax -get-info)
(make-meta-reader 'reader
"language path"
#:read-spec (lambda (in) (read in))
(lambda (s)
(and (module-path? s) s))
values
values
values)))
(make-meta-reader
'reader
"language path"
#:read-spec (lambda (in) (read in))
(lambda (s) (and (module-path? s) s))
values
values
values)))

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

@ -21,41 +21,42 @@
(if (not (and (pair? body)
(pair? (cdr body))
(keyword? (syntax-e (car body)))))
(datum->syntax stx body stx)
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
(case k*
[(kwd) (if var
(err (format "got two ~s keywords" k*) k)
(begin (set! var v) (loop (cddr body))))]
...
[else (err "got an unknown keyword" (car body))])))))
(datum->syntax stx body stx)
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
(case k*
[(kwd) (if var
(err (format "got two ~s keywords" k*) k)
(begin (set! var v) (loop (cddr body))))]
...
[else (err "got an unknown keyword" (car body))])))))
checks ...
(unless var (set! var default)) ...))
(define <lang-id> (datum->syntax stx 'language-module stx))
(define <data-id> (datum->syntax stx 'language-data stx))
(define (construct-reader lang body)
(keywords body
[#:language ~lang lang]
[#:read ~read #'read]
[#:read-syntax ~read-syntax #'read-syntax]
[#:wrapper1 ~wrapper1 #'#f]
[#:wrapper2 ~wrapper2 #'#f]
[#:whole-body-readers? ~whole-body-readers? #'#f]
[#:info ~info #'#f]
[(when (equal? (and lang #t) (and ~lang #t))
(err (string-append
"must specify either a module language, or #:language"
(if (and lang ~lang) ", not both" ""))))
(unless (equal? (and ~read #t) (and ~read-syntax #t))
(err "must specify either both #:read and #:read-syntax, or none"))
(when (and ~whole-body-readers? (not (and ~read ~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
[#:language ~lang lang]
[#:read ~read #'read]
[#:read-syntax ~read-syntax #'read-syntax]
[#:wrapper1 ~wrapper1 #'#f]
[#:wrapper2 ~wrapper2 #'#f]
[#:whole-body-readers? ~whole-body-readers? #'#f]
[#:info ~info #'#f]
[(when (equal? (and lang #t) (and ~lang #t))
(err (string-append
"must specify either a module language, or #:language"
(if (and lang ~lang) ", not both" ""))))
(unless (equal? (and ~read #t) (and ~read-syntax #t))
(err "must specify either both #:read and #:read-syntax, or none"))
(when (and ~whole-body-readers? (not (and ~read ~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
;; out of the template:
(quasisyntax/loc stx
(#%module-begin
#,@body
(#%provide (rename lang:read read) (rename lang:read-syntax read-syntax)
(#%provide (rename lang:read read)
(rename lang:read-syntax read-syntax)
read-properties get-info-getter get-info)
(define (lang:read in modpath line col pos)
(wrap-internal/wrapper #f #f in modpath line col pos))
@ -66,41 +67,43 @@
[lang (car props)] [#,<lang-id> lang] ;\ visible in
[data (cadr props)] [#,<data-id> data] ;/ user-code
[read (if stx?
(let ([rd #,~read-syntax]) (lambda (in) (rd src in)))
#,~read)]
(let ([rd #,~read-syntax])
(lambda (in) (rd src in)))
#,~read)]
[w1 #,~wrapper1]
[w2 #,~wrapper2]
[whole? #,~whole-body-readers?]
[rd (lambda (in) (wrap-internal (if (and (not stx?) (syntax? lang))
(syntax->datum lang)
lang)
in read whole? w1 stx?
modpath src line col pos))]
[rd (lambda (in)
(wrap-internal (if (and (not stx?) (syntax? lang))
(syntax->datum lang)
lang)
in read whole? w1 stx?
modpath src line col pos))]
[r (cond [(not w2) (rd in)]
[(ar? w2 3) (w2 in rd stx?)]
[else (w2 in rd)])])
(if stx?
(syntax-property r 'module-language
(vector (syntax->datum modpath) 'get-info-getter
props))
r)))
(syntax-property r
'module-language
(vector (syntax->datum modpath) 'get-info-getter props))
r)))
(define 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)]))))
(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)))
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)]
@ -124,14 +127,14 @@
[#,<data-id> data] ;/ user-code
[info #,~info])
(if (or (not info) (and (procedure? info) (ar? info 3)))
info
(raise-type-error 'syntax/module-reader
"info procedure of 3 arguments" info))))
info
(raise-type-error 'syntax/module-reader
"info procedure of 3 arguments" info))))
(define (language-info what defval)
(if info
(let ([r (info what defval default-info)])
(if (eq? r default-info) (default-info what defval) r))
(default-info what defval)))
(let ([r (info what defval default-info)])
(if (eq? r default-info) (default-info what defval) r))
(default-info what defval)))
language-info))))
(syntax-case stx ()
[(_ lang body ...)
@ -146,11 +149,9 @@
;; expression that begins with the literal #%module-begin. If so,
;; it just returns that expression, else it wraps with #%module-begin.
(define (wrap-#%module-begin exps stx?)
(define wrapped-exps
(define wrapped-exps
(let ([wrapped `(#%module-begin . ,exps)])
(if stx?
(datum->syntax #f wrapped)
wrapped)))
(if stx? (datum->syntax #f wrapped) wrapped)))
(let ([exps (if stx? (syntax->list exps) exps)])
(cond
[(null? exps) wrapped-exps]
@ -165,10 +166,12 @@
(let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
[body (lambda ()
(if whole?
(read port)
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v) (reverse a) (loop (cons v a)))))))]
(read port)
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v)
(reverse a)
(loop (cons v a)))))))]
[body (cond [(not wrapper) (body)]
[(ar? wrapper 2) (wrapper body stx?)]
[else (wrapper body)])]
@ -176,25 +179,27 @@
(let-values ([(l c p) (port-next-location port)])
(and p (- p pos))))]
[body (if (and stx? (not (syntax? body)))
(datum->syntax #f body all-loc)
body)]
(datum->syntax #f body all-loc)
body)]
[p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))
'page)]
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))
'page)]
[tag-src (lambda (v)
(if stx?
(datum->syntax
#f v (vector src line col pos
(- (or (syntax-position modpath) (add1 pos))
pos)))
v))]
;; Since there are users that wrap with #%module-begin in their reader
;; or wrapper1 functions, we need to avoid double-wrapping. Having to
;; do this for #lang readers should be considered deprecated, and
;; hopefully one day we'll move to just doing it unilaterally.
(datum->syntax
#f v (vector src line col pos
(- (or (syntax-position modpath)
(add1 pos))
pos)))
v))]
;; Since there are users that wrap with #%module-begin in their
;; reader or wrapper1 functions, we need to avoid double-wrapping.
;; Having to do this for #lang readers should be considered
;; deprecated, and hopefully one day we'll move to just doing it
;; unilaterally.
[wrapped-body (wrap-#%module-begin body stx?)]
[r `(,(tag-src 'module) ,(tag-src name) ,lang ,wrapped-body)])
(if stx? (datum->syntax #f r all-loc) r)))
@ -202,18 +207,17 @@
(define (wrap lang port read modpath src line col pos)
(wrap-internal lang port read #f #f #f modpath src line col pos))
(define (make-meta-reader self-sym module-path-desc spec->module-path
convert-read
convert-read-syntax
convert-get-info
#:read-spec [read-spec
(lambda (in)
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
(and spec
(let ([s (cadr spec)])
(if (equal? s "")
#f
s)))))])
(define (make-meta-reader
self-sym module-path-desc spec->module-path
convert-read
convert-read-syntax
convert-get-info
#:read-spec
[read-spec
(lambda (in)
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)])
(and spec (let ([s (cadr spec)])
(if (equal? s "") #f s)))))])
(define (get in export-sym src line col pos mk-fail-thunk)
(define (bad str eof?)
((if eof? raise-read-eof-error raise-read-error)
@ -224,17 +228,20 @@
(and pos pos2 (- pos2 pos)))))
(define spec (read-spec in))
(if (not spec)
(bad #f (eof-object? (peek-byte in)))
(let ([parsed-spec (spec->module-path spec)])
(if parsed-spec
(begin ((current-reader-guard) parsed-spec)
(dynamic-require parsed-spec export-sym (mk-fail-thunk spec)))
(bad spec #f)))))
(bad #f (eof-object? (peek-byte in)))
(let ([parsed-spec (spec->module-path spec)])
(if parsed-spec
(begin ((current-reader-guard) parsed-spec)
(dynamic-require parsed-spec export-sym
(mk-fail-thunk spec)))
(bad spec #f)))))
(define (-get-info inp mod line col pos)
(let ([r (get inp 'get-info (object-name inp) line col pos
(lambda (spec) (lambda () (lambda (inp mod line col pos)
(lambda (tag defval) defval)))))])
(lambda (spec)
(lambda ()
(lambda (inp mod line col pos)
(lambda (tag defval) defval)))))])
(convert-get-info (r inp mod line col pos))))
(define (read-fn in read-sym args src mod line col pos convert)
@ -245,14 +252,17 @@
self-sym
spec))))])
(let ([r (convert r)])
(if (and (procedure? r) (procedure-arity-includes? r (+ 5 (length args))))
(apply r (append args (list in mod line col pos)))
(apply r (append args (list in)))))))
(if (and (procedure? r)
(procedure-arity-includes? r (+ 5 (length args))))
(apply r (append args (list in mod line col pos)))
(apply r (append args (list in)))))))
(define (-read inp mod line col pos)
(read-fn inp 'read null (object-name inp) mod line col pos convert-read))
(read-fn inp 'read null (object-name inp) mod line col pos
convert-read))
(define (-read-syntax src inp mod line col pos)
(read-fn inp 'read-syntax (list src) src mod line col pos convert-read-syntax))
(read-fn inp 'read-syntax (list src) src mod line col pos
convert-read-syntax))
(values -read -read-syntax -get-info)))

2
collects/syntax/scribblings/module-reader.scrbl
View File

@ -290,7 +290,7 @@ are meant to be exported directly.}
@emph{This function is deprecated; the
@schememodname[syntax/module-reader] language can be adapted using the
various keywords to arbitrary readers, and please use it instead.}
various keywords to arbitrary readers; please use it instead.}
Repeatedly calls @scheme[read] on @scheme[in] until an end of file,
collecting the results in order into @scheme[_lst], and derives a