;;; -*- 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 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 characters ;1; into pairs, and converting incoming pairs in characters. ;1; This is usually ok, but with certain hosts, it works better if actually ;1; sends just a . 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 and... ;1; *disable-outgoing-cr-to-crlf-conversion*) ;1; and we want return to just send , ;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 (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 [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 ??"))))) (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 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 escape: C Close -- escape back to kermit command level Y Yank some text into a pop up window and send it thru serial stream 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 terminal screen Clear interaction screen F Flush serial input buffer B Control Baud -- set baud rate E Eval -- evaluate lisp expression P Push -- break to lisp. Hit to return B Transmit a break 0 Transmit a nul s, Show serial stream status L Log connection in a disk file L Close logging to disk file Q Quit logging temporarily R Resume logging ?,,h type this stuff ~%") #+3600 (FORMAT S " Single-keystroke Arguments to the escape: C Close -- escape back to kermit command level Y Yank some text into a pop up window and send it thru serial stream 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 terminal screen Clear interaction screen F Flush serial input buffer B Control Baud -- set baud rate E Eval -- evaluate lisp expression P Push -- break to lisp. Hit to return B Transmit a break 0 Transmit a nul S Show serial stream status L Log connection in a disk file L Close logging to disk file Q Quit logging temporarily R Resume logging ?,,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 for help and feature explanation. 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))))