this should be the first working top-level
This commit is contained in:
parent
1f6fba80ba
commit
d6c8c400c6
|
@ -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 ()
|
||||
|
|
38
scsh/top.scm
38
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 <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))))))))))
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue