--- gforth/prim 2002/10/27 09:57:11 1.101 +++ gforth/prim 2002/12/24 23:40:29 1.108 @@ -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 @@ -1279,7 +1288,8 @@ while(u1--) ASCII strings (larger if ubits is large), and should share no divisors with ubits. */ -unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits]; +static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5}; +unsigned rot = rot_values[ubits]; Char *cp = c_addr; for (ukey=0; cp>(ubits-rot))) @@ -1595,19 +1605,19 @@ wior = IOR(rename(tilde_cstr(c_addr1, u1 file-position ( wfileid -- ud wior ) file file_position /* !! use tell and lseek? */ -ud = LONG2UD(ftell((FILE *)wfileid)); -wior = IOR(UD2LONG(ud)==-1); +ud = OFF2UD(ftello((FILE *)wfileid)); +wior = IOR(UD2OFF(ud)==-1); reposition-file ( ud wfileid -- wior ) file reposition_file -wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); +wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); file-size ( wfileid -- ud wior ) file file_size struct stat buf; wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); -ud = LONG2UD(buf.st_size); +ud = OFF2UD(buf.st_size); resize-file ( ud wfileid -- wior ) file resize_file -wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1); +wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); read-file ( c_addr u1 wfileid -- u2 wior ) file read_file /* !! fread does not guarantee enough */ @@ -1799,16 +1809,9 @@ floor ( r1 -- r2 ) float /* !! unclear wording */ r2 = floor(r1); -(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 +fround ( r1 -- r2 ) gforth f_round +""Round to the nearest integral value."" r2 = rint(r1); -#else -r2 = floor(r1+0.5); -/* !! This is not quite true to the rounding rules given in the standard */ -#endif fmax ( r1 r2 -- r3 ) float f_max if (r1 @ >r ; -\ acondbranch(forthname,stackeffect,restline,code,forthcode) +\ 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 SET_IP((Xt *)a_target); +$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; -$5 +$6 \+glocals $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number -$4 lp += nlocals; -SET_IP((Xt *)a_target); +$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; @@ -2487,7 +2526,7 @@ SUPER_CONTINUE; ) acondbranch(a?branch,f --,f83 aquestion_branch, -if (f==0) { +,if (f==0) { ,: 0= dup \ !f !f \ !! still uses relative addresses r> dup @ \ !f !f IP branchoffset @@ -2505,8 +2544,13 @@ a?dup-?branch ( #a_target f -- f ) new a if (f==0) { sp++; IF_spTOS(spTOS = sp[0]); - SET_IP((Xt *)a_target); - INST_TAIL; +#ifdef NO_IP +INST_TAIL; +JUMP(a_target); +#else +SET_IP((Xt *)a_target); + INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; @@ -2518,8 +2562,12 @@ few cycles in that case, but is easy to invocation */ if (f!=0) { sp--; +#ifdef NO_IP + JUMP(a_target); +#else SET_IP((Xt *)a_target); NEXT; +#endif } SUPER_CONTINUE; @@ -2529,14 +2577,14 @@ SUPER_CONTINUE; acondbranch(a(next),R:n1 -- R:n2,cmFORTH aparen_next, n2=n1-1; -if (n1) { +,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) { +,if (n2 != nlimit) { ,: r> r> 1+ r> 2dup = IF >r 1- >r cell+ >r @@ -2548,7 +2596,7 @@ acondbranch(a(+loop),n R:nlimit R:n1 -- /* dependent upon two's complement arithmetic */ Cell olddiff = n1-nlimit; n2=n1+n; -if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ +,if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ || (olddiff^n)>=0 /* it is a wrap-around effect */) { ,: r> swap @@ -2563,7 +2611,7 @@ if ((olddiff^(olddiff+n))>=0 /* the li 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) { +,if (olddiff>u) { ,) acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_symmetric_plus_loop, @@ -2578,13 +2626,20 @@ if (n<0) { newdiff = -newdiff; } n2=n1+n; -if (diff>=0 || newdiff<0) { +,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; + INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2598,9 +2653,16 @@ SUPER_CONTINUE; \+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; + INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2614,9 +2676,16 @@ SUPER_CONTINUE; THEN >r ; a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do -if (ustart >= ulimit) { - SET_IP((Xt *)a_target); +#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; : @@ -2630,9 +2699,16 @@ SUPER_CONTINUE; THEN >r ; a(-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do -if (nstart <= nlimit) { - SET_IP((Xt *)a_target); +#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; : @@ -2646,9 +2722,16 @@ SUPER_CONTINUE; THEN >r ; a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do -if (ustart <= ulimit) { - SET_IP((Xt *)a_target); +#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; : @@ -2661,6 +2744,40 @@ SUPER_CONTINUE; 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 ( c_code -- f ) gforth-internal forget_dyncode +f = forget_dyncode(c_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)