Powered by ViewCVS 1.0-dev
Reorganized configuration: configure is now created by autoconf from configure.in; I still left it in the CVS repository because not everyone has autoconf. decstation.h renamed to mips.h and apollo68k to m68k. Added general 32bit.h description, which the other machine descriptions use. Created/copied replacement files install-sh memcmp.c memmove.c select.c (carved out from ecvt.c) strtol.c strtoul.c. Bytesex is now handled by configure. Deciding the threading method is now done in machine.h, this should also be done for USE_TOS and USE_FTOS.
\ 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 -- fig
;
:
;
lit -- w fig
w = (Cell)*ip++;
execute xt -- core,fig
cfa = xt;
IF_TOS(TOS = sp[0]);
NEXT1;
branch-lp+!# -- new branch_lp_plus_store_number
/* this will probably not be used */
branch_adjust_lp:
lp += (int)(ip[1]);
goto branch;
branch -- fig
branch:
ip = (Xt *)(((int)ip)+(int)*ip);
:
r> dup @ + >r ;
\ condbranch(forthname,restline,code)
\ this is non-syntactical: code must open a brace that is close by the macro
define(condbranch,
$1 $2
$3 goto branch;
}
else
ip++;
$1-lp+!# $2_lp_plus_store_number
$3 goto branch_adjust_lp;
}
else
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),-- fig paren_loop,
int index = *rp+1;
int limit = rp[1];
if (index != limit) {
*rp = index;
)
condbranch((+loop),n -- fig paren_plus_loop,
/* !! check this thoroughly */
int index = *rp;
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
/* dependent upon two's complement arithmetic */
int olddiff = index-rp[1];
#ifdef 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 ((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((s+loop),n -- new 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 */
int index = *rp;
int diff = index-rp[1];
int 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 -- fig 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 -- core-ext paren_question_do
*--rp = nlimit;
*--rp = nstart;
if (nstart == nlimit) {
IF_TOS(TOS = sp[0]);
goto branch;
}
else {
ip++;
}
i -- n core,fig
n = *rp;
j -- n core
n = rp[2];
\ digit is high-level: 0/0%
(emit) c -- fig paren_emit
putchar(c);
emitcounter++;
(type) c_addr n -- fig paren_type
fwrite(c_addr,sizeof(Char),n,stdout);
emitcounter += n;
(key) -- n fig paren_key
fflush(stdout);
/* !! noecho */
n = key();
key? -- n fig key_q
fflush(stdout);
n = key_query;
cr -- fig
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,fig plus
n = n1+n2;
- n1 n2 -- n core,fig minus
n = n1-n2;
:
negate + ;
negate n1 -- n2 core,fig
/* 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,fig star
n = n1*n2;
:
um* drop ;
/ n1 n2 -- n core,fig 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,fig 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,fig
w = w1&w2;
or w1 w2 -- w core,fig
w = w1|w2;
xor w1 w2 -- w core,fig
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 new $3less_or_equal
f = FLAG($4<=$5);
$1>= $2 -- f new $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, new, new, core, core-ext)
comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)
comparisons(d0, d, d_zero_, d, 0, double, new, double, new)
comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)
within u1 u2 u3 -- f core-ext
f = FLAG(u1-u2 < u3-u2);
:
over - >r - r> u< ;
sp@ -- a_addr fig spat
a_addr = sp+1;
sp! a_addr -- fig spstore
sp = a_addr;
/* works with and without TOS caching */
rp@ -- a_addr fig rpat
a_addr = rp;
rp! a_addr -- fig rpstore
rp = a_addr;
fp@ -- f_addr new fp_fetch
f_addr = fp;
fp! f_addr -- new fp_store
fp = f_addr;
;s -- fig semis
ip = (Xt *)(*rp++);
>r w -- core,fig to_r
*--rp = w;
r> -- w core,fig r_from
w = *rp++;
r@ -- w core,fig r_fetch
/* use r as alias */
/* make r@ an alias for i */
w = *rp;
rdrop -- fig
rp++;
i' -- w fig 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 -- new two_r_drop
rp+=2;
over w1 w2 -- w1 w2 w1 core,fig
drop w -- core,fig
swap w1 w2 -- w2 w1 core,fig
dup w -- w w core,fig
rot w1 w2 w3 -- w2 w3 w1 core rote
-rot w1 w2 w3 -- w3 w1 w2 fig 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 two_rote
:
>r >r 2swap r> r> 2swap ;
\ toggle is high-level: 0.11/0.42%
@ a_addr -- w fig fetch
w = *a_addr;
! w a_addr -- core,fig store
*a_addr = w;
+! n a_addr -- core,fig plus_store
*a_addr += n;
c@ c_addr -- c fig cfetch
c = *c_addr;
c! c c_addr -- fig 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 -- toolkit-ext paren_bye
return (Label *)n;
system c_addr u -- n own
n=system(cstr(c_addr,u,1));
getenv c_addr1 u1 -- c_addr2 u2 new
c_addr2 = getenv(cstr(c_addr1,u1,1));
u2=strlen(c_addr2);
popen c_addr u n -- wfileid own
static char* mode[2]={"r","w"};
wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
pclose wfileid -- wior own
wior=pclose((FILE *)wfileid);
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(&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 = a_addr==NULL; /* !! Define a return code */
free a_addr -- wior memory
free(a_addr);
wior = 0;
resize a_addr1 u -- a_addr2 wior memory
a_addr2 = realloc(a_addr1, u);
wior = 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 new paren_hashkey
u2=0;
while(u1--)
u2+=(int)toupper(*c_addr++);
:
0 -rot bounds ?DO I c@ toupper + LOOP ;
(hashkey1) c_addr u ubits -- ukey new 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 new 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 = FILEIO(fclose((FILE *)wfileid)==EOF);
open-file c_addr u ntype -- w2 wior file open_file
w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
wior = FILEEXIST(w2 == NULL);
create-file c_addr u ntype -- w2 wior file create_file
int fd;
fd = creat(cstr(c_addr, u, 1), 0644);
if (fd > -1) {
w2 = (Cell)fdopen(fd, fileattr[ntype]);
assert(w2 != NULL);
wior = 0;
} else {
assert(fd == -1);
wior = FILEIO(fd);
w2 = 0;
}
delete-file c_addr u -- wior file delete_file
wior = FILEEXIST(unlink(cstr(c_addr, u, 1)));
rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
char *s1=cstr(c_addr2, u2, 1);
wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));
file-position wfileid -- ud wior file file_position
/* !! use tell and lseek? */
ud = ftell((FILE *)wfileid);
wior = 0; /* !! or wior = FLAG(ud<0) */
reposition-file ud wfileid -- wior file reposition_file
wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));
file-size wfileid -- ud wior file file_size
struct stat buf;
wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));
ud = buf.st_size;
resize-file ud wfileid -- wior file resize_file
wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));
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));
/* !! who performs 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));
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 */
{
int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
}
flush-file wfileid -- wior file-ext flush_file
wior = FILEIO(fflush((FILE *) wfileid));
comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
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
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
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
/* !! unclear wording */
r2 = floor(r1);
fround r1 -- r2 float
/* !! 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;
int flag;
int decpt;
sig=ecvt(r, u, &decpt, &flag);
n=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-1])) u--;
switch(number[u-1])
{
case 'd':
case 'D':
case 'e':
case 'E': u--; break;
default: break;
}
number[u]='\0';
r=strtod(number,&endconv);
if((flag=FLAG(!(int)*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(!(int)*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
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
r2 =
#ifdef HAS_EXPM1
expm1(r1);
#else
exp(r1)-1;
#endif
fln r1 -- r2 float-ext
r2 = log(r1);
flnp1 r1 -- r2 float-ext
r2 =
#ifdef HAS_LOG1P
log1p(r1);
#else
log(r1+1);
#endif
flog r1 -- r2 float-ext
r2 = log10(r1);
fsin r1 -- r2 float-ext
r2 = sin(r1);
fsincos r1 -- r2 r3 float-ext
r2 = sin(r1);
r3 = cos(r1);
fsqrt r1 -- r2 float-ext
r2 = sqrt(r1);
ftan r1 -- r2 float-ext
r2 = tan(r1);
\ 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 new 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 new 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 uundefined""
/* !! there is currently no way to determine whether a word is
defining-word-defined */
a_addr = (Cell *)DOES_CODE(xt);
code-address! n xt -- new code_address_store
""Creates a code field with code address c_addr at xt""
MAKE_CF(xt, symbols[CF(n)]);
CACHE_FLUSH(xt,PFA(0));
does-code! a_addr xt -- new 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 -- new does_jump_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 new slash_does_handler
""the size of a does-handler (includes possible padding)""
/* !! a constant or environmental query might be better */
n = DOES_HANDLER_SIZE;
toupper c1 -- c2 new
c2 = toupper(c1);
\ local variable implementation primitives
@local# -- w new fetch_local_number
w = *(Cell *)(lp+(int)(*ip++));
@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 new f_fetch_local_number
r = *(Float *)(lp+(int)(*ip++));
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 new laddr_number
/* this can also be used to implement lp@ */
c_addr = (Char *)(lp+(int)(*ip++));
lp+!# -- new 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 += (int)(*ip++);
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 -- new lp_store
lp = (Address)c_addr;
>l w -- new to_l
lp -= sizeof(Cell);
*(Cell *)lp = w;
f>l r -- new f_to_l
lp -= sizeof(Float);
*(Float *)lp = r;
up! a_addr -- new up_store
up0=up=(char *)a_addr;
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |