Annotation of gforth/history.fs, revision 1.10
1.4 pazsan 1: \ History file support 16oct94py
2:
1.8 anton 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:
1.4 pazsan 21: 0 Value history
22:
23: 2Variable forward^
24: 2Variable backward^
25: 2Variable end^
26:
1.7 pazsan 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:
1.4 pazsan 31: : get-history ( addr len -- wid )
1.7 pazsan 32: force-open to history
1.4 pazsan 33: history file-size throw
34: 2dup forward^ 2! 2dup backward^ 2! end^ 2! ;
35:
1.6 anton 36: s" ~/.gforth-history" get-history
1.4 pazsan 37:
1.6 anton 38: : history-cold
39: Defers 'cold
40: s" ~/.gforth-history" get-history ;
1.4 pazsan 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:
1.7 pazsan 52: : hist-pos ( -- ud ) history file-position throw ;
53: : hist-setpos ( ud -- ) history reposition-file throw ;
1.4 pazsan 54:
1.7 pazsan 55: : get-line ( addr len -- len' flag )
56: swap history read-line throw ;
57:
1.4 pazsan 58: : next-line ( max span addr pos1 -- max span addr pos2 false )
59: clear-line
1.7 pazsan 60: forward^ 2@ 2dup hist-setpos backward^ 2!
61: 2dup get-line drop
62: hist-pos forward^ 2!
63: tuck 2dup type 0 ;
1.4 pazsan 64:
65: : prev-line ( max span addr pos1 -- max span addr pos2 false )
1.7 pazsan 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 ;
1.4 pazsan 74:
1.10 ! anton 75: : ctrl ( compilation: "<char>" -- ) ( run-time: -- ctrl-code )
! 76: char [char] @ - postpone Literal ; immediate
! 77: interpretation: ( "<char>" -- ctrl-code )
! 78: char [char] @ - ;
1.4 pazsan 79:
80: Create lfpad #lf c,
81:
82: : (enter) ( max span addr pos1 -- max span addr pos2 true )
1.7 pazsan 83: >r end^ 2@ hist-setpos
84: 2dup swap history write-line throw
85: hist-pos 2dup backward^ 2! end^ 2!
1.4 pazsan 86: r> (ret) ;
87:
88: \ some other key commands 16oct94py
89:
90: : first-pos ( max span addr pos1 -- max span addr 0 0 )
91: backspaces 0 0 ;
92: : end-pos ( max span addr pos1 -- max span addr span 0 )
93: type-rest 2drop over 0 ;
94:
95: : extract-word ( addr len -- addr' len' ) dup >r
96: BEGIN 1- dup 0>= WHILE 2dup + c@ bl = UNTIL THEN 1+
97: tuck + r> rot - ;
98:
99: Create prefix-found 0 , 0 ,
100:
101: : word-lex ( nfa1 nfa2 -- -1/0/1 )
1.9 anton 102: dup 0=
103: IF
104: 2drop 1 EXIT
105: THEN
106: name>string 2>r name>string
107: dup r@ =
108: IF
109: rdrop r> capscomp 0<= EXIT
110: THEN
111: r> <
112: nip rdrop ;
1.4 pazsan 113:
1.9 anton 114: : search-voc ( addr len nfa1 nfa2 -- addr len nfa3 )
115: >r
116: BEGIN
117: dup
118: WHILE
119: >r dup r@ name>string nip <=
120: IF
121: 2dup r@ name>string drop capscomp 0=
122: IF
123: r> dup r@ word-lex
124: IF
125: dup prefix-found @ word-lex
126: 0>=
127: IF
128: rdrop dup >r
129: THEN
130: THEN
131: >r
1.7 pazsan 132: THEN
1.9 anton 133: THEN
134: r> @
135: REPEAT
136: drop r> ;
1.7 pazsan 137:
138: : prefix-string ( addr len nfa -- addr' len' )
139: dup prefix-found ! ?dup
1.9 anton 140: IF
141: name>string rot /string rot drop
1.7 pazsan 142: dup 1+ prefix-found cell+ !
143: ELSE
144: 2drop s" " prefix-found cell+ off
145: THEN ;
146:
147: : search-prefix ( addr1 len1 -- addr2 len2 )
148: 0 vp dup @ 1- cells over +
149: DO I 2@ <>
150: IF I cell+ @ @ swap search-voc THEN
151: [ -1 cells ] Literal +LOOP
152: prefix-string ;
153:
154: : kill-expand ( max span addr pos1 -- max span addr pos2 )
155: prefix-found cell+ @ 0 ?DO (del) LOOP ;
156:
157: : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
158: 5 pick over 4 pick + prefix-found @ 0<> - < ;
1.4 pazsan 159:
160: : tab-expand ( max span addr pos1 -- max span addr pos2 0 )
1.7 pazsan 161: kill-expand 2dup extract-word search-prefix
162: tib-full?
163: IF 7 emit 2drop 0 0 prefix-found 2!
164: ELSE bounds ?DO I c@ (ins) LOOP THEN
165: prefix-found @ IF bl (ins) THEN 0 ;
1.4 pazsan 166:
167: : kill-prefix ( key -- key )
168: dup #tab <> IF 0 0 prefix-found 2! THEN ;
169:
170: ' kill-prefix IS everychar
171:
172: ' next-line ctrl N cells ctrlkeys + !
173: ' prev-line ctrl P cells ctrlkeys + !
174: ' clear-tib ctrl K cells ctrlkeys + !
175: ' first-pos ctrl A cells ctrlkeys + !
176: ' end-pos ctrl E cells ctrlkeys + !
177: ' (enter) #lf cells ctrlkeys + !
178: ' (enter) #cr cells ctrlkeys + !
179: ' tab-expand #tab cells ctrlkeys + !
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to history.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth