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                    (set! result (thunk)))))))
  64     (write-result result output)))
  65
  66 (define (ge:compile form module)
  67   (compile* form module compile-opts))
  68
  69 (define (compile* form module-name opts)
  70   (let* ((module (or (find-module module-name) (current-module)))
  71          (ev (lambda ()
  72                (call-with-values
  73                    (lambda ()
  74                      (let* ((o (compile form
  75                                         #:to 'objcode
  76                                         #:env module
  77                                         #:opts opts))
  78                             (thunk (make-program o)))
  79                        (start-stack 'geiser-evaluation-stack
  80                                     (eval `(,thunk) module))))
  81                  (lambda vs (map object->string vs))))))
  82     (call-with-result ev)))
  83
  84 (define (ge:eval form module-name)
  85   (let* ((module (or (find-module module-name) (current-module)))
  86          (ev (lambda ()
  87                (call-with-values
  88                    (lambda () (eval form module))
  89                  (lambda vs (map object->string vs))))))
  90     (call-with-result ev)))
  91
  92 (define (ge:compile-file path)
  93   (call-with-result
  94    (lambda ()
  95      (let ((cr (compile-file path
  96                              #:canonicalization 'absolute
  97                              #:opts compile-file-opts)))
  98        (and cr
  99             (list (object->string (save-module-excursion
 100                                    (lambda () (load-compiled cr))))))))))
 101
 102 (define ge:load-file ge:compile-file)
 103
 104 (define (ge:macroexpand form . all)
 105   (let ((all (and (not (null? all)) (car all))))
 106     (with-output-to-string
 107       (lambda ()
 108         (pretty-print (tree-il->scheme (macroexpand form)))))))
 109
 110 (define (ge:add-to-load-path dir)
 111   (and (file-is-directory? dir)
 112        (not (member dir %load-path))
 113        (begin (set! %load-path (cons dir %load-path))
 114               #t)))