--- gforth/history.fs	1996/05/09 18:13:00	1.10
+++ gforth/history.fs	2007/06/17 19:26:42	1.57
@@ -1,6 +1,6 @@
-\ History file support                                 16oct94py
+\ command line edit and history support                 16oct94py
 
-\ Copyright (C) 1995 Free Software Foundation, Inc.
+\ Copyright (C) 1995,2000,2003,2004,2005,2006 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -16,41 +16,76 @@
 
 \ 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 
-0 Value history
+:noname
+    char [char] @ - ;
+:noname
+    char [char] @ - postpone Literal ;
+interpret/compile: ctrl  ( "<char>" -- ctrl-code )
+
+\ command line editing                                  16oct94py
+
+: >string  ( span addr pos1 -- span addr pos1 addr2 len )
+  over 3 pick 2 pick chars /string ;
+
+: bindkey ( xt key -- )  cells ctrlkeys + ! ;
+
+\ history support                                       16oct94py
+
+0 Value history \ history file fid
 
 2Variable forward^
 2Variable backward^
 2Variable end^
 
-: force-open ( addr len -- handle )
-  2dup r/w open-file 0<
-  IF  drop r/w create-file throw  ELSE  nip nip  THEN ;
-
-: get-history ( addr len -- wid )
-  force-open to history
-  history file-size throw
-  2dup forward^ 2! 2dup backward^ 2! end^ 2! ;
-
-s" ~/.gforth-history" get-history
-
-: history-cold
-    Defers 'cold
-    s" ~/.gforth-history" get-history ;
+: force-open ( addr len -- fid )
+    2dup r/w open-file
+    IF
+	drop r/w create-file throw
+    ELSE
+	nip nip
+    THEN ;
+
+s" os-class" environment? [IF] s" unix" str= [ELSE] true [THEN] 
+[IF]
+: history-file ( -- addr u )
+    s" GFORTHHIST" getenv dup 0= IF
+	2drop s" ~/.gforth-history"
+    THEN ;
+[ELSE]
 
-' history-cold IS 'cold
+: history-dir ( -- addr u )
+  s" TMP" getenv ?dup ?EXIT drop
+  s" TEMP" getenv ?dup ?EXIT drop
+  s" c:/" ;
+
+: history-file ( -- addr u )
+  s" GFORTHHIST" getenv ?dup ?EXIT
+  drop
+  history-dir pad place
+  s" /ghist.fs" pad +place pad count ;
+[THEN]
 
 \ moving in history file                               16oct94py
 
-: clear-line ( max span addr pos1 -- max addr )
-  backspaces over spaces swap backspaces ;
+defer back-restore ( u -- )
+defer cur-correct ( addr u -- )
+' backspaces IS back-restore
+' 2drop IS cur-correct
 
-: clear-tib ( max span addr pos -- max 0 addr 0 false )
-  clear-line 0 tuck dup ;
+[IFDEF] x-width
+: clear-line ( max span addr pos1 -- max addr )
+  back-restore over over swap x-width spaces swap back-restore ;
+[ELSE]
+: clear-line ( max span addr pos1 -- max addr )
+  back-restore over spaces swap back-restore ;
+[THEN]
+\ : clear-tib ( max span addr pos -- max 0 addr 0 false )
+\   clear-line 0 tuck dup ;
 
-: hist-pos    ( -- ud )  history file-position throw ;
-: hist-setpos ( ud -- )  history reposition-file throw ;
+: hist-pos    ( -- ud )  history file-position drop ( throw ) ;
+: hist-setpos ( ud -- )  history reposition-file drop ( throw ) ;
 
 : get-line ( addr len -- len' flag )
   swap history read-line throw ;
@@ -60,44 +95,44 @@ s" ~/.gforth-history" get-history
   forward^ 2@ 2dup hist-setpos backward^ 2!
   2dup get-line drop
   hist-pos  forward^ 2!
-  tuck 2dup type 0 ;
+  tuck 2dup type 2dup cur-correct 0 ;
 
-: prev-line  ( max span addr pos1 -- max span addr pos2 false )
-  clear-line  backward^ 2@ forward^ 2!
+: find-prev-line ( max addr -- max span addr pos2 )
+  backward^ 2@ forward^ 2!
   over 2 + negate s>d backward^ 2@ d+ 0. dmax 2dup hist-setpos
   BEGIN
       backward^ 2!   2dup get-line  WHILE
       hist-pos 2dup forward^ 2@ d<  WHILE
       rot drop
-  REPEAT  2drop  THEN
-  tuck 2dup type 0 ;
+  REPEAT  2drop  THEN  tuck ;
 
-: ctrl ( compilation: "<char>" -- ) ( run-time: -- ctrl-code )
-    char [char] @ - postpone Literal ; immediate
-interpretation: ( "<char>" -- ctrl-code )
-    char [char] @ - ;
+: prev-line  ( max span addr pos1 -- max span addr pos2 false )
+    clear-line find-prev-line 2dup type 2dup cur-correct 0 ;
 
-Create lfpad #lf c,
+\ Create lfpad #lf c,
 
 : (enter)  ( max span addr pos1 -- max span addr pos2 true )
   >r end^ 2@ hist-setpos
-  2dup swap history write-line throw
+  2dup swap history write-line drop ( throw ) \ don't worry about errors
   hist-pos 2dup backward^ 2! end^ 2!
   r> (ret) ;
 
-\ some other key commands                              16oct94py
-
-: first-pos  ( max span addr pos1 -- max span addr 0 0 )
-  backspaces 0 0 ;
-: end-pos  ( max span addr pos1 -- max span addr span 0 )
-  type-rest 2drop over 0 ;
-
 : extract-word ( addr len -- addr' len' )  dup >r
   BEGIN  1- dup 0>=  WHILE  2dup + c@ bl =  UNTIL  THEN  1+
   tuck + r> rot - ;
 
 Create prefix-found  0 , 0 ,
 
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
+
+: capscomp  ( c_addr1 u c_addr2 -- n )
+ swap bounds
+ ?DO  dup c@ I c@ <>
+     IF  dup c@ toupper I c@ toupper =
+     ELSE  true  THEN  WHILE  1+  LOOP  drop 0
+ ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
+
 : word-lex ( nfa1 nfa2 -- -1/0/1 )
     dup 0=
     IF
@@ -135,45 +170,190 @@ Create prefix-found  0 , 0 ,
     REPEAT
     drop r> ;
 
+: prefix-off ( -- )  0 0 prefix-found 2! ;
+
 : prefix-string ( addr len nfa -- addr' len' )
     dup prefix-found !  ?dup
     IF
 	name>string rot /string rot drop
 	dup 1+ prefix-found cell+ !
     ELSE
-	2drop s" " prefix-found cell+ off
+	2drop s" " prefix-off
     THEN ;
 
 : search-prefix  ( addr1 len1 -- addr2 len2 )
     0 vp dup @ 1- cells over +
     DO  I 2@ <>
-        IF  I cell+ @ @ swap  search-voc  THEN
+        IF  I cell+ @ wordlist-id @ swap  search-voc  THEN
 	[ -1 cells ] Literal +LOOP
     prefix-string ;
 
-: kill-expand ( max span addr pos1 -- max span addr pos2 )
-    prefix-found cell+ @  0 ?DO  (del)  LOOP ;
-
 : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
     5 pick over 4 pick + prefix-found @ 0<> - < ;
 
-: tab-expand ( max span addr pos1 -- max span addr pos2 0 )
-    kill-expand  2dup extract-word search-prefix
-    tib-full?
-    IF    7 emit  2drop  0 0 prefix-found 2!
-    ELSE  bounds ?DO  I c@ (ins)  LOOP  THEN
-    prefix-found @ IF  bl (ins)  THEN  0 ;
-
 : kill-prefix  ( key -- key )
-  dup #tab <> IF  0 0 prefix-found 2!  THEN ;
+  dup #tab <> IF  prefix-off  THEN ;
+
+\ UTF-8 support
+
+require utf-8.fs
+
+[IFUNDEF] #esc  27 Constant #esc  [THEN]
+
+Variable curpos
+
+: cygwin? ( -- flag ) s" TERM" getenv s" cygwin" str= ;
+: at-xy? ( -- x y )
+    key? drop
+    #esc emit ." [6n"  0 0
+    BEGIN  key dup 'R <>  WHILE
+	    dup '; = IF  drop  swap  ELSE
+		dup '0 '9 1+ within  IF  '0 - swap 10 * +  ELSE
+		    drop  THEN  THEN
+    REPEAT  drop 1- swap 1- ;
+: cursor@ ( -- n )  at-xy? form nip * + ;
+: cursor! ( n -- )  form nip /mod at-xy ;
+: xcur-correct  ( addr u -- )
+    cygwin? curpos @ -1 = or  IF  2drop EXIT  THEN
+    x-width curpos @ + cursor@ -
+    form nip >r  r@ 2/ + r@ / r> * negate curpos +! ;
+: save-cursor ( -- )
+    cygwin? IF  #esc emit '7 emit  ELSE
+	key? IF  -1  ELSE  cursor@  THEN  curpos !  THEN ;
+: restore-cursor ( -- )
+    cygwin? IF  #esc emit '8 emit  ELSE
+	curpos @ dup -1 = IF  drop  ELSE   cursor!  THEN  THEN ;
+
+' xcur-correct IS cur-correct
+
+: .rest ( addr pos1 -- addr pos1 )
+    key? ?EXIT
+    restore-cursor 2dup type 2dup cur-correct ;
+: .all ( span addr pos1 -- span addr pos1 )
+    key? ?EXIT
+    restore-cursor >r 2dup swap type 2dup swap cur-correct r> ;
+: xback-restore ( u -- )
+    drop key? ?EXIT
+    restore-cursor ;
+
+\ In the following, addr max is the buffer, addr span is the current
+\ string in the buffer, and pos1 is the cursor position in the buffer.
+
+: <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> curpos @ -1 = key? or IF
+	>r 2dup swap type r>
+    ELSE
+	.all
+    THEN 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
+    history IF  ['] (xenter)     #lf    bindkey  THEN
+    history IF  ['] (xenter)     #cr    bindkey  THEN
+    ['] xtab-expand  #tab   bindkey
+    ['] (xins)       IS insert-char
+    ['] kill-prefix  IS everychar
+    ['] save-cursor  IS everyline
+    ['] xback-restore IS back-restore
+    ['] xcur-correct  IS cur-correct
+;
+
+xchar-history
+
+\ initializing history
+
+: get-history ( addr len -- )
+    ['] force-open catch
+    ?dup-if
+	\ !! >stderr
+        \ history-file type ." : " .error cr
+	drop 2drop 0 to history
+	['] false ['] false ['] (ret)
+    else
+	to history
+	history file-size throw
+	2dup forward^ 2! 2dup backward^ 2! end^ 2!
+	['] next-line ['] prev-line ['] (enter)
+    endif
+    dup #lf bindkey
+        #cr bindkey
+     ctrl P bindkey
+     ctrl N bindkey
+;
+
+: history-cold ( -- )
+    history-file get-history xchar-history ;
+
+:noname ( -- )
+    defers 'cold
+    history-cold
+; is 'cold
 
-' kill-prefix IS everychar
+history-cold
 
-' next-line  ctrl N cells ctrlkeys + !
-' prev-line  ctrl P cells ctrlkeys + !
-' clear-tib  ctrl K cells ctrlkeys + !
-' first-pos  ctrl A cells ctrlkeys + !
-' end-pos    ctrl E cells ctrlkeys + !
-' (enter)    #lf    cells ctrlkeys + !
-' (enter)    #cr    cells ctrlkeys + !
-' tab-expand #tab   cells ctrlkeys + !