--- gforth/prim	2003/08/17 12:21:05	1.136
+++ gforth/prim	2003/09/14 21:16:48	1.144
@@ -141,6 +141,50 @@ 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""
+a_retaddr = (Cell *)IP;
+SET_IP((Xt *)PFA(CFA));
+
+(docon) ( -- w )	gforth-internal	paren_docon
+""run-time routine for constants""
+w = *(Cell *)PFA(CFA);
+
+(dovar) ( -- a_body )	gforth-internal	paren_dovar
+""run-time routine for variables and CREATEd words""
+a_body = PFA(CFA);
+
+(douser) ( -- a_user )	gforth-internal	paren_douser
+""run-time routine for constants""
+a_user = (Cell *)(up+*(Cell *)PFA(CFA));
+
+(dodefer) ( -- )	gforth-internal	paren_dodefer
+""run-time routine for deferred words""
+ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
+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);
+
+(dodoes) ( -- a_body R:a_retaddr )	gforth-internal	paren_dodoes
+""run-time routine for @code{does>}-defined words""
+a_retaddr = (Cell *)IP;
+a_body = PFA(CFA);
+SET_IP(DOES_CODE1(CFA));
+
+(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
@@ -594,6 +638,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 +841,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> ;
@@ -1316,6 +1363,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 +1400,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 +1431,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 +1456,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);
@@ -2189,6 +2279,14 @@ 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
@@ -2338,7 +2436,9 @@ va-return-double ( r -- )	gforth va_retu
 va_return_double(clist, r);
 return 0;
 
-\-
+\+
+
+\+OLDCALL
 
 define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
@@ -2379,18 +2479,10 @@ 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);