123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490 |
- (define-module (ice-9 command-line)
- #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!)
- #:export (compile-shell-switches
- version-etc
- *GPLv3+*
- *LGPLv3+*
- emit-bug-reporting-address))
- (define G_ gettext)
- (define *GPLv3+*
- (G_ "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>.
- This is free software: you are free to change and redistribute it.
- There is NO WARRANTY, to the extent permitted by law."))
- (define *LGPLv3+*
- (G_ "License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>.
- This is free software: you are free to change and redistribute it.
- There is NO WARRANTY, to the extent permitted by law."))
- (define* (version-etc package version #:key
- (port (current-output-port))
-
- (copyright-year 2023)
- (copyright-holder "Free Software Foundation, Inc.")
- (copyright (format #f "Copyright (C) ~a ~a"
- copyright-year copyright-holder))
- (license *GPLv3+*)
- command-name
- packager packager-version)
- (if command-name
- (format port "~a (~a) ~a\n" command-name package version)
- (format port "~a ~a\n" package version))
- (if packager
- (if packager-version
- (format port (G_ "Packaged by ~a (~a)\n") packager packager-version)
- (format port (G_ "Packaged by ~a\n") packager)))
-
- (display copyright port)
- (newline port)
- (newline port)
- (display license port)
- (newline port))
- (define* (emit-bug-reporting-address package bug-address #:key
- (port (current-output-port))
- (url (string-append
- "http://www.gnu.org/software/"
- package
- "/"))
- packager packager-bug-address)
- (format port (G_ "\nReport bugs to: ~a\n") bug-address)
- (if (and packager packager-bug-address)
- (format port (G_ "Report ~a bugs to: ~a\n") packager packager-bug-address))
- (format port (G_ "~a home page: <~a>\n") package url)
- (format port
- (G_ "General help using GNU software: <http://www.gnu.org/gethelp/>\n")))
- (define *usage*
- (G_ "Evaluate code with Guile, interactively or from a script.
- [-s] FILE load source code from FILE, and exit
- -c EXPR evalute expression EXPR, and exit
- -- stop scanning arguments; run interactively
- The above switches stop argument processing, and pass all
- remaining arguments as the value of (command-line).
- If FILE begins with `-' the -s switch is mandatory.
- -L DIRECTORY add DIRECTORY to the front of the module load path
- -C DIRECTORY like -L, but for compiled files
- -x EXTENSION add EXTENSION to the front of the load extensions
- -l FILE load source code from FILE
- -e FUNCTION after reading script, apply FUNCTION to
- command line arguments
- --language=LANG change language; default: scheme
- -ds do -s script at this point
- --debug start with the \"debugging\" VM engine
- --no-debug start with the normal VM engine (backtraces but
- no breakpoints); default is --debug for interactive
- use, but not for `-s' and `-c'.
- --auto-compile compile source files automatically
- --fresh-auto-compile invalidate auto-compilation cache
- --no-auto-compile disable automatic source file compilation;
- default is to enable auto-compilation of source
- files.
- --listen[=P] listen on a local port or a path for REPL clients;
- if P is not given, the default is local port 37146
- -q inhibit loading of user init file
- --use-srfi=LS load SRFI modules for the SRFIs in LS,
- which is a list of numbers like \"2,13,14\"
- --r6rs change initial Guile environment to better support
- R6RS
- --r7rs change initial Guile environment to better support
- R7RS
- -h, --help display this help and exit
- -v, --version display version information and exit
- \\ read arguments from following script lines"))
- (define* (shell-usage name fatal? #:optional fmt . args)
- (let ((port (if fatal?
- (current-error-port)
- (current-output-port))))
- (when fmt
- (apply format port fmt args)
- (newline port))
- (format port (G_ "Usage: ~a [OPTION]... [FILE]...\n") name)
- (display *usage* port)
- (newline port)
- (emit-bug-reporting-address
- "GNU Guile" "bug-guile@gnu.org"
- #:port port
- #:url "http://www.gnu.org/software/guile/"
- #:packager (assq-ref %guile-build-info 'packager)
- #:packager-bug-address
- (assq-ref %guile-build-info 'packager-bug-address))
- (if fatal?
- (exit 1))))
- (define (eval-string/lang str)
- (case (current-language)
- ((scheme)
- (call-with-input-string
- str
- (lambda (port)
- (let lp ()
- (let ((exp (read port)))
- (if (not (eof-object? exp))
- (begin
- (eval exp (current-module))
- (lp))))))))
- (else
- ((module-ref (resolve-module '(ice-9 eval-string)) 'eval-string) str))))
- (define (load/lang f)
- (case (current-language)
- ((scheme)
- (load-in-vicinity (getcwd) f))
- (else
- ((module-ref (resolve-module '(system base compile)) 'compile-file)
- f #:to 'value))))
- (define* (compile-shell-switches args #:optional (usage-name "guile"))
- (let ((arg0 "guile")
- (script-cell #f)
- (entry-point #f)
- (user-load-path '())
- (user-load-compiled-path '())
- (user-extensions '())
- (interactive? #t)
- (inhibit-user-init? #f)
- (turn-on-debugging? #f)
- (turn-off-debugging? #f))
- (define (error fmt . args)
- (apply shell-usage usage-name #t
- (string-append "error: " fmt "~%") args))
- (define (parse args out)
- (cond
- ((null? args)
- (finish args out))
- (else
- (let ((arg (car args))
- (args (cdr args)))
- (cond
- ((not (string-prefix? "-" arg))
-
-
-
- (set! arg0 arg)
- (set! interactive? #f)
- (if script-cell
- (begin
- (set-car! script-cell arg0)
- (finish args out))
- (finish args
- (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
- out))))
- ((string=? arg "-s")
- (if (null? args)
- (error "missing argument to `-s' switch"))
- (set! arg0 (car args))
- (set! interactive? #f)
- (if script-cell
- (begin
- (set-car! script-cell arg0)
- (finish (cdr args) out))
- (finish (cdr args)
- (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
- out))))
-
- ((string=? arg "-c")
- (if (null? args)
- (error "missing argument to `-c' switch"))
- (set! interactive? #f)
- (finish (cdr args)
- (cons `((@@ (ice-9 command-line) eval-string/lang)
- ,(car args))
- out)))
- ((string=? arg "--")
- (finish args out))
- ((string=? arg "-l")
- (if (null? args)
- (error "missing argument to `-l' switch"))
- (parse (cdr args)
- (cons `((@@ (ice-9 command-line) load/lang) ,(car args))
- out)))
- ((string=? arg "-L")
- (if (null? args)
- (error "missing argument to `-L' switch"))
- (set! user-load-path (cons (car args) user-load-path))
- (parse (cdr args)
- out))
- ((string=? arg "-C")
- (if (null? args)
- (error "missing argument to `-C' switch"))
- (set! user-load-compiled-path
- (cons (car args) user-load-compiled-path))
- (parse (cdr args)
- out))
- ((string=? arg "-x")
- (if (null? args)
- (error "missing argument to `-x' switch"))
- (set! user-extensions (cons (car args) user-extensions))
- (parse (cdr args)
- out))
- ((string=? arg "-e")
- (if (null? args)
- (error "missing argument to `-e' switch"))
- (let* ((port (open-input-string (car args)))
- (arg1 (read port))
- (arg2 (read port)))
-
-
- (set! entry-point
- (cond
- ((not (eof-object? arg2))
- `(@ ,arg1 ,arg2))
- ((and (pair? arg1)
- (not (memq (car arg1) '(@ @@)))
- (and-map symbol? arg1))
- `(@ ,arg1 main))
- (else
- arg1))))
- (parse (cdr args)
- out))
- ((string-prefix? "--language=" arg)
- (parse args
- (cons `(current-language
- ',(string->symbol
- (substring arg (string-length "--language="))))
- out)))
- ((string=? "--language" arg)
- (when (null? args)
- (error "missing argument to `--language' option"))
- (parse (cdr args)
- (cons `(current-language ',(string->symbol (car args)))
- out)))
- ((string=? arg "-ds")
-
-
- (when script-cell
- (error "the -ds switch may only be specified once"))
- (set! script-cell (list #f))
- (parse args
- (acons '(@@ (ice-9 command-line) load/lang)
- script-cell
- out)))
- ((string=? arg "--debug")
- (set! turn-on-debugging? #t)
- (set! turn-off-debugging? #f)
- (parse args out))
- ((string=? arg "--no-debug")
- (set! turn-off-debugging? #t)
- (set! turn-on-debugging? #f)
- (parse args out))
-
-
- ((string=? arg "--auto-compile")
- (set! %load-should-auto-compile #t)
- (parse args out))
- ((string=? arg "--fresh-auto-compile")
- (set! %load-should-auto-compile #t)
- (set! %fresh-auto-compile #t)
- (parse args out))
- ((string=? arg "--no-auto-compile")
- (set! %load-should-auto-compile #f)
- (parse args out))
- ((string=? arg "-q")
- (set! inhibit-user-init? #t)
- (parse args out))
- ((string-prefix? "--use-srfi=" arg)
- (let ((srfis (map (lambda (x)
- (let ((n (string->number x)))
- (if (and n (exact? n) (integer? n) (>= n 0))
- n
- (error "invalid SRFI specification"))))
- (string-split (substring arg 11) #\,))))
- (if (null? srfis)
- (error "invalid SRFI specification"))
- (parse args
- (cons `(use-srfis ',srfis) out))))
- ((string=? "--r6rs" arg)
- (parse args
- (cons '(install-r6rs!) out)))
- ((string=? "--r7rs" arg)
- (parse args
- (cons '(install-r7rs!) out)))
- ((string=? arg "--listen")
- (parse args
- (cons '((@@ (system repl server) spawn-server)) out)))
-
- ((string-prefix? "--listen=" arg)
- (parse
- args
- (cons
- (let ((where (substring arg 9)))
- (cond
- ((string->number where)
- => (lambda (port)
- (if (and (integer? port) (exact? port) (>= port 0))
- `((@@ (system repl server) spawn-server)
- ((@@ (system repl server) make-tcp-server-socket) #:port ,port))
- (error "invalid port for --listen"))))
- ((string-prefix? "/" where)
- `((@@ (system repl server) spawn-server)
- ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where)))
- (else
- (error "unknown argument to --listen"))))
- out)))
- ((or (string=? arg "-h") (string=? arg "--help"))
- (shell-usage usage-name #f)
- (exit 0))
- ((or (string=? arg "-v") (string=? arg "--version"))
- (version-etc "GNU Guile" (version)
- #:license *LGPLv3+*
- #:command-name "guile"
- #:packager (assq-ref %guile-build-info 'packager)
- #:packager-version
- (assq-ref %guile-build-info 'packager-version))
- (exit 0))
- (else
- (error "unrecognized switch ~a" arg)))))))
- (define (finish args out)
-
- (when (and script-cell (not (car script-cell)))
- (error "the `-ds' switch requires the use of `-s' as well"))
-
-
- (set-program-arguments (cons arg0 args))
-
-
- (if (or turn-on-debugging?
- (and interactive? (not turn-off-debugging?)))
- (begin
- (set-default-vm-engine! 'debug)
- (set-vm-engine! 'debug)))
-
-
- `(
-
- (@ (ice-9 control) %)
- (begin
-
-
- ,@(if (and interactive? (not inhibit-user-init?))
- '((load-user-init))
- '())
-
- ,@(map (lambda (ext)
- `(set! %load-extensions (cons ,ext %load-extensions)))
- user-extensions)
-
-
- ,@(map (lambda (path)
- `(set! %load-path (cons ,path %load-path)))
- user-load-path)
- ,@(map (lambda (path)
- `(set! %load-compiled-path
- (cons ,path %load-compiled-path)))
- user-load-compiled-path)
-
- ,@(reverse! out)
-
- ,@(if entry-point
- `((,entry-point (command-line)))
- '())
- ,(if interactive?
-
-
- '((@ (ice-9 top-repl) top-repl))
-
-
- '(quit)))))
- (if (pair? args)
- (begin
- (set! arg0 (car args))
- (let ((slash (string-rindex arg0 #\/)))
- (set! usage-name
- (if slash (substring arg0 (1+ slash)) arg0)))
- (parse (cdr args) '()))
- (parse args '()))))
|