Commit | Line | Data |
---|---|---|
da5d81a1 AW |
1 | ;;; Parsing Guile's command-line |
2 | ||
e1d29ee4 | 3 | ;;; Copyright (C) 1994-1998, 2000-2015 Free Software Foundation, Inc. |
da5d81a1 AW |
4 | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Code: | |
20 | ||
21 | ;;; | |
22 | ;;; Please be careful not to load up other modules in this file, unless | |
23 | ;;; they are explicitly requested. Loading modules currently imposes a | |
24 | ;;; speed penalty of a few stats, an mmap, and some allocation, which | |
25 | ;;; can range from 1 to 20ms, depending on the state of your disk cache. | |
26 | ;;; Since `compile-shell-switches' is called even for the most transient | |
27 | ;;; of command-line programs, we need to keep it lean. | |
28 | ;;; | |
29 | ;;; Generally speaking, the goal is for Guile to boot and execute simple | |
30 | ;;; expressions like "1" within 20ms or less, measured using system time | |
31 | ;;; from the time of the `guile' invocation to exit. | |
32 | ;;; | |
33 | ||
34 | (define-module (ice-9 command-line) | |
a222cbc9 | 35 | #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!) |
da5d81a1 AW |
36 | #:export (compile-shell-switches |
37 | version-etc | |
38 | *GPLv3+* | |
39 | *LGPLv3+* | |
40 | emit-bug-reporting-address)) | |
41 | ||
42 | ;; An initial stab at i18n. | |
43 | (define _ gettext) | |
44 | ||
45 | (define *GPLv3+* | |
46 | (_ "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>. | |
47 | This is free software: you are free to change and redistribute it. | |
48 | There is NO WARRANTY, to the extent permitted by law.")) | |
49 | ||
50 | (define *LGPLv3+* | |
51 | (_ "License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>. | |
52 | This is free software: you are free to change and redistribute it. | |
53 | There is NO WARRANTY, to the extent permitted by law.")) | |
54 | ||
55 | ;; Display the --version information in the | |
56 | ;; standard way: command and package names, package version, followed | |
57 | ;; by a short license notice and a list of up to 10 author names. | |
58 | ;; If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of | |
59 | ;; the program. The formats are therefore: | |
60 | ;; PACKAGE VERSION | |
61 | ;; or | |
62 | ;; COMMAND_NAME (PACKAGE) VERSION. | |
63 | ;; | |
64 | ;; Based on the version-etc gnulib module. | |
65 | ;; | |
66 | (define* (version-etc package version #:key | |
67 | (port (current-output-port)) | |
68 | ;; FIXME: authors | |
f974224d | 69 | (copyright-year 2014) |
da5d81a1 AW |
70 | (copyright-holder "Free Software Foundation, Inc.") |
71 | (copyright (format #f "Copyright (C) ~a ~a" | |
72 | copyright-year copyright-holder)) | |
73 | (license *GPLv3+*) | |
74 | command-name | |
75 | packager packager-version) | |
76 | (if command-name | |
77 | (format port "~a (~a) ~a\n" command-name package version) | |
78 | (format port "~a ~a\n" package version)) | |
79 | ||
80 | (if packager | |
81 | (if packager-version | |
82 | (format port (_ "Packaged by ~a (~a)\n") packager packager-version) | |
83 | (format port (_ "Packaged by ~a\n") packager))) | |
84 | ||
85 | (display copyright port) | |
86 | (newline port) | |
87 | (newline port) | |
88 | (display license port) | |
89 | (newline port)) | |
90 | ||
91 | ||
92 | ;; Display the usual `Report bugs to' stanza. | |
93 | ;; | |
94 | (define* (emit-bug-reporting-address package bug-address #:key | |
95 | (port (current-output-port)) | |
96 | (url (string-append | |
97 | "http://www.gnu.org/software/" | |
98 | package | |
99 | "/")) | |
100 | packager packager-bug-address) | |
101 | (format port (_ "\nReport bugs to: ~a\n") bug-address) | |
102 | (if (and packager packager-bug-address) | |
103 | (format port (_ "Report ~a bugs to: ~a\n") packager packager-bug-address)) | |
104 | (format port (_ "~a home page: <~a>\n") package url) | |
105 | (format port | |
106 | (_ "General help using GNU software: <http://www.gnu.org/gethelp/>\n"))) | |
107 | ||
108 | (define *usage* | |
faabd161 | 109 | (_ "Evaluate code with Guile, interactively or from a script. |
da5d81a1 | 110 | |
faabd161 AW |
111 | [-s] FILE load source code from FILE, and exit |
112 | -c EXPR evalute expression EXPR, and exit | |
da5d81a1 AW |
113 | -- stop scanning arguments; run interactively |
114 | ||
115 | The above switches stop argument processing, and pass all | |
116 | remaining arguments as the value of (command-line). | |
117 | If FILE begins with `-' the -s switch is mandatory. | |
118 | ||
119 | -L DIRECTORY add DIRECTORY to the front of the module load path | |
b05257b9 | 120 | -C DIRECTORY like -L, but for compiled files |
da5d81a1 | 121 | -x EXTENSION add EXTENSION to the front of the load extensions |
faabd161 | 122 | -l FILE load source code from FILE |
da5d81a1 AW |
123 | -e FUNCTION after reading script, apply FUNCTION to |
124 | command line arguments | |
faabd161 | 125 | --language=LANG change language; default: scheme |
da5d81a1 | 126 | -ds do -s script at this point |
c8286111 | 127 | --debug start with the \"debugging\" VM engine |
faabd161 AW |
128 | --no-debug start with the normal VM engine (backtraces but |
129 | no breakpoints); default is --debug for interactive | |
da5d81a1 AW |
130 | use, but not for `-s' and `-c'. |
131 | --auto-compile compile source files automatically | |
1e56cff2 | 132 | --fresh-auto-compile invalidate auto-compilation cache |
faabd161 AW |
133 | --no-auto-compile disable automatic source file compilation; |
134 | default is to enable auto-compilation of source | |
da5d81a1 | 135 | files. |
faabd161 AW |
136 | --listen[=P] listen on a local port or a path for REPL clients; |
137 | if P is not given, the default is local port 37146 | |
da5d81a1 AW |
138 | -q inhibit loading of user init file |
139 | --use-srfi=LS load SRFI modules for the SRFIs in LS, | |
140 | which is a list of numbers like \"2,13,14\" | |
141 | -h, --help display this help and exit | |
142 | -v, --version display version information and exit | |
143 | \\ read arguments from following script lines")) | |
144 | ||
145 | ||
146 | (define* (shell-usage name fatal? #:optional fmt . args) | |
147 | (let ((port (if fatal? | |
148 | (current-error-port) | |
149 | (current-output-port)))) | |
e1d29ee4 LC |
150 | (when fmt |
151 | (apply format port fmt args) | |
152 | (newline port)) | |
da5d81a1 AW |
153 | |
154 | (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name) | |
155 | (display *usage* port) | |
156 | (newline port) | |
157 | ||
158 | (emit-bug-reporting-address | |
159 | "GNU Guile" "bug-guile@gnu.org" | |
160 | #:port port | |
161 | #:url "http://www.gnu.org/software/guile/" | |
162 | #:packager (assq-ref %guile-build-info 'packager) | |
163 | #:packager-bug-address | |
164 | (assq-ref %guile-build-info 'packager-bug-address)) | |
165 | ||
166 | (if fatal? | |
167 | (exit 1)))) | |
168 | ||
faabd161 AW |
169 | ;; Try to avoid loading (ice-9 eval-string) and (system base compile) if |
170 | ;; possible. | |
171 | (define (eval-string/lang str) | |
172 | (case (current-language) | |
173 | ((scheme) | |
174 | (call-with-input-string | |
175 | str | |
176 | (lambda (port) | |
177 | (let lp () | |
178 | (let ((exp (read port))) | |
179 | (if (not (eof-object? exp)) | |
180 | (begin | |
181 | (eval exp (current-module)) | |
182 | (lp)))))))) | |
183 | (else | |
184 | ((module-ref (resolve-module '(ice-9 eval-string)) 'eval-string) str)))) | |
185 | ||
186 | (define (load/lang f) | |
187 | (case (current-language) | |
188 | ((scheme) | |
8026a774 | 189 | (load-in-vicinity (getcwd) f)) |
faabd161 AW |
190 | (else |
191 | ((module-ref (resolve-module '(system base compile)) 'compile-file) | |
192 | f #:to 'value)))) | |
da5d81a1 AW |
193 | |
194 | (define* (compile-shell-switches args #:optional (usage-name "guile")) | |
195 | (let ((arg0 "guile") | |
faabd161 | 196 | (script-cell #f) |
da5d81a1 AW |
197 | (entry-point #f) |
198 | (user-load-path '()) | |
b05257b9 | 199 | (user-load-compiled-path '()) |
da5d81a1 AW |
200 | (user-extensions '()) |
201 | (interactive? #t) | |
202 | (inhibit-user-init? #f) | |
203 | (turn-on-debugging? #f) | |
204 | (turn-off-debugging? #f)) | |
205 | ||
206 | (define (error fmt . args) | |
e1d29ee4 LC |
207 | (apply shell-usage usage-name #t |
208 | (string-append "error: " fmt "~%") args)) | |
da5d81a1 AW |
209 | |
210 | (define (parse args out) | |
211 | (cond | |
212 | ((null? args) | |
213 | (finish args out)) | |
214 | (else | |
215 | (let ((arg (car args)) | |
216 | (args (cdr args))) | |
217 | (cond | |
218 | ((not (string-prefix? "-" arg)) ; foo | |
faabd161 | 219 | ;; If we specified the -ds option, script-cell is the cdr of |
dac9812a AW |
220 | ;; an expression like (load #f). We replace the car (i.e., |
221 | ;; the #f) with the script name. | |
da5d81a1 AW |
222 | (set! arg0 arg) |
223 | (set! interactive? #f) | |
faabd161 | 224 | (if script-cell |
dac9812a | 225 | (begin |
faabd161 | 226 | (set-car! script-cell arg0) |
dac9812a | 227 | (finish args out)) |
faabd161 AW |
228 | (finish args |
229 | (cons `((@@ (ice-9 command-line) load/lang) ,arg0) | |
230 | out)))) | |
da5d81a1 AW |
231 | |
232 | ((string=? arg "-s") ; foo | |
233 | (if (null? args) | |
234 | (error "missing argument to `-s' switch")) | |
235 | (set! arg0 (car args)) | |
da5d81a1 | 236 | (set! interactive? #f) |
faabd161 | 237 | (if script-cell |
dac9812a | 238 | (begin |
faabd161 | 239 | (set-car! script-cell arg0) |
dac9812a | 240 | (finish (cdr args) out)) |
faabd161 AW |
241 | (finish (cdr args) |
242 | (cons `((@@ (ice-9 command-line) load/lang) ,arg0) | |
243 | out)))) | |
dac9812a | 244 | |
da5d81a1 AW |
245 | ((string=? arg "-c") ; evaluate expr |
246 | (if (null? args) | |
247 | (error "missing argument to `-c' switch")) | |
248 | (set! interactive? #f) | |
249 | (finish (cdr args) | |
faabd161 AW |
250 | (cons `((@@ (ice-9 command-line) eval-string/lang) |
251 | ,(car args)) | |
da5d81a1 AW |
252 | out))) |
253 | ||
254 | ((string=? arg "--") ; end args go interactive | |
255 | (finish args out)) | |
256 | ||
257 | ((string=? arg "-l") ; load a file | |
258 | (if (null? args) | |
259 | (error "missing argument to `-l' switch")) | |
260 | (parse (cdr args) | |
a20eb9a3 | 261 | (cons `((@@ (ice-9 command-line) load/lang) ,(car args)) |
faabd161 | 262 | out))) |
da5d81a1 AW |
263 | |
264 | ((string=? arg "-L") ; add to %load-path | |
265 | (if (null? args) | |
266 | (error "missing argument to `-L' switch")) | |
267 | (set! user-load-path (cons (car args) user-load-path)) | |
268 | (parse (cdr args) | |
269 | out)) | |
270 | ||
b05257b9 MW |
271 | ((string=? arg "-C") ; add to %load-compiled-path |
272 | (if (null? args) | |
273 | (error "missing argument to `-C' switch")) | |
274 | (set! user-load-compiled-path | |
275 | (cons (car args) user-load-compiled-path)) | |
276 | (parse (cdr args) | |
277 | out)) | |
278 | ||
da5d81a1 AW |
279 | ((string=? arg "-x") ; add to %load-extensions |
280 | (if (null? args) | |
e6efefad | 281 | (error "missing argument to `-x' switch")) |
da5d81a1 AW |
282 | (set! user-extensions (cons (car args) user-extensions)) |
283 | (parse (cdr args) | |
284 | out)) | |
285 | ||
286 | ((string=? arg "-e") ; entry point | |
287 | (if (null? args) | |
288 | (error "missing argument to `-e' switch")) | |
289 | (let* ((port (open-input-string (car args))) | |
290 | (arg1 (read port)) | |
291 | (arg2 (read port))) | |
292 | ;; Recognize syntax of certain versions of guile 1.4 and | |
293 | ;; transform to (@ MODULE-NAME FUNC). | |
294 | (set! entry-point | |
295 | (cond | |
296 | ((not (eof-object? arg2)) | |
297 | `(@ ,arg1 ,arg2)) | |
298 | ((and (pair? arg1) | |
299 | (not (memq (car arg1) '(@ @@))) | |
300 | (and-map symbol? arg1)) | |
301 | `(@ ,arg1 main)) | |
302 | (else | |
303 | arg1)))) | |
304 | (parse (cdr args) | |
305 | out)) | |
306 | ||
faabd161 AW |
307 | ((string-prefix? "--language=" arg) ; language |
308 | (parse args | |
309 | (cons `(current-language | |
310 | ',(string->symbol | |
311 | (substring arg (string-length "--language=")))) | |
312 | out))) | |
313 | ||
314 | ((string=? "--language" arg) ; language | |
315 | (when (null? args) | |
316 | (error "missing argument to `--language' option")) | |
317 | (parse (cdr args) | |
318 | (cons `(current-language ',(string->symbol (car args))) | |
319 | out))) | |
320 | ||
da5d81a1 AW |
321 | ((string=? arg "-ds") ; do script here |
322 | ;; We put a dummy "load" expression, and let the -s put the | |
323 | ;; filename in. | |
faabd161 AW |
324 | (when script-cell |
325 | (error "the -ds switch may only be specified once")) | |
326 | (set! script-cell (list #f)) | |
da5d81a1 | 327 | (parse args |
faabd161 AW |
328 | (acons '(@@ (ice-9 command-line) load/lang) |
329 | script-cell | |
330 | out))) | |
da5d81a1 AW |
331 | |
332 | ((string=? arg "--debug") | |
333 | (set! turn-on-debugging? #t) | |
334 | (set! turn-off-debugging? #f) | |
335 | (parse args out)) | |
336 | ||
337 | ((string=? arg "--no-debug") | |
338 | (set! turn-off-debugging? #t) | |
339 | (set! turn-on-debugging? #f) | |
340 | (parse args out)) | |
341 | ||
342 | ;; Do auto-compile on/off now, because the form itself might | |
343 | ;; need this decision. | |
344 | ((string=? arg "--auto-compile") | |
90779ad9 AW |
345 | (set! %load-should-auto-compile #t) |
346 | (parse args out)) | |
da5d81a1 | 347 | |
1e56cff2 AW |
348 | ((string=? arg "--fresh-auto-compile") |
349 | (set! %load-should-auto-compile #t) | |
350 | (set! %fresh-auto-compile #t) | |
351 | (parse args out)) | |
352 | ||
da5d81a1 | 353 | ((string=? arg "--no-auto-compile") |
90779ad9 AW |
354 | (set! %load-should-auto-compile #f) |
355 | (parse args out)) | |
da5d81a1 AW |
356 | |
357 | ((string=? arg "-q") ; don't load user init | |
90779ad9 AW |
358 | (set! inhibit-user-init? #t) |
359 | (parse args out)) | |
da5d81a1 AW |
360 | |
361 | ((string-prefix? "--use-srfi=" arg) | |
362 | (let ((srfis (map (lambda (x) | |
363 | (let ((n (string->number x))) | |
364 | (if (and n (exact? n) (integer? n) (>= n 0)) | |
365 | n | |
366 | (error "invalid SRFI specification")))) | |
367 | (string-split (substring arg 11) #\,)))) | |
368 | (if (null? srfis) | |
369 | (error "invalid SRFI specification")) | |
370 | (parse args | |
371 | (cons `(use-srfis ',srfis) out)))) | |
372 | ||
373 | ((string=? arg "--listen") ; start a repl server | |
374 | (parse args | |
59106595 | 375 | (cons '((@@ (system repl server) spawn-server)) out))) |
da5d81a1 AW |
376 | |
377 | ((string-prefix? "--listen=" arg) ; start a repl server | |
378 | (parse | |
379 | args | |
380 | (cons | |
86b4309b | 381 | (let ((where (substring arg 9))) |
da5d81a1 AW |
382 | (cond |
383 | ((string->number where) ; --listen=PORT | |
384 | => (lambda (port) | |
385 | (if (and (integer? port) (exact? port) (>= port 0)) | |
59106595 IP |
386 | `((@@ (system repl server) spawn-server) |
387 | ((@@ (system repl server) make-tcp-server-socket) #:port ,port)) | |
86b4309b | 388 | (error "invalid port for --listen")))) |
da5d81a1 | 389 | ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET |
59106595 IP |
390 | `((@@ (system repl server) spawn-server) |
391 | ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where))) | |
da5d81a1 AW |
392 | (else |
393 | (error "unknown argument to --listen")))) | |
394 | out))) | |
395 | ||
396 | ((or (string=? arg "-h") (string=? arg "--help")) | |
397 | (shell-usage usage-name #f) | |
398 | (exit 0)) | |
399 | ||
400 | ((or (string=? arg "-v") (string=? arg "--version")) | |
401 | (version-etc "GNU Guile" (version) | |
e07f0a55 | 402 | #:license *LGPLv3+* |
da5d81a1 AW |
403 | #:command-name "guile" |
404 | #:packager (assq-ref %guile-build-info 'packager) | |
405 | #:packager-version | |
406 | (assq-ref %guile-build-info 'packager-version)) | |
407 | (exit 0)) | |
408 | ||
409 | (else | |
e1d29ee4 | 410 | (error "unrecognized switch ~a" arg))))))) |
da5d81a1 AW |
411 | |
412 | (define (finish args out) | |
413 | ;; Check to make sure the -ds got a -s. | |
faabd161 AW |
414 | (when (and script-cell (not (car script-cell))) |
415 | (error "the `-ds' switch requires the use of `-s' as well")) | |
da5d81a1 AW |
416 | |
417 | ;; Make any remaining arguments available to the | |
418 | ;; script/command/whatever. | |
419 | (set-program-arguments (cons arg0 args)) | |
420 | ||
421 | ;; If debugging was requested, or we are interactive and debugging | |
422 | ;; was not explicitly turned off, use the debug engine. | |
423 | (if (or turn-on-debugging? | |
424 | (and interactive? (not turn-off-debugging?))) | |
425 | (begin | |
426 | (set-default-vm-engine! 'debug) | |
972275ee | 427 | (set-vm-engine! 'debug))) |
da5d81a1 AW |
428 | |
429 | ;; Return this value. | |
430 | `(;; It would be nice not to load up (ice-9 control), but the | |
431 | ;; default-prompt-handler is nontrivial. | |
432 | (@ (ice-9 control) %) | |
433 | (begin | |
434 | ;; If we didn't end with a -c or a -s and didn't supply a -q, load | |
435 | ;; the user's customization file. | |
436 | ,@(if (and interactive? (not inhibit-user-init?)) | |
437 | '((load-user-init)) | |
438 | '()) | |
439 | ||
440 | ;; Use-specified extensions. | |
441 | ,@(map (lambda (ext) | |
442 | `(set! %load-extensions (cons ,ext %load-extensions))) | |
443 | user-extensions) | |
444 | ||
b05257b9 | 445 | ;; Add the user-specified load paths here, so they won't be in |
da5d81a1 AW |
446 | ;; effect during the loading of the user's customization file. |
447 | ,@(map (lambda (path) | |
448 | `(set! %load-path (cons ,path %load-path))) | |
449 | user-load-path) | |
b05257b9 MW |
450 | ,@(map (lambda (path) |
451 | `(set! %load-compiled-path | |
452 | (cons ,path %load-compiled-path))) | |
453 | user-load-compiled-path) | |
da5d81a1 AW |
454 | |
455 | ;; Put accumulated actions in their correct order. | |
456 | ,@(reverse! out) | |
457 | ||
458 | ;; Handle the `-e' switch, if it was specified. | |
459 | ,@(if entry-point | |
460 | `((,entry-point (command-line))) | |
461 | '()) | |
462 | ,(if interactive? | |
463 | ;; If we didn't end with a -c or a -s, start the | |
464 | ;; repl. | |
465 | '((@ (ice-9 top-repl) top-repl)) | |
466 | ;; Otherwise, after doing all the other actions | |
467 | ;; prescribed by the command line, quit. | |
468 | '(quit))))) | |
469 | ||
470 | (if (pair? args) | |
471 | (begin | |
472 | (set! arg0 (car args)) | |
473 | (let ((slash (string-rindex arg0 #\/))) | |
474 | (set! usage-name | |
475 | (if slash (substring arg0 (1+ slash)) arg0))) | |
476 | (parse (cdr args) '())) | |
477 | (parse args '())))) |