--- /dev/null
+\ *****************************************************************************
+\ * 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 ,
+
+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 ,
+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
+
Code Review / kvmfornfv.git / blobdiff