From 973d51c20fde224d79382dbf6ea817598ea8773c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Oct 2009 23:05:56 +0000 Subject: [PATCH] change 'read-language' protocol so that the result from 'get-info' accepts a key plus default value (instead of just a key) svn: r16459 --- collects/at-exp/lang/reader.ss | 4 ++-- .../drscheme/private/module-language-tools.ss | 2 +- collects/scribble/base/lang/reader.ss | 4 ++-- collects/scribble/manual/lang/reader.ss | 4 ++-- collects/scribble/sigplan/lang/reader.ss | 4 ++-- collects/scribblings/reference/read.scrbl | 22 ++++++++++++------- collects/syntax-color/module-lexer.ss | 2 +- collects/syntax/module-reader.ss | 20 +++++++++-------- .../syntax/scribblings/module-reader.scrbl | 9 ++++---- src/mzscheme/src/read.c | 4 ++-- 10 files changed, 42 insertions(+), 33 deletions(-) diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss index a526ad284b..b519a3f079 100644 --- a/collects/at-exp/lang/reader.ss +++ b/collects/at-exp/lang/reader.ss @@ -24,8 +24,8 @@ wrap-reader wrap-reader (lambda (proc) - (lambda (key) + (lambda (key defval) (case key [(color-lexer) (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] - [else (and proc (proc key))])))))) + [else (if proc (proc key defval) defval)])))))) diff --git a/collects/drscheme/private/module-language-tools.ss b/collects/drscheme/private/module-language-tools.ss index a5c4a3e203..44284597de 100644 --- a/collects/drscheme/private/module-language-tools.ss +++ b/collects/drscheme/private/module-language-tools.ss @@ -102,7 +102,7 @@ (contract (or/c #f (listof (list/c string? (is-a?/c bitmap%) (-> (is-a?/c drscheme:unit:frame<%>) any)))) - (info-result 'drscheme:toolbar-buttons) + (info-result 'drscheme:toolbar-buttons #f) (get-lang-name pos) 'drscheme/private/module-language-tools))))))) diff --git a/collects/scribble/base/lang/reader.ss b/collects/scribble/base/lang/reader.ss index 9152de7247..8f495a8eaf 100644 --- a/collects/scribble/base/lang/reader.ss +++ b/collects/scribble/base/lang/reader.ss @@ -6,13 +6,13 @@ scribble/base/lang #:read-syntax scribble:read-syntax-inside #:whole-body-readers? #t #:wrapper1 (lambda (t) (list* 'doc 'values '() (t))) -#:info (lambda (key default) +#:info (lambda (key defval default) (case key [(color-lexer) (dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)] [(drscheme:toolbar-buttons) (dynamic-require 'scribble/drscheme-buttons 'drscheme-buttons)] - [else (default key)])) + [else (default key defval)])) (require (prefix-in scribble: "../../reader.ss")) diff --git a/collects/scribble/manual/lang/reader.ss b/collects/scribble/manual/lang/reader.ss index 2407939f7e..6e55aade60 100644 --- a/collects/scribble/manual/lang/reader.ss +++ b/collects/scribble/manual/lang/reader.ss @@ -6,10 +6,10 @@ scribble/manual/lang #:read-syntax scribble:read-syntax-inside #:whole-body-readers? #t #:wrapper1 (lambda (t) (cons 'doc (t))) -#:info (lambda (key default) +#:info (lambda (key defval default) (case key [(color-lexer) (dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)] - [else (default key)])) + [else (default defval key)])) (require (prefix-in scribble: "../../reader.ss")) diff --git a/collects/scribble/sigplan/lang/reader.ss b/collects/scribble/sigplan/lang/reader.ss index f67d928afd..efe6bc9a02 100644 --- a/collects/scribble/sigplan/lang/reader.ss +++ b/collects/scribble/sigplan/lang/reader.ss @@ -6,10 +6,10 @@ scribble/sigplan/lang #:read-syntax scribble:read-syntax-inside #:whole-body-readers? #t #:wrapper1 (lambda (t) (cons 'doc (t))) -#:info (lambda (key default) +#:info (lambda (key defval default) (case key [(color-lexer) (dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)] - [else (default key)])) + [else (default defval key)])) (require (prefix-in scribble: "../../reader.ss")) diff --git a/collects/scribblings/reference/read.scrbl b/collects/scribblings/reference/read.scrbl index a13f7a143c..71e6c1a8ac 100644 --- a/collects/scribblings/reference/read.scrbl +++ b/collects/scribblings/reference/read.scrbl @@ -107,7 +107,7 @@ See @secref["readtables"] for an extended example that uses @defproc[(read-language [in input-port? (current-input-port)] [fail-thunk (-> any) (lambda () (error ...))]) - (any/c . -> . any)]{ + (any/c any/c . -> . any)]{ Reads @scheme[in] in the same way as @scheme[read], but stopping as soon as a @tech{reader language} (or its absence) is determined. @@ -119,16 +119,16 @@ a @schemeidfont{read} or @schemeidfont{read-syntax} form as @scheme[read] and @scheme[read-syntax] do, @scheme[read-language] dispatches to a @schemeidfont{get-info} function (if any) exported by the same module. The result of the @schemeidfont{get-info} function is -the result of @scheme[read-language] if it is a function of one -argument; if @schemeidfont{get-info} produces any other kind of +the result of @scheme[read-language] if it is a function of two +arguments; if @schemeidfont{get-info} produces any other kind of result, the @exnraise[exn:fail:contract]. The function produced by @schemeidfont{get-info} reflects information -about the expected syntax of the input stream. The argument to the +about the expected syntax of the input stream. The first argument to the function serves as a key on such information; acceptable keys and the interpretation of results is up to external tools, such as DrScheme. If no information is available for a given key, the result should be -@scheme[#f]. +the second argument. The @schemeidfont{get-info} function itself is applied to five arguments: the input port being read, the module path from which the @@ -138,7 +138,8 @@ integer or @scheme[#f]), and position (positive exact integer or @scheme[#f]) of the start of the @litchar{#lang} or @litchar{#!} form. The @schemeidfont{get-info} function may further read from the given input port to determine its result, but it should read no -further than necessary. +further than necessary. The @schemeidfont{get-info} function should +not read from the port after returning a function. If @scheme[in] starts with a @tech{reader language} specification but the relevant module does not export @schemeidfont{get-info} (but @@ -146,8 +147,13 @@ perhaps does export @schemeidfont{read} and @schemeidfont{read-syntax}), then the result of @scheme[read-language] is @scheme[#f]. -If @scheme[in] does not specify a @tech{reader language}, then -@scheme[fail-thunk] is called. The default @scheme[fail-thunk] raises +If @scheme[in] has a @litchar{#lang} or @litchar{#!} specification, +but parsing and resolving the specification raises an exception, the +exception is propagated by @scheme[read-language]. + +If @scheme[in] does not specify a @tech{reader language} with +@litchar{#lang} or @litchar{#!}, then @scheme[fail-thunk] is +called. The default @scheme[fail-thunk] raises @scheme[exn:fail:contract].} diff --git a/collects/syntax-color/module-lexer.ss b/collects/syntax-color/module-lexer.ss index 9877b5f0a1..9d476f48d5 100644 --- a/collects/syntax-color/module-lexer.ss +++ b/collects/syntax-color/module-lexer.ss @@ -36,7 +36,7 @@ start-pos end-pos 0 - (or (let ([v (get-info 'color-lexer)]) + (or (let ([v (get-info 'color-lexer #f)]) (and v (if (procedure-arity-includes? v 3) (cons v #f) diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index b44ec447fa..ad3f13e394 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -50,6 +50,8 @@ (err "must specify either both #:read and #:read-syntax, or none")) (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) + ;; FIXME: a lot of the generated code is constant and should be lifted + ;; out of the template: (quasisyntax/loc stx (#%module-begin #,@body @@ -112,24 +114,24 @@ (define (get-info-getter props) (define lang (car props)) (define data (cadr props)) - (define (default-info what) + (define (default-info what defval) (case what [(module-language) (car props)] ;; ... more? - [else #f])) + [else defval])) (define info (let* ([#, lang] ;\ visible in [#, data] ;/ user-code [info #,~info]) - (if (or (not info) (and (procedure? info) (ar? info 2))) + (if (or (not info) (and (procedure? info) (ar? info 3))) info (raise-type-error 'syntax/module-reader - "info procedure of 1 or 0 arguments" info)))) - (define (language-info what) + "info procedure of 3 arguments" info)))) + (define (language-info what defval) (if info - (let ([r (info what default-info)]) - (if (eq? r default-info) (default-info what) r)) - (default-info what))) + (let ([r (info what defval default-info)]) + (if (eq? r default-info) (default-info what defval) r)) + (default-info what defval))) language-info)))) (syntax-case stx () [(_ lang body ...) @@ -206,7 +208,7 @@ (define (-get-info inp mod line col pos) (let ([r (get inp 'get-info (object-name inp) line col pos (lambda (spec) (lambda () (lambda (inp mod line col pos) - (lambda (tag) #f)))))]) + (lambda (tag defval) defval)))))]) (convert-get-info (r inp mod line col pos)))) (define (read-fn in read-sym args src mod line col pos convert) diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl index 905864fb3c..378f19af64 100644 --- a/collects/syntax/scribblings/module-reader.scrbl +++ b/collects/syntax/scribblings/module-reader.scrbl @@ -76,10 +76,11 @@ using: Similarly, the @scheme[#:info] keyword supplies a procedure to be used by a @scheme[get-info] export (see @scheme[read-language]). The -procedure produced by @scheme[info-expr] should consume two arguments: -a key symbol and a default info-getting procedure (to be called with -the key for default handling). If @scheme[#:info] is not supplied, the -default info-getting procedure is used. +procedure produced by @scheme[info-expr] should consume three +arguments: a key value, a default result, and a default info-getting +procedure (to be called with the key and default result for default +handling). If @scheme[#:info] is not supplied, the default +info-getting procedure is used. You can also use the (optional) module @scheme[body] forms to provide more definitions that might be needed to implement your reader functions. diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 99d650f7ea..8bc08a6bf7 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -5657,8 +5657,8 @@ static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, Re if (get_info) { a[0] = v; - if (!scheme_check_proc_arity(NULL, 1, 0, 1, a)) { - scheme_wrong_type("read-language", "procedure (arity 1)", -1, -1, a); + if (!scheme_check_proc_arity(NULL, 2, 0, 1, a)) { + scheme_wrong_type("read-language", "procedure (arity 2)", -1, -1, a); } }