suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

move racket/draw overview to the Guide and expand it

Browse Source 
--- plus some minor collateral API improvements

original commit: 8b3165d55b85cffbe3ad28be6d8bd4c218d21529
This commit is contained in:
Matthew Flatt 2010-11-27 15:53:49 -07:00
parent 90ded4003f
commit 8f876ea446
1 changed files with 43 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
collects/scribble/eval.rkt
View File

@ -145,50 +145,56 @@
[(syntax? s) (loop (syntax-e s) ops)] [(syntax? s) (loop (syntax-e s) ops)]
[else (loop ((car ops) s) (cdr ops))]))) [else (loop ((car ops) s) (cdr ops))])))
(define ((do-eval ev) s) (define (extract-to-evaluate s)
(let loop ([s s][expect #f]) (let loop ([s s][expect #f])
(syntax-case s (code:comment eval:alts eval:check) (syntax-case s (code:comment eval:alts eval:check)
[(code:line v (code:comment . rest)) [(code:line v (code:comment . rest))
(loop (extract s cdr car) expect)] (loop (extract s cdr car) expect)]
[(code:comment . rest) [(code:comment . rest)
(list (list (void)) "" "")] (values #f expect)]
[(eval:alts p e) [(eval:alts p e)
(loop (extract s cdr cdr car) expect)] (loop (extract s cdr cdr car) expect)]
[(eval:check e expect) [(eval:check e expect)
(loop (extract s cdr car) (loop (extract s cdr car)
(list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))] (list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))]
[else [else
(let ([r (with-handlers ([(lambda (x) (values s expect)])))
(not (exn:break? x)))
(lambda (e) (define ((do-eval ev) s)
(list (if (exn? e) (let-values ([(s expect) (extract-to-evaluate s)])
(exn-message e) (if s
(format "uncaught exception: ~s" e)) (let ([r (with-handlers ([(lambda (x)
(get-output ev) (not (exn:break? x)))
(get-error-output ev)))]) (lambda (e)
(list (let ([v (do-plain-eval ev s #t)]) (list (if (exn? e)
(if (call-in-sandbox-context (exn-message e)
ev (format "uncaught exception: ~s" e))
(let ([cp (current-print)]) (get-output ev)
(lambda () (get-error-output ev)))])
(and (eq? (current-print) cp) (list (let ([v (do-plain-eval ev s #t)])
(print-as-expression))))) (if (call-in-sandbox-context
(make-reader-graph (copy-value v (make-hasheq)))
(box
(call-in-sandbox-context
ev ev
(lambda () (let ([cp (current-print)])
(let ([s (open-output-string)]) (lambda ()
(parameterize ([current-output-port s]) (and (eq? (current-print) cp)
(map (current-print) v)) (print-as-expression)))))
(get-output-string s))))))) (make-reader-graph (copy-value v (make-hasheq)))
(get-output ev) (box
(get-error-output ev)))]) (call-in-sandbox-context
(when expect ev
(let ([expect (do-plain-eval ev (car expect) #t)]) (lambda ()
(unless (equal? (car r) expect) (let ([s (open-output-string)])
(raise-syntax-error 'eval "example result check failed" s)))) (parameterize ([current-output-port s])
r)]))) (map (current-print) v))
(get-output-string s)))))))
(get-output ev)
(get-error-output ev)))])
(when expect
(let ([expect (do-plain-eval ev (car expect) #t)])
(unless (equal? (car r) expect)
(raise-syntax-error 'eval "example result check failed" s))))
r)
(values (list (list (void)) "" "")))))
(define (install ht v v2) (define (install ht v v2)
@ -337,9 +343,11 @@
(define-syntax-rule (quote-expr e) 'e) (define-syntax-rule (quote-expr e) 'e)
(define (do-interaction-eval ev e) (define (do-interaction-eval ev e)
(parameterize ([current-command-line-arguments #()]) (let-values ([(e expect) (extract-to-evaluate e)])
(do-plain-eval (or ev (make-base-eval)) e #f)) (when e
"") (parameterize ([current-command-line-arguments #()])
(do-plain-eval (or ev (make-base-eval)) e #f)))
""))
(define-syntax interaction-eval (define-syntax interaction-eval
(syntax-rules () (syntax-rules ()