version 1.204, 2006/12/31 13:39:13
|
version 1.211, 2007/04/01 21:30:26
|
Line 209 goto *next_code;
|
Line 209 goto *next_code;
|
a_retaddr = next_code; |
a_retaddr = next_code; |
a_body = PFA(CFA); |
a_body = PFA(CFA); |
INST_TAIL; |
INST_TAIL; |
|
#ifdef DEBUG |
|
fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); |
|
#endif |
goto **(Label *)DOES_CODE1(CFA); |
goto **(Label *)DOES_CODE1(CFA); |
#else /* !defined(NO_IP) */ |
#else /* !defined(NO_IP) */ |
a_retaddr = (Cell *)IP; |
a_retaddr = (Cell *)IP; |
a_body = PFA(CFA); |
a_body = PFA(CFA); |
|
#ifdef DEBUG |
|
fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); |
|
#endif |
SET_IP(DOES_CODE1(CFA)); |
SET_IP(DOES_CODE1(CFA)); |
#endif /* !defined(NO_IP) */ |
#endif /* !defined(NO_IP) */ |
|
|
Line 248 SET_IP((Xt *)a_callee);
|
Line 254 SET_IP((Xt *)a_callee);
|
|
|
execute ( xt -- ) core |
execute ( xt -- ) core |
""Perform the semantics represented by the execution token, @i{xt}."" |
""Perform the semantics represented by the execution token, @i{xt}."" |
|
#ifdef DEBUG |
|
fprintf(stderr, "execute %08x\n", xt); |
|
#endif |
#ifndef NO_IP |
#ifndef NO_IP |
ip=IP; |
ip=IP; |
#endif |
#endif |
Line 748 n = n1+n2;
|
Line 757 n = n1+n2;
|
\ lit+ / lit_plus = lit + |
\ lit+ / lit_plus = lit + |
|
|
lit+ ( n1 #n2 -- n ) new lit_plus |
lit+ ( n1 #n2 -- n ) new lit_plus |
|
#ifdef DEBUG |
|
fprintf(stderr, "lit+ %08x\n", n2); |
|
#endif |
n=n1+n2; |
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 |
Line 851 DCell d = (DCell)n1 * (DCell)n2;
|
Line 863 DCell d = (DCell)n1 * (DCell)n2;
|
#endif |
#endif |
#ifdef ASM_SM_SLASH_REM |
#ifdef ASM_SM_SLASH_REM |
ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5); |
ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5); |
if (((DHI(d)^n3)<0) && n4!=0) { |
if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) { |
if (CHECK_DIVISION && n5 == CELL_MIN) |
if (CHECK_DIVISION && n5 == CELL_MIN) |
throw(BALL_RESULTRANGE); |
throw(BALL_RESULTRANGE); |
n5--; |
n5--; |
n4+=n3; |
n4+=n3; |
} |
} |
#else |
#else |
DCell r = fmdiv(d,n3); |
DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); |
n4=DHI(r); |
n4=DHI(r); |
n5=DLO(r); |
n5=DLO(r); |
#endif |
#endif |
Line 875 DCell d = (DCell)n1 * (DCell)n2;
|
Line 887 DCell d = (DCell)n1 * (DCell)n2;
|
#ifdef ASM_SM_SLASH_REM |
#ifdef ASM_SM_SLASH_REM |
Cell remainder; |
Cell remainder; |
ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4); |
ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4); |
if (((DHI(d)^n3)<0) && remainder!=0) { |
if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) { |
if (CHECK_DIVISION && n4 == CELL_MIN) |
if (CHECK_DIVISION && n4 == CELL_MIN) |
throw(BALL_RESULTRANGE); |
throw(BALL_RESULTRANGE); |
n4--; |
n4--; |
} |
} |
#else |
#else |
DCell r = fmdiv(d,n3); |
DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); |
n4=DLO(r); |
n4=DLO(r); |
#endif |
#endif |
: |
: |
Line 1028 d2 = -d1;
|
Line 1040 d2 = -d1;
|
|
|
d2* ( d1 -- d2 ) double d_two_star |
d2* ( d1 -- d2 ) double d_two_star |
""Shift left by 1; also works on unsigned numbers"" |
""Shift left by 1; also works on unsigned numbers"" |
#ifdef BUGGY_LL_SHIFT |
d2 = DLSHIFT(d1,1); |
DLO_IS(d2, DLO(d1)<<1); |
|
DHI_IS(d2, (DHI(d1)<<1) | (DLO(d1)>>(CELL_BITS-1))); |
|
#else |
|
d2 = 2*d1; |
|
#endif |
|
: |
: |
2dup d+ ; |
2dup d+ ; |
|
|
Line 1492 for (; f83name1 != NULL; f83name1 = (str
|
Line 1499 for (; f83name1 != NULL; f83name1 = (str
|
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
break; |
break; |
f83name2=f83name1; |
f83name2=f83name1; |
|
#ifdef DEBUG |
|
fprintf(stderr, "F83find "); |
|
fwrite(c_addr, u, 1, stderr); |
|
fprintf(stderr, " found %08x\n", f83name2); |
|
#endif |
: |
: |
BEGIN dup WHILE (find-samelen) dup WHILE |
BEGIN dup WHILE (find-samelen) dup WHILE |
>r 2dup r@ cell+ char+ capscomp 0= |
>r 2dup r@ cell+ char+ capscomp 0= |
Line 1647 f = key_query((FILE*)wfileid);
|
Line 1659 f = key_query((FILE*)wfileid);
|
f = key_query(stdin); |
f = key_query(stdin); |
#endif |
#endif |
|
|
\+os |
|
|
|
stdin ( -- wfileid ) gforth |
stdin ( -- wfileid ) gforth |
""The standard input file of the Gforth process."" |
""The standard input file of the Gforth process."" |
wfileid = (Cell)stdin; |
wfileid = (Cell)stdin; |
Line 1661 stderr ( -- wfileid ) gforth
|
Line 1671 stderr ( -- wfileid ) gforth
|
""The standard error output file of the Gforth process."" |
""The standard error output file of the Gforth process."" |
wfileid = (Cell)stderr; |
wfileid = (Cell)stderr; |
|
|
|
\+os |
|
|
form ( -- urows ucols ) gforth |
form ( -- urows ucols ) gforth |
""The number of lines and columns in the terminal. These numbers may change |
""The number of lines and columns in the terminal. These numbers may |
with the window size."" |
change with the window size. Note that it depends on the OS whether |
|
this reflects the actual size and changes with the window size |
|
(currently only on Unix-like OSs). On other OSs you just get a |
|
default, and can tell Gforth the terminal size by setting the |
|
environment variables @code{COLUMNS} and @code{LINES} before starting |
|
Gforth."" |
/* we could block SIGWINCH here to get a consistent size, but I don't |
/* we could block SIGWINCH here to get a consistent size, but I don't |
think this is necessary or always beneficial */ |
think this is necessary or always beneficial */ |
urows=rows; |
urows=rows; |
Line 2766 define(`uploop',
|
Line 2783 define(`uploop',
|
define(`_uploop', |
define(`_uploop', |
`ifelse($1, `$3', `$5', |
`ifelse($1, `$3', `$5', |
`$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')') |
`$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')') |
|
|
\ argflist(argnum): Forth argument list |
\ argflist(argnum): Forth argument list |
define(argflist, |
define(argflist, |
`ifelse($1, 0, `', |
`ifelse($1, 0, `', |
`uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')') |
`uploop(`_i', 1, $1, ``u''`_i ', ``u''`_i')')') |
\ argdlist(argnum): declare C's arguments |
\ argdlist(argnum): declare C's arguments |
define(argdlist, |
define(argdlist, |
`ifelse($1, 0, `', |
`ifelse($1, 0, `', |
Line 2777 define(argdlist,
|
Line 2795 define(argdlist,
|
\ argclist(argnum): pass C's arguments |
\ argclist(argnum): pass C's arguments |
define(argclist, |
define(argclist, |
`ifelse($1, 0, `', |
`ifelse($1, 0, `', |
`uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')') |
`uploop(`_i', 1, $1, ``u''`_i, ', ``u''`_i')')') |
\ icall(argnum) |
\ icall(argnum) |
define(icall, |
define(icall, |
`icall$1 ( argflist($1)u -- uret ) gforth |
`icall$1 ( argflist($1) u -- uret ) gforth |
uret = (SYSCALL(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 = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); |
rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); |
|
|
') |
') |