Commit | Line | Data |
---|---|---|
ea9c5dab | 1 | ;;; Repl common routines |
17e90c5e | 2 | |
32e3c505 | 3 | ;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, |
f974224d | 4 | ;; 2013, 2014 Free Software Foundation, Inc. |
17e90c5e | 5 | |
e1203ea0 LC |
6 | ;;; This library is free software; you can redistribute it and/or |
7 | ;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;; License as published by the Free Software Foundation; either | |
9 | ;;; version 3 of the License, or (at your option) any later version. | |
10 | ;;; | |
11 | ;;; This library is distributed in the hope that it will be useful, | |
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;; Lesser General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;; License along with this library; if not, write to the Free Software | |
18 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
17e90c5e KN |
19 | |
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl common) | |
8239263f | 23 | #:use-module (system base syntax) |
1a1a10d3 AW |
24 | #:use-module (system base compile) |
25 | #:use-module (system base language) | |
a4060f67 | 26 | #:use-module (system base message) |
01c0082f | 27 | #:use-module (system vm program) |
4cbc95f1 | 28 | #:use-module (system vm loader) |
25450a0d | 29 | #:autoload (language tree-il optimize) (optimize) |
32ce4058 | 30 | #:use-module (ice-9 control) |
c27d140a | 31 | #:use-module (ice-9 history) |
01c0082f | 32 | #:export (<repl> make-repl repl-language repl-options |
c372cd74 | 33 | repl-tm-stats repl-gc-stats repl-debug |
33df2ec7 AW |
34 | repl-welcome repl-prompt |
35 | repl-read repl-compile repl-prepare-eval-thunk repl-eval | |
d62dd766 | 36 | repl-expand repl-optimize |
b0b180d5 | 37 | repl-parse repl-print repl-option-ref repl-option-set! |
91037860 | 38 | repl-default-option-set! repl-default-prompt-set! |
dca9a4d6 | 39 | puts ->string user-error |
9346b857 | 40 | *warranty* *copying* *version*)) |
dca9a4d6 AW |
41 | |
42 | (define *version* | |
43 | (format #f "GNU Guile ~A | |
f974224d | 44 | Copyright (C) 1995-2014 Free Software Foundation, Inc. |
dca9a4d6 AW |
45 | |
46 | Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'. | |
47 | This program is free software, and you are welcome to redistribute it | |
48 | under certain conditions; type `,show c' for details." (version))) | |
49 | ||
50 | (define *copying* | |
51 | "Guile is free software: you can redistribute it and/or modify | |
52 | it under the terms of the GNU Lesser General Public License as | |
53 | published by the Free Software Foundation, either version 3 of | |
54 | the License, or (at your option) any later version. | |
55 | ||
56 | Guile is distributed in the hope that it will be useful, but | |
57 | WITHOUT ANY WARRANTY; without even the implied warranty of | |
58 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
59 | Lesser General Public License for more details. | |
60 | ||
61 | You should have received a copy of the GNU Lesser General Public | |
62 | License along with this program. If not, see | |
63 | <http://www.gnu.org/licenses/lgpl.html>.") | |
64 | ||
65 | (define *warranty* | |
66 | "Guile is distributed WITHOUT ANY WARRANTY. The following | |
67 | sections from the GNU General Public License, version 3, should | |
68 | make that clear. | |
69 | ||
70 | 15. Disclaimer of Warranty. | |
71 | ||
72 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY | |
73 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT | |
74 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY | |
75 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, | |
76 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR | |
77 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM | |
78 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF | |
79 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. | |
80 | ||
81 | 16. Limitation of Liability. | |
82 | ||
83 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING | |
84 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS | |
85 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY | |
86 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE | |
87 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF | |
88 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD | |
89 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), | |
90 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF | |
91 | SUCH DAMAGES. | |
92 | ||
93 | 17. Interpretation of Sections 15 and 16. | |
94 | ||
95 | If the disclaimer of warranty and limitation of liability provided | |
96 | above cannot be given local legal effect according to their terms, | |
97 | reviewing courts shall apply local law that most closely approximates | |
98 | an absolute waiver of all civil liability in connection with the | |
99 | Program, unless a warranty or assumption of liability accompanies a | |
100 | copy of the Program in return for a fee. | |
101 | ||
102 | See <http://www.gnu.org/licenses/lgpl.html>, for more details.") | |
17e90c5e KN |
103 | |
104 | \f | |
105 | ;;; | |
8f5cfc81 | 106 | ;;; Repl type |
17e90c5e KN |
107 | ;;; |
108 | ||
5b27d9d2 | 109 | (define-record/keywords <repl> |
c372cd74 | 110 | language options tm-stats gc-stats debug) |
f21dfea6 KN |
111 | |
112 | (define repl-default-options | |
2b12193d | 113 | (copy-tree |
5a79300f | 114 | `((compile-options ,%auto-compilation-options #f) |
c27d140a AW |
115 | (trace #f #f) |
116 | (interp #f #f) | |
117 | (prompt #f ,(lambda (prompt) | |
118 | (cond | |
119 | ((not prompt) #f) | |
120 | ((string? prompt) (lambda (repl) prompt)) | |
121 | ((thunk? prompt) (lambda (repl) (prompt))) | |
122 | ((procedure? prompt) prompt) | |
123 | (else (error "Invalid prompt" prompt))))) | |
afdf5467 DH |
124 | (print #f ,(lambda (print) |
125 | (cond | |
126 | ((not print) #f) | |
127 | ((procedure? print) print) | |
128 | (else (error "Invalid print procedure" print))))) | |
c27d140a AW |
129 | (value-history |
130 | ,(value-history-enabled?) | |
131 | ,(lambda (x) | |
132 | (if x (enable-value-history!) (disable-value-history!)) | |
bb455e4f AW |
133 | (->bool x))) |
134 | (on-error | |
135 | debug | |
136 | ,(let ((vals '(debug backtrace report pass))) | |
137 | (lambda (x) | |
138 | (if (memq x vals) | |
139 | x | |
140 | (error "Bad on-error value ~a; expected one of ~a" x vals)))))))) | |
17e90c5e | 141 | |
849cefac | 142 | (define %make-repl make-repl) |
5b27d9d2 | 143 | (define* (make-repl lang #:optional debug) |
46e0923d AW |
144 | (%make-repl #:language (if (language? lang) |
145 | lang | |
146 | (lookup-language lang)) | |
2b12193d | 147 | #:options (copy-tree repl-default-options) |
1a1a10d3 | 148 | #:tm-stats (times) |
5b27d9d2 | 149 | #:gc-stats (gc-stats) |
5b27d9d2 | 150 | #:debug debug)) |
17e90c5e | 151 | |
f116f923 | 152 | (define (repl-welcome repl) |
dca9a4d6 AW |
153 | (display *version*) |
154 | (newline) | |
155 | (newline) | |
17e90c5e KN |
156 | (display "Enter `,help' for help.\n")) |
157 | ||
f116f923 | 158 | (define (repl-prompt repl) |
91037860 AW |
159 | (cond |
160 | ((repl-option-ref repl 'prompt) | |
161 | => (lambda (prompt) (prompt repl))) | |
162 | (else | |
163 | (format #f "~A@~A~A> " (language-name (repl-language repl)) | |
164 | (module-name (current-module)) | |
d5e0eb57 AW |
165 | (let ((level (length (cond |
166 | ((fluid-ref *repl-stack*) => cdr) | |
167 | (else '()))))) | |
91037860 | 168 | (if (zero? level) "" (format #f " [~a]" level))))))) |
17e90c5e | 169 | |
f116f923 | 170 | (define (repl-read repl) |
c372cd74 AW |
171 | (let ((reader (language-reader (repl-language repl)))) |
172 | (reader (current-input-port) (current-module)))) | |
17e90c5e | 173 | |
35d70ecc AW |
174 | (define (repl-compile-options repl) |
175 | (repl-option-ref repl 'compile-options)) | |
176 | ||
177 | (define (repl-compile repl form) | |
178 | (let ((from (repl-language repl)) | |
179 | (opts (repl-compile-options repl))) | |
691697de | 180 | (compile form #:from from #:to 'bytecode #:opts opts |
d215190e | 181 | #:env (current-module)))) |
b0b180d5 | 182 | |
d62dd766 AW |
183 | (define (repl-expand repl form) |
184 | (let ((from (repl-language repl)) | |
185 | (opts (repl-compile-options repl))) | |
186 | (decompile (compile form #:from from #:to 'tree-il #:opts opts | |
187 | #:env (current-module)) | |
188 | #:from 'tree-il #:to from))) | |
189 | ||
190 | (define (repl-optimize repl form) | |
191 | (let ((from (repl-language repl)) | |
192 | (opts (repl-compile-options repl))) | |
25450a0d AW |
193 | (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts |
194 | #:env (current-module)) | |
195 | (current-module) | |
196 | opts) | |
d62dd766 AW |
197 | #:from 'tree-il #:to from))) |
198 | ||
b0b180d5 AW |
199 | (define (repl-parse repl form) |
200 | (let ((parser (language-parser (repl-language repl)))) | |
201 | (if parser (parser form) form))) | |
17e90c5e | 202 | |
33df2ec7 AW |
203 | (define (repl-prepare-eval-thunk repl form) |
204 | (let* ((eval (language-evaluator (repl-language repl)))) | |
205 | (if (and eval | |
206 | (or (null? (language-compilers (repl-language repl))) | |
c27d140a | 207 | (repl-option-ref repl 'interp))) |
33df2ec7 | 208 | (lambda () (eval form (current-module))) |
b73a2ee0 | 209 | (load-thunk-from-memory (repl-compile repl form))))) |
33df2ec7 | 210 | |
f116f923 | 211 | (define (repl-eval repl form) |
33df2ec7 | 212 | (let ((thunk (repl-prepare-eval-thunk repl form))) |
01c0082f | 213 | (% (thunk)))) |
17e90c5e | 214 | |
f116f923 | 215 | (define (repl-print repl val) |
17e90c5e | 216 | (if (not (eq? val *unspecified*)) |
8f5cfc81 | 217 | (begin |
33df2ec7 | 218 | (run-hook before-print-hook val) |
afdf5467 DH |
219 | (cond |
220 | ((repl-option-ref repl 'print) | |
221 | => (lambda (print) (print repl val))) | |
222 | (else | |
223 | ;; The result of an evaluation is representable in scheme, and | |
224 | ;; should be printed with the generic printer, `write'. The | |
225 | ;; language-printer is something else: it prints expressions of | |
226 | ;; a given language, not the result of evaluation. | |
227 | (write val) | |
228 | (newline)))))) | |
8f5cfc81 | 229 | |
f116f923 | 230 | (define (repl-option-ref repl key) |
c27d140a AW |
231 | (cadr (or (assq key (repl-options repl)) |
232 | (error "unknown repl option" key)))) | |
f21dfea6 | 233 | |
f116f923 | 234 | (define (repl-option-set! repl key val) |
c27d140a AW |
235 | (let ((spec (or (assq key (repl-options repl)) |
236 | (error "unknown repl option" key)))) | |
237 | (set-car! (cdr spec) | |
238 | (if (procedure? (caddr spec)) | |
239 | ((caddr spec) val) | |
240 | val)))) | |
f21dfea6 | 241 | |
91037860 | 242 | (define (repl-default-option-set! key val) |
c27d140a AW |
243 | (let ((spec (or (assq key repl-default-options) |
244 | (error "unknown repl option" key)))) | |
245 | (set-car! (cdr spec) | |
246 | (if (procedure? (caddr spec)) | |
247 | ((caddr spec) val) | |
248 | val)))) | |
91037860 AW |
249 | |
250 | (define (repl-default-prompt-set! prompt) | |
c27d140a | 251 | (repl-default-option-set! 'prompt prompt)) |
91037860 | 252 | |
8f5cfc81 KN |
253 | \f |
254 | ;;; | |
255 | ;;; Utilities | |
256 | ;;; | |
257 | ||
f116f923 | 258 | (define (puts x) (display x) (newline)) |
8f5cfc81 | 259 | |
f116f923 | 260 | (define (->string x) |
8f5cfc81 KN |
261 | (object->string x display)) |
262 | ||
f116f923 | 263 | (define (user-error msg . args) |
8f5cfc81 | 264 | (throw 'user-error #f msg args #f)) |