aboutsummaryrefslogtreecommitdiff
path: root/slof/fs/accept.fs
blob: cb6f2fa8f3ac90f20f92ab8bf719b752230ebf6b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
\ *****************************************************************************
\ * Copyright (c) 2004, 2008 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ *     IBM Corporation - initial implementation
\ ****************************************************************************/


\ Implementation of ACCEPT.  Using ECMA-48 for terminal control.

: beep  bell emit ;

: TABLE-EXECUTE
  CREATE DOES> swap cells+ @ ?dup IF execute ELSE beep THEN ;

0 VALUE accept-adr
0 VALUE accept-max
0 VALUE accept-len
0 VALUE accept-cur

: esc  1b emit ;
: csi  esc 5b emit ;

: move-cursor ( -- )
   esc ." 8" accept-cur IF
      csi base @ decimal accept-cur 0 .r base ! ." C"
   THEN
;

: redraw-line ( -- )
   accept-cur accept-len = IF EXIT THEN
   move-cursor
   accept-adr accept-len accept-cur /string type
   csi ." K" move-cursor
;

: full-redraw-line ( -- )
   accept-cur 0 to accept-cur move-cursor
   accept-adr accept-len type
   csi ." K" to accept-cur move-cursor
;

: redraw-prompt ( -- )
   cr depth . [char] > emit
;

: insert-char ( char -- )
   accept-len accept-max = IF drop beep EXIT THEN
   accept-cur accept-len <> IF csi ." @" dup emit
   accept-adr accept-cur + dup 1+ accept-len accept-cur - move
   ELSE dup emit THEN
   accept-adr accept-cur + c!
   accept-cur 1+ to accept-cur
   accept-len 1+ to accept-len redraw-line
;

: delete-char ( -- )
   accept-cur accept-len = IF beep EXIT THEN
   accept-len 1- to accept-len
   accept-adr accept-cur + dup 1+ swap accept-len accept-cur - move
   csi ." P" redraw-line
;

\ *
\ * History handling
\ *

STRUCT
cell FIELD his>next
cell FIELD his>prev
cell FIELD his>len
   0 FIELD his>buf
CONSTANT /his
0 VALUE his-head
0 VALUE his-tail
0 VALUE his-cur

: add-history ( -- )
   accept-len 0= IF EXIT THEN
   /his accept-len + alloc-mem
   his-tail IF dup his-tail his>next ! ELSE dup to his-head THEN
   his-tail over his>prev !  0 over his>next !  dup to his-tail
   accept-len over his>len !  accept-adr swap his>buf accept-len move
;

: history  ( -- )
   his-head BEGIN dup WHILE
   cr dup his>buf over his>len @ type
   his>next @ REPEAT drop
;

: select-history ( his -- )
   dup to his-cur dup IF
   dup his>len @ accept-max min dup to accept-len to accept-cur
   his>buf accept-adr accept-len move ELSE
   drop 0 to accept-len 0 to accept-cur THEN
   full-redraw-line
;


\
\ tab completion
\

\ tab completion state variables
0 value ?tab-pressed
0 value tab-last-adr
0 value tab-last-len

\ compares two strings and returns the longest equal substring.
: $same-string ( addr-1 len-1 addr-2 len-2 -- addr-1 len-1' )
   dup 0= IF    \ The second parameter is not a string.
      2drop EXIT \ bail out
   THEN
   rot min 0 0 -rot ( addr1 addr2 0 len' 0 )
   DO ( addr1 addr2 len-1' )
      2 pick i + c@ lcc
      2 pick i + c@ lcc
      = IF 1 + ELSE leave THEN
   LOOP
   nip
;

: $tab-sift-words    ( text-addr text-len -- sift-count )
   sift-compl-only >r true to sift-compl-only \ save sifting mode

   last BEGIN @ ?dup WHILE \ loop over all words
      $inner-sift IF \ any completions possible?
         \ convert to lower case for user interface sanity
         2dup bounds DO I c@ lcc I c! LOOP
         ?tab-pressed IF 2dup type space THEN  \ <tab><tab> prints possibilities
         tab-last-adr tab-last-len $same-string \ find matching substring ...
         to tab-last-len to tab-last-adr       \ ... and save it
      THEN
   repeat
   2drop

   #sift-count 0 to #sift-count	\ how many words were found?
   r> to sift-compl-only		\ restore sifting completion mode
;

\ 8< node sifting for tab completion on device tree nodes below this line 8<

#include <stack.fs>

10 new-stack device-stack

: (next-dev) ( node -- node' addr len )
   device-stack
   dup (node>path) rot
   dup child IF dup push child -rot EXIT THEN
   dup peer IF peer -rot EXIT THEN
   drop
   BEGIN
      stack-depth
   WHILE
      pop peer ?dup IF -rot EXIT THEN
   REPEAT
   0 -rot
;

: $inner-sift-nodes ( text-addr text-len node -- ... path-addr path-len true | false )
   (next-dev) ( text-addr text-len node' path-addr path-len )
   dup 0= IF drop false EXIT THEN
   2dup 6 pick 6 pick find-isubstr ( text-addr text-len node' path-addr path-len pos )
   0= IF
      #sift-count 1+ to #sift-count \ count completions
      true
   ELSE
      2drop false
   THEN
;

\
\ test function for (next-dev)
: .nodes ( -- )
   s" /" find-node BEGIN dup WHILE
      (next-dev)
      type cr
   REPEAT
   drop
   reset-stack
;

\ node sifting wants its own pockets
create sift-node-buffer 1000 allot
0 value sift-node-num
: sift-node-buffer
   sift-node-buffer sift-node-num 100 * +
   sift-node-num 1+ dup 10 = IF drop 0 THEN
   to sift-node-num
;

: $tab-sift-nodes    ( text-addr text-len -- sift-count )
   s" /" find-node BEGIN dup WHILE
      $inner-sift-nodes IF \ any completions possible?
         sift-node-buffer swap 2>r 2r@ move 2r> \ make an almost permanent copy without strdup
         ?tab-pressed IF 2dup type space THEN  \ <tab><tab> prints possibilities
         tab-last-adr tab-last-len $same-string \ find matching substring ...
         to tab-last-len to tab-last-adr       \ ... and save it
      THEN
   REPEAT
   2drop drop
   #sift-count 0 to #sift-count	\ how many words were found?
   reset-stack
;

: $tab-sift    ( text-addr text-len -- sift-count )
   ?tab-pressed IF beep space THEN \ cosmetical fix for <tab><tab>

   dup IF bl rsplit dup IF 2swap THEN ELSE 0 0 THEN >r >r

   0 dup to tab-last-len to tab-last-adr	\ reset last possible match
   current-node @ IF			\ if we are in a node?
      2dup 2>r				\ save text
      $tab-sift-words to #sift-count	\ search in current node first
      2r>				\ fetch text to complete, again
   THEN
   2dup 2>r
   current-node @ >r 0 set-node		\ now search in global words
   $tab-sift-words to #sift-count
   r> set-node
   2r> $tab-sift-nodes
   \ concatenate previous commands
   r> r> dup IF s"  " $cat THEN tab-last-adr tab-last-len $cat
   to tab-last-len to tab-last-adr  \ ... and save the whole string
;

\ 8< node sifting for tab completion on device tree nodes above this line 8<

: handle-^A
   0 to accept-cur move-cursor ;
: handle-^B
   accept-cur ?dup IF 1- to accept-cur ( csi ." D" ) move-cursor THEN ;
: handle-^D
   delete-char ( redraw-line ) ;
: handle-^E
   accept-len to accept-cur move-cursor ;
: handle-^F
   accept-cur accept-len <> IF accept-cur 1+ to accept-cur csi ." C" THEN ;
: handle-^H
   accept-cur 0= IF beep EXIT THEN
   handle-^B delete-char
;
: handle-^I
   accept-adr accept-len
   $tab-sift 0 > IF
      ?tab-pressed IF
         redraw-prompt full-redraw-line
         false to ?tab-pressed
      ELSE
         tab-last-adr accept-adr tab-last-len move    \ copy matching substring
         tab-last-len dup to accept-len to accept-cur \ len and cursor position
         full-redraw-line		\ redraw new string
         true to ?tab-pressed	\ second tab will print possible matches
      THEN
   THEN
;

: handle-^K
   BEGIN accept-cur accept-len <> WHILE delete-char REPEAT ;
: handle-^L
   history redraw-prompt full-redraw-line ;
: handle-^N
   his-cur IF his-cur his>next @ ELSE his-head THEN
   dup to his-cur select-history
;
: handle-^P
   his-cur IF his-cur his>prev @ ELSE his-tail THEN
   dup to his-cur select-history
;
: handle-^Q  \ Does not handle terminal formatting yet.
   key insert-char ;
: handle-^R
   full-redraw-line ;
: handle-^U
   0 to accept-len 0 to accept-cur full-redraw-line ;

: handle-fn
   key drop beep
;

TABLE-EXECUTE handle-CSI
0 , ' handle-^P , ' handle-^N , ' handle-^F ,
' handle-^B , 0 , 0 , 0 ,
' handle-^A , 0 , 0 , ' handle-^E ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,

: handle-CSI-key
    key 1f and handle-CSI
;

TABLE-EXECUTE handle-meta
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , ' handle-fn ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , ' handle-CSI-key ,
0 , 0 , 0 , 0 ,

: handle-ESC-O
   key
   dup 48 = IF
      handle-^A
   ELSE
      dup 46 = IF
         handle-^E
      THEN
   THEN drop
;

: handle-ESC-5b
   key
   dup 31 = IF \ HOME
      key drop ( drops closing 7e ) handle-^A
   ELSE
      dup 33 = IF \ DEL
         key drop handle-^D
      ELSE
         dup 34 = IF \ END
            key drop handle-^E
         ELSE
            dup 1f and handle-CSI
         THEN
      THEN
   THEN drop
;

: handle-ESC
   key
   dup 5b = IF
      handle-ESC-5b
   ELSE
      dup 4f = IF
         handle-ESC-O
      ELSE
         dup 1f and handle-meta
      THEN
   THEN drop
;

TABLE-EXECUTE handle-control
0 , \ ^@:
' handle-^A ,
' handle-^B ,
0 , \ ^C:
' handle-^D ,
' handle-^E ,
' handle-^F ,
0 , \ ^G:
' handle-^H ,
' handle-^I , \ tab
0 , \ ^J:
' handle-^K ,
' handle-^L ,
0 , \ ^M: enter: handled in main loop
' handle-^N ,
0 , \ ^O:
' handle-^P ,
' handle-^Q ,
' handle-^R ,
0 , \ ^S:
0 , \ ^T:
' handle-^U ,
0 , \ ^V:
0 , \ ^W:
0 , \ ^X:
0 , \ ^Y: insert save buffer
0 , \ ^Z:
' handle-ESC ,
0 , \ ^\:
0 , \ ^]:
0 , \ ^^:
0 , \ ^_:

: (accept) ( adr len -- len' )
   cursor-on
   to accept-max to accept-adr
   0 to accept-len 0 to accept-cur
   0 to his-cur
   1b emit 37 emit
   BEGIN
      key dup 0d <>
   WHILE
      dup 9 <> IF 0 to ?tab-pressed THEN \ reset state machine
      dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. ??? bogus
      dup bl < IF handle-control ELSE
         dup 80 and IF
            dup a0 < IF 7f and handle-meta ELSE drop beep THEN
         ELSE
            insert-char
	 THEN
      THEN
   REPEAT
   drop add-history
   accept-len to accept-cur
   move-cursor space
   accept-len
   cursor-off
;

' (accept) to accept