584 lines
18 KiB
Scheme
584 lines
18 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|||
|
|
|
|||
|
|
|
|||
|
|
; This is file command.scm.
|
|||
|
|
|
|||
|
|
; Command processor.
|
|||
|
|
|
|||
|
|
; The command processor's state is of three kinds:
|
|||
|
|
; 1. User context - preserved across dump commands.
|
|||
|
|
; This includes the designated user and configuration environments.
|
|||
|
|
; 2. Session state - one per "login"; not preserved across dump commands.
|
|||
|
|
; This includes ## and the command loop's interactive ports.
|
|||
|
|
; 3. Command levels - one for each different command level.
|
|||
|
|
; This includes any condition being handled, and continuations.
|
|||
|
|
|
|||
|
|
(define command-prefix #\,)
|
|||
|
|
|
|||
|
|
|
|||
|
|
; User context.
|
|||
|
|
|
|||
|
|
(define (make-user-context thunk)
|
|||
|
|
(let ((t (make-table)))
|
|||
|
|
(let-fluid $user-context t
|
|||
|
|
(lambda ()
|
|||
|
|
(for-each (lambda (name+thunk)
|
|||
|
|
(table-set! t (car name+thunk) ((cdr name+thunk))))
|
|||
|
|
*user-context-initializers*)
|
|||
|
|
(thunk)
|
|||
|
|
t))))
|
|||
|
|
|
|||
|
|
(define *user-context-initializers* '())
|
|||
|
|
|
|||
|
|
(define $user-context (make-fluid #f))
|
|||
|
|
; (set-fluid! $user-context (make-user-context unspecific)) ;Bad for GC
|
|||
|
|
(define (user-context) (fluid $user-context))
|
|||
|
|
|
|||
|
|
(define (user-context-accessor name initializer)
|
|||
|
|
(set! *user-context-initializers*
|
|||
|
|
(append *user-context-initializers*
|
|||
|
|
(list (cons name initializer))))
|
|||
|
|
(let ((probe (fluid $user-context)))
|
|||
|
|
(if probe (table-set! probe name (initializer))))
|
|||
|
|
(lambda ()
|
|||
|
|
(table-ref (user-context) name)))
|
|||
|
|
|
|||
|
|
(define (user-context-modifier name)
|
|||
|
|
(lambda (new)
|
|||
|
|
(table-set! (user-context) name new)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Session state.
|
|||
|
|
|
|||
|
|
(define session-type
|
|||
|
|
(make-record-type 'session '(input output values batch-mode? bow?)))
|
|||
|
|
(define make-session
|
|||
|
|
(record-constructor session-type
|
|||
|
|
'(input output values batch-mode? bow?)))
|
|||
|
|
(define $session
|
|||
|
|
(make-fluid (make-session (current-input-port)
|
|||
|
|
(current-output-port)
|
|||
|
|
'() #f #f)))
|
|||
|
|
(define (session-accessor name)
|
|||
|
|
(let ((a (record-accessor session-type name)))
|
|||
|
|
(lambda () (a (fluid $session)))))
|
|||
|
|
(define (session-modifier name)
|
|||
|
|
(let ((m (record-modifier session-type name)))
|
|||
|
|
(lambda (new) (m (fluid $session) new))))
|
|||
|
|
(define command-input (session-accessor 'input))
|
|||
|
|
(define command-output (session-accessor 'output))
|
|||
|
|
(define focus-values (session-accessor 'values))
|
|||
|
|
(define set-focus-values! (session-modifier 'values))
|
|||
|
|
(define batch-mode? (session-accessor 'batch-mode?))
|
|||
|
|
(define set-batch-mode?! (session-modifier 'batch-mode?))
|
|||
|
|
(define break-on-warnings? (session-accessor 'bow?))
|
|||
|
|
(define set-break-on-warnings?! (session-modifier 'bow?))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Command levels.
|
|||
|
|
|
|||
|
|
(define $command-levels (make-fluid '()))
|
|||
|
|
(define (command-level) (car (fluid $command-levels)))
|
|||
|
|
|
|||
|
|
(define :command-level
|
|||
|
|
(make-record-type 'command-level
|
|||
|
|
'(throw vm-cont condition interrupts
|
|||
|
|
;; env
|
|||
|
|
)))
|
|||
|
|
(define make-command-level
|
|||
|
|
(record-constructor :command-level
|
|||
|
|
'(throw vm-cont condition interrupts
|
|||
|
|
;; env
|
|||
|
|
)))
|
|||
|
|
(define command-level? (record-predicate :command-level))
|
|||
|
|
(define command-level-throw
|
|||
|
|
(record-accessor :command-level 'throw))
|
|||
|
|
(define command-level-vm-cont
|
|||
|
|
(record-accessor :command-level 'vm-cont))
|
|||
|
|
(define command-level-condition
|
|||
|
|
(record-accessor :command-level 'condition))
|
|||
|
|
(define command-level-interrupts
|
|||
|
|
(record-accessor :command-level 'interrupts))
|
|||
|
|
;(define command-level-env
|
|||
|
|
; (record-accessor :command-level 'env))
|
|||
|
|
;(define set-command-level-env!
|
|||
|
|
; (record-modifier :command-level 'env))
|
|||
|
|
|
|||
|
|
(define environment-for-commands interaction-environment)
|
|||
|
|
|
|||
|
|
; --------------------
|
|||
|
|
; Main entry point.
|
|||
|
|
|
|||
|
|
(define (with-user-context context thunk)
|
|||
|
|
(let-fluid $user-context context thunk)) ; Log in.
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (with-new-session context iport oport resume-args batch? thunk)
|
|||
|
|
(let-fluids $user-context context
|
|||
|
|
$command-levels '()
|
|||
|
|
$session (make-session iport oport resume-args batch? #f)
|
|||
|
|
thunk))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;; The double-paren around the w-n-s is because it returns a continuation
|
|||
|
|
;; which is the thing to do after the command-processor exits.
|
|||
|
|
|
|||
|
|
(define (start-command-processor resume-args context
|
|||
|
|
;; initial-env
|
|||
|
|
start-thunk)
|
|||
|
|
(interrupt-before-heap-overflow!)
|
|||
|
|
((with-new-session context
|
|||
|
|
(current-input-port) (current-output-port)
|
|||
|
|
resume-args (and (pair? resume-args)
|
|||
|
|
(equal? (car resume-args) "batch"))
|
|||
|
|
(lambda ()
|
|||
|
|
(command-loop start-thunk #f
|
|||
|
|
;; initial-env
|
|||
|
|
)))))
|
|||
|
|
|
|||
|
|
; Entry for initialization & testing.
|
|||
|
|
|
|||
|
|
(define (command-processor command-env args)
|
|||
|
|
(start-command-processor args
|
|||
|
|
(make-user-context
|
|||
|
|
(lambda ()
|
|||
|
|
(set-user-command-environment! command-env)))
|
|||
|
|
;; (interaction-environment)
|
|||
|
|
unspecific))
|
|||
|
|
|
|||
|
|
; Command loop
|
|||
|
|
; Uses:
|
|||
|
|
; 1. startup, 2. condition handler, 3. abort-to-level, 4. breakpoint
|
|||
|
|
|
|||
|
|
(define (command-loop start-thunk condition
|
|||
|
|
;; env
|
|||
|
|
)
|
|||
|
|
(call-with-command-level condition ;; env
|
|||
|
|
(lambda (level)
|
|||
|
|
(start-command-level start-thunk level))))
|
|||
|
|
|
|||
|
|
(define (call-with-command-level condition
|
|||
|
|
;; env
|
|||
|
|
proc)
|
|||
|
|
(primitive-catch
|
|||
|
|
(lambda (vm-cont)
|
|||
|
|
((call-with-current-continuation
|
|||
|
|
(lambda (throw)
|
|||
|
|
(proc (make-command-level throw vm-cont condition
|
|||
|
|
(enabled-interrupts)
|
|||
|
|
;; env
|
|||
|
|
))))))))
|
|||
|
|
|
|||
|
|
(define (start-command-level start-thunk level)
|
|||
|
|
(with-handler command-loop-condition-handler
|
|||
|
|
(lambda ()
|
|||
|
|
(let-fluids $command-levels (cons level (fluid $command-levels))
|
|||
|
|
$note-undefined #f ;useful
|
|||
|
|
(lambda ()
|
|||
|
|
;;(with-interaction-environment (command-level-env level)
|
|||
|
|
;;(lambda ()
|
|||
|
|
(start-thunk)
|
|||
|
|
(let ((condition (command-level-condition level)))
|
|||
|
|
(if condition
|
|||
|
|
(display-condition condition (command-output)))
|
|||
|
|
(if (not (= (enabled-interrupts) all-interrupts))
|
|||
|
|
(begin (if (not (and (interrupt? condition)
|
|||
|
|
(= (caddr condition) all-interrupts)))
|
|||
|
|
(write-line "(Enabling interrupts)"
|
|||
|
|
(command-output)))
|
|||
|
|
(set-enabled-interrupts! all-interrupts))))
|
|||
|
|
(let loop ()
|
|||
|
|
(let ((command (read-command-carefully (command-prompt)
|
|||
|
|
(form-preferred?)
|
|||
|
|
(command-input))))
|
|||
|
|
(showing-focus-object
|
|||
|
|
(lambda ()
|
|||
|
|
(execute-command command)))
|
|||
|
|
(loop))))))));;))
|
|||
|
|
|
|||
|
|
(define form-preferred?
|
|||
|
|
(user-context-accessor 'form-preferred? (lambda () #t)))
|
|||
|
|
|
|||
|
|
; Command level control
|
|||
|
|
|
|||
|
|
(define (pop-command-level)
|
|||
|
|
(let ((levels (fluid $command-levels)))
|
|||
|
|
(if (null? (cdr levels))
|
|||
|
|
(if (or (batch-mode?)
|
|||
|
|
(y-or-n? "Exit the Scheme Shell" #t))
|
|||
|
|
(exit-command-processor (lambda () 0))
|
|||
|
|
(abort-to-command-level (car levels)))
|
|||
|
|
(abort-to-command-level (cadr levels)))))
|
|||
|
|
|
|||
|
|
(define (abort-to-command-level level)
|
|||
|
|
(throw-to-command-level
|
|||
|
|
level
|
|||
|
|
(lambda ()
|
|||
|
|
(start-command-level
|
|||
|
|
(lambda ()
|
|||
|
|
(cond ((command-level-condition level)
|
|||
|
|
(display "Back to" (command-output)))
|
|||
|
|
((null? (fluid $command-levels))
|
|||
|
|
(newline (command-output))
|
|||
|
|
(write-line "Top level" (command-output)))))
|
|||
|
|
;; Condition will be displayed.
|
|||
|
|
level))))
|
|||
|
|
|
|||
|
|
(define (throw-to-command-level level thunk)
|
|||
|
|
((command-level-throw level) thunk))
|
|||
|
|
|
|||
|
|
(define (exit-command-processor thunk)
|
|||
|
|
(throw-to-command-level (top-command-level)
|
|||
|
|
(lambda () thunk)))
|
|||
|
|
|
|||
|
|
; Condition handler
|
|||
|
|
|
|||
|
|
(define (command-loop-condition-handler c next-handler)
|
|||
|
|
(cond ((or (warning? c) (note? c))
|
|||
|
|
(if (break-on-warnings?)
|
|||
|
|
(deal-with-condition c)
|
|||
|
|
(begin (display-condition c (command-output))
|
|||
|
|
(unspecific)))) ;proceed
|
|||
|
|
((or (error? c) (interrupt? c))
|
|||
|
|
(if (batch-mode?)
|
|||
|
|
(begin (display-condition c (command-output))
|
|||
|
|
(let ((status (if (error? c) 1 2)))
|
|||
|
|
(exit-command-processor (lambda () status))))
|
|||
|
|
(deal-with-condition c)))
|
|||
|
|
(else
|
|||
|
|
(next-handler))))
|
|||
|
|
|
|||
|
|
(define push-command-levels?
|
|||
|
|
(user-context-accessor 'push-command-levels (lambda () #t)))
|
|||
|
|
;(define set-push-command-levels?!
|
|||
|
|
; (user-context-modifier 'push-command-levels))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (deal-with-condition c)
|
|||
|
|
(if (push-command-levels?)
|
|||
|
|
(command-loop list c
|
|||
|
|
;; (interaction-environment)
|
|||
|
|
)
|
|||
|
|
(call-with-command-level c ;; (interaction-environment)
|
|||
|
|
(lambda (level)
|
|||
|
|
(set-focus-object! level)
|
|||
|
|
(display-condition c (command-output))
|
|||
|
|
(abort-to-command-level (car (fluid $command-levels)))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define-condition-type 'note '())
|
|||
|
|
(define note? (condition-predicate 'note))
|
|||
|
|
|
|||
|
|
(define (command-prompt)
|
|||
|
|
(let ((level (- (length (fluid $command-levels)) 1))
|
|||
|
|
(id (environment-id-string (environment-for-commands))))
|
|||
|
|
(string-append (if (= level 0)
|
|||
|
|
""
|
|||
|
|
(number->string level))
|
|||
|
|
(if (or (= level 0) (= (string-length id) 0))
|
|||
|
|
""
|
|||
|
|
" ")
|
|||
|
|
id
|
|||
|
|
"> ")))
|
|||
|
|
|
|||
|
|
(define-generic environment-id-string &environment-id-string (env))
|
|||
|
|
|
|||
|
|
(define-method &environment-id-string (env) "")
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Evaluate a form
|
|||
|
|
|
|||
|
|
(define (evaluate-and-select form env)
|
|||
|
|
(call-with-values (lambda ()
|
|||
|
|
(evaluate form env))
|
|||
|
|
(lambda results
|
|||
|
|
(if (or (null? results)
|
|||
|
|
(not (null? (cdr results)))
|
|||
|
|
(not (eq? (car results) (unspecific))))
|
|||
|
|
(set-focus-values! results))
|
|||
|
|
(apply values results))))
|
|||
|
|
|
|||
|
|
(define-generic evaluate &evaluate (form env))
|
|||
|
|
|
|||
|
|
(define-method &evaluate (form env) (eval form env))
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Display the focus object if it changes (sort of like emacs's redisplay)
|
|||
|
|
|
|||
|
|
(define (showing-focus-object thunk)
|
|||
|
|
(let ((focus-before (focus-values)))
|
|||
|
|
(thunk)
|
|||
|
|
(let ((focus-after (focus-values)))
|
|||
|
|
(if (not (eq? focus-after focus-before))
|
|||
|
|
(show-command-results focus-after)))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (focus-object)
|
|||
|
|
(let ((v (focus-values)))
|
|||
|
|
(if (and (pair? v) (null? (cdr v))) (car v) v)))
|
|||
|
|
|
|||
|
|
(define (set-focus-object! obj)
|
|||
|
|
(set-focus-values! (list obj)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (show-command-results results)
|
|||
|
|
(cond ((null? results))
|
|||
|
|
((not (null? (cdr results)))
|
|||
|
|
(let ((out (command-output)))
|
|||
|
|
(display "; " out)
|
|||
|
|
(write (length results) out)
|
|||
|
|
(display " values" out)
|
|||
|
|
(newline out))
|
|||
|
|
(for-each show-command-result results))
|
|||
|
|
(else ;(not (eq? (car results) (unspecific)))
|
|||
|
|
(show-command-result (car results)))))
|
|||
|
|
|
|||
|
|
(define (show-command-result result)
|
|||
|
|
(write-carefully (value->expression result)
|
|||
|
|
(command-output))
|
|||
|
|
(newline (command-output)))
|
|||
|
|
|
|||
|
|
(define $write-depth (make-fluid -1))
|
|||
|
|
(define $write-length (make-fluid -1))
|
|||
|
|
|
|||
|
|
(define (write-carefully x port)
|
|||
|
|
(if (error? (ignore-errors (lambda ()
|
|||
|
|
(limited-write x port
|
|||
|
|
(fluid $write-depth)
|
|||
|
|
(fluid $write-length))
|
|||
|
|
#f)))
|
|||
|
|
(display "<Error while printing.>" port)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Sentinels - run after every command.
|
|||
|
|
|
|||
|
|
(define *sentinels* '())
|
|||
|
|
(define (run-sentinels)
|
|||
|
|
(for-each (lambda (sentinel) (sentinel)) *sentinels*))
|
|||
|
|
(define (add-sentinel! sentinel)
|
|||
|
|
(if (not (memq sentinel *sentinels*))
|
|||
|
|
(set! *sentinels* (cons sentinel *sentinels*))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Commands.
|
|||
|
|
|
|||
|
|
(define command-environment
|
|||
|
|
(user-context-accessor 'command-environment interaction-environment))
|
|||
|
|
|
|||
|
|
;(define *command-structure* (unspecific))
|
|||
|
|
;
|
|||
|
|
;(define (command-structure)
|
|||
|
|
; *command-structure*)
|
|||
|
|
;
|
|||
|
|
;(define (set-command-structure! structure) ; called on initial startup
|
|||
|
|
; (set! *command-structure* structure))
|
|||
|
|
|
|||
|
|
(define command-syntax-table (make-table))
|
|||
|
|
(define *command-help* '())
|
|||
|
|
|
|||
|
|
(define (get-command-syntax name)
|
|||
|
|
(or (table-ref (user-command-syntax-table) name)
|
|||
|
|
(table-ref command-syntax-table name)))
|
|||
|
|
|
|||
|
|
(define (define-command-syntax name help1 help2 arg-descriptions)
|
|||
|
|
(table-set! command-syntax-table name arg-descriptions)
|
|||
|
|
(if help1
|
|||
|
|
(set! *command-help* (add-help *command-help* name help1 help2))))
|
|||
|
|
|
|||
|
|
(define (add-help help name help1 help2)
|
|||
|
|
(insert (list name
|
|||
|
|
(string-append (symbol->string name) " " help1)
|
|||
|
|
help2)
|
|||
|
|
help
|
|||
|
|
(lambda (z1 z2)
|
|||
|
|
(string<=? (cadr z1) (cadr z2)))))
|
|||
|
|
|
|||
|
|
(define user-command-syntax-table
|
|||
|
|
(user-context-accessor 'user-command-syntax-table (lambda () (make-table))))
|
|||
|
|
|
|||
|
|
(define user-command-environment
|
|||
|
|
(user-context-accessor 'user-command-environment (lambda () #f)))
|
|||
|
|
|
|||
|
|
(define set-user-command-environment!
|
|||
|
|
(user-context-modifier 'user-command-environment))
|
|||
|
|
|
|||
|
|
(define user-command-help
|
|||
|
|
(user-context-accessor 'user-command-help (lambda () *command-help*)))
|
|||
|
|
|
|||
|
|
(define set-user-command-help!
|
|||
|
|
(user-context-modifier 'user-command-help))
|
|||
|
|
|
|||
|
|
(define (define-user-command-syntax name help1 help2 arg-descriptions)
|
|||
|
|
(table-set! (user-command-syntax-table) name arg-descriptions)
|
|||
|
|
(if help1
|
|||
|
|
(set-user-command-help!
|
|||
|
|
(add-help (user-command-help) name help1 help2))))
|
|||
|
|
|
|||
|
|
(define (execute-command command)
|
|||
|
|
(cond ((eof-object? command)
|
|||
|
|
(newline (command-output))
|
|||
|
|
(pop-command-level))
|
|||
|
|
((not command)) ; error while reading
|
|||
|
|
(else
|
|||
|
|
(let* ((name (car command))
|
|||
|
|
(proc (evaluate name (user-command-environment))))
|
|||
|
|
(dynamic-wind (lambda () #f)
|
|||
|
|
(lambda ()
|
|||
|
|
(apply proc (cdr command)))
|
|||
|
|
run-sentinels)))))
|
|||
|
|
|
|||
|
|
; help
|
|||
|
|
|
|||
|
|
(define (help . maybe-id)
|
|||
|
|
(if (null? maybe-id)
|
|||
|
|
(list-commands)
|
|||
|
|
(print-command-help (car maybe-id))))
|
|||
|
|
|
|||
|
|
(define (print-command-help id)
|
|||
|
|
(let ((o-port (command-output)))
|
|||
|
|
(display #\space o-port)
|
|||
|
|
(cond ((assq id (user-command-help))
|
|||
|
|
=> (lambda (data)
|
|||
|
|
(if (form-preferred?) (display command-prefix o-port))
|
|||
|
|
(display (cadr data) o-port)
|
|||
|
|
(display " " o-port)
|
|||
|
|
(display (caddr data) o-port)))
|
|||
|
|
(else
|
|||
|
|
(display #\" o-port)
|
|||
|
|
(display id o-port)
|
|||
|
|
(display #\" o-port)
|
|||
|
|
(display #\space o-port)
|
|||
|
|
(display "is not a command.")))
|
|||
|
|
(newline o-port)))
|
|||
|
|
|
|||
|
|
(define (list-commands)
|
|||
|
|
(let ((o-port (command-output))
|
|||
|
|
(widest 28)
|
|||
|
|
(f? (form-preferred?)))
|
|||
|
|
(for-each (lambda (s)
|
|||
|
|
(write-line s o-port))
|
|||
|
|
'(
|
|||
|
|
"This is an alpha-test version of Scheme 48. You are interacting with"
|
|||
|
|
"the command processor. A command is either a Scheme form to evaluate"
|
|||
|
|
"or one of the following:"
|
|||
|
|
""))
|
|||
|
|
|
|||
|
|
(list-command-help (user-command-help) f? o-port)
|
|||
|
|
(for-each (lambda (s)
|
|||
|
|
(write-line s o-port))
|
|||
|
|
'(
|
|||
|
|
""
|
|||
|
|
"Square brackets [...] indicate optional arguments."
|
|||
|
|
""
|
|||
|
|
"The expression ## evaluates to the last value displayed by the command"
|
|||
|
|
"processor."
|
|||
|
|
))))
|
|||
|
|
|
|||
|
|
(define (list-command-help data prefix? o-port)
|
|||
|
|
(let* ((strings (map (if prefix?
|
|||
|
|
(lambda (d)
|
|||
|
|
(string-append (command-prefix-string
|
|||
|
|
command-prefix)
|
|||
|
|
(cadr d)))
|
|||
|
|
cadr)
|
|||
|
|
data))
|
|||
|
|
(count (length strings))
|
|||
|
|
(back-half (list-tail strings (quotient (+ 1 count) 2))))
|
|||
|
|
(let loop ((s1 strings) (s2 back-half))
|
|||
|
|
(cond ((not (eq? s1 back-half))
|
|||
|
|
(display #\space o-port)
|
|||
|
|
(display (car s1) o-port)
|
|||
|
|
(write-spaces (max 1 (- 32 (string-length (car s1)))) o-port)
|
|||
|
|
(if (not (null? s2))
|
|||
|
|
(display (car s2) o-port))
|
|||
|
|
(newline o-port)
|
|||
|
|
(loop (cdr s1) (if (null? s2) s2 (cdr s2))))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Utilities
|
|||
|
|
|
|||
|
|
(define (top-command-level)
|
|||
|
|
(last (fluid $command-levels)))
|
|||
|
|
|
|||
|
|
(define (error-form proc args)
|
|||
|
|
(cons proc (map value->expression args)))
|
|||
|
|
|
|||
|
|
(define (value->expression obj) ;mumble
|
|||
|
|
(if (or (number? obj) (char? obj) (string? obj) (boolean? obj))
|
|||
|
|
obj
|
|||
|
|
`',obj))
|
|||
|
|
|
|||
|
|
(define (write-spaces count o-port)
|
|||
|
|
(do ((count count (- count 1)))
|
|||
|
|
((<= count 0))
|
|||
|
|
(display #\space o-port)))
|
|||
|
|
|
|||
|
|
(define (command-prefix-string prefix)
|
|||
|
|
(cond ((string? prefix) prefix)
|
|||
|
|
((char? prefix) (string prefix))
|
|||
|
|
((symbol? prefix) (symbol->string prefix))))
|
|||
|
|
|
|||
|
|
(define (write-line string port)
|
|||
|
|
(display string port)
|
|||
|
|
(newline port))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (y-or-n? question eof-value)
|
|||
|
|
(let ((i-port (command-input))
|
|||
|
|
(o-port (command-output)))
|
|||
|
|
(let loop ((count *y-or-n-eof-count*))
|
|||
|
|
(display question o-port)
|
|||
|
|
(display " (y/n)? " o-port)
|
|||
|
|
(let ((line (read-line i-port)))
|
|||
|
|
(cond ((eof-object? line)
|
|||
|
|
(newline o-port)
|
|||
|
|
(if (= count 0)
|
|||
|
|
eof-value
|
|||
|
|
(begin (display "I'll only ask another " o-port)
|
|||
|
|
(write count o-port)
|
|||
|
|
(display " times." o-port)
|
|||
|
|
(newline o-port)
|
|||
|
|
(loop (- count 1)))))
|
|||
|
|
((< (string-length line) 1) (loop count))
|
|||
|
|
((char=? (string-ref line 0) #\y) #t)
|
|||
|
|
((char=? (string-ref line 0) #\n) #f)
|
|||
|
|
(else (loop count)))))))
|
|||
|
|
|
|||
|
|
(define *y-or-n-eof-count* 100)
|
|||
|
|
|
|||
|
|
(define (read-line port)
|
|||
|
|
(let loop ((l '()))
|
|||
|
|
(let ((c (read-char port)))
|
|||
|
|
(if (eof-object? c)
|
|||
|
|
c
|
|||
|
|
(if (char=? c #\newline)
|
|||
|
|
(list->string (reverse l))
|
|||
|
|
(loop (cons c l)))))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (greet-user info)
|
|||
|
|
(let ((port (command-output)))
|
|||
|
|
(display "Welcome to Scheme 48 " port)
|
|||
|
|
(display version-info port)
|
|||
|
|
(if info
|
|||
|
|
(begin (write-char #\space port)
|
|||
|
|
(display info port)))
|
|||
|
|
(display "." port)
|
|||
|
|
(newline port)
|
|||
|
|
(write-line "Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees."
|
|||
|
|
port)
|
|||
|
|
(write-line "Please report bugs to scheme-48-bugs@martigny.ai.mit.edu."
|
|||
|
|
port)
|
|||
|
|
(if (not (batch-mode?))
|
|||
|
|
(write-line "Type ,? (comma question-mark) for help." port))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define (command-continuation) ;utility for debugger
|
|||
|
|
(let ((obj (focus-object)))
|
|||
|
|
(command-level-vm-cont
|
|||
|
|
(if (command-level? obj)
|
|||
|
|
obj
|
|||
|
|
(command-level)))))
|