sandbox Scribble evaluations; fix rational exact->inexact loss of precision
svn: r8238 original commit: f3cb86dc1ac569297d67573dc73b7f5e3859656a
This commit is contained in:
Matthew Flatt
parent
ee85417518
commit
926ff4fbb0
|
|
@ -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
|
||||
eval-example-string
|
||||
|
||||
make-base-eval
|
||||
|
||||
scribble-eval-handler)
|
||||
|
||||
(define current-int-namespace (make-parameter (current-namespace)))
|
||||
(define scribble-eval-handler (make-parameter (lambda (c? x) (eval x))))
|
||||
(define scribble-eval-handler (make-parameter
|
||||
(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)]
|
||||
[o2 (open-output-string)])
|
||||
(parameterize ([current-output-port o]
|
||||
[current-error-port o2])
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(list (exn-message e)
|
||||
(get-output-string o)
|
||||
(get-output-string o2)))])
|
||||
(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)))))]))
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(list (exn-message e)
|
||||
(get-output ev)
|
||||
(get-error-output ev)))])
|
||||
(list (let ([v (do-plain-eval ev s #t)])
|
||||
(make-reader-graph (copy-value v (make-hash-table))))
|
||||
(get-output ev)
|
||||
(get-error-output ev)))]))
|
||||
|
||||
(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)
|
||||
[((code:comment . _) . rest)
|
||||
(strip-comments #'rest)]
|
||||
[(a . b)
|
||||
(cond
|
||||
[(syntax? stx)
|
||||
(datum->syntax stx
|
||||
(cons (strip-comments #'a)
|
||||
(strip-comments #'b))
|
||||
(strip-comments (syntax-e stx))
|
||||
stx
|
||||
stx
|
||||
stx)]
|
||||
[code:blank #'(void)]
|
||||
[else stx]))
|
||||
|
||||
[(pair? 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?)
|
||||
(parameterize ([current-namespace (current-int-namespace)])
|
||||
(call-with-values (lambda ()
|
||||
((scribble-eval-handler)
|
||||
catching-exns?
|
||||
(let ([s (strip-comments s)])
|
||||
(define (make-base-eval)
|
||||
(parameterize ([sandbox-security-guard (current-security-guard)]
|
||||
[sandbox-output 'string]
|
||||
[sandbox-error-output 'string]
|
||||
[sandbox-eval-limits #f]
|
||||
[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]))))
|
||||
list)))
|
||||
[_else s])
|
||||
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
|
||||
(begin (parameterize ([current-command-line-arguments #()])
|
||||
(do-plain-eval (quote-syntax e) #f))
|
||||
""))]))
|
||||
[(_ #:eval ev e) (do-interaction-eval ev (quote-expr e))]
|
||||
[(_ e) (do-interaction-eval #f (quote-expr e))]))
|
||||
|
||||
|
||||
(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
|
||||
(parameterize ([current-command-line-arguments #()])
|
||||
(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)))
|
||||
[(_ #:eval ev e) (do-interaction-eval-show ev (quote-expr e))]
|
||||
[(_ e) (do-interaction-eval-show #f (quote-expr e))]))
|
||||
|
||||
(define-syntax schemeinput*
|
||||
(syntax-rules (eval-example-string eval:alts code:comment)
|
||||
[(_ (eval-example-string s))
|
||||
(make-paragraph
|
||||
(list
|
||||
(hspace 2)
|
||||
(tt "> ")
|
||||
(span-class "schemevalue" (schemefont s))))]
|
||||
(syntax-rules (eval:alts code:comment)
|
||||
[(_ (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
|
||||
(list (schemeinput* e) ...)
|
||||
(map do-eval (list (quote-syntax e) ...)))]))
|
||||
(titled-interaction #:eval (make-base-eval) t schemeinput* 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
|
||||
(begin (interaction-eval e) ...
|
||||
(schemeblock e ...)))]))
|
||||
(schemeblock+eval #:eval (make-base-eval) 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
|
||||
(begin (interaction-eval e) ...
|
||||
(schememod name e ...)))]))
|
||||
(schememod+eval #:eval (make-base-eval) name e ...)]))
|
||||
|
||||
(define-syntax def+int
|
||||
(syntax-rules ()
|
||||
[(_ def e ...)
|
||||
(make-splice (list (schemeblock+eval def)
|
||||
(interaction e ...)))]))
|
||||
[(_ #:eval ev def e ...)
|
||||
(let ([eva ev])
|
||||
(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 ...)
|
||||
(interaction e ...)))]))
|
||||
(defs+int #:eval (make-base-eval) [def ...] 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 ...)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scribble/doc
|
||||
@require[scribble/manual]
|
||||
@require["utils.ss"]
|
||||
@(require scribble/manual
|
||||
"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
|
||||
that the result for each input @scheme[datum] is shown on the next
|
||||
line. The result is determined by evaluating the syntax-quoted form of
|
||||
the @scheme[datum].
|
||||
@defform*[[(interaction datum ...)
|
||||
(interaction #:eval eval-expr 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
|
||||
@scheme[datum] and produces an element represeting the printed form of
|
||||
the result.}
|
||||
@defform*[[(interaction-eval datum)
|
||||
(interaction-eval #:eval eval-expr datum)]]{
|
||||
|
||||
@defform[(schemeblock+eval datum ...)]{Combines @scheme[schemeblock]
|
||||
and @scheme[interaction-eval].}
|
||||
Like @scheme[interaction], evaluates the @scheme[quote]d form of
|
||||
@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
|
||||
@scheme[interaction], except the the @scheme[defn-datum] is typeset as
|
||||
for @scheme[schemeblock] (i.e., no prompt) with a line of space
|
||||
between the definition and the interactions.}
|
||||
@defform*[[(interaction-eval-show datum)
|
||||
(interaction-eval-show #:eval eval-expr datum)]]{
|
||||
|
||||
@defform[(defs+int (defn-datum ...) expr-datum ...)]{Like
|
||||
@scheme[def+int], but for multiple leading definitions.}
|
||||
Like @scheme[interaction-eval], but produces an element representing
|
||||
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
|
||||
definition using @scheme[define] among the @scheme[datum]s is typeset
|
||||
without a prompt, and with space after it.}
|
||||
@defform*[[(schemeblock+eval datum ...)
|
||||
(schemeblock+eval #:eval eval-expr datum ...)]]{
|
||||
|
||||
@defthing[current-int-namespace parameter?]{A parameter to hold the
|
||||
namespace used by @scheme[interaction], etc.}
|
||||
Combines @scheme[schemeblock] and @scheme[interaction-eval].}
|
||||
|
||||
|
||||
@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.}
|
||||
|
|
|
|||
|
|
@ -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 ...)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user