Annotation of gforth/history.fs, revision 1.7
1.4 pazsan 1: \ History file support 16oct94py
2:
3: 0 Value history
4:
5: 2Variable forward^
6: 2Variable backward^
7: 2Variable end^
8:
1.7 ! pazsan 9: : force-open ( addr len -- handle )
! 10: 2dup r/w open-file 0<
! 11: IF drop r/w create-file throw ELSE nip nip THEN ;
! 12:
1.4 pazsan 13: : get-history ( addr len -- wid )
1.7 ! pazsan 14: force-open to history
1.4 pazsan 15: history file-size throw
16: 2dup forward^ 2! 2dup backward^ 2! end^ 2! ;
17:
1.6 anton 18: s" ~/.gforth-history" get-history
1.4 pazsan 19:
1.6 anton 20: : history-cold
21: Defers 'cold
22: s" ~/.gforth-history" get-history ;
1.4 pazsan 23:
24: ' history-cold IS 'cold
25:
26: \ moving in history file 16oct94py
27:
28: : clear-line ( max span addr pos1 -- max addr )
29: backspaces over spaces swap backspaces ;
30:
31: : clear-tib ( max span addr pos -- max 0 addr 0 false )
32: clear-line 0 tuck dup ;
33:
1.7 ! pazsan 34: : hist-pos ( -- ud ) history file-position throw ;
! 35: : hist-setpos ( ud -- ) history reposition-file throw ;
1.4 pazsan 36:
1.7 ! pazsan 37: : get-line ( addr len -- len' flag )
! 38: swap history read-line throw ;
! 39:
1.4 pazsan 40: : next-line ( max span addr pos1 -- max span addr pos2 false )
41: clear-line
1.7 ! pazsan 42: forward^ 2@ 2dup hist-setpos backward^ 2!
! 43: 2dup get-line drop
! 44: hist-pos forward^ 2!
! 45: tuck 2dup type 0 ;
1.4 pazsan 46:
47: : prev-line ( max span addr pos1 -- max span addr pos2 false )
1.7 ! pazsan 48: clear-line backward^ 2@ forward^ 2!
! 49: over 2 + negate s>d backward^ 2@ d+ 0. dmax 2dup hist-setpos
! 50: BEGIN
! 51: backward^ 2! 2dup get-line WHILE
! 52: hist-pos 2dup forward^ 2@ d< WHILE
! 53: rot drop
! 54: REPEAT 2drop THEN
! 55: tuck 2dup type 0 ;
1.4 pazsan 56:
57: : ctrl ( "<char>" -- ctrl-code )
58: char [char] @ - postpone Literal ; immediate
59:
60: Create lfpad #lf c,
61:
62: : (enter) ( max span addr pos1 -- max span addr pos2 true )
1.7 ! pazsan 63: >r end^ 2@ hist-setpos
! 64: 2dup swap history write-line throw
! 65: hist-pos 2dup backward^ 2! end^ 2!
1.4 pazsan 66: r> (ret) ;
67:
68: \ some other key commands 16oct94py
69:
70: : first-pos ( max span addr pos1 -- max span addr 0 0 )
71: backspaces 0 0 ;
72: : end-pos ( max span addr pos1 -- max span addr span 0 )
73: type-rest 2drop over 0 ;
74:
75: : extract-word ( addr len -- addr' len' ) dup >r
76: BEGIN 1- dup 0>= WHILE 2dup + c@ bl = UNTIL THEN 1+
77: tuck + r> rot - ;
78:
79: Create prefix-found 0 , 0 ,
80:
81: : word-lex ( nfa1 nfa2 -- -1/0/1 )
82: dup 0= IF 2drop 1 EXIT THEN
83: cell+ >r cell+ count $1F and
84: dup r@ c@ $1F and =
85: IF r> char+ capscomp 0<= EXIT THEN
86: nip r> c@ $1F and < ;
87:
1.7 ! pazsan 88: : search-voc ( addr len nfa1 nfa2 -- addr len nfa3 ) >r
! 89: BEGIN dup WHILE >r dup r@ cell+ c@ $1F and <=
! 90: IF 2dup r@ cell+ char+ capscomp 0=
! 91: IF r> dup r@ word-lex
! 92: IF dup prefix-found @ word-lex
! 93: 0>= IF rdrop dup >r THEN
! 94: THEN >r
! 95: THEN
! 96: THEN r> @
! 97: REPEAT drop r> ;
! 98:
! 99: : prefix-string ( addr len nfa -- addr' len' )
! 100: dup prefix-found ! ?dup
! 101: IF cell+ count $1F and rot /string rot drop
! 102: dup 1+ prefix-found cell+ !
! 103: ELSE
! 104: 2drop s" " prefix-found cell+ off
! 105: THEN ;
! 106:
! 107: : search-prefix ( addr1 len1 -- addr2 len2 )
! 108: 0 vp dup @ 1- cells over +
! 109: DO I 2@ <>
! 110: IF I cell+ @ @ swap search-voc THEN
! 111: [ -1 cells ] Literal +LOOP
! 112: prefix-string ;
! 113:
! 114: : kill-expand ( max span addr pos1 -- max span addr pos2 )
! 115: prefix-found cell+ @ 0 ?DO (del) LOOP ;
! 116:
! 117: : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
! 118: 5 pick over 4 pick + prefix-found @ 0<> - < ;
1.4 pazsan 119:
120: : tab-expand ( max span addr pos1 -- max span addr pos2 0 )
1.7 ! pazsan 121: kill-expand 2dup extract-word search-prefix
! 122: tib-full?
! 123: IF 7 emit 2drop 0 0 prefix-found 2!
! 124: ELSE bounds ?DO I c@ (ins) LOOP THEN
! 125: prefix-found @ IF bl (ins) THEN 0 ;
1.4 pazsan 126:
127: : kill-prefix ( key -- key )
128: dup #tab <> IF 0 0 prefix-found 2! THEN ;
129:
130: ' kill-prefix IS everychar
131:
132: ' next-line ctrl N cells ctrlkeys + !
133: ' prev-line ctrl P cells ctrlkeys + !
134: ' clear-tib ctrl K cells ctrlkeys + !
135: ' first-pos ctrl A cells ctrlkeys + !
136: ' end-pos ctrl E cells ctrlkeys + !
137: ' (enter) #lf cells ctrlkeys + !
138: ' (enter) #cr cells ctrlkeys + !
139: ' tab-expand #tab cells ctrlkeys + !
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>