scheme/guile/geiser/evaluation.scm

   1 ;;; evaluation.scm -- evaluation, compilation and macro-expansion
   2
   3 ;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Mon Mar 02, 2009 02:46
  11
  12 (define-module (geiser evaluation)
  13   #:export (ge:compile
  14             ge:eval
  15             ge:macroexpand
  16             ge:compile-file
  17             ge:load-file
  18             ge:set-warnings
  19             ge:add-to-load-path)
  20   #:use-module (geiser modules)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (language tree-il)
  23   #:use-module (system base compile)
  24   #:use-module (system base message)
  25   #:use-module (system base pmatch)
  26   #:use-module (system vm program)
  27   #:use-module (ice-9 pretty-print))
  28
  29
  30 (define compile-opts '())
  31 (define compile-file-opts '())
  32
  33 (define default-warnings '(arity-mismatch unbound-variable format))
  34 (define verbose-warnings `(unused-variable ,@default-warnings))
  35
  36 (define (ge:set-warnings wl)
  37   (let* ((warns (cond ((list? wl) wl)
  38                       ((symbol? wl) (case wl
  39                                       ((none nil null) '())
  40                                       ((medium default) default-warnings)
  41                                       ((high verbose) verbose-warnings)
  42                                       (else '())))
  43                       (else '())))
  44          (fwarns (if (memq 'unused-variable warns)
  45                      (cons 'unused-toplevel warns)
  46                      warns)))
  47     (set! compile-opts (list #:warnings warns))
  48     (set! compile-file-opts (list #:warnings fwarns))))
  49
  50 (ge:set-warnings 'none)
  51
  52 (define (write-result result output)
  53   (write (list (cons 'result result) (cons 'output output)))
  54   (newline))
  55
  56 (define (call-with-result thunk)
  57   (letrec* ((result #f)
  58             (output
  59              (with-output-to-string
  60                (lambda ()
  61                  (with-fluids ((*current-warning-port* (current-output-port))
  62                                (*current-warning-prefix* ""))
  63                    (with-error-to-port (current-output-port)
  64                      (lambda () (set! result (thunk)))))))))
  65     (write-result result output)))
  66
  67 (define (ge:compile form module)
  68   (compile* form module compile-opts))
  69
  70 (define (compile* form module-name opts)
  71   (let* ((module (or (find-module module-name) (current-module)))
  72          (ev (lambda ()
  73                (call-with-values
  74                    (lambda ()
  75                      (let* ((o (compile form
  76                                         #:to 'objcode
  77                                         #:env module
  78                                         #:opts opts))
  79                             (thunk (make-program o)))
  80                        (start-stack 'geiser-evaluation-stack
  81                                     (eval `(,thunk) module))))
  82                  (lambda vs (map object->string vs))))))
  83     (call-with-result ev)))
  84
  85 (define (ge:eval form module-name)
  86   (let* ((module (or (find-module module-name) (current-module)))
  87          (ev (lambda ()
  88                (call-with-values
  89                    (lambda () (eval form module))
  90                  (lambda vs (map object->string vs))))))
  91     (call-with-result ev)))
  92
  93 (define (ge:compile-file path)
  94   (call-with-result
  95    (lambda ()
  96      (let ((cr (compile-file path
  97                              #:canonicalization 'absolute
  98                              #:opts compile-file-opts)))
  99        (and cr
 100             (list (object->string (save-module-excursion
 101                                    (lambda () (load-compiled cr))))))))))
 102
 103 (define ge:load-file ge:compile-file)
 104
 105 (define (ge:macroexpand form . all)
 106   (let ((all (and (not (null? all)) (car all))))
 107     (with-output-to-string
 108       (lambda ()
 109         (pretty-print (tree-il->scheme (macroexpand form)))))))
 110
 111 (define (ge:add-to-load-path dir)
 112   (and (file-is-directory? dir)
 113        (not (member dir %load-path))
 114        (begin (set! %load-path (cons dir %load-path))
 115               #t)))