From d6c8c400c6a0af8b0eaac17b04d4d58a565aca01 Mon Sep 17 00:00:00 2001 From: marting Date: Fri, 8 Oct 1999 18:28:39 +0000 Subject: [PATCH] this should be the first working top-level --- scsh/startup.scm | 6 ----- scsh/top.scm | 58 +++++++++++++++++++++++++----------------------- 2 files changed, 30 insertions(+), 34 deletions(-) diff --git a/scsh/startup.scm b/scsh/startup.scm index 1f723aa..28d600d 100644 --- a/scsh/startup.scm +++ b/scsh/startup.scm @@ -10,7 +10,6 @@ (lambda (args) (parse-switches-and-execute args context)))) -(define holding-interrupt-handlers #f) ;;; Had to define these as the ones in s48's build.scm do not properly ;;; initialise ERROR-OUTPUT-PORT to stderr -- this is a bug in the vm's @@ -26,7 +25,6 @@ (let ((filename (translate filename))) (display (string-append "Writing " filename) (command-output)) (newline (command-output)) - (set! holding-interrupt-handlers (copy-vector (interrupt-handlers-vector))) ;JMG: it is set to # in the vm, so I omit it now ;;;(flush-the-symbol-table!) ;Gets restored at next use of string->symbol (write-image filename @@ -54,15 +52,11 @@ (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)) (init-fdports!) -; (display "start00" (current-error-port)) - ;JMG (init-scsh-hindbrain #t) ; Whatever. Relink & install scsh's I/O system. (call-with-current-continuation (lambda (halt) (set! %vm-prog-args (cons "scsh" args)) ; WRONG -- use image. (set-command-line-args! %vm-prog-args) - (set! holding-interrupt-handlers #f) (with-handler (simple-condition-handler halt (current-error-port)) (lambda () diff --git a/scsh/top.scm b/scsh/top.scm index 85919c8..7a736c7 100644 --- a/scsh/top.scm +++ b/scsh/top.scm @@ -31,9 +31,7 @@ ;;; 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))) + (load-into filename p)) (define (really-ensure-loaded noise . structs) (apply ensure-loaded structs)) @@ -77,6 +75,7 @@ (switches '()) ; A list of handler thunks (top-entry #f) ; -t (need-script? #f)) ; Found a -ds or -dm? + (display args (current-output-port)) (if (pair? args) (let ((arg (car args)) (args (cdr args))) @@ -159,21 +158,21 @@ ((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?)) @@ -184,7 +183,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") @@ -198,14 +197,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.")))) @@ -220,21 +219,23 @@ (get-reflective-tower (user-environment)) ; ??? name)) - (define (parse-switches-and-execute all-args context) - (receive (switches term-switch term-val top-entry args) - (parse-scsh-args (cdr all-args)) + (receive (switches term-switch term-val top-entry args) + (parse-scsh-args (cdr all-args)) (begin - (start-new-session context - (current-input-port) - (current-output-port) - (current-error-port) - args - term-switch) - - (with-interaction-environment ;useless ????????? - (user-environment) + ;;; restart-command-processor will provide one, but we need + ;;; one already in do-switches + (start-new-session context + (current-input-port) + (current-output-port) + (current-error-port) + args + term-switch) + (with-interaction-environment ;useless ????????? + (environment-for-commands) + (lambda () (begin + (init-scsh-signal) ;; Have to do these before calling DO-SWITCHES, because actions ;; performed while processing the switches may use these guys. (set-command-line-args! @@ -255,13 +256,14 @@ (interaction-environment))) (cond ((not term-switch) ; -- interactive - (init-scsh-vars #t) (restart-command-processor args context - (lambda () (display "welcome to scsh-0.6 alpha " + (lambda () + (display "welcome to scsh-0.6 alpha " (current-output-port)) - (in-package (user-environment) '())))) + (newline (current-output-port)) + (in-package (user-environment) '())))) ((eq? term-switch 'c) @@ -277,7 +279,7 @@ ;; Otherwise, the script executed as it loaded, ;; so we're done. - (else (exit 0))))))))) + (else (exit 0))))))))))