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

refix indentation, disable scheme/class loading

Browse Source 
svn: r10471
This commit is contained in:
Eli Barzilay 2008-06-27 04:10:39 +00:00
parent e16ba1b779
commit f283f97493
1 changed files with 53 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,64 +1,56 @@
(module module-reader scheme/base
(require scheme/class)
(provide (rename-out [provide-module-reader #%module-begin]
[wrap wrap-read-all]))
(define-syntax provide-module-reader
(syntax-rules ()
[(_ lib)
(#%module-begin
(#%provide (rename *read read)
(rename *read-syntax read-syntax))
(define (*read in modpath line col pos)
(wrap 'lib in read modpath #f line col pos))
(define (*read-syntax src in modpath line col pos)
(wrap 'lib in (lambda (in) (read-syntax src in))
modpath src line col pos)))]))
(define (wrap lib port read modpath src line col pos)
(let ([body
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v)
(reverse a)
(loop (cons v a)))))])
(let* ([p-name (object-name port)]
[p-name
(cond [(and (object? p-name)
(method-in-interface? 'get-port-name (object-interface p-name)))
(send p-name get-port-name)]
[(and (object? p-name)
(method-in-interface? 'get-filename (object-interface p-name)))
(send p-name get-filename)]
[else p-name])]
[name (cond
[(path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))]
[else
'page])]
[tag-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f
v
(vector src line col pos
(- (or (syntax-position modpath)
(add1 pos))
pos)))
v))]
[lib-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f
lib
modpath
modpath)
v))])
`(,(tag-src 'module) ,(tag-src name) ,(lib-src lib)
. ,body))))
;; (require scheme/class) ; avoid requiring too much to the reader level
(provide (rename-out [provide-module-reader #%module-begin]
[wrap wrap-read-all]))
(define-syntax provide-module-reader
(syntax-rules ()
[(_ lib)
(#%module-begin
(#%provide (rename *read read)
(rename *read-syntax read-syntax))
(define (*read in modpath line col pos)
(wrap 'lib in read modpath #f line col pos))
(define (*read-syntax src in modpath line col pos)
(wrap 'lib in (lambda (in) (read-syntax src in))
modpath src line col pos)))]))
(define (wrap lib port read modpath src line col pos)
(let* ([body (let loop ([a null])
(let ([v (read port)])
(if (eof-object? v)
(reverse a)
(loop (cons v a)))))]
[p-name (object-name port)]
#;
[p-name (let ([i (and (object? p-name) (object-interface p-name))])
(cond [(and i (method-in-interface? 'get-port-name i))
(send p-name get-port-name)]
[(and i (method-in-interface? 'get-filename i))
(send p-name get-filename)]
[else p-name]))]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))
'page)]
[tag-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f v
(vector src line col pos
(- (or (syntax-position modpath)
(add1 pos))
pos)))
v))]
[lib-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f lib modpath modpath)
v))])
`(,(tag-src 'module) ,(tag-src name) ,(lib-src lib)
. ,body)))
)