version 1.13, 1998/10/25 23:15:46
|
version 1.25, 1999/02/21 11:43:12
|
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, 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? glocals [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 137 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 149 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? glocals [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 164 $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, |
Line 181 if (f==0) {
|
Line 180 if (f==0) {
|
\ 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 203 few cycles in that case, but is easy to
|
Line 201 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] |
\+ |
|
|
condbranch((next),-- cmFORTH paren_next, |
condbranch((next),-- cmFORTH paren_next, |
if ((*rp)--) { |
if ((*rp)--) { |
Line 250 if ((olddiff^(olddiff+n))>=0 /* the li
|
Line 247 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 286 if (diff>=0 || newdiff<0) {
|
Line 283 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 325 else {
|
Line 322 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 407 else {
|
Line 404 else {
|
cell+ |
cell+ |
THEN >r ; |
THEN >r ; |
|
|
\+[THEN] |
\+ |
|
|
\ don't make any assumptions where the return stack is!! |
\ don't make any assumptions where the return stack is!! |
\ implement this in machine code if it should run quickly! |
\ implement this in machine code if it should run quickly! |
Line 443 n = rp[4];
|
Line 440 n = rp[4];
|
\ 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 |
|
"" If ucount>0, copy the contents of ucount address units |
|
at c-from to c-to. @code{move} chooses its copy direction |
|
to avoid problems when c-from, c-to 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 |
|
"" If u>0, copy the contents of ucount characters from |
|
data space at c-from to c-to. The copy proceeds @code{char}-by-@code{char} |
|
from low address to high address."" |
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 |
|
"" If u>0, copy the contents of ucount characters from |
|
data space at c-from to c-to. The copy proceeds @code{char}-by-@code{char} |
|
from high address to low address."" |
while (u-- > 0) |
while (u-- > 0) |
c_to[u] = c_from[u]; |
c_to[u] = c_from[u]; |
: |
: |
Line 463 while (u-- > 0)
|
Line 469 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 u>0, store character c in each of u consecutive |
|
@code{char} addresses in memory, starting at address 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, n is 0; if |
the first string is smaller, n is -1; if the first string is larger, n |
the first string is smaller, n is -1; if the first string is larger, 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 considering the current |
Line 504 else if (n>0)
|
Line 512 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 @var{c1} is a lower-case character (in the current locale), @var{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 905 f = FLAG($4>=$5);
|
Line 915 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 931 a_addr = rp;
|
Line 941 a_addr = rp;
|
rp! a_addr -- gforth rpstore |
rp! a_addr -- gforth rpstore |
rp = a_addr; |
rp = a_addr; |
|
|
\+has? floating [IF] |
\+floating |
|
|
fp@ -- f_addr gforth fp_fetch |
fp@ -- f_addr gforth fp_fetch |
f_addr = fp; |
f_addr = fp; |
Line 939 f_addr = fp;
|
Line 949 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 1171 n2 = n1 * sizeof(Char);
|
Line 1181 n2 = n1 * sizeof(Char);
|
; |
; |
|
|
count c_addr1 -- c_addr2 u core |
count c_addr1 -- c_addr2 u core |
|
"" If c-add1 is the address of a counted string return the length of |
|
the string, u, and the address of its first character, c-addr2."" |
u = *c_addr1; |
u = *c_addr1; |
c_addr2 = c_addr1+1; |
c_addr2 = c_addr1+1; |
: |
: |
Line 1191 f83name2=f83name1;
|
Line 1203 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 |
struct F83Name *f83name1; |
struct F83Name *f83name1; |
Line 1272 Create rot-values
|
Line 1284 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 1318 c_addr = (Address)CODE_ADDRESS(xt);
|
Line 1330 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 xt ist the execution token of a defining-word-defined word, |
a_addr is the start of the Forth code after the DOES>; |
a_addr is the start of the Forth code after the @code{DOES>}; |
Otherwise a_addr is 0."" |
Otherwise a_addr is 0."" |
a_addr = (Cell *)DOES_CODE(xt); |
a_addr = (Cell *)DOES_CODE(xt); |
: |
: |
Line 1369 n=1;
|
Line 1381 n=1;
|
: |
: |
1 ; |
1 ; |
|
|
\+has? os [IF] |
|
|
|
key-file wfileid -- n gforth paren_key_file |
key-file wfileid -- n gforth paren_key_file |
|
#ifdef HAS_FILE |
fflush(stdout); |
fflush(stdout); |
n = key((FILE*)wfileid); |
n = key((FILE*)wfileid); |
|
#else |
|
n = key(stdin); |
|
#endif |
|
|
key?-file wfileid -- n facility key_q_file |
key?-file wfileid -- n facility key_q_file |
|
#ifdef HAS_FILE |
fflush(stdout); |
fflush(stdout); |
n = key_query((FILE*)wfileid); |
n = key_query((FILE*)wfileid); |
|
#else |
|
n = key_query(stdin); |
|
#endif |
|
|
|
\+os |
|
|
stdin -- wfileid gforth |
stdin -- wfileid gforth |
wfileid = (Cell)stdin; |
wfileid = (Cell)stdin; |
Line 1412 FLUSH_ICACHE(c_addr,u);
|
Line 1432 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 c-addr1 u1 specifies an environment variable. The string c-addr2 u2 |
|
is the host operating system's expansion of that environment variable. If the |
|
environment variable does not exist, 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 1495 fp=FP;
|
Line 1523 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? file [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 1519 delete-file c_addr u -- wior file delet
|
Line 1556 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 c_addr1 u1 to new name 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 1575 else {
|
Line 1613 else {
|
u2=0; |
u2=0; |
} |
} |
|
|
\+[THEN] has? file [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 1586 write-file c_addr u1 wfileid -- wior fil
|
Line 1625 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? file [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 1620 else {
|
Line 1665 else {
|
wior=0; |
wior=0; |
} |
} |
|
|
\+[THEN] ( has? file ) has? floating [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 1635 r = d;
|
Line 1681 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; |
Line 1748 int decpt;
|
Line 1794 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 |
Line 1756 memmove(c_addr,sig,u);
|
Line 1802 memmove(c_addr,sig,u);
|
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 1915 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
Line 1961 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? glocals [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 1933 w = *(Cell *)(lp+2*sizeof(Cell));
|
Line 1980 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? floating [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 1945 r = *(Float *)(lp+0*sizeof(Float));
|
Line 1992 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 1975 lp = (Address)c_addr;
|
Line 2022 lp = (Address)c_addr;
|
lp -= sizeof(Cell); |
lp -= sizeof(Cell); |
*(Cell *)lp = w; |
*(Cell *)lp = w; |
|
|
\+has? floating [IF] |
\+floating |
|
|
f>l r -- gforth f_to_l |
f>l r -- gforth f_to_l |
lp -= sizeof(Float); |
lp -= sizeof(Float); |
Line 1986 r = fp[u+1]; /* +1, because update of fp
|
Line 2033 r = fp[u+1]; /* +1, because update of fp
|
: |
: |
floats fp@ + f@ ; |
floats fp@ + f@ ; |
|
|
\+[THEN] [THEN] \ has? glocals |
\+ |
|
\+ |
|
|
\+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 2027 open-lib c_addr1 u1 -- u2 gforth open_li
|
Line 2075 open-lib c_addr1 u1 -- u2 gforth open_li
|
#endif |
#endif |
u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); |
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 2039 lib-sym c_addr1 u1 u2 -- u3 gforth lib_s
|
Line 2087 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 2052 icall(20)
|
Line 2100 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 |
|
|