--- gforth/prim	2001/02/26 15:14:20	1.75
+++ gforth/prim	2002/06/02 10:31:28	1.93
@@ -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
@@ -74,6 +77,10 @@
 \ xt.*		XT
 \ 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
@@ -126,6 +133,9 @@
 \ these m4 macros would collide with identifiers
 undefine(`index')
 undefine(`shift')
+undefine(`symbols')
+
+\g control
 
 noop	( -- )		gforth
 :
@@ -139,6 +149,7 @@ execute	( xt -- )		core
 ""Perform the semantics represented by the execution token, @i{xt}.""
 ip=IP;
 IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(xt);
 
 perform	( a_addr -- )	gforth
@@ -146,6 +157,7 @@ perform	( a_addr -- )	gforth
 /* and pfe */
 ip=IP;
 IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(*(Xt *)a_addr);
 :
  @ execute ;
@@ -172,6 +184,7 @@ $1 ( `#'ndisp $2 ) $3
 $4	SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
 TAIL;
 }
+SUPER_CONTINUE;
 $5
 
 \+glocals
@@ -181,6 +194,7 @@ $4    lp += nlocals;
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
 TAIL;
 }
+SUPER_CONTINUE;
 
 \+
 )
@@ -207,6 +221,7 @@ if (f==0) {
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   TAIL;
 }
+SUPER_CONTINUE;
 
 ?dup-0=-?branch	( #ndisp f -- )	new	question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
@@ -219,6 +234,7 @@ if (f!=0) {
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT;
 }
+SUPER_CONTINUE;
 
 \+
 \f[THEN]
@@ -300,6 +316,7 @@ if (nstart == nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;
 }
+SUPER_CONTINUE;
 :
   2dup =
   IF   r> swap rot >r >r
@@ -315,6 +332,7 @@ if (nstart >= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -330,6 +348,7 @@ if (ustart >= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -345,6 +364,7 @@ if (nstart <= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -360,6 +380,7 @@ if (ustart <= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -402,6 +423,8 @@ k	( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
 
 \ 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.""
@@ -511,6 +534,8 @@ u2 = u1-n;
 :
  tuck - >r + r> dup 0< IF  - 0  THEN ;
 
+\g arith
+
 +	( n1 n2 -- n )		core	plus
 n = n1+n2;
 
@@ -908,6 +933,8 @@ f = FLAG(u1-u2 < u3-u2);
 :
  over - >r - r> u< ;
 
+\g internal
+
 sp@	( -- a_addr )		gforth		sp_fetch
 a_addr = sp+1;
 
@@ -935,6 +962,8 @@ fp = f_addr;
 ""The primitive compiled by @code{EXIT}.""
 SET_IP((Xt *)w);
 
+\g stack
+
 >r	( w -- R:w )		core	to_r
 :
  (>r) ;
@@ -1330,7 +1359,6 @@ a_addr = (Cell *)DOES_CODE(xt);
 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));
 :
     ! ;
 
@@ -1338,7 +1366,6 @@ does-code!	( a_addr xt -- )		gforth	does
 ""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+ ! ;
 
@@ -1346,7 +1373,6 @@ does-handler!	( a_addr -- )	gforth	does_
 ""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 ;
 
@@ -1374,6 +1400,8 @@ n=1;
 
 \f[THEN]
 
+\g hostos
+
 key-file	( wfileid -- n )		gforth	paren_key_file
 #ifdef HAS_FILE
 fflush(stdout);
@@ -1422,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
@@ -1446,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
@@ -1588,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++)
@@ -1664,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)
 
@@ -2135,7 +2166,7 @@ Variable UP
 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_spTOS(spTOS=sp[0];)
 IF_fpTOS(fpTOS=fp[0]);
@@ -2343,6 +2374,10 @@ while(a_addr != NULL)
 
 \+
 
+\+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).""
@@ -2359,15 +2394,46 @@ peephole-opt	( xt1 xt2 wpeeptable -- xt
 they cannot be combined, xt is 0.""
 xt = peephole_opt(xt1, xt2, wpeeptable);
 
-lit_plus = lit +
-
-call	( #a_callee -- R:a_retaddr )
+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 )
+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-perform	( #a_addr -- )	new	lit_perform
+ip=IP;
+SUPER_END;
+EXEC(*(Xt *)a_addr);
 
+lit+ / lit_plus = lit +
 
+does-exec ( #a_cfa -- R:nest a_pfa )	new	does_exec
+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));
+
+include(peeprules.vmg)
+
+\+