From b7cfd2fd0035df7a11cf274d1d3d4b43c13c50ef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 3 Mar 2008 21:59:09 +0000 Subject: [PATCH] plt-r6rs executable and initial r6rs docs svn: r8859 --- collects/mzlib/cm.ss | 41 ++-- collects/r5rs/r5rs.scrbl | 4 +- collects/r5rs/run.ss | 2 +- collects/r6rs/info.ss | 6 + collects/r6rs/run.ss | 181 ++++++++++++++++ collects/r6rs/scribblings/r6rs.scrbl | 196 ++++++++++++++++++ collects/scribble/base-render.ss | 2 +- .../scribblings/guide/module-basics.scrbl | 27 ++- collects/scribblings/mzc/make.scrbl | 20 +- collects/syntax/modcode.ss | 11 +- collects/syntax/scribblings/modcode.scrbl | 10 +- 11 files changed, 459 insertions(+), 41 deletions(-) create mode 100644 collects/r6rs/run.ss create mode 100644 collects/r6rs/scribblings/r6rs.scrbl diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index 7c13201eb9..bc8030e0d6 100644 --- a/collects/mzlib/cm.ss +++ b/collects/mzlib/cm.ss @@ -1,15 +1,15 @@ -(module cm mzscheme +(module cm scheme/base (require syntax/modcode syntax/modresolve (lib "main-collects.ss" "setup") - mzlib/file) + scheme/file) (provide make-compilation-manager-load/use-compiled-handler managed-compile-zo make-caching-managed-compile-zo trust-existing-zos manager-compile-notify-handler - (rename trace manager-trace-handler)) + (rename-out [trace manager-trace-handler])) (define manager-compile-notify-handler (make-parameter void)) (define trace (make-parameter void)) @@ -71,7 +71,7 @@ (with-handlers ([void (lambda (exn) (try-delete-file path) (raise exn))]) - (let ([out (open-output-file path 'truncate/replace)]) + (let ([out (open-output-file path #:exists 'truncate/replace)]) (dynamic-wind void (lambda () @@ -96,7 +96,7 @@ (newline op))))) (define (touch path) - (close-output-port (open-output-file path 'append))) + (close-output-port (open-output-file path #:exists 'append))) (define (compilation-failure mode path zo-name date-path reason) (with-handlers ((exn:fail:filesystem? void)) @@ -108,7 +108,7 @@ (display reason p)))) (trace-printf "failure")) - (define (compile-zo mode path) + (define (compile-zo mode path read-src-syntax) ((manager-compile-notify-handler) path) (trace-printf "compiling: ~a" path) (parameterize ([indent (string-append " " (indent))]) @@ -145,9 +145,9 @@ (cons (path->bytes p) external-deps))))) d)))]) - (get-module-code path mode))] + (get-module-code path mode #:source-reader read-src-syntax))] [code-dir (get-code-dir mode path)]) - (if (not (directory-exists? code-dir)) + (when (not (directory-exists? code-dir)) (make-directory* code-dir)) (with-compile-output zo-name @@ -214,8 +214,8 @@ (file-or-directory-modify-seconds name))) (apply first-date l))])) - (define (compile-root mode path up-to-date) - (let ([path (simplify-path (expand-path path))]) + (define (compile-root mode path up-to-date read-src-syntax) + (let ([path (simplify-path (cleanse-path path))]) (let ((stamp (and up-to-date (hash-table-get up-to-date path #f)))) (cond @@ -235,7 +235,7 @@ (cond ((> path-time path-zo-time) (trace-printf "newer src...") - (compile-zo mode path)) + (compile-zo mode path read-src-syntax)) (else (let ((deps (with-handlers ((exn:fail:filesystem? (lambda (ex) (list (version))))) (call-with-input-file (path-add-suffix (get-compilation-path mode path) #".dep") @@ -244,13 +244,13 @@ ((or (not (pair? deps)) (not (equal? (version) (car deps)))) (trace-printf "newer version...") - (compile-zo mode path)) + (compile-zo mode path read-src-syntax)) ((ormap (lambda (d) ;; str => str is a module file name (check transitive dates) ;; (cons 'ext str) => str is an non-module file (check date) (let ([t (cond - [(bytes? d) (compile-root mode (bytes->path d) up-to-date)] - [(path? d) (compile-root mode d up-to-date)] + [(bytes? d) (compile-root mode (bytes->path d) up-to-date read-src-syntax)] + [(path? d) (compile-root mode d up-to-date read-src-syntax)] [(and (pair? d) (eq? (car d) 'ext) (or (bytes? (cdr d)) @@ -270,19 +270,20 @@ (cons 'ext (main-collects-relative->path (cdr p))) (main-collects-relative->path p))) (cdr deps))) - (compile-zo mode path)))))) + (compile-zo mode path read-src-syntax)))))) (let ((stamp (get-compiled-time mode path #t))) (hash-table-put! up-to-date path stamp) stamp))))))))) - (define (managed-compile-zo zo) - ((make-caching-managed-compile-zo) zo)) + (define (managed-compile-zo zo [read-src-syntax read-syntax]) + ((make-caching-managed-compile-zo read-src-syntax) zo)) - (define (make-caching-managed-compile-zo) + (define (make-caching-managed-compile-zo [read-src-syntax read-syntax]) (let ([cache (make-hash-table 'equal)]) (lambda (zo) (parameterize ([current-load/use-compiled (make-compilation-manager-load/use-compiled-handler/table cache)]) - (compile-root (car (use-compiled-file-paths)) (path->complete-path zo) cache))))) + (compile-root (car (use-compiled-file-paths)) (path->complete-path zo) cache read-src-syntax) + (void))))) (define (make-compilation-manager-load/use-compiled-handler) (make-compilation-manager-load/use-compiled-handler/table (make-hash-table 'equal))) @@ -330,7 +331,7 @@ (default-handler path mod-name)] [else (trace-printf "processing: ~a" path) - (compile-root (car modes) path cache) + (compile-root (car modes) path cache read-syntax) (trace-printf "done: ~a" path) (default-handler path mod-name)]))]) compilation-manager-load-handler)))) diff --git a/collects/r5rs/r5rs.scrbl b/collects/r5rs/r5rs.scrbl index 52489dab7e..80a5356b3f 100644 --- a/collects/r5rs/r5rs.scrbl +++ b/collects/r5rs/r5rs.scrbl @@ -82,7 +82,7 @@ By default, @exec{plt-r5rs} departs from @|r5rs| conformance in one crucial way: the initial bindings of primitives correspond to module imports into the top-level environment, instead of variable bindings. This difference is visible if the name of a primitive is redefined at -the top level. Use the @as-index{@DFlag{slow}} command-line +the top level. Use the @as-index{@DFlag{no-prim}} command-line flag---before a file to load, if any---to obtain the standard behavior for primitive bindings (at the cost of performance). @@ -110,7 +110,7 @@ corresponds to @|r5rs|. Use @scheme[(namespace-require/copy 'r5rs)] with an empty namespace to maximize conformance with @|r5rs|; Using @scheme[(namespace-require 'r5rs)], in contrast, creates primitive bindings as imports, which is the same as using -@seclink["plt-r5rs"]{@exec{plt-r5rs}} without the @DFlag{slow} flag. +@seclink["plt-r5rs"]{@exec{plt-r5rs}} without the @DFlag{no-prim} flag. More simply, use @scheme[(scheme-report-environment 5)]. See also @schememodname[r5rs/init], which sets reader and printer parameters to increase conformance. diff --git a/collects/r5rs/run.ss b/collects/r5rs/run.ss index 755a1c70d6..e6c9a38be4 100644 --- a/collects/r5rs/run.ss +++ b/collects/r5rs/run.ss @@ -6,7 +6,7 @@ (define-values (main args) (command-line #:once-each - [("--slow") "disable assumption that primitives are never redefined" + [("--no-prim") "(slow) disable assumption that primitives are never redefined" (slow #t)] #:handlers (case-lambda diff --git a/collects/r6rs/info.ss b/collects/r6rs/info.ss index c14a2ca411..3940614bea 100644 --- a/collects/r6rs/info.ss +++ b/collects/r6rs/info.ss @@ -1 +1,7 @@ #lang setup/infotab + +(define scribblings '(("scribblings/r6rs.scrbl" (multi-page)))) +(define doc-categories '((languages -1))) + +(define mzscheme-launcher-names '("PLT R6RS")) +(define mzscheme-launcher-libraries '("run.ss")) diff --git a/collects/r6rs/run.ss b/collects/r6rs/run.ss new file mode 100644 index 0000000000..b4bdcca92b --- /dev/null +++ b/collects/r6rs/run.ss @@ -0,0 +1,181 @@ +#lang scheme/base +(require scheme/cmdline + compiler/cm + (prefix-in r6rs: "lang/reader.ss") + syntax/modcode + setup/dirs + scheme/port + scheme/file + "private/readtable.ss") + +(define install-mode (make-parameter #f)) +(define compile-mode (make-parameter #f)) +(define install-all-users (make-parameter #f)) +(define install-force (make-parameter #f)) + +(define-values (main args) + (command-line + #:once-any + [("--install") "install libraries from , or stdin if no provided" + (install-mode #t)] + [("--compile") "compile and all dependencies" + (compile-mode #t)] + #:once-each + [("--all-users") "install into main installation" + (install-all-users #t)] + [("--force") "overwrite existing libraries" + (install-force #t)] + #:handlers + (case-lambda + [(x) (values #f null)] + [(x file . args) (values file args)]) + '("file" "arg"))) + +(current-command-line-arguments (apply vector-immutable args)) + +(define (r6rs-read-syntax . args) + (datum->syntax #f (apply r6rs:read-syntax args))) + +(define (extract-libraries orig) + (let loop ([last-pos 0]) + (let ([peeker (let-values ([(line col pos) (port-next-location orig)]) + (let ([p (peeking-input-port orig)]) + (port-count-lines! p) + (relocate-input-port p line col pos)))]) + (port-count-lines! peeker) + (let ([lib-stx (with-r6rs-reader-parameters + (lambda () + (read-syntax (object-name orig) peeker)))]) + (if (eof-object? lib-stx) + null + (let ([lib (syntax->datum lib-stx)]) + (unless (and (list? lib) + ((length lib) . >= . 2) + (eq? 'library (car lib))) + (raise-syntax-error + 'library + "not an R6RS library form" + lib-stx)) + (let ([name (cadr lib)]) + (unless (valid-name? name) + (error (format + "~a: invalid library name: ~e" + (find-system-path 'run-file) + name))) + (let ([path (name->path name)]) + (unless (install-force) + (when (file-exists? path) + (error (format "~a: file already exists: ~a for library: ~e" + (find-system-path 'run-file) + path + name)))) + (let ([code (open-output-bytes)]) + (let ([pos (file-position peeker)]) + (copy-port (make-limited-input-port orig (- pos last-pos)) code) + (cons (cons path (get-output-bytes code #t)) + (loop pos)))))))))))) + +(define (install-libraries orig) + (port-count-lines! orig) + (let ([libs (extract-libraries orig)]) + (for-each (lambda (lib) + (let ([path (car lib)] + [code (cdr lib)]) + (printf " [installing ~a]\n" path) + (let-values ([(base name dir?) (split-path path)]) + (make-directory* base)) + (call-with-output-file* + path + #:exists (if (install-force) 'truncate/replace 'error) + (lambda (out) + (display "#!r6rs\n" out) + (display code out) + (display "\n" out))))) + libs) + (for-each (lambda (lib) + (compile-file (car lib))) + libs))) + +(define (valid-name? name) + (and (list? name) + (pair? name) + (symbol? (car name)) + (let loop ([name name]) + (cond + [(null? (cdr name)) + (or (symbol? (car name)) + (and (list? (car name)) + (andmap exact-nonnegative-integer? (car name))))] + [else (and (symbol? (car name)) + (loop (cdr name)))])))) + +(define (name->path name) + (let* ([name (if (or (= (length name) 1) + (and (= (length name) 2) + (not (symbol? (cadr name))))) + (list* (car name) 'main (cdr name)) + name)]) + (apply build-path + (if (install-all-users) + (find-collects-dir) + (find-user-collects-dir)) + (let loop ([name name]) + (cond + [(and (pair? (cdr name)) + (null? (cddr name)) + (not (symbol? (cadr name)))) + ;; versioned: + (list + (format "~a~a.ss" + (car name) + (apply + string-append + (map (lambda (v) + (format "-~a" v)) + (cadr name)))))] + [(null? (cdr name)) + ;; unversioned: + (list (format "~a.ss" (car name)))] + [else + (cons (symbol->string (car name)) + (loop (cdr name)))]))))) + +;; ---------------------------------------- + +(define (compile-file src) + (parameterize ([manager-compile-notify-handler + (lambda (p) + (printf " [Compiling ~a]\n" p))]) + (managed-compile-zo src r6rs-read-syntax))) + +;; ---------------------------------------- + +(cond + [(install-mode) + (if main + (call-with-input-file* main install-libraries) + (install-libraries (current-input-port)))] + [(compile-mode) + (unless main + (error (format "~a: need a file to compile" (find-system-path 'run-file)))) + (compile-file main)] + [else + (unless main + (error (format "~a: need a file to run" (find-system-path 'run-file)))) + (let* ([main (path->complete-path main)] + [zo (let-values ([(base name dir?) (split-path main)]) + (build-path base + "compiled" + (path-add-suffix name #".zo")))]) + (if ((file-or-directory-modify-seconds zo #f (lambda () -inf.0)) + . > . + (file-or-directory-modify-seconds main #f (lambda () -inf.0))) + ;; .zo will be used; no need to set reader: + (dynamic-require main #f) + ;; need to read with R6RS reader + (let ([code (get-module-code main #:source-reader r6rs-read-syntax)] + [rpath (module-path-index-resolve + (module-path-index-join main #f))]) + (parameterize ([current-module-declare-name rpath]) + (eval code)) + (dynamic-require rpath #f))))]) diff --git a/collects/r6rs/scribblings/r6rs.scrbl b/collects/r6rs/scribblings/r6rs.scrbl new file mode 100644 index 0000000000..36aab7cce0 --- /dev/null +++ b/collects/r6rs/scribblings/r6rs.scrbl @@ -0,0 +1,196 @@ +#lang scribble/doc +@(require scribble/manual + scribble/bnf + (for-label setup/dirs + rnrs/programs-6)) + +@(define guide-src '(lib "scribblings/guide/guide.scrbl")) + +@(define r6rs @elem{R@superscript{6}RS}) + +@title{@bold{R6RS}: Standard Language} + +The ``The Revised@superscript{6} Report on the Algorithmic Language +Scheme'' @cite["Sperber07"] defines a dialect of Scheme. We use +@defterm{@|r6rs|} to refer to both the standard and the language +defined by the standard. + +@|r6rs| defines both @defterm{libraries} and @defterm{top-level +programs}. Both correspond to PLT Scheme @defterm{modules} (see +@secref[#:doc guide-src "modules"]). That is, although @|r6rs| defines +top-level programs as entry points, you can just as easily treat a +library as an entry point when using PLT Scheme. The only difference +is that an @|r6rs| top-level program cannot export any bindings to +other modules. + +@table-of-contents[] + +@; ---------------------------------------- + +@section{Running Top-Level Programs} + +To run a top-level program, either: + +@itemize{ + + @item{Use the @exec{plt-r6rs} executable, supplying the file that + contains the program on the command line: + + @commandline{plt-r6rs @nonterm{program-file}} + + Additional command-line arguments are propagated as + command-line arguments to the program (accessed via + @scheme[command-line]). + + To compile the file to bytecode (to speed future runs of the + program), use @exec{plt-r6rs} with the @DFlag{compile} flag: + + @commandline{plt-r6rs --compile @nonterm{program-file}} + + The bytecode file is written in a @filepath{compiled} + sub-directory next to @nonterm{program-file}. + + For example, if @filepath{hi.scm} contains + + @schemeblock[ + (import (rnrs)) + (display "hello\n") + ] + + then + + @commandline{plt-r6rs hi.scm} + + prints ``hello.''} + + @item{Prefix the program with @schememetafont{#!r6rs}, which counts + as a comment from the @|r6rs| perspective, but is a synonym for + @scheme[#,(hash-lang) r6rs] from the PLT Scheme perspective. + Such files can be run like any other PLT Scheme module, such as + using @exec{mzscheme}: + + @commandline{mzscheme @nonterm{program-file}} + + or using DrScheme with the @onscreen{Module} language. The + file can also be compiled to bytecode using @exec{mzc}: + + @commandline{mzc @nonterm{program-file}} + + For example, if @filepath{hi.ss} contains + + @schemeblock[ + #,(schememetafont "#!r6rs") + (import (rnrs)) + (display "hello\n") + ] + + then + + @commandline{mzscheme hi.ss} + + prints ``hello.'' Similarly, opening @filepath{hi.ss} in + DrScheme and clicking @onscreen{Run} prints ``hello'' within + the DrScheme interactions window.} + +} + +@; ---------------------------------------- + +@section{Installing Libraries} + +To reference an @|r6rs| library from a top-level program or another +library, it must be installed as a collection-based library in PLT +Scheme. + +One way to produce an @|r6rs| installed library is to create in +a @techlink[#:doc guide-src]{collection} a file that starts with +@schememetafont{#!r6rs} and that contains a @scheme[library] form. For +example, the following file might be created in a @filepath{hello.ss} +file within a @filepath{examples} collection directory: + + @schemeblock[ + #,(schememetafont "#!r6rs") + (library (examples hello) + (export greet) + (import (rnrs)) + + (define (greet) + (display "hello\n"))) + ] + +Alternately, the @exec{plt-r6rs} executable with the @DFlag{install} +flag accepts a sequence of @scheme[library] declarations and installs +them into separate files in a collection directory, based on the +declared name of each library: + + @commandline{plt-r6rs --install @nonterm{libraries-file}} + +By default, libraries are installed into the user-specific collection +directory (see @scheme[find-user-collects-dir]). The @DFlag{all-users} +flag causes the libraries to be installed into the main installation, +instead (see @scheme[find-collects-dir]): + + @commandline{plt-r6rs --install --all-users @nonterm{libraries-file}} + +See @secref["libpaths"] for information on how @|r6rs| library names +are turned into collection-based module paths, which determines where +the files are written. Libraries installed by @exec{plt-r6rs +@DFlag{install}} are automatically compiled to bytecode form. + +@; ---------------------------------------- + +@section[#:tag "libpaths"]{Libraries and Collections} + +An @|r6rs| library name is sequence of symbols, optionally followed by +a version as a sequence of exact, non-negative integers. Such a name +is converted to a PLT Scheme module pathname (see @secref[#:doc +guide-src "module-paths"]) by concatenating the symbols with a +@litchar{/} separator, and then appending the version integers each +with a preceeding @litchar{-}. As a special case, when an @|r6rs| path +contains a single symbol followed by a version, a @schemeidfont{main} +symbol is effectively inserted after the initial symbol. + +Examples: + +@schemeblock[ +(rnrs io simple (6)) #, @elem{corresponds to} rnrs/io/simple-6 +(rnrs) #, @elem{corresponds to} rnrs +(rnrs (6)) #, @elem{corresponds to} rnrs/main-6 +] + +When an @|r6rs| library or top-level program refers to another +library, it can supply version constraints rather than naming a +specific version. The version constraint is resolved at compile time +by searching the set of installed files. + +@; ---------------------------------------- + +@section{Scheme Interoperability} + +Using the conversion rules in @secref["libpaths"], and @r6rs library +can refer to modules that are implemented in other dialects supported +by PLT Scheme, and other PLT Scheme modules can refer to libraries +that are implemented in @|r6rs|. + +Beware that a @defterm{pair} in @|r6rs| corresponds to a +@defterm{mutable pair} in @schememodname[scheme/base]. Otherwise, +@|r6rs| libraries and @schememodname[scheme/base] share the same +datatype for numbers, characters, strings, bytevectors (a.k.a. byte +strings), vectors, hash tables, and so on. Input and output +ports from @schememodname[scheme/base] can be used directly as binary +ports with @|r6rs| libraries, and all @|r6rs| ports can be used as +ports in @schememodname[scheme/base] programs, but only textual ports +created via @|r6rs| libraries can be used by other @|r6rs| operations +that expect textual ports. + +@; ---------------------------------------------------------------------- + +@(bibliography + + (bib-entry #:key "Sperber07" + #:author "Michael Sperber, R. Kent Dybvig, Matthew Flatt, and Anton van Straaten (editors)" + #:title @elem{The Revised@superscript{6} Report on the Algorithmic Language Scheme} + #:date "2007" + #:url "http://www.r6rs.org/") + +) diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index d6d841fb73..8d1b60ac54 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -121,7 +121,7 @@ (define/private (convert-key prefix k) (case (car k) - [(part tech) + [(part tech cite) (let ([rhs (cadr k)]) (if (or (string? rhs) (pair? rhs)) (list (car k) (cons prefix (if (pair? rhs) diff --git a/collects/scribblings/guide/module-basics.scrbl b/collects/scribblings/guide/module-basics.scrbl index 619d23eae0..ac6f8fa0a2 100644 --- a/collects/scribblings/guide/module-basics.scrbl +++ b/collects/scribblings/guide/module-basics.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require scribble/manual scribble/eval - "guide-utils.ss") + "guide-utils.ss" + (for-label setup/dirs)) @title[#:tag "module-basics"]{Module Basics} @@ -49,9 +50,10 @@ references on all platforms, much like relative URLs.) Library modules that are distributed with PLT Scheme are usually referenced through an unquoted, suffixless path. The path is relative -(roughly) to the library installation directory. The module below -refers to the @filepath{date.ss} library that is part of the -@filepath{scheme} collection. +to the library installation directory, which contains directories for +individual library @deftech{collections}. The module below refers to +the @filepath{date.ss} library that is part of the @filepath{scheme} +@tech{collection}. @schememod[ scheme @@ -62,5 +64,22 @@ scheme (date->string (seconds->date (current-seconds)))) ] +In addition to the main @tech{collection} directory, which contains +all collections that are part of the installation, collections can +also be installed in a user-specific location. Finally, additional +collection directories can be specified n configuration files or +through the @envvar{PLTCOLLECTS} search path. Try running the +following program to find out where your collections are: + +@schememod[ +scheme + +(require setup/dirs) + +(find-collects-dir) (code:comment #, @t{main collection directory}) +(find-user-collects-dir) (code:comment #, @t{user-specific collection directory}) +(get-collects-search-dirs) (code:comment #, @t{complete search path}) +] + We discuss more forms of module reference later in @secref["module-paths"]. diff --git a/collects/scribblings/mzc/make.scrbl b/collects/scribblings/mzc/make.scrbl index 5022883895..5d33a88586 100644 --- a/collects/scribblings/mzc/make.scrbl +++ b/collects/scribblings/mzc/make.scrbl @@ -195,13 +195,20 @@ modules may produce compiled files with inconsistent timestamps and/or @filepath{.dep} files with incorrect information.} -@defproc[(managed-compile-zo [file path-string?]) void?]{ +@defproc[(managed-compile-zo [file path-string?] + [read-src-syntax (any/c input-port? . -> . syntax?) read-syntax]) + void?]{ Compiles the given module source file to a @filepath{.zo}, installing a compilation-manager handler while the file is compiled (so that required modules are also compiled), and creating a @filepath{.dep} file to record the timestamps of immediate files used to compile the source -(i.e., files @scheme[require]d in the source).} +(i.e., files @scheme[require]d in the source). + +If @scheme[file] is compiled from source, then +@scheme[read-src-syntax] is used in the same way as +@scheme[read-syntax] to read the source module. The normal +@scheme[read-syntax] is used for any required files, however.} @defboolparam[trust-existing-zos trust?]{ @@ -212,12 +219,13 @@ compilation-manager @scheme[load/use-compiled] handler to ``touch'' out-of-date @filepath{.zo} files instead of re-compiling from source.} -@defproc[(make-caching-managed-compile-zo) +@defproc[(make-caching-managed-compile-zo + [read-src-syntax (any/c input-port? . -> . syntax?)]) (path-string? . -> . void?)]{ -Returns a procedure that behaves like @scheme[managed-compile-zo], but -a cache of timestamp information is preserved across calls to the -procedure.} +Returns a procedure that behaves like @scheme[managed-compile-zo] +(providing the same @scheme[read-src-syntax] each time), but a cache +of timestamp information is preserved across calls to the procedure.} @defparam[manager-compile-notify-handler notify (path? . -> . any)]{ diff --git a/collects/syntax/modcode.ss b/collects/syntax/modcode.ss index e0e60e00c7..6b0cac7622 100644 --- a/collects/syntax/modcode.ss +++ b/collects/syntax/modcode.ss @@ -37,7 +37,7 @@ (file-or-directory-modify-seconds a))]) (or (and (not bm) am) (and am bm (>= am bm)))))) - (define (read-one orig-path path src?) + (define (read-one orig-path path src? read-src-syntax) (let ([p ((moddep-current-open-input-file) path)]) (when src? (port-count-lines! p)) (dynamic-wind @@ -53,7 +53,7 @@ (if (path? base) base (current-directory)))]) - (read-syntax path p))))]) + (read-src-syntax path p))))]) (when (eof-object? v) (error 'read-one "empty file; expected a module declaration in: ~a" path)) @@ -77,7 +77,8 @@ (define (get-module-code path [sub-path "compiled"] [compiler compile] [extension-handler #f] #:choose [choose (lambda (src zo so) #f)] - #:notify [notify void]) + #:notify [notify void] + #:source-reader [read-src-syntax read-syntax]) (unless (path-string? path) (raise-type-error 'get-module-code "path or string (sans nul)" path)) (let*-values ([(path) (resolve path)] @@ -106,7 +107,7 @@ (and (not prefer) (date>=? zo path-d))) (notify zo) - (read-one path zo #f)] + (read-one path zo #f read-syntax)] ;; Maybe there's an .so? Use it only if we don't prefer source. [(or (eq? prefer 'so) (and (not prefer) @@ -124,7 +125,7 @@ [(or (eq? prefer 'src) path-d) (notify path) - (with-dir (lambda () (compiler (read-one path path #t))))] + (with-dir (lambda () (compiler (read-one path path #t read-src-syntax))))] ;; Report a not-there error [else (raise (make-exn:get-module-code (format "get-module-code: no such file: ~e" path) diff --git a/collects/syntax/scribblings/modcode.scrbl b/collects/syntax/scribblings/modcode.scrbl index 476c32f010..5cb90bb790 100644 --- a/collects/syntax/scribblings/modcode.scrbl +++ b/collects/syntax/scribblings/modcode.scrbl @@ -15,7 +15,10 @@ . -> . (or/c (symbols 'src 'zo 'so) false/c)) (lambda (src zo so) #f)] - [#:notify notify-proc (any/c . -> . any) void]) + [#:notify notify-proc (any/c . -> . any) void] + [#:src-reader read-syntax-proc + (any/c input-port? . -> . syntax?) + read-syntax]) any]{ Returns a compiled expression for the declaration of the module @@ -58,7 +61,10 @@ or an exception is raised (to report that an extension file cannot be used) when @scheme[ext-proc] is @scheme[#f]. If @scheme[notify-proc] is supplied, it is called for the file -(source, @filepath{.zo} or extension) that is chosen.} +(source, @filepath{.zo} or extension) that is chosen. + +If @scheme[read-syntax-proc] is provided, it is used to read the +module from a source file (but not from a bytecode file).} @defparam[moddep-current-open-input-file proc (path-string? . -> . input-port?)]{