1/***************************************** 2 * ffidl (Darwin 9 Universal version) 3 * 4 * A combination of libffi, for foreign function 5 * interface, and libdl, for dynamic library loading and 6 * symbol listing, packaged with hints from ::dll, and 7 * exported to Tcl. 8 * 9 * Ffidl - Copyright (c) 1999 by Roger E Critchlow Jr, 10 * Santa Fe, NM, USA, rec@elf.org 11 * 12 * Permission is hereby granted, free of charge, to any person 13 * obtaining a copy of this software and associated documentation 14 * files (the ``Software''), to deal in the Software without 15 * restriction, including without limitation the rights to use, copy, 16 * modify, merge, publish, distribute, sublicense, and/or sell copies 17 * of the Software, and to permit persons to whom the Software is 18 * furnished to do so, subject to the following conditions: 19 * 20 * The above copyright notice and this permission notice shall be 21 * included in all copies or substantial portions of the Software. 22 * 23 * THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, 24 * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 25 * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 26 * NONINFRINGEMENT. IN NO EVENT SHALL ROGER E CRITCHLOW JR BE LIABLE 27 * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 28 * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 29 * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 30 * 31 * Note that this distribution of Ffidl contains a modified copy of libffi 32 * which has its own Copyright notice and License. 33 * 34 */ 35 36/* 37 * Changes since ffidl 0.6: 38 * - support for 4-way universal builds on Darwin 39 * - support for Leopard libffi 40 * - remove ffcall and other code unused in Darwin universal build 41 * - support for Darwin Intel 42 * - ObjType bugfixes 43 * - TEA 3.6 buildsystem 44 * 45 * Changes since ffidl 0.5: 46 * - updates for 2005 version of libffi 47 * - TEA 3.2 buildsystem, testsuite 48 * - support for Tcl 8.4, Tcl_WideInt, TclpDlopen 49 * - support for Darwin PowerPC 50 * - fixes for 64bit (LP64) 51 * - callouts & callbacks are created/used relative to current namespace (for unqualified names) 52 * - addition of [ffidl::stubsymbol] for Tcl/Tk symbol resolution via stubs tables 53 * - callbacks can be called anytime, not just from inside callouts (using Tcl_BackgroundError to report errors) 54 * 55 * These changes are under BSD License and are 56 * Copyright (c) 2005-2008, Daniel A. Steffen <das@users.sourceforge.net> 57 * 58 */ 59 60#include <tcl.h> 61#include <tclInt.h> 62#include <tclPort.h> 63 64#ifdef LOOKUP_TK_STUBS 65static const char *MyTkInitStubs(Tcl_Interp *interp, char *version, int exact); 66static void *tkStubsPtr, *tkPlatStubsPtr, *tkIntStubsPtr, *tkIntPlatStubsPtr, *tkIntXlibStubsPtr; 67#else 68#define tkStubsPtr NULL 69#define tkPlatStubsPtr NULL 70#define tkIntStubsPtr NULL 71#define tkIntPlatStubsPtr NULL 72#define tkIntXlibStubsPtr NULL 73#endif 74 75#include <string.h> 76#include <stdlib.h> 77 78#include <ffi.h> 79 80#ifdef FFI_NO_RAW_API 81#undef FFI_NATIVE_RAW_API 82#define FFI_NATIVE_RAW_API 0 83#endif 84 85#ifndef FFI_CLOSURES 86#define HAVE_CLOSURES 0 87#else 88#define HAVE_CLOSURES FFI_CLOSURES 89#endif 90 91#define lib_type_void &ffi_type_void 92#define lib_type_uint8 &ffi_type_uint8 93#define lib_type_sint8 &ffi_type_sint8 94#define lib_type_uint16 &ffi_type_uint16 95#define lib_type_sint16 &ffi_type_sint16 96#define lib_type_uint32 &ffi_type_uint32 97#define lib_type_sint32 &ffi_type_sint32 98#define lib_type_uint64 &ffi_type_uint64 99#define lib_type_sint64 &ffi_type_sint64 100#define lib_type_float &ffi_type_float 101#define lib_type_double &ffi_type_double 102#define lib_type_longdouble &ffi_type_longdouble 103#define lib_type_pointer &ffi_type_pointer 104 105#define lib_type_schar &ffi_type_schar 106#define lib_type_uchar &ffi_type_uchar 107#define lib_type_ushort &ffi_type_ushort 108#define lib_type_sshort &ffi_type_sshort 109#define lib_type_uint &ffi_type_uint 110#define lib_type_sint &ffi_type_sint 111/* ffi_type_ulong & ffi_type_slong are always 64bit ! */ 112#if SIZEOF_LONG == 2 113#define lib_type_ulong &ffi_type_uint16 114#define lib_type_slong &ffi_type_sint16 115#elif SIZEOF_LONG == 4 116#define lib_type_ulong &ffi_type_uint32 117#define lib_type_slong &ffi_type_sint32 118#elif SIZEOF_LONG == 8 119#define lib_type_ulong &ffi_type_uint64 120#define lib_type_slong &ffi_type_sint64 121#endif 122#if HAVE_LONG_LONG 123#if SIZEOF_LONG_LONG == 2 124#define lib_type_ulonglong &ffi_type_uint16 125#define lib_type_slonglong &ffi_type_sint16 126#elif SIZEOF_LONG_LONG == 4 127#define lib_type_ulonglong &ffi_type_uint32 128#define lib_type_slonglong &ffi_type_sint32 129#elif SIZEOF_LONG_LONG == 8 130#define lib_type_ulonglong &ffi_type_uint64 131#define lib_type_slonglong &ffi_type_sint64 132#endif 133#endif 134 135#ifdef __CHAR_UNSIGNED__ 136#define lib_type_char &ffi_type_uint8 137#else 138#define lib_type_char &ffi_type_sint8 139#endif 140 141/* 142 * Turn callbacks off if they're not implemented 143 */ 144#if defined USE_CALLBACKS 145#if ! HAVE_CLOSURES 146#undef USE_CALLBACKS 147#endif 148#endif 149 150/***************************************** 151 * 152 * ffidlopen, ffidlsym, and ffidlclose abstractions 153 * of dlopen(), dlsym(), and dlclose(). 154 */ 155#ifndef NO_DLFCN_H 156#include <dlfcn.h> 157 158static void *ffidlopen(char *library, const char **error) 159{ 160 void *handle = dlopen(library, RTLD_NOW | RTLD_GLOBAL); 161 *error = dlerror(); 162 return handle; 163} 164static void *ffidlsym(void *handle, char *name, const char **error) 165{ 166 void *address = dlsym(handle, name); 167 *error = dlerror(); 168 return address; 169} 170static void ffidlclose(void *handle, const char **error) 171{ 172 dlclose(handle); 173 *error = dlerror(); 174} 175 176#endif 177 178/***************************************** 179 * 180 * Functions exported from this file. 181 */ 182EXTERN void * ffidl_pointer_pun(void *p); 183EXTERN int Ffidl_Init(Tcl_Interp *interp); 184 185/***************************************** 186 * 187 * Definitions. 188 */ 189/* 190 * values for ffidl_type.type 191 */ 192#define FFIDL_VOID 0 193#define FFIDL_INT 1 194#define FFIDL_FLOAT 2 195#define FFIDL_DOUBLE 3 196#define FFIDL_LONGDOUBLE 4 197#define FFIDL_UINT8 5 198#define FFIDL_SINT8 6 199#define FFIDL_UINT16 7 200#define FFIDL_SINT16 8 201#define FFIDL_UINT32 9 202#define FFIDL_SINT32 10 203#define FFIDL_UINT64 11 204#define FFIDL_SINT64 12 205#define FFIDL_STRUCT 13 206#define FFIDL_PTR 14 /* integer value pointer */ 207#define FFIDL_PTR_BYTE 15 /* byte array pointer */ 208#define FFIDL_PTR_UTF8 16 /* UTF-8 string pointer */ 209#define FFIDL_PTR_UTF16 17 /* UTF-16 string pointer */ 210#define FFIDL_PTR_VAR 18 /* byte array in variable */ 211#define FFIDL_PTR_OBJ 19 /* Tcl_Obj pointer */ 212#define FFIDL_PTR_PROC 20 /* Pointer to Tcl proc */ 213 214/* 215 * aliases for unsized type names 216 */ 217#ifdef __CHAR_UNSIGNED__ 218#define FFIDL_CHAR FFIDL_UINT8 219#else 220#define FFIDL_CHAR FFIDL_SINT8 221#endif 222 223#define FFIDL_SCHAR FFIDL_SINT8 224#define FFIDL_UCHAR FFIDL_UINT8 225 226#if SIZEOF_SHORT == 2 227#define FFIDL_USHORT FFIDL_UINT16 228#define FFIDL_SSHORT FFIDL_SINT16 229#elif SIZEOF_SHORT == 4 230#define FFIDL_USHORT FFIDL_UINT32 231#define FFIDL_SSHORT FFIDL_SINT32 232#define UINT_T 233#elif SIZEOF_SHORT == 8 234#define FFIDL_USHORT FFIDL_UINT64 235#define FFIDL_SSHORT FFIDL_SINT64 236#else 237#error "no short type" 238#endif 239 240#if SIZEOF_INT == 2 241#define FFIDL_UINT FFIDL_UINT16 242#define FFIDL_SINT FFIDL_SINT16 243#elif SIZEOF_INT == 4 244#define FFIDL_UINT FFIDL_UINT32 245#define FFIDL_SINT FFIDL_SINT32 246#elif SIZEOF_INT == 8 247#define FFIDL_UINT FFIDL_UINT64 248#define FFIDL_SINT FFIDL_SINT64 249#else 250#error "no int type" 251#endif 252 253#if SIZEOF_LONG == 2 254#define FFIDL_ULONG FFIDL_UINT16 255#define FFIDL_SLONG FFIDL_SINT16 256#elif SIZEOF_LONG == 4 257#define FFIDL_ULONG FFIDL_UINT32 258#define FFIDL_SLONG FFIDL_SINT32 259#elif SIZEOF_LONG == 8 260#define FFIDL_ULONG FFIDL_UINT64 261#define FFIDL_SLONG FFIDL_SINT64 262#else 263#error "no long type" 264#endif 265 266#if HAVE_LONG_LONG 267#if SIZEOF_LONG_LONG == 2 268#define FFIDL_ULONGLONG FFIDL_UINT16 269#define FFIDL_SLONGLONG FFIDL_SINT16 270#elif SIZEOF_LONG_LONG == 4 271#define FFIDL_ULONGLONG FFIDL_UINT32 272#define FFIDL_SLONGLONG FFIDL_SINT32 273#elif SIZEOF_LONG_LONG == 8 274#define FFIDL_ULONGLONG FFIDL_UINT64 275#define FFIDL_SLONGLONG FFIDL_SINT64 276#else 277#error "no long long type" 278#endif 279#endif 280 281/* 282 * Once more through, decide the alignment and C types 283 * for the sized ints 284 */ 285 286#define ALIGNOF_INT8 1 287#define UINT8_T unsigned char 288#define SINT8_T signed char 289 290#if SIZEOF_SHORT == 2 291#define ALIGNOF_INT16 ALIGNOF_SHORT 292#define UINT16_T unsigned short 293#define SINT16_T signed short 294#elif SIZEOF_INT == 2 295#define ALIGNOF_INT16 ALIGNOF_INT 296#define UINT16_T unsigned int 297#define SINT16_T signed int 298#elif SIZEOF_LONG == 2 299#define ALIGNOF_INT16 ALIGNOF_LONG 300#define UINT16_T unsigned long 301#define SINT16_T signed long 302#else 303#error "no 16 bit int" 304#endif 305 306#if SIZEOF_SHORT == 4 307#define ALIGNOF_INT32 ALIGNOF_SHORT 308#define UINT32_T unsigned short 309#define SINT32_T signed short 310#elif SIZEOF_INT == 4 311#define ALIGNOF_INT32 ALIGNOF_INT 312#define UINT32_T unsigned int 313#define SINT32_T signed int 314#elif SIZEOF_LONG == 4 315#define ALIGNOF_INT32 ALIGNOF_LONG 316#define UINT32_T unsigned long 317#define SINT32_T signed long 318#else 319#error "no 32 bit int" 320#endif 321 322#if SIZEOF_SHORT == 8 323#define ALIGNOF_INT64 ALIGNOF_SHORT 324#define UINT64_T unsigned short 325#define SINT64_T signed short 326#elif SIZEOF_INT == 8 327#define ALIGNOF_INT64 ALIGNOF_INT 328#define UINT64_T unsigned int 329#define SINT64_T signed int 330#elif SIZEOF_LONG == 8 331#define ALIGNOF_INT64 ALIGNOF_LONG 332#define UINT64_T unsigned long 333#define SINT64_T signed long 334#elif HAVE_LONG_LONG && SIZEOF_LONG_LONG == 8 335#define ALIGNOF_INT64 ALIGNOF_LONG_LONG 336#define UINT64_T unsigned long long 337#define SINT64_T signed long long 338#endif 339 340#ifdef ALIGNOF_INT64 341#define HAVE_INT64 1 342#endif 343 344/* 345 * values for ffidl_type.class 346 */ 347#define FFIDL_ARG 0x001 /* type parser in argument context */ 348#define FFIDL_RET 0x002 /* type parser in return context */ 349#define FFIDL_ELT 0x004 /* type parser in element context */ 350#define FFIDL_CBARG 0x008 /* type parser in callback argument context */ 351#define FFIDL_CBRET 0x010 /* type parser in callback return context */ 352#define FFIDL_ALL (FFIDL_ARG|FFIDL_RET|FFIDL_ELT|FFIDL_CBARG|FFIDL_CBRET) 353#define FFIDL_ARGRET (FFIDL_ARG|FFIDL_RET) 354#define FFIDL_GETINT 0x020 /* arg needs an int value */ 355#define FFIDL_GETDOUBLE 0x040 /* arg needs a double value */ 356#define FFIDL_GETBYTES 0x080 /* arg needs a bytearray value */ 357#define FFIDL_STATIC_TYPE 0x100 /* do not free this type */ 358#define FFIDL_GETWIDEINT 0x200 /* arg needs a wideInt value */ 359 360/***************************************** 361 * 362 * Type definitions for ffidl. 363 */ 364/* 365 * forward declarations. 366 */ 367typedef union ffidl_value ffidl_value; 368typedef struct ffidl_type ffidl_type; 369typedef struct ffidl_client ffidl_client; 370typedef struct ffidl_cif ffidl_cif; 371typedef struct ffidl_callout ffidl_callout; 372typedef struct ffidl_callback ffidl_callback; 373typedef struct ffidl_closure ffidl_closure; 374 375/* 376 * The ffidl_value structure contains a union used 377 * for converting to/from Tcl type. 378 */ 379union ffidl_value { 380 int v_int; 381 float v_float; 382 double v_double; 383#if HAVE_LONG_DOUBLE 384 long double v_longdouble; 385#endif 386 UINT8_T v_uint8; 387 SINT8_T v_sint8; 388 UINT16_T v_uint16; 389 SINT16_T v_sint16; 390 UINT32_T v_uint32; 391 SINT32_T v_sint32; 392#if HAVE_INT64 393 UINT64_T v_uint64; 394 SINT64_T v_sint64; 395#endif 396 void *v_struct; 397 void *v_pointer; 398}; 399 400/* 401 * The ffidl_type structure contains a type code, a class, 402 * the size of the type, the structure element alignment of 403 * the class, and a pointer to the underlying ffi_type. 404 */ 405struct ffidl_type { 406 size_t size; 407 unsigned short typecode; 408 unsigned short class; 409 unsigned short alignment; 410 unsigned short nelts; 411 ffidl_type **elements; 412 ffi_type *lib_type; 413}; 414 415/* 416 * The ffidl_client contains 417 * a hashtable for ffidl-typedef definitions, 418 * a hashtable for ffidl-callout definitions, 419 * a hashtable for cif's keyed by signature, 420 * a hashtable of libs loaded by ffidl-symbol, 421 * a hashtable of callbacks keyed by proc name 422 */ 423struct ffidl_client { 424 Tcl_HashTable types; 425 Tcl_HashTable cifs; 426 Tcl_HashTable callouts; 427 Tcl_HashTable libs; 428 Tcl_HashTable callbacks; 429}; 430 431/* 432 * The ffidl_cif structure contains an ffi_cif, 433 * an array of ffidl_types used to construct the 434 * cif and convert arguments, and an array of void* 435 * used to pass converted arguments into ffi_call. 436 */ 437struct ffidl_cif { 438 int refs; 439 ffidl_client *client; 440 ffidl_type *rtype; 441 ffidl_value rvalue; 442 void *ret; 443 int argc; 444 ffidl_type **atypes; 445 ffidl_value *avalues; 446 void **args; 447 int use_raw_api; 448 ffi_type **lib_atypes; 449 ffi_cif lib_cif; 450}; 451 452/* 453 * The ffidl_callout contains a cif pointer, 454 * a function address, the ffidl_client 455 * which defined the callout, and a usage 456 * string. 457 */ 458struct ffidl_callout { 459 ffidl_cif *cif; 460 void (*fn)(); 461 ffidl_client *client; 462 char usage[1]; 463}; 464 465#if USE_CALLBACKS 466/* 467 * The ffidl_closure contains a ffi_closure structure, 468 * a Tcl_Interp pointer, and a pointer to the callback binding. 469 */ 470struct ffidl_closure { 471 ffi_closure lib_closure; 472 Tcl_Interp *interp; 473 ffidl_callback *callback; 474}; 475/* 476 * The ffidl_callback binds a ffidl_cif pointer to 477 * a Tcl proc name, it defines the signature of the 478 * c function call to the Tcl proc. 479 */ 480struct ffidl_callback { 481 ffidl_cif *cif; 482 Tcl_Obj *proc; 483 ffidl_closure closure; 484}; 485#endif 486 487/***************************************** 488 * 489 * Data defined in this file. 490 * In addition to the version string above 491 */ 492 493static Tcl_ObjType *ffidl_bytearray_ObjType; 494static Tcl_ObjType *ffidl_int_ObjType; 495#if HAVE_INT64 496static Tcl_ObjType *ffidl_wideInt_ObjType; 497#endif 498static Tcl_ObjType *ffidl_double_ObjType; 499 500/* 501 * base types, the ffi base types and some additional bits. 502 */ 503#define init_type(size,type,class,alignment,libtype) { size,type,class|FFIDL_STATIC_TYPE,alignment,0,0,libtype } 504 505static ffidl_type ffidl_type_void = init_type(0, FFIDL_VOID, FFIDL_RET|FFIDL_CBRET, 0, lib_type_void); 506static ffidl_type ffidl_type_char = init_type(SIZEOF_CHAR, FFIDL_CHAR, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_CHAR, lib_type_char); 507static ffidl_type ffidl_type_schar = init_type(SIZEOF_CHAR, FFIDL_SCHAR, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_CHAR, lib_type_schar); 508static ffidl_type ffidl_type_uchar = init_type(SIZEOF_CHAR, FFIDL_UCHAR, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_CHAR, lib_type_uchar); 509static ffidl_type ffidl_type_sshort = init_type(SIZEOF_SHORT, FFIDL_SSHORT, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_SHORT, lib_type_sshort); 510static ffidl_type ffidl_type_ushort = init_type(SIZEOF_SHORT, FFIDL_USHORT, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_SHORT, lib_type_ushort); 511static ffidl_type ffidl_type_sint = init_type(SIZEOF_INT, FFIDL_SINT, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT, lib_type_sint); 512static ffidl_type ffidl_type_uint = init_type(SIZEOF_INT, FFIDL_UINT, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT, lib_type_uint); 513#if SIZEOF_LONG == 8 514static ffidl_type ffidl_type_slong = init_type(SIZEOF_LONG, FFIDL_SLONG, FFIDL_ALL|FFIDL_GETWIDEINT, ALIGNOF_LONG, lib_type_slong); 515static ffidl_type ffidl_type_ulong = init_type(SIZEOF_LONG, FFIDL_ULONG, FFIDL_ALL|FFIDL_GETWIDEINT, ALIGNOF_LONG, lib_type_ulong); 516#else 517static ffidl_type ffidl_type_slong = init_type(SIZEOF_LONG, FFIDL_SLONG, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_LONG, lib_type_slong); 518static ffidl_type ffidl_type_ulong = init_type(SIZEOF_LONG, FFIDL_ULONG, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_LONG, lib_type_ulong); 519#endif 520#if HAVE_LONG_LONG 521static ffidl_type ffidl_type_slonglong = init_type(SIZEOF_LONG_LONG, FFIDL_SLONGLONG, FFIDL_ALL|FFIDL_GETWIDEINT, ALIGNOF_LONG_LONG, lib_type_slonglong); 522static ffidl_type ffidl_type_ulonglong = init_type(SIZEOF_LONG_LONG, FFIDL_ULONGLONG, FFIDL_ALL|FFIDL_GETWIDEINT, ALIGNOF_LONG_LONG, lib_type_ulonglong ); 523#endif 524static ffidl_type ffidl_type_float = init_type(SIZEOF_FLOAT, FFIDL_FLOAT, FFIDL_ALL|FFIDL_GETDOUBLE, ALIGNOF_FLOAT, lib_type_float); 525static ffidl_type ffidl_type_double = init_type(SIZEOF_DOUBLE, FFIDL_DOUBLE, FFIDL_ALL|FFIDL_GETDOUBLE, ALIGNOF_DOUBLE, lib_type_double); 526#if HAVE_LONG_DOUBLE 527static ffidl_type ffidl_type_longdouble = init_type(SIZEOF_LONG_DOUBLE, FFIDL_LONGDOUBLE, FFIDL_ALL|FFIDL_GETDOUBLE, ALIGNOF_LONG_DOUBLE, lib_type_longdouble ); 528#endif 529static ffidl_type ffidl_type_sint8 = init_type(1, FFIDL_SINT8, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT8, lib_type_sint8); 530static ffidl_type ffidl_type_uint8 = init_type(1, FFIDL_UINT8, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT8, lib_type_uint8); 531static ffidl_type ffidl_type_sint16 = init_type(2, FFIDL_SINT16, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT16, lib_type_sint16); 532static ffidl_type ffidl_type_uint16 = init_type(2, FFIDL_UINT16, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT16, lib_type_uint16); 533static ffidl_type ffidl_type_sint32 = init_type(4, FFIDL_SINT32, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT32, lib_type_sint32); 534static ffidl_type ffidl_type_uint32 = init_type(4, FFIDL_UINT32, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_INT32, lib_type_uint32); 535#if HAVE_INT64 536static ffidl_type ffidl_type_sint64 = init_type(8, FFIDL_SINT64, FFIDL_ALL|FFIDL_GETWIDEINT, ALIGNOF_INT64, lib_type_sint64); 537static ffidl_type ffidl_type_uint64 = init_type(8, FFIDL_UINT64, FFIDL_ALL|FFIDL_GETWIDEINT, ALIGNOF_INT64, lib_type_uint64); 538#endif 539static ffidl_type ffidl_type_pointer = init_type(SIZEOF_VOID_P, FFIDL_PTR, FFIDL_ALL|FFIDL_GETINT, ALIGNOF_VOID_P, lib_type_pointer); 540static ffidl_type ffidl_type_pointer_obj = init_type(SIZEOF_VOID_P, FFIDL_PTR_OBJ, FFIDL_ARGRET|FFIDL_CBARG|FFIDL_CBRET, ALIGNOF_VOID_P, lib_type_pointer); 541static ffidl_type ffidl_type_pointer_utf8 = init_type(SIZEOF_VOID_P, FFIDL_PTR_UTF8, FFIDL_ARGRET|FFIDL_CBARG, ALIGNOF_VOID_P, lib_type_pointer); 542static ffidl_type ffidl_type_pointer_utf16 = init_type(SIZEOF_VOID_P, FFIDL_PTR_UTF16, FFIDL_ARGRET|FFIDL_CBARG, ALIGNOF_VOID_P, lib_type_pointer); 543static ffidl_type ffidl_type_pointer_byte = init_type(SIZEOF_VOID_P, FFIDL_PTR_BYTE, FFIDL_ARG, ALIGNOF_VOID_P, lib_type_pointer); 544static ffidl_type ffidl_type_pointer_var = init_type(SIZEOF_VOID_P, FFIDL_PTR_VAR, FFIDL_ARG, ALIGNOF_VOID_P, lib_type_pointer); 545#if USE_CALLBACKS 546static ffidl_type ffidl_type_pointer_proc = init_type(SIZEOF_VOID_P, FFIDL_PTR_PROC, FFIDL_ARG, ALIGNOF_VOID_P, lib_type_pointer); 547#endif 548 549/***************************************** 550 * 551 * Functions defined in this file. 552 */ 553/* 554 * hash table management 555 */ 556/* define a hashtable entry */ 557static void entry_define(Tcl_HashTable *table, char *name, void *datum) 558{ 559 int dummy; 560 Tcl_SetHashValue(Tcl_CreateHashEntry(table,name,&dummy), datum); 561} 562/* lookup an existing entry */ 563static void *entry_lookup(Tcl_HashTable *table, char *name) 564{ 565 Tcl_HashEntry *entry = Tcl_FindHashEntry(table,name); 566 return entry ? Tcl_GetHashValue(entry) : NULL; 567} 568/* find an entry by it's hash value */ 569static Tcl_HashEntry *entry_find(Tcl_HashTable *table, void *datum) 570{ 571 Tcl_HashSearch search; 572 Tcl_HashEntry *entry = Tcl_FirstHashEntry(table, &search); 573 while (entry != NULL) { 574 if (Tcl_GetHashValue(entry) == datum) 575 return entry; 576 entry = Tcl_NextHashEntry(&search); 577 } 578 return NULL; 579} 580/* 581 * type management 582 */ 583/* define a new type */ 584static void type_define(ffidl_client *client, char *tname, ffidl_type *ttype) 585{ 586 entry_define(&client->types,tname,(void*)ttype); 587} 588/* lookup an existing type */ 589static ffidl_type *type_lookup(ffidl_client *client, char *tname) 590{ 591 return entry_lookup(&client->types,tname); 592} 593/* find a type by it's ffidl_type */ 594/* 595static Tcl_HashEntry *type_find(ffidl_client *client, ffidl_type *type) 596{ 597 return entry_find(&client->types,(void *)type); 598} 599*/ 600/* parse an argument or return type specification */ 601static int type_parse(Tcl_Interp *interp, ffidl_client *client, unsigned context, Tcl_Obj *obj, 602 ffidl_type **type1, ffidl_value *type2, void **argp) 603{ 604 char *arg = Tcl_GetString(obj); 605 char buff[128]; 606 607 /* lookup the type */ 608 *type1 = type_lookup(client, arg); 609 if (*type1 == NULL) { 610 Tcl_AppendResult(interp, "no type defined for: ", arg, NULL); 611 return TCL_ERROR; 612 } 613 /* test the context */ 614 if ((context & (*type1)->class) == 0) { 615 Tcl_AppendResult(interp, "type ", arg, " is not permitted in ", 616 (context&FFIDL_ARG) ? "argument" : "return", 617 " context.", NULL); 618 return TCL_ERROR; 619 } 620 /* set arg value pointer */ 621 switch ((*type1)->typecode) { 622 case FFIDL_VOID: *argp = NULL; break; /* libffi depends on this being NULL on some platforms ! */ 623 case FFIDL_INT: *argp = (void *)&type2->v_int; break; 624 case FFIDL_FLOAT: *argp = (void *)&type2->v_float; break; 625 case FFIDL_DOUBLE: *argp = (void *)&type2->v_double; break; 626#if HAVE_LONG_DOUBLE 627 case FFIDL_LONGDOUBLE: *argp = (void *)&type2->v_longdouble; break; 628#endif 629 case FFIDL_UINT8: *argp = (void *)&type2->v_uint8; break; 630 case FFIDL_SINT8: *argp = (void *)&type2->v_sint8; break; 631 case FFIDL_UINT16: *argp = (void *)&type2->v_uint16; break; 632 case FFIDL_SINT16: *argp = (void *)&type2->v_sint16; break; 633 case FFIDL_UINT32: *argp = (void *)&type2->v_uint32; break; 634 case FFIDL_SINT32: *argp = (void *)&type2->v_sint32; break; 635#if HAVE_INT64 636 case FFIDL_UINT64: *argp = (void *)&type2->v_uint64; break; 637 case FFIDL_SINT64: *argp = (void *)&type2->v_sint64; break; 638#endif 639 case FFIDL_PTR: *argp = (void *)&type2->v_pointer; break; 640 case FFIDL_PTR_BYTE: *argp = (void *)&type2->v_pointer; break; 641 case FFIDL_PTR_OBJ: *argp = (void *)&type2->v_pointer; break; 642 case FFIDL_PTR_UTF8: *argp = (void *)&type2->v_pointer; break; 643 case FFIDL_PTR_UTF16: *argp = (void *)&type2->v_pointer; break; 644 case FFIDL_PTR_VAR: *argp = (void *)&type2->v_pointer; break; 645 case FFIDL_PTR_PROC: *argp = (void *)&type2->v_pointer; break; 646 case FFIDL_STRUCT: *argp = (void *)&type2->v_struct; break; 647 default: 648 sprintf(buff, "unknown ffidl_type.t = %d", (*type1)->typecode); 649 Tcl_AppendResult(interp, buff, NULL); 650 return TCL_ERROR; 651 } 652 return TCL_OK; 653} 654 655/* Determine correct binary formats */ 656#if defined WORDS_BIGENDIAN 657#define FFIDL_WIDEINT_FORMAT "W" 658#define FFIDL_INT_FORMAT "I" 659#define FFIDL_SHORT_FORMAT "S" 660#else 661#define FFIDL_WIDEINT_FORMAT "w" 662#define FFIDL_INT_FORMAT "i" 663#define FFIDL_SHORT_FORMAT "s" 664#endif 665 666/* build a binary format string */ 667static int type_format(Tcl_Interp *interp, ffidl_type *type, int *offset) 668{ 669 int i; 670 char buff[128]; 671 /* Insert alignment padding */ 672 while ((*offset % type->alignment) != 0) { 673 Tcl_AppendResult(interp, "x", NULL); 674 *offset += 1; 675 } 676 switch (type->typecode) { 677 case FFIDL_INT: 678 case FFIDL_UINT8: 679 case FFIDL_SINT8: 680 case FFIDL_UINT16: 681 case FFIDL_SINT16: 682 case FFIDL_UINT32: 683 case FFIDL_SINT32: 684#if HAVE_INT64 685 case FFIDL_UINT64: 686 case FFIDL_SINT64: 687#endif 688 case FFIDL_PTR: 689 case FFIDL_PTR_BYTE: 690 case FFIDL_PTR_OBJ: 691 case FFIDL_PTR_UTF8: 692 case FFIDL_PTR_UTF16: 693 case FFIDL_PTR_VAR: 694 case FFIDL_PTR_PROC: 695 if (type->size == sizeof(Tcl_WideInt)) { 696 *offset += 8; 697 Tcl_AppendResult(interp, FFIDL_WIDEINT_FORMAT, NULL); 698 return TCL_OK; 699 } else if (type->size == sizeof(int)) { 700 *offset += 4; 701 Tcl_AppendResult(interp, FFIDL_INT_FORMAT, NULL); 702 return TCL_OK; 703 } else if (type->size == sizeof(short)) { 704 *offset += 2; 705 Tcl_AppendResult(interp, FFIDL_SHORT_FORMAT, NULL); 706 return TCL_OK; 707 } else if (type->size == sizeof(char)) { 708 *offset += 1; 709 Tcl_AppendResult(interp, "c", NULL); 710 return TCL_OK; 711 } else { 712 *offset += type->size; 713 sprintf(buff, "c%lu", (long)(type->size)); 714 Tcl_AppendResult(interp, buff, NULL); 715 return TCL_OK; 716 } 717 case FFIDL_FLOAT: 718 case FFIDL_DOUBLE: 719#if HAVE_LONG_DOUBLE 720 case FFIDL_LONGDOUBLE: 721#endif 722 if (type->size == sizeof(double)) { 723 *offset += 8; 724 Tcl_AppendResult(interp, "d", NULL); 725 return TCL_OK; 726 } else if (type->size == sizeof(float)) { 727 *offset += 4; 728 Tcl_AppendResult(interp, "f", NULL); 729 return TCL_OK; 730 } else { 731 *offset += type->size; 732 sprintf(buff, "c%lu", (long)(type->size)); 733 Tcl_AppendResult(interp, buff, NULL); 734 return TCL_OK; 735 } 736 case FFIDL_STRUCT: 737 for (i = 0; i < type->nelts; i += 1) 738 if (type_format(interp, type->elements[i], offset) != TCL_OK) 739 return TCL_ERROR; 740 /* Insert tail padding */ 741 while (*offset < type->size) { 742 Tcl_AppendResult(interp, "x", NULL); 743 *offset += 1; 744 } 745 return TCL_OK; 746 default: 747 sprintf(buff, "cannot format ffidl_type: %d", type->typecode); 748 Tcl_ResetResult(interp); 749 Tcl_AppendResult(interp, buff, NULL); 750 return TCL_ERROR; 751 } 752} 753static ffidl_type *type_alloc(ffidl_client *client, int nelts) 754{ 755 ffidl_type *newtype; 756 newtype = (ffidl_type *)Tcl_Alloc(sizeof(ffidl_type) 757 +nelts*sizeof(ffidl_type*) 758 +sizeof(ffi_type)+(nelts+1)*sizeof(ffi_type *) 759 ); 760 if (newtype == NULL) { 761 return NULL; 762 } 763 /* initialize aggregate type */ 764 newtype->size = 0; 765 newtype->typecode = FFIDL_STRUCT; 766 newtype->class = FFIDL_ALL; 767 newtype->alignment = 0; 768 newtype->nelts = nelts; 769 newtype->elements = (ffidl_type **)(newtype+1); 770 newtype->lib_type = (ffi_type *)(newtype->elements+nelts); 771 newtype->lib_type->size = 0; 772 newtype->lib_type->alignment = 0; 773 newtype->lib_type->type = FFI_TYPE_STRUCT; 774 newtype->lib_type->elements = (ffi_type **)(newtype->lib_type+1); 775 return newtype; 776} 777/* free a type */ 778static void type_free(ffidl_type *type) 779{ 780 Tcl_Free((void *)type); 781} 782/* prep a type for use by the library */ 783static int type_prep(ffidl_type *type) 784{ 785 ffi_cif cif; 786 int i; 787 for (i = 0; i < type->nelts; i += 1) 788 type->lib_type->elements[i] = type->elements[i]->lib_type; 789 type->lib_type->elements[i] = NULL; 790 /* try out new type in a temporary cif, which should set size and alignment */ 791 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, type->lib_type, NULL) != FFI_OK) 792 return TCL_ERROR; 793 if (type->size != type->lib_type->size) { 794 fprintf(stderr, "ffidl disagrees with libffi about aggregate size of type %hu! %lu != %lu\n", type->typecode, (long)(type->size), (long)(type->lib_type->size)); 795 } 796 if (type->alignment != type->lib_type->alignment) { 797 fprintf(stderr, "ffidl disagrees with libffi about aggregate alignment of type %hu! %hu != %hu\n", type->typecode, type->alignment, type->lib_type->alignment); 798 } 799 return TCL_OK; 800} 801/* 802 * cif, ie call signature, management. 803 */ 804/* define a new cif */ 805static void cif_define(ffidl_client *client, char *cname, ffidl_cif *cif) 806{ 807 entry_define(&client->cifs,cname,(void*)cif); 808} 809/* lookup an existing cif */ 810static ffidl_cif *cif_lookup(ffidl_client *client, char *cname) 811{ 812 return entry_lookup(&client->cifs,cname); 813} 814/* find a cif by it's ffidl_cif */ 815static Tcl_HashEntry *cif_find(ffidl_client *client, ffidl_cif *cif) 816{ 817 return entry_find(&client->cifs,(void *)cif); 818} 819/* allocate a cif and its parts */ 820static ffidl_cif *cif_alloc(ffidl_client *client, int argc) 821{ 822 /* allocate storage for: 823 the ffidl_cif, 824 the argument ffi_type pointers, 825 the argument ffidl_types, 826 the argument values, 827 and the argument value pointers. 828 */ 829 ffidl_cif *cif; 830 cif = (ffidl_cif *)Tcl_Alloc(sizeof(ffidl_cif) 831 +argc*sizeof(ffidl_type*) 832 +argc*sizeof(ffidl_value) 833 +argc*sizeof(void*) 834 +argc*sizeof(ffi_type*) 835 ); 836 if (cif == NULL) { 837 return NULL; 838 } 839 /* initialize the cif */ 840 cif->refs = 0; 841 cif->client = client; 842 cif->argc = argc; 843 cif->atypes = (ffidl_type **)(cif+1); 844 cif->avalues = (ffidl_value *)(cif->atypes+argc); 845 cif->args = (void **)(cif->avalues+argc); 846 cif->lib_atypes = (ffi_type **)(cif->args+argc); 847 return cif; 848} 849/* free a cif */ 850void cif_free(ffidl_cif *cif) 851{ 852 Tcl_Free((void *)cif); 853} 854/* maintain reference counts on cif's */ 855static void cif_inc_ref(ffidl_cif *cif) 856{ 857 cif->refs += 1; 858} 859static void cif_dec_ref(ffidl_cif *cif) 860{ 861 if (--cif->refs == 0) { 862 Tcl_DeleteHashEntry(cif_find(cif->client, cif)); 863 cif_free(cif); 864 } 865} 866/* do any library dependent prep for this cif */ 867static int cif_prep(ffidl_cif *cif, int protocol) 868{ 869 ffi_type *rtype; 870 int i; 871 cif->use_raw_api = 0; 872 rtype = cif->rtype->lib_type; 873#if FFI_NATIVE_RAW_API 874 cif->use_raw_api = 1; 875 if (cif->rtype->typecode == FFIDL_STRUCT) 876 cif->use_raw_api = 0; 877#endif 878 for (i = 0; i < cif->argc; i += 1) { 879 cif->lib_atypes[i] = cif->atypes[i]->lib_type; 880#if FFI_NATIVE_RAW_API 881 if (cif->atypes[i]->typecode == FFIDL_STRUCT 882 || cif->atypes[i]->typecode == FFIDL_UINT64 883 || cif->atypes[i]->typecode == FFIDL_SINT64) 884 cif->use_raw_api = 0; 885#endif 886 } 887 if (ffi_prep_cif(&cif->lib_cif, protocol, cif->argc, rtype, cif->lib_atypes) != FFI_OK) { 888 return TCL_ERROR; 889 } 890#if FFI_NATIVE_RAW_API 891 if (cif->use_raw_api) { 892 /* rewrite cif->args[i] into a stack image */ 893 int offset = 0, bytes = ffi_raw_size(&cif->lib_cif); 894 /* fprintf(stderr, "using raw api for %d args\n", cif->argc); */ 895 for (i = 0; i < cif->argc; i += 1) { 896 /* set args[i] to args[0]+offset */ 897 /* fprintf(stderr, " arg[%d] was %08x ...", i, cif->args[i]); */ 898 cif->args[i] = (void *)(((char *)cif->args[0])+offset); 899 /* fprintf(stderr, " becomes %08x\n", cif->args[i]); */ 900 /* increment offset */ 901 offset += cif->atypes[i]->size; 902 /* align offset, so total bytes is correct */ 903 if (offset & (FFI_SIZEOF_ARG-1)) 904 offset = (offset|(FFI_SIZEOF_ARG-1))+1; 905 } 906 /* fprintf(stderr, " final offset %d, bytes %d\n", offset, bytes); */ 907 if (offset != bytes) { 908 fprintf(stderr, "ffidl and libffi disagree about bytes of argument! %d != %d\n", offset, bytes); 909 } 910 } 911#endif 912 return TCL_OK; 913} 914/* find the protocol, ie abi, for this cif */ 915static int cif_protocol(Tcl_Interp *interp, Tcl_Obj *obj, int *protocolp, char **protocolnamep) 916{ 917 *protocolp = FFI_DEFAULT_ABI; 918 *protocolnamep = NULL; 919 if (obj != NULL) { 920 *protocolnamep = Tcl_GetString(obj); 921 if (*protocolp == FFI_DEFAULT_ABI) 922 *protocolnamep = NULL; 923 } 924 return TCL_OK; 925} 926/* 927 * parse a cif argument list, return type, and protocol, 928 * and find or create it in the cif table. 929 */ 930static int cif_parse(Tcl_Interp *interp, ffidl_client *client, Tcl_Obj *args, Tcl_Obj *ret, Tcl_Obj *pro, ffidl_cif **cifp, int callbackp) 931{ 932 int argc, protocol, i; 933 Tcl_Obj **argv; 934 char *protocolname; 935 Tcl_DString signature; 936 ffidl_cif *cif; 937 /* fetch argument types */ 938 if (Tcl_ListObjGetElements(interp, args, &argc, &argv) == TCL_ERROR) return TCL_ERROR; 939 /* fetch protocol */ 940 if (cif_protocol(interp, pro, &protocol, &protocolname) == TCL_ERROR) return TCL_ERROR; 941 /* build the cif signature key */ 942 Tcl_DStringInit(&signature); 943 if (protocolname != NULL) { 944 Tcl_DStringAppend(&signature, protocolname, -1); 945 Tcl_DStringAppend(&signature, " ", 1); 946 } 947 Tcl_DStringAppend(&signature, Tcl_GetString(ret), -1); 948 Tcl_DStringAppend(&signature, "(", 1); 949 for (i = 0; i < argc; i += 1) { 950 if (i != 0) Tcl_DStringAppend(&signature, ",", 1); 951 Tcl_DStringAppend(&signature, Tcl_GetString(argv[i]), -1); 952 } 953 Tcl_DStringAppend(&signature, ")", 1); 954 /* lookup the signature in the cif hash */ 955 cif = cif_lookup(client, Tcl_DStringValue(&signature)); 956 if (cif == NULL) { 957 cif = cif_alloc(client, argc); 958 if (cif == NULL) { 959 Tcl_AppendResult(interp, "couldn't allocate the ffidl_cif", NULL); 960 Tcl_DStringFree(&signature); 961 return TCL_ERROR; 962 } 963 /* parse return value spec */ 964 if (type_parse(interp, client, callbackp ? FFIDL_CBRET : FFIDL_RET, ret, 965 &cif->rtype, &cif->rvalue, &cif->ret) == TCL_ERROR) { 966 cif_free(cif); 967 Tcl_DStringFree(&signature); 968 return TCL_ERROR; 969 } 970 /* parse arg specs */ 971 for (i = 0; i < argc; i += 1) 972 if (type_parse(interp, client, callbackp ? FFIDL_CBARG : FFIDL_ARG, argv[i], 973 &cif->atypes[i], &cif->avalues[i], &cif->args[i]) == TCL_ERROR) { 974 cif_free(cif); 975 Tcl_DStringFree(&signature); 976 return TCL_ERROR; 977 } 978 /* see if we done right */ 979 if (cif_prep(cif, protocol) != TCL_OK) { 980 Tcl_AppendResult(interp, "type definition error", NULL); 981 cif_free(cif); 982 Tcl_DStringFree(&signature); 983 return TCL_ERROR; 984 } 985 /* define the cif */ 986 cif_define(client, Tcl_DStringValue(&signature), cif); 987 Tcl_ResetResult(interp); 988 } 989 /* free the signature string */ 990 Tcl_DStringFree(&signature); 991 /* mark the cif as referenced */ 992 cif_inc_ref(cif); 993 /* return success */ 994 *cifp = cif; 995 return TCL_OK; 996} 997/* 998 * callout management 999 */ 1000/* define a new callout */ 1001static void callout_define(ffidl_client *client, char *pname, ffidl_callout *callout) 1002{ 1003 entry_define(&client->callouts,pname,(void*)callout); 1004} 1005/* lookup an existing callout */ 1006static ffidl_callout *callout_lookup(ffidl_client *client, char *pname) 1007{ 1008 return entry_lookup(&client->callouts,pname); 1009} 1010/* find a callout by it's ffidl_callout */ 1011static Tcl_HashEntry *callout_find(ffidl_client *client, ffidl_callout *callout) 1012{ 1013 return entry_find(&client->callouts,(void *)callout); 1014} 1015/* cleanup on ffidl_callout_call deletion */ 1016static void callout_delete(ClientData clientData) 1017{ 1018 ffidl_callout *callout = (ffidl_callout *)clientData; 1019 Tcl_HashEntry *entry = callout_find(callout->client, callout); 1020 if (entry) { 1021 cif_dec_ref(callout->cif); 1022 Tcl_Free((void *)callout); 1023 Tcl_DeleteHashEntry(entry); 1024 } 1025} 1026/* make a call */ 1027/* consider what happens if we reenter using the same cif */ 1028static void callout_call(ffidl_callout *callout) 1029{ 1030 ffidl_cif *cif = callout->cif; 1031#if FFI_NATIVE_RAW_API 1032 if (cif->use_raw_api) 1033 ffi_raw_call(&cif->lib_cif, callout->fn, cif->ret, (ffi_raw *)cif->args[0]); 1034 else 1035 ffi_call(&cif->lib_cif, callout->fn, cif->ret, cif->args); 1036#else 1037 ffi_call(&cif->lib_cif, callout->fn, cif->ret, cif->args); 1038#endif 1039} 1040/* 1041 * lib management, but note we never free a lib 1042 * because we cannot know how often it is used. 1043 */ 1044/* define a new lib */ 1045static void lib_define(ffidl_client *client, char *lname, void *handle, void* unload) 1046{ 1047 void** libentry = (void**)Tcl_Alloc(2*sizeof(void*)); 1048 libentry[0] = handle; libentry[1] = unload; 1049 entry_define(&client->libs,lname,libentry); 1050} 1051/* lookup an existing type */ 1052static void *lib_lookup(ffidl_client *client, char *lname, void** unload) 1053{ 1054 void** libentry = entry_lookup(&client->libs,lname); 1055 if (libentry) { 1056 if (unload) *unload = libentry[1]; 1057 return libentry[0]; 1058 } else { 1059 return NULL; 1060 } 1061} 1062#if USE_CALLBACKS 1063/* 1064 * callback management 1065 */ 1066/* define a new callback */ 1067static void callback_define(ffidl_client *client, char *cname, ffidl_callback *callback) 1068{ 1069 entry_define(&client->callbacks,cname,(void*)callback); 1070} 1071/* lookup an existing callback */ 1072static ffidl_callback *callback_lookup(ffidl_client *client, char *cname) 1073{ 1074 return entry_lookup(&client->callbacks,cname); 1075} 1076/* find a callback by it's ffidl_callback */ 1077/* 1078static Tcl_HashEntry *callback_find(ffidl_client *client, ffidl_callback *callback) 1079{ 1080 return entry_find(&client->callbacks,(void *)callback); 1081} 1082*/ 1083/* delete a callback definition */ 1084/* 1085static void callback_delete(ffidl_client *client, ffidl_callback *callback) 1086{ 1087 Tcl_HashEntry *entry = callback_find(client, callback); 1088 if (entry) { 1089 cif_dec_ref(callback->cif); 1090 Tcl_DecrRefCount(callback->proc); 1091 Tcl_Free((void *)callback); 1092 Tcl_DeleteHashEntry(entry); 1093 } 1094} 1095*/ 1096/* call a tcl proc from a libffi closure */ 1097static void callback_callback(ffi_cif *fficif, void *ret, void **args, void *user_data) 1098{ 1099 ffidl_closure *closure = (ffidl_closure *)user_data; 1100 ffidl_callback *callback = closure->callback; 1101 Tcl_Interp *interp = closure->interp; 1102 ffidl_cif *cif = callback->cif; 1103 Tcl_Obj **objv, *obj, *list; 1104 char buff[128]; 1105 int i, status; 1106 long ltmp; 1107 double dtmp; 1108#if HAVE_INT64 1109 Tcl_WideInt wtmp; 1110#endif 1111 /* test for valid scope */ 1112 if (interp == NULL) { 1113 Tcl_Panic("callback called out of scope!\n"); 1114 } 1115 /* initialize command list */ 1116 list = Tcl_NewListObj(1, &callback->proc); 1117 Tcl_IncrRefCount(list); 1118 /* fetch and convert argument values */ 1119 for (i = 0; i < cif->argc; i += 1) { 1120 void *argp; 1121#if FFI_NATIVE_RAW_API 1122 if (cif->use_raw_api) { 1123 int offset = ((int)cif->args[i])-((int)cif->args[0]); 1124 argp = (void *)(((char *)args)+offset); 1125 } else { 1126 argp = args[i]; 1127 } 1128#else 1129 argp = args[i]; 1130#endif 1131 switch (cif->atypes[i]->typecode) { 1132 case FFIDL_INT: 1133 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(int *)argp))); 1134 continue; 1135 case FFIDL_FLOAT: 1136 Tcl_ListObjAppendElement(interp, list, Tcl_NewDoubleObj((double)(*(float *)argp))); 1137 continue; 1138 case FFIDL_DOUBLE: 1139 Tcl_ListObjAppendElement(interp, list, Tcl_NewDoubleObj(*(double *)argp)); 1140 continue; 1141#if HAVE_LONG_DOUBLE 1142 case FFIDL_LONGDOUBLE: 1143 Tcl_ListObjAppendElement(interp, list, Tcl_NewDoubleObj((double)(*(long double *)argp))); 1144 continue; 1145#endif 1146 case FFIDL_UINT8: 1147 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(UINT8_T *)argp))); 1148 continue; 1149 case FFIDL_SINT8: 1150 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(SINT8_T *)argp))); 1151 continue; 1152 case FFIDL_UINT16: 1153 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(UINT16_T *)argp))); 1154 continue; 1155 case FFIDL_SINT16: 1156 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(SINT16_T *)argp))); 1157 continue; 1158 case FFIDL_UINT32: 1159 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(UINT32_T *)argp))); 1160 continue; 1161 case FFIDL_SINT32: 1162 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(SINT32_T *)argp))); 1163 continue; 1164#if HAVE_INT64 1165 case FFIDL_UINT64: 1166 Tcl_ListObjAppendElement(interp, list, Tcl_NewWideIntObj((Tcl_WideInt)(*(UINT64_T *)argp))); 1167 continue; 1168 case FFIDL_SINT64: 1169 Tcl_ListObjAppendElement(interp, list, Tcl_NewWideIntObj((Tcl_WideInt)(*(SINT64_T *)argp))); 1170 continue; 1171#endif 1172 case FFIDL_STRUCT: 1173 Tcl_ListObjAppendElement(interp, list, Tcl_NewByteArrayObj((unsigned char *)argp, cif->atypes[i]->size)); 1174 continue; 1175 case FFIDL_PTR: 1176 Tcl_ListObjAppendElement(interp, list, Tcl_NewLongObj((long)(*(void **)argp))); 1177 continue; 1178 case FFIDL_PTR_OBJ: 1179 Tcl_ListObjAppendElement(interp, list, *(Tcl_Obj **)argp); 1180 continue; 1181 case FFIDL_PTR_UTF8: 1182 Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(*(char **)argp, -1)); 1183 continue; 1184 case FFIDL_PTR_UTF16: 1185 Tcl_ListObjAppendElement(interp, list, Tcl_NewUnicodeObj(*(Tcl_UniChar **)argp, -1)); 1186 continue; 1187 default: 1188 sprintf(buff, "unimplemented type for callback argument: %d", cif->atypes[i]->typecode); 1189 Tcl_AppendResult(interp, buff, NULL); 1190 Tcl_DecrRefCount(list); 1191 goto escape; 1192 continue; 1193 } 1194 } 1195 /* get command */ 1196 Tcl_ListObjGetElements(interp, list, &i, &objv); 1197 /* call */ 1198 status = Tcl_EvalObjv(interp, cif->argc+1, objv, TCL_EVAL_GLOBAL); 1199 /* clean up arguments */ 1200 Tcl_DecrRefCount(list); 1201 if (status == TCL_ERROR) { 1202 goto escape; 1203 } 1204 /* fetch return value */ 1205 obj = Tcl_GetObjResult(interp); 1206 if (cif->rtype->class & FFIDL_GETINT) { 1207 if (ffidl_double_ObjType && obj->typePtr == ffidl_double_ObjType) { 1208 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) { 1209 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1210 goto escape; 1211 } 1212 ltmp = (long)dtmp; 1213 if (dtmp != ltmp) 1214 if (Tcl_GetLongFromObj(interp, obj, <mp) == TCL_ERROR) { 1215 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1216 goto escape; 1217 } 1218 } else if (Tcl_GetLongFromObj(interp, obj, <mp) == TCL_ERROR) { 1219 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1220 goto escape; 1221 } 1222#if HAVE_INT64 1223 } else if (cif->rtype->class & FFIDL_GETWIDEINT) { 1224 if (ffidl_double_ObjType && obj->typePtr == ffidl_double_ObjType) { 1225 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) { 1226 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1227 goto escape; 1228 } 1229 wtmp = (Tcl_WideInt)dtmp; 1230 if (dtmp != wtmp) 1231 if (Tcl_GetWideIntFromObj(interp, obj, &wtmp) == TCL_ERROR) { 1232 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1233 goto escape; 1234 } 1235 } else if (Tcl_GetWideIntFromObj(interp, obj, &wtmp) == TCL_ERROR) { 1236 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1237 goto escape; 1238 } 1239#endif 1240 } else if (cif->rtype->class & FFIDL_GETDOUBLE) { 1241 if (ffidl_int_ObjType && obj->typePtr == ffidl_int_ObjType) { 1242 if (Tcl_GetLongFromObj(interp, obj, <mp) == TCL_ERROR) { 1243 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1244 goto escape; 1245 } 1246 dtmp = (double)ltmp; 1247 if (dtmp != ltmp) 1248 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) { 1249 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1250 goto escape; 1251 } 1252#if HAVE_INT64 1253 } else if (ffidl_wideInt_ObjType && obj->typePtr == ffidl_wideInt_ObjType) { 1254 if (Tcl_GetWideIntFromObj(interp, obj, &wtmp) == TCL_ERROR) { 1255 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1256 goto escape; 1257 } 1258 dtmp = (double)wtmp; 1259 if (dtmp != wtmp) 1260 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) { 1261 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1262 goto escape; 1263 } 1264#endif 1265 } else if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) { 1266 Tcl_AppendResult(interp, ", converting callback return value", NULL); 1267 goto escape; 1268 } 1269 } 1270 1271 /* convert return value */ 1272 switch (cif->rtype->typecode) { 1273 case FFIDL_VOID: break; 1274 case FFIDL_INT: *(int *)ret = (int)ltmp; break; 1275 case FFIDL_FLOAT: *(float *)ret = (float)dtmp; break; 1276 case FFIDL_DOUBLE: *(double *)ret = dtmp; break; 1277#if HAVE_LONG_DOUBLE 1278 case FFIDL_LONGDOUBLE:*(long double *)ret = dtmp; break; 1279#endif 1280#ifdef POWERPC_DARWIN 1281 case FFIDL_UINT8: *(UINT32_T *)ret = (UINT8_T)ltmp; break; 1282 case FFIDL_SINT8: *(SINT32_T *)ret = (SINT8_T)ltmp; break; 1283 case FFIDL_UINT16: *(UINT32_T *)ret = (UINT16_T)ltmp; break; 1284 case FFIDL_SINT16: *(SINT32_T *)ret = (SINT16_T)ltmp; break; 1285#else 1286 case FFIDL_UINT8: *(UINT8_T *)ret = (UINT8_T)ltmp; break; 1287 case FFIDL_SINT8: *(SINT8_T *)ret = (SINT8_T)ltmp; break; 1288 case FFIDL_UINT16: *(UINT16_T *)ret = (UINT16_T)ltmp; break; 1289 case FFIDL_SINT16: *(SINT16_T *)ret = (SINT16_T)ltmp; break; 1290#endif 1291 case FFIDL_UINT32: *(UINT32_T *)ret = (UINT32_T)ltmp; break; 1292 case FFIDL_SINT32: *(SINT32_T *)ret = (SINT32_T)ltmp; break; 1293#if HAVE_INT64 1294 case FFIDL_UINT64: *(UINT64_T *)ret = (UINT64_T)wtmp; break; 1295 case FFIDL_SINT64: *(SINT64_T *)ret = (SINT64_T)wtmp; break; 1296#endif 1297 case FFIDL_STRUCT: 1298 { 1299 int len; 1300 void *bytes = Tcl_GetByteArrayFromObj(obj, &len); 1301 if (len != cif->rtype->size) { 1302 Tcl_ResetResult(interp); 1303 sprintf(buff, "byte array for callback struct return has %u bytes instead of %lu", len, (long)(cif->rtype->size)); 1304 Tcl_AppendResult(interp, buff, NULL); 1305 goto escape; 1306 } 1307 memcpy(ret, bytes, cif->rtype->size); 1308 break; 1309 } 1310 case FFIDL_PTR: *(void **)ret = (void *)ltmp; break; 1311 case FFIDL_PTR_OBJ: *(Tcl_Obj **)ret = obj; break; 1312 default: 1313 Tcl_ResetResult(interp); 1314 sprintf(buff, "unimplemented type for callback return: %d", cif->rtype->typecode); 1315 Tcl_AppendResult(interp, buff, NULL); 1316 goto escape; 1317 } 1318 /* done */ 1319 return; 1320escape: 1321 Tcl_BackgroundError(interp); 1322 memset(ret, 0, cif->rtype->size); 1323} 1324#endif 1325/* 1326 * Client management. 1327 */ 1328/* client interp deletion callback for cleanup */ 1329static void client_delete(ClientData clientData, Tcl_Interp *interp) 1330{ 1331 ffidl_client *client = (ffidl_client *)clientData; 1332 Tcl_HashSearch search; 1333 Tcl_HashEntry *entry; 1334 1335 /* there should be no callouts left */ 1336 for (entry = Tcl_FirstHashEntry(&client->callouts, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { 1337 char *name = Tcl_GetHashKey(&client->callouts, entry); 1338 /* Couldn't do this while traversing the hash table anyway */ 1339 /* Tcl_DeleteCommand(interp, name); */ 1340 fprintf(stderr, "error - dangling callout in client_delete: %s\n", name); 1341 } 1342 1343#if USE_CALLBACKS 1344 /* free all callbacks */ 1345 for (entry = Tcl_FirstHashEntry(&client->callbacks, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { 1346 ffidl_callback *callback = Tcl_GetHashValue(entry); 1347 cif_dec_ref(callback->cif); 1348 Tcl_DecrRefCount(callback->proc); 1349 Tcl_Free((void *)callback); 1350 } 1351#endif 1352 1353 /* there should be no cifs left */ 1354 for (entry = Tcl_FirstHashEntry(&client->cifs, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { 1355 char *signature = Tcl_GetHashKey(&client->cifs, entry); 1356 fprintf(stderr, "error - dangling ffidl_cif in client_delete: %s\n",signature); 1357 } 1358 1359 /* free all allocated typedefs */ 1360 for (entry = Tcl_FirstHashEntry(&client->types, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { 1361 ffidl_type *type = Tcl_GetHashValue(entry); 1362 if ((type->class & FFIDL_STATIC_TYPE) == 0) 1363 type_free(type); 1364 } 1365 1366 /* free all libs */ 1367 for (entry = Tcl_FirstHashEntry(&client->libs, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { 1368 void **libentry = Tcl_GetHashValue(entry); 1369 const char *error; 1370 ffidlclose(libentry[0], &error); 1371 Tcl_Free((char*)libentry); 1372 } 1373 1374 /* free hashtables */ 1375 Tcl_DeleteHashTable(&client->callouts); 1376#if USE_CALLBACKS 1377 Tcl_DeleteHashTable(&client->callbacks); 1378#endif 1379 Tcl_DeleteHashTable(&client->cifs); 1380 Tcl_DeleteHashTable(&client->types); 1381 Tcl_DeleteHashTable(&client->libs); 1382 1383 /* free client structure */ 1384 Tcl_Free((void *)client); 1385} 1386/* client allocation and initialization */ 1387static ffidl_client *client_alloc(Tcl_Interp *interp) 1388{ 1389 ffidl_client *client; 1390 1391 /* allocate client data structure */ 1392 client = (ffidl_client *)Tcl_Alloc(sizeof(ffidl_client)); 1393 1394 /* allocate hashtables for this load */ 1395 Tcl_InitHashTable(&client->types, TCL_STRING_KEYS); 1396 Tcl_InitHashTable(&client->callouts, TCL_STRING_KEYS); 1397 Tcl_InitHashTable(&client->cifs, TCL_STRING_KEYS); 1398 Tcl_InitHashTable(&client->libs, TCL_STRING_KEYS); 1399#if USE_CALLBACKS 1400 Tcl_InitHashTable(&client->callbacks, TCL_STRING_KEYS); 1401#endif 1402 1403 /* initialize types */ 1404 type_define(client, "void", &ffidl_type_void); 1405 type_define(client, "char", &ffidl_type_char); 1406 type_define(client, "signed char", &ffidl_type_schar); 1407 type_define(client, "unsigned char", &ffidl_type_uchar); 1408 type_define(client, "short", &ffidl_type_sshort); 1409 type_define(client, "unsigned short", &ffidl_type_ushort); 1410 type_define(client, "int", &ffidl_type_sint); 1411 type_define(client, "unsigned", &ffidl_type_uint); 1412 type_define(client, "long", &ffidl_type_slong); 1413 type_define(client, "unsigned long", &ffidl_type_ulong); 1414#if HAVE_LONG_LONG 1415 type_define(client, "long long", &ffidl_type_slonglong); 1416 type_define(client, "unsigned long long", &ffidl_type_ulonglong); 1417#endif 1418 type_define(client, "float", &ffidl_type_float); 1419 type_define(client, "double", &ffidl_type_double); 1420#if HAVE_LONG_DOUBLE 1421 type_define(client, "long double", &ffidl_type_longdouble); 1422#endif 1423 type_define(client, "sint8", &ffidl_type_sint8); 1424 type_define(client, "uint8", &ffidl_type_uint8); 1425 type_define(client, "sint16", &ffidl_type_sint16); 1426 type_define(client, "uint16", &ffidl_type_uint16); 1427 type_define(client, "sint32", &ffidl_type_sint32); 1428 type_define(client, "uint32", &ffidl_type_uint32); 1429#if HAVE_INT64 1430 type_define(client, "sint64", &ffidl_type_sint64); 1431 type_define(client, "uint64", &ffidl_type_uint64); 1432#endif 1433 type_define(client, "pointer", &ffidl_type_pointer); 1434 type_define(client, "pointer-obj", &ffidl_type_pointer_obj); 1435 type_define(client, "pointer-utf8", &ffidl_type_pointer_utf8); 1436 type_define(client, "pointer-utf16", &ffidl_type_pointer_utf16); 1437 type_define(client, "pointer-byte", &ffidl_type_pointer_byte); 1438 type_define(client, "pointer-var", &ffidl_type_pointer_var); 1439#if USE_CALLBACKS 1440 type_define(client, "pointer-proc", &ffidl_type_pointer_proc); 1441#endif 1442 1443 /* arrange for cleanup on interpreter deletion */ 1444 Tcl_CallWhenDeleted(interp, client_delete, (ClientData)client); 1445 1446 /* finis */ 1447 return client; 1448} 1449/***************************************** 1450 * 1451 * Functions exported as tcl commands. 1452 */ 1453 1454/* usage: ::ffidl::info option ?...? */ 1455static int tcl_ffidl_info(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 1456{ 1457 int i; 1458 char *arg; 1459 Tcl_HashTable *table; 1460 Tcl_HashSearch search; 1461 Tcl_HashEntry *entry; 1462 ffidl_type *type; 1463 ffidl_client *client = (ffidl_client *)clientData; 1464 static const char *options[] = { 1465#define INFO_ALIGNOF 0 1466 "alignof", 1467#define INFO_CALLBACKS 1 1468 "callbacks", 1469#define INFO_CALLOUTS 2 1470 "callouts", 1471#define INFO_CANONICAL_HOST 3 1472 "canonical-host", 1473#define INFO_FORMAT 4 1474 "format", 1475#define INFO_HAVE_INT64 5 1476 "have-int64", 1477#define INFO_HAVE_LONG_DOUBLE 6 1478 "have-long-double", 1479#define INFO_HAVE_LONG_LONG 7 1480 "have-long-long", 1481#define INFO_INTERP 8 1482 "interp", 1483#define INFO_LIBRARIES 9 1484 "libraries", 1485#define INFO_SIGNATURES 10 1486 "signatures", 1487#define INFO_SIZEOF 11 1488 "sizeof", 1489#define INFO_TYPEDEFS 12 1490 "typedefs", 1491#define INFO_USE_CALLBACKS 13 1492 "use-callbacks", 1493#define INFO_USE_FFCALL 14 1494 "use-ffcall", 1495#define INFO_USE_LIBFFI 15 1496 "use-libffi", 1497#define INFO_USE_LIBFFI_RAW 16 1498 "use-libffi-raw", 1499 NULL 1500 }; 1501 1502 if (objc < 2) { 1503 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); 1504 return TCL_ERROR; 1505 } 1506 1507 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &i) == TCL_ERROR) 1508 return TCL_ERROR; 1509 1510 switch (i) { 1511 case INFO_CALLOUTS: /* return list of callout names */ 1512 table = &client->callouts; 1513 list_table_keys: /* list the keys in a hash table */ 1514 if (objc != 2) { 1515 Tcl_WrongNumArgs(interp,2,objv,""); 1516 return TCL_ERROR; 1517 } 1518 for (entry = Tcl_FirstHashEntry(table, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) 1519 Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(Tcl_GetHashKey(table,entry),-1)); 1520 return TCL_OK; 1521 case INFO_TYPEDEFS: /* return list of typedef names */ 1522 table = &client->types; 1523 goto list_table_keys; 1524 case INFO_SIGNATURES: /* return list of ffi signatures */ 1525 table = &client->cifs; 1526 goto list_table_keys; 1527 case INFO_LIBRARIES: /* return list of lib names */ 1528 table = &client->libs; 1529 goto list_table_keys; 1530 case INFO_CALLBACKS: /* return list of callback names */ 1531#if USE_CALLBACKS 1532 table = &client->callbacks; 1533 goto list_table_keys; 1534#else 1535 Tcl_AppendResult(interp, "callbacks are not supported in this configuration", NULL); 1536 return TCL_ERROR; 1537#endif 1538 1539 case INFO_SIZEOF: /* return sizeof type */ 1540 case INFO_ALIGNOF: /* return alignof type */ 1541 case INFO_FORMAT: /* return binary format of type */ 1542 if (objc != 3) { 1543 Tcl_WrongNumArgs(interp,2,objv,"type"); 1544 return TCL_ERROR; 1545 } 1546 arg = Tcl_GetString(objv[2]); 1547 type = type_lookup(client, arg); 1548 if (type == NULL) { 1549 Tcl_AppendResult(interp, "undefined type: ", arg, NULL); 1550 return TCL_ERROR; 1551 } 1552 if (i == INFO_SIZEOF) { 1553 Tcl_SetObjResult(interp, Tcl_NewIntObj(type->size)); 1554 return TCL_OK; 1555 } 1556 if (i == INFO_ALIGNOF) { 1557 Tcl_SetObjResult(interp, Tcl_NewIntObj(type->alignment)); 1558 return TCL_OK; 1559 } 1560 if (i == INFO_FORMAT) { 1561 i = 0; 1562 return type_format(interp, type, &i); 1563 } 1564 Tcl_AppendResult(interp, "lost in ::ffidl::info?", NULL); 1565 return TCL_ERROR; 1566 case INFO_INTERP: 1567 /* return the interp as integer */ 1568 if (objc != 2) { 1569 Tcl_WrongNumArgs(interp,2,objv,""); 1570 return TCL_ERROR; 1571 } 1572 Tcl_SetObjResult(interp, Tcl_NewLongObj((long)interp)); 1573 return TCL_OK; 1574 case INFO_USE_FFCALL: 1575 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 1576 return TCL_OK; 1577 case INFO_USE_LIBFFI: 1578 Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); 1579 return TCL_OK; 1580 case INFO_USE_CALLBACKS: 1581#if USE_CALLBACKS 1582 Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); 1583#else 1584 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 1585#endif 1586 return TCL_OK; 1587 case INFO_HAVE_LONG_LONG: 1588#if HAVE_LONG_LONG 1589 Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); 1590#else 1591 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 1592#endif 1593 return TCL_OK; 1594 case INFO_HAVE_LONG_DOUBLE: 1595#if HAVE_LONG_DOUBLE 1596 Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); 1597#else 1598 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 1599#endif 1600 return TCL_OK; 1601 case INFO_USE_LIBFFI_RAW: 1602#if FFI_NATIVE_RAW_API 1603 Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); 1604#else 1605 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 1606#endif 1607 return TCL_OK; 1608 case INFO_HAVE_INT64: 1609#if HAVE_INT64 1610 Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); 1611#else 1612 Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 1613#endif 1614 return TCL_OK; 1615 case INFO_CANONICAL_HOST: 1616 Tcl_SetObjResult(interp, Tcl_NewStringObj(CANONICAL_HOST,-1)); 1617 return TCL_OK; 1618 } 1619 1620 /* return an error */ 1621 Tcl_AppendResult(interp, "missing option implementation: ", Tcl_GetString(objv[1]), NULL); 1622 return TCL_ERROR; 1623} 1624 1625/* usage: ffidl-typedef name type1 ?type2 ...? */ 1626static int tcl_ffidl_typedef(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 1627{ 1628 char *tname1, *tname2; 1629 ffidl_type *newtype, *ttype2; 1630 int nelts, i; 1631 ffidl_client *client = (ffidl_client *)clientData; 1632 /* check number of args */ 1633 if (objc < 3) { 1634 Tcl_WrongNumArgs(interp,1,objv,"name type ?...?"); 1635 return TCL_ERROR; 1636 } 1637 /* fetch new type name, verify that it is new */ 1638 tname1 = Tcl_GetString(objv[1]); 1639 if (type_lookup(client, tname1) != NULL) { 1640 Tcl_AppendResult(interp, "type is already defined: ", tname1, NULL); 1641 return TCL_ERROR; 1642 } 1643 /* define tname1 as an alias for tname2 */ 1644 if (objc == 3) { 1645 tname2 = Tcl_GetString(objv[2]); 1646 ttype2 = type_lookup(client, tname2); 1647 if (ttype2 == NULL) { 1648 Tcl_AppendResult(interp, "undefined type: ", tname2, NULL); 1649 return TCL_ERROR; 1650 } 1651 type_define(client, tname1, ttype2); 1652 return TCL_OK; 1653 } 1654 /* allocate an aggregate type */ 1655 nelts = objc-2; 1656 newtype = type_alloc(client, nelts); 1657 if (newtype == NULL) { 1658 Tcl_AppendResult(interp, "couldn't allocate the ffi_type", NULL); 1659 return TCL_ERROR; 1660 } 1661 /* parse aggregate types */ 1662 newtype->size = 0; 1663 newtype->alignment = 0; 1664 for (i = 0; i < nelts; i += 1) { 1665 tname2 = Tcl_GetString(objv[2+i]); 1666 ttype2 = type_lookup(client, tname2); 1667 if (ttype2 == NULL) { 1668 type_free(newtype); 1669 Tcl_AppendResult(interp, "undefined element type: ", tname2, NULL); 1670 return TCL_ERROR; 1671 } 1672 if ((ttype2->class & FFIDL_ELT) == 0) { 1673 type_free(newtype); 1674 Tcl_AppendResult(interp, "type ", tname2, " is not permitted in element context", NULL); 1675 return TCL_ERROR; 1676 } 1677 newtype->elements[i] = ttype2; 1678 /* accumulate the aggregate size and alignment */ 1679 /* align current size to element's alignment */ 1680 if ((ttype2->alignment-1) & newtype->size) 1681 newtype->size = ((newtype->size-1) | (ttype2->alignment-1)) + 1; 1682 /* add the element's size */ 1683 newtype->size += ttype2->size; 1684 /* bump the aggregate alignment as required */ 1685 if (ttype2->alignment > newtype->alignment) 1686 newtype->alignment = ttype2->alignment; 1687 } 1688 newtype->size = ((newtype->size-1) | (newtype->alignment-1)) + 1; /* tail padding as in libffi */ 1689 if (type_prep(newtype) != TCL_OK) { 1690 type_free(newtype); 1691 Tcl_AppendResult(interp, "type definition error", NULL); 1692 return TCL_ERROR; 1693 } 1694 /* define new type */ 1695 type_define(client, tname1, newtype); 1696 /* return success */ 1697 return TCL_OK; 1698} 1699 1700/* usage: depends on the signature defining the ffidl-callout */ 1701static int tcl_ffidl_call(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 1702{ 1703 ffidl_callout *callout = (ffidl_callout *)clientData; 1704 ffidl_cif *cif = callout->cif; 1705 int i, itmp; 1706 long ltmp; 1707 double dtmp; 1708#if HAVE_INT64 1709 Tcl_WideInt wtmp; 1710#endif 1711 Tcl_Obj *obj = NULL; 1712 char buff[128]; 1713 /* usage check */ 1714 if (objc-1 != cif->argc) { 1715 Tcl_WrongNumArgs(interp, 1, objv, callout->usage); 1716 return TCL_ERROR; 1717 } 1718 /* fetch and convert argument values */ 1719 for (i = 0; i < cif->argc; i += 1) { 1720 /* fetch object */ 1721 obj = objv[1+i]; 1722 /* fetch value from object and store value into arg value array */ 1723 if (cif->atypes[i]->class & FFIDL_GETINT) { 1724 if (ffidl_double_ObjType && obj->typePtr == ffidl_double_ObjType) { 1725 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) 1726 goto cleanup; 1727 ltmp = (long)dtmp; 1728 if (dtmp != ltmp) 1729 if (Tcl_GetLongFromObj(interp, obj, <mp) == TCL_ERROR) 1730 goto cleanup; 1731 } else if (Tcl_GetLongFromObj(interp, obj, <mp) == TCL_ERROR) 1732 goto cleanup; 1733#if HAVE_INT64 1734 } else if (cif->atypes[i]->class & FFIDL_GETWIDEINT) { 1735 if (ffidl_double_ObjType && obj->typePtr == ffidl_double_ObjType) { 1736 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) 1737 goto cleanup; 1738 wtmp = (Tcl_WideInt)dtmp; 1739 if (dtmp != wtmp) 1740 if (Tcl_GetWideIntFromObj(interp, obj, &wtmp) == TCL_ERROR) 1741 goto cleanup; 1742 } else if (Tcl_GetWideIntFromObj(interp, obj, &wtmp) == TCL_ERROR) 1743 goto cleanup; 1744#endif 1745 } else if (cif->atypes[i]->class & FFIDL_GETDOUBLE) { 1746 if (ffidl_int_ObjType && obj->typePtr == ffidl_int_ObjType) { 1747 if (Tcl_GetLongFromObj(interp, obj, <mp) == TCL_ERROR) 1748 goto cleanup; 1749 dtmp = (double)ltmp; 1750 if (dtmp != ltmp) 1751 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) 1752 goto cleanup; 1753#if HAVE_INT64 1754 } else if (ffidl_wideInt_ObjType && obj->typePtr == ffidl_wideInt_ObjType) { 1755 if (Tcl_GetWideIntFromObj(interp, obj, &wtmp) == TCL_ERROR) 1756 goto cleanup; 1757 dtmp = (double)wtmp; 1758 if (dtmp != wtmp) 1759 if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) 1760 goto cleanup; 1761#endif 1762 } else if (Tcl_GetDoubleFromObj(interp, obj, &dtmp) == TCL_ERROR) 1763 goto cleanup; 1764 } 1765 switch (cif->atypes[i]->typecode) { 1766 case FFIDL_INT: 1767 *(int *)cif->args[i] = (int)ltmp; 1768 continue; 1769 case FFIDL_FLOAT: 1770 *(float *)cif->args[i] = (float)dtmp; 1771 continue; 1772 case FFIDL_DOUBLE: 1773 *(double *)cif->args[i] = (double)dtmp; 1774 continue; 1775#if HAVE_LONG_DOUBLE 1776 case FFIDL_LONGDOUBLE: 1777 *(long double *)cif->args[i] = (long double)dtmp; 1778 continue; 1779#endif 1780 case FFIDL_UINT8: 1781 *(UINT8_T *)cif->args[i] = (UINT8_T)ltmp; 1782 continue; 1783 case FFIDL_SINT8: 1784 *(SINT8_T *)cif->args[i] = (SINT8_T)ltmp; 1785 continue; 1786 case FFIDL_UINT16: 1787 *(UINT16_T *)cif->args[i] = (UINT16_T)ltmp; 1788 continue; 1789 case FFIDL_SINT16: 1790 *(SINT16_T *)cif->args[i] = (SINT16_T)ltmp; 1791 continue; 1792 case FFIDL_UINT32: 1793 *(UINT32_T *)cif->args[i] = (UINT32_T)ltmp; 1794 continue; 1795 case FFIDL_SINT32: 1796 *(SINT32_T *)cif->args[i] = (SINT32_T)ltmp; 1797 continue; 1798#if HAVE_INT64 1799 case FFIDL_UINT64: 1800 *(UINT64_T *)cif->args[i] = (UINT64_T)wtmp; 1801 continue; 1802 case FFIDL_SINT64: 1803 *(SINT64_T *)cif->args[i] = (SINT64_T)wtmp; 1804 continue; 1805#endif 1806 case FFIDL_STRUCT: 1807 if (ffidl_bytearray_ObjType && obj->typePtr != ffidl_bytearray_ObjType) { 1808 sprintf(buff, "parameter %d must be a binary string", i); 1809 Tcl_AppendResult(interp, buff, NULL); 1810 goto cleanup; 1811 } 1812 cif->args[i] = (void *)Tcl_GetByteArrayFromObj(obj, &itmp); 1813 if (itmp != cif->atypes[i]->size) { 1814 sprintf(buff, "parameter %d is the wrong size, %u bytes instead of %lu.", i, itmp, (long)(cif->atypes[i]->size)); 1815 Tcl_AppendResult(interp, buff, NULL); 1816 goto cleanup; 1817 } 1818 continue; 1819 case FFIDL_PTR: 1820 *(void **)cif->args[i] = (void *)ltmp; 1821 continue; 1822 case FFIDL_PTR_OBJ: 1823 *(void **)cif->args[i] = (void *)obj; 1824 continue; 1825 case FFIDL_PTR_UTF8: 1826 *(void **)cif->args[i] = (void *)Tcl_GetString(obj); 1827 continue; 1828 case FFIDL_PTR_UTF16: 1829 *(void **)cif->args[i] = (void *)Tcl_GetUnicode(obj); 1830 continue; 1831 case FFIDL_PTR_BYTE: 1832 if (ffidl_bytearray_ObjType && obj->typePtr != ffidl_bytearray_ObjType) { 1833 sprintf(buff, "parameter %d must be a binary string", i); 1834 Tcl_AppendResult(interp, buff, NULL); 1835 goto cleanup; 1836 } 1837 *(void **)cif->args[i] = (void *)Tcl_GetByteArrayFromObj(obj, &itmp); 1838 continue; 1839 case FFIDL_PTR_VAR: 1840 obj = Tcl_ObjGetVar2(interp, objv[1+i], NULL, TCL_LEAVE_ERR_MSG); 1841 if (obj == NULL) return TCL_ERROR; 1842 if (ffidl_bytearray_ObjType && obj->typePtr != ffidl_bytearray_ObjType) { 1843 sprintf(buff, "parameter %d must be a binary string", i); 1844 Tcl_AppendResult(interp, buff, NULL); 1845 goto cleanup; 1846 } 1847 if (Tcl_IsShared(obj)) { 1848 obj = Tcl_ObjSetVar2(interp, objv[1+i], NULL, Tcl_DuplicateObj(obj), TCL_LEAVE_ERR_MSG); 1849 if (obj == NULL) 1850 goto cleanup; 1851 } 1852 *(void **)cif->args[i] = (void *)Tcl_GetByteArrayFromObj(obj, &itmp); 1853 /* printf("pointer-var -> %d\n", cif->avalues[i].v_pointer); */ 1854 Tcl_InvalidateStringRep(obj); 1855 continue; 1856#if USE_CALLBACKS 1857 case FFIDL_PTR_PROC: { 1858 ffidl_callback *callback; 1859 ffidl_closure *closure; 1860 Tcl_DString ds; 1861 char *name = Tcl_GetString(objv[1+i]); 1862 Tcl_DStringInit(&ds); 1863 if (!strstr(name, "::")) { 1864 Tcl_Namespace *ns; 1865 ns = Tcl_GetCurrentNamespace(interp); 1866 if (ns != Tcl_GetGlobalNamespace(interp)) { 1867 Tcl_DStringAppend(&ds, ns->fullName, -1); 1868 } 1869 Tcl_DStringAppend(&ds, "::", 2); 1870 Tcl_DStringAppend(&ds, name, -1); 1871 name = Tcl_DStringValue(&ds); 1872 } 1873 callback = callback_lookup(callout->client, name); 1874 Tcl_DStringFree(&ds); 1875 if (callback == NULL) { 1876 Tcl_AppendResult(interp, "no callback named \"", Tcl_GetString(objv[1+i]), "\" is defined", NULL); 1877 goto cleanup; 1878 } 1879 closure = &(callback->closure); 1880 *(void **)cif->args[i] = (void *)&closure->lib_closure; 1881 } 1882 continue; 1883#endif 1884 default: 1885 sprintf(buff, "unknown type for argument: %d", cif->atypes[i]->typecode); 1886 Tcl_AppendResult(interp, buff, NULL); 1887 goto cleanup; 1888 } 1889 } 1890 /* prepare for structure return */ 1891 if (cif->rtype->typecode == FFIDL_STRUCT) { 1892 obj = Tcl_NewByteArrayObj((unsigned char*)"", cif->rtype->size); 1893 Tcl_IncrRefCount(obj); 1894 cif->ret = Tcl_GetByteArrayFromObj(obj, &itmp); 1895 } 1896 /* call */ 1897 callout_call(callout); 1898 /* convert return value */ 1899 switch (cif->rtype->typecode) { 1900 case FFIDL_VOID: break; 1901 case FFIDL_INT: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_int)); break; 1902 case FFIDL_FLOAT: Tcl_SetObjResult(interp, Tcl_NewDoubleObj((double)cif->rvalue.v_float)); break; 1903 case FFIDL_DOUBLE: Tcl_SetObjResult(interp, Tcl_NewDoubleObj((double)cif->rvalue.v_double)); break; 1904#if HAVE_LONG_DOUBLE 1905 case FFIDL_LONGDOUBLE:Tcl_SetObjResult(interp, Tcl_NewDoubleObj((double)cif->rvalue.v_longdouble)); break; 1906#endif 1907#ifdef POWERPC_DARWIN 1908 case FFIDL_UINT8: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_uint32)); break; 1909 case FFIDL_SINT8: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_sint32)); break; 1910 case FFIDL_UINT16: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_uint32)); break; 1911 case FFIDL_SINT16: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_sint32)); break; 1912#else 1913 case FFIDL_UINT8: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_uint8)); break; 1914 case FFIDL_SINT8: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_sint8)); break; 1915 case FFIDL_UINT16: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_uint16)); break; 1916 case FFIDL_SINT16: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_sint16)); break; 1917#endif 1918 case FFIDL_UINT32: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_uint32)); break; 1919 case FFIDL_SINT32: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_sint32)); break; 1920#if HAVE_INT64 1921 case FFIDL_UINT64: Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)cif->rvalue.v_uint64)); break; 1922 case FFIDL_SINT64: Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)cif->rvalue.v_sint64)); break; 1923#endif 1924 case FFIDL_STRUCT: Tcl_SetObjResult(interp, obj); Tcl_DecrRefCount(obj); break; 1925 case FFIDL_PTR: Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cif->rvalue.v_pointer)); break; 1926 case FFIDL_PTR_OBJ: Tcl_SetObjResult(interp, (Tcl_Obj *)cif->rvalue.v_pointer); break; 1927 case FFIDL_PTR_UTF8: Tcl_SetObjResult(interp, Tcl_NewStringObj(cif->rvalue.v_pointer, -1)); break; 1928 case FFIDL_PTR_UTF16: Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(cif->rvalue.v_pointer, -1)); break; 1929 default: 1930 sprintf(buff, "Invalid return type: %d", cif->rtype->typecode); 1931 Tcl_AppendResult(interp, buff, NULL); 1932 goto cleanup; 1933 return TCL_ERROR; 1934 } 1935 /* done */ 1936 return TCL_OK; 1937 /* blew it */ 1938 cleanup: 1939 return TCL_ERROR; 1940} 1941 1942/* usage: ffidl-callout name {?argument_type ...?} return_type address ?protocol? */ 1943static int tcl_ffidl_callout(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 1944{ 1945 char *name; 1946 void (*fn)(); 1947 int argc, i; 1948 long tmp; 1949 Tcl_Obj **argv; 1950 Tcl_DString usage, ds; 1951 Tcl_Command res; 1952 ffidl_cif *cif; 1953 ffidl_callout *callout; 1954 ffidl_client *client = (ffidl_client *)clientData; 1955 /* usage check */ 1956 if (objc != 5 && objc != 6) { 1957 Tcl_WrongNumArgs(interp, 1, objv, "name {?argument_type ...?} return_type address ?protocol?"); 1958 return TCL_ERROR; 1959 } 1960 /* fetch name */ 1961 Tcl_DStringInit(&ds); 1962 name = Tcl_GetString(objv[1]); 1963 if (!strstr(name, "::")) { 1964 Tcl_Namespace *ns; 1965 ns = Tcl_GetCurrentNamespace(interp); 1966 if (ns != Tcl_GetGlobalNamespace(interp)) { 1967 Tcl_DStringAppend(&ds, ns->fullName, -1); 1968 } 1969 Tcl_DStringAppend(&ds, "::", 2); 1970 Tcl_DStringAppend(&ds, name, -1); 1971 name = Tcl_DStringValue(&ds); 1972 } 1973 /* fetch cif */ 1974 if (cif_parse(interp, client, objv[2], objv[3], objc==5 ? NULL : objv[5], &cif, 0) == TCL_ERROR) return TCL_ERROR; 1975 /* fetch function pointer */ 1976 if (Tcl_GetLongFromObj(interp, objv[4], &tmp) == TCL_ERROR) return TCL_ERROR; 1977 fn = (void (*)())tmp; 1978 /* if callout is already defined, redefine it */ 1979 if ((callout = callout_lookup(client, name))) { 1980 Tcl_DeleteCommand(interp, name); 1981 } 1982 /* build the usage string */ 1983 Tcl_ListObjGetElements(interp, objv[2], &argc, &argv); 1984 Tcl_DStringInit(&usage); 1985 for (i = 0; i < argc; i += 1) { 1986 if (i != 0) Tcl_DStringAppend(&usage, " ", 1); 1987 Tcl_DStringAppend(&usage, Tcl_GetString(argv[i]), -1); 1988 } 1989 /* allocate the callout structure */ 1990 callout = (ffidl_callout *)Tcl_Alloc(sizeof(ffidl_callout)+Tcl_DStringLength(&usage)+1); 1991 if (callout == NULL) { 1992 Tcl_DStringFree(&usage); 1993 cif_dec_ref(cif); 1994 Tcl_AppendResult(interp, "can't allocate ffidl_callout for: ", name, NULL); 1995 return TCL_ERROR; 1996 } 1997 /* initialize the callout */ 1998 callout->cif = cif; 1999 callout->fn = fn; 2000 callout->client = client; 2001 strcpy(callout->usage, Tcl_DStringValue(&usage)); 2002 /* free the usage string */ 2003 Tcl_DStringFree(&usage); 2004 /* define the callout */ 2005 callout_define(client, name, callout); 2006 /* create the tcl command */ 2007 res = Tcl_CreateObjCommand(interp, name, tcl_ffidl_call, (ClientData) callout, callout_delete); 2008 Tcl_DStringFree(&ds); 2009 return (res ? TCL_OK : TCL_ERROR); 2010} 2011 2012#if USE_CALLBACKS 2013/* usage: ffidl-callback name {?argument_type ...?} return_type ?protocol? -> */ 2014static int tcl_ffidl_callback(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 2015{ 2016 char *name; 2017 ffidl_cif *cif; 2018 int tmp; 2019 Tcl_DString ds; 2020 ffidl_callback *callback; 2021 ffidl_client *client = (ffidl_client *)clientData; 2022 ffidl_closure *closure; 2023 /* usage check */ 2024 if (objc != 4 && objc != 5) { 2025 Tcl_WrongNumArgs(interp, 1, objv, "name {?argument_type ...?} return_type ?protocol?"); 2026 return TCL_ERROR; 2027 } 2028 /* fetch name */ 2029 Tcl_DStringInit(&ds); 2030 name = Tcl_GetString(objv[1]); 2031 if (!strstr(name, "::")) { 2032 Tcl_Namespace *ns; 2033 ns = Tcl_GetCurrentNamespace(interp); 2034 if (ns != Tcl_GetGlobalNamespace(interp)) { 2035 Tcl_DStringAppend(&ds, ns->fullName, -1); 2036 } 2037 Tcl_DStringAppend(&ds, "::", 2); 2038 Tcl_DStringAppend(&ds, name, -1); 2039 name = Tcl_DStringValue(&ds); 2040 } 2041 /* fetch cif */ 2042 if (cif_parse(interp, client, objv[2], objv[3], objc == 4 ? NULL : objv[4], &cif, 1) == TCL_ERROR) return TCL_ERROR; 2043 /* if callback is already defined, redefine it */ 2044 if ((callback = callback_lookup(client, name))) { 2045 cif_dec_ref(callback->cif); 2046 Tcl_DecrRefCount(callback->proc); 2047 Tcl_Free((void *)callback); 2048 } 2049 /* allocate the callback structure */ 2050 Tcl_ListObjLength(interp, objv[2], &tmp); 2051 callback = (ffidl_callback *)Tcl_Alloc(sizeof(ffidl_callback)+tmp*sizeof(Tcl_Obj *)); 2052 if (callback == NULL) { 2053 cif_dec_ref(cif); 2054 Tcl_AppendResult(interp, "can't allocate ffidl_callback for: ", name, NULL); 2055 return TCL_ERROR; 2056 } 2057 /* initialize the callback */ 2058 callback->cif = cif; 2059 callback->proc = Tcl_NewStringObj(name, -1); 2060 Tcl_IncrRefCount(callback->proc); 2061 2062 closure = &(callback->closure); 2063 closure->interp = interp; 2064 closure->callback = callback; 2065#if FFI_NATIVE_RAW_API 2066 if (cif->use_raw_api) { 2067 if (ffi_prep_raw_closure((ffi_raw_closure *)&closure->lib_closure, &callback->cif->lib_cif, 2068 (void (*)(ffi_cif*,void*,ffi_raw*,void*))callback_callback, 2069 (void *)closure) != FFI_OK) { 2070 Tcl_AppendResult(interp, "libffi can't make raw closure for: ", name, NULL); 2071 return TCL_ERROR; 2072 } 2073 } else 2074#endif 2075 if (ffi_prep_closure(&closure->lib_closure, &callback->cif->lib_cif, 2076 (void (*)(ffi_cif*,void*,void**,void*))callback_callback, 2077 (void *)closure) != FFI_OK) { 2078 Tcl_AppendResult(interp, "libffi can't make closure for: ", name, NULL); 2079 return TCL_ERROR; 2080 } 2081#endif 2082 /* define the callback */ 2083 callback_define(client, name, callback); 2084 Tcl_DStringFree(&ds); 2085 return TCL_OK; 2086} 2087/* usage: ffidl-symbol library symbol -> address */ 2088static int tcl_ffidl_symbol(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 2089{ 2090 char *library, *symbol, *native; 2091 const char *error; 2092 void *address; 2093 Tcl_DString ds; 2094 Tcl_DString newName; 2095 void *handle, *unload; 2096 ffidl_client *client = (ffidl_client *)clientData; 2097 2098 if (objc != 3) { 2099 Tcl_WrongNumArgs(interp,1,objv,"library symbol"); 2100 return TCL_ERROR; 2101 } 2102 2103 library = Tcl_GetString(objv[1]); 2104 handle = lib_lookup(client, library, NULL); 2105 2106 if (handle == NULL) { 2107 native = Tcl_UtfToExternalDString(NULL, library, -1, &ds); 2108 handle = ffidlopen(strlen(native)?native:NULL, &error); 2109 Tcl_DStringFree(&ds); 2110 if (handle == NULL) { 2111 Tcl_AppendResult(interp, "couldn't load file \"", library, "\" : ", error, (char *) NULL); 2112 return TCL_ERROR; 2113 } 2114 unload = NULL; 2115 lib_define(client, library, handle, unload); 2116 } 2117 2118 symbol = Tcl_GetString(objv[2]); 2119 native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); 2120 address = ffidlsym(handle, native, &error); 2121 if (error) { 2122 /* 2123 * Some platforms still add an underscore to the beginning of symbol 2124 * names. If we can't find a name without an underscore, try again 2125 * with the underscore. 2126 */ 2127 Tcl_DStringInit(&newName); 2128 Tcl_DStringAppend(&newName, "_", 1); 2129 native = Tcl_DStringAppend(&newName, native, -1); 2130 address = ffidlsym(handle, native, &error); 2131 Tcl_DStringFree(&newName); 2132 } 2133 Tcl_DStringFree(&ds); 2134 2135 if (error) { 2136 Tcl_AppendResult(interp, "couldn't find symbol \"", symbol, "\" : ", error, NULL); 2137 return TCL_ERROR; 2138 } 2139 2140 Tcl_SetObjResult(interp, Tcl_NewLongObj((long)address)); 2141 return TCL_OK; 2142} 2143/* usage: ffidl-stubsymbol library stubstable symbolnumber -> address */ 2144static int tcl_ffidl_stubsymbol(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) 2145{ 2146 int library, stubstable, symbolnumber; 2147 void **stubs = NULL, *address; 2148 static const char *library_names[] = { 2149 "tcl", 2150#ifdef LOOKUP_TK_STUBS 2151 "tk", 2152#endif 2153 NULL 2154 }; 2155 enum libraries { 2156 LIB_TCL, LIB_TK, 2157 }; 2158 static const char *stubstable_names[] = { 2159 "stubs", "intStubs", "platStubs", "intPlatStubs", "intXLibStubs", NULL 2160 }; 2161 enum stubstables { 2162 STUBS, INTSTUBS, PLATSTUBS, INTPLATSTUBS, INTXLIBSTUBS, 2163 }; 2164 2165 if (objc != 4) { 2166 Tcl_WrongNumArgs(interp,1,objv,"library stubstable symbolnumber"); 2167 return TCL_ERROR; 2168 } 2169 if (Tcl_GetIndexFromObj(interp, objv[1], library_names, "library", 0, &library) != TCL_OK) { 2170 return TCL_ERROR; 2171 } 2172 if (Tcl_GetIndexFromObj(interp, objv[2], stubstable_names, "stubstable", 0, &stubstable) != TCL_OK) { 2173 return TCL_ERROR; 2174 } 2175 if (Tcl_GetIntFromObj(interp, objv[3], &symbolnumber) != TCL_OK || symbolnumber < 0) { 2176 return TCL_ERROR; 2177 } 2178 2179#ifdef LOOKUP_TK_STUBS 2180 if (library == LIB_TK) { 2181 if (MyTkInitStubs(interp, TCL_VERSION, 0) == NULL) { 2182 return TCL_ERROR; 2183 } 2184 } 2185#endif 2186 switch (stubstable) { 2187 case STUBS: 2188 stubs = (void**)(library == LIB_TCL ? tclStubsPtr : tkStubsPtr); break; 2189 case INTSTUBS: 2190 stubs = (void**)(library == LIB_TCL ? tclIntStubsPtr : tkIntStubsPtr); break; 2191 case PLATSTUBS: 2192 stubs = (void**)(library == LIB_TCL ? tclPlatStubsPtr : tkPlatStubsPtr); break; 2193 case INTPLATSTUBS: 2194 stubs = (void**)(library == LIB_TCL ? tclIntPlatStubsPtr : tkIntPlatStubsPtr); break; 2195 case INTXLIBSTUBS: 2196 stubs = (void**)(library == LIB_TCL ? NULL : tkIntXlibStubsPtr); break; 2197 } 2198 2199 if (!stubs) { 2200 Tcl_AppendResult(interp, "no stubs table \"", Tcl_GetString(objv[2]), 2201 "\" in library \"", Tcl_GetString(objv[1]), "\"", NULL); 2202 return TCL_ERROR; 2203 } 2204 address = *(stubs + 2 + symbolnumber); 2205 if (!address) { 2206 Tcl_AppendResult(interp, "couldn't find symbol number ", Tcl_GetString(objv[3]), 2207 " in stubs table \"", Tcl_GetString(objv[2]), "\"", NULL); 2208 return TCL_ERROR; 2209 } 2210 2211 Tcl_SetObjResult(interp, Tcl_NewLongObj((long)address)); 2212 return TCL_OK; 2213} 2214 2215/* 2216 * One function exported for pointer punning with ffidl-callout. 2217 */ 2218void *ffidl_pointer_pun(void *p) { return p; } 2219 2220/* 2221 *-------------------------------------------------------------- 2222 * 2223 * Ffidl_Init 2224 * 2225 * Results: 2226 * None 2227 * 2228 * Side effects: 2229 * None 2230 * 2231 *-------------------------------------------------------------- 2232 */ 2233int Ffidl_Init(Tcl_Interp *interp) 2234{ 2235 ffidl_client *client; 2236 2237 if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { 2238 return TCL_ERROR; 2239 } 2240 if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) { 2241 return TCL_ERROR; 2242 } 2243 if (Tcl_PkgProvide(interp, "Ffidl", FFIDL_VERSION) != TCL_OK) { 2244 return TCL_ERROR; 2245 } 2246 2247 /* allocate and initialize client for this interpreter */ 2248 client = client_alloc(interp); 2249 2250 /* initialize commands */ 2251 Tcl_CreateObjCommand(interp,"::ffidl::info", tcl_ffidl_info, (ClientData) client, NULL); 2252 Tcl_CreateObjCommand(interp,"::ffidl::typedef", tcl_ffidl_typedef, (ClientData) client, NULL); 2253 Tcl_CreateObjCommand(interp,"::ffidl::symbol", tcl_ffidl_symbol, (ClientData) client, NULL); 2254 Tcl_CreateObjCommand(interp,"::ffidl::stubsymbol", tcl_ffidl_stubsymbol, (ClientData) client, NULL); 2255 Tcl_CreateObjCommand(interp,"::ffidl::callout", tcl_ffidl_callout, (ClientData) client, NULL); 2256#if USE_CALLBACKS 2257 Tcl_CreateObjCommand(interp,"::ffidl::callback", tcl_ffidl_callback, (ClientData) client, NULL); 2258#endif 2259 2260 /* determine Tcl_ObjType * for some types */ 2261 ffidl_bytearray_ObjType = Tcl_GetObjType("bytearray"); 2262 ffidl_int_ObjType = Tcl_GetObjType("int"); 2263#if HAVE_INT64 2264 ffidl_wideInt_ObjType = Tcl_GetObjType("wideInt"); 2265#endif 2266 ffidl_double_ObjType = Tcl_GetObjType("double"); 2267 2268 /* done */ 2269 return TCL_OK; 2270} 2271 2272#ifdef LOOKUP_TK_STUBS 2273typedef struct MyTkStubHooks { 2274 void *tkPlatStubs; 2275 void *tkIntStubs; 2276 void *tkIntPlatStubs; 2277 void *tkIntXlibStubs; 2278} MyTkStubHooks; 2279 2280typedef struct MyTkStubs { 2281 int magic; 2282 struct MyTkStubHooks *hooks; 2283} MyTkStubs; 2284 2285/* private copy of Tk_InitStubs to avoid having to depend on Tk at build time */ 2286static const char * 2287MyTkInitStubs(interp, version, exact) 2288 Tcl_Interp *interp; 2289 char *version; 2290 int exact; 2291{ 2292 const char *actualVersion; 2293 2294 actualVersion = Tcl_PkgRequireEx(interp, "Tk", version, exact, 2295 (ClientData *) &tkStubsPtr); 2296 if (!actualVersion) { 2297 return NULL; 2298 } 2299 2300 if (!tkStubsPtr) { 2301 Tcl_SetResult(interp, 2302 "This implementation of Tk does not support stubs", 2303 TCL_STATIC); 2304 return NULL; 2305 } 2306 2307 tkPlatStubsPtr = ((MyTkStubs*)tkStubsPtr)->hooks->tkPlatStubs; 2308 tkIntStubsPtr = ((MyTkStubs*)tkStubsPtr)->hooks->tkIntStubs; 2309 tkIntPlatStubsPtr = ((MyTkStubs*)tkStubsPtr)->hooks->tkIntPlatStubs; 2310 tkIntXlibStubsPtr = ((MyTkStubs*)tkStubsPtr)->hooks->tkIntXlibStubs; 2311 2312 return actualVersion; 2313} 2314#endif 2315