diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss new file mode 100644 index 0000000..00674fe --- /dev/null +++ b/collects/mzlib/include.ss @@ -0,0 +1,106 @@ + +(module include mzscheme + + (define-syntax include + (lambda (stx) + ;; Parse the file name + (let ([file + (syntax-case stx (build-path) + [(_ fn) + (string? (syntax-e (syntax fn))) + (syntax-e (syntax fn))] + [(_ (build-path elem1 elem ...)) + (andmap + (lambda (e) + (or (string? (syntax-e e)) + (module-identifier=? e (quote-syntax up)) + (module-identifier=? e (quote-syntax same)))) + (syntax->list (syntax (elem1 elem ...)))) + (apply build-path (syntax->datum (syntax (elem1 elem ...))))])]) + ;; Complete the file name + (let ([c-file + (if (complete-path? file) + file + (path->complete-path + file + (cond + ;; Src of include expression is a path? + [(and (string? (syntax-source stx)) + (complete-path? (syntax-source stx))) + (let-values ([(base name dir?) + (split-path (syntax-source stx))]) + (if dir? + (syntax-source stx) + base))] + ;; Load relative? + [(current-load-relative-directory)] + ;; Current directory + [(current-directory)] + [else (raise-syntax-error + 'include + "can't determine a base path" + stx)])))]) + ;; Open the included file + (let ([p (with-handlers ([not-break-exn? + (lambda (exn) + (raise-syntax-error + 'include + (format + "can't open include file (~a)" + (if (exn? exn) + (exn-message exn) + exn)) + stx + c-file))]) + (open-input-file c-file))]) + ;; Read expressions from file + (let ([content + (let loop () + (let ([r (with-handlers ([not-break-exn? + (lambda (exn) + (raise-syntax-error + 'include + (format + "read error (~a)" + (if (exn? exn) + (exn-message exn) + exn)) + stx))]) + (read-syntax c-file p))]) + (if (eof-object? r) + null + (cons r (loop)))))]) + ;; 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 + (cond + [(pair? v) + (loop v)] + [(vector? v) + (list->vector (loop (vector->list v)))] + [(box? v) + (box (loop (unbox v)))] + [else + v]) + content + stx))]))]) + (datum->syntax + `(begin ,@lexed-content) + stx + (quote-syntax here))))))))) + + (export include)) + + + + + \ No newline at end of file diff --git a/collects/mzlib/sigmatch.ss b/collects/mzlib/sigmatch.ss index f710770..17d1e29 100644 --- a/collects/mzlib/sigmatch.ss +++ b/collects/mzlib/sigmatch.ss @@ -74,7 +74,7 @@ "~a: ~a is missing a sub-unit name `~a', required by ~a" who src-context - (sig-path-name s path) + (sig-path-name (car s) path) dest-context) (current-continuation-marks)))))]) (and v diff --git a/collects/mzlib/sigutils.ss b/collects/mzlib/sigutil.ss similarity index 96% rename from collects/mzlib/sigutils.ss rename to collects/mzlib/sigutil.ss index bf71f82..6a40db6 100644 --- a/collects/mzlib/sigutils.ss +++ b/collects/mzlib/sigutil.ss @@ -467,21 +467,23 @@ (loop (cdr e)) (cons (car e) (loop (cdr e)))))))] [local-vars (append renamed-internals filtered-exported-names imported-names)]) - (let loop ([pre-lines null][lines body][port #f][body null][vars null]) + (let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) (make-parse-unit imports renames vars body)] [(and (null? pre-lines) (not port) (not (pair? lines))) (syntax-error 'unit/sig expr "improper body list form")] [else - (let-values ([(line) (local-expand - (cond - [(pair? pre-lines) (car pre-lines)] - [port (read-syntax port)] - [else (car lines)]) - (append - user-stx-forms - local-vars))] + (let-values ([(line) (let ([s (cond + [(pair? pre-lines) (car pre-lines)] + [port (read-syntax port-name port)] + [else (car lines)])]) + (if (eof-object? s) + s + (local-expand s + (append + user-stx-forms + local-vars))))] [(rest-pre-lines) (if (null? pre-lines) null @@ -502,6 +504,7 @@ (loop rest-pre-lines rest-lines port + port-name (cons line body) (append (syntax->list (syntax (id ...))) vars))] [else @@ -518,6 +521,7 @@ (loop (append (cdr line-list) rest-pre-lines) rest-lines port + port-name body vars))] [(and (stx-pair? line) @@ -532,9 +536,10 @@ (format "cannot include a directory ~s" file))) (let* ([old-dir (current-load-relative-directory)] - [p (open-input-file (if (and old-dir (not (complete-path? file))) - (path->complete-path file old-dir) - file))]) + [c-file (if (and old-dir (not (complete-path? file))) + (path->complete-path file old-dir) + file)] + [p (open-input-file c-file)]) (let-values ([(lines body vars) (parameterize ([current-load-relative-directory (if (string? base) @@ -552,11 +557,12 @@ (loop null rest-lines p + c-file body vars)) (lambda () (close-input-port p))))]) - (loop rest-pre-lines lines port body vars)))))] + (loop rest-pre-lines lines port port-name body vars)))))] [else (syntax-error 'unit/sig expr "improper `include' clause form" @@ -565,6 +571,7 @@ (loop rest-pre-lines rest-lines port + port-name (cons line body) vars)]))])))))))) @@ -729,11 +736,11 @@ (get-sig 'compound-unit/sig expr #f (syntax sig)))] - [(elem ...) + [(elem1 elem ...) (andmap (lambda (s) (and (identifier? s) (not (eq? (syntax-e s) ':)))) - (syntax->list (syntax (elem ...)))) + (syntax->list (syntax (elem1 elem ...)))) (values path #f)] [else (syntax-error 'compound-unit/sig expr @@ -924,9 +931,10 @@ list flat (flatten-signature - (symbol->string (if (stx-null? exname) - last - (syntax-e (stx-car exname)))) + (symbol->string + (if (stx-null? exname) + last + (syntax-e (stx-car exname)))) sig))))) (syntax-error 'compound-unit/sig expr @@ -948,9 +956,8 @@ (map sig-explode-pair-sigpart exports))) (lambda (name) (syntax-error 'compound-unit/sig expr - (format - "the name \"~s\" is exported twice" - name)))) + "name is exported twice" + name))) (values (map link-name links) (map link-expr links) (map (lambda (link) (explode-sig (link-sig link))) links) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index 07d7195..06fe83a 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -100,7 +100,7 @@ exploded-imports exploded-exports) (parse-compound-unit expr (syntax body))] - [(t) (lambda (l) (datum->syntax l expr (quote-syntax here)))]) + [(t) (lambda (l) (datum->syntax l expr expr))]) (with-syntax ([(tag ...) (t tags)] [(uexpr ...) (t exprs)] [(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))] @@ -137,9 +137,9 @@ [(_ u sig ...) (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)]) (with-syntax ([exploded-sigs (datum->syntax (explode-named-sigs sigs) - expr (quote-syntax here))] + expr expr)] [flat-sigs (datum->syntax (flatten-signatures sigs) - expr (quote-syntax here))]) + expr expr)]) (syntax/loc expr (let ([unt u]) @@ -156,15 +156,14 @@ (lambda (expr) (syntax-case expr () [(_ e (im-sig ...) ex-sig) - (let ([e (syntax e)] - [im-sigs (map (lambda (sig) + (let ([im-sigs (map (lambda (sig) (get-sig 'unit->unit/sig expr #f sig)) (syntax->list (syntax (im-sig ...))))] [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig))]) (with-syntax ([exploded-imports (datum->syntax (explode-named-sigs im-sigs) - expr (quote-syntax here))] + expr expr)] [exploded-exports (datum->syntax (explode-sig ex-sig) - expr (quote-syntax here))]) + expr expr)]) (syntax (make-unit/sig e