1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         TERMIO.SL
4% Description:  Terminal i-o with protocol and pagemode
5% Author:       Herbert Melenk
6% Created:      4-April-90
7% Modified:
8% Package:
9% Status:       Open Source: BSD License
10%
11% Redistribution and use in source and binary forms, with or without
12% modification, are permitted provided that the following conditions are met:
13%
14%    * Redistributions of source code must retain the relevant copyright
15%      notice, this list of conditions and the following disclaimer.
16%    * Redistributions in binary form must reproduce the above copyright
17%      notice, this list of conditions and the following disclaimer in the
18%      documentation and/or other materials provided with the distribution.
19%
20% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
22% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
23% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
24% CONTRIBUTORS
25% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31% POSSIBILITY OF SUCH DAMAGE.
32%
33%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
34
35(compiletime (load inum fast-vector fast-int))
36
37(compiletime (flag '(reset-terminal-page sync-terminal
38		     char-to-protfile beiss-ab)
39		   'internalfunction))
40
41
42(compiletime (progn
43      (define-constant ESC         16#01B)
44   % cursor
45      (define-constant BACKSPACE   16#008)
46      (define-constant DELETE      16#153)
47      (define-constant INSERT      16#152)
48      (define-constant HOME        16#147)
49      (define-constant END         16#14F)
50      (define-constant UP          16#148)
51      (define-constant DOWN        16#150)
52      (define-constant RIGHT       16#14D)
53      (define-constant LEFT        16#14B)
54   % page
55      (define-constant PAGEUP      16#149)  % I
56      (define-constant PAGEDOWN    16#151)  % Q
57   % tabulator
58      (define-constant TABLEFT     16#10f)
59      (define-constant TABRIGHT    16#009)
60))
61
62
63(fluid '(oldterminalinputhandler oldterminaloutputhandler protfile
64	 morechars* terminaldir  linebuffer*
65	 pagelength* bufferfile!* *page **windows))
66
67(flag '(page) 'switch)
68
69(setq pagelength* 23)
70
71(when (null oldterminalinputhandler)
72      (setq oldterminalinputhandler (wgetv readfunction 0))
73      (setq oldterminaloutputhandler (wgetv writefunction 1))
74)
75
76(de hard-readch()
77  % hard-wired terminal input
78  (prog(c)
79    (&time-control nil)
80    (setq c (int_7))
81    (&time-control t)
82    (return (wand c 16#ff))))
83
84(de hard-princ(c)
85  (&time-control nil)
86  (int_2 (wand c 16#ff))
87  (&time-control t))
88
89
90(de protfile (u)
91    (when (weq **windows 1)
92	  (stderror "use dribble file from Edit menu instead"))
93    (when protfile (close protfile))
94    (setq protfile nil)
95    (cond ((or (equal u "") (null u)(eq u T)) nil)
96	  ((stringp u) (setq protfile (open u 'OUTPUT)) u)
97	  ((idp u)(setq protfile (open (id2string u) 'OUTPUT)) u)
98	  (t (stderror "protfile must be called with string or id"))))
99
100(de newterminalinputhandler (u)
101  (prog(c)
102    (when (not *page)
103       (return
104	 (idapply oldterminalinputhandler (list u))))
105
106	   % fresh buffer necessary
107    (when (wgreaterp (wgetv nextposition u)
108		     (wgetv bufferlength u))
109	  (channelwritestring promptout*
110	     (if (stringp promptstring*) promptstring* ">"))
111	  (flushbuffer promptout*)
112	  (when (weq promptout* stdout*)
113		(setf (wgetv lineposition promptout*) 0))
114	  (setf (wgetv bufferlength u)
115		(line-from-terminal u))
116	  (setf (wgetv nextposition u) 0) )
117
118	  % pick character from buffer
119    (setq c (strbyt (strinf(igetv iobuffer u))
120		     (wgetv nextposition u)))
121    (setf (wgetv nextposition u)
122	       (iadd1 (wgetv nextposition u)))
123
124	  % page control and protocol generation
125    (reset-terminal-page)
126    (when protfile (when (weq terminaldir 1)
127			 (channelterpri protfile)
128			 (setq terminaldir -1))
129		   (char-to-protfile c))
130    (return c)))
131
132(de newterminaloutputhandler (ch u)
133  (prog(ll p)
134    (when (not *page) (go ready))
135    (setq ll (isub1 (wgetv maxline ch)))
136    (setq p (wgetv lineposition ch))
137    (when (and (wgreaterp p 0) (izerop (iremainder p ll)))
138	  (setf (wgetv pageposition ch) (iadd1 (wgetv pageposition ch)))
139	  (when (and bufferfile!* (eq ch 1))
140		(channelterpri bufferfile!*)))
141    (when (and pagelength* (intp pagelength*)
142	       (wgreaterp (wgetv pageposition ch) pagelength*))
143	   (idapply  oldterminaloutputhandler (list ch (char eol)))
144	   (mapc '(- - M  !o !r !e - -)
145		  (function hard-princ))
146	   (reset-terminal-page)
147	   (sync-terminal))
148    (when (and bufferfile!* (eq ch 1))
149	   (channelwritechar bufferfile!* u))
150    (when (and protfile (eq ch 1))
151	  (when (weq terminaldir -1)
152		(channelterpri protfile)
153		(setq terminaldir 1))
154	  (char-to-protfile u))
155  ready
156    (return (idapply oldterminaloutputhandler (list ch u)))))
157
158(de char-to-protfile(u)
159     (cond ((weq u (char (cntrl m))))    % ignore
160	   ((weq u (char (cntrl j))) (channelterpri protfile))
161	   (t (channelwritechar protfile u))))
162
163(de reset-terminal-page()
164    (setf (wgetv lineposition 1) 0)
165    (setf (wgetv pageposition 1) 0))
166
167(de sync-terminal()
168   (let ((c (hard-readch)))
169    (if (eq c (char (cntrl C)))
170	(stderror "break from terminal ")
171     %  (setq morechars* (append morechars* (list c)))
172   )))
173
174(de pagelength(n)
175  (prog(m)
176   (setq m pagelength*)
177   (if (not (intp n)) (stderror "*** illegal parameter for pagelength")
178		      (setq pagelength* n))
179   (return m)))
180
181(de pageon(i)
182   (when (and (weq i 1) (weq **windows 1))
183	 (stderror "use edit menue entry instead of switch PAGE"))
184   (setf (wgetv readfunction 0) 'newterminalinputhandler)
185   (setf (wgetv pageposition 1) 0)
186   (setf (wgetv writefunction 1)'newterminaloutputhandler)
187)
188
189(pageon 0)
190
191(put 'page 'simpfg '((nil nil)
192		     (t (pageon 1))))
193
194(de pagebuffer(n)
195  (when (null (getd 'mf-open)) (load1 'memio))
196  (when (null bufferfile!*) (setq bufferfile!* (mf-open "buffer" 'output)))
197  (mf-setmax bufferfile!* n))
198
199(pagebuffer 200)
200
201(compiletime
202
203(ds page-over(u v n)
204  % move n elements from u to v as long as possible
205   (ifor (from i 1 n 1)
206	 (do
207	   (when u
208	      (setq v (cons (car u) v))
209	      (setq u (cdr u)) ))))
210)
211
212(de wposmin(n m)
213   % positive minimum from n and m
214    (setq n (if (wgreaterp n m) m n))
215    (if (wlessp n 0) 0 n))
216
217
218(de show-page()
219   (let*((bf bufferfile!*)
220	 (bufferfile!* nil)
221	 (pl pagelength*)
222	 (pagelength* nil)
223	   fwd bwd
224	   x y n)
225    (prog()
226       (reset-terminal-page)
227       (setq bwd (reversip (mf2list bf)))
228       (page-over bwd fwd pl)
229  show (setq y (print-page fwd bwd pl))
230  cmd  (setq x (char-from-terminal))
231       (cond
232	     ((eq x HOME)
233	      (setq fwd (append (reverse bwd) fwd))
234	      (setq bwd nil)
235	      (go show))
236	     ((eq x UP)
237	      (page-over bwd fwd 5)
238	      (go show))
239	     ((eq x DOWN)
240	      (page-over fwd bwd
241		    (wposmin 5 (wdifference (length fwd) pl)))
242	      (go show))
243	     ((eq x PAGEUP)
244	      (page-over bwd fwd pl)
245	      (go show))
246	     ((eq x PAGEDOWN)
247	      (page-over fwd bwd
248		   (wposmin pl (wdifference (length fwd) pl)))
249	      (go show))
250	    )
251       (reset-terminal-page)
252       (return x)
253  )))
254
255(de char-from-terminal()
256   (prog (x y)
257      (setq x (hard-readch))
258      (when (not (eq x 0))
259			(when (wgreaterp x 127) (setq x 1))
260		(return x))
261      (setq y (hard-readch))
262      (return  (wplus2 16#100 y))))
263
264(de print-page(fwd bwd n)
265    (terpri)
266    (hard-line (when (null bwd) '(T O P)))
267    (terpri)
268    (ifor (from i 1 n 1)
269	  (do
270	     (when fwd
271		(prin2 (car fwd))
272		(setq fwd (cdr fwd)))))
273    (hard-line (when (null fwd) '(B O T T O M))) )
274
275(de hard-line(text)
276    (ifor (from i 1 35 1) (do (hard-princ (char -))))
277    (mapc text (function hard-princ))
278    (ifor (from i 1 35 1) (do (hard-princ (char -))))
279)
280
281(flag '(pagelength protfile pagebuffer) 'opfn)
282
283(compiletime
284  (ds linebyte(x) (strbyt (strinf ln) x))
285)
286
287(de line-from-terminal(u)
288    (prog (ln c n xn mx ins lb lbr ol lth)
289       (setq lb linebuffer*)
290       (setq ins t)
291       (setq ln (igetv iobuffer u))
292       (setq mx (wgetv maxbuffer u))
293       (setq n -1  xn -1)
294 next  (when (not (wgreaterp mx n)) (go ready1))
295       (setq c (if morechars* (pop morechars*) (char-from-terminal)))
296       (when (or (eq c PAGEUP)
297	     )
298	     (setq c (show-page))
299	     (terpri)
300	     (ifor (from i 0 n 1)
301		 (do
302		   (hard-princ
303		     (strbyt (strinf ln) i))))
304       )
305       (when (eq c UP)   % fetch old line
306	     (when (null lb) (go next))
307	     (clear-line n xn)
308	     (setq ol (pop lb))
309	     (push ol lbr)
310	     (go copyline))
311
312       (when (eq c DOWN)   % fetch old line
313	     (clear-line n xn) (setq n (setq xn -1))
314	     (when (null lbr) (go next))
315	     (setq ol (pop lbr))
316	     (push ol lb)
317	     (go copyline))
318
319    ret
320       (cond
321	     ((eq c ESC)
322	      (clear-line n xn) (setq n (setq xn -1))
323	      (go next))
324
325	     ((eq c HOME)
326	      (ifor (from i (isub1 n) -1 -1)
327		    (do (progn (setq n i) (hard-princ BACKSPACE)))))
328
329	     ((eq c END)
330	      (ifor (from i (iadd1 n) xn 1)
331		    (do (progn (setq n i) (hard-princ (linebyte i))  ))))
332
333	     ((eq c BACKSPACE)
334	       (when (wgeq n 0)
335		 (setf n (isub1 n))
336		 (hard-princ BACKSPACE)
337		 (go delete)))
338
339	     ((eq c LEFT)
340		(when (wgreaterp n 0)
341		      (hard-princ BACKSPACE)
342		      (setq n (isub1 n))))
343
344	     ((eq c RIGHT)
345		(when (wlessp n xn)
346		      (setq n (iadd1 n))
347		      (hard-princ (strbyt (strinf ln) n))
348		       ))
349
350	     ((eq c DELETE)  % skip one char
351	      (go delete))
352
353	     ((eq c INSERT) % switch inser mode
354	      (setq ins (not ins))
355	      (go next))
356
357	     ((eq c (char (cntrl C)))
358	      (setf (wgetv bufferlength u) -1)
359	      (stderror "break from terminal "))
360	     ((and (or (eq c (char (cntrl m)))(eq c (char (cntrl D))))
361		   (wlessp n xn))
362	      (hard-princ c)
363	      (setq xn (iadd1 xn))
364	      (setf (linebyte xn) c)
365	      (go ready)
366	       )   % don't destroy line
367
368	     (t
369		 (when (and ins (wlessp n xn)) % insert ?
370		    (hard-princ (char BLANK))
371		    (ifor (from i (iadd1 n) xn 1)
372			  (do (hard-princ (linebyte i))))
373		    (ifor (from i xn n -1)
374			  (do (progn
375				(setf (linebyte (iadd1 i)) (linebyte i))
376				(hard-princ BACKSPACE))))
377		    (setq xn (iadd1 xn))
378		 )
379		 (setq n (iadd1 n))
380		 (setf (strbyt (strinf ln) n) c)
381		 (hard-princ c)
382		 ))
383       (when (wgreaterp n xn)(setq xn n))
384
385       (when (or (eq c (char (cntrl m)))(eq c (char (cntrl D))))
386	     (go ready))
387       (go next)
388
389 delete
390       (when (wgeq n xn) (go next))
391       (ifor (from i (iadd1 (iadd1 n)) xn 1)
392	     (do (progn
393		  (hard-princ (linebyte i))
394		  (setf (linebyte (isub1 i))(linebyte i))
395	     )))
396       (hard-princ (char BLANK))
397       (hard-princ BACKSPACE)
398       (ifor (from i xn (iadd1 (iadd1 n)) -1)
399	     (do (hard-princ BACKSPACE)))
400       (setq xn (isub1 xn))
401       (go next)
402
403 copyline
404       (setq lth (strlen (strinf ol)))
405       (ifor (from i 0 lth 1)
406	     (do (progn
407		     (setq c (strbyt (strinf ol) i))
408		     (hard-princ c)
409		     (setf (strbyt (strinf ln) i) c))))
410       (setq xn lth)
411       (setq n xn)
412       (go next)
413
414 ready (setq n (iadd1 n))
415       (hard-princ (char eol))
416       (ifor (from i 1 80 1)
417	     (do (hard-princ BACKSPACE)))
418
419       (setf (strbyt (strinf ln) xn) (char eol))
420% ready1(setq oldlinefill* xn)
421%       (ifor (from i 0 xn 1)
422%             (do (setf (strbyt(strinf oldline*) i)
423%                       (strbyt (strinf ln) i))))
424  ready1
425       (push (subseq ln 0 xn) linebuffer*)
426       (beiss-ab linebuffer* 20)
427       (return xn)))
428
429(de beiss-ab(l n)
430   (cond ((null l) l)
431	 ((wleq n 0) (setf (cdr l) nil))
432	 (t (beiss-ab (cdr l)(isub1 n))) ))
433
434 (de clear-line(n xn)
435    (ifor (from i n 0 -1)
436	  (do (hard-princ BACKSPACE)))
437    (ifor (from i 0 xn 1)
438	  (do (hard-princ (char blank))))
439    (ifor (from i 0 xn 1)
440	  (do (hard-princ BACKSPACE))))
441
442
443