From 3ada00788f20ffaf8e7057956f62da5f68e87ff6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Dec 2001 21:57:50 +0000 Subject: [PATCH] . original commit: 5200f352d6becfac3b25078ca70f20e1f5fb55c0 --- collects/mzlib/include.ss | 283 ++++++++++++++++++++++---------------- 1 file changed, 162 insertions(+), 121 deletions(-) diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss index ff4bba9..3d59e46 100644 --- a/collects/mzlib/include.ss +++ b/collects/mzlib/include.ss @@ -1,136 +1,177 @@ (module include mzscheme (require-for-syntax (lib "stx.ss" "syntax")) + (require (lib "etc.ss")) - (define-syntax include-at/relative-to - (lambda (stx) - ;; Parse the file name - (let-values ([(ctx loc file) - (syntax-case* stx (build-path) module-or-top-identifier=? - [(_ ctx loc 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 ...)))))])]) - ;; 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 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)] - [else (raise-syntax-error - #f - "can't determine a base path" - stx)])))]) - ;; Open the included file - (let ([p (with-handlers ([not-break-exn? - (lambda (exn) - (raise-syntax-error - #f - (format - "can't open include file (~a)" - (if (exn? exn) - (exn-message exn) - exn)) - stx - c-file))]) - (open-input-file c-file))]) - (port-count-lines! p) - ;; Read expressions from file - (let ([content - (let loop () - (let ([r (with-handlers ([not-break-exn? - (lambda (exn) - (raise-syntax-error - #f - (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-object - ctx + (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 ([file + (syntax-case* (syntax fn) (build-path) module-or-top-identifier=? + [fn + (string? (syntax-e (syntax fn))) + (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) + file + (path->complete-path + file + (cond + ;; Src of include expression is a path? + [(and (string? (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)] + [else (raise-syntax-error + #f + "can't determine a base path" + orig-stx)])))]) + ;; Open the included file + (let ([p (with-handlers ([not-break-exn? + (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 ([not-break-exn? + (lambda (exn) + (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)))))]) + ;; 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? v) - (loop v)] - [(vector? v) - (list->vector (loop (vector->list v)))] - [(box? v) - (box (loop (unbox v)))] + [(pair? content) + (cons (loop (car content)) + (loop (cdr content)))] + [(null? content) null] [else - v]) - content))]))]) - (datum->syntax-object - (quote-syntax here) - `(begin ,@lexed-content) - stx)))))))) + (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 (check-fn-form fn stx) + ;; Check form of fn: + (syntax-case* fn (build-path) module-or-top-identifier=? + [fn + (string? (syntax-e (syntax fn))) + 'ok] + [(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 ...)))) + 'ok] + [_else (raise-syntax-error #f "bad syntax" stx fn)])) - (define-syntax include - (lambda (stx) + (define (include/proc stx) (syntax-case stx () [(_ fn) - ;; Check form of fn: - (syntax-case* (syntax fn) (build-path) module-or-top-identifier=? - [fn - (string? (syntax-e (syntax fn))) - 'ok] - [(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 ...)))) - 'ok] - [_else (raise-syntax-error #f "bad syntax" stx (syntax fn))]) - ;; Expand to include-at/relative-to: + (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))