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

@@ -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)]))))))

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)))))))
 

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"))
 

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"))

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"))

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
+the result of @scheme[read-language] if it is a function of two
-argument; if @schemeidfont{get-info} produces any other kind of
+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
+If @scheme[in] has a @litchar{#lang} or @litchar{#!} specification,
-@scheme[fail-thunk] is called. The default @scheme[fail-thunk] raises
+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].}
 
 

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)

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-id> lang] ;\ visible in
                     [#,<data-id> 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))))
+                                     "info procedure of 3 arguments" info))))
-           (define (language-info what)
+           (define (language-info what defval)
              (if info
-                 (let ([r (info what default-info)])
+                 (let ([r (info what defval default-info)])
-                   (if (eq? r default-info) (default-info what) r))
+                   (if (eq? r default-info) (default-info what defval) r))
-                 (default-info what)))
+                 (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)

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:
+procedure produced by @scheme[info-expr] should consume three
-a key symbol and a default info-getting procedure (to be called with
+arguments: a key value, a default result, and a default info-getting
-the key for default handling). If @scheme[#:info] is not supplied, the
+procedure (to be called with the key and default result for default
-default info-getting procedure is used.
+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.

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)) {
+    if (!scheme_check_proc_arity(NULL, 2, 0, 1, a)) {
-      scheme_wrong_type("read-language", "procedure (arity 1)", -1, -1, a);
+      scheme_wrong_type("read-language", "procedure (arity 2)", -1, -1, a);
     }
   }