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

.

Browse Source 
original commit: 5200f352d6becfac3b25078ca70f20e1f5fb55c0
This commit is contained in:
Matthew Flatt 2001-12-21 21:57:50 +00:00
parent 5b897abd58
commit 3ada00788f
1 changed files with 162 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

283
collects/mzlib/include.ss
View File

@ -1,136 +1,177 @@
(module include mzscheme (module include mzscheme
(require-for-syntax (lib "stx.ss" "syntax")) (require-for-syntax (lib "stx.ss" "syntax"))
(require (lib "etc.ss"))
(define-syntax include-at/relative-to (define-syntax-set (do-include ; private
(lambda (stx) include-at/relative-to
;; Parse the file name include
(let-values ([(ctx loc file) include-at/relative-to/reader
(syntax-case* stx (build-path) module-or-top-identifier=? include/reader)
[(_ ctx loc fn)
(string? (syntax-e (syntax fn))) (define (do-include/proc stx)
(values (syntax ctx) (syntax loc) (syntax-e (syntax fn)))] (syntax-case stx ()
[(_ ctx loc (build-path elem1 elem ...)) [(_ orig-stx ctx loc fn reader)
(andmap ;; Parse the file name
(lambda (e) (let ([file
(or (string? (syntax-e e)) (syntax-case* (syntax fn) (build-path) module-or-top-identifier=?
(and (identifier? e) [fn
(or (string? (syntax-e (syntax fn)))
(module-identifier=? e (quote-syntax up)) (syntax-e (syntax fn))]
(module-identifier=? e (quote-syntax same)))))) [(build-path elem1 elem ...)
(syntax->list (syntax (elem1 elem ...)))) (apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])]
(values [ctx (syntax ctx)]
(syntax ctx) [loc (syntax loc)]
(syntax loc) [reader (syntax reader)]
(apply build-path (syntax-object->datum (syntax (elem1 elem ...)))))])]) [orig-stx (syntax orig-stx)])
;; Complete the file name
(let ([c-file (let ([read-syntax (if (syntax-e reader)
(if (complete-path? file) (syntax-local-value reader)
file read-syntax)])
(path->complete-path (unless (and (procedure? read-syntax)
file (procedure-arity-includes? read-syntax 2))
(cond (raise-syntax-error
;; Src of include expression is a path? #f
[(and (string? (syntax-source loc)) "reader is not a procedure of two arguments"
(complete-path? (syntax-source loc))) orig-stx))
(let-values ([(base name dir?)
(split-path (syntax-source loc))]) ;; Complete the file name
(if dir? (let ([c-file
(syntax-source loc) (if (complete-path? file)
base))] file
;; Load relative? (path->complete-path
[(current-load-relative-directory)] file
;; Current directory (cond
[(current-directory)] ;; Src of include expression is a path?
[else (raise-syntax-error [(and (string? (syntax-source loc))
#f (complete-path? (syntax-source loc)))
"can't determine a base path" (let-values ([(base name dir?)
stx)])))]) (split-path (syntax-source loc))])
;; Open the included file (if dir?
(let ([p (with-handlers ([not-break-exn? (syntax-source loc)
(lambda (exn) base))]
(raise-syntax-error ;; Load relative?
#f [(current-load-relative-directory)]
(format ;; Current directory
"can't open include file (~a)" [(current-directory)]
(if (exn? exn) [else (raise-syntax-error
(exn-message exn) #f
exn)) "can't determine a base path"
stx orig-stx)])))])
c-file))]) ;; Open the included file
(open-input-file c-file))]) (let ([p (with-handlers ([not-break-exn?
(port-count-lines! p) (lambda (exn)
;; Read expressions from file (raise-syntax-error
(let ([content #f
(let loop () (format
(let ([r (with-handlers ([not-break-exn? "can't open include file (~a)"
(lambda (exn) (if (exn? exn)
(raise-syntax-error (exn-message exn)
#f exn))
(format orig-stx
"read error (~a)" c-file))])
(if (exn? exn) (open-input-file c-file))])
(exn-message exn) (port-count-lines! p)
exn)) ;; Read expressions from file
stx))]) (let ([content
(read-syntax c-file p))]) (let loop ()
(if (eof-object? r) (let ([r (with-handlers ([not-break-exn?
null (lambda (exn)
(cons r (loop)))))]) (raise-syntax-error
;; Preserve src info for content, but set its #f
;; lexical context to be that of the include expression (format
(let ([lexed-content "read error (~a)"
(let loop ([content content]) (if (exn? exn)
(cond (exn-message exn)
[(pair? content) exn))
(cons (loop (car content)) orig-stx))])
(loop (cdr content)))] (read-syntax c-file p))])
[(null? content) null] (if (eof-object? r)
[else null
(let ([v (syntax-e content)]) (cons r (loop)))))])
(datum->syntax-object ;; Preserve src info for content, but set its
ctx ;; lexical context to be that of the include expression
(let ([lexed-content
(let loop ([content content])
(cond (cond
[(pair? v) [(pair? content)
(loop v)] (cons (loop (car content))
[(vector? v) (loop (cdr content)))]
(list->vector (loop (vector->list v)))] [(null? content) null]
[(box? v)
(box (loop (unbox v)))]
[else [else
v]) (let ([v (syntax-e content)])
content))]))]) (datum->syntax-object
(datum->syntax-object ctx
(quote-syntax here) (cond
`(begin ,@lexed-content) [(pair? v)
stx)))))))) (loop v)]
[(vector? v)
(list->vector (loop (vector->list v)))]
[(box? v)
(box (loop (unbox v)))]
[else
v])
content))]))])
(datum->syntax-object
(quote-syntax here)
`(begin ,@lexed-content)
orig-stx)))))))]))
(define-syntax include (define (check-fn-form fn stx)
(lambda (stx) ;; Check form of fn:
(syntax-case* fn (build-path) module-or-top-identifier=?
[fn
(string? (syntax-e (syntax fn)))
'ok]
[(build-path elem1 elem ...)
(andmap
(lambda (e)
(or (string? (syntax-e e))
(and (identifier? e)
(or
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...))))
'ok]
[_else (raise-syntax-error #f "bad syntax" stx fn)]))
(define (include/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ fn) [(_ fn)
;; Check form of fn: (check-fn-form (syntax fn) stx)
(syntax-case* (syntax fn) (build-path) module-or-top-identifier=?
[fn
(string? (syntax-e (syntax fn)))
'ok]
[(build-path elem1 elem ...)
(andmap
(lambda (e)
(or (string? (syntax-e e))
(and (identifier? e)
(or
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...))))
'ok]
[_else (raise-syntax-error #f "bad syntax" stx (syntax fn))])
;; Expand to include-at/relative-to:
(with-syntax ([_stx stx]) (with-syntax ([_stx stx])
(syntax/loc stx (include-at/relative-to _stx _stx fn)))]))) (syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
(define (include-at/relative-to/proc stx)
(syntax-case stx ()
[(_ ctx loc fn)
(check-fn-form (syntax fn) stx)
(with-syntax ([_stx stx])
(syntax/loc stx (do-include _stx ctx loc fn #f)))]))
(define (include/reader/proc stx)
(syntax-case stx ()
[(_ fn reader)
(check-fn-form (syntax fn) stx)
;; Expand to do-include:
(with-syntax ([_stx stx])
(syntax/loc stx
(let-syntax ([the-reader reader])
(do-include _stx _stx _stx fn the-reader))))]))
(define (include-at/relative-to/reader/proc stx)
(syntax-case stx ()
[(_ ctx loc fn reader)
(check-fn-form (syntax fn) stx)
(with-syntax ([_stx stx])
(syntax/loc stx
(let-syntax ([the-reader reader])
(do-include _stx _stx _stx fn the-reader))))])))
(provide include (provide include
include-at/relative-to)) include-at/relative-to
include/reader
include-at/relative-to/reader))