--- gforth/prim 2011/12/31 15:29:25 1.264 +++ gforth/prim 2012/10/08 22:45:19 1.279 @@ -1109,7 +1109,7 @@ if (u1 select ; umin ( u1 u2 -- u ) core if (u1 IF swap THEN drop ; + 2dup u< select ; + +mux ( u1 u2 u3 -- u ) gforth +""multiplex @i{u1} for 1 bits in @i{u3}, @i{u2} for 0 bits in @i{u3} into @i{u}"" +u = (u3 & u1) | (~u3 & u2); +: + tuck and >r invert and r> ; + +select ( u1 u2 f -- u ) gforth +""select @i{u1} if @i{f} is true, @i{u2} if false."" +u = f ? u1 : u2; +: + IF swap THEN nip ; \g compare @@ -1516,6 +1528,17 @@ c_addr2 = c_addr1+1; : dup 1+ swap c@ ; +cell/ ( n1 -- n2 ) gforth cell_divide +""@i{n2} is the number of cells that fit into @i{n1}"" +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 ] ; + \g compiler \+f83headerstring @@ -1700,7 +1723,7 @@ wfileid = (Cell)stderr; \+os -form ( -- urows ucols ) gforth +(form) ( -- urows ucols ) gforth paren_form ""The number of lines and columns in the terminal. These numbers may change with the window size. Note that it depends on the OS whether this reflects the actual size and changes with the window size @@ -1735,6 +1758,10 @@ FLUSH_ICACHE((caddr_t)c_addr,u); (bye) ( n -- ) gforth paren_bye SUPER_END; +gforth_FP=fp; +gforth_SP=sp; +gforth_RP=rp; +gforth_LP=lp; return (Label *)n; (system) ( c_addr u -- wretval wior ) gforth paren_system @@ -1747,13 +1774,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); @@ -1845,7 +1876,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; @@ -1860,13 +1891,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}"" @@ -1945,8 +1982,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 @@ -1981,14 +2020,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}. @@ -2002,13 +2045,15 @@ 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); \+ newline ( -- c_addr u ) gforth ""String containing the newline sequence of the host OS"" -char newline[] = { +static const char newline[] = { #if DIRSEP=='/' /* Unix */ '\n' @@ -2153,7 +2198,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; @@ -2195,7 +2242,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."" @@ -2240,7 +2289,7 @@ representation. If the string represents true. Otherwise, @i{flag} is false. A string of blanks is a special case and represents the floating-point number 0."" Float r; -flag = to_float(c_addr, u, &r); +flag = to_float(c_addr, u, &r, '.'); if (flag) { fp--; fp[0]=r; @@ -2250,10 +2299,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); @@ -2261,13 +2314,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"" @@ -2277,16 +2336,23 @@ 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)"" +CLOBBER_TOS_WORKAROUND_START; #ifdef HAVE_LOG1P extern double #ifdef NeXT @@ -2297,59 +2363,81 @@ r2 = log1p(r1); #else r2 = log(r1+1.); #endif +CLOBBER_TOS_WORKAROUND_END; 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})"" -r2 = sin(r1); -r3 = cos(r1); +CLOBBER_TOS_WORKAROUND_START; +sincos(r1, &r2, &r3); +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 ; @@ -2396,6 +2484,29 @@ faxpy(ra, f_x, nstridex, f_y, nstridey, fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap LOOP 2drop 2drop fdrop ; +>float1 ( c_addr u c -- f:... flag ) gforth to_float1 +""Actual stack effect: ( c_addr u c -- r t | f ). Attempt to convert the +character string @i{c-addr u} to internal floating-point +representation. If the string represents a valid floating-point number +@i{r} is placed on the floating-point stack and @i{flag} is +true. Otherwise, @i{flag} is false. A string of blanks is a special +case and represents the floating-point number 0."" +Float r; +flag = to_float(c_addr, u, &r, c); +if (flag) { + fp--; + fp[0]=r; +} + +float/ ( n1 -- n2 ) gforth float_divide +n2 = n1 / sizeof(Float); + +dfloat/ ( n1 -- n2 ) gforth sfloat_divide +n2 = n1 / sizeof(DFloat); + +sfloat/ ( n1 -- n2 ) gforth dfloat_divide +n2 = n1 / sizeof(SFloat); + \+ \ The following words access machine/OS/installation-dependent @@ -2486,18 +2597,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; @@ -2571,7 +2684,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}."" @@ -2579,7 +2692,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 @@ -2716,7 +2829,20 @@ ip=IP; SUPER_END; VM_JUMP(EXEC1((Xt)a_addr)); +\+objects +\g object_pointer + +>o ( c_addr -- r:c_old ) new to_o +c_old = op; +op = c_addr; +o> ( r:c_addr -- ) new o_restore +op = c_addr; + +o#+ ( #w -- c_addr ) new o_lit_plus +c_addr = op + w; + +\+ \g static_super ifdef(`STACK_CACHE_FILE',