diff --git a/scsh/startup.scm b/scsh/startup.scm index 6162fc5..1f723aa 100644 --- a/scsh/startup.scm +++ b/scsh/startup.scm @@ -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) + \ No newline at end of file diff --git a/scsh/top.scm b/scsh/top.scm index 45e78f3..85919c8 100644 --- a/scsh/top.scm +++ b/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 Open the structure in current package. ;;; -n 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.")))) @@ -208,88 +218,50 @@ (define (new-empty-package name) (make-simple-package '() #t (get-reflective-tower (user-environment)) ; ??? - name)) + name)) (define (parse-switches-and-execute all-args context) (receive (switches term-switch term-val top-entry args) (parse-scsh-args (cdr all-args)) - (begin - - (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 + (begin + (start-new-session context + (current-input-port) + (current-output-port) + (current-error-port) + args + term-switch) + + (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 - (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 + (car all-args)) + args)) ;; Set HOME-DIRECTORY and EXEC-PATH-LIST, - ;; 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. + ;; 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. (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