--- gforth/prim	1999/05/09 21:21:55	1.30
+++ gforth/prim	2000/05/31 14:37:40	1.46
@@ -129,6 +129,7 @@ EXEC(*(Xt *)a_addr);
 :
  @ execute ;
 
+\fhas? skipbranchprims 0= [IF]
 \+glocals
 
 branch-lp+!#	--	gforth	branch_lp_plus_store_number
@@ -208,6 +209,8 @@ else
   INC_IP(1);
 
 \+
+\f[THEN]
+\fhas? skiploopprims 0= [IF]
 
 condbranch((next),--		cmFORTH	paren_next,
 if ((*rp)--) {
@@ -437,30 +440,33 @@ n = rp[4];
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]
 
+\f[THEN]
+
 \ digit is high-level: 0/0%
 
 move	c_from c_to ucount --		core
-"" If @i{ucount}>0, copy the contents of @i{ucount} address units
-at @i{c-from} to @i{c-to}. @code{move} chooses its copy direction
-to avoid problems when @i{c-from}, @i{c-to} overlap.""
+""Copy the contents of @i{ucount} address units at @i{c-from} to
+@i{c-to}. @code{move} works correctly even if the two areas overlap.""
 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
-"" If @i{u}>0, copy the contents of @i{ucount} characters from
-data space at @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
-from low address to high address.""
+cmove	c_from c_to u --	string	c_move
+""Copy the contents of @i{ucount} characters from data space at
+@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
+from low address to high address; i.e., for overlapping areas it is
+safe if @i{c-to}=<@i{c-from}.""
 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
-"" If @i{u}>0, copy the contents of @i{ucount} characters from
-data space at @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
-from high address to low address.""
+""Copy the contents of @i{ucount} characters from data space at
+@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
+from high address to low address; i.e., for overlapping areas it is
+safe if @i{c-to}>=@i{c-from}.""
 while (u-- > 0)
   c_to[u] = c_from[u];
 :
@@ -482,6 +488,7 @@ the first string is smaller, @i{n} is -1
 is 1. Currently this is based on the machine's character
 comparison. In the future, this may change to consider the current
 locale and its collation order.""
+/* close ' to keep fontify happy */ 
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
 if (n==0)
   n = u1-u2;
@@ -490,13 +497,10 @@ if (n<0)
 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 ;
+ rot 2dup swap - >r min swap -text dup
+ IF  rdrop  ELSE  drop r> sgn  THEN ;
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
 
 -text		c_addr1 u c_addr2 -- n	new	dash_text
 n = memcmp(c_addr1, c_addr2, u);
@@ -508,8 +512,8 @@ else if (n>0)
  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>  1 and  THEN  ;
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
 
 toupper	c1 -- c2	gforth
 ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
@@ -713,6 +717,7 @@ ud = (UDCell)u1 * (UDCell)u2;
    and >r >r 2dup d+ swap r> + swap r> ;
 
 um/mod	ud u1 -- u2 u3		core	u_m_slash_mod
+""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LONG_LONG
 UDCell r = umdiv(ud,u1);
 u2=r.hi;
@@ -761,7 +766,7 @@ d = d1-d2;
 :
  dnegate d+ ;
 
-dnegate	d1 -- d2		double
+dnegate	d1 -- d2		double	d_negate
 /* use dminus as alias */
 #ifdef BUGGY_LONG_LONG
 d2 = dnegate(d1);
@@ -800,7 +805,7 @@ w = w1|w2;
 :
  invert swap invert and invert ;
 
-xor	w1 w2 -- w		core
+xor	w1 w2 -- w		core	x_or
 w = w1^w2;
 
 invert	w1 -- w2		core
@@ -808,12 +813,12 @@ w2 = ~w1;
 :
  MAXU xor ;
 
-rshift	u1 n -- u2		core
+rshift	u1 n -- u2		core	r_shift
   u2 = u1>>n;
 :
     0 ?DO 2/ MAXI and LOOP ;
 
-lshift	u1 n -- u2		core
+lshift	u1 n -- u2		core	l_shift
   u2 = u1<<n;
 :
     0 ?DO 2* LOOP ;
@@ -829,7 +834,7 @@ f = FLAG($4==$5);
 	] xor 0= [
     [THEN] ] ;
 
-$1<>	$2 -- f		$7	$3different
+$1<>	$2 -- f		$7	$3not_equals
 f = FLAG($4!=$5);
 :
     [ char $1x char 0 = [IF]
@@ -838,7 +843,7 @@ f = FLAG($4!=$5);
 	] xor 0<> [
     [THEN] ] ;
 
-$1<	$2 -- f		$8	$3less
+$1<	$2 -- f		$8	$3less_than
 f = FLAG($4<$5);
 :
     [ char $1x char 0 = [IF]
@@ -850,7 +855,7 @@ f = FLAG($4<$5);
 	[THEN]
     [THEN] ] ;
 
-$1>	$2 -- f		$9	$3greater
+$1>	$2 -- f		$9	$3greater_than
 f = FLAG($4>$5);
 :
     [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
@@ -882,21 +887,21 @@ f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
 f = FLAG($4==$5);
 #endif
 
-$1<>	$2 -- f		$7	$3different
+$1<>	$2 -- f		$7	$3not_equals
 #ifdef BUGGY_LONG_LONG
 f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
 #else
 f = FLAG($4!=$5);
 #endif
 
-$1<	$2 -- f		$8	$3less
+$1<	$2 -- f		$8	$3less_than
 #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
 #else
 f = FLAG($4<$5);
 #endif
 
-$1>	$2 -- f		$9	$3greater
+$1>	$2 -- f		$9	$3greater_than
 #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
 #else
@@ -928,6 +933,13 @@ dcomparisons(du, ud1 ud2, d_u_, ud1, ud2
 \+
 
 within	u1 u2 u3 -- f		core-ext
+""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2).  This works for
+unsigned and signed numbers (but not a mixture).  Another way to think
+about this word is to consider the numbers as a circle (wrapping
+around from @code{max-u} to 0 for unsigned, and from @code{max-n} to
+min-n for signed numbers); now consider the range from u2 towards
+increasing numbers up to and excluding u3 (giving an empty range if
+u2=u3; if u1 is in this range, @code{within} returns true.""
 f = FLAG(u1-u2 < u3-u2);
 :
  over - >r - r> u< ;
@@ -1012,7 +1024,7 @@ swap	w1 w2 -- w2 w1		core
  >r (swap) ! r> (swap) @ ;
 Variable (swap)
 
-dup	w -- w w		core
+dup	w -- w w		core	dupe
 :
  sp@ @ ;
 
@@ -1335,11 +1347,14 @@ f_addr = (Float *)((((Cell)c_addr)+(size
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
 
 >body		xt -- a_addr	core	to_body
+"" Get the address of the body of the word represented by @i{xt} (the address
+of the word's data field).""
 a_addr = PFA(xt);
 :
     2 cells + ;
 
-\+standardthreading
+\ threading stuff is currently only interesting if we have a compiler
+\fhas? standardthreading has? compiler and [IF]
 
 >code-address		xt -- c_addr		gforth	to_code_address
 ""@i{c-addr} is the code address of the word @i{xt}.""
@@ -1401,7 +1416,7 @@ n=1;
 :
  1 ;
 
-\+
+\f[THEN]
 
 key-file	wfileid -- n		gforth	paren_key_file
 #ifdef HAS_FILE
@@ -1470,6 +1485,7 @@ getenv	c_addr1 u1 -- c_addr2 u2	gforth
 is the host operating system's expansion of that environment variable. If the
 environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
 in length.""
+/* close ' to keep fontify happy */
 c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
 
@@ -1482,6 +1498,8 @@ wretval = pclose((FILE *)wfileid);
 wior = IOR(wretval==-1);
 
 time&date	-- nsec nmin nhour nday nmonth nyear	facility-ext	time_and_date
+""Report the current time of day. Seconds, minutes and hours are numbered from 0.
+Months are numbered from 1.""
 struct timeval time1;
 struct timezone zone1;
 struct tm *ltime;
@@ -1495,6 +1513,7 @@ nmin  =ltime->tm_min;
 nsec  =ltime->tm_sec;
 
 ms	n --	facility-ext
+""Wait at least @i{n} milli-second.""
 struct timeval timeout;
 timeout.tv_sec=n/1000;
 timeout.tv_usec=1000*(n%1000);
@@ -1528,6 +1547,7 @@ I/O result code. If @i{a-addr1} is 0, Gf
 @code{resize} @code{allocate}s @i{u} address units.""
 /* the following check is not necessary on most OSs, but it is needed
    on SunOS 4.1.2. */
+/* close ' to keep fontify happy */
 if (a_addr1==NULL)
   a_addr2 = (Cell *)malloc(u);
 else
@@ -1619,21 +1639,26 @@ if (wior)
   clearerr((FILE *)wfileid);
 
 read-line	c_addr u1 wfileid -- u2 flag wior	file	read_line
-/*
+#if 1
 Cell c;
 flag=-1;
 for(u2=0; u2<u1; u2++)
 {
-   *c_addr++ = (Char)(c = getc((FILE *)wfileid));
-   if(c=='\n') break;
-   if(c==EOF)
-     {
+   c = getc((FILE *)wfileid);
+   if (c=='\n') break;
+   if (c=='\r') {
+     if ((c = getc((FILE *)wfileid))!='\n')
+       ungetc(c,(FILE *)wfileid);
+     break;
+   }
+   if (c==EOF) {
 	flag=FLAG(u2!=0);
 	break;
      }
+   c_addr[u2] = (Char)c;
 }
 wior=FILEIO(ferror((FILE *)wfileid));
-*/
+#else
 if ((flag=FLAG(!feof((FILE *)wfileid) &&
 	       fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
   wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */
@@ -1646,20 +1671,22 @@ else {
   wior=0;
   u2=0;
 }
+#endif
 
 \+
-\+file
 
 write-file	c_addr u1 wfileid -- wior	file	write_file
 /* !! fwrite does not guarantee enough */
+#ifdef HAS_FILE
 {
   UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
   if (wior)
     clearerr((FILE *)wfileid);
 }
-
-\+
+#else
+TYPE(c_addr, u1);
+#endif
 
 emit-file	c wfileid -- wior	gforth	emit_file
 #ifdef HAS_FILE
@@ -1667,7 +1694,7 @@ wior = FILEIO(putc(c, (FILE *)wfileid)==
 if (wior)
   clearerr((FILE *)wfileid);
 #else
-putc(c, stdout);
+PUTC(c);
 #endif
 
 \+file
@@ -1777,22 +1804,22 @@ f**		r1 r2 -- r3	float-ext	f_star_star
 ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
 r3 = pow(r1,r2);
 
-fnegate		r1 -- r2	float
+fnegate		r1 -- r2	float	f_negate
 r2 = - r1;
 
-fdrop		r --		float
+fdrop		r --		float	f_drop
 
-fdup		r -- r r	float
+fdup		r -- r r	float	f_dupe
 
-fswap		r1 r2 -- r2 r1	float
+fswap		r1 r2 -- r2 r1	float	f_swap
 
-fover		r1 r2 -- r1 r2 r1	float
+fover		r1 r2 -- r1 r2 r1	float	f_over
 
-frot		r1 r2 r3 -- r2 r3 r1	float
+frot		r1 r2 r3 -- r2 r3 r1	float	f_rote
 
-fnip		r1 r2 -- r2	gforth
+fnip		r1 r2 -- r2	gforth	f_nip
 
-ftuck		r1 r2 -- r2 r1 r2	gforth
+ftuck		r1 r2 -- r2 r1 r2	gforth	f_tuck
 
 float+		f_addr1 -- f_addr2	float	float_plus
 "" Increment @i{f-addr1} by the number of address units corresponding to the size of
@@ -1808,7 +1835,7 @@ floor		r1 -- r2	float
 /* !! unclear wording */
 r2 = floor(r1);
 
-fround		r1 -- r2	float
+fround		r1 -- r2	float	f_round
 ""Round to the nearest integral value.""
 /* !! unclear wording */
 #ifdef HAVE_RINT
@@ -1818,13 +1845,13 @@ r2 = floor(r1+0.5);
 /* !! This is not quite true to the rounding rules given in the standard */
 #endif
 
-fmax		r1 r2 -- r3	float
+fmax		r1 r2 -- r3	float	f_max
 if (r1<r2)
   r3 = r2;
 else
   r3 = r1;
 
-fmin		r1 r2 -- r3	float
+fmin		r1 r2 -- r3	float	f_min
 if (r1<r2)
   r3 = r1;
 else
@@ -1846,11 +1873,17 @@ internal floating-point representation.
 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 flotaing-point number 0.""
+and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */
 Float r;
 char *number=cstr(c_addr, u, 1);
 char *endconv;
+int sign = 0;
+if(number[0]=='-') {
+   sign = 1;
+   number++;
+   u--;
+}
 while(isspace((unsigned)(number[--u])) && u>0);
 switch(number[u])
 {
@@ -1866,7 +1899,7 @@ if((flag=FLAG(!(Cell)*endconv)))
 {
    IF_FTOS(fp[0] = FTOS);
    fp += -1;
-   FTOS = r;
+   FTOS = sign ? -r : r;
 }
 else if(*endconv=='d' || *endconv=='D')
 {
@@ -1876,34 +1909,34 @@ else if(*endconv=='d' || *endconv=='D')
      {
 	IF_FTOS(fp[0] = FTOS);
 	fp += -1;
-	FTOS = r;
+	FTOS = sign ? -r : r;
      }
 }
 
-fabs		r1 -- r2	float-ext
+fabs		r1 -- r2	float-ext	f_abs
 r2 = fabs(r1);
 
-facos		r1 -- r2	float-ext
+facos		r1 -- r2	float-ext	f_a_cos
 r2 = acos(r1);
 
-fasin		r1 -- r2	float-ext
+fasin		r1 -- r2	float-ext	f_a_sine
 r2 = asin(r1);
 
-fatan		r1 -- r2	float-ext
+fatan		r1 -- r2	float-ext	f_a_tan
 r2 = atan(r1);
 
-fatan2		r1 r2 -- r3	float-ext
+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.""
 r3 = atan2(r1,r2);
 
-fcos		r1 -- r2	float-ext
+fcos		r1 -- r2	float-ext	f_cos
 r2 = cos(r1);
 
-fexp		r1 -- r2	float-ext
+fexp		r1 -- r2	float-ext	f_e_x_p
 r2 = exp(r1);
 
-fexpm1		r1 -- r2	float-ext
+fexpm1		r1 -- r2	float-ext	f_e_x_p_m_one
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 #ifdef HAVE_EXPM1
 extern double
@@ -1916,10 +1949,10 @@ r2 = expm1(r1);
 r2 = exp(r1)-1.;
 #endif
 
-fln		r1 -- r2	float-ext
+fln		r1 -- r2	float-ext	f_l_n
 r2 = log(r1);
 
-flnp1		r1 -- r2	float-ext
+flnp1		r1 -- r2	float-ext	f_l_n_p_one
 ""@i{r2}=ln(@i{r1}+1)""
 #ifdef HAVE_LOG1P
 extern double
@@ -1932,57 +1965,57 @@ r2 = log1p(r1);
 r2 = log(r1+1.);
 #endif
 
-flog		r1 -- r2	float-ext
+flog		r1 -- r2	float-ext	f_log
 ""The decimal logarithm.""
 r2 = log10(r1);
 
-falog		r1 -- r2	float-ext
+falog		r1 -- r2	float-ext	f_a_log
 ""@i{r2}=10**@i{r1}""
 extern double pow10(double);
 r2 = pow10(r1);
 
-fsin		r1 -- r2	float-ext
+fsin		r1 -- r2	float-ext	f_sine
 r2 = sin(r1);
 
-fsincos		r1 -- r2 r3	float-ext
+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);
 
-fsqrt		r1 -- r2	float-ext
+fsqrt		r1 -- r2	float-ext	f_square_root
 r2 = sqrt(r1);
 
-ftan		r1 -- r2	float-ext
+ftan		r1 -- r2	float-ext	f_tan
 r2 = tan(r1);
 :
  fsincos f/ ;
 
-fsinh		r1 -- r2	float-ext
+fsinh		r1 -- r2	float-ext	f_cinch
 r2 = sinh(r1);
 :
  fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
 
-fcosh		r1 -- r2	float-ext
+fcosh		r1 -- r2	float-ext	f_cosh
 r2 = cosh(r1);
 :
  fexp fdup 1/f f+ f2/ ;
 
-ftanh		r1 -- r2	float-ext
+ftanh		r1 -- r2	float-ext	f_tan_h
 r2 = tanh(r1);
 :
  f2* fexpm1 fdup 2. d>f f+ f/ ;
 
-fasinh		r1 -- r2	float-ext
+fasinh		r1 -- r2	float-ext	f_a_cinch
 r2 = asinh(r1);
 :
  fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
 
-facosh		r1 -- r2	float-ext
+facosh		r1 -- r2	float-ext	f_a_cosh
 r2 = acosh(r1);
 :
  fdup fdup f* 1. d>f f- fsqrt f+ fln ;
 
-fatanh		r1 -- r2	float-ext
+fatanh		r1 -- r2	float-ext	f_a_tan_h
 r2 = atanh(r1);
 :
  fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
@@ -2124,6 +2157,7 @@ rret = (SYSCALL(Float(*)(argdlist($1)))u
 
 ')
 
+\ close ' to keep fontify happy
 
 open-lib	c_addr1 u1 -- u2	gforth	open_lib
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
@@ -2164,3 +2198,54 @@ UP=up=(char *)a_addr;
 :
  up ! ;
 Variable UP
+
+wcall	u --	gforth
+IF_FTOS(fp[0]=FTOS);
+FP=fp;
+sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
+fp=FP;
+IF_TOS(TOS=sp[0];)
+IF_FTOS(FTOS=fp[0]);
+
+\+file
+
+open-dir	c_addr u -- wdirid wior	gforth	open_dir
+wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
+wior =  IOR(wdirid == 0);
+
+read-dir	c_addr u1 wdirid -- u2 flag wior	gforth	read_dir
+struct dirent * dent;
+dent = readdir((DIR *)wdirid);
+wior = 0;
+flag = -1;
+if(dent == NULL) {
+  u2 = 0;
+  flag = 0;
+} else {
+  u2 = strlen(dent->d_name);
+  if(u2 > u1)
+    u2 = u1;
+  memmove(c_addr, dent->d_name, u2);
+}
+
+close-dir	wdirid -- wior	gforth	close_dir
+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);
+flag = FLAG(!fnmatch(pattern, string, 0));
+
+\+
+
+newline	-- c_addr u	gforth
+""String containing the newline sequence of the host OS""
+char newline[] = {
+#ifdef unix
+'\n'
+#else
+'\r','\n'
+#endif
+};
+c_addr=newline;
+u=sizeof(newline);