version 1.4, 1997/06/23 15:53:53
|
version 1.41, 1999/12/03 18:24:22
|
Line 1
|
Line 1
|
\ Gforth primitives |
\ Gforth primitives |
|
|
\ Copyright (C) 1995,1996 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 115 INC_IP(1);
|
Line 115 INC_IP(1);
|
r> dup @ swap cell+ >r ; |
r> dup @ swap cell+ >r ; |
|
|
execute xt -- core |
execute xt -- core |
|
""Perform the semantics represented by the execution token, @i{xt}."" |
ip=IP; |
ip=IP; |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
EXEC(xt); |
EXEC(xt); |
|
|
perform a_addr -- gforth |
perform a_addr -- gforth |
""equivalent to @code{@ execute}"" |
""Equivalent to @code{@ execute}."" |
/* and pfe */ |
/* and pfe */ |
ip=IP; |
ip=IP; |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
Line 128 EXEC(*(Xt *)a_addr);
|
Line 129 EXEC(*(Xt *)a_addr);
|
: |
: |
@ execute ; |
@ execute ; |
|
|
\+has-locals [IF] |
\fhas? skipbranchprims 0= [IF] |
|
\+glocals |
|
|
branch-lp+!# -- gforth branch_lp_plus_store_number |
branch-lp+!# -- gforth branch_lp_plus_store_number |
/* this will probably not be used */ |
/* this will probably not be used */ |
Line 136 branch_adjust_lp:
|
Line 138 branch_adjust_lp:
|
lp += (Cell)(IP[1]); |
lp += (Cell)(IP[1]); |
goto branch; |
goto branch; |
|
|
\+[THEN] |
\+ |
|
|
branch -- gforth |
branch -- gforth |
branch: |
branch: |
ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
NEXT_P0; |
|
: |
: |
r> dup @ + >r ; |
r> dup @ + >r ; |
|
|
Line 149 NEXT_P0;
|
Line 150 NEXT_P0;
|
\ this is non-syntactical: code must open a brace that is closed by the macro |
\ this is non-syntactical: code must open a brace that is closed by the macro |
define(condbranch, |
define(condbranch, |
$1 $2 |
$1 $2 |
$3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
$3 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
NEXT_P0; |
|
NEXT; |
NEXT; |
} |
} |
else |
else |
INC_IP(1); |
INC_IP(1); |
$4 |
$4 |
|
|
\+has-locals [IF] |
\+glocals |
|
|
$1-lp+!# $2_lp_plus_store_number |
$1-lp+!# $2_lp_plus_store_number |
$3 goto branch_adjust_lp; |
$3 goto branch_adjust_lp; |
Line 165 $3 goto branch_adjust_lp;
|
Line 165 $3 goto branch_adjust_lp;
|
else |
else |
INC_IP(2); |
INC_IP(2); |
|
|
\+[THEN] |
\+ |
) |
) |
|
|
condbranch(?branch,f -- f83 question_branch, |
condbranch(?branch,f -- f83 question_branch, |
if (f==0) { |
if (f==0) { |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
,) |
,: |
|
0= dup \ !f !f |
|
r> dup @ \ !f !f IP branchoffset |
|
rot and + \ !f IP|IP+branchoffset |
|
swap 0= cell and + \ IP'' |
|
>r ;) |
|
|
\ we don't need an lp_plus_store version of the ?dup-stuff, because it |
\ we don't need an lp_plus_store version of the ?dup-stuff, because it |
\ is only used in if's (yet) |
\ is only used in if's (yet) |
|
|
\+has-xconds [IF] |
\+xconds |
|
|
?dup-?branch f -- f new question_dupe_question_branch |
?dup-?branch f -- f new question_dupe_question_branch |
""The run-time procedure compiled by @code{?DUP-IF}."" |
""The run-time procedure compiled by @code{?DUP-IF}."" |
if (f==0) { |
if (f==0) { |
sp++; |
sp++; |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
NEXT_P0; |
|
NEXT; |
NEXT; |
} |
} |
else |
else |
Line 198 few cycles in that case, but is easy to
|
Line 202 few cycles in that case, but is easy to
|
invocation */ |
invocation */ |
if (f!=0) { |
if (f!=0) { |
sp--; |
sp--; |
ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
NEXT_P0; |
|
NEXT; |
NEXT; |
} |
} |
else |
else |
INC_IP(1); |
INC_IP(1); |
|
|
\+[THEN] |
\+ |
|
\f[THEN] |
|
\fhas? skiploopprims 0= [IF] |
|
|
condbranch((next),-- cmFORTH paren_next, |
condbranch((next),-- cmFORTH paren_next, |
if ((*rp)--) { |
if ((*rp)--) { |
Line 245 if ((olddiff^(olddiff+n))>=0 /* the li
|
Line 250 if ((olddiff^(olddiff+n))>=0 /* the li
|
IF >r + >r dup @ + >r |
IF >r + >r dup @ + >r |
ELSE >r >r drop cell+ >r THEN ;) |
ELSE >r >r drop cell+ >r THEN ;) |
|
|
\+has-xconds [IF] |
\+xconds |
|
|
condbranch((-loop),u -- gforth paren_minus_loop, |
condbranch((-loop),u -- gforth paren_minus_loop, |
/* !! check this thoroughly */ |
/* !! check this thoroughly */ |
Line 281 if (diff>=0 || newdiff<0) {
|
Line 286 if (diff>=0 || newdiff<0) {
|
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
,) |
,) |
|
|
\+[THEN] |
\+ |
|
|
unloop -- core |
unloop -- core |
rp += 2; |
rp += 2; |
Line 320 else {
|
Line 325 else {
|
cell+ >r |
cell+ >r |
THEN ; \ --> CORE-EXT |
THEN ; \ --> CORE-EXT |
|
|
\+has-xconds [IF] |
\+xconds |
|
|
(+do) nlimit nstart -- gforth paren_plus_do |
(+do) nlimit nstart -- gforth paren_plus_do |
*--rp = nlimit; |
*--rp = nlimit; |
Line 402 else {
|
Line 407 else {
|
cell+ |
cell+ |
THEN >r ; |
THEN >r ; |
|
|
\+[THEN] |
\+ |
|
|
|
\ don't make any assumptions where the return stack is!! |
|
\ implement this in machine code if it should run quickly! |
|
|
i -- n core |
i -- n core |
n = *rp; |
n = *rp; |
: |
: |
rp@ cell+ @ ; |
\ rp@ cell+ @ ; |
|
r> r> tuck >r >r ; |
|
|
i' -- w gforth i_tick |
i' -- w gforth i_tick |
""loop end value"" |
""loop end value"" |
w = rp[1]; |
w = rp[1]; |
: |
: |
rp@ cell+ cell+ @ ; |
\ rp@ cell+ cell+ @ ; |
|
r> r> r> dup itmp ! >r >r >r itmp @ ; |
|
variable itmp |
|
|
j -- n core |
j -- n core |
n = rp[2]; |
n = rp[2]; |
: |
: |
rp@ cell+ cell+ cell+ @ ; |
\ rp@ cell+ cell+ cell+ @ ; |
|
r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; |
|
[IFUNDEF] itmp variable itmp [THEN] |
|
|
k -- n gforth |
k -- n gforth |
n = rp[4]; |
n = rp[4]; |
: |
: |
rp@ [ 5 cells ] Literal + @ ; |
\ rp@ [ 5 cells ] Literal + @ ; |
|
r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; |
|
[IFUNDEF] itmp variable itmp [THEN] |
|
|
|
\f[THEN] |
|
|
\ digit is high-level: 0/0% |
\ digit is high-level: 0/0% |
|
|
move c_from c_to ucount -- core |
move c_from c_to ucount -- core |
|
""Copy the contents of @i{ucount} address units at @i{c-from} to |
|
@i{c-to}. @code{move} works correctly even if the two areas overlap."" |
memmove(c_to,c_from,ucount); |
memmove(c_to,c_from,ucount); |
/* make an Ifdef for bsd and others? */ |
/* make an Ifdef for bsd and others? */ |
: |
: |
>r 2dup u< IF r> cmove> ELSE r> cmove THEN ; |
>r 2dup u< IF r> cmove> ELSE r> cmove THEN ; |
|
|
cmove c_from c_to u -- string |
cmove c_from c_to u -- string c_move |
|
""Copy the contents of @i{ucount} characters from data space at |
|
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
|
from low address to high address; i.e., for overlapping areas it is |
|
safe if @i{c-to}=<@i{c-from}."" |
while (u-- > 0) |
while (u-- > 0) |
*c_to++ = *c_from++; |
*c_to++ = *c_from++; |
: |
: |
bounds ?DO dup c@ I c! 1+ LOOP drop ; |
bounds ?DO dup c@ I c! 1+ LOOP drop ; |
|
|
cmove> c_from c_to u -- string c_move_up |
cmove> c_from c_to u -- string c_move_up |
|
""Copy the contents of @i{ucount} characters from data space at |
|
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
|
from high address to low address; i.e., for overlapping areas it is |
|
safe if @i{c-to}>=@i{c-from}."" |
while (u-- > 0) |
while (u-- > 0) |
c_to[u] = c_from[u]; |
c_to[u] = c_from[u]; |
: |
: |
Line 448 while (u-- > 0)
|
Line 475 while (u-- > 0)
|
DO 1- dup c@ I c! -1 +LOOP drop ; |
DO 1- dup c@ I c! -1 +LOOP drop ; |
|
|
fill c_addr u c -- core |
fill c_addr u c -- core |
|
"" If @i{u}>0, store character @i{c} in each of @i{u} consecutive |
|
@code{char} addresses in memory, starting at address @i{c-addr}."" |
memset(c_addr,c,u); |
memset(c_addr,c,u); |
: |
: |
-rot bounds |
-rot bounds |
?DO dup I c! LOOP drop ; |
?DO dup I c! LOOP drop ; |
|
|
compare c_addr1 u1 c_addr2 u2 -- n string |
compare c_addr1 u1 c_addr2 u2 -- n string |
""Compare the strings lexicographically. If they are equal, n is 0; if |
""Compare two strings lexicographically. If they are equal, @i{n} is 0; if |
the first string is smaller, n is -1; if the first string is larger, n |
the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} |
is 1. Currently this is based on the machine's character |
is 1. Currently this is based on the machine's character |
comparison. In the future, this may change to considering the current |
comparison. In the future, this may change to consider the current |
locale and its collation order."" |
locale and its collation order."" |
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
if (n==0) |
if (n==0) |
Line 489 else if (n>0)
|
Line 518 else if (n>0)
|
dup 0< IF drop -1 ELSE 0> 1 and THEN ; |
dup 0< IF drop -1 ELSE 0> 1 and THEN ; |
|
|
toupper c1 -- c2 gforth |
toupper c1 -- c2 gforth |
|
""If @i{c1} is a lower-case character (in the current locale), @i{c2} |
|
is the equivalent upper-case character. All other characters are unchanged."" |
c2 = toupper(c1); |
c2 = toupper(c1); |
: |
: |
dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
Line 507 else if (n>0)
|
Line 538 else if (n>0)
|
ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; |
ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; |
|
|
-trailing c_addr u1 -- c_addr u2 string dash_trailing |
-trailing c_addr u1 -- c_addr u2 string dash_trailing |
|
""Adjust the string specified by @i{c-addr, u1} to remove all trailing |
|
spaces. @i{u2} is the length of the modified string."" |
u2 = u1; |
u2 = u1; |
while (u2>0 && c_addr[u2-1] == ' ') |
while (u2>0 && c_addr[u2-1] == ' ') |
u2--; |
u2--; |
Line 515 while (u2>0 && c_addr[u2-1] == ' ')
|
Line 548 while (u2>0 && c_addr[u2-1] == ' ')
|
dup 0= UNTIL ELSE 1+ THEN ; |
dup 0= UNTIL ELSE 1+ THEN ; |
|
|
/string c_addr1 u1 n -- c_addr2 u2 string slash_string |
/string c_addr1 u1 n -- c_addr2 u2 string slash_string |
|
""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} |
|
characters from the start of the string."" |
c_addr2 = c_addr1+n; |
c_addr2 = c_addr1+n; |
u2 = u1-n; |
u2 = u1-n; |
: |
: |
Line 525 n = n1+n2;
|
Line 560 n = n1+n2;
|
|
|
\ PFE-0.9.14 has it differently, but the next release will have it as follows |
\ PFE-0.9.14 has it differently, but the next release will have it as follows |
under+ n1 n2 n3 -- n n2 gforth under_plus |
under+ n1 n2 n3 -- n n2 gforth under_plus |
""add @var{n3} to @var{n1} (giving @var{n})"" |
""add @i{n3} to @i{n1} (giving @i{n})"" |
n = n1+n3; |
n = n1+n3; |
: |
: |
rot + swap ; |
rot + swap ; |
Line 607 n2 = n1>>1;
|
Line 642 n2 = n1>>1;
|
: |
: |
dup MINI and IF 1 ELSE 0 THEN |
dup MINI and IF 1 ELSE 0 THEN |
[ bits/byte cell * 1- ] literal |
[ bits/byte cell * 1- ] literal |
0 DO 2* swap dup 2* >r U-HIGHBIT and |
0 DO 2* swap dup 2* >r MINI and |
IF 1 ELSE 0 THEN or r> swap |
IF 1 ELSE 0 THEN or r> swap |
LOOP nip ; |
LOOP nip ; |
|
|
fm/mod d1 n1 -- n2 n3 core f_m_slash_mod |
fm/mod d1 n1 -- n2 n3 core f_m_slash_mod |
""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1"" |
""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}."" |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
DCell r = fmdiv(d1,n1); |
DCell r = fmdiv(d1,n1); |
n2=r.hi; |
n2=r.hi; |
Line 634 if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
|
Line 669 if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
|
r> 0< IF swap negate swap THEN ; |
r> 0< IF swap negate swap THEN ; |
|
|
sm/rem d1 n1 -- n2 n3 core s_m_slash_rem |
sm/rem d1 n1 -- n2 n3 core s_m_slash_rem |
""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0"" |
""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0."" |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
DCell r = smdiv(d1,n1); |
DCell r = smdiv(d1,n1); |
n2=r.hi; |
n2=r.hi; |
Line 684 ud = (UDCell)u1 * (UDCell)u2;
|
Line 719 ud = (UDCell)u1 * (UDCell)u2;
|
and >r >r 2dup d+ swap r> + swap r> ; |
and >r >r 2dup d+ swap r> + swap r> ; |
|
|
um/mod ud u1 -- u2 u3 core u_m_slash_mod |
um/mod ud u1 -- u2 u3 core u_m_slash_mod |
|
""ud=u3*u1+u2, u1>u2>=0"" |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
UDCell r = umdiv(ud,u1); |
UDCell r = umdiv(ud,u1); |
u2=r.hi; |
u2=r.hi; |
Line 694 u2 = ud%u1;
|
Line 730 u2 = ud%u1;
|
#endif |
#endif |
: |
: |
0 swap [ 8 cells 1 + ] literal 0 |
0 swap [ 8 cells 1 + ] literal 0 |
?DO >r /modstep r> |
?DO /modstep |
LOOP drop swap 1 rshift or swap ; |
LOOP drop swap 1 rshift or swap ; |
: /modstep ( ud c R: u -- ud-?u c R: u ) |
: /modstep ( ud c R: u -- ud-?u c R: u ) |
over I' u< 0= or IF I' - 1 ELSE 0 THEN d2*+ ; |
>r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ; |
: d2*+ ( ud n -- ud+n c ) |
: d2*+ ( ud n -- ud+n c ) |
over MINI |
over MINI |
and >r >r 2dup d+ swap r> + swap r> ; |
and >r >r 2dup d+ swap r> + swap r> ; |
Line 732 d = d1-d2;
|
Line 768 d = d1-d2;
|
: |
: |
dnegate d+ ; |
dnegate d+ ; |
|
|
dnegate d1 -- d2 double |
dnegate d1 -- d2 double d_negate |
/* use dminus as alias */ |
/* use dminus as alias */ |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
d2 = dnegate(d1); |
d2 = dnegate(d1); |
Line 771 w = w1|w2;
|
Line 807 w = w1|w2;
|
: |
: |
invert swap invert and invert ; |
invert swap invert and invert ; |
|
|
xor w1 w2 -- w core |
xor w1 w2 -- w core x_or |
w = w1^w2; |
w = w1^w2; |
|
|
invert w1 -- w2 core |
invert w1 -- w2 core |
Line 779 w2 = ~w1;
|
Line 815 w2 = ~w1;
|
: |
: |
MAXU xor ; |
MAXU xor ; |
|
|
rshift u1 n -- u2 core |
rshift u1 n -- u2 core r_shift |
u2 = u1>>n; |
u2 = u1>>n; |
: |
: |
0 ?DO 2/ MAXI and LOOP ; |
0 ?DO 2/ MAXI and LOOP ; |
|
|
lshift u1 n -- u2 core |
lshift u1 n -- u2 core l_shift |
u2 = u1<<n; |
u2 = u1<<n; |
: |
: |
0 ?DO 2* LOOP ; |
0 ?DO 2* LOOP ; |
Line 800 f = FLAG($4==$5);
|
Line 836 f = FLAG($4==$5);
|
] xor 0= [ |
] xor 0= [ |
[THEN] ] ; |
[THEN] ] ; |
|
|
$1<> $2 -- f $7 $3different |
$1<> $2 -- f $7 $3not_equals |
f = FLAG($4!=$5); |
f = FLAG($4!=$5); |
: |
: |
[ char $1x char 0 = [IF] |
[ char $1x char 0 = [IF] |
Line 809 f = FLAG($4!=$5);
|
Line 845 f = FLAG($4!=$5);
|
] xor 0<> [ |
] xor 0<> [ |
[THEN] ] ; |
[THEN] ] ; |
|
|
$1< $2 -- f $8 $3less |
$1< $2 -- f $8 $3less_than |
f = FLAG($4<$5); |
f = FLAG($4<$5); |
: |
: |
[ char $1x char 0 = [IF] |
[ char $1x char 0 = [IF] |
Line 821 f = FLAG($4<$5);
|
Line 857 f = FLAG($4<$5);
|
[THEN] |
[THEN] |
[THEN] ] ; |
[THEN] ] ; |
|
|
$1> $2 -- f $9 $3greater |
$1> $2 -- f $9 $3greater_than |
f = FLAG($4>$5); |
f = FLAG($4>$5); |
: |
: |
[ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] |
[ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] |
Line 853 f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
|
Line 889 f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
|
f = FLAG($4==$5); |
f = FLAG($4==$5); |
#endif |
#endif |
|
|
$1<> $2 -- f $7 $3different |
$1<> $2 -- f $7 $3not_equals |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); |
f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); |
#else |
#else |
f = FLAG($4!=$5); |
f = FLAG($4!=$5); |
#endif |
#endif |
|
|
$1< $2 -- f $8 $3less |
$1< $2 -- f $8 $3less_than |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); |
f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); |
#else |
#else |
f = FLAG($4<$5); |
f = FLAG($4<$5); |
#endif |
#endif |
|
|
$1> $2 -- f $9 $3greater |
$1> $2 -- f $9 $3greater_than |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); |
f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); |
#else |
#else |
Line 890 f = FLAG($4>=$5);
|
Line 926 f = FLAG($4>=$5);
|
|
|
) |
) |
|
|
\+has-dcomps [IF] |
\+dcomps |
|
|
dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) |
dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) |
dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) |
dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) |
dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) |
dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) |
|
|
\+[THEN] |
\+ |
|
|
within u1 u2 u3 -- f core-ext |
within u1 u2 u3 -- f core-ext |
|
""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for |
|
unsigned and signed numbers (but not a mixture). Another way to think |
|
about this word is to consider the numbers as a circle (wrapping |
|
around from @code{max-u} to 0 for unsigned, and from @code{max-n} to |
|
min-n for signed numbers); now consider the range from u2 towards |
|
increasing numbers up to and excluding u3 (giving an empty range if |
|
u2=u3; if u1 is in this range, @code{within} returns true."" |
f = FLAG(u1-u2 < u3-u2); |
f = FLAG(u1-u2 < u3-u2); |
: |
: |
over - >r - r> u< ; |
over - >r - r> u< ; |
|
|
sp@ -- a_addr gforth spat |
sp@ -- a_addr gforth sp_fetch |
a_addr = sp+1; |
a_addr = sp+1; |
|
|
sp! a_addr -- gforth spstore |
sp! a_addr -- gforth sp_store |
sp = a_addr; |
sp = a_addr; |
/* works with and without TOS caching */ |
/* works with and without TOS caching */ |
|
|
rp@ -- a_addr gforth rpat |
rp@ -- a_addr gforth rp_fetch |
a_addr = rp; |
a_addr = rp; |
|
|
rp! a_addr -- gforth rpstore |
rp! a_addr -- gforth rp_store |
rp = a_addr; |
rp = a_addr; |
|
|
\+has-floats [IF] |
\+floating |
|
|
fp@ -- f_addr gforth fp_fetch |
fp@ -- f_addr gforth fp_fetch |
f_addr = fp; |
f_addr = fp; |
Line 924 f_addr = fp;
|
Line 967 f_addr = fp;
|
fp! f_addr -- gforth fp_store |
fp! f_addr -- gforth fp_store |
fp = f_addr; |
fp = f_addr; |
|
|
\+[THEN] |
\+ |
|
|
;s -- gforth semis |
;s -- gforth semis |
ip = (Xt *)(*rp++); |
""The primitive compiled by @code{EXIT}."" |
NEXT_P0; |
SET_IP((Xt *)(*rp++)); |
|
|
>r w -- core to_r |
>r w -- core to_r |
*--rp = w; |
*--rp = w; |
Line 983 swap w1 w2 -- w2 w1 core
|
Line 1026 swap w1 w2 -- w2 w1 core
|
>r (swap) ! r> (swap) @ ; |
>r (swap) ! r> (swap) @ ; |
Variable (swap) |
Variable (swap) |
|
|
dup w -- w w core |
dup w -- w w core dupe |
: |
: |
sp@ @ ; |
sp@ @ ; |
|
|
Line 1002 Variable (rot)
|
Line 1045 Variable (rot)
|
|
|
nip w1 w2 -- w2 core-ext |
nip w1 w2 -- w2 core-ext |
: |
: |
>r drop r> ; |
swap drop ; |
|
|
tuck w1 w2 -- w2 w1 w2 core-ext |
tuck w1 w2 -- w2 w1 w2 core-ext |
: |
: |
Line 1054 w = sp[u+1];
|
Line 1097 w = sp[u+1];
|
\ toggle is high-level: 0.11/0.42% |
\ toggle is high-level: 0.11/0.42% |
|
|
@ a_addr -- w core fetch |
@ a_addr -- w core fetch |
|
"" Read from the cell at address @i{a-addr}, and return its contents, @i{w}."" |
w = *a_addr; |
w = *a_addr; |
|
|
! w a_addr -- core store |
! w a_addr -- core store |
|
"" Write the value @i{w} to the cell at address @i{a-addr}."" |
*a_addr = w; |
*a_addr = w; |
|
|
+! n a_addr -- core plus_store |
+! n a_addr -- core plus_store |
|
"" Add @i{n} to the value stored in the cell at address @i{a-addr}."" |
*a_addr += n; |
*a_addr += n; |
: |
: |
tuck @ + swap ! ; |
tuck @ + swap ! ; |
|
|
c@ c_addr -- c core cfetch |
c@ c_addr -- c core c_fetch |
|
"" Read from the char at address @i{c-addr}, and return its contents, @i{c}."" |
c = *c_addr; |
c = *c_addr; |
: |
: |
[ bigendian [IF] ] |
[ bigendian [IF] ] |
Line 1089 c = *c_addr;
|
Line 1136 c = *c_addr;
|
; |
; |
: 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; |
: 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; |
|
|
c! c c_addr -- core cstore |
c! c c_addr -- core c_store |
|
"" Write the value @i{c} to the char at address @i{c-addr}."" |
*c_addr = c; |
*c_addr = c; |
: |
: |
[ bigendian [IF] ] |
[ bigendian [IF] ] |
Line 1119 c! c c_addr -- core cstore
|
Line 1167 c! c c_addr -- core cstore
|
: 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; |
: 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; |
|
|
2! w1 w2 a_addr -- core two_store |
2! w1 w2 a_addr -- core two_store |
|
"" Write the value @i{w1, w2} to the double at address @i{a-addr}."" |
a_addr[0] = w2; |
a_addr[0] = w2; |
a_addr[1] = w1; |
a_addr[1] = w1; |
: |
: |
tuck ! cell+ ! ; |
tuck ! cell+ ! ; |
|
|
2@ a_addr -- w1 w2 core two_fetch |
2@ a_addr -- w1 w2 core two_fetch |
|
"" Read from the double at address @i{a-addr}, and return its contents, @i{w1, w2}."" |
w2 = a_addr[0]; |
w2 = a_addr[0]; |
w1 = a_addr[1]; |
w1 = a_addr[1]; |
: |
: |
dup cell+ @ swap @ ; |
dup cell+ @ swap @ ; |
|
|
cell+ a_addr1 -- a_addr2 core cell_plus |
cell+ a_addr1 -- a_addr2 core cell_plus |
|
"" Increment @i{a-addr1} by the number of address units corresponding to the size of |
|
one cell, to give @i{a-addr2}."" |
a_addr2 = a_addr1+1; |
a_addr2 = a_addr1+1; |
: |
: |
cell + ; |
cell + ; |
|
|
cells n1 -- n2 core |
cells n1 -- n2 core |
|
"" @i{n2} is the number of address units corresponding to @i{n1} cells."" |
n2 = n1 * sizeof(Cell); |
n2 = n1 * sizeof(Cell); |
: |
: |
[ cell |
[ cell |
Line 1145 n2 = n1 * sizeof(Cell);
|
Line 1198 n2 = n1 * sizeof(Cell);
|
2/ dup [IF] ] 2* [ [THEN] |
2/ dup [IF] ] 2* [ [THEN] |
drop ] ; |
drop ] ; |
|
|
char+ c_addr1 -- c_addr2 core care_plus |
char+ c_addr1 -- c_addr2 core char_plus |
|
"" Increment @i{c-addr1} by the number of address units corresponding to the size of |
|
one char, to give @i{c-addr2}."" |
c_addr2 = c_addr1 + 1; |
c_addr2 = c_addr1 + 1; |
: |
: |
1+ ; |
1+ ; |
|
|
(chars) n1 -- n2 gforth paren_cares |
(chars) n1 -- n2 gforth paren_chars |
n2 = n1 * sizeof(Char); |
n2 = n1 * sizeof(Char); |
: |
: |
; |
; |
|
|
count c_addr1 -- c_addr2 u core |
count c_addr1 -- c_addr2 u core |
|
"" If @i{c-add1} is the address of a counted string return the length of |
|
the string, @i{u}, and the address of its first character, @i{c-addr2}."" |
u = *c_addr1; |
u = *c_addr1; |
c_addr2 = c_addr1+1; |
c_addr2 = c_addr1+1; |
: |
: |
dup 1+ swap c@ ; |
dup 1+ swap c@ ; |
|
|
(f83find) c_addr u f83name1 -- f83name2 new paren_f83find |
(f83find) c_addr u f83name1 -- f83name2 new paren_f83find |
for (; f83name1 != NULL; f83name1 = f83name1->next) |
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
break; |
break; |
Line 1176 f83name2=f83name1;
|
Line 1233 f83name2=f83name1;
|
: (find-samelen) ( u f83name1 -- u f83name2/0 ) |
: (find-samelen) ( u f83name1 -- u f83name2/0 ) |
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
|
|
\+has-hash [IF] |
\+hash |
|
|
(hashfind) c_addr u a_addr -- f83name2 new paren_hashfind |
(hashfind) c_addr u a_addr -- f83name2 new paren_hashfind |
F83Name *f83name1; |
struct F83Name *f83name1; |
f83name2=NULL; |
f83name2=NULL; |
while(a_addr != NULL) |
while(a_addr != NULL) |
{ |
{ |
f83name1=(F83Name *)(a_addr[1]); |
f83name1=(struct F83Name *)(a_addr[1]); |
a_addr=(Cell *)(a_addr[0]); |
a_addr=(Cell *)(a_addr[0]); |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
Line 1202 while(a_addr != NULL)
|
Line 1259 while(a_addr != NULL)
|
|
|
(tablefind) c_addr u a_addr -- f83name2 new paren_tablefind |
(tablefind) c_addr u a_addr -- f83name2 new paren_tablefind |
""A case-sensitive variant of @code{(hashfind)}"" |
""A case-sensitive variant of @code{(hashfind)}"" |
F83Name *f83name1; |
struct F83Name *f83name1; |
f83name2=NULL; |
f83name2=NULL; |
while(a_addr != NULL) |
while(a_addr != NULL) |
{ |
{ |
f83name1=(F83Name *)(a_addr[1]); |
f83name1=(struct F83Name *)(a_addr[1]); |
a_addr=(Cell *)(a_addr[0]); |
a_addr=(Cell *)(a_addr[0]); |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
Line 1257 Create rot-values
|
Line 1314 Create rot-values
|
7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, |
7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, |
7 c, 5 c, 5 c, |
7 c, 5 c, 5 c, |
|
|
\+[THEN] |
\+ |
|
|
(parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white |
(parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white |
/* use !isgraph instead of isspace? */ |
/* use !isgraph instead of isspace? */ |
Line 1280 else {
|
Line 1337 else {
|
REPEAT THEN nip - ; |
REPEAT THEN nip - ; |
|
|
aligned c_addr -- a_addr core |
aligned c_addr -- a_addr core |
|
"" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}."" |
a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); |
a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); |
: |
: |
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
|
|
faligned c_addr -- f_addr float f_aligned |
faligned c_addr -- f_addr float f_aligned |
|
"" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}."" |
f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); |
f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); |
: |
: |
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
|
|
>body xt -- a_addr core to_body |
>body xt -- a_addr core to_body |
|
"" Get the address of the body of the word represented by @i{xt} (the address |
|
of the word's data field)."" |
a_addr = PFA(xt); |
a_addr = PFA(xt); |
: |
: |
2 cells + ; |
2 cells + ; |
|
|
|
\ threading stuff is currently only interesting if we have a compiler |
|
\fhas? standardthreading has? compiler and [IF] |
|
|
>code-address xt -- c_addr gforth to_code_address |
>code-address xt -- c_addr gforth to_code_address |
""c_addr is the code address of the word xt"" |
""@i{c-addr} is the code address of the word @i{xt}."" |
/* !! This behaves installation-dependently for DOES-words */ |
/* !! This behaves installation-dependently for DOES-words */ |
c_addr = (Address)CODE_ADDRESS(xt); |
c_addr = (Address)CODE_ADDRESS(xt); |
: |
: |
@ ; |
@ ; |
|
|
>does-code xt -- a_addr gforth to_does_code |
>does-code xt -- a_addr gforth to_does_code |
""If xt ist the execution token of a defining-word-defined word, |
""If @i{xt} is the execution token of a defining-word-defined word, |
a_addr is the start of the Forth code after the DOES>; |
@i{a-addr} is the start of the Forth code after the @code{DOES>}; |
Otherwise a_addr is 0."" |
Otherwise @i{a-addr} is 0."" |
a_addr = (Cell *)DOES_CODE(xt); |
a_addr = (Cell *)DOES_CODE(xt); |
: |
: |
cell+ @ ; |
cell+ @ ; |
|
|
code-address! c_addr xt -- gforth code_address_store |
code-address! c_addr xt -- gforth code_address_store |
""Creates a code field with code address c_addr at xt"" |
""Create a code field with code address @i{c-addr} at @i{xt}."" |
MAKE_CF(xt, c_addr); |
MAKE_CF(xt, c_addr); |
CACHE_FLUSH(xt,PFA(0)); |
CACHE_FLUSH(xt,(size_t)PFA(0)); |
: |
: |
! ; |
! ; |
|
|
does-code! a_addr xt -- gforth does_code_store |
does-code! a_addr xt -- gforth does_code_store |
""creates a code field at xt for a defining-word-defined word; a_addr |
""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr} |
is the start of the Forth code after DOES>"" |
is the start of the Forth code after @code{DOES>}."" |
MAKE_DOES_CF(xt, a_addr); |
MAKE_DOES_CF(xt, a_addr); |
CACHE_FLUSH(xt,PFA(0)); |
CACHE_FLUSH(xt,(size_t)PFA(0)); |
: |
: |
dodoes: over ! cell+ ! ; |
dodoes: over ! cell+ ! ; |
|
|
does-handler! a_addr -- gforth does_handler_store |
does-handler! a_addr -- gforth does_handler_store |
""creates a DOES>-handler at address a_addr. a_addr usually points |
""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points |
just behind a DOES>."" |
just behind a @code{DOES>}."" |
MAKE_DOES_HANDLER(a_addr); |
MAKE_DOES_HANDLER(a_addr); |
CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE); |
CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); |
: |
: |
drop ; |
drop ; |
|
|
/does-handler -- n gforth slash_does_handler |
/does-handler -- n gforth slash_does_handler |
""the size of a does-handler (includes possible padding)"" |
""The size of a @code{DOES>}-handler (includes possible padding)."" |
/* !! a constant or environmental query might be better */ |
/* !! a constant or environmental query might be better */ |
n = DOES_HANDLER_SIZE; |
n = DOES_HANDLER_SIZE; |
: |
: |
Line 1354 n=1;
|
Line 1418 n=1;
|
: |
: |
1 ; |
1 ; |
|
|
\+has-os [IF] |
\f[THEN] |
|
|
(key) -- n gforth paren_key |
key-file wfileid -- n gforth paren_key_file |
|
#ifdef HAS_FILE |
fflush(stdout); |
fflush(stdout); |
/* !! noecho */ |
n = key((FILE*)wfileid); |
n = key(); |
#else |
|
n = key(stdin); |
|
#endif |
|
|
key? -- n facility key_q |
key?-file wfileid -- n facility key_q_file |
|
#ifdef HAS_FILE |
fflush(stdout); |
fflush(stdout); |
n = key_query; |
n = key_query((FILE*)wfileid); |
|
#else |
|
n = key_query(stdin); |
|
#endif |
|
|
|
\+os |
|
|
|
stdin -- wfileid gforth |
|
wfileid = (Cell)stdin; |
|
|
stdout -- wfileid gforth |
stdout -- wfileid gforth |
wfileid = (Cell)stdout; |
wfileid = (Cell)stdout; |
Line 1381 ucols=cols;
|
Line 1457 ucols=cols;
|
|
|
flush-icache c_addr u -- gforth flush_icache |
flush-icache c_addr u -- gforth flush_icache |
""Make sure that the instruction cache of the processor (if there is |
""Make sure that the instruction cache of the processor (if there is |
one) does not contain stale data at @var{c_addr} and @var{u} bytes |
one) does not contain stale data at @i{c-addr} and @i{u} bytes |
afterwards. @code{END-CODE} performs a @code{flush-icache} |
afterwards. @code{END-CODE} performs a @code{flush-icache} |
automatically. Caveat: @code{flush-icache} might not work on your |
automatically. Caveat: @code{flush-icache} might not work on your |
installation; this is usually the case if direct threading is not |
installation; this is usually the case if direct threading is not |
Line 1395 FLUSH_ICACHE(c_addr,u);
|
Line 1471 FLUSH_ICACHE(c_addr,u);
|
return (Label *)n; |
return (Label *)n; |
|
|
(system) c_addr u -- wretval wior gforth peren_system |
(system) c_addr u -- wretval wior gforth peren_system |
|
#ifndef MSDOS |
int old_tp=terminal_prepped; |
int old_tp=terminal_prepped; |
deprep_terminal(); |
deprep_terminal(); |
|
#endif |
wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ |
wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ |
wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); |
wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); |
|
#ifndef MSDOS |
if (old_tp) |
if (old_tp) |
prep_terminal(); |
prep_terminal(); |
|
#endif |
|
|
getenv c_addr1 u1 -- c_addr2 u2 gforth |
getenv c_addr1 u1 -- c_addr2 u2 gforth |
|
""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2} |
|
is the host operating system's expansion of that environment variable. If the |
|
environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters |
|
in length."" |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
Line 1434 timeout.tv_usec=1000*(n%1000);
|
Line 1518 timeout.tv_usec=1000*(n%1000);
|
(void)select(0,0,0,0,&timeout); |
(void)select(0,0,0,0,&timeout); |
|
|
allocate u -- a_addr wior memory |
allocate u -- a_addr wior memory |
|
""Allocate @i{u} address units of contiguous data space. The initial |
|
contents of the data space is undefined. If the allocation is successful, |
|
@i{a-addr} is the start address of the allocated region and @i{wior} |
|
is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior} |
|
is an implementation-defined I/O result code."" |
a_addr = (Cell *)malloc(u?u:1); |
a_addr = (Cell *)malloc(u?u:1); |
wior = IOR(a_addr==NULL); |
wior = IOR(a_addr==NULL); |
|
|
free a_addr -- wior memory |
free a_addr -- wior memory |
|
""Return the region of data space starting at @i{a-addr} to the system. |
|
The regon must originally have been obtained using @code{allocate} or |
|
@code{resize}. If the operational is successful, @i{wior} is 0. |
|
If the operation fails, @i{wior} is an implementation-defined |
|
I/O result code."" |
free(a_addr); |
free(a_addr); |
wior = 0; |
wior = 0; |
|
|
resize a_addr1 u -- a_addr2 wior memory |
resize a_addr1 u -- a_addr2 wior memory |
""Change the size of the allocated area at @i{a_addr1} to @i{u} |
""Change the size of the allocated area at @i{a-addr1} to @i{u} |
address units, possibly moving the contents to a different |
address units, possibly moving the contents to a different |
area. @i{a_addr2} is the address of the resulting area. If |
area. @i{a-addr2} is the address of the resulting area. |
@code{a_addr1} is 0, Gforth's (but not the standard) @code{resize} |
If the operational is successful, @i{wior} is 0. |
@code{allocate}s @i{u} address units."" |
If the operation fails, @i{wior} is an implementation-defined |
|
I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard) |
|
@code{resize} @code{allocate}s @i{u} address units."" |
/* the following check is not necessary on most OSs, but it is needed |
/* the following check is not necessary on most OSs, but it is needed |
on SunOS 4.1.2. */ |
on SunOS 4.1.2. */ |
if (a_addr1==NULL) |
if (a_addr1==NULL) |
Line 1478 fp=FP;
|
Line 1574 fp=FP;
|
IF_TOS(TOS=sp[0]); |
IF_TOS(TOS=sp[0]); |
IF_FTOS(FTOS=fp[0]); |
IF_FTOS(FTOS=fp[0]); |
|
|
\+[THEN] ( has-os ) has-files [IF] |
\+ |
|
\+file |
|
|
close-file wfileid -- wior file close_file |
close-file wfileid -- wior file close_file |
wior = IOR(fclose((FILE *)wfileid)==EOF); |
wior = IOR(fclose((FILE *)wfileid)==EOF); |
|
|
open-file c_addr u ntype -- w2 wior file open_file |
open-file c_addr u ntype -- wfileid wior file open_file |
w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); |
wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); |
wior = IOR(w2 == 0); |
#if defined(GO32) && defined(MSDOS) |
|
if(wfileid && !(ntype & 1)) |
|
setbuf((FILE*)wfileid, NULL); |
|
#endif |
|
wior = IOR(wfileid == 0); |
|
|
create-file c_addr u ntype -- w2 wior file create_file |
create-file c_addr u ntype -- wfileid wior file create_file |
Cell fd; |
Cell fd; |
fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666); |
fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666); |
if (fd != -1) { |
if (fd != -1) { |
w2 = (Cell)fdopen(fd, fileattr[ntype]); |
wfileid = (Cell)fdopen(fd, fileattr[ntype]); |
wior = IOR(w2 == 0); |
#if defined(GO32) && defined(MSDOS) |
|
if(wfileid && !(ntype & 1)) |
|
setbuf((FILE*)wfileid, NULL); |
|
#endif |
|
wior = IOR(wfileid == 0); |
} else { |
} else { |
w2 = 0; |
wfileid = 0; |
wior = IOR(1); |
wior = IOR(1); |
} |
} |
|
|
Line 1502 delete-file c_addr u -- wior file delet
|
Line 1607 delete-file c_addr u -- wior file delet
|
wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); |
wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); |
|
|
rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file |
rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file |
|
""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" |
char *s1=tilde_cstr(c_addr2, u2, 1); |
char *s1=tilde_cstr(c_addr2, u2, 1); |
wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); |
wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); |
|
|
Line 1514 reposition-file ud wfileid -- wior file
|
Line 1620 reposition-file ud wfileid -- wior file
|
wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); |
wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); |
|
|
file-size wfileid -- ud wior file file_size |
file-size wfileid -- ud wior file file_size |
#include <sys/stat.h> |
|
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 = LONG2UD(buf.st_size); |
Line 1548 wior=FILEIO(ferror((FILE *)wfileid));
|
Line 1653 wior=FILEIO(ferror((FILE *)wfileid));
|
*/ |
*/ |
if ((flag=FLAG(!feof((FILE *)wfileid) && |
if ((flag=FLAG(!feof((FILE *)wfileid) && |
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */ |
wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ |
if (wior) |
if (wior) |
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
u2 = strlen(c_addr); |
u2 = strlen(c_addr); |
Line 1559 else {
|
Line 1664 else {
|
u2=0; |
u2=0; |
} |
} |
|
|
\+[THEN] has-files [IF] -1 [ELSE] has-os [THEN] [IF] |
\+ |
|
|
write-file c_addr u1 wfileid -- wior file write_file |
write-file c_addr u1 wfileid -- wior file write_file |
/* !! fwrite does not guarantee enough */ |
/* !! fwrite does not guarantee enough */ |
|
#ifdef HAS_FILE |
{ |
{ |
UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); |
UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); |
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); |
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); |
if (wior) |
if (wior) |
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
} |
} |
|
#else |
|
TYPE(c_addr, u1); |
|
#endif |
|
|
emit-file c wfileid -- wior gforth emit_file |
emit-file c wfileid -- wior gforth emit_file |
|
#ifdef HAS_FILE |
wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); |
wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); |
if (wior) |
if (wior) |
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
|
#else |
|
PUTC(c); |
|
#endif |
|
|
\+[THEN] has-files [IF] |
\+file |
|
|
flush-file wfileid -- wior file-ext flush_file |
flush-file wfileid -- wior file-ext flush_file |
wior = IOR(fflush((FILE *) wfileid)==EOF); |
wior = IOR(fflush((FILE *) wfileid)==EOF); |
Line 1604 else {
|
Line 1717 else {
|
wior=0; |
wior=0; |
} |
} |
|
|
\+[THEN] ( has-files ) has-floats [IF] |
\+ |
|
\+floating |
|
|
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) |
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) |
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) |
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) |
Line 1619 r = d;
|
Line 1733 r = d;
|
|
|
f>d r -- d float f_to_d |
f>d r -- d float f_to_d |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
d.hi = ldexp(r,-CELL_BITS) - (r<0); |
d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0); |
d.lo = r-ldexp((Float)d.hi,CELL_BITS); |
d.lo = r-ldexp((Float)d.hi,CELL_BITS); |
#else |
#else |
d = r; |
d = r; |
#endif |
#endif |
|
|
f! r f_addr -- float f_store |
f! r f_addr -- float f_store |
|
"" Store the floating-point value @i{r} to address @i{f-addr}."" |
*f_addr = r; |
*f_addr = r; |
|
|
f@ f_addr -- r float f_fetch |
f@ f_addr -- r float f_fetch |
|
"" Fetch floating-point value @i{r} from address @i{f-addr}."" |
r = *f_addr; |
r = *f_addr; |
|
|
df@ df_addr -- r float-ext d_f_fetch |
df@ df_addr -- r float-ext d_f_fetch |
|
"" Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}."" |
#ifdef IEEE_FP |
#ifdef IEEE_FP |
r = *df_addr; |
r = *df_addr; |
#else |
#else |
Line 1639 r = *df_addr;
|
Line 1756 r = *df_addr;
|
#endif |
#endif |
|
|
df! r df_addr -- float-ext d_f_store |
df! r df_addr -- float-ext d_f_store |
|
"" Store the double-precision IEEE floating-point value @i{r} to the address @i{df-addr}."" |
#ifdef IEEE_FP |
#ifdef IEEE_FP |
*df_addr = r; |
*df_addr = r; |
#else |
#else |
Line 1646 df! r df_addr -- float-ext d_f_store
|
Line 1764 df! r df_addr -- float-ext d_f_store
|
#endif |
#endif |
|
|
sf@ sf_addr -- r float-ext s_f_fetch |
sf@ sf_addr -- r float-ext s_f_fetch |
|
"" Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}."" |
#ifdef IEEE_FP |
#ifdef IEEE_FP |
r = *sf_addr; |
r = *sf_addr; |
#else |
#else |
Line 1653 r = *sf_addr;
|
Line 1772 r = *sf_addr;
|
#endif |
#endif |
|
|
sf! r sf_addr -- float-ext s_f_store |
sf! r sf_addr -- float-ext s_f_store |
|
"" Store the single-precision IEEE floating-point value @i{r} to the address @i{sf-addr}."" |
#ifdef IEEE_FP |
#ifdef IEEE_FP |
*sf_addr = r; |
*sf_addr = r; |
#else |
#else |
Line 1672 f/ r1 r2 -- r3 float f_slash
|
Line 1792 f/ r1 r2 -- r3 float f_slash
|
r3 = r1/r2; |
r3 = r1/r2; |
|
|
f** r1 r2 -- r3 float-ext f_star_star |
f** r1 r2 -- r3 float-ext f_star_star |
""@i{r3} is @i{r1} raised to the @i{r2}th power"" |
""@i{r3} is @i{r1} raised to the @i{r2}th power."" |
r3 = pow(r1,r2); |
r3 = pow(r1,r2); |
|
|
fnegate r1 -- r2 float |
fnegate r1 -- r2 float f_negate |
r2 = - r1; |
r2 = - r1; |
|
|
fdrop r -- float |
fdrop r -- float f_drop |
|
|
fdup r -- r r float |
fdup r -- r r float f_dupe |
|
|
fswap r1 r2 -- r2 r1 float |
fswap r1 r2 -- r2 r1 float f_swap |
|
|
fover r1 r2 -- r1 r2 r1 float |
fover r1 r2 -- r1 r2 r1 float f_over |
|
|
frot r1 r2 r3 -- r2 r3 r1 float |
frot r1 r2 r3 -- r2 r3 r1 float f_rote |
|
|
fnip r1 r2 -- r2 gforth |
fnip r1 r2 -- r2 gforth f_nip |
|
|
ftuck r1 r2 -- r2 r1 r2 gforth |
ftuck r1 r2 -- r2 r1 r2 gforth f_tuck |
|
|
float+ f_addr1 -- f_addr2 float float_plus |
float+ f_addr1 -- f_addr2 float float_plus |
|
"" Increment @i{f-addr1} by the number of address units corresponding to the size of |
|
one floating-point number, to give @i{f-addr2}."" |
f_addr2 = f_addr1+1; |
f_addr2 = f_addr1+1; |
|
|
floats n1 -- n2 float |
floats n1 -- n2 float |
|
""@i{n2} is the number of address units corresponding to @i{n1} floating-point numbers."" |
n2 = n1*sizeof(Float); |
n2 = n1*sizeof(Float); |
|
|
floor r1 -- r2 float |
floor r1 -- r2 float |
""round towards the next smaller integral value, i.e., round toward negative infinity"" |
""Round towards the next smaller integral value, i.e., round toward negative infinity."" |
/* !! unclear wording */ |
/* !! unclear wording */ |
r2 = floor(r1); |
r2 = floor(r1); |
|
|
fround r1 -- r2 float |
fround r1 -- r2 float f_round |
""round to the nearest integral value"" |
""Round to the nearest integral value."" |
/* !! unclear wording */ |
/* !! unclear wording */ |
#ifdef HAVE_RINT |
#ifdef HAVE_RINT |
r2 = rint(r1); |
r2 = rint(r1); |
Line 1713 r2 = floor(r1+0.5);
|
Line 1836 r2 = floor(r1+0.5);
|
/* !! This is not quite true to the rounding rules given in the standard */ |
/* !! This is not quite true to the rounding rules given in the standard */ |
#endif |
#endif |
|
|
fmax r1 r2 -- r3 float |
fmax r1 r2 -- r3 float f_max |
if (r1<r2) |
if (r1<r2) |
r3 = r2; |
r3 = r2; |
else |
else |
r3 = r1; |
r3 = r1; |
|
|
fmin r1 r2 -- r3 float |
fmin r1 r2 -- r3 float f_min |
if (r1<r2) |
if (r1<r2) |
r3 = r1; |
r3 = r1; |
else |
else |
Line 1732 int decpt;
|
Line 1855 int decpt;
|
sig=ecvt(r, u, &decpt, &flag); |
sig=ecvt(r, u, &decpt, &flag); |
n=(r==0 ? 1 : decpt); |
n=(r==0 ? 1 : decpt); |
f1=FLAG(flag!=0); |
f1=FLAG(flag!=0); |
f2=FLAG(isdigit(sig[0])!=0); |
f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
memmove(c_addr,sig,u); |
memmove(c_addr,sig,u); |
|
|
>float c_addr u -- flag float to_float |
>float c_addr u -- flag float to_float |
|
""Attempt to convert the character string @i{c-addr u} to |
|
internal floating-point representation. If the string |
|
represents a valid floating-point number @i{r} is placed |
|
on the floating-point stack and @i{flag} is true. Otherwise, |
|
@i{flag} is false. A string of blanks is a special case |
|
and represents the floating-point number 0."" |
/* real signature: c_addr u -- r t / f */ |
/* real signature: c_addr u -- r t / f */ |
Float r; |
Float r; |
char *number=cstr(c_addr, u, 1); |
char *number=cstr(c_addr, u, 1); |
char *endconv; |
char *endconv; |
while(isspace(number[--u]) && u>0); |
while(isspace((unsigned)(number[--u])) && u>0); |
switch(number[u]) |
switch(number[u]) |
{ |
{ |
case 'd': |
case 'd': |
Line 1769 else if(*endconv=='d' || *endconv=='D')
|
Line 1898 else if(*endconv=='d' || *endconv=='D')
|
} |
} |
} |
} |
|
|
fabs r1 -- r2 float-ext |
fabs r1 -- r2 float-ext f_abs |
r2 = fabs(r1); |
r2 = fabs(r1); |
|
|
facos r1 -- r2 float-ext |
facos r1 -- r2 float-ext f_a_cos |
r2 = acos(r1); |
r2 = acos(r1); |
|
|
fasin r1 -- r2 float-ext |
fasin r1 -- r2 float-ext f_a_sine |
r2 = asin(r1); |
r2 = asin(r1); |
|
|
fatan r1 -- r2 float-ext |
fatan r1 -- r2 float-ext f_a_tan |
r2 = atan(r1); |
r2 = atan(r1); |
|
|
fatan2 r1 r2 -- r3 float-ext |
fatan2 r1 r2 -- r3 float-ext f_a_tan_two |
""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably |
""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably |
intends this to be the inverse of @code{fsincos}. In gforth it is."" |
intends this to be the inverse of @code{fsincos}. In gforth it is."" |
r3 = atan2(r1,r2); |
r3 = atan2(r1,r2); |
|
|
fcos r1 -- r2 float-ext |
fcos r1 -- r2 float-ext f_cos |
r2 = cos(r1); |
r2 = cos(r1); |
|
|
fexp r1 -- r2 float-ext |
fexp r1 -- r2 float-ext f_e_x_p |
r2 = exp(r1); |
r2 = exp(r1); |
|
|
fexpm1 r1 -- r2 float-ext |
fexpm1 r1 -- r2 float-ext f_e_x_p_m_one |
""@i{r2}=@i{e}**@i{r1}@minus{}1"" |
""@i{r2}=@i{e}**@i{r1}@minus{}1"" |
#ifdef HAVE_EXPM1 |
#ifdef HAVE_EXPM1 |
extern double |
extern double |
Line 1805 r2 = expm1(r1);
|
Line 1934 r2 = expm1(r1);
|
r2 = exp(r1)-1.; |
r2 = exp(r1)-1.; |
#endif |
#endif |
|
|
fln r1 -- r2 float-ext |
fln r1 -- r2 float-ext f_l_n |
r2 = log(r1); |
r2 = log(r1); |
|
|
flnp1 r1 -- r2 float-ext |
flnp1 r1 -- r2 float-ext f_l_n_p_one |
""@i{r2}=ln(@i{r1}+1)"" |
""@i{r2}=ln(@i{r1}+1)"" |
#ifdef HAVE_LOG1P |
#ifdef HAVE_LOG1P |
extern double |
extern double |
Line 1821 r2 = log1p(r1);
|
Line 1950 r2 = log1p(r1);
|
r2 = log(r1+1.); |
r2 = log(r1+1.); |
#endif |
#endif |
|
|
flog r1 -- r2 float-ext |
flog r1 -- r2 float-ext f_log |
""the decimal logarithm"" |
""The decimal logarithm."" |
r2 = log10(r1); |
r2 = log10(r1); |
|
|
falog r1 -- r2 float-ext |
falog r1 -- r2 float-ext f_a_log |
""@i{r2}=10**@i{r1}"" |
""@i{r2}=10**@i{r1}"" |
extern double pow10(double); |
extern double pow10(double); |
r2 = pow10(r1); |
r2 = pow10(r1); |
|
|
fsin r1 -- r2 float-ext |
fsin r1 -- r2 float-ext f_sine |
r2 = sin(r1); |
r2 = sin(r1); |
|
|
fsincos r1 -- r2 r3 float-ext |
fsincos r1 -- r2 r3 float-ext f_sine_cos |
""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" |
""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" |
r2 = sin(r1); |
r2 = sin(r1); |
r3 = cos(r1); |
r3 = cos(r1); |
|
|
fsqrt r1 -- r2 float-ext |
fsqrt r1 -- r2 float-ext f_square_root |
r2 = sqrt(r1); |
r2 = sqrt(r1); |
|
|
ftan r1 -- r2 float-ext |
ftan r1 -- r2 float-ext f_tan |
r2 = tan(r1); |
r2 = tan(r1); |
: |
: |
fsincos f/ ; |
fsincos f/ ; |
|
|
fsinh r1 -- r2 float-ext |
fsinh r1 -- r2 float-ext f_cinch |
r2 = sinh(r1); |
r2 = sinh(r1); |
: |
: |
fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; |
fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; |
|
|
fcosh r1 -- r2 float-ext |
fcosh r1 -- r2 float-ext f_cosh |
r2 = cosh(r1); |
r2 = cosh(r1); |
: |
: |
fexp fdup 1/f f+ f2/ ; |
fexp fdup 1/f f+ f2/ ; |
|
|
ftanh r1 -- r2 float-ext |
ftanh r1 -- r2 float-ext f_tan_h |
r2 = tanh(r1); |
r2 = tanh(r1); |
: |
: |
f2* fexpm1 fdup 2. d>f f+ f/ ; |
f2* fexpm1 fdup 2. d>f f+ f/ ; |
|
|
fasinh r1 -- r2 float-ext |
fasinh r1 -- r2 float-ext f_a_cinch |
r2 = asinh(r1); |
r2 = asinh(r1); |
: |
: |
fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; |
fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; |
|
|
facosh r1 -- r2 float-ext |
facosh r1 -- r2 float-ext f_a_cosh |
r2 = acosh(r1); |
r2 = acosh(r1); |
: |
: |
fdup fdup f* 1. d>f f- fsqrt f+ fln ; |
fdup fdup f* 1. d>f f- fsqrt f+ fln ; |
|
|
fatanh r1 -- r2 float-ext |
fatanh r1 -- r2 float-ext f_a_tan_h |
r2 = atanh(r1); |
r2 = atanh(r1); |
: |
: |
fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ |
fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ |
r> IF fnegate THEN ; |
r> IF fnegate THEN ; |
|
|
sfloats n1 -- n2 float-ext s_floats |
sfloats n1 -- n2 float-ext s_floats |
|
""@i{n2} is the number of address units corresponding to @i{n1} |
|
single-precision IEEE floating-point numbers."" |
n2 = n1*sizeof(SFloat); |
n2 = n1*sizeof(SFloat); |
|
|
dfloats n1 -- n2 float-ext d_floats |
dfloats n1 -- n2 float-ext d_floats |
|
""@i{n2} is the number of address units corresponding to @i{n1} |
|
double-precision IEEE floating-point numbers."" |
n2 = n1*sizeof(DFloat); |
n2 = n1*sizeof(DFloat); |
|
|
sfaligned c_addr -- sf_addr float-ext s_f_aligned |
sfaligned c_addr -- sf_addr float-ext s_f_aligned |
|
"" @i{sf-addr} is the first single-float-aligned address greater |
|
than or equal to @i{c-addr}."" |
sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); |
sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); |
: |
: |
[ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; |
[ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; |
|
|
dfaligned c_addr -- df_addr float-ext d_f_aligned |
dfaligned c_addr -- df_addr float-ext d_f_aligned |
|
"" @i{df-addr} is the first double-float-aligned address greater |
|
than or equal to @i{c-addr}."" |
df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); |
df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); |
: |
: |
[ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; |
[ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; |
Line 1899 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
Line 2036 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ |
\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ |
|
|
\ local variable implementation primitives |
\ local variable implementation primitives |
\+[THEN] ( has-floats ) has-locals [IF] |
\+ |
|
\+glocals |
|
|
@local# -- w gforth fetch_local_number |
@local# -- w gforth fetch_local_number |
w = *(Cell *)(lp+(Cell)NEXT_INST); |
w = *(Cell *)(lp+(Cell)NEXT_INST); |
Line 1917 w = *(Cell *)(lp+2*sizeof(Cell));
|
Line 2055 w = *(Cell *)(lp+2*sizeof(Cell));
|
@local3 -- w new fetch_local_twelve |
@local3 -- w new fetch_local_twelve |
w = *(Cell *)(lp+3*sizeof(Cell)); |
w = *(Cell *)(lp+3*sizeof(Cell)); |
|
|
\+has-floats [IF] |
\+floating |
|
|
f@local# -- r gforth f_fetch_local_number |
f@local# -- r gforth f_fetch_local_number |
r = *(Float *)(lp+(Cell)NEXT_INST); |
r = *(Float *)(lp+(Cell)NEXT_INST); |
Line 1929 r = *(Float *)(lp+0*sizeof(Float));
|
Line 2067 r = *(Float *)(lp+0*sizeof(Float));
|
f@local1 -- r new f_fetch_local_eight |
f@local1 -- r new f_fetch_local_eight |
r = *(Float *)(lp+1*sizeof(Float)); |
r = *(Float *)(lp+1*sizeof(Float)); |
|
|
\+[THEN] |
\+ |
|
|
laddr# -- c_addr gforth laddr_number |
laddr# -- c_addr gforth laddr_number |
/* this can also be used to implement lp@ */ |
/* this can also be used to implement lp@ */ |
Line 1959 lp = (Address)c_addr;
|
Line 2097 lp = (Address)c_addr;
|
lp -= sizeof(Cell); |
lp -= sizeof(Cell); |
*(Cell *)lp = w; |
*(Cell *)lp = w; |
|
|
\+has-floats [IF] |
\+floating |
|
|
f>l r -- gforth f_to_l |
f>l r -- gforth f_to_l |
lp -= sizeof(Float); |
lp -= sizeof(Float); |
*(Float *)lp = r; |
*(Float *)lp = r; |
|
|
\+[THEN] [THEN] \ has-locals |
fpick u -- r gforth |
|
r = fp[u+1]; /* +1, because update of fp happens before this fragment */ |
|
: |
|
floats fp@ + f@ ; |
|
|
|
\+ |
|
\+ |
|
|
\+has-OS [IF] |
\+OS |
|
|
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')') |
Line 1989 define(argclist,
|
Line 2133 define(argclist,
|
\ icall(argnum) |
\ icall(argnum) |
define(icall, |
define(icall, |
`icall$1 argflist($1)u -- uret gforth |
`icall$1 argflist($1)u -- uret gforth |
uret = ((Cell(*)(argdlist($1)))u)(argclist($1)); |
uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1)); |
|
|
') |
') |
define(fcall, |
define(fcall, |
`fcall$1 argflist($1)u -- rret gforth |
`fcall$1 argflist($1)u -- rret gforth |
rret = ((Float(*)(argdlist($1)))u)(argclist($1)); |
rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); |
|
|
') |
') |
|
|
|
|
open-lib c_addr1 u1 -- u2 gforth open_lib |
open-lib c_addr1 u1 -- u2 gforth open_lib |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_LAZY); |
#ifndef RTLD_GLOBAL |
|
#define RTLD_GLOBAL 0 |
|
#endif |
|
u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); |
#else |
#else |
# ifdef HAVE_LIBKERNEL32 |
# ifdef _WIN32 |
u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); |
u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); |
# else |
# else |
#warning Define open-lib! |
#warning Define open-lib! |
Line 2015 lib-sym c_addr1 u1 u2 -- u3 gforth lib_s
|
Line 2162 lib-sym c_addr1 u1 u2 -- u3 gforth lib_s
|
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); |
u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); |
#else |
#else |
# ifdef HAVE_LIBKERNEL32 |
# ifdef _WIN32 |
u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); |
u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); |
# else |
# else |
#warning Define lib-sym! |
#warning Define lib-sym! |
Line 2028 icall(20)
|
Line 2175 icall(20)
|
uploop(i, 0, 7, `fcall(i)') |
uploop(i, 0, 7, `fcall(i)') |
fcall(20) |
fcall(20) |
|
|
\+[THEN] \ has-OS |
\+ |
|
|
up! a_addr -- gforth up_store |
up! a_addr -- gforth up_store |
UP=up=(char *)a_addr; |
UP=up=(char *)a_addr; |
Line 2036 UP=up=(char *)a_addr;
|
Line 2183 UP=up=(char *)a_addr;
|
up ! ; |
up ! ; |
Variable UP |
Variable UP |
|
|
|
wcall u -- gforth |
|
IF_FTOS(fp[0]=FTOS); |
|
FP=fp; |
|
sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP); |
|
fp=FP; |
|
IF_TOS(TOS=sp[0];) |
|
IF_FTOS(FTOS=fp[0]); |
|
|