--- gforth/prim 2002/09/24 16:16:43 1.98 +++ gforth/prim 2002/12/28 17:18:27 1.110 @@ -105,6 +105,7 @@ \E \E set-current \E store-optimization on +\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump \ \ @@ -148,7 +149,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 +159,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); @@ -813,6 +818,8 @@ lshift ( u1 n -- u2 ) core l_shift : 0 ?DO 2* LOOP ; +\g compare + \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) define(comparisons, $1= ( $2 -- f ) $6 $3equals @@ -934,8 +941,6 @@ f = FLAG(u1-u2 < u3-u2); : over - >r - r> u< ; -\g internal - sp@ ( -- a_addr ) gforth sp_fetch a_addr = sp+1; @@ -961,7 +966,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 @@ -1081,6 +1091,8 @@ w = sp[u+1]; \ toggle is high-level: 0.11/0.42% +\g memory + @ ( a_addr -- w ) core fetch ""@i{w} is the cell stored at @i{a_addr}."" w = *a_addr; @@ -1202,6 +1214,8 @@ c_addr2 = c_addr1+1; : dup 1+ swap c@ ; +\g compiler + (f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) if ((UCell)F83NAME_COUNT(f83name1)==u && @@ -1279,7 +1293,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 +1610,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 */ @@ -1708,12 +1723,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,15 +1814,9 @@ floor ( r1 -- r2 ) float /* !! unclear wording */ r2 = floor(r1); -fround ( r1 -- r2 ) float f_round +fround ( r1 -- r2 ) gforth f_round ""Round to the nearest integral value."" -/* !! unclear wording */ -#ifdef HAVE_RINT 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,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 ( 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) +\g end + \+