diff options
Diffstat (limited to 'qemu/roms/SLOF/slof/fs/accept.fs')
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/accept.fs | 410 |
1 files changed, 410 insertions, 0 deletions
diff --git a/qemu/roms/SLOF/slof/fs/accept.fs b/qemu/roms/SLOF/slof/fs/accept.fs new file mode 100644 index 000000000..7e8e2717e --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/accept.fs @@ -0,0 +1,410 @@ +\ ***************************************************************************** +\ * 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 + |