qemu/roms/SLOF/slof/fs/accept.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 \ Implementation of ACCEPT.  Using ECMA-48 for terminal control.
  15
  16 : beep  bell emit ;
  17
  18 : TABLE-EXECUTE
  19   CREATE DOES> swap cells+ @ ?dup IF execute ELSE beep THEN ;
  20
  21 0 VALUE accept-adr
  22 0 VALUE accept-max
  23 0 VALUE accept-len
  24 0 VALUE accept-cur
  25
  26 : esc  1b emit ;
  27 : csi  esc 5b emit ;
  28
  29 : move-cursor ( -- )
  30    esc ." 8" accept-cur IF
  31       csi base @ decimal accept-cur 0 .r base ! ." C"
  32    THEN
  33 ;
  34
  35 : redraw-line ( -- )
  36    accept-cur accept-len = IF EXIT THEN
  37    move-cursor
  38    accept-adr accept-len accept-cur /string type
  39    csi ." K" move-cursor
  40 ;
  41
  42 : full-redraw-line ( -- )
  43    accept-cur 0 to accept-cur move-cursor
  44    accept-adr accept-len type
  45    csi ." K" to accept-cur move-cursor
  46 ;
  47
  48 : redraw-prompt ( -- )
  49    cr depth . [char] > emit
  50 ;
  51
  52 : insert-char ( char -- )
  53    accept-len accept-max = IF drop beep EXIT THEN
  54    accept-cur accept-len <> IF csi ." @" dup emit
  55    accept-adr accept-cur + dup 1+ accept-len accept-cur - move
  56    ELSE dup emit THEN
  57    accept-adr accept-cur + c!
  58    accept-cur 1+ to accept-cur
  59    accept-len 1+ to accept-len redraw-line
  60 ;
  61
  62 : delete-char ( -- )
  63    accept-cur accept-len = IF beep EXIT THEN
  64    accept-len 1- to accept-len
  65    accept-adr accept-cur + dup 1+ swap accept-len accept-cur - move
  66    csi ." P" redraw-line
  67 ;
  68
  69 \ *
  70 \ * History handling
  71 \ *
  72
  73 STRUCT
  74 cell FIELD his>next
  75 cell FIELD his>prev
  76 cell FIELD his>len
  77    0 FIELD his>buf
  78 CONSTANT /his
  79 0 VALUE his-head
  80 0 VALUE his-tail
  81 0 VALUE his-cur
  82
  83 : add-history ( -- )
  84    accept-len 0= IF EXIT THEN
  85    /his accept-len + alloc-mem
  86    his-tail IF dup his-tail his>next ! ELSE dup to his-head THEN
  87    his-tail over his>prev !  0 over his>next !  dup to his-tail
  88    accept-len over his>len !  accept-adr swap his>buf accept-len move
  89 ;
  90
  91 : history  ( -- )
  92    his-head BEGIN dup WHILE
  93    cr dup his>buf over his>len @ type
  94    his>next @ REPEAT drop
  95 ;
  96
  97 : select-history ( his -- )
  98    dup to his-cur dup IF
  99    dup his>len @ accept-max min dup to accept-len to accept-cur
 100    his>buf accept-adr accept-len move ELSE
 101    drop 0 to accept-len 0 to accept-cur THEN
 102    full-redraw-line
 103 ;
 104
 105
 106 \
 107 \ tab completion
 108 \
 109
 110 \ tab completion state variables
 111 0 value ?tab-pressed
 112 0 value tab-last-adr
 113 0 value tab-last-len
 114
 115 \ compares two strings and returns the longest equal substring.
 116 : $same-string ( addr-1 len-1 addr-2 len-2 -- addr-1 len-1' )
 117    dup 0= IF    \ The second parameter is not a string.
 118       2drop EXIT \ bail out
 119    THEN
 120    rot min 0 0 -rot ( addr1 addr2 0 len' 0 )
 121    DO ( addr1 addr2 len-1' )
 122       2 pick i + c@ lcc
 123       2 pick i + c@ lcc
 124       = IF 1 + ELSE leave THEN
 125    LOOP
 126    nip
 127 ;
 128
 129 : $tab-sift-words    ( text-addr text-len -- sift-count )
 130    sift-compl-only >r true to sift-compl-only \ save sifting mode
 131
 132    last BEGIN @ ?dup WHILE \ loop over all words
 133       $inner-sift IF \ any completions possible?
 134          \ convert to lower case for user interface sanity
 135          2dup bounds DO I c@ lcc I c! LOOP
 136          ?tab-pressed IF 2dup type space THEN  \ <tab><tab> prints possibilities
 137          tab-last-adr tab-last-len $same-string \ find matching substring ...
 138          to tab-last-len to tab-last-adr       \ ... and save it
 139       THEN
 140    repeat
 141    2drop
 142
 143    #sift-count 0 to #sift-count \ how many words were found?
 144    r> to sift-compl-only                \ restore sifting completion mode
 145 ;
 146
 147 \ 8< node sifting for tab completion on device tree nodes below this line 8<
 148
 149 #include <stack.fs>
 150
 151 10 new-stack device-stack
 152
 153 : (next-dev) ( node -- node' addr len )
 154    device-stack
 155    dup (node>path) rot
 156    dup child IF dup push child -rot EXIT THEN
 157    dup peer IF peer -rot EXIT THEN
 158    drop
 159    BEGIN
 160       stack-depth
 161    WHILE
 162       pop peer ?dup IF -rot EXIT THEN
 163    REPEAT
 164    0 -rot
 165 ;
 166
 167 : $inner-sift-nodes ( text-addr text-len node -- ... path-addr path-len true | false )
 168    (next-dev) ( text-addr text-len node' path-addr path-len )
 169    dup 0= IF drop false EXIT THEN
 170    2dup 6 pick 6 pick find-isubstr ( text-addr text-len node' path-addr path-len pos )
 171    0= IF
 172       #sift-count 1+ to #sift-count \ count completions
 173       true
 174    ELSE
 175       2drop false
 176    THEN
 177 ;
 178
 179 \
 180 \ test function for (next-dev)
 181 : .nodes ( -- )
 182    s" /" find-node BEGIN dup WHILE
 183       (next-dev)
 184       type cr
 185    REPEAT
 186    drop
 187    reset-stack
 188 ;
 189
 190 \ node sifting wants its own pockets
 191 create sift-node-buffer 1000 allot
 192 0 value sift-node-num
 193 : sift-node-buffer
 194    sift-node-buffer sift-node-num 100 * +
 195    sift-node-num 1+ dup 10 = IF drop 0 THEN
 196    to sift-node-num
 197 ;
 198
 199 : $tab-sift-nodes    ( text-addr text-len -- sift-count )
 200    s" /" find-node BEGIN dup WHILE
 201       $inner-sift-nodes IF \ any completions possible?
 202          sift-node-buffer swap 2>r 2r@ move 2r> \ make an almost permanent copy without strdup
 203          ?tab-pressed IF 2dup type space THEN  \ <tab><tab> prints possibilities
 204          tab-last-adr tab-last-len $same-string \ find matching substring ...
 205          to tab-last-len to tab-last-adr       \ ... and save it
 206       THEN
 207    REPEAT
 208    2drop drop
 209    #sift-count 0 to #sift-count \ how many words were found?
 210    reset-stack
 211 ;
 212
 213 : $tab-sift    ( text-addr text-len -- sift-count )
 214    ?tab-pressed IF beep space THEN \ cosmetical fix for <tab><tab>
 215
 216    dup IF bl rsplit dup IF 2swap THEN ELSE 0 0 THEN >r >r
 217
 218    0 dup to tab-last-len to tab-last-adr        \ reset last possible match
 219    current-node @ IF                    \ if we are in a node?
 220       2dup 2>r                          \ save text
 221       $tab-sift-words to #sift-count    \ search in current node first
 222       2r>                               \ fetch text to complete, again
 223    THEN
 224    2dup 2>r
 225    current-node @ >r 0 set-node         \ now search in global words
 226    $tab-sift-words to #sift-count
 227    r> set-node
 228    2r> $tab-sift-nodes
 229    \ concatenate previous commands
 230    r> r> dup IF s"  " $cat THEN tab-last-adr tab-last-len $cat
 231    to tab-last-len to tab-last-adr  \ ... and save the whole string
 232 ;
 233
 234 \ 8< node sifting for tab completion on device tree nodes above this line 8<
 235
 236 : handle-^A
 237    0 to accept-cur move-cursor ;
 238 : handle-^B
 239    accept-cur ?dup IF 1- to accept-cur ( csi ." D" ) move-cursor THEN ;
 240 : handle-^D
 241    delete-char ( redraw-line ) ;
 242 : handle-^E
 243    accept-len to accept-cur move-cursor ;
 244 : handle-^F
 245    accept-cur accept-len <> IF accept-cur 1+ to accept-cur csi ." C" THEN ;
 246 : handle-^H
 247    accept-cur 0= IF beep EXIT THEN
 248    handle-^B delete-char
 249 ;
 250 : handle-^I
 251    accept-adr accept-len
 252    $tab-sift 0 > IF
 253       ?tab-pressed IF
 254          redraw-prompt full-redraw-line
 255          false to ?tab-pressed
 256       ELSE
 257          tab-last-adr accept-adr tab-last-len move    \ copy matching substring
 258          tab-last-len dup to accept-len to accept-cur \ len and cursor position
 259          full-redraw-line               \ redraw new string
 260          true to ?tab-pressed   \ second tab will print possible matches
 261       THEN
 262    THEN
 263 ;
 264
 265 : handle-^K
 266    BEGIN accept-cur accept-len <> WHILE delete-char REPEAT ;
 267 : handle-^L
 268    history redraw-prompt full-redraw-line ;
 269 : handle-^N
 270    his-cur IF his-cur his>next @ ELSE his-head THEN
 271    dup to his-cur select-history
 272 ;
 273 : handle-^P
 274    his-cur IF his-cur his>prev @ ELSE his-tail THEN
 275    dup to his-cur select-history
 276 ;
 277 : handle-^Q  \ Does not handle terminal formatting yet.
 278    key insert-char ;
 279 : handle-^R
 280    full-redraw-line ;
 281 : handle-^U
 282    0 to accept-len 0 to accept-cur full-redraw-line ;
 283
 284 : handle-fn
 285    key drop beep
 286 ;
 287
 288 TABLE-EXECUTE handle-CSI
 289 0 , ' handle-^P , ' handle-^N , ' handle-^F ,
 290 ' handle-^B , 0 , 0 , 0 ,
 291 ' handle-^A , 0 , 0 , ' handle-^E ,
 292 0 , 0 , 0 , 0 ,
 293 0 , 0 , 0 , 0 ,
 294 0 , 0 , 0 , 0 ,
 295 0 , 0 , 0 , 0 ,
 296 0 , 0 , 0 , 0 ,
 297
 298 TABLE-EXECUTE handle-meta
 299 0 , 0 , 0 , 0 ,
 300 0 , 0 , 0 , 0 ,
 301 0 , 0 , 0 , 0 ,
 302 0 , 0 , 0 , ' handle-fn ,
 303 0 , 0 , 0 , 0 ,
 304 0 , 0 , 0 , 0 ,
 305 0 , 0 , 0 , ' handle-CSI ,
 306 0 , 0 , 0 , 0 ,
 307
 308 : handle-ESC-O
 309    key
 310    dup 48 = IF
 311       handle-^A
 312    ELSE
 313       dup 46 = IF
 314          handle-^E
 315       THEN
 316    THEN drop
 317 ;
 318
 319 : handle-ESC-5b
 320    key
 321    dup 31 = IF \ HOME
 322       key drop ( drops closing 7e ) handle-^A
 323    ELSE
 324       dup 33 = IF \ DEL
 325          key drop handle-^D
 326       ELSE
 327          dup 34 = IF \ END
 328             key drop handle-^E
 329          ELSE
 330             dup 1f and handle-CSI
 331          THEN
 332       THEN
 333    THEN drop
 334 ;
 335
 336 : handle-ESC
 337    key
 338    dup 5b = IF
 339       handle-ESC-5b
 340    ELSE
 341       dup 4f = IF
 342          handle-ESC-O
 343       ELSE
 344          dup 1f and handle-meta
 345       THEN
 346    THEN drop
 347 ;
 348
 349 TABLE-EXECUTE handle-control
 350 0 , \ ^@:
 351 ' handle-^A ,
 352 ' handle-^B ,
 353 0 , \ ^C:
 354 ' handle-^D ,
 355 ' handle-^E ,
 356 ' handle-^F ,
 357 0 , \ ^G:
 358 ' handle-^H ,
 359 ' handle-^I , \ tab
 360 0 , \ ^J:
 361 ' handle-^K ,
 362 ' handle-^L ,
 363 0 , \ ^M: enter: handled in main loop
 364 ' handle-^N ,
 365 0 , \ ^O:
 366 ' handle-^P ,
 367 ' handle-^Q ,
 368 ' handle-^R ,
 369 0 , \ ^S:
 370 0 , \ ^T:
 371 ' handle-^U ,
 372 0 , \ ^V:
 373 0 , \ ^W:
 374 0 , \ ^X:
 375 0 , \ ^Y: insert save buffer
 376 0 , \ ^Z:
 377 ' handle-ESC ,
 378 0 , \ ^\:
 379 0 , \ ^]:
 380 0 , \ ^^:
 381 0 , \ ^_:
 382
 383 : (accept) ( adr len -- len' )
 384    cursor-on
 385    to accept-max to accept-adr
 386    0 to accept-len 0 to accept-cur
 387    0 to his-cur
 388    1b emit 37 emit
 389    BEGIN
 390       key dup 0d <>
 391    WHILE
 392       dup 9 <> IF 0 to ?tab-pressed THEN \ reset state machine
 393       dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. ??? bogus
 394       dup bl < IF handle-control ELSE
 395          dup 80 and IF
 396             dup a0 < IF 7f and handle-meta ELSE drop beep THEN
 397          ELSE
 398             insert-char
 399          THEN
 400       THEN
 401    REPEAT
 402    drop add-history
 403    accept-len to accept-cur
 404    move-cursor space
 405    accept-len
 406    cursor-off
 407 ;
 408
 409 ' (accept) to accept
 410