--- gforth/prim	2002/09/24 16:16:43	1.98
+++ gforth/prim	2002/12/13 15:49:53	1.104
@@ -148,7 +148,9 @@ lit	( #w -- w )		gforth
 
 execute	( xt -- )		core
 ""Perform the semantics represented by the execution token, @i{xt}.""
+#ifndef NO_IP
 ip=IP;
+#endif
 IF_spTOS(spTOS = sp[0]);
 SUPER_END;
 EXEC(xt);
@@ -156,7 +158,9 @@ EXEC(xt);
 perform	( a_addr -- )	gforth
 ""@code{@@ execute}.""
 /* and pfe */
+#ifndef NO_IP
 ip=IP;
+#endif
 IF_spTOS(spTOS = sp[0]);
 SUPER_END;
 EXEC(*(Xt *)a_addr);
@@ -961,7 +965,12 @@ fp = f_addr;
 
 ;s	( R:w -- )		gforth	semis
 ""The primitive compiled by @code{EXIT}.""
+#ifdef NO_IP
+INST_TAIL;
+goto *(void *)w;
+#else
 SET_IP((Xt *)w);
+#endif
 
 \g stack
 
@@ -1708,12 +1717,8 @@ r = d;
 #endif
 
 f>d	( r -- d )		float	f_to_d
-#ifdef BUGGY_LONG_LONG
-d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
-d.lo = r-ldexp((Float)d.hi,CELL_BITS);
-#else
-d = r;
-#endif
+extern DCell double2ll(Float r);
+d = double2ll(r);
 
 f!	( r f_addr -- )	float	f_store
 ""Store @i{r} into the float at address @i{f-addr}.""
@@ -1803,8 +1808,9 @@ floor	( r1 -- r2 )	float
 /* !! unclear wording */
 r2 = floor(r1);
 
-fround	( r1 -- r2 )	float	f_round
-""Round to the nearest integral value.""
+(fround)	( r1 -- r2 )	gforth	paren_f_round
+""Round to the nearest integral value.  Primitive variant (unused)""
+/* !! eliminate this as primitive? */
 /* !! unclear wording */
 #ifdef HAVE_RINT
 r2 = rint(r1);
@@ -2411,6 +2417,10 @@ xt = peephole_opt(xt1, xt2, wpeeptable);
 
 call	( #a_callee -- R:a_retaddr )	new
 ""Call callee (a variant of docol with inline argument).""
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_callee);
+#else
 #ifdef DEBUG
     {
       CFA_TO_NAME((((Cell *)a_callee)-2));
@@ -2420,6 +2430,7 @@ call	( #a_callee -- R:a_retaddr )	new
 #endif
 a_retaddr = (Cell *)IP;
 SET_IP((Xt *)a_callee);
+#endif
 
 useraddr	( #u -- a_addr )	new
 a_addr = (Cell *)(up+u);
@@ -2433,7 +2444,9 @@ lit@		( #a_addr -- w ) new	lit_fetch
 w = *a_addr;
 
 lit-perform	( #a_addr -- )	new	lit_perform
+#ifndef NO_IP
 ip=IP;
+#endif
 SUPER_END;
 EXEC(*(Xt *)a_addr);
 
@@ -2443,8 +2456,12 @@ lit+	( n1 #n2 -- n )		new	lit_plus
 n=n1+n2;
 
 does-exec ( #a_cfa -- R:nest a_pfa )	new	does_exec
+#ifdef NO_IP
+/* compiled to LIT CALL by compile_prim */
+assert(0);
+#else
 a_pfa = PFA(a_cfa);
-nest = (Cell)ip;
+nest = (Cell)IP;
 IF_spTOS(spTOS = sp[0]);
 #ifdef DEBUG
     {
@@ -2454,6 +2471,320 @@ IF_spTOS(spTOS = sp[0]);
     }
 #endif
 SET_IP(DOES_CODE1(a_cfa));
+#endif
+
+abranch-lp+!# ( #a_target #nlocals -- )	gforth	abranch_lp_plus_store_number
+/* this will probably not be used */
+lp += nlocals;
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+#endif
+
+\+
+
+abranch	( #a_target -- )	gforth
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+#endif
+:
+ r> @ >r ;
+
+\ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)
+\ this is non-syntactical: code must open a brace that is closed by the macro
+define(acondbranch,
+$1 ( `#'a_target $2 ) $3
+$4	#ifdef NO_IP
+INST_TAIL;
+#endif
+$5	#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+$6
+
+\+glocals
+
+$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
+$4	#ifdef NO_IP
+INST_TAIL;
+#endif
+$5	lp += nlocals;
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+
+\+
+)
+
+acondbranch(a?branch,f --,f83	aquestion_branch,
+,if (f==0) {
+,:
+ 0= dup     \ !f !f \ !! still uses relative addresses
+ r> dup @   \ !f !f IP branchoffset
+ rot and +  \ !f IP|IP+branchoffset
+ swap 0= cell and + \ IP''
+ >r ;)
+
+\ we don't need an lp_plus_store version of the ?dup-stuff, because it
+\ is only used in if's (yet)
+
+\+xconds
+
+a?dup-?branch	( #a_target f -- f )	new	aquestion_dupe_question_branch
+""The run-time procedure compiled by @code{?DUP-IF}.""
+if (f==0) {
+  sp++;
+  IF_spTOS(spTOS = sp[0]);
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+  INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+
+a?dup-0=-?branch ( #a_target f -- ) new	aquestion_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
+few cycles in that case, but is easy to convert to a CONDBRANCH
+invocation */
+if (f!=0) {
+  sp--;
+#ifdef NO_IP
+  JUMP(a_target);
+#else
+  SET_IP((Xt *)a_target);
+  NEXT;
+#endif
+}
+SUPER_CONTINUE;
+
+\+
+\f[THEN]
+\fhas? skiploopprims 0= [IF]
+
+acondbranch(a(next),R:n1 -- R:n2,cmFORTH	aparen_next,
+n2=n1-1;
+,if (n1) {
+,:
+ r> r> dup 1- >r
+ IF @ >r ELSE cell+ >r THEN ;)
+
+acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth	aparen_loop,
+n2=n1+1;
+,if (n2 != nlimit) {
+,:
+ r> r> 1+ r> 2dup =
+ IF >r 1- >r cell+ >r
+ ELSE >r >r @ >r THEN ;)
+
+acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,
+/* !! check this thoroughly */
+/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
+/* 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 */) {
+,:
+ r> swap
+ r> r> 2dup - >r
+ 2 pick r@ + r@ xor 0< 0=
+ 3 pick r> xor 0< 0= or
+ IF    >r + >r @ >r
+ ELSE  >r >r drop cell+ >r THEN ;)
+
+\+xconds
+
+acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,
+UCell olddiff = n1-nlimit;
+n2=n1-u;
+,if (olddiff>u) {
+,)
+
+acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth	aparen_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 diff = n1-nlimit;
+Cell newdiff = diff+n;
+if (n<0) {
+    diff = -diff;
+    newdiff = -newdiff;
+}
+n2=n1+n;
+,if (diff>=0 || newdiff<0) {
+,)
+
+a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_question_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (nstart == nlimit) {
+#ifdef NO_IP
+    JUMP(a_target);
+#else
+    SET_IP((Xt *)a_target);
+    INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+  2dup =
+  IF   r> swap rot >r >r
+       @ >r
+  ELSE r> swap rot >r >r
+       cell+ >r
+  THEN ;				\ --> CORE-EXT
+
+\+xconds
+
+a(+do)	( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_plus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (nstart >= nlimit) {
+#ifdef NO_IP
+    JUMP(a_target);
+#else
+    SET_IP((Xt *)a_target);
+    INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ >=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(u+do)	( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth	aparen_u_plus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (ustart >= ulimit) {
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ u>=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(-do)	( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_minus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (nstart <= nlimit) {
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ <=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(u-do)	( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth	aparen_u_minus_do
+#ifdef NO_IP
+    INST_TAIL;
+#endif
+if (ustart <= ulimit) {
+#ifdef NO_IP
+JUMP(a_target);
+#else
+SET_IP((Xt *)a_target);
+INST_TAIL; NEXT_P2;
+#endif
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ u<=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+\ set-next-code and call2 do not appear in images and can be
+\ renumbered arbitrarily
+
+set-next-code ( #w -- ) gforth set_next_code
+#ifdef NO_IP
+next_code = (Label)w;
+#endif
+
+call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
+/* call with explicit return address */
+#ifdef NO_IP
+INST_TAIL;
+JUMP(a_callee);
+#else
+assert(0);
+#endif
+
+compile-prim1 ( a_prim -- ) gforth compile_prim1
+""compile prim (incl. immargs) at @var{a_prim}""
+compile_prim1(a_prim);
+
+finish-code ( -- ) gforth finish_code
+""Perform delayed steps in code generation (branch resolution, I-cache
+flushing).""
+finish_code();
+
+forget-dyncode ( a_code -- f ) gforth-internal forget_dyncode
+f = forget_dyncode(a_code);
+
+decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
+""a_prim is the code address of the primitive that has been
+compile_prim1ed to a_code""
+a_prim = decompile_code(a_code);
+
+\+
 
 include(peeprules.vmg)