mirror of
https://github.com/PDP-10/its.git
synced 2026-01-15 16:07:01 +00:00
103 lines
2.6 KiB
Common Lisp
Executable File
103 lines
2.6 KiB
Common Lisp
Executable File
;;;-*-LISP-*-
|
|
|
|
;;; user-query interfaces.
|
|
|
|
(HERALD USER-QUERY)
|
|
|
|
(EVAL-WHEN (EVAL COMPILE)
|
|
(OR (GET 'DO-WITH-TTY-ON 'MACRO)(LOAD '|LIBLSP;TTY FASL|)))
|
|
|
|
|
|
(DEFVAR TTY-RETURN-STACK NIL)
|
|
|
|
(DEFUN READ-HASH-SEQ ()
|
|
(DO ((K 0 (+ CHAR (* K 256)))
|
|
(CHAR (TYI TYI)(TYI TYI)))
|
|
((= CHAR #\CR) K)))
|
|
|
|
(DEFUN READ-PASS-WORD ()
|
|
(DO-WITH-TTY-OFF
|
|
(DO ((K1)(K2))
|
|
(())
|
|
(*CATCH 'RE-READ-PASS-WORD
|
|
(LET ((TTY-RETURN-STACK
|
|
(CONS '(PROGN (TERPRI TYO)
|
|
(PRINC "Interrupted, try again." TYO)
|
|
(*THROW 'RE-READ-PASS-WORD NIL))
|
|
TTY-RETURN-STACK)))
|
|
(CLEAR-INPUT TYI)
|
|
(TERPRI TYO)
|
|
(PRINC '|Input password->| TYO)
|
|
(SETQ K1 (READ-HASH-SEQ))
|
|
(PRINC '|again->| TYO)
|
|
(SETQ K2 (READ-HASH-SEQ))
|
|
(AND (= K1 K2) (RETURN K1))
|
|
(PRINC '|passwords didn't match, try again.| TYO))))))
|
|
|
|
|
|
(DEFUN READ-FILE-NAME (&OPTIONAL (PROBE-TEST NIL))
|
|
(DO ((N))
|
|
(())
|
|
(SETQ N (READ-UNTIL-CR '|File name->|))
|
|
(COND ((EQ N '||))
|
|
(T
|
|
(SETQ N (ERRSET (NAMELIST N) T))
|
|
(AND N (COND ((OR (NOT PROBE-TEST) (PROBEF (CAR N)))
|
|
(RETURN (CAR N)))
|
|
(T
|
|
(PRINC (NAMESTRING (CAR N)) TYO)
|
|
(PRINC '| is not an existing file.| TYO))))))))
|
|
|
|
(DEFVAR PROMPT)
|
|
(DEFVAR INPUT-CHAR-STACK NIL)
|
|
|
|
(DEFUN RE-DISPLAY ()
|
|
(PROGN (PRINC PROMPT TYO)
|
|
(MAPC #'(LAMBDA (X) (TYO X TYO))
|
|
(REVERSE INPUT-CHAR-STACK))))
|
|
|
|
(DEFUN READ-UNTIL-CR (PROMPT &AUX TTY-RETURN-STACK INPUT-CHAR-STACK)
|
|
(PUSH '(PROGN (CURSORPOS 'A TYO)
|
|
(RE-DISPLAY))
|
|
TTY-RETURN-STACK)
|
|
(cursorpos 'a tyo)
|
|
(PRINC PROMPT TYO)
|
|
(DO ((C (TYI TYI)(TYI TYI)))
|
|
((= C #\CR)
|
|
(IMPLODE (NREVERSE INPUT-CHAR-STACK)))
|
|
(COND ((= C #\RUBOUT)
|
|
(COND (INPUT-CHAR-STACK
|
|
(RUBOUT (POP INPUT-CHAR-STACK) TYO))))
|
|
((= C #\FF)
|
|
(RE-DISPLAY))
|
|
(T (PUSH C INPUT-CHAR-STACK)))))
|
|
|
|
(DEFUN TTY-RETURN (&REST IGNORED)
|
|
(AND TTY-RETURN-STACK (EVAL (CAR TTY-RETURN-STACK))))
|
|
|
|
(SETQ TTY-RETURN 'TTY-RETURN)
|
|
|
|
(DEFUN READ-CHARACTER (PROMPT &AUX INPUT-CHAR-STACK TTY-RETURN-STACK)
|
|
(PUSH '(PROGN (CURSORPOS 'A TYO) (RE-DISPLAY))
|
|
TTY-RETURN-STACK)
|
|
(RE-DISPLAY)
|
|
(DO ((C (TYI TYI) (TYI TYI)))
|
|
((NOT (= C #\FF)) C)
|
|
(RE-DISPLAY)))
|
|
|
|
(DEFUN Y-or-n-or-?-p (MESSAGE &OPTIONAL (EXPLAIN))
|
|
(FORMAT TYO "~&~A " MESSAGE)
|
|
(DO ((C))
|
|
(NIL)
|
|
(SETQ C (READ-CHARACTER '|(Y or N)?|))
|
|
(CASEQ C
|
|
((#/Y #/y)
|
|
(PRINC "es." TYO)
|
|
(RETURN T))
|
|
((#/N #/n)
|
|
(PRINC "o." TYO)
|
|
(RETURN NIL))
|
|
((#/? #/h #/H)
|
|
(IF EXPLAIN (FORMAT TYO "~&~A~%" EXPLAIN))
|
|
(FORMAT TYO "~&~A " MESSAGE))
|
|
(T NIL)))) |