--- gforth/prim	2007/09/29 22:20:02	1.219
+++ gforth/prim	2008/07/10 19:59:41	1.229
@@ -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 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
@@ -703,7 +702,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
@@ -2394,14 +2393,16 @@ r = fp[u];
 \g syslib
 
 open-lib	( c_addr1 u1 -- u2 )	gforth	open_lib
-#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
+#if 1
+u2 = (UCell)lt_dlopen(tilde_cstr(c_addr1, u1, 1));
+#elif 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);
+u2=(UCell) dlopen(tilde_cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else
 #  ifdef _WIN32
-u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
+u2 = (Cell) GetModuleHandle(tilde_cstr(c_addr1, u1, 1));
 #  else
 #warning Define open-lib!
 u2 = 0;
@@ -2409,7 +2410,9 @@ u2 = 0;
 #endif
 
 lib-sym	( c_addr1 u1 u2 -- u3 )	gforth	lib_sym
-#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
+#if 1
+u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1));
+#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
 #else
 #  ifdef _WIN32
@@ -2449,338 +2452,12 @@ 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;
+lib-error ( -- c_addr u )       gforth  lib_error
+""Error message for last failed @code{open-lib} or @code{lib-sym}.""
+c_addr = lt_dlerror();
+u = (c_addr == NULL) ? 0 : strlen(c_addr);
 
 \+
-
-\+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)
-
-\+
-\+
-
 \g peephole
 
 \+peephole