53 lines
1.9 KiB
Scheme
53 lines
1.9 KiB
Scheme
(module module-reader scheme/base
|
|
|
|
(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)]
|
|
[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))))
|
|
|
|
)
|