version 1.60, 1996/12/23 15:07:46
|
version 1.61, 1997/02/06 21:23:05
|
Line 111 noop -- gforth
|
Line 111 noop -- gforth
|
lit -- w gforth |
lit -- w gforth |
w = (Cell)NEXT_INST; |
w = (Cell)NEXT_INST; |
INC_IP(1); |
INC_IP(1); |
|
: |
|
r> dup @ swap cell+ >r ; |
|
|
execute xt -- core |
execute xt -- core |
ip=IP; |
ip=IP; |
Line 126 EXEC(*(Xt *)a_addr);
|
Line 128 EXEC(*(Xt *)a_addr);
|
: |
: |
@ execute ; |
@ execute ; |
|
|
|
\+has-locals [IF] |
|
|
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 */ |
branch_adjust_lp: |
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); |
ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
Line 139 NEXT_P0;
|
Line 145 NEXT_P0;
|
: |
: |
r> dup @ + >r ; |
r> dup @ + >r ; |
|
|
\ condbranch(forthname,restline,code) |
\ condbranch(forthname,restline,code,forthcode) |
\ 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 |
Line 149 $3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INS
|
Line 155 $3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INS
|
} |
} |
else |
else |
INC_IP(1); |
INC_IP(1); |
|
$4 |
|
|
|
\+has-locals [IF] |
|
|
$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 156 $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]); |
) |
,) |
|
|
\ 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) |
Line 195 else
|
Line 205 else
|
|
|
condbranch((next),-- cmFORTH paren_next, |
condbranch((next),-- cmFORTH paren_next, |
if ((*rp)--) { |
if ((*rp)--) { |
) |
,: |
|
r> r> dup 1- >r |
|
IF dup @ + >r ELSE cell+ >r THEN ;) |
|
|
condbranch((loop),-- gforth paren_loop, |
condbranch((loop),-- gforth paren_loop, |
Cell index = *rp+1; |
Cell index = *rp+1; |
Cell limit = rp[1]; |
Cell limit = rp[1]; |
if (index != limit) { |
if (index != limit) { |
*rp = index; |
*rp = index; |
) |
,: |
|
r> r> 1+ r> 2dup = |
|
IF >r 1- >r cell+ >r |
|
ELSE >r >r dup @ + >r THEN ;) |
|
|
condbranch((+loop),n -- gforth paren_plus_loop, |
condbranch((+loop),n -- gforth paren_plus_loop, |
/* !! check this thoroughly */ |
/* !! check this thoroughly */ |
Line 210 Cell index = *rp;
|
Line 225 Cell index = *rp;
|
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ |
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ |
/* dependent upon two's complement arithmetic */ |
/* dependent upon two's complement arithmetic */ |
Cell olddiff = index-rp[1]; |
Cell olddiff = index-rp[1]; |
#ifndef undefined |
|
if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ |
if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ |
|| (olddiff^n)>=0 /* it is a wrap-around effect */) { |
|| (olddiff^n)>=0 /* it is a wrap-around effect */) { |
#else |
|
#ifndef MAXINT |
|
#define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1) |
|
#endif |
|
if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) { |
|
#endif |
|
#ifdef i386 |
#ifdef i386 |
*rp += n; |
*rp += n; |
#else |
#else |
*rp = index + n; |
*rp = index + n; |
#endif |
#endif |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
) |
,: |
|
r> swap |
|
r> r> 2dup - >r |
|
2 pick r@ + r@ xor 0< 0= |
|
3 pick r> xor 0< 0= or |
|
IF >r + >r dup @ + >r |
|
ELSE >r >r drop cell+ >r THEN ;) |
|
|
condbranch((-loop),u -- gforth paren_minus_loop, |
condbranch((-loop),u -- gforth paren_minus_loop, |
/* !! check this thoroughly */ |
/* !! check this thoroughly */ |
Line 238 if (olddiff>u) {
|
Line 252 if (olddiff>u) {
|
*rp = index - u; |
*rp = index - u; |
#endif |
#endif |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
) |
,) |
|
|
condbranch((s+loop),n -- gforth paren_symmetric_plus_loop, |
condbranch((s+loop),n -- gforth paren_symmetric_plus_loop, |
""The run-time procedure compiled by S+LOOP. It loops until the index |
""The run-time procedure compiled by S+LOOP. It loops until the index |
Line 259 if (diff>=0 || newdiff<0) {
|
Line 273 if (diff>=0 || newdiff<0) {
|
*rp = index + n; |
*rp = index + n; |
#endif |
#endif |
IF_TOS(TOS = sp[0]); |
IF_TOS(TOS = sp[0]); |
) |
,) |
|
|
unloop -- core |
unloop -- core |
rp += 2; |
rp += 2; |
Line 290 if (nstart == nlimit) {
|
Line 304 if (nstart == nlimit) {
|
else { |
else { |
INC_IP(1); |
INC_IP(1); |
} |
} |
|
: |
|
swap 2dup |
|
r> swap >r swap >r |
|
= |
|
IF |
|
dup @ + |
|
ELSE |
|
cell+ |
|
THEN >r ; |
|
|
(+do) nlimit nstart -- gforth paren_plus_do |
(+do) nlimit nstart -- gforth paren_plus_do |
*--rp = nlimit; |
*--rp = nlimit; |
Line 301 if (nstart >= nlimit) {
|
Line 324 if (nstart >= nlimit) {
|
else { |
else { |
INC_IP(1); |
INC_IP(1); |
} |
} |
|
: |
|
swap 2dup |
|
r> swap >r swap >r |
|
>= |
|
IF |
|
dup @ + |
|
ELSE |
|
cell+ |
|
THEN >r ; |
|
|
(u+do) ulimit ustart -- gforth paren_u_plus_do |
(u+do) ulimit ustart -- gforth paren_u_plus_do |
*--rp = ulimit; |
*--rp = ulimit; |
Line 312 if (ustart >= ulimit) {
|
Line 344 if (ustart >= ulimit) {
|
else { |
else { |
INC_IP(1); |
INC_IP(1); |
} |
} |
|
: |
|
swap 2dup |
|
r> swap >r swap >r |
|
u>= |
|
IF |
|
dup @ + |
|
ELSE |
|
cell+ |
|
THEN >r ; |
|
|
(-do) nlimit nstart -- gforth paren_minus_do |
(-do) nlimit nstart -- gforth paren_minus_do |
*--rp = nlimit; |
*--rp = nlimit; |
Line 323 if (nstart <= nlimit) {
|
Line 364 if (nstart <= nlimit) {
|
else { |
else { |
INC_IP(1); |
INC_IP(1); |
} |
} |
|
: |
|
swap 2dup |
|
r> swap >r swap >r |
|
<= |
|
IF |
|
dup @ + |
|
ELSE |
|
cell+ |
|
THEN >r ; |
|
|
(u-do) ulimit ustart -- gforth paren_u_minus_do |
(u-do) ulimit ustart -- gforth paren_u_minus_do |
*--rp = ulimit; |
*--rp = ulimit; |
Line 334 if (ustart <= ulimit) {
|
Line 384 if (ustart <= ulimit) {
|
else { |
else { |
INC_IP(1); |
INC_IP(1); |
} |
} |
|
: |
|
swap 2dup |
|
r> swap >r swap >r |
|
u<= |
|
IF |
|
dup @ + |
|
ELSE |
|
cell+ |
|
THEN >r ; |
|
|
i -- n core |
i -- n core |
n = *rp; |
n = *rp; |
|
: |
|
rp@ cell+ @ ; |
|
|
|
i' -- w gforth i_tick |
|
""loop end value"" |
|
w = rp[1]; |
|
: |
|
rp@ cell+ cell+ @ ; |
|
|
j -- n core |
j -- n core |
n = rp[2]; |
n = rp[2]; |
|
: |
|
rp@ cell+ cell+ cell+ @ ; |
|
|
\ digit is high-level: 0/0% |
\ digit is high-level: 0/0% |
|
|
Line 419 else if (n>0)
|
Line 488 else if (n>0)
|
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
ELSE c@ I c@ - unloop THEN -text-flag ; |
ELSE c@ I c@ - unloop THEN -text-flag ; |
: -text-flag ( n -- -1/0/1 ) |
: -text-flag ( n -- -1/0/1 ) |
dup 0< IF drop -1 ELSE 0> IF 1 ELSE 0 THEN THEN ; |
dup 0< IF drop -1 ELSE 0> 1 and THEN ; |
|
|
|
toupper c1 -- c2 gforth |
|
c2 = toupper(c1); |
|
: |
|
dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
|
|
capscomp c_addr1 u c_addr2 -- n new |
capscomp c_addr1 u c_addr2 -- n new |
n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */ |
n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */ |
Line 429 else if (n>0)
|
Line 503 else if (n>0)
|
n = 1; |
n = 1; |
: |
: |
swap bounds |
swap bounds |
?DO dup c@ toupper I c@ toupper = WHILE 1+ LOOP drop 0 |
?DO dup c@ I c@ <> |
|
IF dup c@ toupper I c@ toupper = |
|
ELSE true THEN WHILE 1+ LOOP drop 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 |
Line 593 ud = ummul(u1,u2);
|
Line 669 ud = ummul(u1,u2);
|
#else |
#else |
ud = (UDCell)u1 * (UDCell)u2; |
ud = (UDCell)u1 * (UDCell)u2; |
#endif |
#endif |
|
: |
|
>r >r 0 0 r> r> [ 8 cells ] literal 0 |
|
DO |
|
over >r dup >r 0< and d2*+ drop |
|
r> 2* r> swap |
|
LOOP 2drop ; |
|
: d2*+ ( ud n -- ud+n c ) |
|
over U-HIGHBIT |
|
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 |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
Line 604 u3 = ud/u1;
|
Line 689 u3 = ud/u1;
|
u2 = ud%u1; |
u2 = ud%u1; |
#endif |
#endif |
: |
: |
dup IF 0 (um/mod) THEN nip ; |
0 swap [ 8 cells 1 + ] literal 0 |
: (um/mod) ( ud ud -- ud u ) |
?DO >r /modstep r> |
2dup >r >r dup 0< |
LOOP drop swap 1 rshift or swap ; |
IF 2drop 0 |
: /modstep ( ud c R: u -- ud-?u c R: u ) |
ELSE 2dup d+ (um/mod) 2* THEN |
over I' u< 0= or IF I' - 1 ELSE 0 THEN d2*+ ; |
-rot r> r> 2over 2over du< |
|
IF 2drop rot |
|
ELSE dnegate d+ rot 1+ THEN ; |
|
|
|
m+ d1 n -- d2 double m_plus |
m+ d1 n -- d2 double m_plus |
#ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LONG_LONG |
Line 804 NEXT_P0;
|
Line 886 NEXT_P0;
|
r> -- w core r_from |
r> -- w core r_from |
w = *rp++; |
w = *rp++; |
|
|
r@ -- w core r_fetch |
|
/* use r as alias */ |
|
/* make r@ an alias for i */ |
|
w = *rp; |
|
|
|
rdrop -- gforth |
rdrop -- gforth |
rp++; |
rp++; |
|
: |
i' -- w gforth i_tick |
r> r> drop >r ; |
w=rp[1]; |
|
|
|
2>r w1 w2 -- core-ext two_to_r |
2>r w1 w2 -- core-ext two_to_r |
*--rp = w1; |
*--rp = w1; |
*--rp = w2; |
*--rp = w2; |
|
: |
|
swap r> swap >r swap >r >r ; |
|
|
2r> -- w1 w2 core-ext two_r_from |
2r> -- w1 w2 core-ext two_r_from |
w2 = *rp++; |
w2 = *rp++; |
w1 = *rp++; |
w1 = *rp++; |
|
: |
|
r> r> swap r> swap >r swap ; |
|
|
2r@ -- w1 w2 core-ext two_r_fetch |
2r@ -- w1 w2 core-ext two_r_fetch |
w2 = rp[0]; |
w2 = rp[0]; |
w1 = rp[1]; |
w1 = rp[1]; |
|
: |
|
i' j ; |
|
|
2rdrop -- gforth two_r_drop |
2rdrop -- gforth two_r_drop |
rp+=2; |
rp+=2; |
|
: |
|
r> r> drop r> drop >r ; |
|
|
over w1 w2 -- w1 w2 w1 core |
over w1 w2 -- w1 w2 w1 core |
|
: |
|
sp@ cell+ @ ; |
|
|
drop w -- core |
drop w -- core |
|
: |
|
IF THEN ; |
|
|
swap w1 w2 -- w2 w1 core |
swap w1 w2 -- w2 w1 core |
|
: |
|
>r (swap) ! r> (swap) @ ; |
|
Variable (swap) |
|
|
dup w -- w w core |
dup w -- w w core |
|
: |
|
sp@ @ ; |
|
|
rot w1 w2 w3 -- w2 w3 w1 core rote |
rot w1 w2 w3 -- w2 w3 w1 core rote |
|
: |
|
(swap) ! (rot) ! >r (rot) @ (swap) @ r> ; |
|
Variable (rot) |
|
|
-rot w1 w2 w3 -- w3 w1 w2 gforth not_rote |
-rot w1 w2 w3 -- w3 w1 w2 gforth not_rote |
: |
: |
Line 846 rot w1 w2 w3 -- w2 w3 w1 core rote
|
Line 942 rot w1 w2 w3 -- w2 w3 w1 core rote
|
|
|
nip w1 w2 -- w2 core-ext |
nip w1 w2 -- w2 core-ext |
: |
: |
swap drop ; |
>r drop r> ; |
|
|
tuck w1 w2 -- w2 w1 w2 core-ext |
tuck w1 w2 -- w2 w1 w2 core-ext |
: |
: |
Line 881 w = sp[u+1];
|
Line 977 w = sp[u+1];
|
|
|
2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap |
2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap |
: |
: |
>r -rot r> -rot ; |
rot >r rot r> ; |
|
|
2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double-ext two_rote |
2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double-ext two_rote |
: |
: |
Line 905 w = *a_addr;
|
Line 1001 w = *a_addr;
|
|
|
+! n a_addr -- core plus_store |
+! n a_addr -- core plus_store |
*a_addr += n; |
*a_addr += n; |
|
: |
|
tuck @ + swap ! ; |
|
|
c@ c_addr -- c core cfetch |
c@ c_addr -- c core cfetch |
c = *c_addr; |
c = *c_addr; |
Line 955 c_addr2 = c_addr1+1;
|
Line 1053 c_addr2 = c_addr1+1;
|
: |
: |
dup 1+ swap c@ ; |
dup 1+ swap c@ ; |
|
|
(bye) n -- gforth paren_bye |
|
return (Label *)n; |
|
|
|
(system) c_addr u -- wretval wior gforth peren_system |
|
int old_tp=terminal_prepped; |
|
deprep_terminal(); |
|
wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ |
|
wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); |
|
if (old_tp) |
|
prep_terminal(); |
|
|
|
getenv c_addr1 u1 -- c_addr2 u2 gforth |
|
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
|
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
|
open-pipe c_addr u ntype -- wfileid wior gforth open_pipe |
|
wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */ |
|
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
|
|
|
close-pipe wfileid -- wretval wior gforth close_pipe |
|
wretval = pclose((FILE *)wfileid); |
|
wior = IOR(wretval==-1); |
|
|
|
time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
|
struct timeval time1; |
|
struct timezone zone1; |
|
struct tm *ltime; |
|
gettimeofday(&time1,&zone1); |
|
ltime=localtime((time_t *)&time1.tv_sec); |
|
nyear =ltime->tm_year+1900; |
|
nmonth=ltime->tm_mon+1; |
|
nday =ltime->tm_mday; |
|
nhour =ltime->tm_hour; |
|
nmin =ltime->tm_min; |
|
nsec =ltime->tm_sec; |
|
|
|
ms n -- facility-ext |
|
struct timeval timeout; |
|
timeout.tv_sec=n/1000; |
|
timeout.tv_usec=1000*(n%1000); |
|
(void)select(0,0,0,0,&timeout); |
|
|
|
allocate u -- a_addr wior memory |
|
a_addr = (Cell *)malloc(u?u:1); |
|
wior = IOR(a_addr==NULL); |
|
|
|
free a_addr -- wior memory |
|
free(a_addr); |
|
wior = 0; |
|
|
|
resize a_addr1 u -- a_addr2 wior memory |
|
""Change the size of the allocated area at @i{a_addr1} to @i{u} |
|
address units, possibly moving the contents to a different |
|
area. @i{a_addr2} is the address of the resulting area. If |
|
@code{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 |
|
on SunOS 4.1.2. */ |
|
if (a_addr1==NULL) |
|
a_addr2 = (Cell *)malloc(u); |
|
else |
|
a_addr2 = (Cell *)realloc(a_addr1, u); |
|
wior = IOR(a_addr2==NULL); /* !! Define a return code */ |
|
|
|
(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 = f83name1->next) |
if (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; |
f83name2=f83name1; |
f83name2=f83name1; |
Line 1040 while(a_addr != NULL)
|
Line 1074 while(a_addr != NULL)
|
{ |
{ |
f83name1=(F83Name *)(a_addr[1]); |
f83name1=(F83Name *)(a_addr[1]); |
a_addr=(Cell *)(a_addr[0]); |
a_addr=(Cell *)(a_addr[0]); |
if (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? */) |
{ |
{ |
f83name2=f83name1; |
f83name2=f83name1; |
Line 1063 while(a_addr != NULL)
|
Line 1097 while(a_addr != NULL)
|
{ |
{ |
f83name1=(F83Name *)(a_addr[1]); |
f83name1=(F83Name *)(a_addr[1]); |
a_addr=(Cell *)(a_addr[0]); |
a_addr=(Cell *)(a_addr[0]); |
if (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? */) |
{ |
{ |
f83name2=f83name1; |
f83name2=f83name1; |
Line 1132 else {
|
Line 1166 else {
|
BEGIN dup WHILE over c@ bl > WHILE 1 /string |
BEGIN dup WHILE over c@ bl > WHILE 1 /string |
REPEAT THEN nip - ; |
REPEAT THEN nip - ; |
|
|
|
aligned c_addr -- a_addr core |
|
a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); |
|
: |
|
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
|
|
|
faligned c_addr -- f_addr float f_aligned |
|
f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); |
|
: |
|
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
|
|
|
>body xt -- a_addr core to_body |
|
a_addr = PFA(xt); |
|
: |
|
2 cells + ; |
|
|
|
>code-address xt -- c_addr gforth to_code_address |
|
""c_addr is the code address of the word xt"" |
|
/* !! This behaves installation-dependently for DOES-words */ |
|
c_addr = CODE_ADDRESS(xt); |
|
: |
|
@ ; |
|
|
|
>does-code xt -- a_addr gforth to_does_code |
|
""If xt ist the execution token of a defining-word-defined word, |
|
a_addr is the start of the Forth code after the DOES>; |
|
Otherwise a_addr is 0."" |
|
a_addr = (Cell *)DOES_CODE(xt); |
|
: |
|
cell+ @ ; |
|
|
|
code-address! c_addr xt -- gforth code_address_store |
|
""Creates a code field with code address c_addr at xt"" |
|
MAKE_CF(xt, c_addr); |
|
CACHE_FLUSH(xt,PFA(0)); |
|
: |
|
! ; |
|
|
|
does-code! a_addr xt -- gforth does_code_store |
|
""creates a code field at xt for a defining-word-defined word; a_addr |
|
is the start of the Forth code after DOES>"" |
|
MAKE_DOES_CF(xt, a_addr); |
|
CACHE_FLUSH(xt,PFA(0)); |
|
: |
|
dodoes: over ! cell+ ! ; |
|
|
|
does-handler! a_addr -- gforth does_handler_store |
|
""creates a DOES>-handler at address a_addr. a_addr usually points |
|
just behind a DOES>."" |
|
MAKE_DOES_HANDLER(a_addr); |
|
CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE); |
|
: |
|
drop ; |
|
|
|
/does-handler -- n gforth slash_does_handler |
|
""the size of a does-handler (includes possible padding)"" |
|
/* !! a constant or environmental query might be better */ |
|
n = DOES_HANDLER_SIZE; |
|
: |
|
2 cells ; |
|
|
|
threading-method -- n gforth threading_method |
|
""0 if the engine is direct threaded."" |
|
#if defined(DIRECT_THREADED) |
|
n=0; |
|
#else |
|
n=1; |
|
#endif |
|
: |
|
1 ; |
|
|
|
\+has-os [IF] |
|
|
|
flush-icache c_addr u -- gforth flush_icache |
|
""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 |
|
afterwards. @code{END-CODE} performs a @code{flush-icache} |
|
automatically. Caveat: @code{flush-icache} might not work on your |
|
installation; this is usually the case if direct threading is not |
|
supported on your machine (take a look at your @file{machine.h}) and |
|
your machine has a separate instruction cache. In such cases, |
|
@code{flush-icache} does nothing instead of flushing the instruction |
|
cache."" |
|
FLUSH_ICACHE(c_addr,u); |
|
|
|
(bye) n -- gforth paren_bye |
|
return (Label *)n; |
|
|
|
(system) c_addr u -- wretval wior gforth peren_system |
|
int old_tp=terminal_prepped; |
|
deprep_terminal(); |
|
wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ |
|
wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); |
|
if (old_tp) |
|
prep_terminal(); |
|
|
|
getenv c_addr1 u1 -- c_addr2 u2 gforth |
|
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
|
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
|
open-pipe c_addr u ntype -- wfileid wior gforth open_pipe |
|
wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */ |
|
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
|
|
|
close-pipe wfileid -- wretval wior gforth close_pipe |
|
wretval = pclose((FILE *)wfileid); |
|
wior = IOR(wretval==-1); |
|
|
|
time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
|
struct timeval time1; |
|
struct timezone zone1; |
|
struct tm *ltime; |
|
gettimeofday(&time1,&zone1); |
|
ltime=localtime((time_t *)&time1.tv_sec); |
|
nyear =ltime->tm_year+1900; |
|
nmonth=ltime->tm_mon+1; |
|
nday =ltime->tm_mday; |
|
nhour =ltime->tm_hour; |
|
nmin =ltime->tm_min; |
|
nsec =ltime->tm_sec; |
|
|
|
ms n -- facility-ext |
|
struct timeval timeout; |
|
timeout.tv_sec=n/1000; |
|
timeout.tv_usec=1000*(n%1000); |
|
(void)select(0,0,0,0,&timeout); |
|
|
|
allocate u -- a_addr wior memory |
|
a_addr = (Cell *)malloc(u?u:1); |
|
wior = IOR(a_addr==NULL); |
|
|
|
free a_addr -- wior memory |
|
free(a_addr); |
|
wior = 0; |
|
|
|
resize a_addr1 u -- a_addr2 wior memory |
|
""Change the size of the allocated area at @i{a_addr1} to @i{u} |
|
address units, possibly moving the contents to a different |
|
area. @i{a_addr2} is the address of the resulting area. If |
|
@code{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 |
|
on SunOS 4.1.2. */ |
|
if (a_addr1==NULL) |
|
a_addr2 = (Cell *)malloc(u); |
|
else |
|
a_addr2 = (Cell *)realloc(a_addr1, u); |
|
wior = IOR(a_addr2==NULL); /* !! Define a return code */ |
|
|
|
strerror n -- c_addr u gforth |
|
c_addr = strerror(n); |
|
u = strlen(c_addr); |
|
|
|
strsignal n -- c_addr u gforth |
|
c_addr = strsignal(n); |
|
u = strlen(c_addr); |
|
|
|
call-c w -- gforth call_c |
|
""Call the C function pointed to by @i{w}. The C function has to |
|
access the stack itself. The stack pointers are exported in the global |
|
variables @code{SP} and @code{FP}."" |
|
/* This is a first attempt at support for calls to C. This may change in |
|
the future */ |
|
IF_FTOS(fp[0]=FTOS); |
|
FP=fp; |
|
SP=sp; |
|
((void (*)())w)(); |
|
sp=SP; |
|
fp=FP; |
|
IF_TOS(TOS=sp[0]); |
|
IF_FTOS(FTOS=fp[0]); |
|
|
|
\+[THEN] ( has-os ) has-files [IF] |
|
|
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); |
|
|
Line 1213 else {
|
Line 1420 else {
|
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 */ |
{ |
{ |
Cell 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); |
Line 1257 wfileid = (Cell)stdout;
|
Line 1464 wfileid = (Cell)stdout;
|
stderr -- wfileid gforth |
stderr -- wfileid gforth |
wfileid = (Cell)stderr; |
wfileid = (Cell)stderr; |
|
|
|
\+[THEN] ( has-files ) has-floats [IF] |
|
|
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 1526 n2 = n1*sizeof(SFloat);
|
Line 1735 n2 = n1*sizeof(SFloat);
|
dfloats n1 -- n2 float-ext d_floats |
dfloats n1 -- n2 float-ext d_floats |
n2 = n1*sizeof(DFloat); |
n2 = n1*sizeof(DFloat); |
|
|
aligned c_addr -- a_addr core |
|
a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); |
|
: |
|
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
|
|
|
faligned c_addr -- f_addr float f_aligned |
|
f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); |
|
: |
|
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
|
|
|
sfaligned c_addr -- sf_addr float-ext s_f_aligned |
sfaligned c_addr -- sf_addr float-ext s_f_aligned |
sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); |
sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); |
: |
: |
Line 1551 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
Line 1750 df_addr = (DFloat *)((((Cell)c_addr)+(si
|
\ !! how about environmental queries DIRECT-THREADED, |
\ !! how about environmental queries DIRECT-THREADED, |
\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ |
\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ |
|
|
>body xt -- a_addr core to_body |
|
a_addr = PFA(xt); |
|
|
|
>code-address xt -- c_addr gforth to_code_address |
|
""c_addr is the code address of the word xt"" |
|
/* !! This behaves installation-dependently for DOES-words */ |
|
c_addr = CODE_ADDRESS(xt); |
|
|
|
>does-code xt -- a_addr gforth to_does_code |
|
""If xt ist the execution token of a defining-word-defined word, |
|
a_addr is the start of the Forth code after the DOES>; |
|
Otherwise a_addr is 0."" |
|
a_addr = (Cell *)DOES_CODE(xt); |
|
|
|
code-address! c_addr xt -- gforth code_address_store |
|
""Creates a code field with code address c_addr at xt"" |
|
MAKE_CF(xt, c_addr); |
|
CACHE_FLUSH(xt,PFA(0)); |
|
|
|
does-code! a_addr xt -- gforth does_code_store |
|
""creates a code field at xt for a defining-word-defined word; a_addr |
|
is the start of the Forth code after DOES>"" |
|
MAKE_DOES_CF(xt, a_addr); |
|
CACHE_FLUSH(xt,PFA(0)); |
|
|
|
does-handler! a_addr -- gforth does_handler_store |
|
""creates a DOES>-handler at address a_addr. a_addr usually points |
|
just behind a DOES>."" |
|
MAKE_DOES_HANDLER(a_addr); |
|
CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE); |
|
|
|
/does-handler -- n gforth slash_does_handler |
|
""the size of a does-handler (includes possible padding)"" |
|
/* !! a constant or environmental query might be better */ |
|
n = DOES_HANDLER_SIZE; |
|
|
|
threading-method -- n gforth threading_method |
|
""0 if the engine is direct threaded."" |
|
#if defined(DIRECT_THREADED) |
|
n=0; |
|
#else |
|
n=1; |
|
#endif |
|
|
|
flush-icache c_addr u -- gforth flush_icache |
|
""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 |
|
afterwards. @code{END-CODE} performs a @code{flush-icache} |
|
automatically. Caveat: @code{flush-icache} might not work on your |
|
installation; this is usually the case if direct threading is not |
|
supported on your machine (take a look at your @file{machine.h}) and |
|
your machine has a separate instruction cache. In such cases, |
|
@code{flush-icache} does nothing instead of flushing the instruction |
|
cache."" |
|
FLUSH_ICACHE(c_addr,u); |
|
|
|
toupper c1 -- c2 gforth |
|
c2 = toupper(c1); |
|
|
|
\ local variable implementation primitives |
\ local variable implementation primitives |
|
\+[THEN] ( has-floats ) has-locals [IF] |
|
|
@local# -- w gforth fetch_local_number |
@local# -- w gforth fetch_local_number |
w = *(Cell *)(lp+(Cell)NEXT_INST); |
w = *(Cell *)(lp+(Cell)NEXT_INST); |
INC_IP(1); |
INC_IP(1); |
Line 1627 w = *(Cell *)(lp+2*sizeof(Cell));
|
Line 1769 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] |
|
|
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); |
INC_IP(1); |
INC_IP(1); |
Line 1637 r = *(Float *)(lp+0*sizeof(Float));
|
Line 1781 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@ */ |
c_addr = (Char *)(lp+(Cell)NEXT_INST); |
c_addr = (Char *)(lp+(Cell)NEXT_INST); |
Line 1665 lp = (Address)c_addr;
|
Line 1811 lp = (Address)c_addr;
|
lp -= sizeof(Cell); |
lp -= sizeof(Cell); |
*(Cell *)lp = w; |
*(Cell *)lp = w; |
|
|
|
\+has-floats [IF] |
|
|
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 |
|
|
up! a_addr -- gforth up_store |
up! a_addr -- gforth up_store |
up0=up=(char *)a_addr; |
up0=up=(char *)a_addr; |
|
: |
call-c w -- gforth call_c |
up ! ; |
""Call the C function pointed to by @i{w}. The C function has to |
|
access the stack itself. The stack pointers are exported in the gloabl |
|
variables @code{SP} and @code{FP}."" |
|
/* This is a first attempt at support for calls to C. This may change in |
|
the future */ |
|
IF_FTOS(fp[0]=FTOS); |
|
FP=fp; |
|
SP=sp; |
|
((void (*)())w)(); |
|
sp=SP; |
|
fp=FP; |
|
IF_TOS(TOS=sp[0]); |
|
IF_FTOS(FTOS=fp[0]); |
|
|
|
strerror n -- c_addr u gforth |
|
c_addr = strerror(n); |
|
u = strlen(c_addr); |
|
|
|
strsignal n -- c_addr u gforth |
|
c_addr = strsignal(n); |
|
u = strlen(c_addr); |
|