--- gforth/prim	2011/12/19 19:43:29	1.263
+++ gforth/prim	2012/05/26 10:20:01	1.272
@@ -1,6 +1,6 @@
 \ Gforth primitives
 
-\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010 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.
 
@@ -1747,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);
@@ -1845,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;
@@ -1860,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}""
@@ -1945,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
@@ -1981,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}.
@@ -2002,13 +2018,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'
@@ -2057,7 +2075,7 @@ clock_gettime(CLOCK_REALTIME,&time1);
 #else
 struct timeval time2;
 gettimeofday(&time2,NULL);
-time1.tv_sec = time2.tv_sec;
+time1.tv_sec = time2.tv_sec;1
 time1.tv_nsec = time2.tv_usec*1000;
 #endif
 dtime = timespec2ns(&time1);
@@ -2153,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;
@@ -2195,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.""
@@ -2240,7 +2262,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 +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);
@@ -2261,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""
@@ -2277,16 +2309,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 +2336,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 +2457,20 @@ 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;
+}
+
 \+
 
 \ The following words access machine/OS/installation-dependent
@@ -2486,18 +2561,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 +2648,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 +2656,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