1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
\ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
\ Copyright (C) 1995 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
\ May be cross-compiled
decimal
\ .( 12may93jaw
: .( ( compilation "...<paren>" -- ) \ core-ext dot-paren
[char] ) parse type ; immediate
\ VALUE 2>R 2R> 2R@ 17may93jaw
\ !! 2value
: 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
swap postpone Literal postpone Literal ; immediate restrict
' drop alias d>s ( d -- n ) \ double d_to_s
: m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
>r s>d >r abs -rot
s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
r> IF dnegate THEN ;
\ CASE OF ENDOF ENDCASE 17may93jaw
\ just as described in dpANS5
0 CONSTANT case ( compilation -- case-sys ; run-time -- ) \ core-ext
immediate
: of ( compilation -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
\ !! the implementation does not match the stack effect
1+ >r
postpone over postpone = postpone if postpone drop
r> ; immediate
: endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ core-ext end-of
>r postpone else r> ; immediate
: endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
postpone drop
0 ?do postpone then loop ; immediate
\ C" 17may93jaw
: (c") "lit ;
: CLiteral
postpone (c") here over char+ allot place align ; immediate restrict
: C" ( compilation "...<quote>" -- ; run-time -- c-addr ) \ core-ext c-quote
[char] " parse postpone CLiteral ; immediate restrict
\ UNUSED 17may93jaw
: dictionary-end ( -- addr )
forthstart dup 3 cells + @ + ;
: unused ( -- u ) \ core-ext
dictionary-end here - ;
\ [COMPILE] 17may93jaw
: [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
' compile, ; immediate
\ MARKER 17may93jaw
\ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
\ doesn't work now. vocabularies?
\ CONVERT 17may93jaw
: convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
\ obsolescent; superseded by @code{>number}.
true >number drop ;
\ ERASE 17may93jaw
: erase ( addr len -- ) \ core-ext
\ !! dependence on "1 chars 1 ="
( 0 1 chars um/mod nip ) 0 fill ;
: blank ( addr len -- ) \ string
bl fill ;
\ SEARCH 02sep94py
: search ( buf buflen text textlen -- restbuf restlen flag ) \ string
2over 2 pick - 1+ 3 pick c@ >r
BEGIN
r@ scan dup
WHILE
>r >r 2dup r@ -text
0=
IF
>r drop 2drop r> r> r> rot + 1- rdrop true
EXIT
THEN
r> r> 1 /string
REPEAT
2drop 2drop rdrop false ;
\ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
: source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
loadfile @ dup 0= IF drop sourceline# 0 min THEN ;
: save-input ( -- x1 .. xn n ) \ core-ext
>in @
loadfile @
if
loadfile @ file-position throw
else
blk @
linestart @
then
sourceline#
>tib @
source-id
6 ;
: restore-input ( x1 .. xn n -- flag ) \ core-ext
6 <> -12 and throw
source-id <> -12 and throw
>tib !
>r ( line# )
loadfile @ 0<>
if
loadfile @ reposition-file throw
else
linestart !
blk !
sourceline# r@ <> blk @ 0= and loadfile @ 0= and
if
drop rdrop true EXIT
then
then
r> loadline !
>in !
false ;
\ This things we don't need, but for being complete... jaw
\ EXPECT SPAN 17may93jaw
variable span ( -- a-addr ) \ core-ext
\ obsolescent
: expect ( c-addr +len -- ) \ core-ext
\ obsolescent; use accept
0 rot over
BEGIN ( maxlen span c-addr pos1 )
key decode ( maxlen span c-addr pos2 flag )
>r 2over = r> or
UNTIL
2 pick swap /string type
nip span ! ;
|
