221 lines
8.2 KiB
Racket
221 lines
8.2 KiB
Racket
|
|
(module include mzscheme
|
|
(require-for-syntax syntax/stx
|
|
racket/private/increader
|
|
"cm-accomplice.rkt")
|
|
(require mzlib/etc)
|
|
|
|
(define-for-syntax (resolve-path-spec fn loc stx build-path-stx)
|
|
(let ([file
|
|
(syntax-case* fn (lib) module-or-top-identifier=?
|
|
[_
|
|
(string? (syntax-e fn))
|
|
(let ([s (syntax-e fn)])
|
|
(unless (or (relative-path? s)
|
|
(absolute-path? s))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad pathname string"
|
|
stx
|
|
fn))
|
|
(string->path s))]
|
|
[(-build-path elem ...)
|
|
(begin
|
|
(collect-garbage)
|
|
(module-identifier=? #'-build-path build-path-stx)
|
|
(module-or-top-identifier=? #'-build-path build-path-stx))
|
|
(let ([l (syntax-object->datum (syntax (elem ...)))])
|
|
(when (null? l)
|
|
(raise-syntax-error
|
|
#f
|
|
"`build-path' keyword is not followed by at least one string"
|
|
stx
|
|
fn))
|
|
(apply build-path l))]
|
|
[(lib filename ...)
|
|
(let ([l (syntax-object->datum (syntax (filename ...)))])
|
|
(unless (or (andmap string? l)
|
|
(pair? l))
|
|
(raise-syntax-error
|
|
#f
|
|
"`lib' keyword is not followed by a sequence of string datums"
|
|
stx
|
|
fn))
|
|
(apply collection-file-path
|
|
(car l)
|
|
(if (null? (cdr l))
|
|
(list "mzlib")
|
|
(cdr l))))]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
"not a pathname string, `build-path' form, or `lib' form for file"
|
|
stx
|
|
fn)])])
|
|
(if (complete-path? file)
|
|
file
|
|
(path->complete-path
|
|
file
|
|
(cond
|
|
;; Src of include expression is a path?
|
|
[(and (path? (syntax-source loc))
|
|
(complete-path? (syntax-source loc)))
|
|
(let-values ([(base name dir?)
|
|
(split-path (syntax-source loc))])
|
|
(if dir?
|
|
(syntax-source loc)
|
|
base))]
|
|
;; Load relative?
|
|
[(current-load-relative-directory)]
|
|
;; Current directory
|
|
[(current-directory)])))))
|
|
|
|
(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 ([orig-c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)]
|
|
[ctx (syntax ctx)]
|
|
[loc (syntax loc)]
|
|
[reader (syntax reader)]
|
|
[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)))])
|
|
|
|
(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)
|
|
(reader-val
|
|
(let loop ([e (syntax-object->datum
|
|
(local-expand reader 'expression null))])
|
|
(cond
|
|
[(reader? e) e]
|
|
[(pair? e) (or (loop (car e))
|
|
(loop (cdr e)))]
|
|
[else #f])))
|
|
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))
|
|
|
|
;; Open the included file
|
|
(let ([p (with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(raise-syntax-error
|
|
#f
|
|
(format
|
|
"can't open include file (~a)"
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
exn))
|
|
orig-stx
|
|
c-file))])
|
|
(open-input-file c-file))])
|
|
(port-count-lines! p)
|
|
;; Read expressions from file
|
|
(let ([content
|
|
(let loop ()
|
|
(let ([r (with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(close-input-port p)
|
|
(raise-syntax-error
|
|
#f
|
|
(format
|
|
"read error (~a)"
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
exn))
|
|
orig-stx))])
|
|
(read-syntax c-file p))])
|
|
(if (eof-object? r)
|
|
null
|
|
(cons r (loop)))))])
|
|
(close-input-port p)
|
|
;; Preserve src info for content, but set its
|
|
;; lexical context to be that of the include expression
|
|
(let ([lexed-content
|
|
(let loop ([content content])
|
|
(cond
|
|
[(pair? content)
|
|
(cons (loop (car content))
|
|
(loop (cdr content)))]
|
|
[(null? content) null]
|
|
[else
|
|
(let ([v (syntax-e content)])
|
|
(datum->syntax-object
|
|
ctx
|
|
(cond
|
|
[(pair? v)
|
|
(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 (include/proc stx)
|
|
(syntax-case stx ()
|
|
[(_ fn)
|
|
(with-syntax ([_stx stx])
|
|
(syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
|
|
|
|
(define (include-at/relative-to/proc stx)
|
|
(syntax-case stx ()
|
|
[(_ ctx loc fn)
|
|
(with-syntax ([_stx stx])
|
|
(syntax/loc stx (do-include _stx ctx loc fn #f)))]))
|
|
|
|
(define (include/reader/proc stx)
|
|
(syntax-case stx ()
|
|
[(_ fn reader)
|
|
;; Expand to do-include:
|
|
(with-syntax ([_stx stx])
|
|
(syntax/loc stx
|
|
(do-include _stx _stx _stx fn
|
|
(letrec-syntax ([the-reader (lambda (stx)
|
|
(datum->syntax-object
|
|
#'here
|
|
(make-reader reader)))])
|
|
the-reader))))]))
|
|
|
|
(define (include-at/relative-to/reader/proc stx)
|
|
(syntax-case stx ()
|
|
[(_ ctx loc fn reader)
|
|
(with-syntax ([_stx stx])
|
|
(syntax/loc stx
|
|
(do-include _stx ctx loc fn
|
|
(letrec-syntax ([the-reader (lambda (stx)
|
|
(datum->syntax-object
|
|
#'here
|
|
(make-reader reader)))])
|
|
the-reader))))])))
|
|
|
|
(provide include
|
|
include-at/relative-to
|
|
include/reader
|
|
include-at/relative-to/reader))
|