summaryrefslogtreecommitdiff
path: root/geiser/evaluation.scm
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2010-09-07 05:58:22 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2010-09-07 05:58:22 +0200
commit75634733f322e856c8608c1adff0fb7df9edb06d (patch)
treebd4fbcc4260a0be0dfbc12583c1320697951a48b /geiser/evaluation.scm
parent3a80209b93ef0b7f9bad0fbce2d976c6b5b89e5f (diff)
downloadgeiser-guile-75634733f322e856c8608c1adff0fb7df9edb06d.tar.gz
geiser-guile-75634733f322e856c8608c1adff0fb7df9edb06d.tar.bz2
Guile: configurable warning level
Diffstat (limited to 'geiser/evaluation.scm')
-rw-r--r--geiser/evaluation.scm40
1 files changed, 31 insertions, 9 deletions
diff --git a/geiser/evaluation.scm b/geiser/evaluation.scm
index aba0cfe..6b8df8f 100644
--- a/geiser/evaluation.scm
+++ b/geiser/evaluation.scm
@@ -10,11 +10,12 @@
;; Start date: Mon Mar 02, 2009 02:46
(define-module (geiser evaluation)
- #:export (ge:eval
- ge:compile
+ #:export (compile/warns
+ compile/no-warns
ge:macroexpand
ge:compile-file
- ge:load-file)
+ ge:load-file
+ ge:set-warnings)
#:use-module (geiser modules)
#:use-module (srfi srfi-1)
#:use-module (language tree-il)
@@ -39,7 +40,26 @@
(write (list (cons 'result result) (cons 'output output)))
(newline))
-(define compile-opts '(#:warnings (arity-mismatch unbound-variable)))
+(define compile-opts (make-fluid))
+(define compile-file-opts (make-fluid))
+
+(define default-warnings '(arity-mismatch unbound-variable))
+(define verbose-warnings `(unused-variable ,@default-warnings))
+
+(define (ge:set-warnings wl)
+ (let* ((warns (cond ((list? wl) wl)
+ ((symbol? wl) (case wl
+ ((none nil null) '())
+ ((medium default) default-warnings)
+ ((high verbose) verbose-warnings)))
+ (else '())))
+ (fwarns (if (memq 'unused-variable warns)
+ (cons 'unused-toplevel warns)
+ warns)))
+ (fluid-set! compile-opts (list #:warnings warns))
+ (fluid-set! compile-file-opts (list #:warnings fwarns))))
+
+(ge:set-warnings 'none)
(define (call-with-result thunk)
(letrec* ((result #f)
@@ -50,7 +70,11 @@
(set! result (thunk)))))))
(write-result result output)))
-(define (ge:compile form module-name)
+(define (compile/no-warns form module)
+ (with-fluids ((compile-opts '()))
+ (compile/warns form module)))
+
+(define (compile/warns form module-name)
(let* ((module (or (find-module module-name) (current-module)))
(ev (lambda ()
(call-with-values
@@ -58,21 +82,19 @@
(let* ((o (compile form
#:to 'objcode
#:env module
- #:opts compile-opts))
+ #:opts (fluid-ref compile-opts)))
(thunk (make-program o)))
(start-stack 'geiser-evaluation-stack
(eval `(,thunk) module))))
(lambda vs (map object->string vs))))))
(call-with-result ev)))
-(define ge:eval ge:compile)
-
(define (ge:compile-file path)
(call-with-result
(lambda ()
(let ((cr (compile-file path
#:canonicalization 'absolute
- #:opts compile-opts)))
+ #:opts (fluid-ref compile-file-opts))))
(and cr
(list (object->string (save-module-excursion
(lambda () (load-compiled cr))))))))))