blob: ea0f1777786e3b814796ccc71d3578a34b2aa5fd (
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
|
;;; Evaluating code from users
;;; Copyright (C) 2011, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (ice-9 eval-string)
#:use-module (system base compile)
#:use-module (system base language)
#:use-module (system vm loader)
#:replace (eval-string))
(define (ensure-language x)
(if (language? x)
x
(lookup-language x)))
(define* (read-and-eval port #:key (lang (current-language)))
(parameterize ((current-language (ensure-language lang)))
(define (read)
((language-reader (current-language)) port (current-module)))
(define (eval exp)
((language-evaluator (current-language)) exp (current-module)))
(let ((exp (read)))
(if (eof-object? exp)
;; The behavior of read-and-compile and of the old
;; eval-string.
*unspecified*
(let lp ((exp exp))
(call-with-values
(lambda () (eval exp))
(lambda vals
(let ((next (read)))
(cond
((eof-object? next)
(apply values vals))
(else
(lp next)))))))))))
(define* (eval-string str #:key
(module (current-module))
(file #f)
(line #f)
(column #f)
(lang (current-language))
(compile? #f))
(define (maybe-with-module module thunk)
(if module
(save-module-excursion
(lambda ()
(set-current-module module)
(thunk)))
(thunk)))
(let ((lang (ensure-language lang)))
(call-with-input-string
str
(lambda (port)
(maybe-with-module
module
(lambda ()
(if module
(set-current-module module))
(if file
(set-port-filename! port file))
(if line
(set-port-line! port line))
(if column
(set-port-column! port line))
(if (or compile? (not (language-evaluator lang)))
((load-thunk-from-memory
(read-and-compile port #:from lang #:to 'bytecode)))
(read-and-eval port #:lang lang))))))))
|
