--- gforth/prim	2001/01/14 22:53:19	1.70
+++ gforth/prim	2001/05/01 13:35:42	1.82
@@ -72,9 +72,12 @@
 \ 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
@@ -91,8 +94,8 @@
 \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" WID"		single data-stack type-prefix wid
 \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 #
@@ -127,6 +130,7 @@
 \ these m4 macros would collide with identifiers
 undefine(`index')
 undefine(`shift')
+undefine(`symbols')
 
 noop	( -- )		gforth
 :
@@ -140,6 +144,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
@@ -147,6 +152,7 @@ perform	( a_addr -- )	gforth
 /* and pfe */
 ip=IP;
 IF_spTOS(spTOS = sp[0]);
+SUPER_END;
 EXEC(*(Xt *)a_addr);
 :
  @ execute ;
@@ -1186,7 +1192,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
 
@@ -1423,6 +1429,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
@@ -2136,7 +2143,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]);
@@ -2279,3 +2286,97 @@ 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
+
+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 )
+""Call callee (a variant of docol with inline argument).""
+a_retaddr = (Cell *)IP;
+SET_IP((Xt *)a_callee);
+
+useraddr	( #u -- a_addr )
+a_addr = (Cell *)(up+u);
+
+include(peeprules.vmg)
+
+\+