Powered by ViewCVS 1.0-dev
added answords.fs and strsignal.c added checking of documenetation of ANS Forth words Fixed many documentation errors and added some documentation signal handling now uses strsignal and can handle signals not present on all machines
\ Copyright 1992 by the ANSI figForth Development Group
\
\ WARNING: This file is processed by m4. Make sure your identifiers
\ don't collide with m4's (e.g. by undefining them).
\
\
\
\ This file contains instructions in the following format:
\
\ forth name stack effect category [pronunciation]
\ [""glossary entry""]
\ C code
\ [:
\ Forth code]
\
\ The pronunciation is also used for forming C names.
\
\
\
\ These informations are automatically translated into C-code for the
\ interpreter and into some other files. I hope that your C compiler has
\ decent optimization, otherwise the automatically generated code will
\ be somewhat slow. The Forth version of the code is included for manual
\ compilers, so they will need to compile only the important words.
\
\ Note that stack pointer adjustment is performed according to stack
\ effect by automatically generated code and NEXT is automatically
\ appended to the C code. Also, you can use the names in the stack
\ effect in the C code. Stack access is automatic. One exception: if
\ your code does not fall through, the results are not stored into the
\ stack. Use different names on both sides of the '--', if you change a
\ value (some stores to the stack are optimized away).
\
\
\
\ The stack variables have the following types:
\
\ name matches type
\ f.* Bool
\ c.* Char
\ [nw].* Cell
\ u.* UCell
\ d.* DCell
\ ud.* UDCell
\ r.* Float
\ a_.* Cell *
\ c_.* Char *
\ f_.* Float *
\ df_.* DFloat *
\ sf_.* SFloat *
\ xt.* XT
\ wid.* WID
\ f83name.* F83Name *
\
\
\
\ In addition the following names can be used:
\ ip the instruction pointer
\ sp the data stack pointer
\ rp the parameter stack pointer
\ lp the locals stack pointer
\ NEXT executes NEXT
\ cfa
\ NEXT1 executes NEXT1
\ FLAG(x) makes a Forth flag from a C flag
\
\
\
\ Percentages in comments are from Koopmans book: average/maximum use
\ (taken from four, not very representative benchmarks)
\
\
\
\ To do:
\
\ throw execute, cfa and NEXT1 out?
\ macroize *ip, ip++, *ip++ (pipelining)?
\ these m4 macros would collide with identifiers
undefine(`index')
undefine(`shift')
noop -- gforth
;
:
;
lit -- w gforth
w = (Cell)NEXT_INST;
INC_IP(1);
execute xt -- core
ip=IP;
cfa = xt;
IF_TOS(TOS = sp[0]);
NEXT1;
branch-lp+!# -- gforth branch_lp_plus_store_number
/* this will probably not be used */
branch_adjust_lp:
lp += (Cell)(IP[1]);
goto branch;
branch -- gforth
branch:
ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
NEXT_P0;
:
r> dup @ + >r ;
\ condbranch(forthname,restline,code)
\ this is non-syntactical: code must open a brace that is closed by the macro
define(condbranch,
$1 $2
$3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
NEXT_P0;
NEXT;
}
else
INC_IP(1);
$1-lp+!# $2_lp_plus_store_number
$3 goto branch_adjust_lp;
}
else
INC_IP(2);
)
condbranch(?branch,f -- f83 question_branch,
if (f==0) {
IF_TOS(TOS = sp[0]);
)
condbranch((next),-- cmFORTH paren_next,
if ((*rp)--) {
)
condbranch((loop),-- gforth paren_loop,
Cell index = *rp+1;
Cell limit = rp[1];
if (index != limit) {
*rp = index;
)
condbranch((+loop),n -- gforth paren_plus_loop,
/* !! check this thoroughly */
Cell index = *rp;
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
/* dependent upon two's complement arithmetic */
Cell olddiff = index-rp[1];
#ifndef undefined
if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
|| (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
*rp += n;
#else
*rp = index + n;
#endif
IF_TOS(TOS = sp[0]);
)
condbranch((-loop),u -- gforth paren_minus_loop,
/* !! check this thoroughly */
Cell index = *rp;
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
/* dependent upon two's complement arithmetic */
UCell olddiff = index-rp[1];
if (olddiff>u) {
*rp = index - u;
IF_TOS(TOS = sp[0]);
)
condbranch((s+loop),n -- gforth paren_symmetric_plus_loop,
""The run-time procedure compiled by S+LOOP. It loops until the index
crosses the boundary between limit and limit-sign(n). I.e. a symmetric
version of (+LOOP).""
/* !! check this thoroughly */
Cell index = *rp;
Cell diff = index-rp[1];
Cell newdiff = diff+n;
if (n<0) {
diff = -diff;
newdiff = -newdiff;
}
if (diff>=0 || newdiff<0) {
#ifdef i386
*rp += n;
#else
*rp = index + n;
#endif
IF_TOS(TOS = sp[0]);
)
unloop -- core
rp += 2;
:
r> rdrop rdrop >r ;
(for) ncount -- cmFORTH paren_for
/* or (for) = >r -- collides with unloop! */
*--rp = 0;
*--rp = ncount;
:
r> swap 0 >r >r >r ;
(do) nlimit nstart -- gforth paren_do
/* or do it in high-level? 0.09/0.23% */
*--rp = nlimit;
*--rp = nstart;
:
r> -rot swap >r >r >r ;
(?do) nlimit nstart -- gforth paren_question_do
*--rp = nlimit;
*--rp = nstart;
if (nstart == nlimit) {
IF_TOS(TOS = sp[0]);
goto branch;
}
else {
INC_IP(1);
}
(+do) nlimit nstart -- gforth paren_plus_do
*--rp = nlimit;
*--rp = nstart;
if (nstart >= nlimit) {
IF_TOS(TOS = sp[0]);
goto branch;
}
else {
INC_IP(1);
}
(u+do) ulimit ustart -- gforth paren_u_plus_do
*--rp = ulimit;
*--rp = ustart;
if (ustart >= ulimit) {
IF_TOS(TOS = sp[0]);
goto branch;
}
else {
INC_IP(1);
}
(-do) nlimit nstart -- gforth paren_minus_do
*--rp = nlimit;
*--rp = nstart;
if (nstart <= nlimit) {
IF_TOS(TOS = sp[0]);
goto branch;
}
else {
INC_IP(1);
}
(u-do) ulimit ustart -- gforth paren_u_minus_do
*--rp = ulimit;
*--rp = ustart;
if (ustart <= ulimit) {
IF_TOS(TOS = sp[0]);
goto branch;
}
else {
INC_IP(1);
}
i -- n core
n = *rp;
j -- n core
n = rp[2];
\ digit is high-level: 0/0%
(emit) c -- gforth paren_emit
putchar(c);
emitcounter++;
(type) c_addr n -- gforth paren_type
fwrite(c_addr,sizeof(Char),n,stdout);
emitcounter += n;
(key) -- n gforth paren_key
fflush(stdout);
/* !! noecho */
n = key();
key? -- n facility key_q
fflush(stdout);
n = key_query;
cr -- core
puts("");
:
$0A emit ;
move c_from c_to ucount -- core
memmove(c_to,c_from,ucount);
/* make an Ifdef for bsd and others? */
:
>r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
cmove c_from c_to u -- string
while (u-- > 0)
*c_to++ = *c_from++;
:
bounds ?DO dup c@ I c! 1+ LOOP drop ;
cmove> c_from c_to u -- string c_move_up
while (u-- > 0)
c_to[u] = c_from[u];
:
dup 0= IF drop 2drop exit THEN
rot over + -rot bounds swap 1-
DO 1- dup c@ I c! -1 +LOOP drop ;
fill c_addr u c -- core
memset(c_addr,c,u);
:
-rot bounds
?DO dup I c! LOOP drop ;
compare c_addr1 u1 c_addr2 u2 -- n string
""Compare the 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
is 1. Currently this is based on the machine's character
comparison. In the future, this may change to considering the current
locale and its collation order.""
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
if (n==0)
n = u1-u2;
if (n<0)
n = -1;
else if (n>0)
n = 1;
:
rot 2dup - >r min swap -text dup
IF rdrop
ELSE drop r@ 0>
IF rdrop -1
ELSE r> 1 and
THEN
THEN ;
-text c_addr1 u c_addr2 -- n new dash_text
n = memcmp(c_addr1, c_addr2, u);
if (n<0)
n = -1;
else if (n>0)
n = 1;
:
swap bounds
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
ELSE c@ I c@ - unloop THEN -text-flag ;
: -text-flag ( n -- -1/0/1 )
dup 0< IF drop -1 ELSE 0> IF 1 ELSE 0 THEN THEN ;
capscomp c_addr1 u c_addr2 -- n new
Char c1, c2;
for (;; u--, c_addr1++, c_addr2++) {
if (u == 0) {
n = 0;
break;
}
c1 = toupper(*c_addr1);
c2 = toupper(*c_addr2);
if (c1 != c2) {
if (c1 < c2)
n = -1;
else
n = 1;
break;
}
}
:
swap bounds
?DO dup c@ toupper I c@ toupper = WHILE 1+ LOOP drop 0
ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ;
-trailing c_addr u1 -- c_addr u2 string dash_trailing
u2 = u1;
while (c_addr[u2-1] == ' ')
u2--;
:
BEGIN 1- 2dup + c@ bl = WHILE
dup 0= UNTIL ELSE 1+ THEN ;
/string c_addr1 u1 n -- c_addr2 u2 string slash_string
c_addr2 = c_addr1+n;
u2 = u1-n;
:
tuck - >r + r> dup 0< IF - 0 THEN ;
+ n1 n2 -- n core plus
n = n1+n2;
- n1 n2 -- n core minus
n = n1-n2;
:
negate + ;
negate n1 -- n2 core
/* use minus as alias */
n2 = -n1;
:
invert 1+ ;
1+ n1 -- n2 core one_plus
n2 = n1+1;
:
1 + ;
1- n1 -- n2 core one_minus
n2 = n1-1;
:
1 - ;
max n1 n2 -- n core
if (n1<n2)
n = n2;
else
n = n1;
:
2dup < IF swap THEN drop ;
min n1 n2 -- n core
if (n1<n2)
n = n1;
else
n = n2;
:
2dup > IF swap THEN drop ;
abs n1 -- n2 core
if (n1<0)
n2 = -n1;
else
n2 = n1;
:
dup 0< IF negate THEN ;
* n1 n2 -- n core star
n = n1*n2;
:
um* drop ;
/ n1 n2 -- n core slash
n = n1/n2;
:
/mod nip ;
mod n1 n2 -- n core
n = n1%n2;
:
/mod drop ;
/mod n1 n2 -- n3 n4 core slash_mod
n4 = n1/n2;
n3 = n1%n2; /* !! is this correct? look into C standard! */
:
>r s>d r> fm/mod ;
2* n1 -- n2 core two_star
n2 = 2*n1;
:
dup + ;
2/ n1 -- n2 core two_slash
/* !! is this still correct? */
n2 = n1>>1;
fm/mod d1 n1 -- n2 n3 core f_m_slash_mod
""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
/* assumes that the processor uses either floored or symmetric division */
n3 = d1/n1;
n2 = d1%n1;
/* note that this 1%-3>0 is optimized by the compiler */
if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
n3--;
n2+=n1;
}
sm/rem d1 n1 -- n2 n3 core s_m_slash_rem
""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
/* assumes that the processor uses either floored or symmetric division */
n3 = d1/n1;
n2 = d1%n1;
/* note that this 1%-3<0 is optimized by the compiler */
if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
n3++;
n2-=n1;
}
:
over >r dup >r abs -rot
dabs rot um/mod
r> 0< IF negate THEN
r> 0< IF swap negate swap THEN ;
m* n1 n2 -- d core m_star
d = (DCell)n1 * (DCell)n2;
:
2dup 0< and >r
2dup swap 0< and >r
um* r> - r> - ;
um* u1 u2 -- ud core u_m_star
/* use u* as alias */
ud = (UDCell)u1 * (UDCell)u2;
um/mod ud u1 -- u2 u3 core u_m_slash_mod
u3 = ud/u1;
u2 = ud%u1;
:
dup IF 0 (um/mod) THEN nip ;
: (um/mod) ( ud ud--ud u)
2dup >r >r dup 0<
IF 2drop 0
ELSE 2dup d+ (um/mod) 2* THEN
-rot r> r> 2over 2over du<
IF 2drop rot
ELSE dnegate d+ rot 1+ THEN ;
m+ d1 n -- d2 double m_plus
d2 = d1+n;
:
s>d d+ ;
d+ d1 d2 -- d double d_plus
d = d1+d2;
:
>r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
r> + >r + r> 0< r> r> + swap - ;
d- d1 d2 -- d double d_minus
d = d1-d2;
:
dnegate d+ ;
dnegate d1 -- d2 double
/* use dminus as alias */
d2 = -d1;
:
invert swap negate tuck 0= - ;
dmax d1 d2 -- d double
if (d1<d2)
d = d2;
else
d = d1;
:
2over 2over d> IF 2swap THEN 2drop ;
dmin d1 d2 -- d double
if (d1<d2)
d = d1;
else
d = d2;
:
2over 2over d< IF 2swap THEN 2drop ;
dabs d1 -- d2 double
if (d1<0)
d2 = -d1;
else
d2 = d1;
:
dup 0< IF dnegate THEN ;
d2* d1 -- d2 double d_two_star
d2 = 2*d1;
:
2dup d+ ;
d2/ d1 -- d2 double d_two_slash
/* !! is this still correct? */
d2 = d1>>1;
:
dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ;
d>s d -- n double d_to_s
/* make this an alias for drop? */
n = d;
:
drop ;
and w1 w2 -- w core
w = w1&w2;
or w1 w2 -- w core
w = w1|w2;
xor w1 w2 -- w core
w = w1^w2;
invert w1 -- w2 core
w2 = ~w1;
:
-1 xor ;
rshift u1 n -- u2 core
u2 = u1>>n;
lshift u1 n -- u2 core
u2 = u1<<n;
\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
define(comparisons,
$1= $2 -- f $6 $3equals
f = FLAG($4==$5);
$1<> $2 -- f $7 $3different
/* use != as alias ? */
f = FLAG($4!=$5);
$1< $2 -- f $8 $3less
f = FLAG($4<$5);
$1> $2 -- f $9 $3greater
f = FLAG($4>$5);
$1<= $2 -- f gforth $3less_or_equal
f = FLAG($4<=$5);
$1>= $2 -- f gforth $3greater_or_equal
f = FLAG($4>=$5);
)
comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
comparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
comparisons(d0, d, d_zero_, d, 0, double, gforth, double, gforth)
comparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
within u1 u2 u3 -- f core-ext
f = FLAG(u1-u2 < u3-u2);
:
over - >r - r> u< ;
sp@ -- a_addr gforth spat
a_addr = sp+1;
sp! a_addr -- gforth spstore
sp = a_addr;
/* works with and without TOS caching */
rp@ -- a_addr gforth rpat
a_addr = rp;
rp! a_addr -- gforth rpstore
rp = a_addr;
fp@ -- f_addr gforth fp_fetch
f_addr = fp;
fp! f_addr -- gforth fp_store
fp = f_addr;
;s -- gforth semis
ip = (Xt *)(*rp++);
NEXT_P0;
>r w -- core to_r
*--rp = w;
r> -- w core r_from
w = *rp++;
r@ -- w core r_fetch
/* use r as alias */
/* make r@ an alias for i */
w = *rp;
rdrop -- gforth
rp++;
i' -- w gforth i_tick
w=rp[1];
2>r w1 w2 -- core-ext two_to_r
*--rp = w1;
*--rp = w2;
2r> -- w1 w2 core-ext two_r_from
w2 = *rp++;
w1 = *rp++;
2r@ -- w1 w2 core-ext two_r_fetch
w2 = rp[0];
w1 = rp[1];
2rdrop -- gforth two_r_drop
rp+=2;
over w1 w2 -- w1 w2 w1 core
drop w -- core
swap w1 w2 -- w2 w1 core
dup w -- w w core
rot w1 w2 w3 -- w2 w3 w1 core rote
-rot w1 w2 w3 -- w3 w1 w2 gforth not_rote
:
rot rot ;
nip w1 w2 -- w2 core-ext
:
swap drop ;
tuck w1 w2 -- w2 w1 w2 core-ext
:
swap over ;
?dup w -- w core question_dupe
if (w!=0) {
IF_TOS(*sp-- = w;)
#ifndef USE_TOS
*--sp = w;
#endif
}
:
dup IF dup THEN ;
pick u -- w core-ext
w = sp[u+1];
:
1+ cells sp@ + @ ;
2drop w1 w2 -- core two_drop
:
drop drop ;
2dup w1 w2 -- w1 w2 w1 w2 core two_dupe
:
over over ;
2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over
:
3 pick 3 pick ;
2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap
:
>r -rot r> -rot ;
2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double-ext two_rote
:
>r >r 2swap r> r> 2swap ;
2nip w1 w2 w3 w4 -- w3 w4 gforth two_nip
:
2swap 2drop ;
2tuck w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 gforth two_tuck
:
2swap 2over ;
\ toggle is high-level: 0.11/0.42%
@ a_addr -- w core fetch
w = *a_addr;
! w a_addr -- core store
*a_addr = w;
+! n a_addr -- core plus_store
*a_addr += n;
c@ c_addr -- c core cfetch
c = *c_addr;
c! c c_addr -- core cstore
*c_addr = c;
2! w1 w2 a_addr -- core two_store
a_addr[0] = w2;
a_addr[1] = w1;
:
tuck ! cell+ ! ;
2@ a_addr -- w1 w2 core two_fetch
w2 = a_addr[0];
w1 = a_addr[1];
:
dup cell+ @ swap @ ;
d! d a_addr -- double d_store
/* !! alignment problems on some machines */
*(DCell *)a_addr = d;
d@ a_addr -- d double d_fetch
d = *(DCell *)a_addr;
cell+ a_addr1 -- a_addr2 core cell_plus
a_addr2 = a_addr1+1;
:
[ cell ] Literal + ;
cells n1 -- n2 core
n2 = n1 * sizeof(Cell);
:
[ cell ]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ drop ] ;
char+ c_addr1 -- c_addr2 core care_plus
c_addr2 = c_addr1 + 1;
:
1+ ;
(chars) n1 -- n2 gforth paren_cares
n2 = n1 * sizeof(Char);
:
;
count c_addr1 -- c_addr2 u core
u = *c_addr1;
c_addr2 = c_addr1+1;
:
dup 1+ swap c@ ;
(bye) n -- gforth paren_bye
return (Label *)n;
system c_addr u -- n gforth
n=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
getenv c_addr1 u1 -- c_addr2 u2 gforth
c_addr2 = getenv(cstr(c_addr1,u1,1));
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
popen c_addr u n -- wfileid own
static char* mode[2]={"r","w"}; /* !! should we use FAM here? */
wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]); /* ~ expansion of 1st arg? */
pclose wfileid -- wior own
wior=pclose((FILE *)wfileid); /* !! what to do with the result */
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);
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_addr2} 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
for (; f83name1 != NULL; f83name1 = f83name1->next)
if (F83NAME_COUNT(f83name1)==u &&
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;
f83name2=f83name1;
:
BEGIN dup WHILE
>r dup r@ cell+ c@ $1F and =
IF 2dup r@ cell+ char+ capscomp 0=
IF 2drop r> EXIT THEN THEN
r> @
REPEAT nip nip ;
(hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
F83Name *f83name1;
f83name2=NULL;
while(a_addr != NULL)
{
f83name1=(F83Name *)(a_addr[1]);
a_addr=(Cell *)(a_addr[0]);
if (F83NAME_COUNT(f83name1)==u &&
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
{
f83name2=f83name1;
break;
}
}
:
BEGIN dup WHILE
2@ >r >r dup r@ cell+ c@ $1F and =
IF 2dup r@ cell+ char+ capscomp 0=
IF 2drop r> rdrop EXIT THEN THEN
rdrop r>
REPEAT nip nip ;
(hashkey) c_addr u1 -- u2 gforth paren_hashkey
u2=0;
while(u1--)
u2+=(Cell)toupper(*c_addr++);
:
0 -rot bounds ?DO I c@ toupper + LOOP ;
(hashkey1) c_addr u ubits -- ukey gforth paren_hashkey1
""ukey is the hash key for the string c_addr u fitting in ubits bits""
/* this hash function rotates the key at every step by rot bits within
ubits bits and xors it with the character. This function does ok in
the chi-sqare-test. Rot should be <=7 (preferably <=5) for
ASCII strings (larger if ubits is large), and should share no
divisors with ubits.
*/
unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits];
Char *cp = c_addr;
for (ukey=0; cp<c_addr+u; cp++)
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
^ toupper(*cp))
& ((1<<ubits)-1));
:
dup rot-values + c@ over 1 swap lshift 1- >r
tuck - 2swap r> 0 2swap bounds
?DO dup 4 pick lshift swap 3 pick rshift or
I c@ toupper xor
over and LOOP
nip nip nip ;
Create rot-values
5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c,
3 c, 5 c, 5 c, 5 c, 5 c, 7 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,
(parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white
/* use !isgraph instead of isspace? */
Char *endp = c_addr1+u1;
while (c_addr1<endp && isspace(*c_addr1))
c_addr1++;
if (c_addr1<endp) {
for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
;
u2 = c_addr1-c_addr2;
}
else {
c_addr2 = c_addr1;
u2 = 0;
}
:
BEGIN dup WHILE over c@ bl <= WHILE 1 /string
REPEAT THEN 2dup
BEGIN dup WHILE over c@ bl > WHILE 1 /string
REPEAT THEN nip - ;
close-file wfileid -- wior file close_file
wior = IOR(fclose((FILE *)wfileid)==EOF);
open-file c_addr u ntype -- w2 wior file open_file
w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
wior = IOR(w2 == 0);
create-file c_addr u ntype -- w2 wior file create_file
Cell fd;
fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
if (fd != -1) {
w2 = (Cell)fdopen(fd, fileattr[ntype]);
wior = IOR(w2 == 0);
} else {
w2 = 0;
wior = IOR(1);
}
delete-file c_addr u -- wior file delete_file
wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
char *s1=tilde_cstr(c_addr2, u2, 1);
wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
file-position wfileid -- ud wior file file_position
/* !! use tell and lseek? */
ud = ftell((FILE *)wfileid);
wior = IOR(ud==-1);
reposition-file ud wfileid -- wior file reposition_file
wior = IOR(fseek((FILE *)wfileid, (long)ud, SEEK_SET)==-1);
file-size wfileid -- ud wior file file_size
struct stat buf;
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
ud = buf.st_size;
resize-file ud wfileid -- wior file resize_file
wior = IOR(ftruncate(fileno((FILE *)wfileid), (Cell)ud)==-1);
read-file c_addr u1 wfileid -- u2 wior file read_file
/* !! fread does not guarantee enough */
u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
/* !! is the value of ferror errno-compatible? */
if (wior)
clearerr((FILE *)wfileid);
read-line c_addr u1 wfileid -- u2 flag wior file read_line
/*
Cell c;
flag=-1;
for(u2=0; u2<u1; u2++)
{
*c_addr++ = (Char)(c = getc((FILE *)wfileid));
if(c=='\n') break;
if(c==EOF)
{
flag=FLAG(u2!=0);
break;
}
}
wior=FILEIO(ferror((FILE *)wfileid));
*/
if ((flag=FLAG(!feof((FILE *)wfileid) &&
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */
if (wior)
clearerr((FILE *)wfileid);
u2 = strlen(c_addr);
u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
}
else {
wior=0;
u2=0;
}
write-file c_addr u1 wfileid -- wior file write_file
/* !! fwrite does not guarantee enough */
{
Cell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
if (wior)
clearerr((FILE *)wfileid);
}
flush-file wfileid -- wior file-ext flush_file
wior = IOR(fflush((FILE *) wfileid)==EOF);
file-status c_addr u -- ntype wior file-ext file_status
char *filename=tilde_cstr(c_addr, u, 1);
if (access (filename, F_OK) != 0) {
ntype=0;
wior=IOR(1);
}
else if (access (filename, R_OK | W_OK) == 0) {
ntype=2; /* r/w */
wior=0;
}
else if (access (filename, R_OK) == 0) {
ntype=0; /* r/o */
wior=0;
}
else if (access (filename, W_OK) == 0) {
ntype=4; /* w/o */
wior=0;
}
else {
ntype=1; /* well, we cannot access the file, but better deliver a legal
access mode (r/o bin), so we get a decent error later upon open. */
wior=0;
}
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
d>f d -- r float d_to_f
r = d;
f>d r -- d float f_to_d
/* !! basis 15 is not very specific */
d = r;
f! r f_addr -- float f_store
*f_addr = r;
f@ f_addr -- r float f_fetch
r = *f_addr;
df@ df_addr -- r float-ext d_f_fetch
#ifdef IEEE_FP
r = *df_addr;
#else
!! df@
#endif
df! r df_addr -- float-ext d_f_store
#ifdef IEEE_FP
*df_addr = r;
#else
!! df!
#endif
sf@ sf_addr -- r float-ext s_f_fetch
#ifdef IEEE_FP
r = *sf_addr;
#else
!! sf@
#endif
sf! r sf_addr -- float-ext s_f_store
#ifdef IEEE_FP
*sf_addr = r;
#else
!! sf!
#endif
f+ r1 r2 -- r3 float f_plus
r3 = r1+r2;
f- r1 r2 -- r3 float f_minus
r3 = r1-r2;
f* r1 r2 -- r3 float f_star
r3 = r1*r2;
f/ r1 r2 -- r3 float f_slash
r3 = r1/r2;
f** r1 r2 -- r3 float-ext f_star_star
""@i{r3} is @i{r1} raised to the @i{r2}th power""
r3 = pow(r1,r2);
fnegate r1 -- r2 float
r2 = - r1;
fdrop r -- float
fdup r -- r r float
fswap r1 r2 -- r2 r1 float
fover r1 r2 -- r1 r2 r1 float
frot r1 r2 r3 -- r2 r3 r1 float
fnip r1 r2 -- r2 gforth
ftuck r1 r2 -- r2 r1 r2 gforth
float+ f_addr1 -- f_addr2 float float_plus
f_addr2 = f_addr1+1;
floats n1 -- n2 float
n2 = n1*sizeof(Float);
floor r1 -- r2 float
""round towards the next smaller integral value, i.e., round toward negative infinity""
/* !! unclear wording */
r2 = floor(r1);
fround r1 -- r2 float
""round to the nearest integral value""
/* !! unclear wording */
#ifdef HAVE_RINT
r2 = rint(r1);
#else
r2 = floor(r1+0.5);
/* !! This is not quite true to the rounding rules given in the standard */
#endif
fmax r1 r2 -- r3 float
if (r1<r2)
r3 = r2;
else
r3 = r1;
fmin r1 r2 -- r3 float
if (r1<r2)
r3 = r1;
else
r3 = r2;
represent r c_addr u -- n f1 f2 float
char *sig;
Cell flag;
Cell decpt;
sig=ecvt(r, u, (int *)&decpt, (int *)&flag);
n=(r==0 ? 1 : decpt);
f1=FLAG(flag!=0);
f2=FLAG(isdigit(sig[0])!=0);
memmove(c_addr,sig,u);
>float c_addr u -- flag float to_float
/* real signature: c_addr u -- r t / f */
Float r;
char *number=cstr(c_addr, u, 1);
char *endconv;
while(isspace(number[--u]) && u>0);
switch(number[u])
{
case 'd':
case 'D':
case 'e':
case 'E': break;
default : u++; break;
}
number[u]='\0';
r=strtod(number,&endconv);
if((flag=FLAG(!(Cell)*endconv)))
{
IF_FTOS(fp[0] = FTOS);
fp += -1;
FTOS = r;
}
else if(*endconv=='d' || *endconv=='D')
{
*endconv='E';
r=strtod(number,&endconv);
if((flag=FLAG(!(Cell)*endconv)))
{
IF_FTOS(fp[0] = FTOS);
fp += -1;
FTOS = r;
}
}
fabs r1 -- r2 float-ext
r2 = fabs(r1);
facos r1 -- r2 float-ext
r2 = acos(r1);
fasin r1 -- r2 float-ext
r2 = asin(r1);
fatan r1 -- r2 float-ext
r2 = atan(r1);
fatan2 r1 r2 -- r3 float-ext
""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably
intends this to be the inverse of @code{fsincos}. In gforth it is.""
r3 = atan2(r1,r2);
fcos r1 -- r2 float-ext
r2 = cos(r1);
fexp r1 -- r2 float-ext
r2 = exp(r1);
fexpm1 r1 -- r2 float-ext
""@i{r2}=@i{e}**@i{r1}@minus{}1""
#ifdef HAVE_EXPM1
extern double expm1(double);
r2 = expm1(r1);
#else
r2 = exp(r1)-1.;
#endif
fln r1 -- r2 float-ext
r2 = log(r1);
flnp1 r1 -- r2 float-ext
""@i{r2}=ln(@i{r1}+1)""
#ifdef HAVE_LOG1P
extern double log1p(double);
r2 = log1p(r1);
#else
r2 = log(r1+1.);
#endif
flog r1 -- r2 float-ext
""the decimal logarithm""
r2 = log10(r1);
falog r1 -- r2 float-ext
""@i{r2}=10**@i{r1}""
extern double pow10(double);
r2 = pow10(r1);
fsin r1 -- r2 float-ext
r2 = sin(r1);
fsincos r1 -- r2 r3 float-ext
""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
r2 = sin(r1);
r3 = cos(r1);
fsqrt r1 -- r2 float-ext
r2 = sqrt(r1);
ftan r1 -- r2 float-ext
r2 = tan(r1);
:
fsincos f/ ;
fsinh r1 -- r2 float-ext
r2 = sinh(r1);
:
fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
fcosh r1 -- r2 float-ext
r2 = cosh(r1);
:
fexp fdup 1/f f+ f2/ ;
ftanh r1 -- r2 float-ext
r2 = tanh(r1);
:
f2* fexpm1 fdup 2. d>f f+ f/ ;
fasinh r1 -- r2 float-ext
r2 = asinh(r1);
:
fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
facosh r1 -- r2 float-ext
r2 = acosh(r1);
:
fdup fdup f* 1. d>f f- fsqrt f+ fln ;
fatanh r1 -- r2 float-ext
r2 = atanh(r1);
:
fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/
r> IF fnegate THEN ;
sfloats n1 -- n2 float-ext s_floats
n2 = n1*sizeof(SFloat);
dfloats n1 -- n2 float-ext d_floats
n2 = n1*sizeof(DFloat);
aligned c_addr -- a_addr core
a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&~sizeof(Cell));
faligned c_addr -- f_addr float f_aligned
f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&~sizeof(Float));
sfaligned c_addr -- sf_addr float-ext s_f_aligned
sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&~sizeof(SFloat));
dfaligned c_addr -- df_addr float-ext d_f_aligned
df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&~sizeof(DFloat));
\ The following words access machine/OS/installation-dependent ANSI
\ figForth internals
\ !! how about environmental queries DIRECT-THREADED,
\ 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 the
behaviour is undefined""
/* !! there is currently no way to determine whether a word is
defining-word-defined */
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;
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# -- w gforth fetch_local_number
w = *(Cell *)(lp+(Cell)NEXT_INST);
INC_IP(1);
@local0 -- w new fetch_local_zero
w = *(Cell *)(lp+0*sizeof(Cell));
@local1 -- w new fetch_local_four
w = *(Cell *)(lp+1*sizeof(Cell));
@local2 -- w new fetch_local_eight
w = *(Cell *)(lp+2*sizeof(Cell));
@local3 -- w new fetch_local_twelve
w = *(Cell *)(lp+3*sizeof(Cell));
f@local# -- r gforth f_fetch_local_number
r = *(Float *)(lp+(Cell)NEXT_INST);
INC_IP(1);
f@local0 -- r new f_fetch_local_zero
r = *(Float *)(lp+0*sizeof(Float));
f@local1 -- r new f_fetch_local_eight
r = *(Float *)(lp+1*sizeof(Float));
laddr# -- c_addr gforth laddr_number
/* this can also be used to implement lp@ */
c_addr = (Char *)(lp+(Cell)NEXT_INST);
INC_IP(1);
lp+!# -- gforth lp_plus_store_number
""used with negative immediate values it allocates memory on the
local stack, a positive immediate argument drops memory from the local
stack""
lp += (Cell)NEXT_INST;
INC_IP(1);
lp- -- new minus_four_lp_plus_store
lp += -sizeof(Cell);
lp+ -- new eight_lp_plus_store
lp += sizeof(Float);
lp+2 -- new sixteen_lp_plus_store
lp += 2*sizeof(Float);
lp! c_addr -- gforth lp_store
lp = (Address)c_addr;
>l w -- gforth to_l
lp -= sizeof(Cell);
*(Cell *)lp = w;
f>l r -- gforth f_to_l
lp -= sizeof(Float);
*(Float *)lp = r;
up! a_addr -- gforth up_store
up0=up=(char *)a_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 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);
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |