--- gforth/prim 2010/08/31 20:10:59 1.255 +++ gforth/prim 2012/03/10 20:33:31 1.266 @@ -1,6 +1,6 @@ \ Gforth primitives -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -618,6 +618,18 @@ f_fp = fp; c_lp = lp; a_newhandler = rp-5; +(throw1) ( ... wball a_handler -- ... wball ) gforth paren_throw1 +rp = a_handler; +lp = (Address)rp[1]; +fp = (Float *)rp[2]; +sp = (Cell *)rp[3]; +#ifndef NO_IP +ip=IP; +#endif +SUPER_END; +VM_JUMP(EXEC1(*(Xt *)rp[4])); + + \+ \ don't make any assumptions where the return stack is!! @@ -1091,6 +1103,22 @@ lshift ( u1 n -- u2 ) core l_shift : 0 ?DO 2* LOOP ; +umax ( u1 u2 -- u ) core +if (u1 IF swap THEN drop ; + \g compare \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) @@ -1792,6 +1820,8 @@ if (a_addr1==NULL) else a_addr2 = (Cell *)realloc(a_addr1, u); wior = IOR(a_addr2==NULL); /* !! Define a return code */ +if (a_addr2==NULL) + a_addr2 = a_addr1; strerror ( n -- c_addr u ) gforth c_addr = (Char *)strerror(n); @@ -2019,6 +2049,19 @@ duser = timeval2us(&time1); dsystem = DZERO; #endif +ntime ( -- dtime ) gforth +""Report the current time in nanoseconds since some epoch."" +struct timespec time1; +#ifdef HAVE_CLOCK_GETTIME +clock_gettime(CLOCK_REALTIME,&time1); +#else +struct timeval time2; +gettimeofday(&time2,NULL); +time1.tv_sec = time2.tv_sec;1 +time1.tv_nsec = time2.tv_usec*1000; +#endif +dtime = timespec2ns(&time1); + \+ \+floating @@ -2110,7 +2153,9 @@ r3 = r1/r2; f** ( r1 r2 -- r3 ) float-ext f_star_star ""@i{r3} is @i{r1} raised to the @i{r2}th power."" +CLOBBER_TOS_WORKAROUND_START; r3 = pow(r1,r2); +CLOBBER_TOS_WORKAROUND_END; fm* ( r1 n -- r2 ) gforth fm_star r2 = r1*n; @@ -2152,7 +2197,9 @@ n2 = n1*sizeof(Float); floor ( r1 -- r2 ) float ""Round towards the next smaller integral value, i.e., round toward negative infinity."" /* !! unclear wording */ +CLOBBER_TOS_WORKAROUND_START; r2 = floor(r1); +CLOBBER_TOS_WORKAROUND_END; fround ( r1 -- r2 ) float f_round ""Round to the nearest integral value."" @@ -2207,10 +2254,14 @@ fabs ( r1 -- r2 ) float-ext f_abs r2 = fabs(r1); facos ( r1 -- r2 ) float-ext f_a_cos +CLOBBER_TOS_WORKAROUND_START; r2 = acos(r1); +CLOBBER_TOS_WORKAROUND_END; fasin ( r1 -- r2 ) float-ext f_a_sine +CLOBBER_TOS_WORKAROUND_START; r2 = asin(r1); +CLOBBER_TOS_WORKAROUND_END; fatan ( r1 -- r2 ) float-ext f_a_tan r2 = atan(r1); @@ -2218,13 +2269,19 @@ r2 = atan(r1); fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably intends this to be the inverse of @code{fsincos}. In gforth it is."" +CLOBBER_TOS_WORKAROUND_START; r3 = atan2(r1,r2); +CLOBBER_TOS_WORKAROUND_END; fcos ( r1 -- r2 ) float-ext f_cos +CLOBBER_TOS_WORKAROUND_START; r2 = cos(r1); +CLOBBER_TOS_WORKAROUND_END; fexp ( r1 -- r2 ) float-ext f_e_x_p +CLOBBER_TOS_WORKAROUND_START; r2 = exp(r1); +CLOBBER_TOS_WORKAROUND_END; fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one ""@i{r2}=@i{e}**@i{r1}@minus{}1"" @@ -2234,13 +2291,19 @@ extern double const #endif expm1(double); +CLOBBER_TOS_WORKAROUND_START; r2 = expm1(r1); +CLOBBER_TOS_WORKAROUND_END; #else +CLOBBER_TOS_WORKAROUND_START; r2 = exp(r1)-1.; +CLOBBER_TOS_WORKAROUND_END; #endif fln ( r1 -- r2 ) float-ext f_l_n +CLOBBER_TOS_WORKAROUND_START; r2 = log(r1); +CLOBBER_TOS_WORKAROUND_END; flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one ""@i{r2}=ln(@i{r1}+1)"" @@ -2257,56 +2320,78 @@ r2 = log(r1+1.); flog ( r1 -- r2 ) float-ext f_log ""The decimal logarithm."" +CLOBBER_TOS_WORKAROUND_START; r2 = log10(r1); +CLOBBER_TOS_WORKAROUND_END; falog ( r1 -- r2 ) float-ext f_a_log ""@i{r2}=10**@i{r1}"" extern double pow10(double); +CLOBBER_TOS_WORKAROUND_START; r2 = pow10(r1); +CLOBBER_TOS_WORKAROUND_END; fsin ( r1 -- r2 ) float-ext f_sine +CLOBBER_TOS_WORKAROUND_START; r2 = sin(r1); +CLOBBER_TOS_WORKAROUND_END; fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" +CLOBBER_TOS_WORKAROUND_START; r2 = sin(r1); r3 = cos(r1); +CLOBBER_TOS_WORKAROUND_END; fsqrt ( r1 -- r2 ) float-ext f_square_root r2 = sqrt(r1); ftan ( r1 -- r2 ) float-ext f_tan +CLOBBER_TOS_WORKAROUND_START; r2 = tan(r1); +CLOBBER_TOS_WORKAROUND_END; : fsincos f/ ; fsinh ( r1 -- r2 ) float-ext f_cinch +CLOBBER_TOS_WORKAROUND_START; r2 = sinh(r1); +CLOBBER_TOS_WORKAROUND_END; : fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; fcosh ( r1 -- r2 ) float-ext f_cosh +CLOBBER_TOS_WORKAROUND_START; r2 = cosh(r1); +CLOBBER_TOS_WORKAROUND_END; : fexp fdup 1/f f+ f2/ ; ftanh ( r1 -- r2 ) float-ext f_tan_h +CLOBBER_TOS_WORKAROUND_START; r2 = tanh(r1); +CLOBBER_TOS_WORKAROUND_END; : f2* fexpm1 fdup 2. d>f f+ f/ ; fasinh ( r1 -- r2 ) float-ext f_a_cinch +CLOBBER_TOS_WORKAROUND_START; r2 = asinh(r1); +CLOBBER_TOS_WORKAROUND_END; : fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; facosh ( r1 -- r2 ) float-ext f_a_cosh +CLOBBER_TOS_WORKAROUND_START; r2 = acosh(r1); +CLOBBER_TOS_WORKAROUND_END; : fdup fdup f* 1. d>f f- fsqrt f+ fln ; fatanh ( r1 -- r2 ) float-ext f_a_tan_h +CLOBBER_TOS_WORKAROUND_START; r2 = atanh(r1); +CLOBBER_TOS_WORKAROUND_END; : fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ r> IF fnegate THEN ; @@ -2528,7 +2613,7 @@ u = (c_addr[0] << 8) | (c_addr[1]); be-ul@ ( c_addr -- u ) gforth l_fetch_be ""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}."" -u = (c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); +u = ((Cell)c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); le-uw@ ( c_addr -- u ) gforth w_fetch_le ""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" @@ -2536,7 +2621,7 @@ u = (c_addr[1] << 8) | (c_addr[0]); le-ul@ ( c_addr -- u ) gforth l_fetch_le ""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}."" -u = (c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); +u = ((Cell)c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); \+64bit