1: \ History file support 16oct94py
2:
3: \ Copyright (C) 1995 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: 0 Value history
22:
23: 2Variable forward^
24: 2Variable backward^
25: 2Variable end^
26:
27: : force-open ( addr len -- handle )
28: 2dup r/w open-file 0<
29: IF drop r/w create-file throw ELSE nip nip THEN ;
30:
31: : get-history ( addr len -- wid )
32: force-open to history
33: history file-size throw
34: 2dup forward^ 2! 2dup backward^ 2! end^ 2! ;
35:
36: s" ~/.gforth-history" get-history
37:
38: : history-cold
39: Defers 'cold
40: s" ~/.gforth-history" get-history ;
41:
42: ' history-cold IS 'cold
43:
44: \ moving in history file 16oct94py
45:
46: : clear-line ( max span addr pos1 -- max addr )
47: backspaces over spaces swap backspaces ;
48:
49: : clear-tib ( max span addr pos -- max 0 addr 0 false )
50: clear-line 0 tuck dup ;
51:
52: : hist-pos ( -- ud ) history file-position throw ;
53: : hist-setpos ( ud -- ) history reposition-file throw ;
54:
55: : get-line ( addr len -- len' flag )
56: swap history read-line throw ;
57:
58: : next-line ( max span addr pos1 -- max span addr pos2 false )
59: clear-line
60: forward^ 2@ 2dup hist-setpos backward^ 2!
61: 2dup get-line drop
62: hist-pos forward^ 2!
63: tuck 2dup type 0 ;
64:
65: : prev-line ( max span addr pos1 -- max span addr pos2 false )
66: clear-line backward^ 2@ forward^ 2!
67: over 2 + negate s>d backward^ 2@ d+ 0. dmax 2dup hist-setpos
68: BEGIN
69: backward^ 2! 2dup get-line WHILE
70: hist-pos 2dup forward^ 2@ d< WHILE
71: rot drop
72: REPEAT 2drop THEN
73: tuck 2dup type 0 ;
74:
75: : ctrl ( "<char>" -- ctrl-code )
76: char [char] @ - postpone Literal ; immediate
77:
78: Create lfpad #lf c,
79:
80: : (enter) ( max span addr pos1 -- max span addr pos2 true )
81: >r end^ 2@ hist-setpos
82: 2dup swap history write-line throw
83: hist-pos 2dup backward^ 2! end^ 2!
84: r> (ret) ;
85:
86: \ some other key commands 16oct94py
87:
88: : first-pos ( max span addr pos1 -- max span addr 0 0 )
89: backspaces 0 0 ;
90: : end-pos ( max span addr pos1 -- max span addr span 0 )
91: type-rest 2drop over 0 ;
92:
93: : extract-word ( addr len -- addr' len' ) dup >r
94: BEGIN 1- dup 0>= WHILE 2dup + c@ bl = UNTIL THEN 1+
95: tuck + r> rot - ;
96:
97: Create prefix-found 0 , 0 ,
98:
99: : word-lex ( nfa1 nfa2 -- -1/0/1 )
100: dup 0= IF 2drop 1 EXIT THEN
101: cell+ >r cell+ count $1F and
102: dup r@ c@ $1F and =
103: IF r> char+ capscomp 0<= EXIT THEN
104: nip r> c@ $1F and < ;
105:
106: : search-voc ( addr len nfa1 nfa2 -- addr len nfa3 ) >r
107: BEGIN dup WHILE >r dup r@ cell+ c@ $1F and <=
108: IF 2dup r@ cell+ char+ capscomp 0=
109: IF r> dup r@ word-lex
110: IF dup prefix-found @ word-lex
111: 0>= IF rdrop dup >r THEN
112: THEN >r
113: THEN
114: THEN r> @
115: REPEAT drop r> ;
116:
117: : prefix-string ( addr len nfa -- addr' len' )
118: dup prefix-found ! ?dup
119: IF cell+ count $1F and rot /string rot drop
120: dup 1+ prefix-found cell+ !
121: ELSE
122: 2drop s" " prefix-found cell+ off
123: THEN ;
124:
125: : search-prefix ( addr1 len1 -- addr2 len2 )
126: 0 vp dup @ 1- cells over +
127: DO I 2@ <>
128: IF I cell+ @ @ swap search-voc THEN
129: [ -1 cells ] Literal +LOOP
130: prefix-string ;
131:
132: : kill-expand ( max span addr pos1 -- max span addr pos2 )
133: prefix-found cell+ @ 0 ?DO (del) LOOP ;
134:
135: : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
136: 5 pick over 4 pick + prefix-found @ 0<> - < ;
137:
138: : tab-expand ( max span addr pos1 -- max span addr pos2 0 )
139: kill-expand 2dup extract-word search-prefix
140: tib-full?
141: IF 7 emit 2drop 0 0 prefix-found 2!
142: ELSE bounds ?DO I c@ (ins) LOOP THEN
143: prefix-found @ IF bl (ins) THEN 0 ;
144:
145: : kill-prefix ( key -- key )
146: dup #tab <> IF 0 0 prefix-found 2! THEN ;
147:
148: ' kill-prefix IS everychar
149:
150: ' next-line ctrl N cells ctrlkeys + !
151: ' prev-line ctrl P cells ctrlkeys + !
152: ' clear-tib ctrl K cells ctrlkeys + !
153: ' first-pos ctrl A cells ctrlkeys + !
154: ' end-pos ctrl E cells ctrlkeys + !
155: ' (enter) #lf cells ctrlkeys + !
156: ' (enter) #cr cells ctrlkeys + !
157: ' tab-expand #tab cells ctrlkeys + !
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>