--- gforth/prim 2007/07/06 12:54:56 1.216 +++ gforth/prim 2012/09/17 19:58:36 1.277 @@ -1,12 +1,12 @@ \ Gforth primitives -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ WARNING: This file is processed by m4. Make sure your identifiers @@ -109,9 +108,9 @@ \E store-optimization on \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump \E -\E include-skipped-insts on \ static superinsts include cells for components -\E \ useful for dynamic programming and -\E \ superinsts across entry points +\E `include-skipped-insts' on \ static superinsts include cells for components +\E \ useful for dynamic programming and +\E \ superinsts across entry points \ \ @@ -203,6 +202,14 @@ INST_TAIL; goto *next_code; #endif /* defined(NO_IP) */ +(dovalue) ( -- w ) gforth-internal paren_doval +""run-time routine for constants"" +w = *(Cell *)PFA(CFA); +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + (dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes ""run-time routine for @code{does>}-defined words"" #ifdef NO_IP @@ -222,9 +229,28 @@ fprintf(stderr, "dodoes to %x, push %x\n SET_IP(DOES_CODE1(CFA)); #endif /* !defined(NO_IP) */ -(does-handler) ( -- ) gforth-internal paren_does_handler -""just a slot to have an encoding for the DOESJUMP, -which is no longer used anyway (!! eliminate this)"" +(doabicode) ( ... -- ...) gforth-internal paren_doabicode +""run-time routine for @code{ABI-code} definitions"" +abifunc *f = (abifunc *)PFA(CFA); +Float *fp_mem = fp; +sp = (*f)(sp, &fp_mem); +fp = fp_mem; +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + +(do;abicode) ( ... -- ... ) gforth-internal paren_do_semicolon_abi_code +""run-time routine for @code{;abi-code}-defined words"" +Float *fp_mem = fp; +Address body = (Address)PFA(CFA); +semiabifunc *f = (semiabifunc *)DOES_CODE1(CFA); +sp = (*f)(sp, &fp_mem, body); +fp = fp_mem; +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ \F [endif] @@ -586,6 +612,24 @@ SET_IP((Xt *)a_target); cell+ THEN >r ; +(try1) ( ... a_oldhandler a_recovery -- R:a_recovery R:a_sp R:f_fp R:c_lp R:a_oldhandler a_newhandler ) gforth paren_try1 +a_sp = sp-1; +f_fp = fp; +c_lp = lp; +a_newhandler = rp-5; + +(throw1) ( ... wball a_handler -- ... wball ) gforth paren_throw1 +rp = a_handler; +lp = (Address)rp[1]; +fp = (Float *)rp[2]; +sp = (Cell *)rp[3]; +#ifndef NO_IP +ip=IP; +#endif +SUPER_END; +VM_JUMP(EXEC1(*(Xt *)rp[4])); + + \+ \ don't make any assumptions where the return stack is!! @@ -695,7 +739,7 @@ c2 = toupper(c1); : dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; -capscompare ( c_addr1 u1 c_addr2 u2 -- n ) string +capscompare ( c_addr1 u1 c_addr2 u2 -- n ) gforth ""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 @@ -1059,6 +1103,22 @@ lshift ( u1 n -- u2 ) core l_shift : 0 ?DO 2* LOOP ; +umax ( u1 u2 -- u ) core +if (u1 IF swap THEN drop ; + \g compare \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) @@ -1456,6 +1516,10 @@ c_addr2 = c_addr1+1; : dup 1+ swap c@ ; +cell/ ( n1 -- n2 ) gforth cell_divide +""@i{n2} is the number of cells that fit into @i{n1}"" +n2 = n1 / sizeof(Cell); + \g compiler \+f83headerstring @@ -1640,7 +1704,7 @@ wfileid = (Cell)stderr; \+os -form ( -- urows ucols ) gforth +(form) ( -- urows ucols ) gforth paren_form ""The number of lines and columns in the terminal. These numbers may change with the window size. Note that it depends on the OS whether this reflects the actual size and changes with the window size @@ -1655,7 +1719,11 @@ ucols=cols; wcwidth ( u -- n ) gforth ""The number of fixed-width characters per unicode character u"" +#ifdef HAVE_WCWIDTH n = wcwidth(u); +#else +n = 1; +#endif flush-icache ( c_addr u -- ) gforth flush_icache ""Make sure that the instruction cache of the processor (if there is @@ -1667,10 +1735,14 @@ supported on your machine (take a look a your machine has a separate instruction cache. In such cases, @code{flush-icache} does nothing instead of flushing the instruction cache."" -FLUSH_ICACHE(c_addr,u); +FLUSH_ICACHE((caddr_t)c_addr,u); (bye) ( n -- ) gforth paren_bye SUPER_END; +gforth_FP=fp; +gforth_SP=sp; +gforth_RP=rp; +gforth_LP=lp; return (Label *)n; (system) ( c_addr u -- wretval wior ) gforth paren_system @@ -1683,12 +1755,17 @@ is the host operating system's expansion environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters in length."" /* close ' to keep fontify happy */ -c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1)); +char * string = cstr(c_addr1,u1); +c_addr2 = (Char *)getenv(string); u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2)); +free(string); open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe -wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ +char * string = cstr(c_addr,u); +fflush(stdout); +wfileid=(Cell)popen(string,pfileattr[wfam]); /* ~ expansion of 1st arg? */ wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ +free(string); close-pipe ( wfileid -- wretval wior ) gforth close_pipe wretval = pclose((FILE *)wfileid); @@ -1755,6 +1832,8 @@ if (a_addr1==NULL) else a_addr2 = (Cell *)realloc(a_addr1, u); wior = IOR(a_addr2==NULL); /* !! Define a return code */ +if (a_addr2==NULL) + a_addr2 = a_addr1; strerror ( n -- c_addr u ) gforth c_addr = (Char *)strerror(n); @@ -1770,11 +1849,21 @@ access the stack itself. The stack point variables @code{gforth_SP} and @code{gforth_FP}."" /* This is a first attempt at support for calls to C. This may change in the future */ +IF_fpTOS(fp[0]=fpTOS); gforth_FP=fp; gforth_SP=sp; +gforth_RP=rp; +gforth_LP=lp; +#ifdef HAS_LINKBACK ((void (*)())w)(); +#else +((void (*)(void *))w)(&gforth_pointers); +#endif sp=gforth_SP; fp=gforth_FP; +rp=gforth_RP; +lp=gforth_LP; +IF_fpTOS(fpTOS=fp[0]); \+ \+file @@ -1783,22 +1872,19 @@ close-file ( wfileid -- wior ) file clo wior = IOR(fclose((FILE *)wfileid)==EOF); open-file ( c_addr u wfam -- wfileid wior ) file open_file -wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]); -wior = IOR(wfileid == 0); +char * string = tilde_cstr(c_addr,u); +wfileid = opencreate_file(string, wfam, 0, &wior); +free(string); create-file ( c_addr u wfam -- wfileid wior ) file create_file -Cell fd; -fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666); -if (fd != -1) { - wfileid = (Cell)fdopen(fd, fileattr[wfam]); - wior = IOR(wfileid == 0); -} else { - wfileid = 0; - wior = IOR(1); -} +char * string = tilde_cstr(c_addr,u); +wfileid = opencreate_file(string, wfam, O_CREAT|O_TRUNC, &wior); +free(string); delete-file ( c_addr u -- wior ) file delete_file -wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); +char * string = tilde_cstr(c_addr,u); +wior = IOR(unlink(string)==-1); +free(string); rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" @@ -1823,13 +1909,15 @@ wior = IOR(ftruncate(fileno((FILE *)wfil read-file ( c_addr u1 wfileid -- u2 wior ) file read_file /* !! fread does not guarantee enough */ u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); +if (u2>0) + gf_regetc((FILE *)wfileid); wior = FILEIO(u2f f+ f/ f+ f2/ ; fcosh ( r1 -- r2 ) float-ext f_cosh +CLOBBER_TOS_WORKAROUND_START; r2 = cosh(r1); +CLOBBER_TOS_WORKAROUND_END; : fexp fdup 1/f f+ f2/ ; ftanh ( r1 -- r2 ) float-ext f_tan_h +CLOBBER_TOS_WORKAROUND_START; r2 = tanh(r1); +CLOBBER_TOS_WORKAROUND_END; : f2* fexpm1 fdup 2. d>f f+ f/ ; fasinh ( r1 -- r2 ) float-ext f_a_cinch +CLOBBER_TOS_WORKAROUND_START; r2 = asinh(r1); +CLOBBER_TOS_WORKAROUND_END; : fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; facosh ( r1 -- r2 ) float-ext f_a_cosh +CLOBBER_TOS_WORKAROUND_START; r2 = acosh(r1); +CLOBBER_TOS_WORKAROUND_END; : fdup fdup f* 1. d>f f- fsqrt f+ fln ; fatanh ( r1 -- r2 ) float-ext f_a_tan_h +CLOBBER_TOS_WORKAROUND_START; r2 = atanh(r1); +CLOBBER_TOS_WORKAROUND_END; : fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ r> IF fnegate THEN ; @@ -2308,6 +2465,29 @@ faxpy(ra, f_x, nstridex, f_y, nstridey, fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap LOOP 2drop 2drop fdrop ; +>float1 ( c_addr u c -- f:... flag ) gforth to_float1 +""Actual stack effect: ( c_addr u c -- r t | f ). Attempt to convert the +character string @i{c-addr u} to internal floating-point +representation. If the string represents a valid floating-point number +@i{r} is placed on the floating-point stack and @i{flag} is +true. Otherwise, @i{flag} is false. A string of blanks is a special +case and represents the floating-point number 0."" +Float r; +flag = to_float(c_addr, u, &r, c); +if (flag) { + fp--; + fp[0]=r; +} + +float/ ( n1 -- n2 ) gforth float_divide +n2 = n1 / sizeof(Float); + +dfloat/ ( n1 -- n2 ) gforth sfloat_divide +n2 = n1 / sizeof(DFloat); + +sfloat/ ( n1 -- n2 ) gforth dfloat_divide +n2 = n1 / sizeof(SFloat); + \+ \ The following words access machine/OS/installation-dependent @@ -2395,31 +2575,23 @@ r = fp[u]; \g syslib open-lib ( c_addr1 u1 -- u2 ) gforth open_lib -#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) -#ifndef RTLD_GLOBAL -#define RTLD_GLOBAL 0 -#endif -u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); -#else -# ifdef _WIN32 -u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); -# else -#warning Define open-lib! -u2 = 0; -# endif -#endif +u2 = gforth_dlopen(c_addr1, u1); lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym -#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) -u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); +char * string = cstr(c_addr1, u1); +#ifdef HAVE_LIBLTDL +u3 = (UCell) lt_dlsym((lt_dlhandle)u2, string); +#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) +u3 = (UCell) dlsym((void*)u2,string); #else # ifdef _WIN32 -u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); +u3 = (Cell) GetProcAddress((HMODULE)u2, string); # else #warning Define lib-sym! u3 = 0; # endif #endif +free(string); wcall ( ... u -- ... ) gforth gforth_FP=fp; @@ -2450,338 +2622,119 @@ l! ( w c_addr -- ) gforth l_store ""Store the bottom 32 bits of @i{w} at @i{c_addr}."" *(Tetrabyte*)(c_addr) = w; -\+FFCALL - -av-start-void ( c_addr -- ) gforth av_start_void -av_start_void(alist, c_addr); - -av-start-int ( c_addr -- ) gforth av_start_int -av_start_int(alist, c_addr, &irv); - -av-start-float ( c_addr -- ) gforth av_start_float -av_start_float(alist, c_addr, &frv); - -av-start-double ( c_addr -- ) gforth av_start_double -av_start_double(alist, c_addr, &drv); - -av-start-longlong ( c_addr -- ) gforth av_start_longlong -av_start_longlong(alist, c_addr, &llrv); - -av-start-ptr ( c_addr -- ) gforth av_start_ptr -av_start_ptr(alist, c_addr, void*, &prv); - -av-int ( w -- ) gforth av_int -av_int(alist, w); - -av-float ( r -- ) gforth av_float -av_float(alist, r); - -av-double ( r -- ) gforth av_double -av_double(alist, r); - -av-longlong ( d -- ) gforth av_longlong -#ifdef BUGGY_LL_SIZE -av_longlong(alist, DLO(d)); -#else -av_longlong(alist, d); -#endif - -av-ptr ( c_addr -- ) gforth av_ptr -av_ptr(alist, void*, c_addr); - -av-int-r ( R:w -- ) gforth av_int_r -av_int(alist, w); - -av-float-r ( -- ) gforth av_float_r -float r = *(Float*)lp; -lp += sizeof(Float); -av_float(alist, r); - -av-double-r ( -- ) gforth av_double_r -double r = *(Float*)lp; -lp += sizeof(Float); -av_double(alist, r); - -av-longlong-r ( R:d -- ) gforth av_longlong_r -#ifdef BUGGY_LL_SIZE -av_longlong(alist, DLO(d)); -#else -av_longlong(alist, d); -#endif - -av-ptr-r ( R:c_addr -- ) gforth av_ptr_r -av_ptr(alist, void*, c_addr); - -av-call-void ( ... -- ... ) gforth av_call_void -SAVE_REGS -av_call(alist); -REST_REGS - -av-call-int ( ... -- ... w ) gforth av_call_int -SAVE_REGS -av_call(alist); -REST_REGS -w = irv; - -av-call-float ( ... -- ... r ) gforth av_call_float -SAVE_REGS -av_call(alist); -REST_REGS -r = frv; - -av-call-double ( ... -- ... r ) gforth av_call_double -SAVE_REGS -av_call(alist); -REST_REGS -r = drv; - -av-call-longlong ( ... -- ... d ) gforth av_call_longlong -SAVE_REGS -av_call(alist); -REST_REGS -#ifdef BUGGY_LONG_LONG -DLO_IS(d, llrv); -DHI_IS(d, 0); -#else -d = llrv; -#endif - -av-call-ptr ( ... -- ... c_addr ) gforth av_call_ptr -SAVE_REGS -av_call(alist); -REST_REGS -c_addr = prv; - -alloc-callback ( a_ip -- c_addr ) gforth alloc_callback -c_addr = (char *)alloc_callback(gforth_callback, (Xt *)a_ip); - -va-start-void ( -- ) gforth va_start_void -va_start_void(gforth_clist); - -va-start-int ( -- ) gforth va_start_int -va_start_int(gforth_clist); - -va-start-longlong ( -- ) gforth va_start_longlong -va_start_longlong(gforth_clist); - -va-start-ptr ( -- ) gforth va_start_ptr -va_start_ptr(gforth_clist, (char *)); - -va-start-float ( -- ) gforth va_start_float -va_start_float(gforth_clist); - -va-start-double ( -- ) gforth va_start_double -va_start_double(gforth_clist); - -va-arg-int ( -- w ) gforth va_arg_int -w = va_arg_int(gforth_clist); - -va-arg-longlong ( -- d ) gforth va_arg_longlong -#ifdef BUGGY_LONG_LONG -DLO_IS(d, va_arg_longlong(gforth_clist)); -DHI_IS(d, 0); -#else -d = va_arg_longlong(gforth_clist); -#endif - -va-arg-ptr ( -- c_addr ) gforth va_arg_ptr -c_addr = (char *)va_arg_ptr(gforth_clist,char*); - -va-arg-float ( -- r ) gforth va_arg_float -r = va_arg_float(gforth_clist); - -va-arg-double ( -- r ) gforth va_arg_double -r = va_arg_double(gforth_clist); - -va-return-void ( -- ) gforth va_return_void -va_return_void(gforth_clist); -return 0; - -va-return-int ( w -- ) gforth va_return_int -va_return_int(gforth_clist, w); -return 0; - -va-return-ptr ( c_addr -- ) gforth va_return_ptr -va_return_ptr(gforth_clist, void *, c_addr); -return 0; - -va-return-longlong ( d -- ) gforth va_return_longlong -#ifdef BUGGY_LONG_LONG -va_return_longlong(gforth_clist, d.lo); -#else -va_return_longlong(gforth_clist, d); -#endif -return 0; - -va-return-float ( r -- ) gforth va_return_float -va_return_float(gforth_clist, r); -return 0; - -va-return-double ( r -- ) gforth va_return_double -va_return_double(gforth_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((ffi_cif *)a_cif, FFI_DEFAULT_ABI, n, - (ffi_type *)a_rtype, (ffi_type **)a_atypes); - -ffi-call ( a_avalues a_rvalue a_ip a_cif -- ) gforth ffi_call -SAVE_REGS -ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, (void *)a_rvalue, (void **)a_avalues); -REST_REGS - -ffi-prep-closure ( a_ip a_cif a_closure -- w ) gforth ffi_prep_closure -w = ffi_prep_closure((ffi_closure *)a_closure, (ffi_cif *)a_cif, gforth_callback, (void *)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 *)(*gforth_clist++); - -ffi-arg-long ( -- w ) gforth ffi_arg_long -w = *(long *)(*gforth_clist++); - -ffi-arg-longlong ( -- d ) gforth ffi_arg_longlong -#ifdef BUGGY_LONG_LONG -DLO_IS(d, *(Cell*)(*gforth_clist++)); -DHI_IS(d, -(*(Cell*)(*gforth_clist++)<0)); -#else -d = *(DCell*)(*gforth_clist++); -#endif - -ffi-arg-dlong ( -- d ) gforth ffi_arg_dlong -#ifdef BUGGY_LONG_LONG -DLO_IS(d, *(Cell*)(*gforth_clist++)); -DHI_IS(d, -(*(Cell*)(*gforth_clist++)<0)); -#else -d = *(Cell*)(*gforth_clist++); -#endif - -ffi-arg-ptr ( -- c_addr ) gforth ffi_arg_ptr -c_addr = *(Char **)(*gforth_clist++); - -ffi-arg-float ( -- r ) gforth ffi_arg_float -r = *(float*)(*gforth_clist++); - -ffi-arg-double ( -- r ) gforth ffi_arg_double -r = *(double*)(*gforth_clist++); - -ffi-ret-void ( -- ) gforth ffi_ret_void -return 0; - -ffi-ret-int ( w -- ) gforth ffi_ret_int -*(int*)(gforth_ritem) = w; -return 0; - -ffi-ret-longlong ( d -- ) gforth ffi_ret_longlong -#ifdef BUGGY_LONG_LONG -*(Cell*)(gforth_ritem) = DLO(d); -#else -*(DCell*)(gforth_ritem) = d; -#endif -return 0; - -ffi-ret-dlong ( d -- ) gforth ffi_ret_dlong -#ifdef BUGGY_LONG_LONG -*(Cell*)(gforth_ritem) = DLO(d); -#else -*(Cell*)(gforth_ritem) = d; -#endif -return 0; - -ffi-ret-long ( n -- ) gforth ffi_ret_long -*(Cell*)(gforth_ritem) = n; -return 0; - -ffi-ret-ptr ( c_addr -- ) gforth ffi_ret_ptr -*(Char **)(gforth_ritem) = c_addr; -return 0; - -ffi-ret-float ( r -- ) gforth ffi_ret_float -*(float*)(gforth_ritem) = r; -return 0; - -ffi-ret-double ( r -- ) gforth ffi_ret_double -*(double*)(gforth_ritem) = r; -return 0; - -\+ - -\+OLDCALL - -define(`uploop', - `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') -define(`_uploop', - `ifelse($1, `$3', `$5', - `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')') - -\ argflist(argnum): Forth argument list -define(argflist, - `ifelse($1, 0, `', - `uploop(`_i', 1, $1, ``u''`_i ', ``u''`_i')')') -\ argdlist(argnum): declare C's arguments -define(argdlist, - `ifelse($1, 0, `', - `uploop(`_i', 1, $1, `Cell, ', `Cell')')') -\ argclist(argnum): pass C's arguments -define(argclist, - `ifelse($1, 0, `', - `uploop(`_i', 1, $1, ``u''`_i, ', ``u''`_i')')') -\ icall(argnum) -define(icall, -`icall$1 ( argflist($1) u -- uret ) gforth -uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1)); - -') -define(fcall, -`fcall$1 ( argflist($1) u -- rret ) gforth -rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); - -') - -\ close ' to keep fontify happy - -uploop(i, 0, 7, `icall(i)') -icall(20) -uploop(i, 0, 7, `fcall(i)') -fcall(20) +lib-error ( -- c_addr u ) gforth lib_error +""Error message for last failed @code{open-lib} or @code{lib-sym}."" +#ifdef HAVE_LIBLTDL +c_addr = (Char *)lt_dlerror(); +u = (c_addr == NULL) ? 0 : strlen((char *)c_addr); +#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) +c_addr = dlerror(); +u = strlen(c_addr); +#else +c_addr = "libltdl is not configured"; +u = strlen(c_addr); +#endif + +be-w! ( w c_addr -- ) gforth w_store_be +""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 8; +c_addr[1] = w; + +be-l! ( w c_addr -- ) gforth l_store_be +""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 24; +c_addr[1] = w >> 16; +c_addr[2] = w >> 8; +c_addr[3] = w; + +le-w! ( w c_addr -- ) gforth w_store_le +""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[1] = w >> 8; +c_addr[0] = w; + +le-l! ( w c_addr -- ) gforth l_store_le +""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[3] = w >> 24; +c_addr[2] = w >> 16; +c_addr[1] = w >> 8; +c_addr[0] = w; + +be-uw@ ( c_addr -- u ) gforth w_fetch_be +""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}."" +u = (c_addr[0] << 8) | (c_addr[1]); + +be-ul@ ( c_addr -- u ) gforth l_fetch_be +""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}."" +u = ((Cell)c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); + +le-uw@ ( c_addr -- u ) gforth w_fetch_le +""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" +u = (c_addr[1] << 8) | (c_addr[0]); + +le-ul@ ( c_addr -- u ) gforth l_fetch_le +""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}."" +u = ((Cell)c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); + +\+64bit + +x! ( w c_addr -- ) gforth x_store +""Store the bottom 64 bits of @i{w} at 64-bit-aligned @i{c_addr}."" +*(UOctabyte *)c_addr = w; + +ux@ ( c_addr -- u ) gforth u_x_fetch +""@i{u} is the zero-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" +u = *(UOctabyte *)c_addr; + +sx@ ( c_addr -- n ) gforth s_x_fetch +""@i{u} is the sign-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" +n = *(Octabyte *)c_addr; + +be-x! ( w c_addr -- ) gforth b_e_x_store +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 56; +c_addr[1] = w >> 48; +c_addr[2] = w >> 40; +c_addr[3] = w >> 32; +c_addr[4] = w >> 24; +c_addr[5] = w >> 16; +c_addr[6] = w >> 8; +c_addr[7] = w; + +le-x! ( w c_addr -- ) gforth l_e_x_store +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[7] = w >> 56; +c_addr[6] = w >> 48; +c_addr[5] = w >> 40; +c_addr[4] = w >> 32; +c_addr[3] = w >> 24; +c_addr[2] = w >> 16; +c_addr[1] = w >> 8; +c_addr[0] = w; + +be-ux@ ( c_addr -- u ) gforth b_e_u_x_fetch +""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" +u = (((Cell)(c_addr[0]) << 56) | + ((Cell)(c_addr[1]) << 48) | + ((Cell)(c_addr[2]) << 40) | + ((Cell)(c_addr[3]) << 32) | + ((Cell)(c_addr[4]) << 24) | + ((Cell)(c_addr[5]) << 16) | + ((Cell)(c_addr[6]) << 8) | + ((Cell)(c_addr[7]))); + +le-ux@ ( c_addr -- u ) gforth l_e_u_x_fetch +""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}."" +u = (((Cell)(c_addr[7]) << 56) | + ((Cell)(c_addr[6]) << 48) | + ((Cell)(c_addr[5]) << 40) | + ((Cell)(c_addr[4]) << 32) | + ((Cell)(c_addr[3]) << 24) | + ((Cell)(c_addr[2]) << 16) | + ((Cell)(c_addr[1]) << 8) | + ((Cell)(c_addr[0]))); \+ \+ - \g peephole \+peephole @@ -2828,6 +2781,49 @@ a_addr = groups; \+ +\g primitive_centric + +\ primitives for primitive-centric code +\ another one is does-exec + +abi-call ( #a_callee ... -- ... ) gforth-internal abi_call +/* primitive for compiled ABI-CODE words */ +abifunc *f = (abifunc *)a_callee; +Float *fp_mem = fp; +sp = (*f)(sp, &fp_mem); +fp = fp_mem; + +;abi-code-exec ( #a_cfa ... -- ... ) gforth-internal semi_abi_code_exec +/* primitive for performing ;ABI-CODE words */ +Float *fp_mem = fp; +semiabifunc *f = (semiabifunc *)DOES_CODE1(a_cfa); +Address body = (Address)PFA(a_cfa); +sp = (*f)(sp, &fp_mem, body); +fp = fp_mem; + +lit-execute ( #a_addr -- ) new lit_execute +/* for ;code and code words; a static superinstruction would be more general, + but VM_JUMP is currently not supported there */ +#ifndef NO_IP +ip=IP; +#endif +SUPER_END; +VM_JUMP(EXEC1((Xt)a_addr)); + +\+objects +\g object_pointer + +>o ( c_addr -- r:c_old ) new to_o +c_old = op; +op = c_addr; + +o> ( r:c_addr -- ) new o_restore +op = c_addr; + +o#+ ( #w -- c_addr ) new o_lit_plus +c_addr = op + w; + +\+ \g static_super ifdef(`STACK_CACHE_FILE',