source: project/stream-wiki/trunk/extensions/scheme.scm @ 6549

Last change on this file since 6549 was 6549, checked in by azul, 12 years ago

Wrap the sandbox's eval in a condition-case for better error handling.

File size: 1.7 KB
Line 
1(use syntax-case)
2
3(define-syntax environment
4  (syntax-rules ()
5    ((environment original ((name expr) ...))
6     (lambda (op)
7       (case op
8         ((name) expr)
9         ...
10         (else (original op)))))
11    ((environment ((name expr) ...))
12     (environment (lambda (op)
13                    (warning "unbound variable (dynamic environment)" op)
14                    (if #f #f))
15                  ((name expr) ...)))))
16
17(define-syntax environment-get
18  (syntax-rules ()
19    ((environment-get env sym) (env 'sym))))
20
21(define-syntax let-from-environment
22  (syntax-rules ()
23    ((let-from-environment env (sym ...) body ...)
24     (let ((sym (environment-get env sym)) ...) body ...))))
25
26(define-syntax environment-capture
27  (syntax-rules ()
28    ((environment-capture env (sym ...))
29     (environment env ((sym sym) ...)))
30    ((environment-capture (sym ...))
31     (environment ((sym sym) ...)))))
32
33(define (tag-scheme env)
34  (let-from-environment env (text)
35    (let ((env (make-safe-environment parent: default-safe-environment extendable: #t)))
36      (safe-environment-set! env 'display display)
37      (safe-environment-set! env 'format format)
38      (safe-environment-set! env 'newline newline)
39      (with-output-to-stream
40        (lambda ()
41          (with-input-from-string
42            (stream->string text)
43            (lambda ()
44              (let loop ((expr (read)))
45                (unless (eof-object? expr)
46                  (condition-case
47                    (safe-eval expr environment: env fuel: 100000 allocation-limit: 100000)
48                    (e (exn) (format #t "Error evaluating expresion: ~A" expr)))
49                  (loop (read)))))))))))
50
51(set! *extensions*
52  `((scheme (code-span ,tag-scheme))))
Note: See TracBrowser for help on using the repository browser.