142 lines
4.3 KiB
Racket
142 lines
4.3 KiB
Racket
|
|
(module restart scheme/base
|
|
(require racket/cmdline)
|
|
|
|
(provide restart-mzscheme)
|
|
|
|
(define (restart-mzscheme init-argv adjust-flag-table argv init-namespace)
|
|
(let* ([result #t]
|
|
[args #f]
|
|
[version? #f]
|
|
[rep? #f]
|
|
[no-coll-paths? #f]
|
|
[no-init-file? #f]
|
|
[no-compiled? #f]
|
|
[scheme? #f]
|
|
[scheme-set? #f]
|
|
[print-error
|
|
(lambda (e)
|
|
(if (exn? e)
|
|
(eprintf "~a\n" (exn-message e))
|
|
(eprintf "Exception in init file: ~e\n" e)))]
|
|
[beginize (lambda (l)
|
|
(string-append
|
|
"(begin "
|
|
(apply string-append l)
|
|
")"))]
|
|
[load-scheme (lambda (s?)
|
|
(unless scheme-set?
|
|
(set! scheme? s?)
|
|
(set! scheme-set? #t)))]
|
|
[script (lambda (flags proc like s?)
|
|
`[,flags
|
|
,(lambda (f file) (load-scheme s?) (lambda () (proc file)))
|
|
(,(format "Same as -~a-" like) "file")])]
|
|
[table
|
|
`([multi
|
|
[("-e" "--eval")
|
|
,(lambda (f expr) (load-scheme #t) expr)
|
|
("Evaluates <expr>" "expr")]
|
|
[("-f" "--load")
|
|
,(lambda (f file) (load-scheme #t) (lambda () (load file)))
|
|
("Loads <file>" "file")]
|
|
[("-t" "--require")
|
|
,(lambda (f file) (load-scheme #f) (lambda () (namespace-require `(file ,file))))
|
|
("Requires <file>" "file")]
|
|
[("-l" "--lib")
|
|
,(lambda (f file) (load-scheme #f) (lambda () (namespace-require `(lib ,file))))
|
|
("Imports library <file>" "file")]]
|
|
[final
|
|
,(script '("-r" "--script") load "f" #t)
|
|
,(script '("-u" "--require-script") (lambda (f) (namespace-require `(file ,f))) "t" #f)]
|
|
[multi
|
|
[("-k")
|
|
,(lambda (f n m) (error 'mzscheme "The -k flag is not supported in this mode"))
|
|
("Load executable-embedded code from file offset <n> to <m>" "n" "m")]
|
|
[("-m" "--main")
|
|
,(lambda (f) (lambda ()
|
|
(when result
|
|
(eval `(main ,@(cdr args))))))
|
|
("Calls `main' with a list of argument strings, if no prior errors")]
|
|
[("-x" "--no-init-path")
|
|
,(lambda (f) (set! no-coll-paths? #t))
|
|
("Don't set current-library-collection-paths")]
|
|
[("-q" "--no-init-file")
|
|
,(lambda (f) (set! no-init-file? #t))
|
|
("Don't load \"~/.mzschemerc\" or \"mzscheme.rc\"")]
|
|
[("-c" "--no-compiled")
|
|
,(lambda (f) (set! no-compiled? #t))
|
|
("Don't use compiled bytecode")]
|
|
[("-v" "--version")
|
|
,(lambda (f) (set! version? #t))
|
|
("Show the version")]
|
|
[("-i" "--repl")
|
|
,(lambda (f) (load-scheme #t) (set! rep? #t))
|
|
("Run the read-eval-print loop")]
|
|
[("-b" "--binary")
|
|
,(lambda (f) (error 'mzscheme "The -b flag is not supported in this mode"))
|
|
("Read stdin and write stdout/stderr in binary mode")]])])
|
|
(parse-command-line
|
|
"mzscheme"
|
|
init-argv
|
|
table
|
|
void
|
|
'("ignored"))
|
|
(set! args #f)
|
|
(when (equal? argv #())
|
|
(set! scheme? #t)
|
|
(set! rep? #t))
|
|
(parse-command-line
|
|
"mzscheme"
|
|
argv
|
|
(adjust-flag-table table)
|
|
(lambda (exprs . rest)
|
|
(unless (null? rest)
|
|
(set! args rest))
|
|
;(when args (set! rest args))
|
|
(let ([n (make-base-empty-namespace)]
|
|
[argv (if args (list->vector args) (vector))])
|
|
(parameterize ([current-command-line-arguments argv]
|
|
[print-as-expression #f])
|
|
(thread-wait
|
|
(thread
|
|
(lambda ()
|
|
(current-namespace n)
|
|
(when no-compiled?
|
|
(use-compiled-file-paths null))
|
|
(let ([program (find-system-path 'exec-file)])
|
|
(when version? (display (banner)))
|
|
|
|
(find-library-collection-paths))
|
|
|
|
(init-namespace)
|
|
|
|
(when scheme?
|
|
(namespace-require 'scheme/init))
|
|
|
|
(let/ec k
|
|
(exit-handler
|
|
(lambda (status)
|
|
(set! result status)
|
|
(k #f)))
|
|
(let/ec escape
|
|
(for-each
|
|
(lambda (e)
|
|
(with-handlers ([void (lambda (e)
|
|
(print-error e)
|
|
(set! result #f)
|
|
(escape #f))])
|
|
(if (string? e)
|
|
(eval (read (open-input-string e)))
|
|
(e))))
|
|
exprs))
|
|
(when rep?
|
|
(unless no-init-file?
|
|
(let ([f (find-system-path 'init-file)])
|
|
(when (file-exists? f)
|
|
(with-handlers ([void print-error])
|
|
(load f)))))
|
|
(read-eval-print-loop)))))))))
|
|
`("arg"))
|
|
result)))
|