--- gforth/prim 2004/03/29 13:54:14 1.152 +++ gforth/prim 2005/03/17 18:49:03 1.170 @@ -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 @@ -330,6 +328,8 @@ SET_IP((Xt *)a_target); \ 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 @@ -339,6 +339,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 } @@ -488,10 +519,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 @@ -511,10 +540,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 @@ -534,10 +561,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 @@ -557,10 +582,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 @@ -580,10 +603,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 @@ -784,20 +805,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; @@ -817,19 +885,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 @@ -839,19 +923,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 @@ -860,7 +952,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; @@ -872,7 +964,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; @@ -888,13 +980,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 @@ -907,9 +1007,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 @@ -960,9 +1060,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 @@ -988,12 +1088,20 @@ w2 = ~w1; rshift ( u1 n -- u2 ) core r_shift ""Logical shift right by @i{n} bits."" - u2 = u1>>n; +#ifdef BROKEN_SHIFT + u2 = rshift(u1, n); +#else + u2 = u1 >> n; +#endif : 0 ?DO 2/ MAXI and LOOP ; lshift ( u1 n -- u2 ) core l_shift - u2 = u1< ( $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); @@ -1590,16 +1698,8 @@ SUPER_END; return (Label *)n; (system) ( c_addr u -- wretval wior ) gforth paren_system -#ifndef MSDOS -int old_tp=terminal_prepped; -deprep_terminal(); -#endif -wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ +wretval = gforth_system(c_addr, u); wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); -#ifndef MSDOS -if (old_tp) - prep_terminal(); -#endif getenv ( c_addr1 u1 -- c_addr2 u2 ) gforth ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2} @@ -1845,6 +1945,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 @@ -1887,11 +2002,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 \+ @@ -1904,13 +2015,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 @@ -2035,6 +2150,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); @@ -2354,8 +2472,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 @@ -2377,8 +2495,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 @@ -2414,8 +2532,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 @@ -2452,8 +2570,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