--- gforth/prim	1999/11/08 22:01:09	1.40
+++ gforth/prim	2002/12/13 15:49:53	1.104
@@ -1,6 +1,6 @@
 \ Gforth primitives
 
-\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -16,7 +16,7 @@
 
 \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software
-\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 
 
 \ WARNING: This file is processed by m4. Make sure your identifiers
@@ -26,19 +26,19 @@
 \ 
 \ This file contains primitive specifications in the following format:
 \ 
-\ forth name	stack effect	category	[pronunciation]
+\ forth name	( stack effect )	category	[pronunciation]
 \ [""glossary entry""]
 \ C code
 \ [:
 \ Forth code]
 \ 
-\ prims2x is pedantic about tabs vs. blanks. The fields of the first
-\ line of a primitive are separated by tabs, the stack items in a
-\ stack effect by blanks.
+\ Note: Fields in brackets are optional.  Word specifications have to
+\ be separated by at least one empty line
 \
 \ Both pronounciation and stack items (in the stack effect) must
-\ conform to the C name syntax or the C compiler will complain.
-\ 
+\ conform to the C identifier syntax or the C compiler will complain.
+\ If you don't have a pronounciation field, the Forth name is used,
+\ and has to conform to the C identifier syntax.
 \ 
 \ These specifications are automatically translated into C-code for the
 \ interpreter and into some other files. I hope that your C compiler has
@@ -53,15 +53,18 @@
 \ your code does not fall through, the results are not stored into the
 \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).
-\ 
-\ 
+\
+\ For superinstructions the syntax is:
+\
+\ forth-name [/ c-name] = forth-name forth-name ...
+\
 \ 
 \ The stack variables have the following types:
 \ 
 \ name matches	type
 \ f.*		Bool
 \ c.*		Char
-\ [nw].*		Cell
+\ [nw].*	Cell
 \ u.*		UCell
 \ d.*		DCell
 \ ud.*		UDCell
@@ -72,8 +75,37 @@
 \ df_.*		DFloat *
 \ sf_.*		SFloat *
 \ xt.*		XT
-\ wid.*		WID
 \ f83name.*	F83Name *
+
+\E stack data-stack   sp Cell
+\E stack fp-stack     fp Float
+\E stack return-stack rp Cell
+\E
+\E get-current prefixes set-current
+\E 
+\E s" Bool"		single data-stack type-prefix f
+\E s" Char"		single data-stack type-prefix c
+\E s" Cell"		single data-stack type-prefix n
+\E s" Cell"		single data-stack type-prefix w
+\E s" UCell"		single data-stack type-prefix u
+\E s" DCell"		double data-stack type-prefix d
+\E s" UDCell"		double data-stack type-prefix ud
+\E s" Float"		single fp-stack   type-prefix r
+\E s" Cell *"		single data-stack type-prefix a_
+\E s" Char *"		single data-stack type-prefix c_
+\E s" Float *"		single data-stack type-prefix f_
+\E s" DFloat *"		single data-stack type-prefix df_
+\E s" SFloat *"		single data-stack type-prefix sf_
+\E s" Xt"		single data-stack type-prefix xt
+\E s" struct F83Name *"	single data-stack type-prefix f83name
+\E s" struct Longname *" single data-stack type-prefix longname
+\E 
+\E return-stack stack-prefix R:
+\E inst-stream  stack-prefix #
+\E 
+\E set-current
+\E store-optimization on
+
 \ 
 \ 
 \ 
@@ -102,29 +134,35 @@
 \ these m4 macros would collide with identifiers
 undefine(`index')
 undefine(`shift')
+undefine(`symbols')
 
-noop	--		gforth
-;
+\g control
+
+noop	( -- )		gforth
 :
  ;
 
-lit	-- w		gforth
-w = (Cell)NEXT_INST;
-INC_IP(1);
+lit	( #w -- w )		gforth
 :
  r> dup @ swap cell+ >r ;
 
-execute		xt --		core
+execute	( xt -- )		core
 ""Perform the semantics represented by the execution token, @i{xt}.""
+#ifndef NO_IP
 ip=IP;
-IF_TOS(TOS = sp[0]);
+#endif
+IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(xt);
 
-perform		a_addr --	gforth
-""Equivalent to @code{@ execute}.""
+perform	( a_addr -- )	gforth
+""@code{@@ execute}.""
 /* and pfe */
+#ifndef NO_IP
 ip=IP;
-IF_TOS(TOS = sp[0]);
+#endif
+IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(*(Xt *)a_addr);
 :
  @ execute ;
@@ -132,45 +170,42 @@ EXEC(*(Xt *)a_addr);
 \fhas? skipbranchprims 0= [IF]
 \+glocals
 
-branch-lp+!#	--	gforth	branch_lp_plus_store_number
+branch-lp+!#	( #ndisp #nlocals -- )	gforth	branch_lp_plus_store_number
 /* this will probably not be used */
-branch_adjust_lp:
-lp += (Cell)(IP[1]);
-goto branch;
+lp += nlocals;
+SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
 
 \+
 
-branch	--		gforth
-branch:
-SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
+branch	( #ndisp -- )		gforth
+SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
 :
  r> dup @ + >r ;
 
-\ condbranch(forthname,restline,code,forthcode)
+\ condbranch(forthname,stackeffect,restline,code,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,
-$1	$2
-$3	SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
-	NEXT;
+$1 ( `#'ndisp $2 ) $3
+$4	SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+INST_TAIL;
 }
-else
-    INC_IP(1);
-$4
+SUPER_CONTINUE;
+$5
 
 \+glocals
 
-$1-lp+!#	$2_lp_plus_store_number
-$3    goto branch_adjust_lp;
+$1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number
+$4    lp += nlocals;
+SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
+INST_TAIL;
 }
-else
-    INC_IP(2);
+SUPER_CONTINUE;
 
 \+
 )
 
-condbranch(?branch,f --		f83	question_branch,
+condbranch(?branch,f --,f83	question_branch,
 if (f==0) {
-    IF_TOS(TOS = sp[0]);
 ,:
  0= dup     \ !f !f
  r> dup @   \ !f !f IP branchoffset
@@ -183,18 +218,17 @@ if (f==0) {
 
 \+xconds
 
-?dup-?branch	f -- f	new	question_dupe_question_branch
+?dup-?branch	( #ndisp 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]);
-  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
-  NEXT;
+  IF_spTOS(spTOS = sp[0]);
+  SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+  INST_TAIL;
 }
-else
-  INC_IP(1);
+SUPER_CONTINUE;
 
-?dup-0=-?branch	f --	new	question_dupe_zero_equals_question_branch
+?dup-0=-?branch	( #ndisp f -- )	new	question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
 /* the approach taken here of declaring the word as having the stack
 effect ( f -- ) and correcting for it in the branch-taken case costs a
@@ -202,46 +236,38 @@ few cycles in that case, but is easy to
 invocation */
 if (f!=0) {
   sp--;
-  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
+  SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT;
 }
-else
-  INC_IP(1);
+SUPER_CONTINUE;
 
 \+
 \f[THEN]
 \fhas? skiploopprims 0= [IF]
 
-condbranch((next),--		cmFORTH	paren_next,
-if ((*rp)--) {
+condbranch((next),R:n1 -- R:n2,cmFORTH	paren_next,
+n2=n1-1;
+if (n1) {
 ,:
  r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)
 
-condbranch((loop),--		gforth	paren_loop,
-Cell index = *rp+1;
-Cell limit = rp[1];
-if (index != limit) {
-    *rp = index;
+condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth	paren_loop,
+n2=n1+1;
+if (n2 != nlimit) {
 ,:
  r> r> 1+ r> 2dup =
  IF >r 1- >r cell+ >r
  ELSE >r >r dup @ + >r THEN ;)
 
-condbranch((+loop),n --		gforth	paren_plus_loop,
+condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,
 /* !! check this thoroughly */
-Cell index = *rp;
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */
-Cell olddiff = index-rp[1];
+Cell olddiff = n1-nlimit;
+n2=n1+n;	
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {
-#ifdef i386
-    *rp += n;
-#else
-    *rp = index + n;
-#endif
-    IF_TOS(TOS = sp[0]);
 ,:
  r> swap
  r> r> 2dup - >r
@@ -252,71 +278,50 @@ if ((olddiff^(olddiff+n))>=0   /* the li
 
 \+xconds
 
-condbranch((-loop),u --		gforth	paren_minus_loop,
-/* !! check this thoroughly */
-Cell index = *rp;
-UCell olddiff = index-rp[1];
+condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
+UCell olddiff = n1-nlimit;
+n2=n1-u;
 if (olddiff>u) {
-#ifdef i386
-    *rp -= u;
-#else
-    *rp = index - u;
-#endif
-    IF_TOS(TOS = sp[0]);
 ,)
 
-condbranch((s+loop),n --		gforth	paren_symmetric_plus_loop,
+condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth	paren_symmetric_plus_loop,
 ""The run-time procedure compiled by S+LOOP. It loops until the index
 crosses the boundary between limit and limit-sign(n). I.e. a symmetric
 version of (+LOOP).""
 /* !! check this thoroughly */
-Cell index = *rp;
-Cell diff = index-rp[1];
+Cell diff = n1-nlimit;
 Cell newdiff = diff+n;
 if (n<0) {
     diff = -diff;
     newdiff = -newdiff;
 }
+n2=n1+n;
 if (diff>=0 || newdiff<0) {
-#ifdef i386
-    *rp += n;
-#else
-    *rp = index + n;
-#endif
-    IF_TOS(TOS = sp[0]);
 ,)
 
 \+
 
-unloop		--	core
-rp += 2;
+unloop	( R:w1 R:w2 -- )	core
+/* !! alias for 2rdrop */
 :
  r> rdrop rdrop >r ;
 
-(for)	ncount --		cmFORTH		paren_for
+(for)	( ncount -- R:nlimit R:ncount )		cmFORTH		paren_for
 /* or (for) = >r -- collides with unloop! */
-*--rp = 0;
-*--rp = ncount;
+nlimit=0;
 :
  r> swap 0 >r >r >r ;
 
-(do)	nlimit nstart --		gforth		paren_do
-/* or do it in high-level? 0.09/0.23% */
-*--rp = nlimit;
-*--rp = nstart;
+(do)	( nlimit nstart -- R:nlimit R:nstart )	gforth		paren_do
 :
  r> swap rot >r >r >r ;
 
-(?do)	nlimit nstart --	gforth	paren_question_do
-*--rp = nlimit;
-*--rp = nstart;
+(?do)	( #ndisp nlimit nstart -- R:nlimit R:nstart )	gforth	paren_question_do
 if (nstart == nlimit) {
-    IF_TOS(TOS = sp[0]);
-    goto branch;
-    }
-else {
-    INC_IP(1);
+    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
   2dup =
   IF   r> swap rot >r >r
@@ -327,16 +332,12 @@ else {
 
 \+xconds
 
-(+do)	nlimit nstart --	gforth	paren_plus_do
-*--rp = nlimit;
-*--rp = nstart;
+(+do)	( #ndisp nlimit nstart -- R:nlimit R:nstart )	gforth	paren_plus_do
 if (nstart >= nlimit) {
-    IF_TOS(TOS = sp[0]);
-    goto branch;
-    }
-else {
-    INC_IP(1);
+    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -347,16 +348,12 @@ else {
      cell+
  THEN  >r ;
 
-(u+do)	ulimit ustart --	gforth	paren_u_plus_do
-*--rp = ulimit;
-*--rp = ustart;
+(u+do)	( #ndisp ulimit ustart -- R:ulimit R:ustart )	gforth	paren_u_plus_do
 if (ustart >= ulimit) {
-    IF_TOS(TOS = sp[0]);
-    goto branch;
-    }
-else {
-    INC_IP(1);
+    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -367,16 +364,12 @@ else {
      cell+
  THEN  >r ;
 
-(-do)	nlimit nstart --	gforth	paren_minus_do
-*--rp = nlimit;
-*--rp = nstart;
+(-do)	( #ndisp nlimit nstart -- R:nlimit R:nstart )	gforth	paren_minus_do
 if (nstart <= nlimit) {
-    IF_TOS(TOS = sp[0]);
-    goto branch;
-    }
-else {
-    INC_IP(1);
+    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -387,16 +380,12 @@ else {
      cell+
  THEN  >r ;
 
-(u-do)	ulimit ustart --	gforth	paren_u_minus_do
-*--rp = ulimit;
-*--rp = ustart;
+(u-do)	( #ndisp ulimit ustart -- R:ulimit R:ustart )	gforth	paren_u_minus_do
 if (ustart <= ulimit) {
-    IF_TOS(TOS = sp[0]);
-    goto branch;
-    }
-else {
-    INC_IP(1);
+    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -412,29 +401,24 @@ else {
 \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!
 
-i	-- n		core
-n = *rp;
+i	( R:n -- R:n n )		core
 :
 \ rp@ cell+ @ ;
   r> r> tuck >r >r ;
 
-i'	-- w		gforth		i_tick
-""loop end value""
-w = rp[1];
+i'	( R:w R:w2 -- R:w R:w2 w )		gforth		i_tick
 :
 \ rp@ cell+ cell+ @ ;
   r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp
 
-j	-- n		core
-n = rp[2];
+j	( R:n R:d1 -- n R:n R:d1 )		core
 :
 \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]
 
-k	-- n		gforth
-n = rp[4];
+k	( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )		gforth
 :
 \ rp@ [ 5 cells ] Literal + @ ;
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
@@ -444,15 +428,18 @@ n = rp[4];
 
 \ digit is high-level: 0/0%
 
-move	c_from c_to ucount --		core
-""Copy the contents of @i{ucount} address units at @i{c-from} to
+\g strings
+
+move	( c_from c_to ucount -- )		core
+""Copy the contents of @i{ucount} aus at @i{c-from} to
 @i{c-to}. @code{move} works correctly even if the two areas overlap.""
+/* !! note that the standard specifies addr, not c-addr */
 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
+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
@@ -462,7 +449,7 @@ while (u-- > 0)
 :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
 
-cmove>	c_from c_to u --	string	c_move_up
+cmove>	( c_from c_to u -- )	string	c_move_up
 ""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
@@ -474,20 +461,20 @@ while (u-- > 0)
  rot over + -rot bounds swap 1-
  DO  1- dup c@ I c!  -1 +LOOP  drop ;
 
-fill	c_addr u c --	core
-"" If @i{u}>0, store character @i{c} in each of @i{u} consecutive
-@code{char} addresses in memory, starting at address @i{c-addr}.""
+fill	( c_addr u c -- )	core
+""Store @i{c} in @i{u} chars starting at @i{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	( c_addr1 u1 c_addr2 u2 -- n )	string
 ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
 the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
 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;
@@ -496,15 +483,12 @@ 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
+-text	( c_addr1 u c_addr2 -- n )	new	dash_text
 n = memcmp(c_addr1, c_addr2, u);
 if (n<0)
   n = -1;
@@ -513,18 +497,18 @@ 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  ;
+ ELSE  c@ I c@ - unloop  THEN  sgn ;
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
 
-toupper	c1 -- c2	gforth
+toupper	( c1 -- c2 )	gforth
 ""If @i{c1} is a lower-case character (in the current locale), @i{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 - ;
 
-capscomp	c_addr1 u c_addr2 -- n	new
+capscomp	( c_addr1 u c_addr2 -- n )	new
 n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
 if (n<0)
   n = -1;
@@ -535,9 +519,9 @@ else if (n>0)
  ?DO  dup c@ I c@ <>
      IF  dup c@ toupper I c@ toupper =
      ELSE  true  THEN  WHILE  1+  LOOP  drop 0
- ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;
+ ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
 
--trailing	c_addr u1 -- c_addr u2		string	dash_trailing
+-trailing	( c_addr u1 -- c_addr u2 )		string	dash_trailing
 ""Adjust the string specified by @i{c-addr, u1} to remove all trailing
 spaces. @i{u2} is the length of the modified string.""
 u2 = u1;
@@ -547,7 +531,7 @@ while (u2>0 && c_addr[u2-1] == ' ')
  BEGIN  1- 2dup + c@ bl =  WHILE
         dup  0= UNTIL  ELSE  1+  THEN ;
 
-/string		c_addr1 u1 n -- c_addr2 u2	string	slash_string
+/string	( c_addr1 u1 n -- c_addr2 u2 )	string	slash_string
 ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
 characters from the start of the string.""
 c_addr2 = c_addr1+n;
@@ -555,38 +539,40 @@ u2 = u1-n;
 :
  tuck - >r + r> dup 0< IF  - 0  THEN ;
 
-+	n1 n2 -- n		core	plus
+\g arith
+
++	( n1 n2 -- n )		core	plus
 n = n1+n2;
 
 \ PFE-0.9.14 has it differently, but the next release will have it as follows
-under+	n1 n2 n3 -- n n2	gforth	under_plus
+under+	( n1 n2 n3 -- n n2 )	gforth	under_plus
 ""add @i{n3} to @i{n1} (giving @i{n})""
 n = n1+n3;
 :
  rot + swap ;
 
--	n1 n2 -- n		core	minus
+-	( n1 n2 -- n )		core	minus
 n = n1-n2;
 :
  negate + ;
 
-negate	n1 -- n2		core
+negate	( n1 -- n2 )		core
 /* use minus as alias */
 n2 = -n1;
 :
  invert 1+ ;
 
-1+	n1 -- n2		core		one_plus
+1+	( n1 -- n2 )		core		one_plus
 n2 = n1+1;
 :
  1 + ;
 
-1-	n1 -- n2		core		one_minus
+1-	( n1 -- n2 )		core		one_minus
 n2 = n1-1;
 :
  1 - ;
 
-max	n1 n2 -- n	core
+max	( n1 n2 -- n )	core
 if (n1<n2)
   n = n2;
 else
@@ -594,7 +580,7 @@ else
 :
  2dup < IF swap THEN drop ;
 
-min	n1 n2 -- n	core
+min	( n1 n2 -- n )	core
 if (n1<n2)
   n = n1;
 else
@@ -602,42 +588,44 @@ else
 :
  2dup > IF swap THEN drop ;
 
-abs	n1 -- n2	core
-if (n1<0)
-  n2 = -n1;
+abs	( n -- u )	core
+if (n<0)
+  u = -n;
 else
-  n2 = n1;
+  u = n;
 :
  dup 0< IF negate THEN ;
 
-*	n1 n2 -- n		core	star
+*	( n1 n2 -- n )		core	star
 n = n1*n2;
 :
  um* drop ;
 
-/	n1 n2 -- n		core	slash
+/	( n1 n2 -- n )		core	slash
 n = n1/n2;
 :
  /mod nip ;
 
-mod	n1 n2 -- n		core
+mod	( n1 n2 -- n )		core
 n = n1%n2;
 :
  /mod drop ;
 
-/mod	n1 n2 -- n3 n4		core		slash_mod
+/mod	( n1 n2 -- n3 n4 )		core		slash_mod
 n4 = n1/n2;
 n3 = n1%n2; /* !! is this correct? look into C standard! */
 :
  >r s>d r> fm/mod ;
 
-2*	n1 -- n2		core		two_star
+2*	( n1 -- n2 )		core		two_star
+""Shift left by 1; also works on unsigned numbers""
 n2 = 2*n1;
 :
  dup + ;
 
-2/	n1 -- n2		core		two_slash
-/* !! is this still correct? */
+2/	( n1 -- n2 )		core		two_slash
+""Arithmetic shift right by 1.  For signed numbers this is a floored
+division by 2 (note that @code{/} not necessarily floors).""
 n2 = n1>>1;
 :
  dup MINI and IF 1 ELSE 0 THEN
@@ -646,7 +634,7 @@ n2 = n1>>1;
      IF 1 ELSE 0 THEN or r> swap
  LOOP nip ;
 
-fm/mod	d1 n1 -- n2 n3		core		f_m_slash_mod
+fm/mod	( d1 n1 -- n2 n3 )		core		f_m_slash_mod
 ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
 #ifdef BUGGY_LONG_LONG
 DCell r = fmdiv(d1,n1);
@@ -668,7 +656,7 @@ if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
  um/mod
  r> 0< IF  swap negate swap  THEN ;
 
-sm/rem	d1 n1 -- n2 n3		core		s_m_slash_rem
+sm/rem	( d1 n1 -- n2 n3 )		core		s_m_slash_rem
 ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
 #ifdef BUGGY_LONG_LONG
 DCell r = smdiv(d1,n1);
@@ -690,7 +678,7 @@ if (1%-3<0 && (d1<0) != (n1<0) && n2!=0)
  r> r@ xor 0< IF       negate       THEN
  r>        0< IF  swap negate swap  THEN ;
 
-m*	n1 n2 -- d		core	m_star
+m*	( n1 n2 -- d )		core	m_star
 #ifdef BUGGY_LONG_LONG
 d = mmul(n1,n2);
 #else
@@ -701,7 +689,7 @@ d = (DCell)n1 * (DCell)n2;
  2dup swap 0< and >r
  um* r> - r> - ;
 
-um*	u1 u2 -- ud		core	u_m_star
+um*	( u1 u2 -- ud )		core	u_m_star
 /* use u* as alias */
 #ifdef BUGGY_LONG_LONG
 ud = ummul(u1,u2);
@@ -718,7 +706,7 @@ ud = (UDCell)u1 * (UDCell)u2;
    over MINI
    and >r >r 2dup d+ swap r> + swap r> ;
 
-um/mod	ud u1 -- u2 u3		core	u_m_slash_mod
+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);
@@ -738,7 +726,7 @@ u2 = ud%u1;
    over MINI
    and >r >r 2dup d+ swap r> + swap r> ;
 
-m+	d1 n -- d2		double		m_plus
+m+	( d1 n -- d2 )		double		m_plus
 #ifdef BUGGY_LONG_LONG
 d2.lo = d1.lo+n;
 d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
@@ -748,7 +736,7 @@ d2 = d1+n;
 :
  s>d d+ ;
 
-d+	d1 d2 -- d		double	d_plus
+d+	( d1 d2 -- d )		double	d_plus
 #ifdef BUGGY_LONG_LONG
 d.lo = d1.lo+d2.lo;
 d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
@@ -758,7 +746,7 @@ d = d1+d2;
 :
  rot + >r tuck + swap over u> r> swap - ;
 
-d-	d1 d2 -- d		double		d_minus
+d-	( d1 d2 -- d )		double		d_minus
 #ifdef BUGGY_LONG_LONG
 d.lo = d1.lo - d2.lo;
 d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
@@ -768,7 +756,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);
@@ -778,7 +766,8 @@ d2 = -d1;
 :
  invert swap negate tuck 0= - ;
 
-d2*	d1 -- d2		double		d_two_star
+d2*	( d1 -- d2 )		double		d_two_star
+""Shift left by 1; also works on unsigned numbers""
 #ifdef BUGGY_LONG_LONG
 d2.lo = d1.lo<<1;
 d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
@@ -788,7 +777,9 @@ d2 = 2*d1;
 :
  2dup d+ ;
 
-d2/	d1 -- d2		double		d_two_slash
+d2/	( d1 -- d2 )		double		d_two_slash
+""Arithmetic shift right by 1.  For signed numbers this is a floored
+division by 2.""
 #ifdef BUGGY_LONG_LONG
 d2.hi = d1.hi>>1;
 d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
@@ -799,35 +790,36 @@ d2 = d1>>1;
  dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
  r> IF  [ 1 8 cells 1- lshift ] Literal + THEN  swap ;
 
-and	w1 w2 -- w		core
+and	( w1 w2 -- w )		core
 w = w1&w2;
 
-or	w1 w2 -- w		core
+or	( w1 w2 -- w )		core
 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
+invert	( w1 -- w2 )		core
 w2 = ~w1;
 :
  MAXU xor ;
 
-rshift	u1 n -- u2		core
+rshift	( u1 n -- u2 )		core	r_shift
+""Logical shift right by @i{n} bits.""
   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 ;
 
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,
-$1=	$2 -- f		$6	$3equals
+$1=	( $2 -- f )		$6	$3equals
 f = FLAG($4==$5);
 :
     [ char $1x char 0 = [IF]
@@ -836,7 +828,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]
@@ -845,7 +837,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]
@@ -857,18 +849,18 @@ 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] ]
     $1< ;
 
-$1<=	$2 -- f		gforth	$3less_or_equal
+$1<=	( $2 -- f )		gforth	$3less_or_equal
 f = FLAG($4<=$5);
 :
     $1> 0= ;
 
-$1>=	$2 -- f		gforth	$3greater_or_equal
+$1>=	( $2 -- f )		gforth	$3greater_or_equal
 f = FLAG($4>=$5);
 :
     [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
@@ -882,42 +874,42 @@ comparisons(u, u1 u2, u_, u1, u2, gforth
 
 \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(dcomparisons,
-$1=	$2 -- f		$6	$3equals
+$1=	( $2 -- f )		$6	$3equals
 #ifdef BUGGY_LONG_LONG
 f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
 #else
 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
 f = FLAG($4>$5);
 #endif
 
-$1<=	$2 -- f		gforth	$3less_or_equal
+$1<=	( $2 -- f )		gforth	$3less_or_equal
 #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		gforth	$3greater_or_equal
+$1>=	( $2 -- f )		gforth	$3greater_or_equal
 #ifdef BUGGY_LONG_LONG
 f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
 #else
@@ -934,103 +926,102 @@ dcomparisons(du, ud1 ud2, d_u_, ud1, ud2
 
 \+
 
-within	u1 u2 u3 -- f		core-ext
+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.""
+u2=u3); if u1 is in this range, @code{within} returns true.""
 f = FLAG(u1-u2 < u3-u2);
 :
  over - >r - r> u< ;
 
-sp@	-- a_addr		gforth		sp_fetch
+\g internal
+
+sp@	( -- a_addr )		gforth		sp_fetch
 a_addr = sp+1;
 
-sp!	a_addr --		gforth		sp_store
+sp!	( a_addr -- )		gforth		sp_store
 sp = a_addr;
-/* works with and without TOS caching */
+/* works with and without spTOS caching */
 
-rp@	-- a_addr		gforth		rp_fetch
+rp@	( -- a_addr )		gforth		rp_fetch
 a_addr = rp;
 
-rp!	a_addr --		gforth		rp_store
+rp!	( a_addr -- )		gforth		rp_store
 rp = a_addr;
 
 \+floating
 
-fp@	-- f_addr	gforth	fp_fetch
+fp@	( -- f_addr )	gforth	fp_fetch
 f_addr = fp;
 
-fp!	f_addr --	gforth	fp_store
+fp!	( f_addr -- )	gforth	fp_store
 fp = f_addr;
 
 \+
 
-;s	--		gforth	semis
+;s	( R:w -- )		gforth	semis
 ""The primitive compiled by @code{EXIT}.""
-SET_IP((Xt *)(*rp++));
+#ifdef NO_IP
+INST_TAIL;
+goto *(void *)w;
+#else
+SET_IP((Xt *)w);
+#endif
 
->r	w --		core	to_r
-*--rp = w;
+\g stack
+
+>r	( w -- R:w )		core	to_r
 :
  (>r) ;
 : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
 
-r>	-- w		core	r_from
-w = *rp++;
+r>	( R:w -- w )		core	r_from
 :
  rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 Create (rdrop) ' ;s A,
 
-rdrop	--		gforth
-rp++;
+rdrop	( R:w -- )		gforth
 :
  r> r> drop >r ;
 
-2>r	w1 w2 --	core-ext	two_to_r
-*--rp = w1;
-*--rp = w2;
+2>r	( w1 w2 -- R:w1 R:w2 )	core-ext	two_to_r
 :
  swap r> swap >r swap >r >r ;
 
-2r>	-- w1 w2	core-ext	two_r_from
-w2 = *rp++;
-w1 = *rp++;
+2r>	( R:w1 R:w2 -- w1 w2 )	core-ext	two_r_from
 :
  r> r> swap r> swap >r swap ;
 
-2r@	-- w1 w2	core-ext	two_r_fetch
-w2 = rp[0];
-w1 = rp[1];
+2r@	( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )	core-ext	two_r_fetch
 :
  i' j ;
 
-2rdrop	--		gforth	two_r_drop
-rp+=2;
+2rdrop	(  R:w1 R:w2 -- )		gforth	two_r_drop
 :
  r> r> drop r> drop >r ;
 
-over	w1 w2 -- w1 w2 w1		core
+over	( w1 w2 -- w1 w2 w1 )		core
 :
  sp@ cell+ @ ;
 
-drop	w --		core
+drop	( w -- )		core
 :
  IF THEN ;
 
-swap	w1 w2 -- w2 w1		core
+swap	( w1 w2 -- w2 w1 )		core
 :
  >r (swap) ! r> (swap) @ ;
 Variable (swap)
 
-dup	w -- w w		core
+dup	( w -- w w )		core	dupe
 :
  sp@ @ ;
 
-rot	w1 w2 w3 -- w2 w3 w1	core	rote
+rot	( w1 w2 w3 -- w2 w3 w1 )	core	rote
 :
 [ defined? (swap) [IF] ]
     (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
@@ -1039,21 +1030,23 @@ Variable (rot)
     >r swap r> swap ;
 [THEN]
 
--rot	w1 w2 w3 -- w3 w1 w2	gforth	not_rote
+-rot	( w1 w2 w3 -- w3 w1 w2 )	gforth	not_rote
 :
  rot rot ;
 
-nip	w1 w2 -- w2		core-ext
+nip	( w1 w2 -- w2 )		core-ext
 :
  swap drop ;
 
-tuck	w1 w2 -- w2 w1 w2	core-ext
+tuck	( w1 w2 -- w2 w1 w2 )	core-ext
 :
  swap over ;
 
-?dup	w -- w			core	question_dupe
+?dup	( w -- w )			core	question_dupe
+""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
+@code{dup} if w is nonzero.""
 if (w!=0) {
-  IF_TOS(*sp-- = w;)
+  IF_spTOS(*sp-- = w;)
 #ifndef USE_TOS
   *--sp = w;
 #endif
@@ -1061,57 +1054,58 @@ if (w!=0) {
 :
  dup IF dup THEN ;
 
-pick	u -- w			core-ext
+pick	( u -- w )			core-ext
+""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
 w = sp[u+1];
 :
  1+ cells sp@ + @ ;
 
-2drop	w1 w2 --		core	two_drop
+2drop	( w1 w2 -- )		core	two_drop
 :
  drop drop ;
 
-2dup	w1 w2 -- w1 w2 w1 w2	core	two_dupe
+2dup	( w1 w2 -- w1 w2 w1 w2 )	core	two_dupe
 :
  over over ;
 
-2over	w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2	core	two_over
+2over	( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 )	core	two_over
 :
  3 pick 3 pick ;
 
-2swap	w1 w2 w3 w4 -- w3 w4 w1 w2	core	two_swap
+2swap	( w1 w2 w3 w4 -- w3 w4 w1 w2 )	core	two_swap
 :
  rot >r rot r> ;
 
-2rot	w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2	double-ext	two_rote
+2rot	( w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 )	double-ext	two_rote
 :
  >r >r 2swap r> r> 2swap ;
 
-2nip	w1 w2 w3 w4 -- w3 w4	gforth	two_nip
+2nip	( w1 w2 w3 w4 -- w3 w4 )	gforth	two_nip
 :
  2swap 2drop ;
 
-2tuck	w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4	gforth	two_tuck
+2tuck	( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 )	gforth	two_tuck
 :
  2swap 2over ;
 
 \ toggle is high-level: 0.11/0.42%
 
-@	a_addr -- w		core	fetch
-"" Read from the cell at address @i{a-addr}, and return its contents, @i{w}.""
+@	( a_addr -- w )		core	fetch
+""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;
 
-!	w a_addr --		core	store
-"" Write the value @i{w} to the cell at address @i{a-addr}.""
+!	( w a_addr -- )		core	store
+""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;
 
-+!	n a_addr --		core	plus_store
-"" Add @i{n} to the value stored in the cell at address @i{a-addr}.""
++!	( n a_addr -- )		core	plus_store
+""Add @i{n} to the cell at @i{a-addr}.""
 *a_addr += n;
 :
  tuck @ + swap ! ;
 
-c@	c_addr -- c		core	c_fetch
-"" Read from the char at address @i{c-addr}, and return its contents, @i{c}.""
+c@	( c_addr -- c )		core	c_fetch
+""@i{c} is the char stored at @i{c_addr}.""
 c = *c_addr;
 :
 [ bigendian [IF] ]
@@ -1136,8 +1130,8 @@ c = *c_addr;
 ;
 : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
 
-c!	c c_addr --		core	c_store
-"" Write the value @i{c} to the char at address @i{c-addr}.""
+c!	( c c_addr -- )		core	c_store
+""Store @i{c} into the char at @i{c-addr}.""
 *c_addr = c;
 :
 [ bigendian [IF] ]
@@ -1166,29 +1160,29 @@ c!	c c_addr --		core	c_store
 [THEN]
 : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;
 
-2!	w1 w2 a_addr --		core	two_store
-"" Write the value @i{w1, w2} to the double at address @i{a-addr}.""
+2!	( w1 w2 a_addr -- )		core	two_store
+""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell.""
 a_addr[0] = w2;
 a_addr[1] = w1;
 :
  tuck ! cell+ ! ;
 
-2@	a_addr -- w1 w2		core	two_fetch
-"" Read from the double at address @i{a-addr}, and return its contents, @i{w1, w2}.""
+2@	( a_addr -- w1 w2 )		core	two_fetch
+""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is
+the content of the next cell.""
 w2 = a_addr[0];
 w1 = a_addr[1];
 :
  dup cell+ @ swap @ ;
 
-cell+	a_addr1 -- a_addr2	core	cell_plus
-"" Increment @i{a-addr1} by the number of address units corresponding to the size of
-one cell, to give @i{a-addr2}.""
+cell+	( a_addr1 -- a_addr2 )	core	cell_plus
+""@code{1 cells +}""
 a_addr2 = a_addr1+1;
 :
  cell + ;
 
-cells	n1 -- n2		core
-"" @i{n2} is the number of address units corresponding to @i{n1} cells.""
+cells	( n1 -- n2 )		core
+"" @i{n2} is the number of address units of @i{n1} cells.""
 n2 = n1 * sizeof(Cell);
 :
  [ cell
@@ -1198,27 +1192,26 @@ n2 = n1 * sizeof(Cell);
  2/ dup [IF] ] 2* [ [THEN]
  drop ] ;
 
-char+	c_addr1 -- c_addr2	core	char_plus
-"" Increment @i{c-addr1} by the number of address units corresponding to the size of
-one char, to give @i{c-addr2}.""
+char+	( c_addr1 -- c_addr2 )	core	char_plus
+""@code{1 chars +}.""
 c_addr2 = c_addr1 + 1;
 :
  1+ ;
 
-(chars)		n1 -- n2	gforth	paren_chars
+(chars)	( n1 -- n2 )	gforth	paren_chars
 n2 = n1 * sizeof(Char);
 :
  ;
 
-count	c_addr1 -- c_addr2 u	core
-"" If @i{c-add1} is the address of a counted string return the length of
-the string, @i{u}, and the address of its first character, @i{c-addr2}.""
+count	( c_addr1 -- c_addr2 u )	core
+""@i{c-addr2} is the first character and @i{u} the length of the
+counted string at @i{c-addr1}.""
 u = *c_addr1;
 c_addr2 = c_addr1+1;
 :
  dup 1+ swap c@ ;
 
-(f83find)	c_addr u f83name1 -- f83name2	new	paren_f83find
+(f83find)	( c_addr u f83name1 -- f83name2 )	new	paren_f83find
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
@@ -1231,11 +1224,11 @@ f83name2=f83name1;
 	r> @
     REPEAT  THEN  nip nip ;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )
-    BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
+    BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL THEN ;
 
 \+hash
 
-(hashfind)	c_addr u a_addr -- f83name2	new	paren_hashfind
+(hashfind)	( c_addr u a_addr -- f83name2 )	new	paren_hashfind
 struct F83Name *f83name1;
 f83name2=NULL;
 while(a_addr != NULL)
@@ -1257,7 +1250,7 @@ while(a_addr != NULL)
 	rdrop r>
  REPEAT nip nip ;
 
-(tablefind)	c_addr u a_addr -- f83name2	new	paren_tablefind
+(tablefind)	( c_addr u a_addr -- f83name2 )	new	paren_tablefind
 ""A case-sensitive variant of @code{(hashfind)}""
 struct F83Name *f83name1;
 f83name2=NULL;
@@ -1280,14 +1273,14 @@ while(a_addr != NULL)
 	rdrop r>
  REPEAT nip nip ;
 
-(hashkey)	c_addr u1 -- u2		gforth	paren_hashkey
+(hashkey)	( c_addr u1 -- u2 )		gforth	paren_hashkey
 u2=0;
 while(u1--)
    u2+=(Cell)toupper(*c_addr++);
 :
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;
 
-(hashkey1)	c_addr u ubits -- ukey		gforth	paren_hashkey1
+(hashkey1)	( c_addr u ubits -- ukey )		gforth	paren_hashkey1
 ""ukey is the hash key for the string c_addr u fitting in ubits bits""
 /* this hash function rotates the key at every step by rot bits within
    ubits bits and xors it with the character. This function does ok in
@@ -1316,7 +1309,7 @@ Create rot-values
 
 \+
 
-(parse-white)	c_addr1 u1 -- c_addr2 u2	gforth	paren_parse_white
+(parse-white)	( c_addr1 u1 -- c_addr2 u2 )	gforth	paren_parse_white
 /* use !isgraph instead of isspace? */
 Char *endp = c_addr1+u1;
 while (c_addr1<endp && isspace(*c_addr1))
@@ -1336,19 +1329,19 @@ else {
  BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string
  REPEAT  THEN  nip - ;
 
-aligned		c_addr -- a_addr	core
+aligned	( c_addr -- a_addr )	core
 "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}.""
 a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
 :
  [ cell 1- ] Literal + [ -1 cells ] Literal and ;
 
-faligned	c_addr -- f_addr	float	f_aligned
+faligned	( c_addr -- f_addr )	float	f_aligned
 "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}.""
 f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
 :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
 
->body		xt -- a_addr	core	to_body
+>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);
@@ -1358,52 +1351,49 @@ a_addr = PFA(xt);
 \ 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
+>code-address	( xt -- c_addr )		gforth	to_code_address
 ""@i{c-addr} is the code address of the word @i{xt}.""
 /* !! This behaves installation-dependently for DOES-words */
 c_addr = (Address)CODE_ADDRESS(xt);
 :
     @ ;
 
->does-code	xt -- a_addr		gforth	to_does_code
-""If @i{xt} is the execution token of a defining-word-defined word,
+>does-code	( xt -- a_addr )		gforth	to_does_code
+""If @i{xt} is the execution token of a child of a @code{DOES>} word,
 @i{a-addr} is the start of the Forth code after the @code{DOES>};
 Otherwise @i{a-addr} is 0.""
 a_addr = (Cell *)DOES_CODE(xt);
 :
     cell+ @ ;
 
-code-address!		c_addr xt --		gforth	code_address_store
+code-address!	( c_addr xt -- )		gforth	code_address_store
 ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);
-CACHE_FLUSH(xt,(size_t)PFA(0));
 :
     ! ;
 
-does-code!	a_addr xt --		gforth	does_code_store
-""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}
-is the start of the Forth code after @code{DOES>}.""
+does-code!	( a_addr xt -- )		gforth	does_code_store
+""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
+@i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);
-CACHE_FLUSH(xt,(size_t)PFA(0));
 :
     dodoes: over ! cell+ ! ;
 
-does-handler!	a_addr --	gforth	does_handler_store
-""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points
-just behind a @code{DOES>}.""
+does-handler!	( a_addr -- )	gforth	does_handler_store
+""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
+@i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);
-CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :
     drop ;
 
-/does-handler	-- n	gforth	slash_does_handler
+/does-handler	( -- n )	gforth	slash_does_handler
 ""The size of a @code{DOES>}-handler (includes possible padding).""
 /* !! a constant or environmental query might be better */
 n = DOES_HANDLER_SIZE;
 :
     2 cells ;
 
-threading-method	-- n	gforth	threading_method
+threading-method	( -- n )	gforth	threading_method
 ""0 if the engine is direct threaded. Note that this may change during
 the lifetime of an image.""
 #if defined(DOUBLY_INDIRECT)
@@ -1420,7 +1410,9 @@ n=1;
 
 \f[THEN]
 
-key-file	wfileid -- n		gforth	paren_key_file
+\g hostos
+
+key-file	( wfileid -- n )		gforth	paren_key_file
 #ifdef HAS_FILE
 fflush(stdout);
 n = key((FILE*)wfileid);
@@ -1428,7 +1420,7 @@ n = key((FILE*)wfileid);
 n = key(stdin);
 #endif
 
-key?-file	wfileid -- n		facility	key_q_file
+key?-file	( wfileid -- n )		facility	key_q_file
 #ifdef HAS_FILE
 fflush(stdout);
 n = key_query((FILE*)wfileid);
@@ -1438,16 +1430,16 @@ n = key_query(stdin);
 
 \+os
 
-stdin	-- wfileid	gforth
+stdin	( -- wfileid )	gforth
 wfileid = (Cell)stdin;
 
-stdout	-- wfileid	gforth
+stdout	( -- wfileid )	gforth
 wfileid = (Cell)stdout;
 
-stderr	-- wfileid	gforth
+stderr	( -- wfileid )	gforth
 wfileid = (Cell)stderr;
 
-form	-- urows ucols	gforth
+form	( -- urows ucols )	gforth
 ""The number of lines and columns in the terminal. These numbers may change
 with the window size.""
 /* we could block SIGWINCH here to get a consistent size, but I don't
@@ -1455,7 +1447,7 @@ with the window size.""
 urows=rows;
 ucols=cols;
 
-flush-icache	c_addr u --	gforth	flush_icache
+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 @i{c-addr} and @i{u} bytes
 afterwards. @code{END-CODE} performs a @code{flush-icache}
@@ -1467,10 +1459,11 @@ your machine has a separate instruction
 cache.""
 FLUSH_ICACHE(c_addr,u);
 
-(bye)	n --	gforth	paren_bye
+(bye)	( n -- )	gforth	paren_bye
+SUPER_END;
 return (Label *)n;
 
-(system)	c_addr u -- wretval wior	gforth	peren_system
+(system)	( c_addr u -- wretval wior )	gforth	peren_system
 #ifndef MSDOS
 int old_tp=terminal_prepped;
 deprep_terminal();
@@ -1482,27 +1475,32 @@ if (old_tp)
   prep_terminal();
 #endif
 
-getenv	c_addr1 u1 -- c_addr2 u2	gforth
+getenv	( c_addr1 u1 -- c_addr2 u2 )	gforth
 ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
 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));
 
-open-pipe	c_addr u ntype -- wfileid wior	gforth	open_pipe
-wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
+open-pipe	( c_addr u wfam -- wfileid wior )	gforth	open_pipe
+wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
 
-close-pipe	wfileid -- wretval wior		gforth	close_pipe
+close-pipe	( wfileid -- wretval wior )		gforth	close_pipe
 wretval = pclose((FILE *)wfileid);
 wior = IOR(wretval==-1);
 
-time&date	-- nsec nmin nhour nday nmonth nyear	facility-ext	time_and_date
+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;
 gettimeofday(&time1,&zone1);
+/* !! Single Unix specification: 
+   If tzp is not a null pointer, the behaviour is unspecified. */
 ltime=localtime((time_t *)&time1.tv_sec);
 nyear =ltime->tm_year+1900;
 nmonth=ltime->tm_mon+1;
@@ -1511,123 +1509,116 @@ nhour =ltime->tm_hour;
 nmin  =ltime->tm_min;
 nsec  =ltime->tm_sec;
 
-ms	n --	facility-ext
+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);
 (void)select(0,0,0,0,&timeout);
 
-allocate	u -- a_addr wior	memory
+allocate	( u -- a_addr wior )	memory
 ""Allocate @i{u} address units of contiguous data space. The initial
 contents of the data space is undefined. If the allocation is successful,
 @i{a-addr} is the start address of the allocated region and @i{wior}
 is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
-is an implementation-defined I/O result code.""
+is a non-zero I/O result code.""
 a_addr = (Cell *)malloc(u?u:1);
 wior = IOR(a_addr==NULL);
 
-free		a_addr -- wior		memory
+free	( a_addr -- wior )		memory
 ""Return the region of data space starting at @i{a-addr} to the system.
-The regon must originally have been obtained using @code{allocate} or
+The region must originally have been obtained using @code{allocate} or
 @code{resize}. If the operational is successful, @i{wior} is 0.
-If the operation fails, @i{wior} is an implementation-defined
-I/O result code.""
+If the operation fails, @i{wior} is a non-zero I/O result code.""
 free(a_addr);
 wior = 0;
 
-resize		a_addr1 u -- a_addr2 wior	memory
+resize	( a_addr1 u -- a_addr2 wior )	memory
 ""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 the operational is successful, @i{wior} is 0.
-If the operation fails, @i{wior} is an implementation-defined
+If the operation is successful, @i{wior} is 0.
+If the operation fails, @i{wior} is a non-zero
 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. */
+/* close ' to keep fontify happy */
 if (a_addr1==NULL)
   a_addr2 = (Cell *)malloc(u);
 else
   a_addr2 = (Cell *)realloc(a_addr1, u);
 wior = IOR(a_addr2==NULL);	/* !! Define a return code */
 
-strerror	n -- c_addr u	gforth
+strerror	( n -- c_addr u )	gforth
 c_addr = strerror(n);
 u = strlen(c_addr);
 
-strsignal	n -- c_addr u	gforth
+strsignal	( n -- c_addr u )	gforth
 c_addr = strsignal(n);
 u = strlen(c_addr);
 
-call-c	w --	gforth	call_c
+call-c	( w -- )	gforth	call_c
 ""Call the C function pointed to by @i{w}. The C function has to
 access the stack itself. The stack pointers are exported in the global
 variables @code{SP} and @code{FP}.""
 /* This is a first attempt at support for calls to C. This may change in
    the future */
-IF_FTOS(fp[0]=FTOS);
+IF_fpTOS(fp[0]=fpTOS);
 FP=fp;
 SP=sp;
 ((void (*)())w)();
 sp=SP;
 fp=FP;
-IF_TOS(TOS=sp[0]);
-IF_FTOS(FTOS=fp[0]);
+IF_spTOS(spTOS=sp[0]);
+IF_fpTOS(fpTOS=fp[0]);
 
 \+
 \+file
 
-close-file	wfileid -- wior		file	close_file
+close-file	( wfileid -- wior )		file	close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);
 
-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
+open-file	( c_addr u wfam -- wfileid wior )	file	open_file
+wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
 wior =  IOR(wfileid == 0);
 
-create-file	c_addr u ntype -- wfileid wior	file	create_file
+create-file	( c_addr u wfam -- wfileid wior )	file	create_file
 Cell	fd;
-fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);
+fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
 if (fd != -1) {
-  wfileid = (Cell)fdopen(fd, fileattr[ntype]);
-#if defined(GO32) && defined(MSDOS)
-  if(wfileid && !(ntype & 1))
-    setbuf((FILE*)wfileid, NULL);
-#endif
+  wfileid = (Cell)fdopen(fd, fileattr[wfam]);
   wior = IOR(wfileid == 0);
 } else {
   wfileid = 0;
   wior = IOR(1);
 }
 
-delete-file	c_addr u -- wior		file	delete_file
+delete-file	( c_addr u -- wior )		file	delete_file
 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	( c_addr1 u1 c_addr2 u2 -- wior )	file-ext	rename_file
 ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
 
-file-position	wfileid -- ud wior	file	file_position
+file-position	( wfileid -- ud wior )	file	file_position
 /* !! use tell and lseek? */
 ud = LONG2UD(ftell((FILE *)wfileid));
 wior = IOR(UD2LONG(ud)==-1);
 
-reposition-file	ud wfileid -- wior	file	reposition_file
+reposition-file	( ud wfileid -- wior )	file	reposition_file
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
 
-file-size	wfileid -- ud wior	file	file_size
+file-size	( wfileid -- ud wior )	file	file_size
 struct stat buf;
 wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 ud = LONG2UD(buf.st_size);
 
-resize-file	ud wfileid -- wior	file	resize_file
+resize-file	( ud wfileid -- wior )	file	resize_file
 wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1);
 
-read-file	c_addr u1 wfileid -- u2 wior	file	read_file
+read-file	( c_addr u1 wfileid -- u2 wior )	file	read_file
 /* !! fread does not guarantee enough */
 u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
 wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
@@ -1635,38 +1626,30 @@ wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)
   clearerr((FILE *)wfileid);
 
-read-line	c_addr u1 wfileid -- u2 flag wior	file	read_line
-/*
+read-line	( c_addr u1 wfileid -- u2 flag wior )	file	read_line
+/* this may one day be replaced with : read-line (read-line) nip ; */
 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));
-*/
-if ((flag=FLAG(!feof((FILE *)wfileid) &&
-	       fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
-  wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */
-  if (wior)
-    clearerr((FILE *)wfileid);
-  u2 = strlen(c_addr);
-  u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
-}
-else {
-  wior=0;
-  u2=0;
-}
 
 \+
 
-write-file	c_addr u1 wfileid -- wior	file	write_file
+write-file	( c_addr u1 wfileid -- wior )	file	write_file
 /* !! fwrite does not guarantee enough */
 #ifdef HAS_FILE
 {
@@ -1679,7 +1662,7 @@ write-file	c_addr u1 wfileid -- wior	fil
 TYPE(c_addr, u1);
 #endif
 
-emit-file	c wfileid -- wior	gforth	emit_file
+emit-file	( c wfileid -- wior )	gforth	emit_file
 #ifdef HAS_FILE
 wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
 if (wior)
@@ -1690,29 +1673,29 @@ PUTC(c);
 
 \+file
 
-flush-file	wfileid -- wior		file-ext	flush_file
+flush-file	( wfileid -- wior )		file-ext	flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);
 
-file-status	c_addr u -- ntype wior	file-ext	file_status
+file-status	( c_addr u -- wfam wior )	file-ext	file_status
 char *filename=tilde_cstr(c_addr, u, 1);
 if (access (filename, F_OK) != 0) {
-  ntype=0;
+  wfam=0;
   wior=IOR(1);
 }
 else if (access (filename, R_OK | W_OK) == 0) {
-  ntype=2; /* r/w */
+  wfam=2; /* r/w */
   wior=0;
 }
 else if (access (filename, R_OK) == 0) {
-  ntype=0; /* r/o */
+  wfam=0; /* r/o */
   wior=0;
 }
 else if (access (filename, W_OK) == 0) {
-  ntype=4; /* w/o */
+  wfam=4; /* w/o */
   wior=0;
 }
 else {
-  ntype=1; /* well, we cannot access the file, but better deliver a legal
+  wfam=1; /* well, we cannot access the file, but better deliver a legal
 	    access mode (r/o bin), so we get a decent error later upon open. */
   wior=0;
 }
@@ -1720,10 +1703,12 @@ else {
 \+
 \+floating
 
+\g floating
+
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
 
-d>f		d -- r		float	d_to_f
+d>f	( d -- r )		float	d_to_f
 #ifdef BUGGY_LONG_LONG
 extern double ldexp(double x, int exp);
 r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
@@ -1731,103 +1716,101 @@ r = ldexp((Float)d.hi,CELL_BITS) + (Floa
 r = d;
 #endif
 
-f>d		r -- d		float	f_to_d
-#ifdef BUGGY_LONG_LONG
-d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
-d.lo = r-ldexp((Float)d.hi,CELL_BITS);
-#else
-d = r;
-#endif
+f>d	( r -- d )		float	f_to_d
+extern DCell double2ll(Float r);
+d = double2ll(r);
 
-f!		r f_addr --	float	f_store
-"" Store the floating-point value @i{r} to address @i{f-addr}.""
+f!	( r f_addr -- )	float	f_store
+""Store @i{r} into the float at address @i{f-addr}.""
 *f_addr = r;
 
-f@		f_addr -- r	float	f_fetch
-"" Fetch floating-point value @i{r} from address @i{f-addr}.""
+f@	( f_addr -- r )	float	f_fetch
+""@i{r} is the float at address @i{f-addr}.""
 r = *f_addr;
 
-df@		df_addr -- r	float-ext	d_f_fetch
-"" Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
+df@	( df_addr -- r )	float-ext	d_f_fetch
+""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
 #ifdef IEEE_FP
 r = *df_addr;
 #else
 !! df@
 #endif
 
-df!		r df_addr --	float-ext	d_f_store
-"" Store the double-precision IEEE floating-point value @i{r} to the address @i{df-addr}.""
+df!	( r df_addr -- )	float-ext	d_f_store
+""Store @i{r} as double-precision IEEE floating-point value to the
+address @i{df-addr}.""
 #ifdef IEEE_FP
 *df_addr = r;
 #else
 !! df!
 #endif
 
-sf@		sf_addr -- r	float-ext	s_f_fetch
-"" Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
+sf@	( sf_addr -- r )	float-ext	s_f_fetch
+""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
 #ifdef IEEE_FP
 r = *sf_addr;
 #else
 !! sf@
 #endif
 
-sf!		r sf_addr --	float-ext	s_f_store
-"" Store the single-precision IEEE floating-point value @i{r} to the address @i{sf-addr}.""
+sf!	( r sf_addr -- )	float-ext	s_f_store
+""Store @i{r} as single-precision IEEE floating-point value to the
+address @i{sf-addr}.""
 #ifdef IEEE_FP
 *sf_addr = r;
 #else
 !! sf!
 #endif
 
-f+		r1 r2 -- r3	float	f_plus
+f+	( r1 r2 -- r3 )	float	f_plus
 r3 = r1+r2;
 
-f-		r1 r2 -- r3	float	f_minus
+f-	( r1 r2 -- r3 )	float	f_minus
 r3 = r1-r2;
 
-f*		r1 r2 -- r3	float	f_star
+f*	( r1 r2 -- r3 )	float	f_star
 r3 = r1*r2;
 
-f/		r1 r2 -- r3	float	f_slash
+f/	( r1 r2 -- r3 )	float	f_slash
 r3 = r1/r2;
 
-f**		r1 r2 -- r3	float-ext	f_star_star
+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
-one floating-point number, to give @i{f-addr2}.""
+float+	( f_addr1 -- f_addr2 )	float	float_plus
+""@code{1 floats +}.""
 f_addr2 = f_addr1+1;
 
-floats		n1 -- n2	float
-""@i{n2} is the number of address units corresponding to @i{n1} floating-point numbers.""
+floats	( n1 -- n2 )	float
+""@i{n2} is the number of address units of @i{n1} floats.""
 n2 = n1*sizeof(Float);
 
-floor		r1 -- r2	float
+floor	( r1 -- r2 )	float
 ""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.""
+(fround)	( r1 -- r2 )	gforth	paren_f_round
+""Round to the nearest integral value.  Primitive variant (unused)""
+/* !! eliminate this as primitive? */
 /* !! unclear wording */
 #ifdef HAVE_RINT
 r2 = rint(r1);
@@ -1836,19 +1819,19 @@ 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
   r3 = r2;
 
-represent		r c_addr u -- n f1 f2	float
+represent	( r c_addr u -- n f1 f2 )	float
 char *sig;
 int flag;
 int decpt;
@@ -1858,17 +1841,23 @@ f1=FLAG(flag!=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 @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	( c_addr u -- flag )	float	to_float
+""Actual stack effect: ( c_addr u -- 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.""
 /* 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])
 {
@@ -1882,9 +1871,9 @@ number[u]='\0';
 r=strtod(number,&endconv);
 if((flag=FLAG(!(Cell)*endconv)))
 {
-   IF_FTOS(fp[0] = FTOS);
+   IF_fpTOS(fp[0] = fpTOS);
    fp += -1;
-   FTOS = r;
+   fpTOS = sign ? -r : r;
 }
 else if(*endconv=='d' || *endconv=='D')
 {
@@ -1892,36 +1881,36 @@ else if(*endconv=='d' || *endconv=='D')
    r=strtod(number,&endconv);
    if((flag=FLAG(!(Cell)*endconv)))
      {
-	IF_FTOS(fp[0] = FTOS);
+	IF_fpTOS(fp[0] = fpTOS);
 	fp += -1;
-	FTOS = r;
+	fpTOS = 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
@@ -1934,10 +1923,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
@@ -1950,81 +1939,81 @@ 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/
  r> IF  fnegate  THEN ;
 
-sfloats		n1 -- n2	float-ext	s_floats
-""@i{n2} is the number of address units corresponding to @i{n1}
+sfloats	( n1 -- n2 )	float-ext	s_floats
+""@i{n2} is the number of address units of @i{n1}
 single-precision IEEE floating-point numbers.""
 n2 = n1*sizeof(SFloat);
 
-dfloats		n1 -- n2	float-ext	d_floats
-""@i{n2} is the number of address units corresponding to @i{n1}
+dfloats	( n1 -- n2 )	float-ext	d_floats
+""@i{n2} is the number of address units of @i{n1}
 double-precision IEEE floating-point numbers.""
 n2 = n1*sizeof(DFloat);
 
-sfaligned	c_addr -- sf_addr	float-ext	s_f_aligned
-"" @i{sf-addr} is the first single-float-aligned address greater
+sfaligned	( c_addr -- sf_addr )	float-ext	s_f_aligned
+""@i{sf-addr} is the first single-float-aligned address greater
 than or equal to @i{c-addr}.""
 sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
 :
  [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
 
-dfaligned	c_addr -- df_addr	float-ext	d_f_aligned
-"" @i{df-addr} is the first double-float-aligned address greater
+dfaligned	( c_addr -- df_addr )	float-ext	d_f_aligned
+""@i{df-addr} is the first double-float-aligned address greater
 than or equal to @i{c-addr}.""
 df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
 :
@@ -2039,71 +2028,68 @@ df_addr = (DFloat *)((((Cell)c_addr)+(si
 \+
 \+glocals
 
-@local#		-- w	gforth	fetch_local_number
-w = *(Cell *)(lp+(Cell)NEXT_INST);
-INC_IP(1);
+@local#	( #noffset -- w )	gforth	fetch_local_number
+w = *(Cell *)(lp+noffset);
 
-@local0	-- w	new	fetch_local_zero
+@local0	( -- w )	new	fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));
 
-@local1	-- w	new	fetch_local_four
+@local1	( -- w )	new	fetch_local_four
 w = *(Cell *)(lp+1*sizeof(Cell));
 
-@local2	-- w	new	fetch_local_eight
+@local2	( -- w )	new	fetch_local_eight
 w = *(Cell *)(lp+2*sizeof(Cell));
 
-@local3	-- w	new	fetch_local_twelve
+@local3	( -- w )	new	fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));
 
 \+floating
 
-f@local#	-- r	gforth	f_fetch_local_number
-r = *(Float *)(lp+(Cell)NEXT_INST);
-INC_IP(1);
+f@local#	( #noffset -- r )	gforth	f_fetch_local_number
+r = *(Float *)(lp+noffset);
 
-f@local0	-- r	new	f_fetch_local_zero
+f@local0	( -- r )	new	f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));
 
-f@local1	-- r	new	f_fetch_local_eight
+f@local1	( -- r )	new	f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));
 
 \+
 
-laddr#		-- c_addr	gforth	laddr_number
+laddr#	( #noffset -- c_addr )	gforth	laddr_number
 /* this can also be used to implement lp@ */
-c_addr = (Char *)(lp+(Cell)NEXT_INST);
-INC_IP(1);
+c_addr = (Char *)(lp+noffset);
 
-lp+!#	--	gforth	lp_plus_store_number
+lp+!#	( #noffset -- )	gforth	lp_plus_store_number
 ""used with negative immediate values it allocates memory on the
 local stack, a positive immediate argument drops memory from the local
 stack""
-lp += (Cell)NEXT_INST;
-INC_IP(1);
+lp += noffset;
 
-lp-	--	new	minus_four_lp_plus_store
+lp-	( -- )	new	minus_four_lp_plus_store
 lp += -sizeof(Cell);
 
-lp+	--	new	eight_lp_plus_store
+lp+	( -- )	new	eight_lp_plus_store
 lp += sizeof(Float);
 
-lp+2	--	new	sixteen_lp_plus_store
+lp+2	( -- )	new	sixteen_lp_plus_store
 lp += 2*sizeof(Float);
 
-lp!	c_addr --	gforth	lp_store
+lp!	( c_addr -- )	gforth	lp_store
 lp = (Address)c_addr;
 
->l	w --	gforth	to_l
+>l	( w -- )	gforth	to_l
 lp -= sizeof(Cell);
 *(Cell *)lp = w;
 
 \+floating
 
-f>l	r --	gforth	f_to_l
+f>l	( r -- )	gforth	f_to_l
 lp -= sizeof(Float);
 *(Float *)lp = r;
 
-fpick	u -- r		gforth
+fpick	( u -- r )		gforth
+""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
 r = fp[u+1]; /* +1, because update of fp happens before this fragment */
 :
  floats fp@ + f@ ;
@@ -2132,18 +2118,19 @@ define(argclist,
                `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')
 \ icall(argnum)
 define(icall,
-`icall$1	argflist($1)u -- uret	gforth
+`icall$1	( argflist($1)u -- uret )	gforth
 uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
 
 ')
 define(fcall,
-`fcall$1	argflist($1)u -- rret	gforth
+`fcall$1	( argflist($1)u -- rret )	gforth
 rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
 
 ')
 
+\ close ' to keep fontify happy
 
-open-lib	c_addr1 u1 -- u2	gforth	open_lib
+open-lib	( c_addr1 u1 -- u2 )	gforth	open_lib
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 #ifndef RTLD_GLOBAL
 #define RTLD_GLOBAL 0
@@ -2158,7 +2145,7 @@ u2 = 0;
 #  endif
 #endif
 
-lib-sym	c_addr1 u1 u2 -- u3	gforth	lib_sym
+lib-sym	( c_addr1 u1 u2 -- u3 )	gforth	lib_sym
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
 #else
@@ -2177,17 +2164,628 @@ fcall(20)
 
 \+
 
-up!	a_addr --	gforth	up_store
+up!	( a_addr -- )	gforth	up_store
 UP=up=(char *)a_addr;
 :
  up ! ;
 Variable UP
 
-wcall	u --	gforth
-IF_FTOS(fp[0]=FTOS);
+wcall	( u -- )	gforth
+IF_fpTOS(fp[0]=fpTOS);
 FP=fp;
-sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
+sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;
-IF_TOS(TOS=sp[0];)
-IF_FTOS(FTOS=fp[0]);
+IF_spTOS(spTOS=sp[0];)
+IF_fpTOS(fpTOS=fp[0]);
+
+\+file
+
+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));
+wior =  IOR(wdirid == 0);
+
+read-dir	( c_addr u1 wdirid -- u2 flag wior )	gforth	read_dir
+""Attempt to read the next entry from the directory specified
+by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. 
+If the attempt fails because there is no more entries,
+@i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
+If the attempt to read the next entry fails because of any other reason, 
+return @i{ior}<>0.
+If the attempt succeeds, store file name to the buffer at @i{c-addr}
+and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
+If the length of the file name is greater than @i{u1}, 
+store first @i{u1} characters from file name into the buffer and
+indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
+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;
+    wior = -512-ENAMETOOLONG;
+  }
+  memmove(c_addr, dent->d_name, u2);
+}
+
+close-dir	( wdirid -- wior )	gforth	close_dir
+""Close the directory specified by @i{dir-id}.""
+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[] = {
+#if defined(unix) || defined(__MACH__)
+/* Darwin/MacOS X sets __MACH__, but not unix. */
+'\n'
+#else
+'\r','\n'
+#endif
+};
+c_addr=newline;
+u=sizeof(newline);
+:
+ "newline count ;
+Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
+
+\+os
+
+utime	( -- dtime )	gforth
+""Report the current time in microseconds since some epoch.""
+struct timeval time1;
+gettimeofday(&time1,NULL);
+dtime = timeval2us(&time1);
+
+cputime ( -- duser dsystem ) gforth
+""duser and dsystem are the respective user- and system-level CPU
+times used since the start of the Forth system (excluding child
+processes), in microseconds (the granularity may be much larger,
+however).  On platforms without the getrusage call, it reports elapsed
+time (since some epoch) for duser and 0 for dsystem.""
+#ifdef HAVE_GETRUSAGE
+struct rusage usage;
+getrusage(RUSAGE_SELF, &usage);
+duser = timeval2us(&usage.ru_utime);
+dsystem = timeval2us(&usage.ru_stime);
+#else
+struct timeval time1;
+gettimeofday(&time1,NULL);
+duser = timeval2us(&time1);
+#ifndef BUGGY_LONG_LONG
+dsystem = (DCell)0;
+#else
+dsystem=(DCell){0,0};
+#endif
+#endif
+
+\+
+
+\+floating
+
+v*	( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
+""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
+next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
+ucount elements.""
+for (r=0.; ucount>0; ucount--) {
+  r += *f_addr1 * *f_addr2;
+  f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
+  f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
+}
+:
+ >r swap 2swap swap 0e r> 0 ?DO
+     dup f@ over + 2swap dup f@ f* f+ over + 2swap
+ LOOP 2drop 2drop ; 
+
+faxpy	( ra f_x nstridex f_y nstridey ucount -- )	gforth
+""vy=ra*vx+vy""
+for (; ucount>0; ucount--) {
+  *f_y += ra * *f_x;
+  f_x = (Float *)(((Address)f_x)+nstridex);
+  f_y = (Float *)(((Address)f_y)+nstridey);
+}
+:
+ >r swap 2swap swap r> 0 ?DO
+     fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
+ LOOP 2drop 2drop fdrop ;
+
+\+
 
+\+file
+
+(read-line)	( c_addr u1 wfileid -- u2 flag u3 wior )	file	paren_read_line
+Cell c;
+flag=-1;
+u3=0;
+for(u2=0; u2<u1; u2++)
+{
+   c = getc((FILE *)wfileid);
+   u3++;
+   if (c=='\n') break;
+   if (c=='\r') {
+     if ((c = getc((FILE *)wfileid))!='\n')
+       ungetc(c,(FILE *)wfileid);
+     else
+       u3++;
+     break;
+   }
+   if (c==EOF) {
+	flag=FLAG(u2!=0);
+	break;
+     }
+   c_addr[u2] = (Char)c;
+}
+wior=FILEIO(ferror((FILE *)wfileid));
+
+\+
+
+(listlfind)	( c_addr u longname1 -- longname2 )	new	paren_listlfind
+for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
+  if ((UCell)LONGNAME_COUNT(longname1)==u &&
+      memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
+    break;
+longname2=longname1;
+:
+    BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
+	>r 2dup r@ cell+ cell+ capscomp  0=
+	IF  2drop r>  EXIT  THEN
+	r> @
+    REPEAT  THEN  nip nip ;
+: (findl-samelen) ( u longname1 -- u longname2/0 )
+    BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
+
+\+hash
+
+(hashlfind)	( c_addr u a_addr -- longname2 )	new	paren_hashlfind
+struct Longname *longname1;
+longname2=NULL;
+while(a_addr != NULL)
+{
+   longname1=(struct Longname *)(a_addr[1]);
+   a_addr=(Cell *)(a_addr[0]);
+   if ((UCell)LONGNAME_COUNT(longname1)==u &&
+       memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
+     {
+	longname2=longname1;
+	break;
+     }
+}
+:
+ BEGIN  dup  WHILE
+        2@ >r >r dup r@ cell+ @ lcount-mask and =
+        IF  2dup r@ cell+ cell+ capscomp 0=
+	    IF  2drop r> rdrop  EXIT  THEN  THEN
+	rdrop r>
+ REPEAT nip nip ;
+
+(tablelfind)	( c_addr u a_addr -- longname2 )	new	paren_tablelfind
+""A case-sensitive variant of @code{(hashfind)}""
+struct Longname *longname1;
+longname2=NULL;
+while(a_addr != NULL)
+{
+   longname1=(struct Longname *)(a_addr[1]);
+   a_addr=(Cell *)(a_addr[0]);
+   if ((UCell)LONGNAME_COUNT(longname1)==u &&
+       memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)
+     {
+	longname2=longname1;
+	break;
+     }
+}
+:
+ BEGIN  dup  WHILE
+        2@ >r >r dup r@ cell+ @ lcount-mask and =
+        IF  2dup r@ cell+ cell+ -text 0=
+	    IF  2drop r> rdrop  EXIT  THEN  THEN
+	rdrop r>
+ REPEAT nip nip ;
+
+\+
+
+\+peephole
+
+\g peephole
+
+primtable	( -- wprimtable )	new
+""wprimtable is a table containing the xts of the primitives indexed
+by sequence-number in prim (for use in prepare-peephole-table).""
+wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);
+
+prepare-peephole-table	( wprimtable -- wpeeptable ) new prepare_peephole_opt
+""wpeeptable is a data structure used by @code{peephole-opt}; it is
+constructed by combining a primitives table with a simple peephole
+optimization table.""
+wpeeptable = prepare_peephole_table((Xt *)wprimtable);
+
+peephole-opt	( xt1 xt2 wpeeptable -- xt )	new	peephole_opt
+""xt is the combination of xt1 and xt2 (according to wpeeptable); if
+they cannot be combined, xt is 0.""
+xt = peephole_opt(xt1, xt2, wpeeptable);
+
+call	( #a_callee -- R:a_retaddr )	new
+""Call callee (a variant of docol with inline argument).""
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_callee);
+#else
+#ifdef DEBUG
+    {
+      CFA_TO_NAME((((Cell *)a_callee)-2));
+      fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
+	      len,name);
+    }
+#endif
+a_retaddr = (Cell *)IP;
+SET_IP((Xt *)a_callee);
+#endif
+
+useraddr	( #u -- a_addr )	new
+a_addr = (Cell *)(up+u);
+
+compile-prim ( xt1 -- xt2 )	new	compile_prim
+xt2 = (Xt)compile_prim((Label)xt1);
+
+\ lit@ / lit_fetch = lit @
+
+lit@		( #a_addr -- w ) new	lit_fetch
+w = *a_addr;
+
+lit-perform	( #a_addr -- )	new	lit_perform
+#ifndef NO_IP
+ip=IP;
+#endif
+SUPER_END;
+EXEC(*(Xt *)a_addr);
+
+\ lit+ / lit_plus = lit +
+
+lit+	( n1 #n2 -- n )		new	lit_plus
+n=n1+n2;
+
+does-exec ( #a_cfa -- R:nest a_pfa )	new	does_exec
+#ifdef NO_IP
+/* compiled to LIT CALL by compile_prim */
+assert(0);
+#else
+a_pfa = PFA(a_cfa);
+nest = (Cell)IP;
+IF_spTOS(spTOS = sp[0]);
+#ifdef DEBUG
+    {
+      CFA_TO_NAME(a_cfa);
+      fprintf(stderr,"%08lx: does %08lx %.*s\n",
+	      (Cell)ip,(Cell)a_cfa,len,name);
+    }
+#endif
+SET_IP(DOES_CODE1(a_cfa));
+#endif
+
+abranch-lp+!# ( #a_target #nlocals -- )	gforth	abranch_lp_plus_store_number
+/* this will probably not be used */
+lp += nlocals;
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+#endif
+
+\+
+
+abranch	( #a_target -- )	gforth
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+#endif
+:
+ r> @ >r ;
+
+\ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)
+\ this is non-syntactical: code must open a brace that is closed by the macro
+define(acondbranch,
+$1 ( `#'a_target $2 ) $3
+$4	#ifdef NO_IP
+INST_TAIL;
+#endif
+$5	#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+$6
+
+\+glocals
+
+$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
+$4	#ifdef NO_IP
+INST_TAIL;
+#endif
+$5	lp += nlocals;
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+
+\+
+)
+
+acondbranch(a?branch,f --,f83	aquestion_branch,
+,if (f==0) {
+,:
+ 0= dup     \ !f !f \ !! still uses relative addresses
+ r> dup @   \ !f !f IP branchoffset
+ rot and +  \ !f IP|IP+branchoffset
+ swap 0= cell and + \ IP''
+ >r ;)
+
+\ we don't need an lp_plus_store version of the ?dup-stuff, because it
+\ is only used in if's (yet)
+
+\+xconds
+
+a?dup-?branch	( #a_target f -- f )	new	aquestion_dupe_question_branch
+""The run-time procedure compiled by @code{?DUP-IF}.""
+if (f==0) {
+  sp++;
+  IF_spTOS(spTOS = sp[0]);
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+  INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+
+a?dup-0=-?branch ( #a_target f -- ) new	aquestion_dupe_zero_equals_question_branch
+""The run-time procedure compiled by @code{?DUP-0=-IF}.""
+/* the approach taken here of declaring the word as having the stack
+effect ( f -- ) and correcting for it in the branch-taken case costs a
+few cycles in that case, but is easy to convert to a CONDBRANCH
+invocation */
+if (f!=0) {
+  sp--;
+#ifdef NO_IP
+  JUMP(a_target);
+#else
+  SET_IP((Xt *)a_target);
+  NEXT;
+#endif
+}
+SUPER_CONTINUE;
+
+\+
+\f[THEN]
+\fhas? skiploopprims 0= [IF]
+
+acondbranch(a(next),R:n1 -- R:n2,cmFORTH	aparen_next,
+n2=n1-1;
+,if (n1) {
+,:
+ r> r> dup 1- >r
+ IF @ >r ELSE cell+ >r THEN ;)
+
+acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth	aparen_loop,
+n2=n1+1;
+,if (n2 != nlimit) {
+,:
+ r> r> 1+ r> 2dup =
+ IF >r 1- >r cell+ >r
+ ELSE >r >r @ >r THEN ;)
+
+acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,
+/* !! check this thoroughly */
+/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
+/* dependent upon two's complement arithmetic */
+Cell olddiff = n1-nlimit;
+n2=n1+n;	
+,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
+    || (olddiff^n)>=0          /* it is a wrap-around effect */) {
+,:
+ r> swap
+ r> r> 2dup - >r
+ 2 pick r@ + r@ xor 0< 0=
+ 3 pick r> xor 0< 0= or
+ IF    >r + >r @ >r
+ ELSE  >r >r drop cell+ >r THEN ;)
+
+\+xconds
+
+acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,
+UCell olddiff = n1-nlimit;
+n2=n1-u;
+,if (olddiff>u) {
+,)
+
+acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth	aparen_symmetric_plus_loop,
+""The run-time procedure compiled by S+LOOP. It loops until the index
+crosses the boundary between limit and limit-sign(n). I.e. a symmetric
+version of (+LOOP).""
+/* !! check this thoroughly */
+Cell diff = n1-nlimit;
+Cell newdiff = diff+n;
+if (n<0) {
+    diff = -diff;
+    newdiff = -newdiff;
+}
+n2=n1+n;
+,if (diff>=0 || newdiff<0) {
+,)
+
+a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_question_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (nstart == nlimit) {
+#ifdef NO_IP
+    JUMP(a_target);
+#else
+    SET_IP((Xt *)a_target);
+    INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+  2dup =
+  IF   r> swap rot >r >r
+       @ >r
+  ELSE r> swap rot >r >r
+       cell+ >r
+  THEN ;				\ --> CORE-EXT
+
+\+xconds
+
+a(+do)	( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_plus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (nstart >= nlimit) {
+#ifdef NO_IP
+    JUMP(a_target);
+#else
+    SET_IP((Xt *)a_target);
+    INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ >=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(u+do)	( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth	aparen_u_plus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (ustart >= ulimit) {
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ u>=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(-do)	( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_minus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (nstart <= nlimit) {
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ <=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(u-do)	( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth	aparen_u_minus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (ustart <= ulimit) {
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ u<=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+\ set-next-code and call2 do not appear in images and can be
+\ renumbered arbitrarily
+
+set-next-code ( #w -- ) gforth set_next_code
+#ifdef NO_IP
+next_code = (Label)w;
+#endif
+
+call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
+/* call with explicit return address */
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_callee);
+#else
+assert(0);
+#endif
+
+compile-prim1 ( a_prim -- ) gforth compile_prim1
+""compile prim (incl. immargs) at @var{a_prim}""
+compile_prim1(a_prim);
+
+finish-code ( -- ) gforth finish_code
+""Perform delayed steps in code generation (branch resolution, I-cache
+flushing).""
+finish_code();
+
+forget-dyncode ( a_code -- f ) gforth-internal forget_dyncode
+f = forget_dyncode(a_code);
+
+decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
+""a_prim is the code address of the primitive that has been
+compile_prim1ed to a_code""
+a_prim = decompile_code(a_code);
+
+\+
+
+include(peeprules.vmg)
+
+\+