home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
lispmachine.zip
/
lmiter.lsp
< prev
next >
Wrap
Text File
|
1988-08-16
|
42KB
|
1,453 lines
;;; -*- PACKAGE:KERMIT; BASE: 8; IBASE: 8; MODE:LISP -*-
;******************************************************************************
; Copyright (c) 1984, 1985 by Lisp Machine Inc.
; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
; Permission to copy all or part of this material is granted, provided
; that the copies are not made or distributed for resale, and the
; copyright notices and reference to the source file and the software
; distribution version appear, and that notice is given that copying is
; by permission of Lisp Machine Inc. LMI reserves for itself the
; sole commercial right to use any part of this KERMIT/H19-Emulator
; not covered by any Columbia University copyright. Inquiries concerning
; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
;
; Version Information:
; LMKERMIT 1.0 -- Original LMI code, plus edit ;1; for 3600 port
;
; Authorship Information:
; Mark David (LMI) Original version, using KERMIT.C as a guide
; George Carrette (LMI) Various enhancements
; Mark Ahlstrom (Honeywell) Port to 3600 (edits marked with ";1;" comments)
;
; Author Addresses:
; George Carrette ARPANET: GJC at MIT-MC
;
; Mark Ahlstrom ARPANET: Ahlstrom at HI-Multics
; PHONE: (612) 887-4006
; USMAIL: Honeywell MN09-1400
; Computer Sciences Center
; 10701 Lyndale Avenue South
; Bloomington, MN 55420
;******************************************************************************
;;; This program is KERMIT-TERMINAL.
;;;
;;; This is to be used to make your lisp machine terminal
;;; act like it is an "H19" terminal.
;;;
;;; No flavors are defined in this file. None of this code
;;; depends on anything having to do with flavors, except
;;; in so far as the lisp machine graphics operations require.
;;; This code contains a refreshingly low density of "messages."
;;; This makes the code so simple, I consider it ALMOST self explanatory.
;;;
;;; No "special" window is required. That is, a lisp listener
;;; should do fine. A tv:minimum-window will not, of course, work.
;;;
;;; For the H19 graphics protocol, see the Zenith manual for
;;; the Z29 terminal, which is available from the documentation
;;; department of LMI.
;;; ("Z-29 user's & technical guide"
;;; Appendix B -- Zenith Mode Code Info
;;; 1983, Zenith Data Systems.)
;;;
;;;
;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;;; special variables
;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; To use this, you only need to bind three special variables:
;;; 1. *TERMINAL* This must be bound to a local input output window
;;; that gets input from the lisp machine's keyboard
;;; and mouse.
;;; 2. *SERIAL-STREAM*
;;; This must be bound to an serial stream (or some stream
;;; than supports the operations we use in this code.)
;;; To get this stream, on a Lambda Lisp Machine,
;;; you usually just call si:make-sdu-serial-stream
;;; with no arguments.
;;; 3. interaction-pane
;;; This is a pane in which to bind debug-io, trace-output, query-io, use
;;; the NETWORK key interactions and in general any thing not involved
;;; in normal terminal interaction.
;;; It will work (if you have a normal window for example) to just
;;; have this be the same stream as *terminal* is bound to. The requirement
;;; is that IT MUST BE AN EXPOSED WINDOW!!
;;;
(DEFCONST *ESCAPE-DISPATCH-TABLE* (MAKE-HASH-TABLE))
(DECLARE (SPECIAL INTERACTION-PANE
kermit-frame ;1;
))
(DEFCONST *SERIAL-STREAM* :unbound)
(DEFCONST *TERMINAL* :unbound)
(DEFCONST *BAD-ESCAPES* ())
(defconst *local-echo-mode* nil)
(DEFCONST *LOGFILE* NIL) ;where to log terminal session, if desired
(DEFCONST TURN-ON-LOGGING? NIL)
(DEFCONST *TERMINAL-DEBUG-MODE* NIL)
;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; TERMINAL GRAPHICS AND OUTPUT "PRIMITIVES"
;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
(DEFCONST *INSERT-FLAG* ())
(DEFCONST *REVERSE-VIDEO-FLAG* ())
(DEFCONST *CURSOR-SAVE* '(0 0))
(DEFCONST *SYSTEM-POSITION* '(0 0))
(DEFCONST *USE-BIT-7-FOR-META* NIL)
(DEFCONST *AUTO-CR-ON-LF-FLAG* NIL)
(DEFCONST *AUTO-LF-ON-CR-FLAG* NIL)
;1; #+3600
;1; (defconst *disable-outgoing-cr-to-crlf-conversion* t
;1; "Yes if you want return to just send a <cr> during terminal emulation.") ;1; see the following note
;1; **************** some experimental new stuff for 3600 ****************
;1;
;1; The 3600 ascii translation that is "build in" to all :ascii-character
;1; streams has the unfortunate convention of turning outgoing <return> characters
;1; into <CR><LF> pairs, and converting incoming <CR><LF> pairs in <return> characters.
;1; This is usually ok, but with certain hosts, it works better if <return> actually
;1; sends just a <CR>. For example, I found that I could only get proper Heath19
;1; emulation with our LAN and with Multics if I set *disable-return-to-crlf-conversion*
;1; and *auto-lf-on-cr-flag* to true.
;1; Note that this is pulled from >rel-6-sys>io>stream.lisp and modified...
;1; Also note that this should only be in effect when connected for terminal
;1; emulation. It must work in the usual way for file transfers, etc.
;1; #+3600
;1; (defvar kermit-connected-flag nil) ;1; defined in lmiwin.
;1; #+3600
;1; (DEFWHOPPER (si:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN :TYO) (CH)
;1; (COND ((and ;1; This first condition is the changed part.
;1; kermit-connected-flag ;1; if we are connected for terminal emulation and...
;1; (char= ch #\CR) ;1; char is <return> and...
;1; *disable-outgoing-cr-to-crlf-conversion*) ;1; and we want return to just send <cr>,
;1; (continue-whopper #O015)) ;1; then do it that way.
;1; ((CHAR= CH #\CR) ;1; This rest is the normal function...
;1; (CONTINUE-WHOPPER #O015)
;1; (CONTINUE-WHOPPER #O012))
;1; (T (CONTINUE-WHOPPER (CHAR-TO-ASCII CH)))))
(DEFSUBST TERMINAL-INSERT-CHAR ()
(SEND *TERMINAL* ':INSERT-CHAR 1 ':CHARACTER))
(DEFSUBST TERMINAL-ERASE-ALUF ()
(SEND *TERMINAL* ':ERASE-ALUF))
(DEFSUBST TERMINAL-SET-ERASE-ALUF (ALU)
(SEND *TERMINAL* ':SET-ERASE-ALUF ALU))
(DEFSUBST TERMINAL-TYO (CHAR-CODE)
(SEND *TERMINAL* ':TYO CHAR-CODE))
(DEFSUBST TERMINAL-READ-CURSORPOS ()
(SEND *TERMINAL* ':READ-CURSORPOS ':CHARACTER))
(DEFSUBST TERMINAL-SET-CURSORPOS (X Y)
(SEND *TERMINAL* ':SET-CURSORPOS
X Y
':CHARACTER))
(DEFSUBST TERMINAL-INSERT-LINE (&OPTIONAL (NTIMES 1))
#+3600 (send *terminal* :insert-line ntimes) ;1; tv:sheet-insert-line is obsolete on 3600
#-3600 (TV:SHEET-INSERT-LINE *TERMINAL* NTIMES))
(DEFSUBST TERMINAL-DELETE-LINE (&OPTIONAL (NTIMES 1))
#+3600 (send *terminal* :delete-line ntimes) ;1; tv:sheet-delete-line obsolete on 3600
#-3600 (TV:SHEET-DELETE-LINE *TERMINAL* NTIMES))
(DEFSUBST TERMINAL-CLEAR-CHAR ()
(SEND *TERMINAL* ':CLEAR-CHAR))
(DEFSUBST TERMINAL-CHARACTER-WIDTH ()
(MULTIPLE-VALUE-BIND (WIDTH IGNORE)
(SEND *TERMINAL* ':SIZE-IN-CHARACTERS)
WIDTH))
(DEFSUBST TERMINAL-CHARACTER-HEIGHT ()
(MULTIPLE-VALUE-BIND (IGNORE HEIGHT)
(SEND *TERMINAL* ':SIZE-IN-CHARACTERS)
HEIGHT))
(DEFSUBST TERMINAL-END-OF-PAGE-EXCEPTION ()
(SEND *TERMINAL* ':HOME-CURSOR)
(SEND *TERMINAL* ':DELETE-LINE)
(TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2)))
(DEFSUBST TERMINAL-CR ()
(MULTIPLE-VALUE-BIND (IGNORE Y)
(TERMINAL-READ-CURSORPOS)
(TERMINAL-SET-CURSORPOS 0 Y)
(AND *AUTO-LF-ON-CR-FLAG*
(COND ((EQ Y (- (TERMINAL-CHARACTER-HEIGHT) 2))
(TERMINAL-END-OF-PAGE-EXCEPTION))
(T (TERMINAL-SET-CURSORPOS 0 (1+ Y)))))
NIL))
(DEFSUBST TERMINAL-LINEFEED ()
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(COND ((EQ Y (- (TERMINAL-CHARACTER-HEIGHT) 2))
(TERMINAL-END-OF-PAGE-EXCEPTION))
(T (TERMINAL-SET-CURSORPOS
(IF *AUTO-CR-ON-LF-FLAG* 0 X)
(1+ Y))))
NIL))
(defsubst serial-tyi ()
(let ((ch? (send *serial-stream* ':tyi)))
(and ch? (logand ch? #o177))))
(DEFSUBST TERMINAL-SAVE-POS-1 ()
(SETQ *SYSTEM-POSITION* (MULTIPLE-VALUE-LIST (TERMINAL-READ-CURSORPOS))))
(DEFSUBST TERMINAL-RESTORE-POS-1 ()
(TERMINAL-SET-CURSORPOS (CAR *SYSTEM-POSITION*) (CADR *SYSTEM-POSITION*)))
(DEFSUBST TERMINAL-GOTO-BEG-OF-LINE ()
(MULTIPLE-VALUE-BIND (IGNORE Y)
(TERMINAL-READ-CURSORPOS)
(TERMINAL-SET-CURSORPOS 0 Y)))
(DEFSUBST TERMINAL-BACKSPACE ()
(TERMINAL-TYO #\BACKSPACE))
(DEFSUBST TERMINAL-BEEP ()
(BEEP))
(DEFSUBST TERMINAL-TAB ()
(TERMINAL-TYO #\TAB))
;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; definition of DEF-TERMINAL-ESCAPE
;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
(DEFMACRO DEF-TERMINAL-ESCAPE (KEY-NUMBER NEED-TO-DEFINE-P FUNCTION-NAME &BODY BODY)
(COND (NEED-TO-DEFINE-P
`(PROGN 'COMPILE
(PUTHASH ,KEY-NUMBER ',FUNCTION-NAME *ESCAPE-DISPATCH-TABLE*)
(DEFUN ,FUNCTION-NAME () . ,BODY)))
('ALREADY-DEFINED-BY-SYSTEM-OR-USER
`(PUTHASH ,KEY-NUMBER ',FUNCTION-NAME *ESCAPE-DISPATCH-TABLE*))))
;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; terminal escape definitions
;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
(DEF-TERMINAL-ESCAPE #/[ T TERMINAL-EAT-TEMP ; this may be wrong
;; 'Enter Hold Screen Mode' ZEHS
(LET (I1 I2 FLAG)
(SETQ I1 (SERIAL-TYI))
(SETQ I2 (SERIAL-TYI))
(COND ((EQ I1 #\?) (SETQ FLAG T) (SERIAL-TYI))
((OR (> I2 #\9) (< I2 #\0))
(SETQ I1 (- I1 #\0)))
(T (SETQ I1 (+ (* 10. (- I1 #\0)) (- I2 #\0)))
(SETQ I2 (SERIAL-TYI))))
(COND ((NOT FLAG)
(SELECTQ I2
(#\L (TERMINAL-INSERT-LINE I1))
(#\M (TERMINAL-DELETE-LINE I1)))))))
(DEF-TERMINAL-ESCAPE #\\ T EXIT-EAT-TEMP
(TERMINAL-CLEAR-SCREEN)) ; this may be wrong
(DEF-TERMINAL-ESCAPE #\H T TERMINAL-HOME-CURSOR
(SEND *TERMINAL* ':HOME-CURSOR))
(DEF-TERMINAL-ESCAPE #\p T TERMINAL-REVERSE-VIDEO
(SETQ *REVERSE-VIDEO-FLAG* T)
NIL)
(DEF-TERMINAL-ESCAPE #\q T TERMINAL-NORMAL-VIDEO
(SETQ *REVERSE-VIDEO-FLAG* NIL)
NIL)
(DEF-TERMINAL-ESCAPE #\x T TERMINAL-SET-MODE
(SELECTQ (SERIAL-TYI)
(#O10 (SETQ *AUTO-LF-ON-CR-FLAG* T))
(#O11 (SETQ *AUTO-CR-ON-LF-FLAG* T))
(:OTHERWISE ()))
(COND (*TERMINAL-DEBUG-MODE* (FORMAT INTERACTION-PANE "~% SET MODE: ~O [~C] ")))
NIL)
(DEF-TERMINAL-ESCAPE #\y T TERMINAL-RESET-MODE
(SELECTQ (SERIAL-TYI)
(#O10 (SETQ *AUTO-LF-ON-CR-FLAG* NIL))
(#O11 (SETQ *AUTO-CR-ON-LF-FLAG* NIL))
(:OTHERWISE ()))
(COND (*TERMINAL-DEBUG-MODE* (FORMAT INTERACTION-PANE "~% SET MODE: ~O [~C] ")))
NIL)
(DEF-TERMINAL-ESCAPE #\C T TERMINAL-CURSOR-FORWARD
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(UNLESS (EQ X 79.)
(TERMINAL-SET-CURSORPOS (1+ X) Y))))
(DEF-TERMINAL-ESCAPE #\D T TERMINAL-CURSOR-BACKWARDS
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(UNLESS (EQ X 0)
(TERMINAL-SET-CURSORPOS (1- X) Y))))
(DEF-TERMINAL-ESCAPE #\B T TERMINAL-CURSOR-DOWN
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(UNLESS (EQ Y (- (TERMINAL-CHARACTER-HEIGHT) 2))
(TERMINAL-SET-CURSORPOS X (1+ Y)))))
(DEF-TERMINAL-ESCAPE #\A T TERMINAL-CURSOR-UP
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(UNLESS (EQ Y 0)
(TERMINAL-SET-CURSORPOS X (1- Y)))))
(DEF-TERMINAL-ESCAPE #\I T TERMINAL-REVERSE-INDEX
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(COND ((ZEROP X)
(TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2))
(TERMINAL-DELETE-LINE)
(TERMINAL-SET-CURSORPOS X Y)
(TERMINAL-INSERT-LINE))
(T (TERMINAL-CURSOR-UP)))))
(DEF-TERMINAL-ESCAPE #\n T TERMINAL-REPORT-CURSOR
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(SEND *SERIAL-STREAM* ':TYO #O33) ;33 is ascii <altmode>
(SEND *SERIAL-STREAM* ':TYO #\Y)
(SEND *SERIAL-STREAM* ':TYO (+ 32. Y))
(SEND *SERIAL-STREAM* ':TYO (+ 32. X))))
(DEF-TERMINAL-ESCAPE #\J T TERMINAL-CLEAR-EOF
(SEND *TERMINAL* #+3600 :clear-rest-of-window #-3600 ':CLEAR-EOF) ;1;
)
(DEF-TERMINAL-ESCAPE #\j T TERMINAL-SAVE-POS
(SETQ *CURSOR-SAVE*
(MULTIPLE-VALUE-LIST (TERMINAL-READ-CURSORPOS))))
(DEF-TERMINAL-ESCAPE #\k T TERMINAL-RESTORE-POS
(TERMINAL-SET-CURSORPOS (CAR *CURSOR-SAVE*) (CADR *CURSOR-SAVE*)))
(DEF-TERMINAL-ESCAPE #\Y T TERMINAL-SET-POS
(LET ((Y (SERIAL-TYI))
(X (SERIAL-TYI)))
(cond (*terminal-debug-mode*
(format t "~& setpos X=~D Y=~D" (- x 32.) (- y 32.))))
(TERMINAL-SET-CURSORPOS (- X 32.) (- Y 32.))))
(DEF-TERMINAL-ESCAPE #\E T TERMINAL-CLEAR-SCREEN
(SEND *TERMINAL* #+3600 :clear-window #-3600 ':CLEAR-SCREEN)) ;1;
(DEF-TERMINAL-ESCAPE #\b T TERMINAL-CLEAR-BOD
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(DOTIMES (LINE (1- Y))
(TERMINAL-SET-CURSORPOS 0 LINE)
(TERMINAL-CLEAR-EOL))
(TERMINAL-SET-CURSORPOS 0 Y)
(DOTIMES (DUMMY X)
(TERMINAL-CLEAR-CHAR)
(TERMINAL-CURSOR-FORWARD))
(TERMINAL-CURSOR-BACKWARDS)))
(DEF-TERMINAL-ESCAPE #\l T TERMINAL-CLEAR-LINE
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(TERMINAL-SET-CURSORPOS 0 Y)
(TERMINAL-CLEAR-EOL)
(TERMINAL-SET-CURSORPOS X Y)))
(DEF-TERMINAL-ESCAPE #\o T TERMINAL-ERASE-BOL
(MULTIPLE-VALUE-BIND (X Y)
(TERMINAL-READ-CURSORPOS)
(TERMINAL-SET-CURSORPOS 0 Y)
(DOTIMES (DUMMY X)
(TERMINAL-CLEAR-CHAR)
(TERMINAL-CURSOR-FORWARD))
(TERMINAL-CURSOR-BACKWARDS)))
(DEF-TERMINAL-ESCAPE #\K T TERMINAL-CLEAR-EOL
(SEND *TERMINAL* #+3600 :clear-rest-of-line #-3600 ':CLEAR-EOL)) ;1;
(DEF-TERMINAL-ESCAPE #\L T TERMINAL-INSERT-ONE-LINE
(TERMINAL-SAVE-POS-1)
(TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2))
(TERMINAL-DELETE-LINE)
(TERMINAL-RESTORE-POS-1)
(TERMINAL-INSERT-LINE)
(TERMINAL-GOTO-BEG-OF-LINE))
(DEF-TERMINAL-ESCAPE #\M T TERMINAL-DELETE-ONE-LINE
(TERMINAL-DELETE-LINE)
(TERMINAL-SAVE-POS-1)
(TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2))
(TERMINAL-INSERT-LINE)
(TERMINAL-RESTORE-POS-1)
(TERMINAL-GOTO-BEG-OF-LINE))
(DEF-TERMINAL-ESCAPE #\N T TERMINAL-DELETE-CHAR
(SEND *TERMINAL* ':DELETE-CHAR))
(DEF-TERMINAL-ESCAPE #\@ T TERMINAL-INSERT-MODE
(SETQ *INSERT-FLAG* T)
NIL)
(DEF-TERMINAL-ESCAPE #\O T TERMINAL-EXIT-INSERT-MODE
(SETQ *INSERT-FLAG* NIL))
(DEFSUBST ESCAPE-DISPATCH ()
(LET* ((KEYSTROKE (SERIAL-TYI))
(METHOD (GETHASH KEYSTROKE *ESCAPE-DISPATCH-TABLE*)))
(COND (METHOD
(FUNCALL METHOD)
(COND (*TERMINAL-DEBUG-MODE*
(FORMAT INTERACTION-PANE "~% ~O [~:@C] ~S " KEYSTROKE KEYSTROKE METHOD))))
(T (PUSH KEYSTROKE *BAD-ESCAPES*)
(COND (*TERMINAL-DEBUG-MODE*
(FORMAT INTERACTION-PANE "~% ~O [~C] <<*** BAD ESCAPE CHARACTER"
KEYSTROKE KEYSTROKE)))))))
(DEFUN READ-CHAR-FROM-SERIAL-STREAM-TO-TERMINAL ()
(LET ((KEYSTROKE (SERIAL-TYI)))
(COND ((EQ KEYSTROKE #O33) ;ASCII <ALTMODE> [ESCAPE]
(ESCAPE-DISPATCH))
((< #O31 KEYSTROKE #O200)
(AND *LOGFILE* TURN-ON-LOGGING? (SEND *LOGFILE* ':TYO KEYSTROKE)) ;LOGFILE KLUDGE
(COND (*INSERT-FLAG* (TERMINAL-INSERT-CHAR)))
(LET ((STORE (TERMINAL-ERASE-ALUF)))
(TERMINAL-SET-ERASE-ALUF (IF *REVERSE-VIDEO-FLAG* TV:ALU-IOR TV:ALU-ANDCA))
(TERMINAL-CLEAR-CHAR)
(TERMINAL-SET-ERASE-ALUF STORE))
(COND ((> (TERMINAL-READ-CURSORPOS) (TERMINAL-CHARACTER-WIDTH))
(TERMINAL-CR)))
(TERMINAL-TYO KEYSTROKE))
(T (SELECTQ KEYSTROKE
(#O7 (TERMINAL-BEEP))
(#O10 (TERMINAL-BACKSPACE))
(#O11 (TERMINAL-TAB)
(AND *LOGFILE* TURN-ON-LOGGING? (SEND *LOGFILE* ':TYO #O211)))
(#O12 (TERMINAL-LINEFEED))
(#O15 (TERMINAL-CR)
(AND *LOGFILE* TURN-ON-LOGGING? (SEND *LOGFILE* ':TYO #O215)))
(T (COND (*TERMINAL-DEBUG-MODE*
(FORMAT INTERACTION-PANE
"~%Unrecognized /"control character/": ~O [~:@C]"
KEYSTROKE KEYSTROKE))))
)))))
(defun process-wait-listen (&rest streams)
"waits on input on the streams, returns the stream which has input ready."
(let ((stream1 (car streams)))
(cond
((send stream1 ':listen) stream1)
(t
(with-stack-list (return-value nil)
(process-wait "wait-listen"
#'(lambda (return-value streams)
(dolist (stream streams)
(if (send stream ':listen)
(return (setf (car return-value) stream)))))
return-value
streams)
(car return-value))))))
;;; sending characters from terminal to serial-stream:
(DEFSUBST TERMINAL-TYI ()
(SEND *TERMINAL* ':TYI))
(defsubst serial-tyo (char)
(send *serial-stream* ':tyo char))
;;; this is now somewhat specialize for
;;; kermit by having this mouse menu tracking
;;; business, but its just the easiest way to
;;; keep the menu active while Connect is running.
;;; See the file "sys:kermit;kermit-window" for
;;; the extra meaning to this.
(defsubst terminal-any-tyi ()
(send *terminal* ':any-tyi))
(defun read-char-from-keyboard-to-serial-stream ()
(declare (special *escchr*))
(let ((key-stroke (terminal-any-tyi)))
(cond ((and (not (atom key-stroke)) (eq (car key-stroke) ':menu))
(funcall (cadddr key-stroke) ':execute (cadr key-stroke)))
((not (fixnump key-stroke)) (beep))
(t (if *local-echo-mode*
(format *terminal* "~C" key-stroke))
(when (memq (ldb %%kbd-char key-stroke) '(#\Rubout #+(not 3600) #\Delete)) ;1;
(setq key-stroke (dpb 177 %%kbd-char key-stroke)))
(select key-stroke
(*escchr* (network-keystroke-handler))
(#\Call (serial-tyo #\ )) ; send a [top-c] (for ascii ctrl-z)
#+3600
(#\Escape (serial-tyo #o33)) ;1; send escape character, too.
(t (let
((char (ldb %%kbd-char key-stroke))
(control (ldb %%kbd-control key-stroke))
(meta (ldb %%kbd-meta key-stroke)))
(cond ((and (eq meta 1) (eq control 1))
(serial-tyo
#+3600 #\c-Z ;1; Will this do it??
#-3600 #\top-c) ;; [TOP-C] IS An Ascii CTRL-Z
(serial-tyo char))
(t (cond ((eq control 1) (setq char (logand char 37))))
(cond ((not (zerop meta))
(cond (*use-bit-7-for-meta*
(setq char (logior #o200 (logand char #o177))))
(t (serial-tyo #o33)
(setq char (logior char #o40))))))
(serial-tyo char)))
nil)))))))
(defun network-keystroke-handler ()
(declare (special kermit-frame *escchr*))
(terminal-network-prompt) ;PROMPT THE USER
(let ((terminal-io interaction-pane))
;1; I think that tv:with-selection-substitute on LMI would substitute kermit-frame for
;1; interaction-pane if interaction-pane is unbound, so that is what I will explicitly do for 3600.
(#-3600 tv:with-selection-substitute #-3600 (interaction-pane kermit-frame)
#+3600 let #+3600 ((interaction-pane (if (boundp 'interaction-pane) interaction-pane kermit-frame)))
(let ((key-stroke (char-upcase (terminal-tyi))))
(unless (eq key-stroke #\rubout)
(format interaction-pane "~:@C" key-stroke))
(condition-case ()
(prog1 ; hey, return ':close sometimes
(selectq key-stroke
(#\CLEAR-SCREEN (terminal-clear-screen))
(#\CONTROL-CLEAR-SCREEN (send interaction-pane
#+3600 :clear-window ;1; clear-screen is
#-3600 ':clear-screen)) ;1; obsolete on 3600
((#\HELP #/H) (terminal-network-help))
(#\SPACE nil)
(#\control-y (terminal-control-y-pop-up-ed-string-hack))
(#/E (terminal-read-eval-print))
(#\control-d
(format t "~&Turning ~A Terminal Debug mode.~%"
(if (setq *terminal-debug-mode* (not *terminal-debug-mode*))
"ON" "OFF")))
(#/D (format t "~&Turning ~A Local Echo mode.~%"
(if (setq *local-echo-mode* (not *local-echo-mode*))
"ON" "OFF")))
(#\CONTROL-B (terminal-get-and-set-new-baud-rate))
(#\CONTROL-S (terminal-set-status-of-connection))
(#\STATUS (terminal-show-status-of-connection))
(#/F (terminal-flush-input-buffer))
(#/L (terminal-start-logging))
(#\C-L (terminal-close-logging))
(#/K (format interaction-pane "...closing stream ~S..."
*serial-stream*)
(send *serial-stream* ':close ':abort)
(format interaction-pane "and disconnecting.~%")
':close)
;;KERMIT PROTOCOL:
(#/0 (terminal-transmit-nul))
(#/B (terminal-transmit-break))
(#/C (format interaction-pane "...disconnecting.~%")
':close)
(#/P (terminal-push-to-system-command-processor))
(#/Q (terminal-quit-logging))
(#/R (terminal-resume-logging))
(#/S (terminal-show-status-of-connection))
(#/? (terminal-network-help))
(#\NETWORK (terminal-transmit-network-escape-character))
(#\RUBOUT) ;do nothing
(:otherwise (if (eq key-stroke kermit:*escchr*)
(terminal-transmit-network-escape-character)
(if (not (eq key-stroke #\RUBOUT))
(format interaction-pane
" <-- ?? Unknown argument to <NETWORK> ??")))))
(terpri interaction-pane))
(sys:abort nil))))))
(defun terminal-control-y-pop-up-ed-string-hack ()
(let
((string-to-transmit? ;null if aborted
(zwei:pop-up-edstring ""
'(:mouse)
()
(- (tv:sheet-inside-right *terminal*)
(tv:sheet-inside-left *terminal*))
(- (tv:sheet-inside-bottom *terminal*)
(tv:sheet-inside-top *terminal*))
"Edit Text and hit <END> to transmit.")))
(if string-to-transmit?
(loop for i from 0 below (array-active-length string-to-transmit?)
as char = (aref string-to-transmit? i)
doing (send *serial-stream* ':tyo char)))))
(DEFUN TERMINAL-NETWORK-HELP ()
;1; with-help-stream not on 3600...
(#-3600 SI:WITH-HELP-STREAM #-3600 (S :LABEL '(:STRING "Terminal Network Help"
:FONT FONTS:METSI :TOP :CENTERED)
:SUPERIOR *TERMINAL*)
#+3600 with-kermit-typeout-stream #+3600 S #+3600 '(:STRING "Terminal Network Help"
:FONT FONTS:METSI :TOP)
#-3600
(FORMAT S "
Single-keystroke Arguments to the <NETWORK> escape:
C Close -- escape back to kermit command level
<ctrl> Y Yank some text into a pop up window and send it thru serial stream
<ctrl> D Debug toggle -- toggles terminal debug mode
D Duplex toggle -- switch between local and remote terminal echoing
K Kill stream -- send current stream a :close message and disconnect
<clear-screen> Clear terminal screen
<ctrl><clear> Clear interaction screen
F Flush serial input buffer
<ctrl>B Control Baud -- set baud rate
E Eval -- evaluate lisp expression
P Push -- break to lisp. Hit <resume> to return
B Transmit a break
0 Transmit a nul
s,<status> Show serial stream status
L Log connection in a disk file
<control>L Close logging to disk file
Q Quit logging temporarily
R Resume logging
?,<help>,h type this stuff ~%")
#+3600
(FORMAT S "
Single-keystroke Arguments to the <NETWORK> escape:
C Close -- escape back to kermit command level
<ctrl> Y Yank some text into a pop up window and send it thru serial stream
<ctrl> D Debug toggle -- toggles terminal debug mode
D Duplex toggle -- switch between local and remote terminal echoing
K Kill stream -- send current stream a :close message and disconnect
<refresh> Clear terminal screen
<ctrl><refresh> Clear interaction screen
F Flush serial input buffer
<ctrl>B Control Baud -- set baud rate
E Eval -- evaluate lisp expression
P Push -- break to lisp. Hit <resume> to return
B Transmit a break
0 Transmit a nul
S Show serial stream status
L Log connection in a disk file
<control>L Close logging to disk file
Q Quit logging temporarily
R Resume logging
?,<help>,h Help, type this stuff ~%")
))
(defun toggle-duplex ()
(format t "~&Local Echo mode being turned ~A.~%"
(if *local-echo-mode* "OFF" "ON"))
(setq *local-echo-mode* (not *local-echo-mode*)))
(defun terminal-flush-input-buffer ()
(send *serial-stream* ':clear-input))
;;; this macro here because this gets compiled first (before kermit-window).
(defmacro with-second-font-and-more-processing (window &body body)
"sets window's font to its second font and turns on more processing during body.
sets them back to the way they were afterwards."
(let ((font (gensym))
(more-p (gensym)))
`(let ((,font (send ,window ':current-font))
(,more-p (send ,window ':more-p)))
(unwind-protect
(progn
(send ,window ':set-current-font 1)
(send ,window ':set-more-p t)
,@body)
(send ,window ':set-current-font ,font)
(send ,window ':set-more-p ,more-p)))))
(DEFUN TERMINAL-TRANSMIT-NETWORK-ESCAPE-CHARACTER ()
(declare (special *escchr*))
(serial-tyo *escchr*))
(defun terminal-show-status-of-connection ()
;1; Once again, I changed this since 3600 doesn't have with-help-stream.
(#-3600 si:with-help-stream #-3600 (standard-output
:label `(:string "Terminal Status"
,@(if (boundp 'fonts:metsi)
'(:font fonts:metsi))
:top :centered)
:superior *terminal*)
#+3600 with-kermit-typeout-stream #+3600 standard-output
#+3600 `(:string "Terminal Status"
,@(if (boundp 'fonts:metsi) '(:font fonts:metsi)) :top)
;; status of logging:
(format t "~&Logging is ~A~A."
(if *logfile* "ON" "OFF")
(if *logfile*
(if turn-on-logging? " and ENABLED" " but DISABLED")
""))
;; and show logfile name if any:
(if *logfile*
(format t "~&Logfile name is: ~A" *logfile*))
;; status of echo:
(format t "~&Local-echo-mode is ~A."
(if *local-echo-mode* "ON" "OFF"))
;; terminal sizes:
(let ((font (send *terminal* ':current-font)))
(format t "~&Terminal sizes:~% Height: ~D lines; ~D pixels per line.~A"
(terminal-character-height)
(tv:font-char-height font)
(format nil "~% Width: ~D characters; ~D pixels per character."
(terminal-character-width)
(tv:font-char-width font))))
;; line status:
(cond
#-3600 ((typep *serial-stream* 'unix:unix-stream) ;1; no unix package on 3600
(describe *serial-stream*))
#-3600 ((typep *serial-stream* 'si:sdu-serial-stream) ;1; no sdu stuff on 3600
(format t "~%baud rate of ~A: ~d"
*serial-stream*
(send *serial-stream* ':baud-rate))
(si:sdu-serial-status))
((typep *serial-stream* 'si:serial-stream)
(format t "~%baud rate of ~A: ~d"
*serial-stream*
(send *serial-stream* ':get ':baud))
#-3600 (si:serial-status) ;1; no serial-status on 3600, so guess at what it describes...
#+3600 (progn
(format t "~%parity is ~d ~
~%number of data bits is ~d ~
~%number of stop bits is ~d ~
~%xon-xoff protocol is ~d"
(send *serial-stream* ':get ':parity)
(send *serial-stream* ':get ':number-of-data-bits)
(send *serial-stream* ':get ':number-of-stop-bits)
(send *serial-stream* ':get ':xon-xoff-protocol)))
)
(t (describe *serial-stream*)))
))
;;; LOGGING: here it is.
;;; All we do is this: if the incoming character from the
;;; serial stream is a printing ascii character, we put it
;;; in the log file. Printing characters are in the range
;;; 32 to 177 plus 11, 14, and 15 (octal). Linefeeds and any
;;; other control characters are not sent. No input from the
;;; user's side is included whatsoever. The code for the actual
;;; capture of characters is thus isolated within the function
;;; read-char-from-serial-stream-to-terminal.
(defun terminal-start-logging ()
(cond (*logfile*
(format interaction-pane "~& Cannot open a new logfile!!")
(tv:beep))
((setq *logfile*
(open (terminal-get-logfile-name-from-user) '(:out)))
(setq turn-on-logging? t)
(format interaction-pane "~& Logging output to file ~A~%"
(send *logfile* ':truename)))
(t (format interaction-pane "~& Unable to open logfile.")
(tv:beep)))
nil)
(defun terminal-get-logfile-name-from-user ()
(let ((default-pathname
(fs:merge-pathname-defaults
"TERMINAL.LOG"
(if (and (boundp 'kermit-default-pathname) ;1; added :unbound check
(neq kermit-default-pathname :unbound))
kermit-default-pathname
(fs:user-homedir)))))
(fs:merge-pathname-defaults
(prompt-and-read
':string-trim
(format nil
"~&Name log file: (DEFAULT: ~A) " ;1; just removed ">" from end...
default-pathname))
default-pathname)))
(defun terminal-quit-logging ()
(cond ((and *logfile* turn-on-logging?)
(format interaction-pane
"~&Turning off logged output to ~A~%"
(send *logfile* ':truename))
(setq turn-on-logging? nil))
((not *logfile*)
(format interaction-pane
"~& ?? There is no logging being done.~%"))
((not turn-on-logging?)
(format interaction-pane
"~& ?? Logging is not turned on.~%"))))
(DEFUN TERMINAL-RESUME-LOGGING ()
(COND ((AND *LOGFILE* (NOT TURN-ON-LOGGING?))
(FORMAT INTERACTION-PANE "~&Turning on logged output to ~A~%"
(SEND *LOGFILE* ':TRUENAME))
(SETQ TURN-ON-LOGGING? T))
((NOT *LOGFILE*)
(FORMAT INTERACTION-PANE
"~& ?? There is no logging being done.~%"))
(TURN-ON-LOGGING?
(FORMAT INTERACTION-PANE
"~& ?? Logging is not turned off.~%"))))
(DEFUN TERMINAL-CLOSE-LOGGING ()
(COND (*LOGFILE*
(FORMAT INTERACTION-PANE "~&Closing logged output to ~A" (SEND *LOGFILE* ':TRUENAME))
(SEND *LOGFILE* ':CLOSE)
(SETQ *LOGFILE* NIL)
(SETQ TURN-ON-LOGGING? NIL))
(T (FORMAT INTERACTION-PANE
" ?? There is no log file to close~%"))))
#-common
(DEFUN TERMINAL-PUSH-TO-SYSTEM-COMMAND-PROCESSOR ()
(LET ((TERMINAL-IO INTERACTION-PANE))
(BREAK KERMIT)))
#+common
(DEFUN TERMINAL-PUSH-TO-SYSTEM-COMMAND-PROCESSOR ()
(LET ((TERMINAL-IO INTERACTION-PANE))
(BREAK "Kermit Break while in Connect.")))
(DEFUN TERMINAL-TRANSMIT-NUL ()
(SERIAL-TYO 0))
(DEFUN TERMINAL-CLOSE-CONNECTION ()
NIL)
(DEFUN TERMINAL-GET-AND-SET-NEW-BAUD-RATE () ;1; had to change this since 3600 will not be object-code compatible,
(LET (TO-WHAT) ;1; and does not have stuff for selecting processor type.
#-3600 (SELECTOR SI:PROCESSOR-TYPE-CODE EQ
(SI:LAMBDA-TYPE-CODE
(SEND *SERIAL-STREAM*
':SET-BAUD-RATE
(IF (ZEROP (SETQ TO-WHAT
(PROMPT-AND-READ ':NUMBER
"~%The current baud rate is ~D. Answering with 0 keeps it.~%Baud rate? >>"
(SEND *SERIAL-STREAM* ':BAUD-RATE))))
(SEND *SERIAL-STREAM* ':BAUD-RATE)
TO-WHAT)))
(SI:CADR-TYPE-CODE
(SEND *SERIAL-STREAM*
':PUT
':BAUD
(IF (ZEROP (SETQ TO-WHAT
(PROMPT-AND-READ ':NUMBER
"~%The current baud rate is ~D. Answering with 0 keeps it.~%Baud rate? >>"
(SEND *SERIAL-STREAM* ':GET ':BAUD))))
(SEND *SERIAL-STREAM* ':GET ':BAUD)
TO-WHAT))))
#+3600 (SEND *SERIAL-STREAM*
':PUT
':BAUD
(IF (ZEROP (SETQ TO-WHAT
(PROMPT-AND-READ ':NUMBER
"~%The current baud rate is ~D. Answering with 0 keeps it.~%Baud rate? >>"
(SEND *SERIAL-STREAM* ':GET ':BAUD))))
(SEND *SERIAL-STREAM* ':GET ':BAUD)
TO-WHAT))
))
(DEFUN TERMINAL-SET-STATUS-OF-CONNECTION ()
NIL)
(DEFUN TERMINAL-READ-EVAL-PRINT ()
(FORMAT INTERACTION-PANE "~%EVAL>")
(LET ((DEBUG-IO INTERACTION-PANE)
(QUERY-IO INTERACTION-PANE)
(ERROR-OUTPUT INTERACTION-PANE)
(TERMINAL-IO INTERACTION-PANE)
(STANDARD-INPUT INTERACTION-PANE)
(STANDARD-OUTPUT INTERACTION-PANE))
(CONDITION-CASE ()
(PRINT (EVAL (READ)))
(SYS:ABORT NIL))))
#-3600
(DEFUN TERMINAL-TRANSMIT-BREAK ()
;;PUT ASCII NUL [0] ON LINE FOR 1/4 SECOND
;1; Weird, but for 3600, the first parameter to time-difference
;1; is assumed to be later than the second, so had to change this.
;1; But.... this still doesn't work.... what you need is next version.
(LOOP WITH TIME = (TIME)
DOING (COND ((> #-3600 (TIME-DIFFERENCE TIME (TIME))
#+3600 (time-difference (time) time)
15.)
(RETURN))
(T (SERIAL-TYO 0)))))
#+3600
(defun terminal-transmit-break ()
(send *serial-stream* :send-break)) ;1; makes sense...
(DEFUN TERMINAL-NETWORK-PROMPT ()
(FORMAT INTERACTION-PANE "~&NETWORK>"))
;1; The defaults for these instance variable seem to have to be set here,
;1; as well as in the defconst/defvar of the corresponding globals.
;1; If not, they appear to take the global value when not connected,
;1; and the following value during connection.
(defflavor kterm-state
;; analogous to kstate.
;; these are all used free by connect & its subroutines.
((*logfile* nil)
(turn-on-logging? nil)
(*local-echo-mode* nil)
(*terminal-debug-mode* nil)
(*insert-flag* nil)
(*reverse-video-flag* nil)
(*cursor-save* '(0 0))
(*system-position* '(0 0))
(*use-bit-7-for-meta* nil)
(*auto-cr-on-lf-flag* nil)
(*auto-lf-on-cr-flag* nil) ;1; accidentally left out?
)
()
:special-instance-variables)
;; for kermit window interface to call
(defmethod (kterm-state :make-connection)
(serial-stream terminal-stream)
;; now all the special instance variables are bound.
(connect serial-stream terminal-stream))
;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;;; CONNECT
;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
(defun connect
;; bind various streams
(*serial-stream* *terminal*
&optional
(error-output error-output)
(debug-io debug-io)
&aux
(interaction-pane (if (boundp 'interaction-pane)
interaction-pane *terminal*))
(*ttyfd* *serial-stream*))
"Make *terminal* a virtual terminal connected with *serial-stream*, a serial stream.
A simulation of a Heath//H19//Z29 terminal is attempted
for communication with ASCII terminals. Do <NETWORK> <HELP>
for help and feature explanation. <Network>C to Close (disconnect)"
(declare (special *ttyfd*))
(let ((char-aluf (send *terminal* ':char-aluf)))
(loop initially
(send *terminal* ':set-char-aluf tv:alu-xor)
with winner = (process-wait-listen *serial-stream* *terminal*)
doing
(cond ((eq winner *serial-stream*)
(read-char-from-serial-stream-to-terminal)
(setq winner (process-wait-listen *terminal* *serial-stream*)))
(t (cond ((eq (read-char-from-keyboard-to-serial-stream) ':close)
(loop-finish)) ; we're done
(t (setq winner (process-wait-listen *serial-stream* *terminal*))))))
finally
(send *terminal* ':set-char-aluf char-aluf)
(return nil))))