[gforth] / gforth / history.fs  

gforth: gforth/history.fs

1 : pazsan 1.11 \ command line edit and history support 16oct94py
2 : pazsan 1.4
3 : anton 1.8 \ 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 : pazsan 1.11 :noname
22 :     char [char] @ - ;
23 :     :noname
24 :     char [char] @ - postpone Literal ;
25 :     special: ctrl ( "<char>" -- ctrl-code )
26 :    
27 :     \ command line editing 16oct94py
28 :    
29 :     : >string ( span addr pos1 -- span addr pos1 addr2 len )
30 :     over 3 pick 2 pick chars /string ;
31 :     : type-rest ( span addr pos1 -- span addr pos1 back )
32 :     >string tuck type ;
33 :     : (del) ( max span addr pos1 -- max span addr pos2 )
34 :     1- >string over 1+ -rot move
35 :     rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
36 :     : (ins) ( max span addr pos1 char -- max span addr pos2 )
37 :     >r >string over 1+ swap move 2dup chars + r> swap c!
38 :     rot 1+ -rot type-rest 1- backspaces 1+ ;
39 :     : ?del ( max span addr pos1 -- max span addr pos2 0 )
40 :     dup IF (del) THEN 0 ;
41 :     : (ret) type-rest drop true space ;
42 :     : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
43 :     : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
44 :     : eof 2 pick over or 0= IF
45 :     bye
46 :     ELSE 2 pick over <>
47 :     IF forw drop (del) ELSE #bell emit THEN 0
48 :     THEN ;
49 :    
50 :     ' forw ctrl F cells ctrlkeys + !
51 :     ' back ctrl B cells ctrlkeys + !
52 :     ' ?del ctrl H cells ctrlkeys + !
53 :     ' eof ctrl D cells ctrlkeys + !
54 :    
55 :     ' (ins) IS insert-char
56 :    
57 :     \ history support 16oct94py
58 :    
59 : pazsan 1.4 0 Value history
60 :    
61 :     2Variable forward^
62 :     2Variable backward^
63 :     2Variable end^
64 :    
65 : pazsan 1.7 : force-open ( addr len -- handle )
66 :     2dup r/w open-file 0<
67 :     IF drop r/w create-file throw ELSE nip nip THEN ;
68 :    
69 : pazsan 1.4 : get-history ( addr len -- wid )
70 : pazsan 1.7 force-open to history
71 : pazsan 1.4 history file-size throw
72 :     2dup forward^ 2! 2dup backward^ 2! end^ 2! ;
73 :    
74 : anton 1.6 s" ~/.gforth-history" get-history
75 : pazsan 1.4
76 : anton 1.6 : history-cold
77 :     Defers 'cold
78 :     s" ~/.gforth-history" get-history ;
79 : pazsan 1.4
80 :     ' history-cold IS 'cold
81 :    
82 :     \ moving in history file 16oct94py
83 :    
84 :     : clear-line ( max span addr pos1 -- max addr )
85 :     backspaces over spaces swap backspaces ;
86 :    
87 :     : clear-tib ( max span addr pos -- max 0 addr 0 false )
88 :     clear-line 0 tuck dup ;
89 :    
90 : pazsan 1.7 : hist-pos ( -- ud ) history file-position throw ;
91 :     : hist-setpos ( ud -- ) history reposition-file throw ;
92 : pazsan 1.4
93 : pazsan 1.7 : get-line ( addr len -- len' flag )
94 :     swap history read-line throw ;
95 :    
96 : pazsan 1.4 : next-line ( max span addr pos1 -- max span addr pos2 false )
97 :     clear-line
98 : pazsan 1.7 forward^ 2@ 2dup hist-setpos backward^ 2!
99 :     2dup get-line drop
100 :     hist-pos forward^ 2!
101 :     tuck 2dup type 0 ;
102 : pazsan 1.4
103 :     : prev-line ( max span addr pos1 -- max span addr pos2 false )
104 : pazsan 1.7 clear-line backward^ 2@ forward^ 2!
105 :     over 2 + negate s>d backward^ 2@ d+ 0. dmax 2dup hist-setpos
106 :     BEGIN
107 :     backward^ 2! 2dup get-line WHILE
108 :     hist-pos 2dup forward^ 2@ d< WHILE
109 :     rot drop
110 :     REPEAT 2drop THEN
111 :     tuck 2dup type 0 ;
112 : pazsan 1.4
113 :     Create lfpad #lf c,
114 :    
115 :     : (enter) ( max span addr pos1 -- max span addr pos2 true )
116 : pazsan 1.7 >r end^ 2@ hist-setpos
117 :     2dup swap history write-line throw
118 :     hist-pos 2dup backward^ 2! end^ 2!
119 : pazsan 1.4 r> (ret) ;
120 :    
121 :     \ some other key commands 16oct94py
122 :    
123 :     : first-pos ( max span addr pos1 -- max span addr 0 0 )
124 :     backspaces 0 0 ;
125 :     : end-pos ( max span addr pos1 -- max span addr span 0 )
126 :     type-rest 2drop over 0 ;
127 :    
128 :     : extract-word ( addr len -- addr' len' ) dup >r
129 :     BEGIN 1- dup 0>= WHILE 2dup + c@ bl = UNTIL THEN 1+
130 :     tuck + r> rot - ;
131 :    
132 :     Create prefix-found 0 , 0 ,
133 :    
134 :     : word-lex ( nfa1 nfa2 -- -1/0/1 )
135 : anton 1.9 dup 0=
136 :     IF
137 :     2drop 1 EXIT
138 :     THEN
139 :     name>string 2>r name>string
140 :     dup r@ =
141 :     IF
142 :     rdrop r> capscomp 0<= EXIT
143 :     THEN
144 :     r> <
145 :     nip rdrop ;
146 : pazsan 1.4
147 : anton 1.9 : search-voc ( addr len nfa1 nfa2 -- addr len nfa3 )
148 :     >r
149 :     BEGIN
150 :     dup
151 :     WHILE
152 :     >r dup r@ name>string nip <=
153 :     IF
154 :     2dup r@ name>string drop capscomp 0=
155 :     IF
156 :     r> dup r@ word-lex
157 :     IF
158 :     dup prefix-found @ word-lex
159 :     0>=
160 :     IF
161 :     rdrop dup >r
162 :     THEN
163 :     THEN
164 :     >r
165 : pazsan 1.7 THEN
166 : anton 1.9 THEN
167 :     r> @
168 :     REPEAT
169 :     drop r> ;
170 : pazsan 1.7
171 :     : prefix-string ( addr len nfa -- addr' len' )
172 :     dup prefix-found ! ?dup
173 : anton 1.9 IF
174 :     name>string rot /string rot drop
175 : pazsan 1.7 dup 1+ prefix-found cell+ !
176 :     ELSE
177 :     2drop s" " prefix-found cell+ off
178 :     THEN ;
179 :    
180 :     : search-prefix ( addr1 len1 -- addr2 len2 )
181 :     0 vp dup @ 1- cells over +
182 :     DO I 2@ <>
183 :     IF I cell+ @ @ swap search-voc THEN
184 :     [ -1 cells ] Literal +LOOP
185 :     prefix-string ;
186 :    
187 :     : kill-expand ( max span addr pos1 -- max span addr pos2 )
188 :     prefix-found cell+ @ 0 ?DO (del) LOOP ;
189 :    
190 :     : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
191 :     5 pick over 4 pick + prefix-found @ 0<> - < ;
192 : pazsan 1.4
193 :     : tab-expand ( max span addr pos1 -- max span addr pos2 0 )
194 : pazsan 1.7 kill-expand 2dup extract-word search-prefix
195 :     tib-full?
196 :     IF 7 emit 2drop 0 0 prefix-found 2!
197 :     ELSE bounds ?DO I c@ (ins) LOOP THEN
198 :     prefix-found @ IF bl (ins) THEN 0 ;
199 : pazsan 1.4
200 :     : kill-prefix ( key -- key )
201 :     dup #tab <> IF 0 0 prefix-found 2! THEN ;
202 :    
203 :     ' kill-prefix IS everychar
204 :    
205 :     ' next-line ctrl N cells ctrlkeys + !
206 :     ' prev-line ctrl P cells ctrlkeys + !
207 :     ' clear-tib ctrl K cells ctrlkeys + !
208 :     ' first-pos ctrl A cells ctrlkeys + !
209 :     ' end-pos ctrl E cells ctrlkeys + !
210 :     ' (enter) #lf cells ctrlkeys + !
211 :     ' (enter) #cr cells ctrlkeys + !
212 :     ' tab-expand #tab cells ctrlkeys + !
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help