\ ***************************************************************************** \ * 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 \ 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 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 \ 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 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