scsh-0.5/env/command.scm

584 lines
18 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; 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)))))