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

module paths normalize to .rkt, load handler converts .rkt back to .ss if necessary

Browse Source 
svn: r18788

original commit: bdb71498e3ed816d44c9faf830f97fbe9fdaa3f2
This commit is contained in:
Matthew Flatt 2010-04-11 16:55:18 +00:00
parent 29e1296e08
commit 23736d15be
1 changed files with 90 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

169
collects/mzlib/include.ss
View File

@ -76,91 +76,102 @@
(syntax-case stx () (syntax-case stx ()
[(_ orig-stx ctx loc fn reader) [(_ orig-stx ctx loc fn reader)
;; Parse the file name ;; Parse the file name
(let ([c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)] (let ([orig-c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)]
[ctx (syntax ctx)] [ctx (syntax ctx)]
[loc (syntax loc)] [loc (syntax loc)]
[reader (syntax reader)] [reader (syntax reader)]
[orig-stx (syntax orig-stx)]) [orig-stx (syntax orig-stx)]
[rkt->ss (lambda (p)
(let ([b (path->bytes p)])
(if (regexp-match? #rx#"[.]rkt$" b)
(path-replace-suffix p #".ss")
p)))])
(register-external-file c-file) (let ([c-file (if (file-exists? orig-c-file)
orig-c-file
(let ([p2 (rkt->ss orig-c-file)])
(if (file-exists? p2)
p2
orig-c-file)))])
(register-external-file c-file)
(let ([read-syntax (if (syntax-e reader) (let ([read-syntax (if (syntax-e reader)
(reader-val (reader-val
(let loop ([e (syntax-object->datum (let loop ([e (syntax-object->datum
(local-expand reader 'expression null))]) (local-expand reader 'expression null))])
(cond (cond
[(reader? e) e] [(reader? e) e]
[(pair? e) (or (loop (car e)) [(pair? e) (or (loop (car e))
(loop (cdr e)))] (loop (cdr e)))]
[else #f]))) [else #f])))
read-syntax)]) read-syntax)])
(unless (and (procedure? read-syntax) (unless (and (procedure? read-syntax)
(procedure-arity-includes? read-syntax 2)) (procedure-arity-includes? read-syntax 2))
(raise-syntax-error (raise-syntax-error
#f #f
"reader is not a procedure of two arguments" "reader is not a procedure of two arguments"
orig-stx)) orig-stx))
;; Open the included file ;; Open the included file
(let ([p (with-handlers ([exn:fail? (let ([p (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(raise-syntax-error (raise-syntax-error
#f #f
(format (format
"can't open include file (~a)" "can't open include file (~a)"
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
exn)) exn))
orig-stx orig-stx
c-file))]) c-file))])
(open-input-file c-file))]) (open-input-file c-file))])
(port-count-lines! p) (port-count-lines! p)
;; Read expressions from file ;; Read expressions from file
(let ([content (let ([content
(let loop () (let loop ()
(let ([r (with-handlers ([exn:fail? (let ([r (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(close-input-port p) (close-input-port p)
(raise-syntax-error (raise-syntax-error
#f #f
(format (format
"read error (~a)" "read error (~a)"
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
exn)) exn))
orig-stx))]) orig-stx))])
(read-syntax c-file p))]) (read-syntax c-file p))])
(if (eof-object? r) (if (eof-object? r)
null null
(cons r (loop)))))]) (cons r (loop)))))])
(close-input-port p) (close-input-port p)
;; Preserve src info for content, but set its ;; Preserve src info for content, but set its
;; lexical context to be that of the include expression ;; lexical context to be that of the include expression
(let ([lexed-content (let ([lexed-content
(let loop ([content content]) (let loop ([content content])
(cond (cond
[(pair? content) [(pair? content)
(cons (loop (car content)) (cons (loop (car content))
(loop (cdr content)))] (loop (cdr content)))]
[(null? content) null] [(null? content) null]
[else [else
(let ([v (syntax-e content)]) (let ([v (syntax-e content)])
(datum->syntax-object (datum->syntax-object
ctx ctx
(cond (cond
[(pair? v) [(pair? v)
(loop v)] (loop v)]
[(vector? v) [(vector? v)
(list->vector (loop (vector->list v)))] (list->vector (loop (vector->list v)))]
[(box? v) [(box? v)
(box (loop (unbox v)))] (box (loop (unbox v)))]
[else [else
v]) v])
content))]))]) content))]))])
(datum->syntax-object (datum->syntax-object
(quote-syntax here) (quote-syntax here)
`(begin ,@lexed-content) `(begin ,@lexed-content)
orig-stx))))))])) orig-stx)))))))]))
(define (include/proc stx) (define (include/proc stx)
(syntax-case stx () (syntax-case stx ()