version 1.1, 1997/05/21 20:39:36
|
version 1.17, 1998/12/11 22:54:27
|
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 128 EXEC(*(Xt *)a_addr);
|
Line 128 EXEC(*(Xt *)a_addr);
|
: |
: |
@ execute ; |
@ execute ; |
|
|
\+has-locals [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 136 branch_adjust_lp:
|
lp += (Cell)(IP[1]); |
lp += (Cell)(IP[1]); |
goto branch; |
goto branch; |
|
|
\+[THEN] |
\+ |
|
|
branch -- gforth |
branch -- gforth |
branch: |
branch: |
Line 157 else
|
Line 157 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}."" |
Line 205 if (f!=0) {
|
Line 210 if (f!=0) {
|
else |
else |
INC_IP(1); |
INC_IP(1); |
|
|
\+[THEN] |
\+ |
|
|
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] |
|
|
\ digit is high-level: 0/0% |
\ digit is high-level: 0/0% |
|
|
Line 508 else if (n>0)
|
Line 523 else if (n>0)
|
|
|
-trailing c_addr u1 -- c_addr u2 string dash_trailing |
-trailing c_addr u1 -- c_addr u2 string dash_trailing |
u2 = u1; |
u2 = u1; |
while (c_addr[u2-1] == ' ') |
while (u2>0 && c_addr[u2-1] == ' ') |
u2--; |
u2--; |
: |
: |
BEGIN 1- 2dup + c@ bl = WHILE |
BEGIN 1- 2dup + c@ bl = WHILE |
Line 607 n2 = n1>>1;
|
Line 622 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 ; |
|
|
Line 694 u2 = ud%u1;
|
Line 709 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 890 f = FLAG($4>=$5);
|
Line 905 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 |
f = FLAG(u1-u2 < u3-u2); |
f = FLAG(u1-u2 < u3-u2); |
Line 916 a_addr = rp;
|
Line 931 a_addr = rp;
|
rp! a_addr -- gforth rpstore |
rp! a_addr -- gforth rpstore |
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 939 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++); |
ip = (Xt *)(*rp++); |
Line 1002 Variable (rot)
|
Line 1017 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 1162 c_addr2 = c_addr1+1;
|
Line 1177 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 1191 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 1217 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 1272 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 1312 a_addr = (Cell *)DOES_CODE(xt);
|
Line 1327 a_addr = (Cell *)DOES_CODE(xt);
|
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"" |
""Creates a code field with code address c_addr at xt"" |
MAKE_CF(xt, c_addr); |
MAKE_CF(xt, c_addr); |
CACHE_FLUSH(xt,PFA(0)); |
CACHE_FLUSH(xt,(size_t)PFA(0)); |
: |
: |
! ; |
! ; |
|
|
Line 1320 does-code! a_addr xt -- gforth does_cod
|
Line 1335 does-code! a_addr xt -- gforth does_cod
|
""creates a code field at xt for a defining-word-defined word; a_addr |
""creates a code field at xt for a defining-word-defined word; a_addr |
is the start of the Forth code after DOES>"" |
is the start of the Forth code after 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+ ! ; |
|
|
Line 1328 does-handler! a_addr -- gforth does_hand
|
Line 1343 does-handler! a_addr -- gforth does_hand
|
""creates a DOES>-handler at address a_addr. a_addr usually points |
""creates a DOES>-handler at address a_addr. a_addr usually points |
just behind a DOES>."" |
just behind a 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 ; |
|
|
Line 1354 n=1;
|
Line 1369 n=1;
|
: |
: |
1 ; |
1 ; |
|
|
\+has-os [IF] |
key-file wfileid -- n gforth paren_key_file |
|
#ifdef HAS_FILE |
(key) -- n gforth paren_key |
|
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 1478 fp=FP;
|
Line 1503 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 -- w2 wior file open_file |
w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); |
w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); |
|
#if defined(GO32) && defined(MSDOS) |
|
if(w2 && !(ntype & 1)) |
|
setbuf((FILE*)w2, NULL); |
|
#endif |
wior = IOR(w2 == 0); |
wior = IOR(w2 == 0); |
|
|
create-file c_addr u ntype -- w2 wior file create_file |
create-file c_addr u ntype -- w2 wior file create_file |
Line 1492 Cell fd;
|
Line 1522 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]); |
w2 = (Cell)fdopen(fd, fileattr[ntype]); |
|
#if defined(GO32) && defined(MSDOS) |
|
if(w2 && !(ntype & 1)) |
|
setbuf((FILE*)w2, NULL); |
|
#endif |
wior = IOR(w2 == 0); |
wior = IOR(w2 == 0); |
} else { |
} else { |
w2 = 0; |
w2 = 0; |
Line 1514 reposition-file ud wfileid -- wior file
|
Line 1548 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 1559 else {
|
Line 1592 else {
|
u2=0; |
u2=0; |
} |
} |
|
|
\+[THEN] has-files [IF] -1 [ELSE] has-os [THEN] [IF] |
\+ |
|
\+file |
|
|
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 */ |
Line 1570 write-file c_addr u1 wfileid -- wior fil
|
Line 1604 write-file c_addr u1 wfileid -- wior fil
|
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
} |
} |
|
|
|
\+ |
|
|
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, stdout); |
|
#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 1644 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 1795 r2 = exp(r1);
|
Line 1836 r2 = exp(r1);
|
fexpm1 r1 -- r2 float-ext |
fexpm1 r1 -- r2 float-ext |
""@i{r2}=@i{e}**@i{r1}@minus{}1"" |
""@i{r2}=@i{e}**@i{r1}@minus{}1"" |
#ifdef HAVE_EXPM1 |
#ifdef HAVE_EXPM1 |
extern double expm1(double); |
extern double |
|
#ifdef NeXT |
|
const |
|
#endif |
|
expm1(double); |
r2 = expm1(r1); |
r2 = expm1(r1); |
#else |
#else |
r2 = exp(r1)-1.; |
r2 = exp(r1)-1.; |
Line 1807 r2 = log(r1);
|
Line 1852 r2 = log(r1);
|
flnp1 r1 -- r2 float-ext |
flnp1 r1 -- r2 float-ext |
""@i{r2}=ln(@i{r1}+1)"" |
""@i{r2}=ln(@i{r1}+1)"" |
#ifdef HAVE_LOG1P |
#ifdef HAVE_LOG1P |
extern double log1p(double); |
extern double |
|
#ifdef NeXT |
|
const |
|
#endif |
|
log1p(double); |
r2 = log1p(r1); |
r2 = log1p(r1); |
#else |
#else |
r2 = log(r1+1.); |
r2 = log(r1+1.); |
Line 1891 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
Line 1940 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 1909 w = *(Cell *)(lp+2*sizeof(Cell));
|
Line 1959 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 1921 r = *(Float *)(lp+0*sizeof(Float));
|
Line 1971 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 1951 lp = (Address)c_addr;
|
Line 2001 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 1981 define(argclist,
|
Line 2037 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 HAVE_LIBKERNEL32 |
u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); |
u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); |
Line 2020 icall(20)
|
Line 2079 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; |
: |
: |
up ! ; |
up ! ; |
Variable UP |
Variable UP |
|
|