1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;; -*-LISP-*-
 11 
 12 ;;;
 13 ;;;       supdupctl -- Written by BSG 7/12/78 after he wrote a
 14 ;;;       SUPDUP user end and discovered he didn't have a server.
 15 ;;;       From PYZCTL.
 16 ;;;
 17 ;;;       From old aitvctl, from dm2500ctl.
 18 ;;;
 19 
 20 ;;;       Define the old %TD codes.
 21 
 22 (declare (eval (read)))
 23 (do x (read)(read)(eq x 'applesauce)(eval x))
 24 
 25 (setsyntax '% 'macro 'DCTL-tdcode-macro)
 26 
 27 (setq DCTL-tdcode-list '(
 28 
 29           TDEOF     202
 30           TDEOL     203
 31           TDNOP     210
 32           TDMV0     217
 33           TDMOV     200
 34           TDCLR     220
 35           TDBEL     221
 36           TDILP     223
 37           TDDLP     224
 38           TDICP     225
 39           TDDCP     226
 40                           ))
 41 
 42 (do x DCTL-tdcode-list (cddr x)(null x)(putprop (car x)(cadr x) 'tdcode))
 43 (defun cana macro (x)
 44     (list 'not (list 'zerop (list 'boole 1 (cadr x)(caddr x)))))
 45 
 46 (defun DCTL-tdcode-macro ()
 47        (or (get (read) 'tdcode)
 48            (error "Undefined tdcode")))
 49 
 50 applesauce
 51 
 52 
 53 (declare (special X Y screenheight tty-no-upmotionp screenlinelen tty-type overstrike-availablep e-quit-transparency))
 54 (declare (special DCTL-ttyopt-word DCTL-aobjn-count))
 55 (declare (special idel-lines-availablep idel-chars-availablep))
 56 
 57 
 58 ;;; Initialize terminal and terminal control package.
 59 
 60 (defun DCTL-init ()
 61        (Rprinc "Multics EMACS Supdup Server")
 62        (Rtyo 15)(Rtyo 12)
 63        (e_pl1_$dump_output_buffer)
 64        (setq DCTL-aobjn-count (lsh (- (DCTL-get-supdup-36-word)) -18.))
 65        (DCTL-get-supdup-36-word) ;TCTYP
 66        (setq DCTL-ttyopt-word (DCTL-get-supdup-36-word))
 67        (setq screenheight (DCTL-get-supdup-36-word))
 68        (setq screenheight (min 64. screenheight))
 69        (setq screenlinelen (DCTL-get-supdup-36-word))
 70        (DCTL-get-supdup-36-word) ;TTYROL
 71        (setq DCTL-aobjn-count (- DCTL-aobjn-count 5))
 72        (do ()((= DCTL-aobjn-count 0))
 73           (setq DCTL-aobjn-count (1- DCTL-aobjn-count))
 74           (DCTL-get-supdup-36-word))
 75        (setq idel-chars-availablep (cana DCTL-ttyopt-word 000001000000))
 76        (setq idel-lines-availablep (cana DCTL-ttyopt-word 000002000000))
 77        (setq overstrike-availablep (cana DCTL-ttyopt-word 001000000000))
 78        (setq tty-no-upmotionp (not (cana DCTL-ttyopt-word 000400000000)))
 79        (setq tty-type 'supdup)
 80        (Rtyo %TDNOP)
 81        (set-permanent-key '^\    'supdup-ITP-escape)
 82        (set-permanent-key 'esc-@ 'supdup-300-escape)
 83        (setq X -777 Y -777)
 84        (DCTL-position-cursor 0 0)
 85        (DCTL-clear-rest-of-screen))
 86 
 87 (defun DCTL-get-supdup-36-word ()
 88      (do ((w 0 (+ (lsh w 6) b))
 89           (b)
 90           (i 1 (1+ i)))
 91          ((> i 6) w)
 92 
 93           (setq b (DCTL-gnz-char)))))))
 94 
 95 
 96 (defun DCTL-assert-scpos (x y)
 97        (and x (setq X x))
 98        (and y (setq Y y))
 99        (DCTL-tdmov X Y X Y))
100 
101 (defun DCTL-nextline ()
102        (cond ((or (< X 0)(< Y 0))
103               (DCTL-position-cursor 0 0))
104              ((= Y (1- screenheight))
105               (DCTL-position-cursor X 0))
106              (t (DCTL-position-cursor X (1+ Y))
107                 (DCTL-assert-scpos nil (1- Y)))))
108 
109 ;;; Move terminal's cursor to desired position.
110 ;;; Real work is done in DCTL-real-position-cursor.
111 
112 ;;;       This hairy hack is solely for the benefit of printing tty's,
113 ;;;       and interfaces Multics EMACS' notion of a prtty "screen" to ITS's.
114 
115 
116 (defun DCTL-position-cursor (x y)
117        (cond ((and (= x X)(= y Y)))               ;aok, exit.
118              ((not tty-no-upmotionp)(DCTL-real-position-cursor x y))
119              ((or (< X 0)(< Y 0))                 ;randomized?
120               (DCTL-tdmov 50 0 0 1)
121               (DCTL-tdmov 0 0 x y))
122              ((= Y y)(DCTL-real-position-cursor x y))
123              ((= y 0)(DCTL-tdmov X 0 X 1)
124                      (DCTL-tdmov X y x y))
125              (t (DCTL-tdmov X (1- y) x y))))
126 
127 
128 (defun DCTL-tdmov (oldx oldy newx newy)
129        (setq X newx Y newy)
130        (Rtyo %TDMOV)
131        (Rtyo oldy)
132        (Rtyo oldx)
133        (Rtyo newy)
134        (Rtyo newx))
135 
136 
137 ;;; Actually move a tty cursor.
138 
139 (defun DCTL-real-position-cursor (x y)
140        (Rtyo %TDMV0)
141        (Rtyo y)
142        (Rtyo x)
143        (setq X x Y y))
144 
145 
146 (defun DCTL-ring-tty-bell ()
147        (Rtyo %TDBEL))
148 
149 (defprop supdup t tintinnabulum-ipsum-meum-sono)
150 
151 ; Output string.
152 (defun DCTL-display-char-string (string)
153        ((lambda (len)
154                 (setq X (+ X len))
155                 (Rprinc string))
156         (stringlength string)))
157 
158 ; Clear whole screen.
159 (defun DCTL-clear-rest-of-screen ()
160        (cond (tty-no-upmotionp (DCTL-nextline))
161              (t (Rtyo %TDEOF))))
162 
163 ; Go to next line on non-moveuppable terminals.
164 (defun DCTL-nextline ()
165        (cond ((= Y (1- screenheight))
166               (DCTL-position-cursor X 0))
167              (t (DCTL-position-cursor X (1+ Y)))))
168 
169 ; Clear to end of line.
170 
171 (defun DCTL-kill-line ()
172        (Rtyo %TDEOL))
173 
174 ; Insert character string in line at current position.
175 (defun DCTL-insert-char-string (str)
176        ((lambda (len)
177                 (Rtyo %TDICP)
178                 (Rtyo len)
179                 (Rprinc str)
180                 (setq X (+ X len)))
181         (stringlength str)))
182 
183 ; Delete characters from current position in line.
184 (defun DCTL-delete-chars (n)
185        (Rtyo %TDDCP)
186        (Rtyo n))
187 
188 ; Insert n blank lines at current position.
189 (defun DCTL-insert-lines (n)
190        (Rtyo %TDILP)
191        (Rtyo n))
192 
193 
194 ; Delete n lines at current position.
195 (defun DCTL-delete-lines (n)
196        (Rtyo %TDDLP)
197        (Rtyo n))
198 
199 ; Intelligent terminal protocol Handlers.
200 
201 (defun DCTL-gnz-char ()
202    (do x (e_pl1_$get_char)(e_pl1_$get_char) nil
203          (cond ((= x 377)((lambda (e-quit-transparency) (telnet-loser (DCTL-gnz-char))) 'leave-it)(setq x -1)))
204        (or (< x 0)(return x))))
205 
206 (defun supdup-300-escape ()
207        ((lambda (c)
208         (cond ((= c 301)(quit))
209               ((= c 302)(do x (DCTL-gnz-char)(DCTL-gnz-char)(= x 0)))
210               (t () )))
211         (DCTL-gnz-char)))
212 
213 (defun supdup-ITP-escape ()
214        (real-supdup-ITP-escape (DCTL-gnz-char)))
215 
216 (defun real-supdup-ITP-escape (c)
217           (cond ((= c 34)) ;too bad
218                 ((= c 003)  ;PIATY
219                  (do ()(nil)
220                       ((lambda (d)
221                           (cond ((= d 34)((lambda(e)
222                                              (cond ((= e 003))
223                                                    (t (real-supdup-ITP-escape e))))
224                                           (DCTL-gnz-char)))
225                                 (t (full-redisplay)
226                                    (process-char d)
227                                    (return nil))))
228                        (DCTL-gnz-char))))
229                 ((= c 020)   ;^P
230                  (setq Y (DCTL-gnz-char) X (DCTL-gnz-char)))
231                 (t ((lambda (d)
232                       (setq c (boole 1 3 c));meta, control
233                       (and (cana d 1)(setq d (- d 100)))
234                       (xec-cmd-triplet (lsh c -1) d nil))
235                    (DCTL-gnz-char)))))