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

Adjusted the module-reader to handler editor objects as object-names of ports.

Browse Source 
svn: r10470
This commit is contained in:
Danny Yoo 2008-06-27 03:26:44 +00:00
parent ca7188be1e
commit e16ba1b779
1 changed files with 37 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,23 +1,25 @@
(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)
(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)])
@ -25,18 +27,28 @@
(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)]
[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))
(add1 pos))
pos)))
v))]
[lib-src (lambda (v)