--- gforth/prim 2005/09/03 07:49:02 1.176 +++ gforth/prim 2005/12/31 15:46:10 1.184 @@ -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. @@ -2002,6 +2002,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); @@ -2022,6 +2025,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; @@ -2080,6 +2086,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; @@ -2426,6 +2444,24 @@ FP=fp; sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP); fp=FP; +w@ ( a_addr -- u ) gforth wfetch +u = *(UWyde*)(a_addr); + +sw@ ( a_addr -- u ) gforth swfetch +u = *(Wyde*)(a_addr); + +w! ( u a_addr -- ) gforth wstore +*(Wyde*)(a_addr) = u; + +l@ ( a_addr -- u ) gforth lfetch +u = *(UTetrabyte*)(a_addr); + +sl@ ( a_addr -- u ) gforth slfetch +u = *(Tetrabyte*)(a_addr); + +l! ( u a_addr -- ) gforth lstore +*(Tetrabyte*)(a_addr) = u; + \+FFCALL av-start-void ( c_addr -- ) gforth av_start_void @@ -2621,7 +2657,9 @@ ffi-prep-cif ( a_atypes n a_rtype a_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, ffi_callback, a_ip); @@ -2631,7 +2669,7 @@ ffi-2@ ( a_addr -- d ) gforth ffi_2fetch DLO_IS(d, (Cell*)(*a_addr)); DHI_IS(d, 0); #else -d = *(DCell*)(*a_addr); +d = *(DCell*)(a_addr); #endif ffi-2! ( d a_addr -- ) gforth ffi_2store @@ -2642,7 +2680,7 @@ ffi-2! ( d a_addr -- ) gforth ffi_2store #endif ffi-arg-int ( -- w ) gforth ffi_arg_int -w = *(Cell*)(*clist++); +w = *(int *)(*clist++); ffi-arg-longlong ( -- d ) gforth ffi_arg_longlong #ifdef BUGGY_LONG_LONG @@ -2661,24 +2699,32 @@ r = *(float*)(*clist++); ffi-arg-double ( -- r ) gforth ffi_arg_double r = *(double*)(*clist++); -ffi-ret-int ( -- w ) gforth ffi_ret_int +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 +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 +ffi-ret-ptr ( c_addr -- ) gforth ffi_ret_ptr *(char **)(ritem) = c_addr; +return 0; -ffi-ret-float ( -- r ) gforth ffi_ret_float +ffi-ret-float ( r -- ) gforth ffi_ret_float *(float*)(ritem) = r; +return 0; -ffi-ret-double ( -- r ) gforth ffi_ret_double +ffi-ret-double ( r -- ) gforth ffi_ret_double *(double*)(ritem) = r; +return 0; \+