178 lines
5.8 KiB
Scheme
178 lines
5.8 KiB
Scheme
|
;;;
|
|||
|
;;; Copyright (c) 1985 Massachusetts Institute of Technology
|
|||
|
;;;
|
|||
|
;;; This material was developed by the Scheme project at the
|
|||
|
;;; Massachusetts Institute of Technology, Department of
|
|||
|
;;; Electrical Engineering and Computer Science. Permission to
|
|||
|
;;; copy this software, to redistribute it, and to use it for any
|
|||
|
;;; purpose is granted, subject to the following restrictions and
|
|||
|
;;; understandings.
|
|||
|
;;;
|
|||
|
;;; 1. Any copy made of this software must include this copyright
|
|||
|
;;; notice in full.
|
|||
|
;;;
|
|||
|
;;; 2. Users of this software agree to make their best efforts (a)
|
|||
|
;;; to return to the MIT Scheme project any improvements or
|
|||
|
;;; extensions that they make, so that these may be included in
|
|||
|
;;; future releases; and (b) to inform MIT of noteworthy uses of
|
|||
|
;;; this software.
|
|||
|
;;;
|
|||
|
;;; 3. All materials developed as a consequence of the use of
|
|||
|
;;; this software shall duly acknowledge such use, in accordance
|
|||
|
;;; with the usual standards of acknowledging credit in academic
|
|||
|
;;; research.
|
|||
|
;;;
|
|||
|
;;; 4. MIT has made no warrantee or representation that the
|
|||
|
;;; operation of this software will be error-free, and MIT is
|
|||
|
;;; under no obligation to provide any services, by way of
|
|||
|
;;; maintenance, update, or otherwise.
|
|||
|
;;;
|
|||
|
;;; 5. In conjunction with products arising from the use of this
|
|||
|
;;; material, there shall be no use of the name of the
|
|||
|
;;; Massachusetts Institute of Technology nor of any adaptation
|
|||
|
;;; thereof in any advertising, promotional, or sales literature
|
|||
|
;;; without prior written consent from MIT in each case.
|
|||
|
;;;
|
|||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
;;;
|
|||
|
;;; Modified by Texas Instruments Inc 8/15/85
|
|||
|
;;;
|
|||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|||
|
(define reset-typein-window
|
|||
|
(lambda ()
|
|||
|
(%clear-window typein-screen)))
|
|||
|
|
|||
|
;;; command-prompts
|
|||
|
|
|||
|
(define *command-prompt-string* #!false)
|
|||
|
|
|||
|
(define *command-prompt-displayed?* #!false)
|
|||
|
|
|||
|
(define *temporary-message-displayed?* #!false)
|
|||
|
|
|||
|
(define *prompt-should-be-erased?* #!false)
|
|||
|
|
|||
|
(define *t-msg* "")
|
|||
|
|
|||
|
(define reset-command-prompt!
|
|||
|
(lambda ()
|
|||
|
(set! *command-prompt-string* #!false)
|
|||
|
(set! *command-prompt-displayed?* #!false)))
|
|||
|
|
|||
|
(define set-command-prompt!
|
|||
|
(lambda (prompt)
|
|||
|
(set! *command-prompt-string* prompt)))
|
|||
|
|
|||
|
(define set-echo-prompt!
|
|||
|
(lambda (string)
|
|||
|
(set! *command-prompt-string* #!false)
|
|||
|
(set! *command-prompt-displayed?* #!false)
|
|||
|
(set! *temporary-message-displayed?* #!false)
|
|||
|
(set! *prompt-should-be-erased?* #!false)
|
|||
|
(write-prompt! string)))
|
|||
|
|
|||
|
(define erase-echo-prompt!
|
|||
|
(lambda ()
|
|||
|
(set! *command-prompt-string* #!false)
|
|||
|
(set! *command-prompt-displayed?* #!false)
|
|||
|
(set! *temporary-message-displayed?* #!false)
|
|||
|
(set! *prompt-should-be-erased?* #!false)
|
|||
|
(clear-prompt!)))
|
|||
|
|
|||
|
(define update-typein-window!
|
|||
|
(lambda ()
|
|||
|
(cond (*command-prompt-string*
|
|||
|
(write-prompt! *command-prompt-string*)
|
|||
|
(set! *command-prompt-string* #!false)
|
|||
|
(set! *command-prompt-displayed?* #!true)
|
|||
|
(set! *temporary-message-displayed?* #!false)
|
|||
|
(set! *prompt-should-be-erased?* #!true))
|
|||
|
|
|||
|
(*prompt-should-be-erased?*
|
|||
|
(set! *command-prompt-displayed?* #!false)
|
|||
|
(set! *temporary-message-displayed?* #!false)
|
|||
|
(set! *prompt-should-be-erased?* #!false)
|
|||
|
(clear-prompt!))
|
|||
|
|
|||
|
(*temporary-message-displayed?*
|
|||
|
(set! *prompt-should-be-erased?* #!true)
|
|||
|
(set! *command-prompt-displayed?* #!false)
|
|||
|
(set! *temporary-message-displayed?* #!false)))))
|
|||
|
|
|||
|
(define write-prompt!
|
|||
|
(lambda (string)
|
|||
|
(%clear-window typein-screen)
|
|||
|
(write-string! typein-screen string 0 0)))
|
|||
|
|
|||
|
(define clear-prompt!
|
|||
|
(lambda ()
|
|||
|
(%clear-window typein-screen)))
|
|||
|
|
|||
|
(define temporary-message
|
|||
|
(lambda (string)
|
|||
|
(set! *t-msg* string)
|
|||
|
(set-temp-message-status)
|
|||
|
(write-prompt! string)))
|
|||
|
|
|||
|
(define set-temp-message-status
|
|||
|
(lambda ()
|
|||
|
(set! *command-prompt-string* #!false)
|
|||
|
(set! *command-prompt-displayed?* #!false)
|
|||
|
(set! *prompt-should-be-erased?* #!false)
|
|||
|
(set! *temporary-message-displayed?* #!true)))
|
|||
|
|
|||
|
(define append-message
|
|||
|
(lambda (string)
|
|||
|
(set! *t-msg* (string-append *t-msg* string))
|
|||
|
(temporary-message *t-msg*)))
|
|||
|
|
|||
|
;;; prompting
|
|||
|
|
|||
|
(define prompt-for-pathname
|
|||
|
(lambda (prompt)
|
|||
|
(temporary-message prompt)
|
|||
|
(read-pathname-from-screen typein-screen)))
|
|||
|
|
|||
|
(define prompt-for-confirmation?
|
|||
|
(lambda (prompt)
|
|||
|
(define (loop)
|
|||
|
(let ((char (char-upcase (editor-read-char typein-screen))))
|
|||
|
(if (or (char=? #\Y char) (char=? #\N char))
|
|||
|
(char=? #\Y char)
|
|||
|
(loop))))
|
|||
|
(temporary-message prompt)
|
|||
|
(loop)))
|
|||
|
|
|||
|
|
|||
|
(define read-pathname-from-screen
|
|||
|
(let ((input-buffer (make-string 80 #\space)))
|
|||
|
(lambda (screen)
|
|||
|
(define erase-move-back
|
|||
|
(lambda (screen)
|
|||
|
(let ((cursor-x (%reify-port screen screen:cursor-x))
|
|||
|
(cursor-y (%reify-port screen screen:cursor-y))
|
|||
|
(set-cursor-pos
|
|||
|
(lambda (x y)
|
|||
|
(%reify-port! screen screen:cursor-x x)
|
|||
|
(%reify-port! screen screen:cursor-y y))))
|
|||
|
(set-cursor-pos (-1+ cursor-x) cursor-y)
|
|||
|
(princ #\space screen)
|
|||
|
(set-cursor-pos (-1+ cursor-x) cursor-y))))
|
|||
|
|
|||
|
(define (loop char ptr)
|
|||
|
(cond ((char=? char #\return) (substring input-buffer 0 ptr))
|
|||
|
((char=? char #\Backspace)
|
|||
|
(if (not (= ptr 0))
|
|||
|
(begin
|
|||
|
(erase-move-back screen)
|
|||
|
(loop (editor-read-char screen) (-1+ ptr)))
|
|||
|
(loop (editor-read-char screen) ptr)))
|
|||
|
((char-graphic? char)
|
|||
|
(princ char screen)
|
|||
|
(string-set! input-buffer ptr char)
|
|||
|
(loop (editor-read-char screen) (1+ ptr)))
|
|||
|
(else (loop (editor-read-char screen) ptr))))
|
|||
|
(loop (editor-read-char screen) 0))))
|
|||
|
|
|||
|
|