diff options
| -rw-r--r-- | elisp/geiser-guile.el | 34 | ||||
| -rw-r--r-- | scheme/guile/geiser/emacs.scm | 16 | ||||
| -rw-r--r-- | scheme/guile/geiser/evaluation.scm | 40 |
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)))))))))) |