version 1.104, 2002/12/13 15:49:53
|
version 1.110, 2002/12/28 17:18:27
|
Line 105
|
Line 105
|
\E |
\E |
\E set-current |
\E set-current |
\E store-optimization on |
\E store-optimization on |
|
\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump |
|
|
\ |
\ |
\ |
\ |
Line 817 lshift ( u1 n -- u2 ) core l_shift
|
Line 818 lshift ( u1 n -- u2 ) core l_shift
|
: |
: |
0 ?DO 2* LOOP ; |
0 ?DO 2* LOOP ; |
|
|
|
\g compare |
|
|
\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
define(comparisons, |
define(comparisons, |
$1= ( $2 -- f ) $6 $3equals |
$1= ( $2 -- f ) $6 $3equals |
Line 938 f = FLAG(u1-u2 < u3-u2);
|
Line 941 f = FLAG(u1-u2 < u3-u2);
|
: |
: |
over - >r - r> u< ; |
over - >r - r> u< ; |
|
|
\g internal |
|
|
|
sp@ ( -- a_addr ) gforth sp_fetch |
sp@ ( -- a_addr ) gforth sp_fetch |
a_addr = sp+1; |
a_addr = sp+1; |
|
|
Line 1090 w = sp[u+1];
|
Line 1091 w = sp[u+1];
|
|
|
\ toggle is high-level: 0.11/0.42% |
\ toggle is high-level: 0.11/0.42% |
|
|
|
\g memory |
|
|
@ ( a_addr -- w ) core fetch |
@ ( a_addr -- w ) core fetch |
""@i{w} is the cell stored at @i{a_addr}."" |
""@i{w} is the cell stored at @i{a_addr}."" |
w = *a_addr; |
w = *a_addr; |
Line 1211 c_addr2 = c_addr1+1;
|
Line 1214 c_addr2 = c_addr1+1;
|
: |
: |
dup 1+ swap c@ ; |
dup 1+ swap c@ ; |
|
|
|
\g compiler |
|
|
(f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find |
(f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find |
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) |
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
Line 1288 while(u1--)
|
Line 1293 while(u1--)
|
ASCII strings (larger if ubits is large), and should share no |
ASCII strings (larger if ubits is large), and should share no |
divisors with ubits. |
divisors with ubits. |
*/ |
*/ |
unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits]; |
static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5}; |
|
unsigned rot = rot_values[ubits]; |
Char *cp = c_addr; |
Char *cp = c_addr; |
for (ukey=0; cp<c_addr+u; cp++) |
for (ukey=0; cp<c_addr+u; cp++) |
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) |
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) |
Line 1604 wior = IOR(rename(tilde_cstr(c_addr1, u1
|
Line 1610 wior = IOR(rename(tilde_cstr(c_addr1, u1
|
|
|
file-position ( wfileid -- ud wior ) file file_position |
file-position ( wfileid -- ud wior ) file file_position |
/* !! use tell and lseek? */ |
/* !! use tell and lseek? */ |
ud = LONG2UD(ftell((FILE *)wfileid)); |
ud = OFF2UD(ftello((FILE *)wfileid)); |
wior = IOR(UD2LONG(ud)==-1); |
wior = IOR(UD2OFF(ud)==-1); |
|
|
reposition-file ( ud wfileid -- wior ) file reposition_file |
reposition-file ( ud wfileid -- wior ) file reposition_file |
wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); |
wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); |
|
|
file-size ( wfileid -- ud wior ) file file_size |
file-size ( wfileid -- ud wior ) file file_size |
struct stat buf; |
struct stat buf; |
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); |
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); |
ud = LONG2UD(buf.st_size); |
ud = OFF2UD(buf.st_size); |
|
|
resize-file ( ud wfileid -- wior ) file resize_file |
resize-file ( ud wfileid -- wior ) file resize_file |
wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1); |
wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); |
|
|
read-file ( c_addr u1 wfileid -- u2 wior ) file read_file |
read-file ( c_addr u1 wfileid -- u2 wior ) file read_file |
/* !! fread does not guarantee enough */ |
/* !! fread does not guarantee enough */ |
Line 1808 floor ( r1 -- r2 ) float
|
Line 1814 floor ( r1 -- r2 ) float
|
/* !! unclear wording */ |
/* !! unclear wording */ |
r2 = floor(r1); |
r2 = floor(r1); |
|
|
(fround) ( r1 -- r2 ) gforth paren_f_round |
fround ( r1 -- r2 ) gforth f_round |
""Round to the nearest integral value. Primitive variant (unused)"" |
""Round to the nearest integral value."" |
/* !! eliminate this as primitive? */ |
|
/* !! unclear wording */ |
|
#ifdef HAVE_RINT |
|
r2 = rint(r1); |
r2 = rint(r1); |
#else |
|
r2 = floor(r1+0.5); |
|
/* !! This is not quite true to the rounding rules given in the standard */ |
|
#endif |
|
|
|
fmax ( r1 r2 -- r3 ) float f_max |
fmax ( r1 r2 -- r3 ) float f_max |
if (r1<r2) |
if (r1<r2) |
Line 2028 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
Line 2027 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
\+ |
\+ |
\+glocals |
\+glocals |
|
|
|
\g locals |
|
|
@local# ( #noffset -- w ) gforth fetch_local_number |
@local# ( #noffset -- w ) gforth fetch_local_number |
w = *(Cell *)(lp+noffset); |
w = *(Cell *)(lp+noffset); |
|
|
Line 2099 r = fp[u+1]; /* +1, because update of fp
|
Line 2100 r = fp[u+1]; /* +1, because update of fp
|
|
|
\+OS |
\+OS |
|
|
|
\g syslib |
|
|
define(`uploop', |
define(`uploop', |
`pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') |
`pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') |
define(`_uploop', |
define(`_uploop', |
Line 2435 SET_IP((Xt *)a_callee);
|
Line 2438 SET_IP((Xt *)a_callee);
|
useraddr ( #u -- a_addr ) new |
useraddr ( #u -- a_addr ) new |
a_addr = (Cell *)(up+u); |
a_addr = (Cell *)(up+u); |
|
|
compile-prim ( xt1 -- xt2 ) new compile_prim |
compile-prim ( xt1 -- xt2 ) obsolete compile_prim |
xt2 = (Xt)compile_prim((Label)xt1); |
xt2 = (Xt)compile_prim((Label)xt1); |
|
|
\ lit@ / lit_fetch = lit @ |
\ lit@ / lit_fetch = lit @ |
Line 2776 finish-code ( -- ) gforth finish_code
|
Line 2779 finish-code ( -- ) gforth finish_code
|
flushing)."" |
flushing)."" |
finish_code(); |
finish_code(); |
|
|
forget-dyncode ( a_code -- f ) gforth-internal forget_dyncode |
forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode |
f = forget_dyncode(a_code); |
f = forget_dyncode(c_code); |
|
|
decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim |
decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim |
""a_prim is the code address of the primitive that has been |
""a_prim is the code address of the primitive that has been |
Line 2788 a_prim = decompile_code(a_code);
|
Line 2791 a_prim = decompile_code(a_code);
|
|
|
include(peeprules.vmg) |
include(peeprules.vmg) |
|
|
|
\g end |
|
|
\+ |
\+ |