File:
[gforth] /
gforth /
extend.fs
Revision
1.27:
download - view:
text,
annotated -
select for diffs
Sun Jul 6 15:55:23 1997 UTC (26 years, 9 months ago) by
jwilke
Branches:
MAIN
CVS tags:
HEAD
Major change!
hash and search does not rely on each other.
context and voclink are now present in kernel.
words and marker can now defined without loading hash or search
marker went to extend.fs
word went to kernel/tools.fs
table goes to seperate file (at the moment)
glocals.fs and kernel/toolsext.fs are changed because of the change in the
wordlist-map-struct...
Attention: You can't recompile the code without new kernel-files!!!
jens
1: \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
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:
22: \ May be cross-compiled
23:
24: decimal
25:
26: \ .( 12may93jaw
27:
28: : .( ( compilation "...<paren>" -- ) \ core-ext dot-paren
29: [char] ) parse type ; immediate
30:
31: \ VALUE 2>R 2R> 2R@ 17may93jaw
32:
33: \ !! 2value
34:
35: : 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
36: swap postpone Literal postpone Literal ; immediate restrict
37:
38: ' drop alias d>s ( d -- n ) \ double d_to_s
39:
40: : m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
41: >r s>d >r abs -rot
42: s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
43: swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
44: r> IF dnegate THEN ;
45:
46: \ CASE OF ENDOF ENDCASE 17may93jaw
47:
48: \ just as described in dpANS5
49:
50: 0 CONSTANT case ( compilation -- case-sys ; run-time -- ) \ core-ext
51: immediate
52:
53: : of ( compilation -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
54: \ !! the implementation does not match the stack effect
55: 1+ >r
56: postpone over postpone = postpone if postpone drop
57: r> ; immediate
58:
59: : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ core-ext end-of
60: >r postpone else r> ; immediate
61:
62: : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
63: postpone drop
64: 0 ?do postpone then loop ; immediate
65:
66: \ C" 17may93jaw
67:
68: : (c") "lit ;
69:
70: : CLiteral
71: postpone (c") here over char+ allot place align ; immediate restrict
72:
73: : C" ( compilation "...<quote>" -- ; run-time -- c-addr ) \ core-ext c-quote
74: [char] " parse postpone CLiteral ; immediate restrict
75:
76: \ [COMPILE] 17may93jaw
77:
78: : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
79: comp' drop compile, ; immediate
80:
81: \ CONVERT 17may93jaw
82:
83: : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
84: \G obsolescent; superseded by @code{>number}.
85: char+ true >number drop ;
86:
87: \ ERASE 17may93jaw
88:
89: : erase ( addr len -- ) \ core-ext
90: \ !! dependence on "1 chars 1 ="
91: ( 0 1 chars um/mod nip ) 0 fill ;
92: : blank ( addr len -- ) \ string
93: bl fill ;
94:
95: \ SEARCH 02sep94py
96:
97: : search ( buf buflen text textlen -- restbuf restlen flag ) \ string
98: 2over 2 pick - 1+ 3 pick c@ >r
99: BEGIN
100: r@ scan dup
101: WHILE
102: >r >r 2dup r@ -text
103: 0=
104: IF
105: >r drop 2drop r> r> r> rot + 1- rdrop true
106: EXIT
107: THEN
108: r> r> 1 /string
109: REPEAT
110: 2drop 2drop rdrop false ;
111:
112: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
113:
114: : source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
115: loadfile @ dup 0= IF drop sourceline# 0 min THEN ;
116:
117: : save-input ( -- x1 .. xn n ) \ core-ext
118: >in @
119: loadfile @
120: if
121: loadfile @ file-position throw
122: else
123: blk @
124: linestart @
125: then
126: sourceline#
127: >tib @
128: source-id
129: 6 ;
130:
131: : restore-input ( x1 .. xn n -- flag ) \ core-ext
132: 6 <> -12 and throw
133: source-id <> -12 and throw
134: >tib !
135: >r ( line# )
136: loadfile @ 0<>
137: if
138: loadfile @ reposition-file throw
139: else
140: linestart !
141: blk !
142: sourceline# r@ <> blk @ 0= and loadfile @ 0= and
143: if
144: drop rdrop true EXIT
145: then
146: then
147: r> loadline !
148: >in !
149: false ;
150:
151: \ This things we don't need, but for being complete... jaw
152:
153: \ EXPECT SPAN 17may93jaw
154:
155: variable span ( -- a-addr ) \ core-ext
156: \ obsolescent
157:
158: : expect ( c-addr +len -- ) \ core-ext
159: \ obsolescent; use accept
160: 0 rot over
161: BEGIN ( maxlen span c-addr pos1 )
162: key decode ( maxlen span c-addr pos2 flag )
163: >r 2over = r> or
164: UNTIL
165: 2 pick swap /string type
166: nip span ! ;
167:
168: \ marker 18dec94py
169:
170: \ Marker creates a mark that is removed (including everything
171: \ defined afterwards) when executing the mark.
172:
173: : marker, ( -- mark ) here dup A,
174: voclink @ A, voclink
175: BEGIN @ dup WHILE dup 0 wordlist-link - @ A, REPEAT drop
176: udp @ , ;
177:
178: : marker! ( mark -- )
179: dup @ swap cell+
180: dup @ voclink ! cell+
181: voclink
182: BEGIN
183: @ dup
184: WHILE
185: over @ over 0 wordlist-link - !
186: swap cell+ swap
187: REPEAT
188: drop voclink
189: BEGIN
190: @ dup
191: WHILE
192: dup 0 wordlist-link - rehash
193: REPEAT
194: drop
195: @ udp ! dp ! ;
196:
197: : marker ( "mark" -- )
198: marker, Create A,
199: DOES> ( -- )
200: @ marker! ;
201:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>