.
original commit: 5200f352d6becfac3b25078ca70f20e1f5fb55c0
This commit is contained in:
parent
5b897abd58
commit
3ada00788f
|
@ -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))
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user