--- gforth/prim 2004/08/27 15:53:50 1.155 +++ gforth/prim 2005/07/27 19:44:20 1.171 @@ -1,6 +1,6 @@ \ Gforth primitives -\ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -191,7 +191,7 @@ goto *next_code; 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)); +VM_JUMP(EXEC1(*(Xt *)PFA(CFA))); (dofield) ( n1 -- n2 ) gforth-internal paren_field ""run-time routine for fields"" @@ -249,9 +249,8 @@ execute ( xt -- ) core #ifndef NO_IP ip=IP; #endif -IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */ SUPER_END; -EXEC(xt); +VM_JUMP(EXEC1(xt)); perform ( a_addr -- ) gforth ""@code{@@ execute}."" @@ -259,9 +258,8 @@ perform ( a_addr -- ) gforth #ifndef NO_IP ip=IP; #endif -IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */ SUPER_END; -EXEC(*(Xt *)a_addr); +VM_JUMP(EXEC1(*(Xt *)a_addr)); : @ execute ; @@ -284,7 +282,7 @@ lit-perform ( #a_addr -- ) new lit_perfo ip=IP; #endif SUPER_END; -EXEC(*(Xt *)a_addr); +VM_JUMP(EXEC1(*(Xt *)a_addr)); does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec #ifdef NO_IP @@ -293,7 +291,6 @@ assert(0); #else a_pfa = PFA(a_cfa); nest = (Cell)IP; -IF_spTOS(spTOS = sp[0]); #ifdef DEBUG { CFA_TO_NAME(a_cfa); @@ -324,15 +321,14 @@ INST_TAIL; JUMP(a_target); #else SET_IP((Xt *)a_target); -INST_TAIL; -NEXT_P2; #endif -SUPER_CONTINUE; /* we do our own control flow, so don't append NEXT etc. */ : r> @ >r ; \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) \ this is non-syntactical: code must open a brace that is closed by the macro +\ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) +\ this is non-syntactical: code must open a brace that is closed by the macro define(condbranch, $1 ( `#'a_target $2 ) $3 $4 #ifdef NO_IP @@ -342,6 +338,37 @@ $5 #ifdef NO_IP JUMP(a_target); #else SET_IP((Xt *)a_target); +#endif +} +$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); +#endif +} + +\+ +) + +\ version that generates two jumps (not good for PR 15242 workaround) +define(condbranch_twojump, +$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 } @@ -491,10 +518,8 @@ if (nstart == nlimit) { JUMP(a_target); #else SET_IP((Xt *)a_target); - INST_TAIL; NEXT_P2; #endif } -SUPER_CONTINUE; : 2dup = IF r> swap rot >r >r @@ -514,10 +539,8 @@ if (nstart >= nlimit) { JUMP(a_target); #else SET_IP((Xt *)a_target); - INST_TAIL; NEXT_P2; #endif } -SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -537,10 +560,8 @@ if (ustart >= ulimit) { JUMP(a_target); #else SET_IP((Xt *)a_target); -INST_TAIL; NEXT_P2; #endif } -SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -560,10 +581,8 @@ if (nstart <= nlimit) { JUMP(a_target); #else SET_IP((Xt *)a_target); -INST_TAIL; NEXT_P2; #endif } -SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -583,10 +602,8 @@ if (ustart <= ulimit) { JUMP(a_target); #else SET_IP((Xt *)a_target); -INST_TAIL; NEXT_P2; #endif } -SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -787,20 +804,67 @@ n = n1*n2; / ( n1 n2 -- n ) core slash n = n1/n2; +if(FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) n--; : /mod nip ; mod ( n1 n2 -- n ) core n = n1%n2; +if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2; : /mod drop ; /mod ( n1 n2 -- n3 n4 ) core slash_mod n4 = n1/n2; n3 = n1%n2; /* !! is this correct? look into C standard! */ +if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) { + n4--; + n3+=n2; +} : >r s>d r> fm/mod ; +*/mod ( n1 n2 n3 -- n4 n5 ) core star_slash_mod +""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double."" +#ifdef BUGGY_LL_MUL +DCell d = mmul(n1,n2); +#else +DCell d = (DCell)n1 * (DCell)n2; +#endif +#ifdef BUGGY_LL_DIV +DCell r = fmdiv(d,n3); +n4=DHI(r); +n5=DLO(r); +#else +/* assumes that the processor uses either floored or symmetric division */ +n5 = d/n3; +n4 = d%n3; +if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) { + n5--; + n4+=n3; +} +#endif +: + >r m* r> fm/mod ; + +*/ ( n1 n2 n3 -- n4 ) core star_slash +""n4=(n1*n2)/n3, with the intermediate result being double."" +#ifdef BUGGY_LL_MUL +DCell d = mmul(n1,n2); +#else +DCell d = (DCell)n1 * (DCell)n2; +#endif +#ifdef BUGGY_LL_DIV +DCell r = fmdiv(d,n3); +n4=DLO(r); +#else +/* assumes that the processor uses either floored or symmetric division */ +n4 = d/n3; +if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0) n4--; +#endif +: + */mod nip ; + 2* ( n1 -- n2 ) core two_star ""Shift left by 1; also works on unsigned numbers"" n2 = 2*n1; @@ -820,19 +884,35 @@ n2 = n1>>1; fm/mod ( d1 n1 -- n2 n3 ) core f_m_slash_mod ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}."" -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_DIV +#ifdef ASM_SM_SLASH_REM +ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3); +if (((DHI(d1)^n1)<0) && n2!=0) { + n3--; + n2+=n1; +} +#else /* !defined(ASM_SM_SLASH_REM) */ DCell r = fmdiv(d1,n1); -n2=r.hi; -n3=r.lo; -#else +n2=DHI(r); +n3=DLO(r); +#endif /* !defined(ASM_SM_SLASH_REM) */ +#else +#ifdef ASM_SM_SLASH_REM4 +ASM_SM_SLASH_REM4(d1, n1, n2, n3); +if (((DHI(d1)^n1)<0) && n2!=0) { + n3--; + n2+=n1; +} +#else /* !defined(ASM_SM_SLASH_REM4) */ /* assumes that the processor uses either floored or symmetric division */ n3 = d1/n1; n2 = d1%n1; /* note that this 1%-3>0 is optimized by the compiler */ -if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) { +if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) { n3--; n2+=n1; } +#endif /* !defined(ASM_SM_SLASH_REM4) */ #endif : dup >r dup 0< IF negate >r dnegate r> THEN @@ -842,19 +922,27 @@ if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) sm/rem ( d1 n1 -- n2 n3 ) core s_m_slash_rem ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0."" -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_DIV +#ifdef ASM_SM_SLASH_REM +ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3); +#else /* !defined(ASM_SM_SLASH_REM) */ DCell r = smdiv(d1,n1); -n2=r.hi; -n3=r.lo; -#else +n2=DHI(r); +n3=DLO(r); +#endif /* !defined(ASM_SM_SLASH_REM) */ +#else +#ifdef ASM_SM_SLASH_REM4 +ASM_SM_SLASH_REM4(d1, n1, n2, n3); +#else /* !defined(ASM_SM_SLASH_REM4) */ /* assumes that the processor uses either floored or symmetric division */ n3 = d1/n1; n2 = d1%n1; /* note that this 1%-3<0 is optimized by the compiler */ -if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) { +if (1%-3<0 && ((DHI(d1)^n1)<0) && n2!=0) { n3++; n2-=n1; } +#endif /* !defined(ASM_SM_SLASH_REM4) */ #endif : over >r dup >r abs -rot @@ -863,7 +951,7 @@ if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) r> 0< IF swap negate swap THEN ; m* ( n1 n2 -- d ) core m_star -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_MUL d = mmul(n1,n2); #else d = (DCell)n1 * (DCell)n2; @@ -875,7 +963,7 @@ d = (DCell)n1 * (DCell)n2; um* ( u1 u2 -- ud ) core u_m_star /* use u* as alias */ -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_MUL ud = ummul(u1,u2); #else ud = (UDCell)u1 * (UDCell)u2; @@ -891,13 +979,21 @@ ud = (UDCell)u1 * (UDCell)u2; um/mod ( ud u1 -- u2 u3 ) core u_m_slash_mod ""ud=u3*u1+u2, u1>u2>=0"" -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_DIV +#ifdef ASM_UM_SLASH_MOD +ASM_UM_SLASH_MOD(ud.lo, ud.hi, u1, u2, u3); +#else /* !defined(ASM_UM_SLASH_MOD) */ UDCell r = umdiv(ud,u1); -u2=r.hi; -u3=r.lo; -#else +u2=DHI(r); +u3=DLO(r); +#endif /* !defined(ASM_UM_SLASH_MOD) */ +#else +#ifdef ASM_UM_SLASH_MOD4 +ASM_UM_SLASH_MOD4(ud, u1, u2, u3); +#else /* !defined(ASM_UM_SLASH_MOD4) */ u3 = ud/u1; u2 = ud%u1; +#endif /* !defined(ASM_UM_SLASH_MOD4) */ #endif : 0 swap [ 8 cells 1 + ] literal 0 @@ -910,9 +1006,9 @@ u2 = ud%u1; and >r >r 2dup d+ swap r> + swap r> ; m+ ( d1 n -- d2 ) double m_plus -#ifdef BUGGY_LONG_LONG -d2.lo = d1.lo+n; -d2.hi = d1.hi - (n<0) + (d2.lod d+ ; d+ ( d1 d2 -- d ) double d_plus -#ifdef BUGGY_LONG_LONG -d.lo = d1.lo+d2.lo; -d.hi = d1.hi + d2.hi + (d.lor tuck + swap over u> r> swap - ; d- ( d1 d2 -- d ) double d_minus -#ifdef BUGGY_LONG_LONG -d.lo = d1.lo - d2.lo; -d.hi = d1.hi-d2.hi-(d1.lo>(CELL_BITS-1)); +#ifdef BUGGY_LL_SHIFT +DLO_IS(d2, DLO(d1)<<1); +DHI_IS(d2, (DHI(d1)<<1) | (DLO(d1)>>(CELL_BITS-1))); #else d2 = 2*d1; #endif @@ -963,9 +1059,9 @@ d2 = 2*d1; d2/ ( d1 -- d2 ) double d_two_slash ""Arithmetic shift right by 1. For signed numbers this is a floored division by 2."" -#ifdef BUGGY_LONG_LONG -d2.hi = d1.hi>>1; -d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1)); +#ifdef BUGGY_LL_SHIFT +DHI_IS(d2, DHI(d1)>>1); +DLO_IS(d2, (DLO(d1)>>1) | (DHI(d1)<<(CELL_BITS-1))); #else d2 = d1>>1; #endif @@ -1068,42 +1164,42 @@ comparisons(u, u1 u2, u_, u1, u2, gforth \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...) define(dcomparisons, $1= ( $2 -- f ) $6 $3equals -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_CMP f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); #else f = FLAG($4==$5); #endif $1<> ( $2 -- f ) $7 $3not_equals -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_CMP f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); #else f = FLAG($4!=$5); #endif $1< ( $2 -- f ) $8 $3less_than -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_CMP f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); #else f = FLAG($4<$5); #endif $1> ( $2 -- f ) $9 $3greater_than -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_CMP f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); #else f = FLAG($4>$5); #endif $1<= ( $2 -- f ) gforth $3less_or_equal -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_CMP f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi); #else f = FLAG($4<=$5); #endif $1>= ( $2 -- f ) gforth $3greater_or_equal -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_CMP f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi); #else f = FLAG($4>=$5); @@ -1848,6 +1944,21 @@ char * string = cstr(c_addr1, u1, 1); char * pattern = cstr(c_addr2, u2, 0); flag = FLAG(!fnmatch(pattern, string, 0)); +set-dir ( c_addr u -- wior ) gforth set_dir +""Change the current directory to @i{c-addr, u}. +Return an error if this is not possible"" +wior = IOR(chdir(tilde_cstr(c_addr, u, 1))); + +get-dir ( c_addr1 u1 -- c_addr2 u2 ) gforth get_dir +""Store the current directory in the buffer specified by @{c-addr1, u1}. +If the buffer size is not sufficient, return 0 0"" +c_addr2 = getcwd(c_addr1, u1); +if(c_addr2 != NULL) { + u2 = strlen(c_addr2); +} else { + u2 = 0; +} + \+ newline ( -- c_addr u ) gforth @@ -1890,11 +2001,7 @@ dsystem = timeval2us(&usage.ru_stime); struct timeval time1; gettimeofday(&time1,NULL); duser = timeval2us(&time1); -#ifndef BUGGY_LONG_LONG -dsystem = (DCell)0; -#else -dsystem=(DCell){0,0}; -#endif +dsystem = DZERO; #endif \+ @@ -1907,13 +2014,17 @@ comparisons(f, r1 r2, f_, r1, r2, gforth comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) d>f ( d -- r ) float d_to_f -#ifdef BUGGY_LONG_LONG +#ifdef BUGGY_LL_D2F extern double ldexp(double x, int exp); -if (d.hi<0) { +if (DHI(d)<0) { +#ifdef BUGGY_LL_ADD DCell d2=dnegate(d); - r = -(ldexp((Float)d2.hi,CELL_BITS) + (Float)d2.lo); +#else + DCell d2=-d; +#endif + r = -(ldexp((Float)DHI(d2),CELL_BITS) + (Float)DLO(d2)); } else - r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo; + r = ldexp((Float)DHI(d),CELL_BITS) + (Float)DLO(d); #else r = d; #endif @@ -2038,6 +2149,9 @@ f2=FLAG(isdigit((unsigned)(sig[0]))!=0); siglen=strlen(sig); if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */ siglen=u; +if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */ + for (; sig[siglen-1]=='0'; siglen--); + ; memcpy(c_addr,sig,siglen); memset(c_addr+siglen,f2?'0':' ',u-siglen); @@ -2357,8 +2471,8 @@ 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); +#ifdef BUGGY_LL_SIZE +av_longlong(alist, DLO(d)); #else av_longlong(alist, d); #endif @@ -2380,8 +2494,8 @@ 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); +#ifdef BUGGY_LL_SIZE +av_longlong(alist, DLO(d)); #else av_longlong(alist, d); #endif @@ -2417,8 +2531,8 @@ SAVE_REGS av_call(alist); REST_REGS #ifdef BUGGY_LONG_LONG -d.lo = llrv; -d.hi = 0; +DLO_IS(d, llrv); +DHI_IS(d, 0); #else d = llrv; #endif @@ -2455,8 +2569,8 @@ 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; +DLO_IS(d, va_arg_longlong(clist)); +DHI_IS(d, 0); #else d = va_arg_longlong(clist); #endif