version 1.211, 2007/04/01 21:30:26
|
version 1.224, 2008/02/23 13:03:56
|
Line 1
|
Line 1
|
\ Gforth primitives |
\ Gforth primitives |
|
|
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
|
|
\ WARNING: This file is processed by m4. Make sure your identifiers |
\ WARNING: This file is processed by m4. Make sure your identifiers |
Line 109
|
Line 108
|
\E store-optimization on |
\E store-optimization on |
\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump |
\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump |
\E |
\E |
\E include-skipped-insts on \ static superinsts include cells for components |
\E `include-skipped-insts' on \ static superinsts include cells for components |
\E \ useful for dynamic programming and |
\E \ useful for dynamic programming and |
\E \ superinsts across entry points |
\E \ superinsts across entry points |
|
|
\ |
\ |
\ |
\ |
Line 203 INST_TAIL;
|
Line 202 INST_TAIL;
|
goto *next_code; |
goto *next_code; |
#endif /* defined(NO_IP) */ |
#endif /* defined(NO_IP) */ |
|
|
|
(dovalue) ( -- w ) gforth-internal paren_doval |
|
""run-time routine for constants"" |
|
w = *(Cell *)PFA(CFA); |
|
#ifdef NO_IP |
|
INST_TAIL; |
|
goto *next_code; |
|
#endif /* defined(NO_IP) */ |
|
|
(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes |
(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes |
""run-time routine for @code{does>}-defined words"" |
""run-time routine for @code{does>}-defined words"" |
#ifdef NO_IP |
#ifdef NO_IP |
Line 338 SET_IP((Xt *)a_target);
|
Line 345 SET_IP((Xt *)a_target);
|
|
|
\ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) |
\ condbranch(forthname,stackeffect,restline,code1,code2,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 |
\ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) |
|
\ this is non-syntactical: code must open a brace that is closed by the macro |
|
define(condbranch, |
define(condbranch, |
$1 ( `#'a_target $2 ) $3 |
$1 ( `#'a_target $2 ) $3 |
$4 #ifdef NO_IP |
$4 #ifdef NO_IP |
Line 349 $5 #ifdef NO_IP
|
Line 354 $5 #ifdef NO_IP
|
JUMP(a_target); |
JUMP(a_target); |
#else |
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
|
ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */') |
#endif |
#endif |
} |
} |
|
ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */') |
$6 |
$6 |
|
|
\+glocals |
\+glocals |
Line 364 $5 lp += nlocals;
|
Line 371 $5 lp += nlocals;
|
JUMP(a_target); |
JUMP(a_target); |
#else |
#else |
SET_IP((Xt *)a_target); |
SET_IP((Xt *)a_target); |
|
ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */') |
#endif |
#endif |
} |
} |
|
ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */') |
\+ |
|
) |
|
|
|
\ version that generates two jumps (not good for PR 15242 workaround) |
|
define(condbranch_twojump, |
|
$1 ( `#'a_target $2 ) $3 |
|
$4 #ifdef NO_IP |
|
INST_TAIL; |
|
#endif |
|
$5 #ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
|
} |
|
SUPER_CONTINUE; |
|
$6 |
|
|
|
\+glocals |
|
|
|
$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number |
|
$4 #ifdef NO_IP |
|
INST_TAIL; |
|
#endif |
|
$5 lp += nlocals; |
|
#ifdef NO_IP |
|
JUMP(a_target); |
|
#else |
|
SET_IP((Xt *)a_target); |
|
INST_TAIL; NEXT_P2; |
|
#endif |
|
} |
|
SUPER_CONTINUE; |
|
|
|
\+ |
\+ |
) |
) |
Line 635 i' ( R:w R:w2 -- R:w R:w2 w ) gforth i
|
Line 609 i' ( R:w R:w2 -- R:w R:w2 w ) gforth i
|
r> r> r> dup itmp ! >r >r >r itmp @ ; |
r> r> r> dup itmp ! >r >r >r itmp @ ; |
variable itmp |
variable itmp |
|
|
j ( R:n R:d1 -- n R:n R:d1 ) core |
j ( R:w R:w1 R:w2 -- w R:w R:w1 R:w2 ) core |
: |
: |
\ rp@ cell+ cell+ cell+ @ ; |
\ rp@ cell+ cell+ cell+ @ ; |
r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; |
r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; |
[IFUNDEF] itmp variable itmp [THEN] |
[IFUNDEF] itmp variable itmp [THEN] |
|
|
k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 ) gforth |
k ( R:w R:w1 R:w2 R:w3 R:w4 -- w R:w R:w1 R:w2 R:w3 R:w4 ) gforth |
: |
: |
\ rp@ [ 5 cells ] Literal + @ ; |
\ rp@ [ 5 cells ] Literal + @ ; |
r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; |
r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; |
Line 728 c2 = toupper(c1);
|
Line 702 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 - ; |
|
|
capscompare ( c_addr1 u1 c_addr2 u2 -- n ) string |
capscompare ( c_addr1 u1 c_addr2 u2 -- n ) gforth |
""Compare two strings lexicographically. If they are equal, @i{n} is 0; if |
""Compare two strings lexicographically. If they are equal, @i{n} is 0; if |
the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} |
the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} |
is 1. Currently this is based on the machine's character |
is 1. Currently this is based on the machine's character |
Line 1751 nhour =ltime->tm_hour;
|
Line 1725 nhour =ltime->tm_hour;
|
nmin =ltime->tm_min; |
nmin =ltime->tm_min; |
nsec =ltime->tm_sec; |
nsec =ltime->tm_sec; |
|
|
ms ( n -- ) facility-ext |
ms ( u -- ) facility-ext |
""Wait at least @i{n} milli-second."" |
""Wait at least @i{n} milli-second."" |
struct timeval timeout; |
gforth_ms(u); |
timeout.tv_sec=n/1000; |
|
timeout.tv_usec=1000*(n%1000); |
|
(void)select(0,0,0,0,&timeout); |
|
|
|
allocate ( u -- a_addr wior ) memory |
allocate ( u -- a_addr wior ) memory |
""Allocate @i{u} address units of contiguous data space. The initial |
""Allocate @i{u} address units of contiguous data space. The initial |
Line 1803 u = strlen((char *)c_addr);
|
Line 1774 u = strlen((char *)c_addr);
|
call-c ( ... w -- ... ) gforth call_c |
call-c ( ... w -- ... ) gforth call_c |
""Call the C function pointed to by @i{w}. The C function has to |
""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 |
access the stack itself. The stack pointers are exported in the global |
variables @code{SP} and @code{FP}."" |
variables @code{gforth_SP} and @code{gforth_FP}."" |
/* This is a first attempt at support for calls to C. This may change in |
/* This is a first attempt at support for calls to C. This may change in |
the future */ |
the future */ |
gforth_FP=fp; |
gforth_FP=fp; |
Line 1819 close-file ( wfileid -- wior ) file clo
|
Line 1790 close-file ( wfileid -- wior ) file clo
|
wior = IOR(fclose((FILE *)wfileid)==EOF); |
wior = IOR(fclose((FILE *)wfileid)==EOF); |
|
|
open-file ( c_addr u wfam -- wfileid wior ) file open_file |
open-file ( c_addr u wfam -- wfileid wior ) file open_file |
wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]); |
wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior); |
wior = IOR(wfileid == 0); |
|
|
|
create-file ( c_addr u wfam -- wfileid wior ) file create_file |
create-file ( c_addr u wfam -- wfileid wior ) file create_file |
Cell fd; |
wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior); |
fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666); |
|
if (fd != -1) { |
|
wfileid = (Cell)fdopen(fd, fileattr[wfam]); |
|
wior = IOR(wfileid == 0); |
|
} else { |
|
wfileid = 0; |
|
wior = IOR(1); |
|
} |
|
|
|
delete-file ( c_addr u -- wior ) file delete_file |
delete-file ( c_addr u -- wior ) file delete_file |
wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); |
wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); |
Line 2146 floor ( r1 -- r2 ) float
|
Line 2108 floor ( r1 -- r2 ) float
|
/* !! unclear wording */ |
/* !! unclear wording */ |
r2 = floor(r1); |
r2 = floor(r1); |
|
|
fround ( r1 -- r2 ) gforth f_round |
fround ( r1 -- r2 ) float f_round |
""Round to the nearest integral value."" |
""Round to the nearest integral value."" |
r2 = rint(r1); |
r2 = rint(r1); |
|
|
Line 2431 r = fp[u];
|
Line 2393 r = fp[u];
|
\g syslib |
\g syslib |
|
|
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 1 |
|
u2 = (UCell)lt_dlopen(cstr(c_addr1, u1, 1)); |
|
#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
#ifndef RTLD_GLOBAL |
#ifndef RTLD_GLOBAL |
#define RTLD_GLOBAL 0 |
#define RTLD_GLOBAL 0 |
#endif |
#endif |
Line 2446 u2 = 0;
|
Line 2410 u2 = 0;
|
#endif |
#endif |
|
|
lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym |
lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
#if 1 |
|
u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1)); |
|
#elif 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 _WIN32 |
# ifdef _WIN32 |
Line 2816 uploop(i, 0, 7, `fcall(i)')
|
Line 2782 uploop(i, 0, 7, `fcall(i)')
|
fcall(20) |
fcall(20) |
|
|
\+ |
\+ |
\+ |
|
|
|
|
lib-error ( -- c_addr u ) gforth lib_error |
|
c_addr = lt_dlerror(); |
|
u = (c_addr == NULL) ? 0 : strlen(c_addr); |
|
|
|
\+ |
\g peephole |
\g peephole |
|
|
\+peephole |
\+peephole |