--- gforth/prim	1997/09/13 12:04:58	1.6
+++ gforth/prim	1999/03/29 22:52:28	1.27
@@ -1,6 +1,6 @@
 \ Gforth primitives
 
-\ Copyright (C) 1995,1996 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -115,12 +115,13 @@ INC_IP(1);
  r> dup @ swap cell+ >r ;
 
 execute		xt --		core
+""Perform the semantics represented by the execution token, @var{xt}.""
 ip=IP;
 IF_TOS(TOS = sp[0]);
 EXEC(xt);
 
 perform		a_addr --	gforth
-""equivalent to @code{@ execute}""
+""Equivalent to @code{@ execute}.""
 /* and pfe */
 ip=IP;
 IF_TOS(TOS = sp[0]);
@@ -128,7 +129,7 @@ EXEC(*(Xt *)a_addr);
 :
  @ execute ;
 
-\+has? glocals [IF]
+\+glocals
 
 branch-lp+!#	--	gforth	branch_lp_plus_store_number
 /* this will probably not be used */
@@ -136,12 +137,11 @@ branch_adjust_lp:
 lp += (Cell)(IP[1]);
 goto branch;
 
-\+[THEN]
+\+
 
 branch	--		gforth
 branch:
-ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
-NEXT_P0;
+SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
 :
  r> dup @ + >r ;
 
@@ -149,15 +149,14 @@ NEXT_P0;
 \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,
 $1	$2
-$3	ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
-        NEXT_P0;
+$3	SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
 	NEXT;
 }
 else
     INC_IP(1);
 $4
 
-\+has? glocals [IF]
+\+glocals
 
 $1-lp+!#	$2_lp_plus_store_number
 $3    goto branch_adjust_lp;
@@ -165,7 +164,7 @@ $3    goto branch_adjust_lp;
 else
     INC_IP(2);
 
-\+[THEN]
+\+
 )
 
 condbranch(?branch,f --		f83	question_branch,
@@ -181,15 +180,14 @@ if (f==0) {
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it
 \ is only used in if's (yet)
 
-\+has? xconds [IF]
+\+xconds
 
 ?dup-?branch	f -- f	new	question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {
   sp++;
   IF_TOS(TOS = sp[0]);
-  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
-  NEXT_P0;
+  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT;
 }
 else
@@ -203,14 +201,13 @@ few cycles in that case, but is easy to
 invocation */
 if (f!=0) {
   sp--;
-  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
-  NEXT_P0;
+  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT;
 }
 else
   INC_IP(1);
 
-\+[THEN]
+\+
 
 condbranch((next),--		cmFORTH	paren_next,
 if ((*rp)--) {
@@ -250,7 +247,7 @@ if ((olddiff^(olddiff+n))>=0   /* the li
  IF    >r + >r dup @ + >r
  ELSE  >r >r drop cell+ >r THEN ;)
 
-\+has? xconds [IF]
+\+xconds
 
 condbranch((-loop),u --		gforth	paren_minus_loop,
 /* !! check this thoroughly */
@@ -286,7 +283,7 @@ if (diff>=0 || newdiff<0) {
     IF_TOS(TOS = sp[0]);
 ,)
 
-\+[THEN]
+\+
 
 unloop		--	core
 rp += 2;
@@ -325,7 +322,7 @@ else {
        cell+ >r
   THEN ;				\ --> CORE-EXT
 
-\+has? xconds [IF]
+\+xconds
 
 (+do)	nlimit nstart --	gforth	paren_plus_do
 *--rp = nlimit;
@@ -407,7 +404,7 @@ else {
      cell+
  THEN  >r ;
 
-\+[THEN]
+\+
 
 \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!
@@ -443,18 +440,27 @@ n = rp[4];
 \ digit is high-level: 0/0%
 
 move	c_from c_to ucount --		core
+"" If @var{ucount}>0, copy the contents of @var{ucount} address units
+at @var{c-from} to @var{c-to}. @code{move} chooses its copy direction
+to avoid problems when @var{c-from}, @var{c-to} 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 @var{u}>0, copy the contents of @var{ucount} characters from
+data space at @var{c-from} to @var{c-to}. The copy proceeds @code{char}-by-@code{char}
+from low address to high address.""
 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 @var{u}>0, copy the contents of @var{ucount} characters from
+data space at @var{c-from} to @var{c-to}. The copy proceeds @code{char}-by-@code{char}
+from high address to low address.""
 while (u-- > 0)
   c_to[u] = c_from[u];
 :
@@ -463,16 +469,18 @@ while (u-- > 0)
  DO  1- dup c@ I c!  -1 +LOOP  drop ;
 
 fill	c_addr u c --	core
+"" If @var{u}>0, store character @var{c} in each of @var{u} consecutive
+@code{char} addresses in memory, starting at address @var{c-addr}.""
 memset(c_addr,c,u);
 :
  -rot bounds
  ?DO  dup I c!  LOOP  drop ;
 
 compare		c_addr1 u1 c_addr2 u2 -- n	string
-""Compare the strings lexicographically. If they are equal, n is 0; if
-the first string is smaller, n is -1; if the first string is larger, n
+""Compare two strings lexicographically. If they are equal, @var{n} is 0; if
+the first string is smaller, @var{n} is -1; if the first string is larger, @var{n}
 is 1. Currently this is based on the machine's character
-comparison. In the future, this may change to considering the current
+comparison. In the future, this may change to consider the current
 locale and its collation order.""
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
 if (n==0)
@@ -504,6 +512,8 @@ else if (n>0)
  dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;
 
 toupper	c1 -- c2	gforth
+""If @var{c1} is a lower-case character (in the current locale), @var{c2}
+is the equivalent upper-case character. All other characters are unchanged.""
 c2 = toupper(c1);
 :
  dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
@@ -522,6 +532,8 @@ else if (n>0)
  ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;
 
 -trailing	c_addr u1 -- c_addr u2		string	dash_trailing
+""Adjust the string specified by @var{c-addr, u1} to remove all trailing
+spaces. @var{u2} is the length of the modified string.""
 u2 = u1;
 while (u2>0 && c_addr[u2-1] == ' ')
   u2--;
@@ -530,6 +542,8 @@ while (u2>0 && c_addr[u2-1] == ' ')
         dup  0= UNTIL  ELSE  1+  THEN ;
 
 /string		c_addr1 u1 n -- c_addr2 u2	string	slash_string
+""Adjust the string specified by @var{c-addr1, u1} to remove @var{n}
+characters from the start of the string.""
 c_addr2 = c_addr1+n;
 u2 = u1-n;
 :
@@ -627,7 +641,7 @@ n2 = n1>>1;
  LOOP nip ;
 
 fm/mod	d1 n1 -- n2 n3		core		f_m_slash_mod
-""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
+""Floored division: @var{d1} = @var{n3}*@var{n1}+@var{n2}, @var{n1}>@var{n2}>=0 or 0>=@var{n2}>@var{n1}.""
 #ifdef BUGGY_LONG_LONG
 DCell r = fmdiv(d1,n1);
 n2=r.hi;
@@ -649,7 +663,7 @@ if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
  r> 0< IF  swap negate swap  THEN ;
 
 sm/rem	d1 n1 -- n2 n3		core		s_m_slash_rem
-""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
+""Symmetric division: @var{d1} = @var{n3}*@var{n1}+@var{n2}, sign(@var{n2})=sign(@var{d1}) or 0.""
 #ifdef BUGGY_LONG_LONG
 DCell r = smdiv(d1,n1);
 n2=r.hi;
@@ -905,33 +919,33 @@ f = FLAG($4>=$5);
 
 )
 
-\+has? dcomps [IF]
+\+dcomps
 
 dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
 dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
 dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
 
-\+[THEN]
+\+
 
 within	u1 u2 u3 -- f		core-ext
 f = FLAG(u1-u2 < u3-u2);
 :
  over - >r - r> u< ;
 
-sp@	-- a_addr		gforth		spat
+sp@	-- a_addr		gforth		sp_fetch
 a_addr = sp+1;
 
-sp!	a_addr --		gforth		spstore
+sp!	a_addr --		gforth		sp_store
 sp = a_addr;
 /* works with and without TOS caching */
 
-rp@	-- a_addr		gforth		rpat
+rp@	-- a_addr		gforth		rp_fetch
 a_addr = rp;
 
-rp!	a_addr --		gforth		rpstore
+rp!	a_addr --		gforth		rp_store
 rp = a_addr;
 
-\+has? floating [IF]
+\+floating
 
 fp@	-- f_addr	gforth	fp_fetch
 f_addr = fp;
@@ -939,11 +953,11 @@ f_addr = fp;
 fp!	f_addr --	gforth	fp_store
 fp = f_addr;
 
-\+[THEN]
+\+
 
 ;s	--		gforth	semis
-ip = (Xt *)(*rp++);
-NEXT_P0;
+""The primitive compiled by @code{EXIT}.""
+SET_IP((Xt *)(*rp++));
 
 >r	w --		core	to_r
 *--rp = w;
@@ -1079,7 +1093,7 @@ w = *a_addr;
 :
  tuck @ + swap ! ;
 
-c@	c_addr -- c		core	cfetch
+c@	c_addr -- c		core	c_fetch
 c = *c_addr;
 :
 [ bigendian [IF] ]
@@ -1104,7 +1118,7 @@ c = *c_addr;
 ;
 : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
 
-c!	c c_addr --		core	cstore
+c!	c c_addr --		core	c_store
 *c_addr = c;
 :
 [ bigendian [IF] ]
@@ -1171,13 +1185,15 @@ n2 = n1 * sizeof(Char);
  ;
 
 count	c_addr1 -- c_addr2 u	core
+"" If @var{c-add1} is the address of a counted string return the length of
+the string, @var{u}, and the address of its first character, @var{c-addr2}.""
 u = *c_addr1;
 c_addr2 = c_addr1+1;
 :
  dup 1+ swap c@ ;
 
 (f83find)	c_addr u f83name1 -- f83name2	new	paren_f83find
-for (; f83name1 != NULL; f83name1 = f83name1->next)
+for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;
@@ -1191,14 +1207,14 @@ f83name2=f83name1;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
 
-\+has? hash [IF]
+\+hash
 
 (hashfind)	c_addr u a_addr -- f83name2	new	paren_hashfind
-F83Name *f83name1;
+struct F83Name *f83name1;
 f83name2=NULL;
 while(a_addr != NULL)
 {
-   f83name1=(F83Name *)(a_addr[1]);
+   f83name1=(struct F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
@@ -1217,11 +1233,11 @@ while(a_addr != NULL)
 
 (tablefind)	c_addr u a_addr -- f83name2	new	paren_tablefind
 ""A case-sensitive variant of @code{(hashfind)}""
-F83Name *f83name1;
+struct F83Name *f83name1;
 f83name2=NULL;
 while(a_addr != NULL)
 {
-   f83name1=(F83Name *)(a_addr[1]);
+   f83name1=(struct F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
@@ -1272,7 +1288,7 @@ Create rot-values
   7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
   7 c, 5 c, 5 c,
 
-\+[THEN]
+\+
 
 (parse-white)	c_addr1 u1 -- c_addr2 u2	gforth	paren_parse_white
 /* use !isgraph instead of isspace? */
@@ -1310,45 +1326,45 @@ a_addr = PFA(xt);
     2 cells + ;
 
 >code-address		xt -- c_addr		gforth	to_code_address
-""c_addr is the code address of the word xt""
+""@var{c-addr} is the code address of the word @var{xt}.""
 /* !! This behaves installation-dependently for DOES-words */
 c_addr = (Address)CODE_ADDRESS(xt);
 :
     @ ;
 
 >does-code	xt -- a_addr		gforth	to_does_code
-""If xt ist the execution token of a defining-word-defined word,
-a_addr is the start of the Forth code after the DOES>;
-Otherwise a_addr is 0.""
+""If @var{xt} is the execution token of a defining-word-defined word,
+@var{a-addr} is the start of the Forth code after the @code{DOES>};
+Otherwise @var{a-addr} is 0.""
 a_addr = (Cell *)DOES_CODE(xt);
 :
     cell+ @ ;
 
 code-address!		c_addr xt --		gforth	code_address_store
-""Creates a code field with code address c_addr at xt""
+""Create a code field with code address @var{c-addr} at @var{xt}.""
 MAKE_CF(xt, c_addr);
-CACHE_FLUSH(xt,PFA(0));
+CACHE_FLUSH(xt,(size_t)PFA(0));
 :
     ! ;
 
 does-code!	a_addr xt --		gforth	does_code_store
-""creates a code field at xt for a defining-word-defined word; a_addr
-is the start of the Forth code after DOES>""
+""Create a code field at @var{xt} for a defining-word-defined word; @var{a-addr}
+is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);
-CACHE_FLUSH(xt,PFA(0));
+CACHE_FLUSH(xt,(size_t)PFA(0));
 :
     dodoes: over ! cell+ ! ;
 
 does-handler!	a_addr --	gforth	does_handler_store
-""creates a DOES>-handler at address a_addr. a_addr usually points
-just behind a DOES>.""
+""Create a @code{DOES>}-handler at address @var{a-addr}. Usually, @var{a-addr} points
+just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);
-CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
+CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :
     drop ;
 
 /does-handler	-- n	gforth	slash_does_handler
-""the size of a does-handler (includes possible padding)""
+""The size of a @code{DOES>}-handler (includes possible padding).""
 /* !! a constant or environmental query might be better */
 n = DOES_HANDLER_SIZE;
 :
@@ -1369,16 +1385,26 @@ n=1;
 :
  1 ;
 
-\+has? os [IF]
-
-(key)	-- n		gforth	paren_key
+key-file	wfileid -- n		gforth	paren_key_file
+#ifdef HAS_FILE
 fflush(stdout);
-/* !! noecho */
-n = key();
+n = key((FILE*)wfileid);
+#else
+n = key(stdin);
+#endif
 
-key?	-- n		facility	key_q
+key?-file	wfileid -- n		facility	key_q_file
+#ifdef HAS_FILE
 fflush(stdout);
-n = key_query;
+n = key_query((FILE*)wfileid);
+#else
+n = key_query(stdin);
+#endif
+
+\+os
+
+stdin	-- wfileid	gforth
+wfileid = (Cell)stdin;
 
 stdout	-- wfileid	gforth
 wfileid = (Cell)stdout;
@@ -1396,7 +1422,7 @@ ucols=cols;
 
 flush-icache	c_addr u --	gforth	flush_icache
 ""Make sure that the instruction cache of the processor (if there is
-one) does not contain stale data at @var{c_addr} and @var{u} bytes
+one) does not contain stale data at @var{c-addr} and @var{u} bytes
 afterwards. @code{END-CODE} performs a @code{flush-icache}
 automatically. Caveat: @code{flush-icache} might not work on your
 installation; this is usually the case if direct threading is not
@@ -1410,14 +1436,22 @@ FLUSH_ICACHE(c_addr,u);
 return (Label *)n;
 
 (system)	c_addr u -- wretval wior	gforth	peren_system
+#ifndef MSDOS
 int old_tp=terminal_prepped;
 deprep_terminal();
+#endif
 wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
 wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
+#ifndef MSDOS
 if (old_tp)
   prep_terminal();
+#endif
 
 getenv	c_addr1 u1 -- c_addr2 u2	gforth
+""The string @var{c-addr1 u1} specifies an environment variable. The string @var{c-addr2 u2}
+is the host operating system's expansion of that environment variable. If the
+environment variable does not exist, @var{c-addr2 u2} specifies a string 0 characters
+in length.""
 c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
 
@@ -1449,19 +1483,31 @@ timeout.tv_usec=1000*(n%1000);
 (void)select(0,0,0,0,&timeout);
 
 allocate	u -- a_addr wior	memory
+""Allocate @var{u} address units of contiguous data space. The initial
+contents of the data space is undefined. If the allocation is successful,
+@var{a-addr} is the start address of the allocated region and @var{wior}
+is 0. If the allocation fails, @var{a-addr} is undefined and @var{wior}
+is an implementation-defined I/O result code.""
 a_addr = (Cell *)malloc(u?u:1);
 wior = IOR(a_addr==NULL);
 
 free		a_addr -- wior		memory
+""Return the region of data space starting at @var{a-addr} to the system.
+The regon must originally have been obtained using @code{allocate} or
+@code{resize}. If the operational is successful, @var{wior} is 0.
+If the operation fails, @var{wior} is an implementation-defined
+I/O result code.""
 free(a_addr);
 wior = 0;
 
 resize		a_addr1 u -- a_addr2 wior	memory
-""Change the size of the allocated area at @i{a_addr1} to @i{u}
+""Change the size of the allocated area at @i{a-addr1} to @i{u}
 address units, possibly moving the contents to a different
-area. @i{a_addr2} is the address of the resulting area. If
-@code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}
-@code{allocate}s @i{u} address units.""
+area. @i{a-addr2} is the address of the resulting area.
+If the operational is successful, @var{wior} is 0.
+If the operation fails, @var{wior} is an implementation-defined
+I/O result code. If @i{a-addr1} is 0, Gforth's (but not the standard)
+@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. */
 if (a_addr1==NULL)
@@ -1493,23 +1539,32 @@ fp=FP;
 IF_TOS(TOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);
 
-\+[THEN] ( has? os ) has? file [IF]
+\+
+\+file
 
 close-file	wfileid -- wior		file	close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);
 
-open-file	c_addr u ntype -- w2 wior	file	open_file
-w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
-wior =  IOR(w2 == 0);
+open-file	c_addr u ntype -- wfileid wior	file	open_file
+wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
+#if defined(GO32) && defined(MSDOS)
+if(wfileid && !(ntype & 1))
+  setbuf((FILE*)wfileid, NULL);
+#endif
+wior =  IOR(wfileid == 0);
 
-create-file	c_addr u ntype -- w2 wior	file	create_file
+create-file	c_addr u ntype -- wfileid wior	file	create_file
 Cell	fd;
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);
 if (fd != -1) {
-  w2 = (Cell)fdopen(fd, fileattr[ntype]);
-  wior = IOR(w2 == 0);
+  wfileid = (Cell)fdopen(fd, fileattr[ntype]);
+#if defined(GO32) && defined(MSDOS)
+  if(wfileid && !(ntype & 1))
+    setbuf((FILE*)wfileid, NULL);
+#endif
+  wior = IOR(wfileid == 0);
 } else {
-  w2 = 0;
+  wfileid = 0;
   wior = IOR(1);
 }
 
@@ -1517,6 +1572,7 @@ delete-file	c_addr u -- wior		file	delet
 wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
 
 rename-file	c_addr1 u1 c_addr2 u2 -- wior	file-ext	rename_file
+""Rename file @var{c_addr1 u1} to new name @var{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
 
@@ -1529,7 +1585,6 @@ reposition-file	ud wfileid -- wior	file
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
 
 file-size	wfileid -- ud wior	file	file_size
-#include <sys/stat.h>
 struct stat buf;
 wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 ud = LONG2UD(buf.st_size);
@@ -1574,7 +1629,8 @@ else {
   u2=0;
 }
 
-\+[THEN]  has? file [IF] -1 [ELSE] has? os [THEN] [IF]
+\+
+\+file
 
 write-file	c_addr u1 wfileid -- wior	file	write_file
 /* !! fwrite does not guarantee enough */
@@ -1585,12 +1641,18 @@ write-file	c_addr u1 wfileid -- wior	fil
     clearerr((FILE *)wfileid);
 }
 
+\+
+
 emit-file	c wfileid -- wior	gforth	emit_file
+#ifdef HAS_FILE
 wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
 if (wior)
   clearerr((FILE *)wfileid);
+#else
+putc(c, stdout);
+#endif
 
-\+[THEN]  has? file [IF]
+\+file
 
 flush-file	wfileid -- wior		file-ext	flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);
@@ -1619,7 +1681,8 @@ else {
   wior=0;
 }
 
-\+[THEN] ( has? file ) has? floating [IF]
+\+
+\+floating
 
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
@@ -1634,7 +1697,7 @@ r = d;
 
 f>d		r -- d		float	f_to_d
 #ifdef BUGGY_LONG_LONG
-d.hi = ldexp(r,-CELL_BITS) - (r<0);
+d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);
 #else
 d = r;
@@ -1687,7 +1750,7 @@ f/		r1 r2 -- r3	float	f_slash
 r3 = r1/r2;
 
 f**		r1 r2 -- r3	float-ext	f_star_star
-""@i{r3} is @i{r1} raised to the @i{r2}th power""
+""@i{r3} is @i{r1} raised to the @i{r2}th power.""
 r3 = pow(r1,r2);
 
 fnegate		r1 -- r2	float
@@ -1714,12 +1777,12 @@ floats		n1 -- n2	float
 n2 = n1*sizeof(Float);
 
 floor		r1 -- r2	float
-""round towards the next smaller integral value, i.e., round toward negative infinity""
+""Round towards the next smaller integral value, i.e., round toward negative infinity.""
 /* !! unclear wording */
 r2 = floor(r1);
 
 fround		r1 -- r2	float
-""round to the nearest integral value""
+""Round to the nearest integral value.""
 /* !! unclear wording */
 #ifdef HAVE_RINT
 r2 = rint(r1);
@@ -1747,15 +1810,21 @@ int decpt;
 sig=ecvt(r, u, &decpt, &flag);
 n=(r==0 ? 1 : decpt);
 f1=FLAG(flag!=0);
-f2=FLAG(isdigit(sig[0])!=0);
+f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);
 
 >float	c_addr u -- flag	float	to_float
+""Attempt to convert the character string @var{c-addr u} to
+internal floating-point representation. If the string
+represents a valid floating-point number @var{r} is placed
+on the floating-point stack and @var{flag} is true. Otherwise,
+@var{flag} is false. A string of blanks is a special case
+and represents the flotaing-point number 0.""
 /* real signature: c_addr u -- r t / f */
 Float r;
 char *number=cstr(c_addr, u, 1);
 char *endconv;
-while(isspace(number[--u]) && u>0);
+while(isspace((unsigned)(number[--u])) && u>0);
 switch(number[u])
 {
    case 'd':
@@ -1797,7 +1866,7 @@ fatan		r1 -- r2	float-ext
 r2 = atan(r1);
 
 fatan2		r1 r2 -- r3	float-ext
-""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably
+""@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);
 
@@ -1837,7 +1906,7 @@ r2 = log(r1+1.);
 #endif
 
 flog		r1 -- r2	float-ext
-""the decimal logarithm""
+""The decimal logarithm.""
 r2 = log10(r1);
 
 falog		r1 -- r2	float-ext
@@ -1914,7 +1983,8 @@ df_addr = (DFloat *)((((Cell)c_addr)+(si
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
 
 \ local variable implementation primitives
-\+[THEN] ( has? floats ) has? glocals [IF]
+\+
+\+glocals
 
 @local#		-- w	gforth	fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);
@@ -1932,7 +2002,7 @@ w = *(Cell *)(lp+2*sizeof(Cell));
 @local3	-- w	new	fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));
 
-\+has? floating [IF]
+\+floating
 
 f@local#	-- r	gforth	f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);
@@ -1944,7 +2014,7 @@ r = *(Float *)(lp+0*sizeof(Float));
 f@local1	-- r	new	f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));
 
-\+[THEN]
+\+
 
 laddr#		-- c_addr	gforth	laddr_number
 /* this can also be used to implement lp@ */
@@ -1974,15 +2044,21 @@ lp = (Address)c_addr;
 lp -= sizeof(Cell);
 *(Cell *)lp = w;
 
-\+has? floating [IF]
+\+floating
 
 f>l	r --	gforth	f_to_l
 lp -= sizeof(Float);
 *(Float *)lp = r;
 
-\+[THEN]  [THEN] \ has? glocals
+fpick	u -- r		gforth
+r = fp[u+1]; /* +1, because update of fp happens before this fragment */
+:
+ floats fp@ + f@ ;
+
+\+
+\+
 
-\+has? OS [IF]
+\+OS
 
 define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
@@ -2004,21 +2080,24 @@ define(argclist,
 \ icall(argnum)
 define(icall,
 `icall$1	argflist($1)u -- uret	gforth
-uret = ((Cell(*)(argdlist($1)))u)(argclist($1));
+uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
 
 ')
 define(fcall,
 `fcall$1	argflist($1)u -- rret	gforth
-rret = ((Float(*)(argdlist($1)))u)(argclist($1));
+rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
 
 ')
 
 
 open-lib	c_addr1 u1 -- u2	gforth	open_lib
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
-u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_LAZY);
+#ifndef RTLD_GLOBAL
+#define RTLD_GLOBAL 0
+#endif
+u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else
-#  ifdef HAVE_LIBKERNEL32
+#  ifdef _WIN32
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
 #  else
 #warning Define open-lib!
@@ -2030,7 +2109,7 @@ lib-sym	c_addr1 u1 u2 -- u3	gforth	lib_s
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
 #else
-#  ifdef HAVE_LIBKERNEL32
+#  ifdef _WIN32
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
 #  else
 #warning Define lib-sym!
@@ -2043,11 +2122,10 @@ icall(20)
 uploop(i, 0, 7, `fcall(i)')
 fcall(20)
 
-\+[THEN] \ has? OS
+\+
 
 up!	a_addr --	gforth	up_store
 UP=up=(char *)a_addr;
 :
  up ! ;
 Variable UP
-