File:
[gforth] /
gforth /
history.fs
Revision
1.9:
download - view:
text,
annotated -
select for diffs
Sun Jan 7 17:22:11 1996 UTC (28 years, 3 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
added more.fs for people with old terminals.
WORDS and SEE now now respect the terminal size.
a lot of reordering in the Makefile, approaching the GNU standards.
factored NAME>STRING out of many words.
use AC_DECL_SYS_SIGLIST test in configure.in.
removed emitcounter (it was not used anyway).
SYSTEM now unpreps and repreps the terminal.
fixed byg in prims2x.fs.
added NEEDS, ?CSP, !CSP.
rewrote ALIAS?.
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=
101: IF
102: 2drop 1 EXIT
103: THEN
104: name>string 2>r name>string
105: dup r@ =
106: IF
107: rdrop r> capscomp 0<= EXIT
108: THEN
109: r> <
110: nip rdrop ;
111:
112: : search-voc ( addr len nfa1 nfa2 -- addr len nfa3 )
113: >r
114: BEGIN
115: dup
116: WHILE
117: >r dup r@ name>string nip <=
118: IF
119: 2dup r@ name>string drop capscomp 0=
120: IF
121: r> dup r@ word-lex
122: IF
123: dup prefix-found @ word-lex
124: 0>=
125: IF
126: rdrop dup >r
127: THEN
128: THEN
129: >r
130: THEN
131: THEN
132: r> @
133: REPEAT
134: drop r> ;
135:
136: : prefix-string ( addr len nfa -- addr' len' )
137: dup prefix-found ! ?dup
138: IF
139: name>string rot /string rot drop
140: dup 1+ prefix-found cell+ !
141: ELSE
142: 2drop s" " prefix-found cell+ off
143: THEN ;
144:
145: : search-prefix ( addr1 len1 -- addr2 len2 )
146: 0 vp dup @ 1- cells over +
147: DO I 2@ <>
148: IF I cell+ @ @ swap search-voc THEN
149: [ -1 cells ] Literal +LOOP
150: prefix-string ;
151:
152: : kill-expand ( max span addr pos1 -- max span addr pos2 )
153: prefix-found cell+ @ 0 ?DO (del) LOOP ;
154:
155: : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
156: 5 pick over 4 pick + prefix-found @ 0<> - < ;
157:
158: : tab-expand ( max span addr pos1 -- max span addr pos2 0 )
159: kill-expand 2dup extract-word search-prefix
160: tib-full?
161: IF 7 emit 2drop 0 0 prefix-found 2!
162: ELSE bounds ?DO I c@ (ins) LOOP THEN
163: prefix-found @ IF bl (ins) THEN 0 ;
164:
165: : kill-prefix ( key -- key )
166: dup #tab <> IF 0 0 prefix-found 2! THEN ;
167:
168: ' kill-prefix IS everychar
169:
170: ' next-line ctrl N cells ctrlkeys + !
171: ' prev-line ctrl P cells ctrlkeys + !
172: ' clear-tib ctrl K cells ctrlkeys + !
173: ' first-pos ctrl A cells ctrlkeys + !
174: ' end-pos ctrl E cells ctrlkeys + !
175: ' (enter) #lf cells ctrlkeys + !
176: ' (enter) #cr cells ctrlkeys + !
177: ' tab-expand #tab cells ctrlkeys + !
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>