blob: bdbcdd8a8b10b533add2e622acc2496ab8de0381 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
;;; 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))))
|
