66 lines
1.8 KiB
Scheme
66 lines
1.8 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Miniature command processor.
|
||
|
|
|
||
|
|
(define (command-processor ignore args)
|
||
|
|
(let ((in (current-input-port))
|
||
|
|
(out (current-output-port))
|
||
|
|
(batch? (member "batch" args)))
|
||
|
|
(let loop ()
|
||
|
|
((call-with-current-continuation
|
||
|
|
(lambda (go)
|
||
|
|
(with-handler
|
||
|
|
(lambda (c punt)
|
||
|
|
(cond ((or (error? c) (interrupt? c))
|
||
|
|
(display-condition c out)
|
||
|
|
(go (if batch?
|
||
|
|
(lambda () 1)
|
||
|
|
loop)))
|
||
|
|
((warning? c)
|
||
|
|
(display-condition c out))
|
||
|
|
(else (punt))))
|
||
|
|
(lambda ()
|
||
|
|
(if (not batch?) (display "- " out))
|
||
|
|
(let ((form (read in)))
|
||
|
|
(cond ((eof-object? form)
|
||
|
|
(newline out)
|
||
|
|
(go (lambda () 0)))
|
||
|
|
((and (pair? form) (eq? (car form) 'unquote))
|
||
|
|
(case (cadr form)
|
||
|
|
((load)
|
||
|
|
(mini-load in)
|
||
|
|
(go loop))
|
||
|
|
((go)
|
||
|
|
(let ((form (read in)))
|
||
|
|
(go (lambda ()
|
||
|
|
(eval form (interaction-environment))))))
|
||
|
|
(else (error "unknown command" (cadr form)))))
|
||
|
|
(else
|
||
|
|
(call-with-values
|
||
|
|
(lambda () (eval form (interaction-environment)))
|
||
|
|
(lambda results
|
||
|
|
(for-each (lambda (result)
|
||
|
|
(write result out)
|
||
|
|
(newline out))
|
||
|
|
results)
|
||
|
|
(go loop))))))))))))))
|
||
|
|
|
||
|
|
(define (mini-load in)
|
||
|
|
(let ((c (peek-char in)))
|
||
|
|
(cond ((char=? c #\newline) (read-char in) #t)
|
||
|
|
((char-whitespace? c) (read-char in) (mini-load in))
|
||
|
|
(else
|
||
|
|
(let ((filename (read-string in char-whitespace?)))
|
||
|
|
(load filename)
|
||
|
|
(mini-load in))))))
|
||
|
|
|
||
|
|
(define (read-string port delimiter?)
|
||
|
|
(let loop ((l '()) (n 0))
|
||
|
|
(let ((c (peek-char port)))
|
||
|
|
(cond ((or (eof-object? c)
|
||
|
|
(delimiter? c))
|
||
|
|
(list->string (reverse l)))
|
||
|
|
(else
|
||
|
|
(loop (cons (read-char port) l) (+ n 1)))))))
|