--- gforth/history.fs 2007/09/30 19:46:10 1.63 +++ gforth/history.fs 2010/01/23 22:19:50 1.73 @@ -1,12 +1,12 @@ \ command line edit and history support 16oct94py -\ Copyright (C) 1995,2000,2003,2004,2005,2006 Free Software Foundation, Inc. +\ Copyright (C) 1995,2000,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,13 +15,14 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. +: ctrl-i ( "" -- c ) + char toupper $40 xor ; + +' ctrl-i :noname - char [char] @ - ; -:noname - char [char] @ - postpone Literal ; + ctrl-i postpone Literal ; interpret/compile: ctrl ( "" -- ctrl-code ) \ command line editing 16oct94py @@ -76,8 +77,7 @@ defer cur-correct ( addr u -- ) Variable linew Variable screenw - -: linew-off linew off form nip screenw ! ; +: linew-off linew off cols screenw ! ; [IFDEF] x-width : clear-line ( max span addr pos1 -- max addr ) @@ -207,12 +207,14 @@ require utf-8.fs [IFUNDEF] #esc 27 Constant #esc [THEN] : at-deltaxy ( dx dy -- ) + over 0< over 0= and IF drop abs backspaces EXIT THEN + base @ >r decimal ?dup IF #esc emit '[ emit dup abs 0 .r 0< IF 'A ELSE 'B THEN emit THEN ?dup IF #esc emit '[ emit dup abs 0 .r 0< IF 'D ELSE 'C THEN emit - THEN ; + THEN r> base ! ; \ : cygwin? ( -- flag ) s" TERM" getenv s" cygwin" str= ; \ : at-xy? ( -- x y ) @@ -237,7 +239,7 @@ require utf-8.fs linew @ xback-restore >r 2dup swap type 2dup swap cur-correct r> ; : xretype ( max span addr pos1 -- max span addr pos1 f ) - .all form nip screenw @ >r screenw ! + .all cols screenw @ >r screenw ! linew @ screenw @ / linew @ r@ / max screenw @ r> - * 0 max dup spaces linew +! .rest false ; @@ -252,7 +254,7 @@ require utf-8.fs 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 ) - .all .rest ; + key? 0= IF .all .rest THEN ; : xback ( max span addr pos1 -- max span addr pos2 f ) dup IF over + xchar- over - 0 max .all .rest ELSE bell THEN 0 ; @@ -276,11 +278,8 @@ require utf-8.fs : xend-pos ( max span addr pos1 -- max span addr span 0 ) drop over .all 0 ; - -: xclear-line ( max span addr pos1 -- max addr ) - 2dup x-width dup xback-restore dup spaces xback-restore drop nip ; -: xclear-tib ( max span addr pos -- max 0 addr 0 false ) - xclear-line 0 tuck dup ; +: xclear-rest ( max span addr pos -- max pos addr pos false ) + rot >r tuck 2dup r> swap /string u8width dup spaces linew +! .all 0 ; : (xenter) ( max span addr pos1 -- max span addr pos2 true ) >r end^ 2@ hist-setpos @@ -314,7 +313,7 @@ require utf-8.fs ['] ?xdel ctrl H bindkey ['] xeof ctrl D bindkey ['] ctrl X bindkey - ['] xclear-tib ctrl K bindkey + ['] xclear-rest ctrl K bindkey ['] xfirst-pos ctrl A bindkey ['] xend-pos ctrl E bindkey ['] xretype ctrl L bindkey @@ -323,7 +322,9 @@ require utf-8.fs ['] xtab-expand #tab bindkey ['] (xins) IS insert-char ['] kill-prefix IS everychar +[ifdef] everyline ['] linew-off IS everyline +[endif] ['] xback-restore IS back-restore ['] xcur-correct IS cur-correct ;