--- gforth/prim	2003/05/18 18:27:44	1.130
+++ gforth/prim	2004/03/29 11:23:01	1.151
@@ -136,11 +136,90 @@
 \ throw execute, cfa and NEXT1 out?
 \ macroize *ip, ip++, *ip++ (pipelining)?
 
+\ Stack caching setup
+
+ifdef(`M4_ENGINE_FAST', `include(cache1.vmg)', `include(cache0.vmg)')
+
 \ these m4 macros would collide with identifiers
 undefine(`index')
 undefine(`shift')
 undefine(`symbols')
 
+\F 0 [if]
+
+\ run-time routines for non-primitives.  They are defined as
+\ primitives, because that simplifies things.
+
+(docol)	( -- R:a_retaddr )	gforth-internal	paren_docol
+""run-time routine for colon definitions""
+#ifdef NO_IP
+a_retaddr = next_code;
+INST_TAIL;
+goto **(Label *)PFA(CFA);
+#else /* !defined(NO_IP) */
+a_retaddr = (Cell *)IP;
+SET_IP((Xt *)PFA(CFA));
+#endif /* !defined(NO_IP) */
+
+(docon) ( -- w )	gforth-internal	paren_docon
+""run-time routine for constants""
+w = *(Cell *)PFA(CFA);
+#ifdef NO_IP
+INST_TAIL;
+goto *next_code;
+#endif /* defined(NO_IP) */
+
+(dovar) ( -- a_body )	gforth-internal	paren_dovar
+""run-time routine for variables and CREATEd words""
+a_body = PFA(CFA);
+#ifdef NO_IP
+INST_TAIL;
+goto *next_code;
+#endif /* defined(NO_IP) */
+
+(douser) ( -- a_user )	gforth-internal	paren_douser
+""run-time routine for constants""
+a_user = (Cell *)(up+*(Cell *)PFA(CFA));
+#ifdef NO_IP
+INST_TAIL;
+goto *next_code;
+#endif /* defined(NO_IP) */
+
+(dodefer) ( -- )	gforth-internal	paren_dodefer
+""run-time routine for deferred words""
+#ifndef NO_IP
+ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
+#endif /* !defined(NO_IP) */
+SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
+EXEC(*(Xt *)PFA(CFA));
+
+(dofield) ( n1 -- n2 )	gforth-internal	paren_field
+""run-time routine for fields""
+n2 = n1 + *(Cell *)PFA(CFA);
+#ifdef NO_IP
+INST_TAIL;
+goto *next_code;
+#endif /* defined(NO_IP) */
+
+(dodoes) ( -- a_body R:a_retaddr )	gforth-internal	paren_dodoes
+""run-time routine for @code{does>}-defined words""
+#ifdef NO_IP
+a_retaddr = next_code;
+a_body = PFA(CFA);
+INST_TAIL;
+goto **(Label *)DOES_CODE1(CFA);
+#else /* !defined(NO_IP) */
+a_retaddr = (Cell *)IP;
+a_body = PFA(CFA);
+SET_IP(DOES_CODE1(CFA));
+#endif /* !defined(NO_IP) */
+
+(does-handler) ( -- )	gforth-internal	paren_does_handler
+""just a slot to have an encoding for the DOESJUMP, 
+which is no longer used anyway (!! eliminate this)""
+
+\F [endif]
+
 \g control
 
 noop	( -- )		gforth
@@ -150,6 +229,7 @@ noop	( -- )		gforth
 call	( #a_callee -- R:a_retaddr )	new
 ""Call callee (a variant of docol with inline argument).""
 #ifdef NO_IP
+assert(0);
 INST_TAIL;
 JUMP(a_callee);
 #else
@@ -169,7 +249,7 @@ execute	( xt -- )		core
 #ifndef NO_IP
 ip=IP;
 #endif
-IF_spTOS(spTOS = sp[0]);
+IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */
 SUPER_END;
 EXEC(xt);
 
@@ -179,7 +259,7 @@ perform	( a_addr -- )	gforth
 #ifndef NO_IP
 ip=IP;
 #endif
-IF_spTOS(spTOS = sp[0]);
+IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */
 SUPER_END;
 EXEC(*(Xt *)a_addr);
 :
@@ -353,8 +433,9 @@ condbranch((+loop),n R:nlimit R:n1 -- R:
 /* 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 */) {
+,if (((olddiff^(olddiff+n))    /* the limit is not crossed */
+     &(olddiff^n))	       /* OR it is a wrap-around effect */
+    >=0) { /* & is used to avoid having two branches for gforth-native */
 ,:
  r> swap
  r> r> 2dup - >r
@@ -383,7 +464,7 @@ if (n<0) {
     newdiff = -newdiff;
 }
 n2=n1+n;
-,if (diff>=0 || newdiff<0) {
+,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */
 ,)
 
 \+
@@ -594,6 +675,10 @@ n = compare(c_addr1, u1, c_addr2, u2);
 :
  rot 2dup swap - >r min swap -text dup
  IF  rdrop  ELSE  drop r> sgn  THEN ;
+: -text ( c_addr1 u c_addr2 -- n )
+ swap bounds
+ ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
+ ELSE  c@ I c@ - unloop  THEN  sgn ;
 : sgn ( n -- -1/0/1 )
  dup 0= IF EXIT THEN  0< 2* 1+ ;
 
@@ -793,11 +878,10 @@ ud = ummul(u1,u2);
 ud = (UDCell)u1 * (UDCell)u2;
 #endif
 :
-   >r >r 0 0 r> r> [ 8 cells ] literal 0
+   0 -rot dup [ 8 cells ] literal -
    DO
-       over >r dup >r 0< and d2*+ drop
-       r> 2* r> swap
-   LOOP 2drop ;
+	dup 0< I' and d2*+ drop
+   LOOP ;
 : d2*+ ( ud n -- ud+n c )
    over MINI
    and >r >r 2dup d+ swap r> + swap r> ;
@@ -1084,19 +1168,19 @@ rdrop	( R:w -- )		gforth
 :
  r> r> drop >r ;
 
-2>r	( w1 w2 -- R:w1 R:w2 )	core-ext	two_to_r
+2>r	( d -- R:d )	core-ext	two_to_r
 :
  swap r> swap >r swap >r >r ;
 
-2r>	( R:w1 R:w2 -- w1 w2 )	core-ext	two_r_from
+2r>	( R:d -- d )	core-ext	two_r_from
 :
  r> r> swap r> swap >r swap ;
 
-2r@	( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )	core-ext	two_r_fetch
+2r@	( R:d -- R:d d )	core-ext	two_r_fetch
 :
  i' j ;
 
-2rdrop	(  R:w1 R:w2 -- )		gforth	two_r_drop
+2rdrop	( R:d -- )		gforth	two_r_drop
 :
  r> r> drop r> drop >r ;
 
@@ -1316,6 +1400,33 @@ c_addr2 = c_addr1+1;
 
 \g compiler
 
+\+f83headerstring
+
+(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? */)
+    break;
+f83name2=f83name1;
+:
+    BEGIN  dup WHILE  (find-samelen)  dup  WHILE
+	>r 2dup r@ cell+ char+ capscomp  0=
+	IF  2drop r>  EXIT  THEN
+	r> @
+    REPEAT  THEN  nip nip ;
+: (find-samelen) ( u f83name1 -- u f83name2/0 )
+    BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
+: capscomp ( c_addr1 u c_addr2 -- n )
+ swap bounds
+ ?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  sgn ;
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
+
+\-
+
 (listlfind)	( c_addr u longname1 -- longname2 )	new	paren_listlfind
 longname2=listlfind(c_addr, u, longname1);
 :
@@ -1326,6 +1437,14 @@ longname2=listlfind(c_addr, u, longname1
     REPEAT  THEN  nip nip ;
 : (findl-samelen) ( u longname1 -- u longname2/0 )
     BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
+: capscomp ( c_addr1 u c_addr2 -- n )
+ swap bounds
+ ?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  sgn ;
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
 
 \+hash
 
@@ -1349,6 +1468,12 @@ longname2 = tablelfind(c_addr, u, a_addr
 	    IF  2drop r> rdrop  EXIT  THEN  THEN
 	rdrop r>
  REPEAT nip nip ;
+: -text ( c_addr1 u c_addr2 -- n )
+ swap bounds
+ ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
+ ELSE  c@ I c@ - unloop  THEN  sgn ;
+: sgn ( n -- -1/0/1 )
+ dup 0= IF EXIT THEN  0< 2* 1+ ;
 
 (hashkey1)	( c_addr u ubits -- ukey )		gforth	paren_hashkey1
 ""ukey is the hash key for the string c_addr u fitting in ubits bits""
@@ -1368,6 +1493,8 @@ Create rot-values
 
 \+
 
+\+
+
 (parse-white)	( c_addr1 u1 -- c_addr2 u2 )	gforth	paren_parse_white
 struct Cellpair r=parse_white(c_addr1, u1);
 c_addr2 = (Char *)(r.n1);
@@ -1561,7 +1688,7 @@ c_addr = strerror(n);
 u = strlen(c_addr);
 
 strsignal	( n -- c_addr u )	gforth
-c_addr = strsignal(n);
+c_addr = (Address)strsignal(n);
 u = strlen(c_addr);
 
 call-c	( w -- )	gforth	call_c
@@ -2162,6 +2289,216 @@ r = fp[u+1]; /* +1, because update of fp
 
 \g syslib
 
+open-lib	( c_addr1 u1 -- u2 )	gforth	open_lib
+#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
+#ifndef RTLD_GLOBAL
+#define RTLD_GLOBAL 0
+#endif
+u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
+#else
+#  ifdef _WIN32
+u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
+#  else
+#warning Define open-lib!
+u2 = 0;
+#  endif
+#endif
+
+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
+#  ifdef _WIN32
+u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
+#  else
+#warning Define lib-sym!
+u3 = 0;
+#  endif
+#endif
+
+wcall	( u -- )	gforth
+IF_fpTOS(fp[0]=fpTOS);
+FP=fp;
+sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
+fp=FP;
+IF_spTOS(spTOS=sp[0];)
+IF_fpTOS(fpTOS=fp[0]);
+
+\+FFCALL
+
+av-start-void	( c_addr -- )	gforth  av_start_void
+av_start_void(alist, c_addr);
+
+av-start-int	( c_addr -- )	gforth  av_start_int
+av_start_int(alist, c_addr, &irv);
+
+av-start-float	( c_addr -- )	gforth  av_start_float
+av_start_float(alist, c_addr, &frv);
+
+av-start-double	( c_addr -- )	gforth  av_start_double
+av_start_double(alist, c_addr, &drv);
+
+av-start-longlong	( c_addr -- )	gforth  av_start_longlong
+av_start_longlong(alist, c_addr, &llrv);
+
+av-start-ptr	( c_addr -- )	gforth  av_start_ptr
+av_start_ptr(alist, c_addr, void*, &prv);
+
+av-int  ( w -- )  gforth  av_int
+av_int(alist, w);
+
+av-float	( r -- )	gforth  av_float
+av_float(alist, r);
+
+av-double	( r -- )	gforth  av_double
+av_double(alist, r);
+
+av-longlong	( d -- )	gforth  av_longlong
+#ifdef BUGGY_LONG_LONG
+av_longlong(alist, d.lo);
+#else
+av_longlong(alist, d);
+#endif
+
+av-ptr	( c_addr -- )	gforth  av_ptr
+av_ptr(alist, void*, c_addr);
+
+av-int-r  ( R:w -- )  gforth  av_int_r
+av_int(alist, w);
+
+av-float-r	( -- )	gforth  av_float_r
+float r = *(Float*)lp;
+lp += sizeof(Float);
+av_float(alist, r);
+
+av-double-r	( -- )	gforth  av_double_r
+double r = *(Float*)lp;
+lp += sizeof(Float);
+av_double(alist, r);
+
+av-longlong-r	( R:d -- )	gforth  av_longlong_r
+#ifdef BUGGY_LONG_LONG
+av_longlong(alist, d.lo);
+#else
+av_longlong(alist, d);
+#endif
+
+av-ptr-r	( R:c_addr -- )	gforth  av_ptr_r
+av_ptr(alist, void*, c_addr);
+
+av-call-void	( -- )	gforth  av_call_void
+SAVE_REGS
+av_call(alist);
+REST_REGS
+
+av-call-int	( -- w )	gforth  av_call_int
+SAVE_REGS
+av_call(alist);
+REST_REGS
+w = irv;
+
+av-call-float	( -- r )	gforth  av_call_float
+SAVE_REGS
+av_call(alist);
+REST_REGS
+r = frv;
+
+av-call-double	( -- r )	gforth  av_call_double
+SAVE_REGS
+av_call(alist);
+REST_REGS
+r = drv;
+
+av-call-longlong	( -- d )	gforth  av_call_longlong
+SAVE_REGS
+av_call(alist);
+REST_REGS
+#ifdef BUGGY_LONG_LONG
+d = llrv;
+#else
+d.lo = llrv;
+d.hi = 0;
+#endif
+
+av-call-ptr	( -- c_addr )	gforth  av_call_ptr
+SAVE_REGS
+av_call(alist);
+REST_REGS
+c_addr = prv;
+
+alloc-callback	( a_ip -- c_addr )	gforth	alloc_callback
+c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);
+
+va-start-void	( -- )	gforth	va_start_void
+va_start_void(clist);
+
+va-start-int	( -- )	gforth	va_start_int
+va_start_int(clist);
+
+va-start-longlong	( -- )	gforth	va_start_longlong
+va_start_longlong(clist);
+
+va-start-ptr	( -- )	gforth	va_start_ptr
+va_start_ptr(clist, (char *));
+
+va-start-float	( -- )	gforth	va_start_float
+va_start_float(clist);
+
+va-start-double	( -- )	gforth	va_start_double
+va_start_double(clist);
+
+va-arg-int	( -- w )	gforth	va_arg_int
+w = va_arg_int(clist);
+
+va-arg-longlong	( -- d )	gforth	va_arg_longlong
+#ifdef BUGGY_LONG_LONG
+d.lo = va_arg_longlong(clist);
+d.hi = 0;
+#else
+d = va_arg_longlong(clist);
+#endif
+
+va-arg-ptr	( -- c_addr )	gforth	va_arg_ptr
+c_addr = (char *)va_arg_ptr(clist,char*);
+
+va-arg-float	( -- r )	gforth	va_arg_float
+r = va_arg_float(clist);
+
+va-arg-double	( -- r )	gforth	va_arg_double
+r = va_arg_double(clist);
+
+va-return-void ( -- )	gforth va_return_void
+va_return_void(clist);
+return 0;
+
+va-return-int ( w -- )	gforth va_return_int
+va_return_int(clist, w);
+return 0;
+
+va-return-ptr ( c_addr -- )	gforth va_return_ptr
+va_return_ptr(clist, void *, c_addr);
+return 0;
+
+va-return-longlong ( d -- )	gforth va_return_longlong
+#ifdef BUGGY_LONG_LONG
+va_return_longlong(clist, d.lo);
+#else
+va_return_longlong(clist, d);
+#endif
+return 0;
+
+va-return-float ( r -- )	gforth va_return_float
+va_return_float(clist, r);
+return 0;
+
+va-return-double ( r -- )	gforth va_return_double
+va_return_double(clist, r);
+return 0;
+
+\+
+
+\+OLDCALL
+
 define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
 define(`_uploop',
@@ -2193,52 +2530,18 @@ rret = (SYSCALL(Float(*)(argdlist($1)))u
 
 \ close ' to keep fontify happy
 
-open-lib	( c_addr1 u1 -- u2 )	gforth	open_lib
-#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
-#ifndef RTLD_GLOBAL
-#define RTLD_GLOBAL 0
-#endif
-u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
-#else
-#  ifdef _WIN32
-u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
-#  else
-#warning Define open-lib!
-u2 = 0;
-#  endif
-#endif
-
-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
-#  ifdef _WIN32
-u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
-#  else
-#warning Define lib-sym!
-u3 = 0;
-#  endif
-#endif
-
 uploop(i, 0, 7, `icall(i)')
 icall(20)
 uploop(i, 0, 7, `fcall(i)')
 fcall(20)
 
 \+
+\+
 
-wcall	( u -- )	gforth
-IF_fpTOS(fp[0]=fpTOS);
-FP=fp;
-sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
-fp=FP;
-IF_spTOS(spTOS=sp[0];)
-IF_fpTOS(fpTOS=fp[0]);
+\g peephole
 
 \+peephole
 
-\g peephole
-
 compile-prim1 ( a_prim -- ) gforth compile_prim1
 ""compile prim (incl. immargs) at @var{a_prim}""
 compile_prim1(a_prim);
@@ -2246,7 +2549,10 @@ compile_prim1(a_prim);
 finish-code ( -- ) gforth finish_code
 ""Perform delayed steps in code generation (branch resolution, I-cache
 flushing).""
+IF_spTOS(sp[0]=spTOS); /* workaround for failing to save spTOS
+			  (gcc-2.95.1, gforth-fast --enable-force-reg) */
 finish_code();
+IF_spTOS(spTOS=sp[0]);
 
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 f = forget_dyncode(c_code);
@@ -2273,14 +2579,15 @@ JUMP(a_callee);
 assert(0);
 #endif
 
+tag-offsets ( -- a_addr ) gforth tag_offsets
+extern Cell groups[32];
+a_addr = groups;
+
 \+
 
 \g static_super
 
-\C #if !defined(GFORTH_DEBUGGING) && !defined(INDIRECT_THREADED) && !defined(DOUBLY_INDIRECT) && !defined(VM_PROFILING)
-
-include(peeprules.vmg)
-
-\C #endif
+ifdef(`M4_ENGINE_FAST',
+`include(peeprules.vmg)')
 
 \g end