diff options
Diffstat (limited to 'scheme')
| -rw-r--r-- | scheme/guile/geiser/emacs.scm | 16 | ||||
| -rw-r--r-- | scheme/guile/geiser/evaluation.scm | 40 |
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)))))))))) |