--- gforth/prim 2010/05/17 09:01:11 1.250 +++ gforth/prim 2012/03/17 22:18:59 1.268 @@ -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. @@ -612,6 +612,24 @@ SET_IP((Xt *)a_target); cell+ THEN >r ; +(try1) ( ... a_oldhandler a_recovery -- R:a_recovery R:a_sp R:f_fp R:c_lp R:a_oldhandler a_newhandler ) gforth paren_try1 +a_sp = sp-1; +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!! @@ -1085,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...) @@ -1713,13 +1747,17 @@ is the host operating system's expansion environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters in length."" /* close ' to keep fontify happy */ -c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1)); +char * string = cstr(c_addr1,u1); +c_addr2 = (Char *)getenv(string); u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2)); +free(string); open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe +char * string = cstr(c_addr,u); fflush(stdout); -wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ +wfileid=(Cell)popen(string,pfileattr[wfam]); /* ~ expansion of 1st arg? */ wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ +free(string); close-pipe ( wfileid -- wretval wior ) gforth close_pipe wretval = pclose((FILE *)wfileid); @@ -1786,6 +1824,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); @@ -1809,7 +1849,7 @@ gforth_LP=lp; #ifdef HAS_LINKBACK ((void (*)())w)(); #else -((void (*)(void *))w)(gforth_pointers); +((void (*)(void *))w)(&gforth_pointers); #endif sp=gforth_SP; fp=gforth_FP; @@ -1824,13 +1864,19 @@ close-file ( wfileid -- wior ) file clo wior = IOR(fclose((FILE *)wfileid)==EOF); open-file ( c_addr u wfam -- wfileid wior ) file open_file -wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior); +char * string = tilde_cstr(c_addr,u); +wfileid = opencreate_file(string, wfam, 0, &wior); +free(string); create-file ( c_addr u wfam -- wfileid wior ) file create_file -wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior); +char * string = tilde_cstr(c_addr,u); +wfileid = opencreate_file(string, wfam, O_CREAT|O_TRUNC, &wior); +free(string); delete-file ( c_addr u -- wior ) file delete_file -wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); +char * string = tilde_cstr(c_addr,u); +wior = IOR(unlink(string)==-1); +free(string); rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" @@ -1909,8 +1955,10 @@ flag = FLAG(feof((FILE *) wfileid)); open-dir ( c_addr u -- wdirid wior ) gforth open_dir ""Open the directory specified by @i{c-addr, u} and return @i{dir-id} for futher access to it."" -wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1)); +char * string = tilde_cstr(c_addr,u); +wdirid = (Cell)opendir(string); wior = IOR(wdirid == 0); +free(string); read-dir ( c_addr u1 wdirid -- u2 flag wior ) gforth read_dir ""Attempt to read the next entry from the directory specified @@ -1945,14 +1993,18 @@ close-dir ( wdirid -- wior ) gforth clos wior = IOR(closedir((DIR *)wdirid)); filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file -char * string = cstr(c_addr1, u1, 1); -char * pattern = cstr(c_addr2, u2, 0); +char * string = cstr(c_addr1, u1); +char * pattern = cstr(c_addr2, u2); flag = FLAG(!fnmatch(pattern, string, 0)); +free(string); +free(pattern); set-dir ( c_addr u -- wior ) gforth set_dir ""Change the current directory to @i{c-addr, u}. Return an error if this is not possible"" -wior = IOR(chdir(tilde_cstr(c_addr, u, 1))); +char * string = tilde_cstr(c_addr, u); +wior = IOR(chdir(string)); +free(string); get-dir ( c_addr1 u1 -- c_addr2 u2 ) gforth get_dir ""Store the current directory in the buffer specified by @i{c-addr1, u1}. @@ -1966,7 +2018,9 @@ if(c_addr2 != NULL) { =mkdir ( c_addr u wmode -- wior ) gforth equals_mkdir ""Create directory @i{c-addr u} with mode @i{wmode}."" -wior = IOR(mkdir(tilde_cstr(c_addr,u,1),wmode)); +char * string = tilde_cstr(c_addr,u); +wior = IOR(mkdir(string,wmode)); +free(string); \+ @@ -2013,6 +2067,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 @@ -2104,7 +2171,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; @@ -2146,7 +2215,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."" @@ -2201,10 +2272,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); @@ -2212,13 +2287,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"" @@ -2228,13 +2309,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)"" @@ -2251,56 +2338,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 ; @@ -2437,18 +2546,20 @@ open-lib ( c_addr1 u1 -- u2 ) gforth ope u2 = gforth_dlopen(c_addr1, u1); lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym +char * string = cstr(c_addr1, u1); #ifdef HAVE_LIBLTDL -u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1)); +u3 = (UCell) lt_dlsym((lt_dlhandle)u2, string); #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) -u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); +u3 = (UCell) dlsym((void*)u2,string); #else # ifdef _WIN32 -u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); +u3 = (Cell) GetProcAddress((HMODULE)u2, string); # else #warning Define lib-sym! u3 = 0; # endif #endif +free(string); wcall ( ... u -- ... ) gforth gforth_FP=fp; @@ -2492,55 +2603,106 @@ c_addr = "libltdl is not configured"; u = strlen(c_addr); #endif -w!be ( w c_addr -- ) gforth w_store_be +be-w! ( w c_addr -- ) gforth w_store_be ""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" -*(Wyde*)(c_addr) = htobe16(w); +c_addr[0] = w >> 8; +c_addr[1] = w; -l!be ( w c_addr -- ) gforth l_store_be +be-l! ( w c_addr -- ) gforth l_store_be ""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" -*(Tetrabyte*)(c_addr) = htobe32(w); - -x!be ( w c_addr -- ) gforth x_store_be -""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" -*(Octabyte*)(c_addr) = htobe64(w); +c_addr[0] = w >> 24; +c_addr[1] = w >> 16; +c_addr[2] = w >> 8; +c_addr[3] = w; -w!le ( w c_addr -- ) gforth w_store_le +le-w! ( w c_addr -- ) gforth w_store_le ""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" -*(Wyde*)(c_addr) = htole16(w); +c_addr[1] = w >> 8; +c_addr[0] = w; -l!le ( w c_addr -- ) gforth l_store_le +le-l! ( w c_addr -- ) gforth l_store_le ""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" -*(Tetrabyte*)(c_addr) = htole32(w); +c_addr[3] = w >> 24; +c_addr[2] = w >> 16; +c_addr[1] = w >> 8; +c_addr[0] = w; -x!le ( w c_addr -- ) gforth x_store_le -""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" -*(Octabyte*)(c_addr) = htole64(w); - -w@be ( c_addr -- u ) gforth w_fetch_be +be-uw@ ( c_addr -- u ) gforth w_fetch_be ""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}."" -u = be16toh(*(UWyde*)(c_addr)); +u = (c_addr[0] << 8) | (c_addr[1]); -l@be ( c_addr -- u ) gforth l_fetch_be +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 = be32toh(*(UTetrabyte*)(c_addr)); - -x@be ( c_addr -- u ) gforth x_fetch_be -""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" -u = be64toh(*(UOctabyte*)(c_addr)); +u = ((Cell)c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); -w@le ( c_addr -- u ) gforth w_fetch_le +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}."" -u = le16toh(*(UWyde*)(c_addr)); +u = (c_addr[1] << 8) | (c_addr[0]); -l@le ( c_addr -- u ) gforth l_fetch_le +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 = le32toh(*(UTetrabyte*)(c_addr)); +u = ((Cell)c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); + +\+64bit + +x! ( w c_addr -- ) gforth x_store +""Store the bottom 64 bits of @i{w} at 64-bit-aligned @i{c_addr}."" +*(UOctabyte *)c_addr = w; + +ux@ ( c_addr -- u ) gforth u_x_fetch +""@i{u} is the zero-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" +u = *(UOctabyte *)c_addr; + +sx@ ( c_addr -- n ) gforth s_x_fetch +""@i{u} is the sign-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" +n = *(Octabyte *)c_addr; -x@le ( c_addr -- u ) gforth x_fetch_le +be-x! ( w c_addr -- ) gforth b_e_x_store +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 56; +c_addr[1] = w >> 48; +c_addr[2] = w >> 40; +c_addr[3] = w >> 32; +c_addr[4] = w >> 24; +c_addr[5] = w >> 16; +c_addr[6] = w >> 8; +c_addr[7] = w; + +le-x! ( w c_addr -- ) gforth l_e_x_store +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[7] = w >> 56; +c_addr[6] = w >> 48; +c_addr[5] = w >> 40; +c_addr[4] = w >> 32; +c_addr[3] = w >> 24; +c_addr[2] = w >> 16; +c_addr[1] = w >> 8; +c_addr[0] = w; + +be-ux@ ( c_addr -- u ) gforth b_e_u_x_fetch +""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" +u = (((Cell)(c_addr[0]) << 56) | + ((Cell)(c_addr[1]) << 48) | + ((Cell)(c_addr[2]) << 40) | + ((Cell)(c_addr[3]) << 32) | + ((Cell)(c_addr[4]) << 24) | + ((Cell)(c_addr[5]) << 16) | + ((Cell)(c_addr[6]) << 8) | + ((Cell)(c_addr[7]))); + +le-ux@ ( c_addr -- u ) gforth l_e_u_x_fetch ""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}."" -u = le64toh(*(UOctabyte*)(c_addr)); +u = (((Cell)(c_addr[7]) << 56) | + ((Cell)(c_addr[6]) << 48) | + ((Cell)(c_addr[5]) << 40) | + ((Cell)(c_addr[4]) << 32) | + ((Cell)(c_addr[3]) << 24) | + ((Cell)(c_addr[2]) << 16) | + ((Cell)(c_addr[1]) << 8) | + ((Cell)(c_addr[0]))); \+ +\+ \g peephole \+peephole