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