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

* Extended syntax/module-reader to deal with many more situations

Browse Source 
using keywords, and allowing arbitrary code in the reader module
* Added tests for the new functionality
* Used the new stuff for the r5rs, r6rs, and honu readers

svn: r11495
This commit is contained in:
Eli Barzilay 2008-08-31 06:25:41 +00:00
parent 711401bd55
commit 7d6bc32ed9
7 changed files with 174 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/honu/lang/reader.ss
View File

@ -1,16 +1,6 @@
#lang s-exp syntax/module-reader
(module reader scheme/base
(require (only-in syntax/module-reader wrap-read-all))
(provide (rename-out [*read read]
[*read-syntax read-syntax]))
(define (*read in modpath line col pos)
(wrap in read-honu modpath #f line col pos))
(define (*read-syntax src in modpath line col pos)
(wrap in (lambda (in)
(read-honu-syntax src in))
modpath src line col pos))
honu
(define (wrap port read modpath src line col pos)
(wrap-read-all 'honu port read modpath src line col pos)))
#:read read-honu
#:read-syntax read-honu-syntax

27
collects/r5rs/init.ss
View File

@ -1,19 +1,16 @@
#lang scheme/base
(module init scheme/base
(read-case-sensitive #f)
(read-accept-infix-dot #f)
(read-curly-brace-as-paren #f)
(read-square-bracket-as-paren #f)
(read-case-sensitive #f)
(read-accept-infix-dot #f)
(read-curly-brace-as-paren #f)
(read-square-bracket-as-paren #f)
(print-mpair-curly-braces #f)
;; Printing pairs with curly braces is a bad idea, because
;; syntax errors then use curly braces!
(print-mpair-curly-braces #f)
;; Printing pairs with curly braces is a bad idea, because
;; syntax errors then use curly braces!
(define-syntax out
(syntax-rules ()
[(_) (begin
(require "main.ss")
(provide (all-from-out "main.ss")))]))
(let-syntax ([out (syntax-rules ()
[(_) (begin
(require "main.ss")
(provide (all-from-out "main.ss")))])])
(out))

26
collects/r5rs/lang/reader.ss
View File

@ -1,20 +1,10 @@
#lang s-exp syntax/module-reader
(module reader scheme/base
(require (only-in syntax/module-reader wrap-read-all))
(provide (rename-out [*read read]
[*read-syntax read-syntax]))
(define (*read in modpath line col pos)
(wrap in read modpath #f line col pos))
(define (*read-syntax src in modpath line col pos)
(wrap in (lambda (in)
(read-syntax src in))
modpath src line col pos))
r5rs
(define (wrap port read modpath src line col pos)
(parameterize ([read-case-sensitive #f]
[read-accept-infix-dot #f]
[read-curly-brace-as-paren #f]
[read-square-bracket-as-paren #f])
(wrap-read-all 'r5rs port read modpath src line col pos))))
#:wrapper1 (lambda (t)
(parameterize ([read-case-sensitive #f]
[read-accept-infix-dot #f]
[read-curly-brace-as-paren #f]
[read-square-bracket-as-paren #f])
(t)))

20
collects/r6rs/lang/reader.ss
View File

@ -1,19 +1,7 @@
#lang scheme/base
#lang s-exp syntax/module-reader
(require (only-in syntax/module-reader wrap-read-all)
"../private/readtable.ss")
(provide (rename-out [*read read]
[*read-syntax read-syntax]))
r6rs
(define (*read in)
(wrap in read #f #f #f #f #f))
#:wrapper1 with-r6rs-reader-parameters
(define (*read-syntax src in modpath line col pos)
(wrap in (lambda (in)
(read-syntax src in))
modpath src line col pos))
(define (wrap in read modpath src line col pos)
(with-r6rs-reader-parameters
(lambda ()
(wrap-read-all 'r6rs in read modpath src line col pos))))
(require "../private/readtable.ss")

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

@ -1,28 +1,77 @@
(module module-reader scheme/base
(provide (rename-out [provide-module-reader #%module-begin]
[wrap wrap-read-all]))
[wrap wrap-read-all])
(except-out (all-from-out scheme/base) #%module-begin))
(define-syntax provide-module-reader
(syntax-rules ()
[(_ lib)
(#%module-begin
(#%provide (rename *read read)
(rename *read-syntax read-syntax))
(require (for-syntax scheme/base))
(define (*read in modpath line col pos)
(wrap 'lib in read modpath #f line col pos))
(define-syntax (provide-module-reader stx)
(syntax-case stx ()
[(_ lib body ...)
(let ([-read #f]
[-read-syntax #f]
[-wrapper1 #f]
[-wrapper2 #f])
(define -body
(let loop ([body #'(body ...)])
(define (err str)
(raise-syntax-error 'syntax/module-reader str
(car (syntax->list body))))
(syntax-case body ()
[(#:read r body ...)
(if -read
(err "got two #:read keywords")
(begin (set! -read #'r) (loop #'(body ...))))]
[(#:read-syntax r body ...)
(if -read-syntax
(err "got two #:read-syntax keywords")
(begin (set! -read-syntax #'r) (loop #'(body ...))))]
[(#:wrapper1 w body ...)
(if -wrapper1
(err "got two #:wrapper1 keywords")
(begin (set! -wrapper1 #'w) (loop #'(body ...))))]
[(#:wrapper2 w body ...)
(if -wrapper2
(err "got two #:wrapper2 keywords")
(begin (set! -wrapper2 #'w) (loop #'(body ...))))]
[(k . b) (keyword? (syntax-e #'k))
(err "got an unknown keyword")]
[_ body])))
(with-syntax ([-read (or -read #'read)]
[-read-syntax (or -read-syntax #'read-syntax)]
[-wrapper1 (or -wrapper1 #'#f)]
[-wrapper2 (or -wrapper2 #'#f)]
[(body ...) -body])
(syntax/loc stx
(#%module-begin
body ...
(#%provide (rename *read read) (rename *read-syntax read-syntax))
(define-values (*read *read-syntax)
(let* ([rd -read]
[rds -read-syntax]
[w1 -wrapper1]
[w1-extra? (and w1 (procedure-arity-includes? w1 2))]
[w1r (if w1-extra? (lambda (t) (w1 t #f)) w1)]
[w1s (if w1-extra? (lambda (t) (w1 t #t)) w1)]
[w2 (or -wrapper2 (lambda (in r) (r in)))])
(values
(lambda (in modpath line col pos)
(w2 in (lambda (in)
(wrap-internal 'lib in rd w1r modpath #f
line col pos))))
(lambda (src in modpath line col pos)
(w2 in (lambda (in)
(wrap-internal 'lib in (lambda (in) (rds src in))
w1s modpath src
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)))))]
(define (wrap-internal lib port read wrapper modpath src line col pos)
(let* ([body (lambda ()
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v) (reverse a) (loop (cons v a))))))]
[body (if wrapper (wrapper body) (body))]
[p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
@ -41,7 +90,9 @@
(if (syntax? modpath)
(datum->syntax #f lib modpath modpath)
v))])
`(,(tag-src 'module) ,(tag-src name) ,(lib-src lib)
. ,body)))
`(,(tag-src 'module) ,(tag-src name) ,(lib-src lib) . ,body)))
(define (wrap lib port read modpath src line col pos)
(wrap-internal lib port read #f modpath src line col pos))
)

73
collects/tests/mzscheme/module-reader.ss Normal file
View File

@ -0,0 +1,73 @@
(load-relative "loadtest.ss")
(Section 'module-reader)
;; ----------------------------------------
;; plain version
(module r0 syntax/module-reader scheme/base)
;; using a simple wrapper to get a case-insensitive reader
(module r1 syntax/module-reader scheme/base
#:wrapper1 (lambda (t) (parameterize ([read-case-sensitive #f]) (t))))
;; using the more general wrapper to get a case-insensitive reader
(module r2 syntax/module-reader scheme/base
#:wrapper2 (lambda (in r) (parameterize ([read-case-sensitive #f]) (r in))))
;; using explicit case-insensitive read/-syntax versions
(module r3 syntax/module-reader scheme/base
#:read (wrap read) #:read-syntax (wrap read-syntax)
(define ((wrap reader) . args)
(parameterize ([read-case-sensitive #f]) (apply reader args))))
;; add something to the result
(module r4 syntax/module-reader zzz
#:wrapper1 (lambda (t) (cons 'foo (t))))
;; same as above, but do it properly, if a syntax or a datum is needed
(module r5 syntax/module-reader zzz
#:wrapper1 (lambda (t stx?) (cons (if stx? #'foo 'foo) (t))))
;; make an empty module, after reading the contents
(module r6 syntax/module-reader zzz
#:wrapper1 (lambda (t) '()))
;; fake input port to get an empty module
(module r7 syntax/module-reader zzz
#:wrapper2 (lambda (in rd) (rd (open-input-string ""))))
;; forget about the input -- just return a fixed empty input module
(module r8 syntax/module-reader whatever
#:wrapper2 (lambda (in rd)
(if (syntax? (rd in)) #'(module page zzz) '(module page zzz))))
(define (from-string read str)
(parameterize ([read-accept-reader #t])
(read (open-input-string str))))
(define (test-both str result)
(for ([read (list read
;; same as `read', but using read-syntax
(lambda (in) (syntax->datum (read-syntax #f in))))])
(test result from-string read str)))
(test-both "#reader 'r0 (define FoO #:bAr)"
'(module page scheme/base (define FoO #:bAr)))
(for ([mod '(r1 r2 r3)])
(test-both (format "#reader '~a (define FoO #:bAr)" mod)
'(module page scheme/base (define foo #:bar))))
(test-both "#reader 'r4 (define foo #:bar)"
'(module page zzz foo (define foo #:bar)))
(test-both "#reader 'r5 (define foo #:bar)"
'(module page zzz foo (define foo #:bar)))
(test-both "#reader 'r6 (define foo #:bar)"
'(module page zzz))
;; ----------------------------------------
(report-errs)

1
collects/tests/mzscheme/syntax-tests.ss
View File

@ -3,5 +3,6 @@
(load-in-sandbox "moddep.ss")
(load-in-sandbox "boundmap-test.ss")
(load-in-sandbox "cm.ss")
(load-in-sandbox "module-reader.ss.ss")
(report-errs)