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

105
collects/mzlib/include.ss
View File

@ -1,28 +1,40 @@
(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
include
include-at/relative-to/reader
include/reader)
(define (do-include/proc stx)
(syntax-case stx ()
[(_ orig-stx ctx loc fn reader)
;; Parse the file name ;; Parse the file name
(let-values ([(ctx loc file) (let ([file
(syntax-case* stx (build-path) module-or-top-identifier=? (syntax-case* (syntax fn) (build-path) module-or-top-identifier=?
[(_ ctx loc fn) [fn
(string? (syntax-e (syntax fn))) (string? (syntax-e (syntax fn)))
(values (syntax ctx) (syntax loc) (syntax-e (syntax fn)))] (syntax-e (syntax fn))]
[(_ ctx loc (build-path elem1 elem ...)) [(build-path elem1 elem ...)
(andmap (apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])]
(lambda (e) [ctx (syntax ctx)]
(or (string? (syntax-e e)) [loc (syntax loc)]
(and (identifier? e) [reader (syntax reader)]
(or [orig-stx (syntax orig-stx)])
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same)))))) (let ([read-syntax (if (syntax-e reader)
(syntax->list (syntax (elem1 elem ...)))) (syntax-local-value reader)
(values read-syntax)])
(syntax ctx) (unless (and (procedure? read-syntax)
(syntax loc) (procedure-arity-includes? read-syntax 2))
(apply build-path (syntax-object->datum (syntax (elem1 elem ...)))))])]) (raise-syntax-error
#f
"reader is not a procedure of two arguments"
orig-stx))
;; Complete the file name ;; Complete the file name
(let ([c-file (let ([c-file
(if (complete-path? file) (if (complete-path? file)
@ -45,7 +57,7 @@
[else (raise-syntax-error [else (raise-syntax-error
#f #f
"can't determine a base path" "can't determine a base path"
stx)])))]) orig-stx)])))])
;; Open the included file ;; Open the included file
(let ([p (with-handlers ([not-break-exn? (let ([p (with-handlers ([not-break-exn?
(lambda (exn) (lambda (exn)
@ -56,7 +68,7 @@
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
exn)) exn))
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)
@ -72,7 +84,7 @@
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
exn)) exn))
stx))]) orig-stx))])
(read-syntax c-file p))]) (read-syntax c-file p))])
(if (eof-object? r) (if (eof-object? r)
null null
@ -103,14 +115,11 @@
(datum->syntax-object (datum->syntax-object
(quote-syntax here) (quote-syntax here)
`(begin ,@lexed-content) `(begin ,@lexed-content)
stx)))))))) orig-stx)))))))]))
(define-syntax include (define (check-fn-form fn stx)
(lambda (stx)
(syntax-case stx ()
[(_ fn)
;; Check form of fn: ;; Check form of fn:
(syntax-case* (syntax fn) (build-path) module-or-top-identifier=? (syntax-case* fn (build-path) module-or-top-identifier=?
[fn [fn
(string? (syntax-e (syntax fn))) (string? (syntax-e (syntax fn)))
'ok] 'ok]
@ -124,13 +133,45 @@
(module-identifier=? e (quote-syntax same)))))) (module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...)))) (syntax->list (syntax (elem1 elem ...))))
'ok] 'ok]
[_else (raise-syntax-error #f "bad syntax" stx (syntax fn))]) [_else (raise-syntax-error #f "bad syntax" stx fn)]))
;; Expand to include-at/relative-to:
(define (include/proc stx)
(syntax-case stx ()
[(_ fn)
(check-fn-form (syntax fn) stx)
(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))