removed most of the hacks due to restart-command-processor
This commit is contained in:
parent
f812d7e579
commit
6cc6334039
|
@ -8,8 +8,6 @@
|
|||
(define (make-scsh-starter)
|
||||
(let ((context (user-context)))
|
||||
(lambda (args)
|
||||
(display "off we go" (current-error-port))
|
||||
(display context)
|
||||
(parse-switches-and-execute args context))))
|
||||
|
||||
(define holding-interrupt-handlers #f)
|
||||
|
@ -41,14 +39,7 @@
|
|||
;;; to decide whether to do the scsh-var inits quietly or with warnings.
|
||||
|
||||
(define (dump-scsh fname)
|
||||
(really-dump-scsh-program
|
||||
(make-scsh-starter)
|
||||
; (display "hiii")
|
||||
; (let ((d (make-scsh-starter)))
|
||||
; (display "hiiiiiiiiiiii")
|
||||
; d)
|
||||
|
||||
fname))
|
||||
(really-dump-scsh-program (make-scsh-starter) fname))
|
||||
|
||||
;;; Init the scsh run-time's vars quietly before running the program.
|
||||
;;; This is what we export to the user for his programs.
|
||||
|
@ -63,28 +54,20 @@
|
|||
(define (scsh-stand-alone-resumer start)
|
||||
(usual-resumer ;sets up exceptions, interrupts, and current input & output
|
||||
(lambda (args) ; VM gives us our args, but not our program.
|
||||
(display "start0" (current-error-port))
|
||||
; (display "start0" (current-error-port))
|
||||
(init-fdports!)
|
||||
(display "start00" (current-error-port))
|
||||
; (display "start00" (current-error-port))
|
||||
;JMG (init-scsh-hindbrain #t) ; Whatever. Relink & install scsh's I/O system.
|
||||
(call-with-current-continuation
|
||||
(lambda (halt)
|
||||
(display "start" (current-error-port))
|
||||
(set! %vm-prog-args (cons "scsh" args)) ; WRONG -- use image.
|
||||
(display "start1" (current-error-port))
|
||||
(set-command-line-args! %vm-prog-args)
|
||||
(display "start2" (current-error-port))
|
||||
(let ((len (vector-length holding-interrupt-handlers)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((eq? i (- len 1)))
|
||||
(set-interrupt-handler
|
||||
i (vector-ref holding-interrupt-handlers i))))
|
||||
(display "start3" (current-error-port))
|
||||
(set! holding-interrupt-handlers #f)
|
||||
(display "start4" (current-error-port))
|
||||
(with-handler (simple-condition-handler halt (current-error-port))
|
||||
(lambda ()
|
||||
(let ((exit-val (start (command-line))))
|
||||
(if (integer? exit-val) exit-val 0))))))))) ; work around bug.
|
||||
(with-handler
|
||||
(simple-condition-handler halt (current-error-port))
|
||||
(lambda ()
|
||||
(let ((exit-val (start (command-line))))
|
||||
(if (integer? exit-val) exit-val 0))))))))) ; work around bug.
|
||||
|
||||
(define %vm-prog-args #f)
|
||||
|
136
scsh/top.scm
136
scsh/top.scm
|
@ -28,6 +28,16 @@
|
|||
(cond ((structure? s) s)
|
||||
(else (error "not a structure" s struct-name)))))
|
||||
|
||||
;;; ensure-loaded and load-into now write to noise-port anyway
|
||||
|
||||
(define (load-quietly filename p)
|
||||
(display "going to load now " (current-error-port))
|
||||
(load-into filename p)
|
||||
(display "loaded " (current-error-port)))
|
||||
|
||||
(define (really-ensure-loaded noise . structs)
|
||||
(apply ensure-loaded structs))
|
||||
|
||||
;;; The switches:
|
||||
;;; -o <struct> Open the structure in current package.
|
||||
;;; -n <package> Create new package, make it current package.
|
||||
|
@ -144,26 +154,26 @@
|
|||
(if (pair? switches)
|
||||
(let ((switch (car switches))
|
||||
(switches (cdr switches)))
|
||||
; (format #t "Doing switch ~a~%" switch)
|
||||
(format #t "Doing switch ~a~%" switch)
|
||||
(cond
|
||||
|
||||
((equal? switch "-ds")
|
||||
(load-quietly script-file (interaction-environment))
|
||||
; (format #t "loaded script ~s~%" script-file)
|
||||
(format #t "loaded script ~s~%" script-file)
|
||||
(lp switches #t))
|
||||
|
||||
((equal? switch "-dm")
|
||||
(load-quietly script-file (config-package))
|
||||
; (format #t "loaded module ~s~%" script-file)
|
||||
(format #t "loaded module ~s~%" script-file)
|
||||
(lp switches #t))
|
||||
|
||||
((string=? (car switch) "-l")
|
||||
; (format #t "loading file ~s~%" (cdr switch))
|
||||
(format #t "loading file ~s~%" (cdr switch))
|
||||
(load-quietly (cdr switch) (interaction-environment))
|
||||
(lp switches script-loaded?))
|
||||
|
||||
((string=? (car switch) "-lm")
|
||||
; (format #t "loading module file ~s~%" (cdr switch))
|
||||
(format #t "loading module file ~s~%" (cdr switch))
|
||||
(load-quietly (cdr switch) (config-package))
|
||||
(lp switches script-loaded?))
|
||||
|
||||
|
@ -174,7 +184,7 @@
|
|||
(really-ensure-loaded #f (get-struct cp struct-name))
|
||||
(package-open! (interaction-environment)
|
||||
(lambda () (get-struct cp struct-name)))
|
||||
; (format #t "Opened ~s~%" struct-name)
|
||||
(format #t "Opened ~s~%" struct-name)
|
||||
(lp switches script-loaded?)))
|
||||
|
||||
((string=? (car switch) "-n")
|
||||
|
@ -188,14 +198,14 @@
|
|||
(lp switches script-loaded?)))
|
||||
|
||||
((string=? (car switch) "-m")
|
||||
; (format #t "struct-name ~s~%" (cdr switch))
|
||||
(format #t "struct-name ~s~%" (cdr switch))
|
||||
(let ((struct (get-struct (config-package) (cdr switch))))
|
||||
; (format #t "struct-name ~s, struct ~s~%" (cdr switch) struct)
|
||||
(format #t "struct-name ~s, struct ~s~%" (cdr switch) struct)
|
||||
(let ((pack (structure-package struct)))
|
||||
; (format #t "package ~s~%" pack)
|
||||
(format #t "package ~s~%" pack)
|
||||
(set-interaction-environment! pack)
|
||||
(really-ensure-loaded #f struct)
|
||||
; (format #t "Switched to ~s~%" pack)
|
||||
(format #t "Switched to ~s~%" pack)
|
||||
(lp switches script-loaded?))))
|
||||
|
||||
(else (error "Impossible error in do-switches. Report to developers."))))
|
||||
|
@ -214,82 +224,44 @@
|
|||
(define (parse-switches-and-execute all-args context)
|
||||
(receive (switches term-switch term-val top-entry args)
|
||||
(parse-scsh-args (cdr all-args))
|
||||
(begin
|
||||
(begin
|
||||
(start-new-session context
|
||||
(current-input-port)
|
||||
(current-output-port)
|
||||
(current-error-port)
|
||||
args
|
||||
term-switch)
|
||||
|
||||
(display "hey there.." (current-error-port))
|
||||
; (display context (current-error-port))
|
||||
; (display (config-package))
|
||||
; (display (user-environment))
|
||||
((with-handler ; taken from command.scm
|
||||
command-loop-condition-handler
|
||||
(lambda ()
|
||||
(notify-on-interrupts (current-thread))
|
||||
(start-new-session context
|
||||
(current-input-port)
|
||||
(current-output-port)
|
||||
(current-error-port)
|
||||
args
|
||||
term-switch)
|
||||
(display "bye" (current-error-port))
|
||||
(display (config-package) (current-error-port))
|
||||
(display "ups" (current-error-port))
|
||||
|
||||
; (let ((commands usual-commands)
|
||||
; (build-in built-in-structures)
|
||||
; (meta-structs more-structures))
|
||||
; (call-with-values
|
||||
; (lambda ()
|
||||
; (make-user-envs commands build-in meta-structs))
|
||||
; (lambda (env init-thunk)
|
||||
(with-interaction-environment
|
||||
(with-interaction-environment ;useless ?????????
|
||||
(user-environment)
|
||||
(display "okay, but now ?" (current-error-port))
|
||||
(begin
|
||||
;(with-interaction-environment (user-environment) ; <-- from CONTEXT.
|
||||
(begin
|
||||
;; Have to do these before calling DO-SWITCHES, because actions
|
||||
;; performed while processing the switches may use these guys.
|
||||
(set-command-line-args!
|
||||
(cons (if (eq? term-switch 's)
|
||||
(if (string? term-val)
|
||||
term-val ; Script file.
|
||||
"file-descriptor-script"); -sfd <num>
|
||||
(car all-args))
|
||||
args))
|
||||
|
||||
;; Have to do these before calling DO-SWITCHES, because actions
|
||||
;; performed while processing the switches may use these guys.
|
||||
(set-command-line-args!
|
||||
(cons (if (eq? term-switch 's)
|
||||
(if (string? term-val)
|
||||
term-val ; Script file.
|
||||
"file-descriptor-script"); -sfd <num>
|
||||
(car all-args))
|
||||
args))
|
||||
;; Set HOME-DIRECTORY and EXEC-PATH-LIST,
|
||||
;; quietly if not running an interactive script.
|
||||
(init-scsh-vars term-switch)
|
||||
;; quietly if not running an interactive script.
|
||||
(init-scsh-vars term-switch)
|
||||
|
||||
(let* ((script-loaded? (do-switches switches term-val)))
|
||||
(if (and (not script-loaded?) ; There wasn't a -ds or -dm,
|
||||
(eq? term-switch 's)) ; but there is a script,
|
||||
(load-quietly term-val ; so load it now.
|
||||
(let* ((script-loaded? (do-switches switches term-val)))
|
||||
(if (and (not script-loaded?) ; There wasn't a -ds or -dm,
|
||||
(eq? term-switch 's)) ; but there is a script,
|
||||
(load-quietly term-val ; so load it now.
|
||||
(interaction-environment)))
|
||||
|
||||
(cond ((not term-switch) ; -- interactive
|
||||
(display "scsh is up" (current-error-port))
|
||||
(init-scsh-vars #t)
|
||||
(display "fdports installed" (current-error-port))
|
||||
; (interrupt-before-heap-overflow!)
|
||||
(let ((repl-data #f) ;no condition
|
||||
(repl-thunk real-command-loop))
|
||||
(let ((thunk (really-push-command-level repl-thunk
|
||||
repl-data
|
||||
(get-dynamic-env)
|
||||
'())))
|
||||
(ignore-further-interrupts)
|
||||
thunk)))
|
||||
;
|
||||
(command-loop
|
||||
;(lambda ()
|
||||
; (display "Scsh ")
|
||||
; (display scsh-version-string)
|
||||
; (newline))
|
||||
; #f))
|
||||
;; COMMAND-LOOP returns a continuation when it exits,
|
||||
;; which gets invoked outside the W-N-S above. I.e.,
|
||||
;; we "log out" and start over.
|
||||
(cond ((not term-switch) ; -- interactive
|
||||
(init-scsh-vars #t)
|
||||
(restart-command-processor
|
||||
args
|
||||
context
|
||||
(lambda () (display "welcome to scsh-0.6 alpha "
|
||||
(current-output-port))
|
||||
(in-package (user-environment) '()))))
|
||||
|
||||
|
||||
((eq? term-switch 'c)
|
||||
|
@ -305,8 +277,8 @@
|
|||
|
||||
;; Otherwise, the script executed as it loaded,
|
||||
;; so we're done.
|
||||
(else (exit 0))
|
||||
))))))))))))
|
||||
(else (exit 0)))))))))
|
||||
|
||||
|
||||
|
||||
(define (read-exactly-one-sexp-from-string s)
|
||||
|
@ -340,7 +312,7 @@ end-option: -s <script> Specify script.
|
|||
-sfd <num> Script is on file descriptor <num>.
|
||||
-c <exp> Evaluate expression.
|
||||
-- Interactive session.
|
||||
"))
|
||||
" (current-error-port)))
|
||||
(exit -1))
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue