gforth/history.fs - diff

Return to history.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/history.fs between versions 1.43 and 1.59

version 1.43, 2005/12/31 15:46:08	version 1.59, 2007/07/01 11:32:44
Line 1	Line 1
\ command line edit and history support 16oct94py	\ command line edit and history support 16oct94py

\ Copyright (C) 1995,2000,2003,2004,2005 Free Software Foundation, Inc.	\ Copyright (C) 1995,2000,2003,2004,2005,2006 Free Software Foundation, Inc.

\ This file is part of Gforth.	\ This file is part of Gforth.

Line 69 s" os-class" environment? [IF] s" unix"	Line 69 s" os-class" environment? [IF] s" unix"

\ moving in history file 16oct94py	\ moving in history file 16oct94py

: clear-line ( max span addr pos1 -- max addr )	defer back-restore ( u -- )
backspaces over spaces swap backspaces ;	defer cur-correct ( addr u -- )
	' backspaces IS back-restore
	' 2drop IS cur-correct

	[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-tib ( max span addr pos -- max 0 addr 0 false )
\ clear-line 0 tuck dup ;	\ clear-line 0 tuck dup ;

Line 86 s" os-class" environment? [IF] s" unix"	Line 95 s" os-class" environment? [IF] s" unix"
forward^ 2@ 2dup hist-setpos backward^ 2!	forward^ 2@ 2dup hist-setpos backward^ 2!
2dup get-line drop	2dup get-line drop
hist-pos forward^ 2!	hist-pos forward^ 2!
tuck 2dup type 0 ;	tuck 2dup type 2dup cur-correct 0 ;

: find-prev-line ( max addr -- max span addr pos2 )	: find-prev-line ( max addr -- max span addr pos2 )
backward^ 2@ forward^ 2!	backward^ 2@ forward^ 2!
Line 98 s" os-class" environment? [IF] s" unix"	Line 107 s" os-class" environment? [IF] s" unix"
REPEAT 2drop THEN tuck ;	REPEAT 2drop THEN tuck ;

: prev-line ( max span addr pos1 -- max span addr pos2 false )	: prev-line ( max span addr pos1 -- max span addr pos2 false )
clear-line find-prev-line 2dup type 0 ;	clear-line find-prev-line 2dup type 2dup cur-correct 0 ;

\ Create lfpad #lf c,	\ Create lfpad #lf c,

Line 191 require utf-8.fs	Line 200 require utf-8.fs

[IFUNDEF] #esc 27 Constant #esc [THEN]	[IFUNDEF] #esc 27 Constant #esc [THEN]

: save-cursor ( -- ) #esc emit '7 emit ;	Variable curpos
: restore-cursor ( -- ) #esc emit '8 emit ;	Variable screenw

	: cygwin? ( -- flag ) s" TERM" getenv s" cygwin" str= ;
	: at-xy? ( -- x y )
	#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? screenw @ * + ;
	: cursor! ( n -- ) screenw @ /mod at-xy ;
	: xcur-correct ( addr u -- )
	cygwin? curpos @ -1 = or IF 2drop EXIT THEN
	x-width curpos @ + cursor@ -
	screenw @ >r r@ 2/ + r@ / r> * negate curpos +! ;
	: save-cursor ( -- )
	cygwin? IF #esc emit '7 emit ELSE
	key? IF -1 ELSE form nip screenw ! 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 )	: .rest ( addr pos1 -- addr pos1 )
restore-cursor 2dup type ;	key? ?EXIT
	restore-cursor 2dup type 2dup cur-correct ;
: .all ( span addr pos1 -- span addr pos1 )	: .all ( span addr pos1 -- span addr pos1 )
restore-cursor >r 2dup swap type r> ;	key? ?EXIT
	restore-cursor >r 2dup swap type 2dup swap cur-correct r> ;
	: xback-restore ( u -- )
	drop key? ?EXIT
	restore-cursor ;

	: xretype ( max span addr pos1 -- max span addr pos1 )
	restore-cursor screenw @ >r save-cursor
	.all 2 pick r@ / screenw @ r> - * 0 max spaces .rest false ;

	\ 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 )	: <xins> ( max span addr pos1 xc -- max span addr pos2 )
>r 2over r@ xc-size + u< IF ( max span addr pos1 R:xc )	>r 2over r@ xc-size + u< IF ( max span addr pos1 R:xc )
Line 238 require utf-8.fs	Line 283 require utf-8.fs
>r end^ 2@ hist-setpos	>r end^ 2@ hist-setpos
2dup swap history write-line drop ( throw ) \ don't worry about errors	2dup swap history write-line drop ( throw ) \ don't worry about errors
hist-pos 2dup backward^ 2! end^ 2!	hist-pos 2dup backward^ 2! end^ 2!
r> .all space true ;	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 )	: xkill-expand ( max span addr pos1 -- max span addr pos2 )
prefix-found cell+ @ ?dup IF >r	prefix-found cell+ @ ?dup IF >r
Line 269 require utf-8.fs	Line 318 require utf-8.fs
['] xclear-tib ctrl K bindkey	['] xclear-tib ctrl K bindkey
['] xfirst-pos ctrl A bindkey	['] xfirst-pos ctrl A bindkey
['] xend-pos ctrl E bindkey	['] xend-pos ctrl E bindkey
['] (xenter) #lf bindkey	['] xretype bl bindkey
['] (xenter) #cr bindkey	history IF ['] (xenter) #lf bindkey THEN
	history IF ['] (xenter) #cr bindkey THEN
['] xtab-expand #tab bindkey	['] xtab-expand #tab bindkey
['] (xins) IS insert-char	['] (xins) IS insert-char
['] kill-prefix IS everychar	['] kill-prefix IS everychar
['] save-cursor IS everyline ;	['] save-cursor IS everyline
	['] xback-restore IS back-restore
	['] xcur-correct IS cur-correct
	;

xchar-history	xchar-history

Line 285 xchar-history	Line 338 xchar-history
?dup-if	?dup-if
\ !! >stderr	\ !! >stderr
\ history-file type ." : " .error cr	\ history-file type ." : " .error cr
drop 2drop	drop 2drop 0 to history
['] false ['] false ['] (ret)	['] false ['] false ['] (ret)
else	else
to history	to history
Line 302 xchar-history	Line 355 xchar-history
: history-cold ( -- )	: history-cold ( -- )
history-file get-history xchar-history ;	history-file get-history xchar-history ;

' history-cold INIT8 chained	:noname ( -- )
	defers 'cold
	history-cold
	; is 'cold

history-cold	history-cold

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.43
changed lines
	Added in v.1.59