summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--elisp/geiser-guile.el34
-rw-r--r--scheme/guile/geiser/emacs.scm16
-rw-r--r--scheme/guile/geiser/evaluation.scm40
3 files changed, 75 insertions, 15 deletions
diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el
index 15c40cc..55116d3 100644
--- a/elisp/geiser-guile.el
+++ b/elisp/geiser-guile.el
@@ -63,6 +63,29 @@ If `t', Geiser will use `next-error' to jump to the error's location."
:type 'boolean
:group 'geiser-guile)
+(geiser-custom--defcustom geiser-guile-warning-level 'medium
+ "Verbosity of the warnings reported by Guile.
+
+You can choose either one of the predefined warning sets, or
+provide a list of symbols identifying the ones you want. Possible
+choices are arity-mismatch, unbound-variable, unused-variable and
+unused-toplevel. Unrecognised symbols are ignored.
+
+The predefined levels are:
+
+ - Medium: arity-mismatch, unbound-variable
+ - High: arity-mismatch, unbound-variable, unused-variable
+ - None: no warnings
+
+Changes to the value of this variable will automatically take
+effect on new REPLs. For existing ones, use the command
+\\[geiser-guile-update-warning-level]."
+ :type '(choice (const :tag "Medium (arity and unbound vars)" medium)
+ (const :tag "High (also unused vars)" high)
+ (const :tag "No warnings" none)
+ (repeat :tag "Custom" symbol))
+ :group 'geiser-guile)
+
;;; REPL support:
@@ -189,6 +212,14 @@ This function uses `geiser-guile-init-file' if it exists."
;;; REPL startup
+(defun geiser-guile-update-warning-level ()
+ "Update the warning level used by the REPL.
+The new level is set using the value of `geiser-guile-warning-level'."
+ (interactive)
+ (let ((code `(:eval (ge:set-warnings ',geiser-guile-warning-level)
+ (geiser evaluation))))
+ (geiser-eval--send/result code)))
+
(defun geiser-guile--startup ()
(set (make-local-variable 'compilation-error-regexp-alist)
`((,geiser-guile--path-rx geiser-guile--resolve-file-x)
@@ -197,7 +228,8 @@ This function uses `geiser-guile-init-file' if it exists."
(compilation-setup t)
(font-lock-add-keywords nil
`((,geiser-guile--path-rx 1
- compilation-error-face))))
+ compilation-error-face)))
+ (geiser-guile-update-warning-level))
;;; Implementation definition:
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))))))))))