version 1.82, 2001/05/01 13:35:42
|
version 1.87, 2001/12/25 16:55:10
|
Line 132 undefine(`index')
|
Line 132 undefine(`index')
|
undefine(`shift') |
undefine(`shift') |
undefine(`symbols') |
undefine(`symbols') |
|
|
|
\g control |
|
|
noop ( -- ) gforth |
noop ( -- ) gforth |
: |
: |
; |
; |
Line 179 $1 ( `#'ndisp $2 ) $3
|
Line 181 $1 ( `#'ndisp $2 ) $3
|
$4 SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
$4 SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
$5 |
$5 |
|
|
\+glocals |
\+glocals |
Line 188 $4 lp += nlocals;
|
Line 191 $4 lp += nlocals;
|
SET_IP((Xt *)(((Cell)(IP-2))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-2))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
|
|
\+ |
\+ |
) |
) |
Line 214 if (f==0) {
|
Line 218 if (f==0) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
|
|
?dup-0=-?branch ( #ndisp f -- ) new question_dupe_zero_equals_question_branch |
?dup-0=-?branch ( #ndisp f -- ) new question_dupe_zero_equals_question_branch |
""The run-time procedure compiled by @code{?DUP-0=-IF}."" |
""The run-time procedure compiled by @code{?DUP-0=-IF}."" |
Line 226 if (f!=0) {
|
Line 231 if (f!=0) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
NEXT; |
NEXT; |
} |
} |
|
SUPER_CONTINUE; |
|
|
\+ |
\+ |
\f[THEN] |
\f[THEN] |
Line 307 if (nstart == nlimit) {
|
Line 313 if (nstart == nlimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
2dup = |
2dup = |
IF r> swap rot >r >r |
IF r> swap rot >r >r |
Line 322 if (nstart >= nlimit) {
|
Line 329 if (nstart >= nlimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 337 if (ustart >= ulimit) {
|
Line 345 if (ustart >= ulimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 352 if (nstart <= nlimit) {
|
Line 361 if (nstart <= nlimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 367 if (ustart <= ulimit) {
|
Line 377 if (ustart <= ulimit) {
|
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); |
TAIL; |
TAIL; |
} |
} |
|
SUPER_CONTINUE; |
: |
: |
swap 2dup |
swap 2dup |
r> swap >r swap >r |
r> swap >r swap >r |
Line 409 k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
|
Line 420 k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
|
|
|
\ digit is high-level: 0/0% |
\ digit is high-level: 0/0% |
|
|
|
\g strings |
|
|
move ( c_from c_to ucount -- ) core |
move ( c_from c_to ucount -- ) core |
""Copy the contents of @i{ucount} aus at @i{c-from} to |
""Copy the contents of @i{ucount} aus at @i{c-from} to |
@i{c-to}. @code{move} works correctly even if the two areas overlap."" |
@i{c-to}. @code{move} works correctly even if the two areas overlap."" |
Line 518 u2 = u1-n;
|
Line 531 u2 = u1-n;
|
: |
: |
tuck - >r + r> dup 0< IF - 0 THEN ; |
tuck - >r + r> dup 0< IF - 0 THEN ; |
|
|
|
\g arith |
|
|
+ ( n1 n2 -- n ) core plus |
+ ( n1 n2 -- n ) core plus |
n = n1+n2; |
n = n1+n2; |
|
|
Line 915 f = FLAG(u1-u2 < u3-u2);
|
Line 930 f = FLAG(u1-u2 < u3-u2);
|
: |
: |
over - >r - r> u< ; |
over - >r - r> u< ; |
|
|
|
\g internal |
|
|
sp@ ( -- a_addr ) gforth sp_fetch |
sp@ ( -- a_addr ) gforth sp_fetch |
a_addr = sp+1; |
a_addr = sp+1; |
|
|
Line 942 fp = f_addr;
|
Line 959 fp = f_addr;
|
""The primitive compiled by @code{EXIT}."" |
""The primitive compiled by @code{EXIT}."" |
SET_IP((Xt *)w); |
SET_IP((Xt *)w); |
|
|
|
\g stack |
|
|
>r ( w -- R:w ) core to_r |
>r ( w -- R:w ) core to_r |
: |
: |
(>r) ; |
(>r) ; |
Line 1381 n=1;
|
Line 1400 n=1;
|
|
|
\f[THEN] |
\f[THEN] |
|
|
|
\g hostos |
|
|
key-file ( wfileid -- n ) gforth paren_key_file |
key-file ( wfileid -- n ) gforth paren_key_file |
#ifdef HAS_FILE |
#ifdef HAS_FILE |
fflush(stdout); |
fflush(stdout); |
Line 1454 c_addr2 = getenv(cstr(c_addr1,u1,1));
|
Line 1475 c_addr2 = getenv(cstr(c_addr1,u1,1));
|
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe |
open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe |
wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */ |
wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ |
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
|
|
close-pipe ( wfileid -- wretval wior ) gforth close_pipe |
close-pipe ( wfileid -- wretval wior ) gforth close_pipe |
Line 1596 if (wior)
|
Line 1617 if (wior)
|
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
|
|
read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line |
read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line |
""this is only for backward compatibility"" |
/* this may one day be replaced with : read-line (read-line) nip ; */ |
Cell c; |
Cell c; |
flag=-1; |
flag=-1; |
for(u2=0; u2<u1; u2++) |
for(u2=0; u2<u1; u2++) |
Line 1672 else {
|
Line 1693 else {
|
\+ |
\+ |
\+floating |
\+floating |
|
|
|
\g 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 2353 while(a_addr != NULL)
|
Line 2376 while(a_addr != NULL)
|
|
|
\+peephole |
\+peephole |
|
|
|
\g peephole |
|
|
primtable ( -- wprimtable ) new |
primtable ( -- wprimtable ) new |
""wprimtable is a table containing the xts of the primitives indexed |
""wprimtable is a table containing the xts of the primitives indexed |
by sequence-number in prim (for use in prepare-peephole-table)."" |
by sequence-number in prim (for use in prepare-peephole-table)."" |
Line 2369 peephole-opt ( xt1 xt2 wpeeptable -- xt
|
Line 2394 peephole-opt ( xt1 xt2 wpeeptable -- xt
|
they cannot be combined, xt is 0."" |
they cannot be combined, xt is 0."" |
xt = peephole_opt(xt1, xt2, wpeeptable); |
xt = peephole_opt(xt1, xt2, wpeeptable); |
|
|
call ( #a_callee -- R:a_retaddr ) |
call ( #a_callee -- R:a_retaddr ) new |
""Call callee (a variant of docol with inline argument)."" |
""Call callee (a variant of docol with inline argument)."" |
a_retaddr = (Cell *)IP; |
a_retaddr = (Cell *)IP; |
SET_IP((Xt *)a_callee); |
SET_IP((Xt *)a_callee); |
|
|
useraddr ( #u -- a_addr ) |
useraddr ( #u -- a_addr ) new |
a_addr = (Cell *)(up+u); |
a_addr = (Cell *)(up+u); |
|
|
|
compile-prim ( xt1 -- xt2 ) new compile_prim |
|
xt2 = (Xt)compile_prim((Label)xt1); |
|
|
include(peeprules.vmg) |
include(peeprules.vmg) |
|
|
\+ |
\+ |