summaryrefslogtreecommitdiff
path: root/geiser/evaluation.scm
diff options
context:
space:
mode:
Diffstat (limited to 'geiser/evaluation.scm')
-rw-r--r--geiser/evaluation.scm144
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))))