version 1.35, 2004/12/27 20:05:53
|
version 1.40, 2005/01/12 21:21:53
|
Line 1
|
Line 1
|
\ command line edit and history support 16oct94py |
\ command line edit and history support 16oct94py |
|
|
\ Copyright (C) 1995,2000,2003 Free Software Foundation, Inc. |
\ Copyright (C) 1995,2000,2003,2004 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 218 Create prefix-found 0 , 0 ,
|
Line 218 Create prefix-found 0 , 0 ,
|
prefix-found @ IF bl (ins) THEN 0 ; |
prefix-found @ IF bl (ins) THEN 0 ; |
|
|
: kill-prefix ( key -- key ) |
: kill-prefix ( key -- key ) |
dup #tab <> IF 0 0 prefix-found 2! THEN ; |
dup #tab <> IF prefix-off THEN ; |
|
|
[IFUNDEF] everyline defer everyline [THEN] |
[IFUNDEF] everyline defer everyline [THEN] |
|
|
: 8-bit-io ( -- ) |
: char-history ( -- ) |
|
\ might be useful on dumb terminals, otherwise unused |
['] forw ctrl F bindkey |
['] forw ctrl F bindkey |
['] back ctrl B bindkey |
['] back ctrl B bindkey |
['] ?del ctrl H bindkey |
['] ?del ctrl H bindkey |
Line 238 Create prefix-found 0 , 0 ,
|
Line 239 Create prefix-found 0 , 0 ,
|
['] tab-expand #tab bindkey |
['] tab-expand #tab bindkey |
['] (ins) IS insert-char |
['] (ins) IS insert-char |
['] kill-prefix IS everychar |
['] kill-prefix IS everychar |
['] noop IS everyline |
['] noop IS everyline ; |
[ action-of key ] Literal IS key |
|
[ action-of emit ] Literal IS emit ; |
|
|
|
\ UTF-8 support |
\ UTF-8 support |
|
|
include utf-8.fs |
require utf-8.fs |
|
|
: utf-8-cold ( -- ) |
[IFUNDEF] #esc 27 Constant #esc [THEN] |
s" LANG" getenv s" .UTF-8" search nip nip |
|
IF utf-8-io ELSE 8-bit-io THEN ; |
|
|
|
' utf-8-cold INIT8 chained |
: save-cursor ( -- ) #esc emit '7 emit ; |
|
: restore-cursor ( -- ) #esc emit '8 emit ; |
|
: .rest ( addr pos1 -- addr pos1 ) |
|
restore-cursor 2dup type ; |
|
: .all ( span addr pos1 -- span addr pos1 ) |
|
restore-cursor >r 2dup swap type r> ; |
|
|
|
: <xins> ( max span addr pos1 xc -- max span addr pos2 ) |
|
>r 2over r@ xc-size + u< IF ( max span addr pos1 R:xc ) |
|
rdrop bell EXIT THEN |
|
>string over r@ xc-size + swap move |
|
2dup chars + r@ swap r@ xc-size xc!+? 2drop drop |
|
r> xc-size >r rot r@ chars + -rot r> chars + ; |
|
: (xins) ( max span addr pos1 xc -- max span addr pos2 ) |
|
<xins> .all .rest ; |
|
: xback ( max span addr pos1 -- max span addr pos2 f ) |
|
dup IF over + xchar- over - 0 max .all .rest |
|
ELSE bell THEN 0 ; |
|
: xforw ( max span addr pos1 -- max span addr pos2 f ) |
|
2 pick over <> IF over + xc@+ xemit over - ELSE bell THEN 0 ; |
|
: (xdel) ( max span addr pos1 -- max span addr pos2 ) |
|
over + dup xchar- tuck - >r over - |
|
>string over r@ + -rot move |
|
rot r> - -rot ; |
|
: ?xdel ( max span addr pos1 -- max span addr pos2 0 ) |
|
dup IF (xdel) .all 2 spaces .rest THEN 0 ; |
|
: <xdel> ( max span addr pos1 -- max span addr pos2 0 ) |
|
2 pick over <> |
|
IF xforw drop (xdel) .all 2 spaces .rest |
|
ELSE bell THEN 0 ; |
|
: xeof 2 pick over or 0= IF bye ELSE <xdel> THEN ; |
|
|
|
: xfirst-pos ( max span addr pos1 -- max span addr 0 0 ) |
|
drop 0 .all .rest 0 ; |
|
: xend-pos ( max span addr pos1 -- max span addr span 0 ) |
|
drop over .all 0 ; |
|
|
|
|
|
: xclear-line ( max span addr pos1 -- max addr ) |
|
drop restore-cursor swap spaces restore-cursor ; |
|
: xclear-tib ( max span addr pos -- max 0 addr 0 false ) |
|
xclear-line 0 tuck dup ; |
|
|
|
: (xenter) ( max span addr pos1 -- max span addr pos2 true ) |
|
>r end^ 2@ hist-setpos |
|
2dup swap history write-line drop ( throw ) \ don't worry about errors |
|
hist-pos 2dup backward^ 2! end^ 2! |
|
r> .all space true ; |
|
|
|
: xkill-expand ( max span addr pos1 -- max span addr pos2 ) |
|
prefix-found cell+ @ ?dup IF >r |
|
r@ - >string over r@ + -rot move |
|
rot r@ - -rot .all r> spaces .rest THEN ; |
|
|
|
: insert ( string length buffer size -- ) |
|
rot over min >r r@ - ( left over ) |
|
over dup r@ + rot move r> move ; |
|
|
|
: xtab-expand ( max span addr pos1 -- max span addr pos2 0 ) |
|
key? IF #tab (xins) 0 EXIT THEN |
|
xkill-expand 2dup extract-word dup 0= IF nip EXIT THEN |
|
search-prefix tib-full? |
|
IF bell 2drop prefix-off |
|
ELSE dup >r |
|
2>r >string r@ + 2r> 2swap insert |
|
r@ + rot r> + -rot |
|
THEN |
|
prefix-found @ IF bl (xins) ELSE .all .rest THEN 0 ; |
|
|
|
: xchar-history ( -- ) |
|
['] xforw ctrl F bindkey |
|
['] xback ctrl B bindkey |
|
['] ?xdel ctrl H bindkey |
|
['] xeof ctrl D bindkey |
|
['] <xdel> ctrl X bindkey |
|
['] xclear-tib ctrl K bindkey |
|
['] xfirst-pos ctrl A bindkey |
|
['] xend-pos ctrl E bindkey |
|
['] (xenter) #lf bindkey |
|
['] (xenter) #cr bindkey |
|
['] xtab-expand #tab bindkey |
|
['] (xins) IS insert-char |
|
['] kill-prefix IS everychar |
|
['] save-cursor IS everyline ; |
|
|
utf-8-cold |
xchar-history |
|
|
\ initializing history |
\ initializing history |
|
|