--- gforth/prim 2005/07/31 20:27:41 1.173 +++ gforth/prim 2006/02/19 17:27:12 1.189 @@ -1,6 +1,6 @@ \ Gforth primitives -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -417,12 +417,11 @@ INST_TAIL; JUMP(a_target); #else SET_IP((Xt *)a_target); - INST_TAIL; NEXT_P2; #endif -} +} else { sp--; sp[0]=f; -SUPER_CONTINUE; +} ?dup-0=-?branch ( #a_target f -- S:... ) new question_dupe_zero_equals_question_branch ""The run-time procedure compiled by @code{?DUP-0=-IF}."" @@ -433,10 +432,8 @@ if (f!=0) { JUMP(a_target); #else SET_IP((Xt *)a_target); - NEXT; #endif } -SUPER_CONTINUE; \+ \fhas? skiploopprims 0= [IF] @@ -722,6 +719,15 @@ c2 = toupper(c1); : dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; +capscompare ( c_addr1 u1 c_addr2 u2 -- n ) string +""Compare two strings lexicographically. If they are equal, @i{n} is 0; if +the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} +is 1. Currently this is based on the machine's character +comparison. In the future, this may change to consider the current +locale and its collation order."" +/* close ' to keep fontify happy */ +n = capscompare(c_addr1, u1, c_addr2, u2); + /string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} characters from the start of the string."" @@ -876,7 +882,7 @@ division by 2 (note that @code{/} not ne n2 = n1>>1; : dup MINI and IF 1 ELSE 0 THEN - [ bits/byte cell * 1- ] literal + [ bits/char cell * 1- ] literal 0 DO 2* swap dup 2* >r MINI and IF 1 ELSE 0 THEN or r> swap LOOP nip ; @@ -1232,7 +1238,7 @@ useraddr ( #u -- a_addr ) new a_addr = (Cell *)(up+u); up! ( a_addr -- ) gforth up_store -UP=up=(char *)a_addr; +gforth_UP=up=(char *)a_addr; : up ! ; Variable UP @@ -1648,7 +1654,7 @@ n = key((FILE*)wfileid); n = key(stdin); #endif -key?-file ( wfileid -- n ) facility key_q_file +key?-file ( wfileid -- n ) gforth key_q_file #ifdef HAS_FILE fflush(stdout); n = key_query((FILE*)wfileid); @@ -1675,6 +1681,10 @@ with the window size."" urows=rows; ucols=cols; +wcwidth ( u -- n ) gforth +""The number of fixed-width characters per unicode character u"" +n = wcwidth(u); + flush-icache ( c_addr u -- ) gforth flush_icache ""Make sure that the instruction cache of the processor (if there is one) does not contain stale data at @i{c-addr} and @i{u} bytes @@ -1791,11 +1801,11 @@ access the stack itself. The stack point variables @code{SP} and @code{FP}."" /* This is a first attempt at support for calls to C. This may change in the future */ -FP=fp; -SP=sp; +gforth_FP=fp; +gforth_SP=sp; ((void (*)())w)(); -sp=SP; -fp=FP; +sp=gforth_SP; +fp=gforth_FP; \+ \+file @@ -2005,6 +2015,9 @@ dsystem = DZERO; comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) +s>f ( n -- r ) float s_to_f +r = n; + d>f ( d -- r ) float d_to_f #ifdef BUGGY_LL_D2F extern double ldexp(double x, int exp); @@ -2025,6 +2038,9 @@ f>d ( r -- d ) float f_to_d extern DCell double2ll(Float r); d = double2ll(r); +f>s ( r -- n ) float f_to_s +n = (Cell)r; + f! ( r f_addr -- ) float f_store ""Store @i{r} into the float at address @i{f-addr}."" *f_addr = r; @@ -2083,6 +2099,18 @@ f** ( r1 r2 -- r3 ) float-ext f_star_sta ""@i{r3} is @i{r1} raised to the @i{r2}th power."" r3 = pow(r1,r2); +fm* ( r1 n -- r2 ) gforth fm_star +r2 = r1*n; + +fm/ ( r1 n -- r2 ) gforth fm_slash +r2 = r1/n; + +fm*/ ( r1 n1 n2 -- r2 ) gforth fm_star_slash +r2 = (r1*n1)/n2; + +f**2 ( r1 -- r2 ) gforth fm_square +r2 = r1*r1; + fnegate ( r1 -- r2 ) float f_negate r2 = - r1; @@ -2425,9 +2453,33 @@ u3 = 0; #endif wcall ( ... u -- ... ) gforth -FP=fp; -sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP); -fp=FP; +gforth_FP=fp; +sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &gforth_FP); +fp=gforth_FP; + +uw@ ( c_addr -- u ) gforth u_w_fetch +""@i{u} is the zero-extended 16-bit value stored at @i{c_addr}."" +u = *(UWyde*)(c_addr); + +sw@ ( c_addr -- n ) gforth s_w_fetch +""@i{n} is the sign-extended 16-bit value stored at @i{c_addr}."" +n = *(Wyde*)(c_addr); + +w! ( w c_addr -- ) gforth w_store +""Store the bottom 16 bits of @i{w} at @i{c_addr}."" +*(Wyde*)(c_addr) = w; + +ul@ ( c_addr -- u ) gforth u_l_fetch +""@i{u} is the zero-extended 32-bit value stored at @i{c_addr}."" +u = *(UTetrabyte*)(c_addr); + +sl@ ( c_addr -- n ) gforth s_l_fetch +""@i{n} is the sign-extended 32-bit value stored at @i{c_addr}."" +n = *(Tetrabyte*)(c_addr); + +l! ( w c_addr -- ) gforth l_store +""Store the bottom 32 bits of @i{w} at @i{c_addr}."" +*(Tetrabyte*)(c_addr) = w; \+FFCALL @@ -2532,7 +2584,7 @@ REST_REGS c_addr = prv; alloc-callback ( a_ip -- c_addr ) gforth alloc_callback -c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip); +c_addr = (char *)alloc_callback(gforth_callback, (Xt *)a_ip); va-start-void ( -- ) gforth va_start_void va_start_void(clist); @@ -2601,6 +2653,99 @@ va_return_double(clist, r); return 0; \+ + +\+LIBFFI + +ffi-type ( n -- a_type ) gforth ffi_type +static void* ffi_types[] = + { &ffi_type_void, + &ffi_type_uint8, &ffi_type_sint8, + &ffi_type_uint16, &ffi_type_sint16, + &ffi_type_uint32, &ffi_type_sint32, + &ffi_type_uint64, &ffi_type_sint64, + &ffi_type_float, &ffi_type_double, &ffi_type_longdouble, + &ffi_type_pointer }; +a_type = ffi_types[n]; + +ffi-size ( n1 -- n2 ) gforth ffi_size +static int ffi_sizes[] = + { sizeof(ffi_cif), sizeof(ffi_closure) }; +n2 = ffi_sizes[n1]; + +ffi-prep-cif ( a_atypes n a_rtype a_cif -- w ) gforth ffi_prep_cif +w = ffi_prep_cif(a_cif, FFI_DEFAULT_ABI, n, a_rtype, a_atypes); + +ffi-call ( a_avalues a_rvalue a_ip a_cif -- ) gforth ffi_call +SAVE_REGS +ffi_call(a_cif, a_ip, a_rvalue, a_avalues); +REST_REGS + +ffi-prep-closure ( a_ip a_cif a_closure -- w ) gforth ffi_prep_closure +w = ffi_prep_closure(a_closure, a_cif, gforth_callback, a_ip); + +ffi-2@ ( a_addr -- d ) gforth ffi_2fetch +#ifdef BUGGY_LONG_LONG +DLO_IS(d, (Cell*)(*a_addr)); +DHI_IS(d, 0); +#else +d = *(DCell*)(a_addr); +#endif + +ffi-2! ( d a_addr -- ) gforth ffi_2store +#ifdef BUGGY_LONG_LONG +*(Cell*)(a_addr) = DLO(d); +#else +*(DCell*)(a_addr) = d; +#endif + +ffi-arg-int ( -- w ) gforth ffi_arg_int +w = *(int *)(*clist++); + +ffi-arg-longlong ( -- d ) gforth ffi_arg_longlong +#ifdef BUGGY_LONG_LONG +DLO_IS(d, (Cell*)(*clist++)); +DHI_IS(d, 0); +#else +d = *(DCell*)(*clist++); +#endif + +ffi-arg-ptr ( -- c_addr ) gforth ffi_arg_ptr +c_addr = *(char **)(*clist++); + +ffi-arg-float ( -- r ) gforth ffi_arg_float +r = *(float*)(*clist++); + +ffi-arg-double ( -- r ) gforth ffi_arg_double +r = *(double*)(*clist++); + +ffi-ret-void ( -- ) gforth ffi_ret_void +return 0; + +ffi-ret-int ( w -- ) gforth ffi_ret_int +*(int*)(ritem) = w; +return 0; + +ffi-ret-longlong ( d -- ) gforth ffi_ret_longlong +#ifdef BUGGY_LONG_LONG +*(Cell*)(ritem) = DLO(d); +#else +*(DCell*)(ritem) = d; +#endif +return 0; + +ffi-ret-ptr ( c_addr -- ) gforth ffi_ret_ptr +*(char **)(ritem) = c_addr; +return 0; + +ffi-ret-float ( r -- ) gforth ffi_ret_float +*(float*)(ritem) = r; +return 0; + +ffi-ret-double ( r -- ) gforth ffi_ret_double +*(double*)(ritem) = r; +return 0; + +\+ \+OLDCALL