this should be the first working top-level

This commit is contained in:
marting 1999-10-08 18:28:39 +00:00
parent 1f6fba80ba
commit d6c8c400c6
2 changed files with 30 additions and 34 deletions

View File

@ -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 ()

View File

@ -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 <entry>
(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))
(begin
;;; 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 ?????????
(user-environment)
(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,12 +256,13 @@
(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))
(newline (current-output-port))
(in-package (user-environment) '()))))
@ -277,7 +279,7 @@
;; Otherwise, the script executed as it loaded,
;; so we're done.
(else (exit 0)))))))))
(else (exit 0))))))))))