sandbox Scribble evaluations; fix rational exact->inexact loss of precision

svn: r8238

original commit: f3cb86dc1ac569297d67573dc73b7f5e3859656a

collects/scribble/eval.ss

@@ -5,6 +5,7 @@
            "scheme.ss"
            "decode.ss"
            scheme/file
+           scheme/sandbox
            mzlib/string
            (for-syntax scheme/base))
 
@@ -20,14 +21,14 @@
            defexamples
            defexamples*
            as-examples
-
+           
-           current-int-namespace
+           make-base-eval
-           eval-example-string
 
            scribble-eval-handler)
 
-  (define current-int-namespace (make-parameter (current-namespace)))
+  (define scribble-eval-handler (make-parameter 
-  (define scribble-eval-handler (make-parameter (lambda (c? x) (eval x))))
+                                 (lambda (ev c? x)
+                                   (ev x))))
 
   (define image-counter 0)
 
@@ -123,27 +124,23 @@
                    (cdr val-list+outputs)
                     #f)))))))
 
-  (define (do-eval s)
+  (define ((do-eval ev) s)
     (syntax-case s (code:comment eval:alts)
      [(code:line v (code:comment . rest))
-      (do-eval #'v)]
+      ((do-eval ev) #'v)]
      [(code:comment . rest)
       (list (list (void)) "" "")]
      [(eval:alts p e)
-      (do-eval #'e)]
+      ((do-eval ev) #'e)]
      [else
-      (let ([o (open-output-string)]
+      (with-handlers ([exn? (lambda (e)
-            [o2 (open-output-string)])
+                              (list (exn-message e)
-        (parameterize ([current-output-port o]
+                                    (get-output ev)
-                       [current-error-port o2])
+                                    (get-error-output ev)))])
-          (with-handlers ([exn? (lambda (e)
+        (list (let ([v (do-plain-eval ev s #t)])
-                                  (list (exn-message e)
+                (make-reader-graph (copy-value v (make-hash-table))))
-                                        (get-output-string o)
+              (get-output ev)
-                                        (get-output-string o2)))])
+              (get-error-output ev)))]))
-            (list (let ([v (do-plain-eval s #t)])
-                    (make-reader-graph (copy-value v (make-hash-table))))
-                  (get-output-string o)
-                  (get-output-string o2)))))]))
 
   (define (install ht v v2)
     (hash-table-put! ht v v2)
@@ -184,64 +181,78 @@
      [else v]))
             
   (define (strip-comments stx)
-    (syntax-case stx (code:comment code:blank)
+    (cond
-     [((code:comment . _) . rest)
+     [(syntax? stx)
-      (strip-comments #'rest)]
-     [(a . b)
       (datum->syntax stx
-                     (cons (strip-comments #'a)
+                     (strip-comments (syntax-e stx))
-                           (strip-comments #'b))
                      stx
                      stx
                      stx)]
-     [code:blank #'(void)]
+      [(pair? stx)
-     [else stx]))
+       (let ([a (car stx)]
-      
+             [comment? (lambda (a)
+                         (and (pair? a)
+                              (or (eq? (car a) 'code:comment)
+                                  (and (identifier? a)
+                                       (eq? (syntax-e (car a)) 'code:comment)))))])
+         (if (or (comment? a)
+                 (and (syntax? a) (comment? (syntax-e a))))
+             (strip-comments (cdr stx))
+             (cons (strip-comments a)
+                   (strip-comments (cdr stx)))))]
+      [(eq? stx 'code:blank) (void)]
+      [else stx]))
 
-  (define (do-plain-eval s catching-exns?)
+  (define (make-base-eval)
-    (parameterize ([current-namespace (current-int-namespace)])
+    (parameterize ([sandbox-security-guard (current-security-guard)]
-        (call-with-values (lambda () 
+                   [sandbox-output 'string]
-                            ((scribble-eval-handler) 
+                   [sandbox-error-output 'string]
-                             catching-exns? 
+                   [sandbox-eval-limits #f]
-                             (let ([s (strip-comments s)])
+                   [sandbox-make-inspector current-inspector])
+      (make-evaluator 'scheme/base)))
+      
+  (define (do-plain-eval ev s catching-exns?)
+    (call-with-values (lambda () 
+                        ((scribble-eval-handler) 
+                         ev
+                         catching-exns? 
+                         (let ([s (strip-comments s)])
+                           (if (syntax? s)
                                (syntax-case s (module)
                                  [(module . _rest)
                                   (syntax->datum s)]
-                                 [_else s]))))
+                                 [_else s])
-          list)))
+                               s))))
+      list))
+
+  (define-syntax-rule (quote-expr e) 'e)
+
+  (define (do-interaction-eval ev e)
+    (parameterize ([current-command-line-arguments #()])
+      (do-plain-eval (or ev (make-base-eval)) e #f))
+    "")
 
   (define-syntax interaction-eval
     (syntax-rules ()
-      [(_ e) (#%expression
+      [(_ #:eval ev e) (do-interaction-eval ev (quote-expr e))]
-              (begin (parameterize ([current-command-line-arguments #()])
+      [(_ e) (do-interaction-eval #f (quote-expr e))]))
-                       (do-plain-eval (quote-syntax e) #f))
-                     ""))]))
 
 
   (define (show-val v)
     (span-class "schemeresult"
                 (to-element/no-color v)))
 
+  (define (do-interaction-eval-show ev e)
+    (parameterize ([current-command-line-arguments #()])
+      (show-val (car (do-plain-eval (or ev (make-base-eval)) e #f)))))
+
   (define-syntax interaction-eval-show
     (syntax-rules ()
-      [(_ e) (#%expression
+      [(_ #:eval ev e) (do-interaction-eval-show ev (quote-expr e))]
-              (parameterize ([current-command-line-arguments #()])
+      [(_ e) (do-interaction-eval-show #f (quote-expr e))]))
-                (show-val (car (do-plain-eval (quote-syntax e) #f)))))]))
-
-  (define (eval-example-string s)
-    (eval (read (open-input-string s))))
-
-  (parameterize ([current-namespace (current-int-namespace)])
-    (eval `(define eval-example-string ,eval-example-string)))
 
   (define-syntax schemeinput*
-    (syntax-rules (eval-example-string eval:alts code:comment)
+    (syntax-rules (eval:alts code:comment)
-      [(_ (eval-example-string s))
-       (make-paragraph
-        (list
-         (hspace 2)
-         (tt "> ")
-         (span-class "schemevalue" (schemefont s))))]
       [(_ (code:comment . rest)) (schemeblock (code:comment . rest))]
       [(_ (eval:alts a b)) (schemeinput* a)]
       [(_ e) (schemeinput e)]))
@@ -266,61 +277,87 @@
       [(_ (code:line (define . rest) . rest2))
        (syntax-case stx ()
          [(_ e) #'(schemeblock+line e)])]
-      [(_ e) #'(schemeinput e)]))
+      [(_ e) #'(schemeinput* e)]))
+
+  (define (do-titled-interaction ev t shows evals)
+    (interleave t
+                shows
+                (map (do-eval ev) evals)))
 
   (define-syntax titled-interaction
     (syntax-rules ()
+      [(_ #:eval ev t schemeinput* e ...)
+       (do-titled-interaction ev t (list (schemeinput* e) ...) (list (quote-expr e) ...))]
       [(_ t schemeinput* e ...)
-       (interleave t
+       (titled-interaction #:eval (make-base-eval) t schemeinput* e ...)]))
-                   (list (schemeinput* e) ...)
-                   (map do-eval (list (quote-syntax e) ...)))]))
 
     (define-syntax interaction
       (syntax-rules ()
+        [(_ #:eval ev e ...) (titled-interaction #:eval ev #f schemeinput* e ...)]
         [(_ e ...) (titled-interaction #f schemeinput* e ...)]))
 
   (define-syntax schemeblock+eval
     (syntax-rules ()
+      [(_ #:eval ev e ...)
+       (let ([eva ev])
+         (#%expression
+          (begin (interaction-eval #:eval eva e) ...
+                 (schemeblock e ...))))]
       [(_ e ...)
-       (#%expression
+       (schemeblock+eval #:eval (make-base-eval) e ...)]))
-        (begin (interaction-eval e) ...
-               (schemeblock e ...)))]))
 
   (define-syntax schememod+eval
     (syntax-rules ()
+      [(_ #:eval ev name e ...)
+       (let ([eva ev])
+         (#%expression
+          (begin (interaction-eval #:eval eva e) ...
+                 (schememod name e ...))))]
       [(_ name e ...)
-       (#%expression
+       (schememod+eval #:eval (make-base-eval) name e ...)]))
-        (begin (interaction-eval e) ...
-               (schememod name e ...)))]))
 
   (define-syntax def+int
     (syntax-rules ()
-      [(_ def e ...)
+      [(_ #:eval ev def e ...)
-       (make-splice (list (schemeblock+eval def)
+       (let ([eva ev])
-                          (interaction e ...)))]))
+         (make-splice (list (schemeblock+eval #:eval eva def)
+                            (interaction #:eval eva e ...))))]
+      [(_ def e ...) 
+       (def+int #:eval (make-base-eval) def e ...)]))
 
   (define-syntax defs+int
     (syntax-rules ()
+      [(_ #:eval ev [def ...] e ...)
+       (let ([eva ev])
+         (make-splice (list (schemeblock+eval #:eval eva def ...)
+                            (interaction #:eval eva e ...))))]
       [(_ [def ...] e ...)
-       (make-splice (list (schemeblock+eval def ...)
+       (defs+int #:eval (make-base-eval) [def ...] e ...)]))
-                          (interaction e ...)))]))
 
   (define example-title
     (make-paragraph (list "Examples:")))
   (define-syntax examples
     (syntax-rules ()
+      [(_ #:eval ev e ...)
+       (titled-interaction #:eval ev example-title schemeinput* e ...)]
       [(_ e ...)
        (titled-interaction example-title schemeinput* e ...)]))
   (define-syntax examples*
     (syntax-rules ()
+      [(_ #:eval ev example-title e ...)
+       (titled-interaction #:eval ev example-title schemeinput* e ...)]
       [(_ example-title e ...)
        (titled-interaction example-title schemeinput* e ...)]))
   (define-syntax defexamples
     (syntax-rules ()
+      [(_ #:eval ev e ...)
+       (titled-interaction #:eval ev example-title schemedefinput* e ...)]
       [(_ e ...)
        (titled-interaction example-title schemedefinput* e ...)]))
   (define-syntax defexamples*
     (syntax-rules ()
+      [(_ #:eval ev example-title e ...)
+       (titled-interaction #:eval ev example-title schemedefinput* e ...)]
       [(_ example-title e ...)
        (titled-interaction example-title schemedefinput* e ...)]))
 

collects/scribblings/scribble/eval.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
-@require[scribble/manual]
+@(require scribble/manual
-@require["utils.ss"]
+          "utils.ss"
+          (for-label scheme/sandbox))
 
 @title[#:tag "eval"]{Evaluation and Examples}
 
@@ -9,10 +10,19 @@ utilities for evaluating code at document-build time and incorporating
 the results in the document, especially to show example uses of
 defined procedures and syntax.}
 
-@defform[(interaction datum ...)]{Like @scheme[schemeinput], except
+@defform*[[(interaction datum ...)
-that the result for each input @scheme[datum] is shown on the next
+           (interaction #:eval eval-expr datum ...)]]{
-line. The result is determined by evaluating the syntax-quoted form of
+
-the @scheme[datum].
+Like @scheme[schemeinput], except that the result for each input
+@scheme[datum] is shown on the next line. The result is determined by
+evaluating the @scheme[quote]d form of the @scheme[datum] using he
+evaluator produced by @scheme[eval-expr], if provided.
+
+The @scheme[eval-expr] must produce a sandbox evaluator via
+@scheme[make-evaluator] or @scheme[make-module-evaluator] with the
+@scheme[sandbox-output] and @scheme[sandbox-error-output] parameters
+set to @scheme['string]. If @scheme[eval] is not provided, an
+evaluator is created using @scheme[make-base-eval].
 
 Uses of @scheme[code:comment] and @schemeidfont{code:blank} are
 stipped from each @scheme[datum] before evaluation.
@@ -25,33 +35,73 @@ If a datum has the form @scheme[(eval:alts #,(svar show-datum) #,(svar
 eval-datum))], then @svar[show-datum] is typeset, while
 @svar[eval-datum] is evaluated.}
 
-@defform[(interaction-eval datum)]{Evaluates the syntax-quoted form of
-each @scheme[datum] via @scheme[do-eval] and returns the empty string.}
 
-@defform[(interaction-eval-show datum)]{Evaluates the syntax-quoted form of
+@defform*[[(interaction-eval datum)
-@scheme[datum] and produces an element represeting the printed form of
+           (interaction-eval #:eval eval-expr datum)]]{
-the result.}
 
-@defform[(schemeblock+eval datum ...)]{Combines @scheme[schemeblock]
+Like @scheme[interaction], evaluates the @scheme[quote]d form of
-and @scheme[interaction-eval].}
+@scheme[datum], but returns the empty string.}
 
-@defform[(schememod+eval name datum ...)]{Combines @scheme[schememod]
-and @scheme[interaction-eval].}
 
-@defform[(def+int defn-datum expr-datum ...)]{Like
+@defform*[[(interaction-eval-show datum)
-@scheme[interaction], except the the @scheme[defn-datum] is typeset as
+           (interaction-eval-show #:eval eval-expr datum)]]{
-for @scheme[schemeblock] (i.e., no prompt) with a line of space
-between the definition and the interactions.}
 
-@defform[(defs+int (defn-datum ...) expr-datum ...)]{Like
+Like @scheme[interaction-eval], but produces an element representing
-@scheme[def+int], but for multiple leading definitions.}
+the printed form of the evaluation result.}
 
-@defform[(examples datum ...)]{Like @scheme[interaction], but with an
-``Examples:'' label prefixed.}
 
-@defform[(defexamples datum ...)]{Like @scheme[examples], but each
+@defform*[[(schemeblock+eval datum ...)
-definition using @scheme[define] among the @scheme[datum]s is typeset
+           (schemeblock+eval #:eval eval-expr datum ...)]]{
-without a prompt, and with space after it.}
 
-@defthing[current-int-namespace parameter?]{A parameter to hold the
+Combines @scheme[schemeblock] and @scheme[interaction-eval].}
-namespace used by @scheme[interaction], etc.}
+
+
+@defform*[[(schememod+eval name datum ...)
+           (schememod+eval #:eval eval-expr name datum ...)]]{
+
+Combines @scheme[schememod] and @scheme[interaction-eval].}
+
+
+@defform*[[(def+int defn-datum expr-datum ...)
+           (def+int #:eval eval-expr defn-datum expr-datum ...)]]{
+
+Like @scheme[interaction], except the the @scheme[defn-datum] is
+typeset as for @scheme[schemeblock] (i.e., no prompt) and a line of
+space is inserted before the @scheme[expr-datum]s.}
+
+
+@defform*[[(defs+int (defn-datum ...) expr-datum ...)
+           (defs+int #:eval eval-expr (defn-datum ...) expr-datum ...)]]{
+
+Like @scheme[def+int], but for multiple leading definitions.}
+
+
+@defform*[[(examples datum ...)
+           (examples #:eval eval-expr datum ...)]]{
+
+Like @scheme[interaction], but with an ``Examples:'' label prefixed.}
+
+
+@defform*[[(defexamples datum ...)
+           (defexamples #:eval eval-expr datum ...)]]{
+
+Like @scheme[examples], but each definition using @scheme[define] or
+@scheme[define-struct] among the @scheme[datum]s is typeset without a
+prompt, and with line of space after it.}
+
+
+@defproc[(make-base-eval) (any/c . -> . any)]{
+
+Creates an evaluator using @scheme[(make-evaluator 'scheme/base)],
+setting sandbox parameters to disable limits, set the outputs to
+@scheme['string], and not add extra security guards.}
+
+
+@defparam[scribble-eval-handler handler 
+          ((any/c . -> . any) any/c boolean? . -> . any)]{
+
+A parameter that serves as a hook for evaluation. The evaluator to use
+is supplied as the first argument to the parameter's value, and the
+second argument is the form to evaluate. The last argument is
+@scheme[#t] if exceptions are being captured (to display exception
+results), @scheme[#f] otherwise.}

collects/scribblings/scribble/reader.scrbl

@@ -5,6 +5,9 @@
 @require["utils.ss"]
 @require[(for-syntax scheme/base)]
 
+@(define read-eval (make-base-eval))
+@interaction-eval[#:eval read-eval (require (for-syntax scheme/base))]
+
 @title[#:tag "reader"]{@"@"-Reader}
 
 The Scribble @"@"-reader is designed to be a convenient facility for
@@ -649,6 +652,7 @@ example, implicitly quoted keywords:
 
 @; FIXME: a bit of code duplication here
 @def+int[
+  #:eval read-eval 
   (define-syntax (foo stx)
     (let ([p (syntax-property stx 'scribble)])
       (syntax-case stx ()
@@ -687,6 +691,7 @@ an example of this.
 
 @; FIXME: a bit of code duplication here
 @def+int[
+  #:eval read-eval 
   (define-syntax (verb stx)
     (syntax-case stx ()
       [(_ cmd item ...)