diff options
Diffstat (limited to 'geiser/evaluation.scm')
-rw-r--r-- | geiser/evaluation.scm | 144 |
1 files changed, 0 insertions, 144 deletions
diff --git a/geiser/evaluation.scm b/geiser/evaluation.scm deleted file mode 100644 index bdbcdd8..0000000 --- a/geiser/evaluation.scm +++ /dev/null @@ -1,144 +0,0 @@ -;;; evaluation.scm -- evaluation, compilation and macro-expansion - -;; Copyright (C) 2009, 2010, 2011, 2013, 2015 Jose Antonio Ortega Ruiz - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the Modified BSD License. You should -;; have received a copy of the license along with this program. If -;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. - -;; Start date: Mon Mar 02, 2009 02:46 - -(cond-expand - (guile-2.2 - (define-module (geiser evaluation) - #:export (ge:compile - ge:eval - ge:macroexpand - ge:compile-file - ge:load-file - ge:set-warnings - ge:add-to-load-path) - #:use-module (geiser modules) - #:use-module (srfi srfi-1) - #:use-module (language tree-il) - #:use-module (system base compile) - #:use-module (system base message) - #:use-module (system base pmatch) - #:use-module (system vm program) - #:use-module (ice-9 pretty-print) - #:use-module (system vm loader))) - (else - (define-module (geiser evaluation) - #:export (ge:compile - ge:eval - ge:macroexpand - ge:compile-file - ge:load-file - ge:set-warnings - ge:add-to-load-path) - #:use-module (geiser modules) - #:use-module (srfi srfi-1) - #:use-module (language tree-il) - #:use-module (system base compile) - #:use-module (system base message) - #:use-module (system base pmatch) - #:use-module (system vm program) - #:use-module (ice-9 pretty-print)))) - - -(define compile-opts '()) -(define compile-file-opts '()) - -(define default-warnings '(arity-mismatch unbound-variable format)) -(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 '()))) - (else '()))) - (fwarns (if (memq 'unused-variable warns) - (cons 'unused-toplevel warns) - warns))) - (set! compile-opts (list #:warnings warns)) - (set! compile-file-opts (list #:warnings fwarns)))) - -(ge:set-warnings 'none) - -(define (call-with-result thunk) - (letrec* ((result #f) - (output - (with-output-to-string - (lambda () - (with-fluids ((*current-warning-port* (current-output-port)) - (*current-warning-prefix* "")) - (with-error-to-port (current-output-port) - (lambda () (set! result - (map object->string (thunk)))))))))) - (write `((result ,@result) (output . ,output))) - (newline))) - -(define (ge:compile form module) - (compile* form module compile-opts)) - -(define (compile* form module-name opts) - (let* ((module (or (find-module module-name) (current-module))) - (ev (lambda () - (call-with-values - (lambda () - (let* ((to (cond-expand (guile-2.2 'bytecode) - (else 'objcode))) - (cf (cond-expand (guile-2.2 load-thunk-from-memory) - (else make-program))) - (o (compile form - #:to to - #:env module - #:opts opts)) - (thunk (cf o))) - (start-stack 'geiser-evaluation-stack - (eval `(,thunk) module)))) - (lambda vs vs))))) - (call-with-result ev))) - -(define (ge:eval form module-name) - (let* ((module (or (find-module module-name) (current-module))) - (ev (lambda () - (call-with-values - (lambda () (eval form module)) - (lambda vs vs))))) - (call-with-result ev))) - -(define (ge:compile-file path) - (call-with-result - (lambda () - (let ((cr (compile-file path - #:canonicalization 'absolute - #:opts compile-file-opts))) - (and cr - (list (object->string (save-module-excursion - (lambda () (load-compiled cr)))))))))) - -(define ge:load-file ge:compile-file) - -(define (ge:macroexpand form . all) - (let ((all (and (not (null? all)) (car all)))) - (with-output-to-string - (lambda () - (pretty-print (tree-il->scheme (macroexpand form))))))) - -(define (add-to-list lst dir) - (and (not (member dir lst)))) - -(define (ge:add-to-load-path dir) - (and (file-is-directory? dir) - (let ((in-lp (member dir %load-path)) - (in-clp (member dir %load-compiled-path))) - (when (not in-lp) - (set! %load-path (cons dir %load-path))) - (when (not in-clp) - (set! %load-compiled-path (cons dir %load-compiled-path))) - (or in-lp in-clp)))) |