--- gforth/prim	2000/09/23 15:46:58	1.63
+++ gforth/prim	2002/01/05 20:16:17	1.89
@@ -72,8 +72,36 @@
 \ 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
+
 \ 
 \ 
 \ 
@@ -102,29 +130,31 @@
 \ these m4 macros would collide with identifiers
 undefine(`index')
 undefine(`shift')
+undefine(`symbols')
+
+\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
 ""Perform the semantics represented by the execution token, @i{xt}.""
 ip=IP;
-IF_TOS(TOS = sp[0]);
+IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(xt);
 
 perform	( a_addr -- )	gforth
 ""@code{@@ execute}.""
 /* and pfe */
 ip=IP;
-IF_TOS(TOS = sp[0]);
+IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(*(Xt *)a_addr);
 :
  @ execute ;
@@ -132,45 +162,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));
+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));
+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 +210,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));
+  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 +228,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 +270,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));
+    TAIL;
 }
+SUPER_CONTINUE;
 :
   2dup =
   IF   r> swap rot >r >r
@@ -327,16 +324,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));
+    TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -347,16 +340,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));
+    TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -367,16 +356,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));
+    TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -387,16 +372,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));
+    TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -412,29 +393,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,6 +420,8 @@ n = rp[4];
 
 \ digit is high-level: 0/0%
 
+\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.""
@@ -553,6 +531,8 @@ u2 = u1-n;
 :
  tuck - >r + r> dup 0< IF  - 0  THEN ;
 
+\g arith
+
 +	( n1 n2 -- n )		core	plus
 n = n1+n2;
 
@@ -950,12 +930,14 @@ f = FLAG(u1-u2 < u3-u2);
 :
  over - >r - r> u< ;
 
+\g internal
+
 sp@	( -- a_addr )		gforth		sp_fetch
 a_addr = sp+1;
 
 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
 a_addr = rp;
@@ -973,54 +955,39 @@ fp = f_addr;
 
 \+
 
-;s	( -- )		gforth	semis
+;s	( R:w -- )		gforth	semis
 ""The primitive compiled by @code{EXIT}.""
-SET_IP((Xt *)(*rp++));
+SET_IP((Xt *)w);
+
+\g stack
 
->r	( w -- )		core	to_r
-""@code{( R: -- w )}""
-*--rp = w;
+>r	( w -- R:w )		core	to_r
 :
  (>r) ;
 : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
 
-r>	( -- w )		core	r_from
-""@code{( R: w -- )}""
-w = *rp++;
+r>	( R:w -- w )		core	r_from
 :
  rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 Create (rdrop) ' ;s A,
 
-rdrop	( -- )		gforth
-""@code{( R: w -- )}""
-rp++;
+rdrop	( R:w -- )		gforth
 :
  r> r> drop >r ;
 
-2>r	( w1 w2 -- )	core-ext	two_to_r
-""@code{( R: -- w1 w2 )}""
-*--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
-""@code{( R: w1 w2 -- )}""
-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
-""@code{( R: w1 w2 -- w1 w2 )}""
-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
-""@code{( R: w1 w2 -- )}""
-rp+=2;
+2rdrop	(  R:w1 R:w2 -- )		gforth	two_r_drop
 :
  r> r> drop r> drop >r ;
 
@@ -1066,7 +1033,7 @@ tuck	( w1 w2 -- w2 w1 w2 )	core-ext
 ""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
@@ -1244,7 +1211,7 @@ 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
 
@@ -1433,6 +1400,8 @@ n=1;
 
 \f[THEN]
 
+\g hostos
+
 key-file	( wfileid -- n )		gforth	paren_key_file
 #ifdef HAS_FILE
 fflush(stdout);
@@ -1481,6 +1450,7 @@ cache.""
 FLUSH_ICACHE(c_addr,u);
 
 (bye)	( n -- )	gforth	paren_bye
+SUPER_END;
 return (Label *)n;
 
 (system)	( c_addr u -- wretval wior )	gforth	peren_system
@@ -1505,7 +1475,7 @@ c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
 
 open-pipe	( c_addr u wfam -- wfileid wior )	gforth	open_pipe
-wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */
+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
@@ -1584,14 +1554,14 @@ access the stack itself. The stack point
 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
@@ -1647,7 +1617,7 @@ if (wior)
   clearerr((FILE *)wfileid);
 
 read-line	( c_addr u1 wfileid -- u2 flag wior )	file	read_line
-""this is only for backward compatibility""
+/* this may one day be replaced with : read-line (read-line) nip ; */
 Cell c;
 flag=-1;
 for(u2=0; u2<u1; u2++)
@@ -1723,6 +1693,8 @@ 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)
 
@@ -1892,9 +1864,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 = sign ? -r : r;
+   fpTOS = sign ? -r : r;
 }
 else if(*endconv=='d' || *endconv=='D')
 {
@@ -1902,9 +1874,9 @@ 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 = sign ? -r : r;
+	fpTOS = sign ? -r : r;
      }
 }
 
@@ -2049,9 +2021,8 @@ 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
 w = *(Cell *)(lp+0*sizeof(Cell));
@@ -2067,9 +2038,8 @@ 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
 r = *(Float *)(lp+0*sizeof(Float));
@@ -2079,17 +2049,15 @@ 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 += -sizeof(Cell);
@@ -2196,12 +2164,12 @@ UP=up=(char *)a_addr;
 Variable UP
 
 wcall	( u -- )	gforth
-IF_FTOS(fp[0]=FTOS);
+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
 
@@ -2219,8 +2187,10 @@ if(dent == NULL) {
   flag = 0;
 } else {
   u2 = strlen(dent->d_name);
-  if(u2 > u1)
+  if(u2 > u1) {
     u2 = u1;
+    wior = -512-ENAMETOOLONG;
+  }
   memmove(c_addr, dent->d_name, u2);
 }
 
@@ -2237,7 +2207,8 @@ flag = FLAG(!fnmatch(pattern, string, 0)
 newline	( -- c_addr u )	gforth
 ""String containing the newline sequence of the host OS""
 char newline[] = {
-#ifdef unix
+#if defined(unix) || defined(__MACH__)
+/* Darwin/MacOS X sets __MACH__, but not unix. */
 '\n'
 #else
 '\r','\n'
@@ -2338,3 +2309,128 @@ for(u2=0; u2<u1; u2++)
 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 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);
+
+useraddr	( #u -- a_addr )	new
+a_addr = (Cell *)(up+u);
+
+compile-prim ( xt1 -- xt2 )	new	compile_prim
+xt2 = (Xt)compile_prim((Label)xt1);
+
+lit@	( #a_addr -- w )	new	lit_fetch
+w = *a_addr;
+
+lit-perform	( #a_addr -- )	new	lit_perform
+ip=IP;
+SUPER_END;
+EXEC(*(Xt *)a_addr);
+
+lit+	( #n1 n2 -- n3 )	new	lit_plus
+n3 = n1 + n2;
+
+does-exec ( #a_cfa -- R:nest a_pfa )	new	does_exec
+a_pfa = PFA(a_cfa);
+nest = (Cell)ip;
+IF_spTOS(spTOS = sp[0]);
+SUPER_END;
+SET_IP(DOES_CODE1(a_cfa));
+SUPER_END;
+
+include(peeprules.vmg)
+
+\+