summaryrefslogtreecommitdiff
path: root/scheme/guile/geiser
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
commit9e072c67041be2a9968d153ab6a6de3c047bc0f0 (patch)
treec89f32f6f160f726d2fd3e01637d880cb4cb9c1f /scheme/guile/geiser
parent9ecfebdfd5d3361c643c2b16b9fb7771122b0e82 (diff)
downloadgeiser-chez-9e072c67041be2a9968d153ab6a6de3c047bc0f0.tar.gz
geiser-chez-9e072c67041be2a9968d153ab6a6de3c047bc0f0.tar.bz2
Guile: configurable warning level
Diffstat (limited to 'scheme/guile/geiser')
-rw-r--r--scheme/guile/geiser/emacs.scm16
-rw-r--r--scheme/guile/geiser/evaluation.scm40
2 files changed, 42 insertions, 14 deletions
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index 3b6f49c..af1a052 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -10,9 +10,7 @@
;; Start date: Sun Feb 08, 2009 18:39
(define-module (geiser emacs)
- #:re-export (ge:eval
- ge:compile
- ge:macroexpand
+ #:re-export (ge:macroexpand
ge:compile-file
ge:load-file
ge:autodoc
@@ -26,8 +24,10 @@
ge:callers
ge:callees
ge:find-file)
- #:export (ge:no-values)
- #:export (ge:newline)
+ #:export (ge:compile
+ ge:no-values
+ ge:newline)
+ #:use-module (ice-9 match)
#:use-module (geiser evaluation)
#:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:))
#:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:))
@@ -37,4 +37,10 @@
(define (ge:no-values) (values))
(define ge:newline newline)
+(define (ge:compile form mod)
+ (match form
+ (`((@ (geiser emacs) . ,_) . ,_) (compile/no-warns form mod))
+ (_ (compile/warns form mod))))
+
+
;;; emacs.scm ends here
diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm
index aba0cfe..6b8df8f 100644
--- a/scheme/guile/geiser/evaluation.scm
+++ b/scheme/guile/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))))))))))