native/ffi.c — sigil-ffi

1/*

2 * Sigil Dynamic FFI

3 *

4 * Provides dynamic foreign function interface: dlopen/dlsym wrappers,

5 * type descriptors, value marshaling, and dyncall-based dispatch.

6 */

8#include <sigil/sigil.h>

9#include <stdio.h>

10#include <stdlib.h>

11#include <string.h>

12#include <errno.h>

14#ifdef _WIN32

15#include <windows.h>

16#else

17#include <dlfcn.h>

18#endif

20#include "dyncall.h"

21#include "dyncall_signature.h"

22#include "dyncall_callback.h"

23#include "dyncall_value.h"

25/* Forward declarations for sigil_apply variants */

26extern Value sigil_apply0(SigilVM *vm, Value proc);

27extern Value sigil_apply1(SigilVM *vm, Value proc, Value arg);

28extern Value sigil_apply2(SigilVM *vm, Value proc, Value arg1, Value arg2);

29extern Value sigil_apply3(SigilVM *vm, Value proc, Value arg1, Value arg2, Value arg3);

30extern Value sigil_applyN(SigilVM *vm, Value proc, int argc, Value *argv);

32/* ============================================================

33 * FFI Type System

34 * ============================================================ */

36enum FfiTypeId {

37 FFI_VOID,

38 FFI_BOOL,

39 FFI_INT8,

40 FFI_UINT8,

41 FFI_INT16,

42 FFI_UINT16,

43 FFI_INT32,

44 FFI_UINT32,

45 FFI_INT64,

46 FFI_UINT64,

47 FFI_FLOAT,

48 FFI_DOUBLE,

49 FFI_POINTER,

50 FFI_STRING,

51 FFI_INT,

52 FFI_UINT,

53 FFI_LONG,

54 FFI_ULONG,

55 FFI_SIZE_T,

56 FFI_AGGREGATE,

57 FFI_TYPE_COUNT

58};

60/* Register class for dispatch */

61enum FfiRegClass {

62 REG_INT, /* intptr_t - integers, pointers, bool */

63 REG_FLOAT, /* float */

64 REG_DOUBLE, /* double */

65 REG_STRUCT /* aggregate (reserved for future use) */

66};

68typedef struct {

69 enum FfiRegClass reg_class;

70 size_t size;

71 size_t alignment;

72} FfiTypeInfo;

74static const FfiTypeInfo ffi_type_info[FFI_TYPE_COUNT] = {

75 [FFI_VOID] = { REG_INT, 0, 1 },

76 [FFI_BOOL] = { REG_INT, sizeof(_Bool), sizeof(_Bool) },

77 [FFI_INT8] = { REG_INT, 1, 1 },

78 [FFI_UINT8] = { REG_INT, 1, 1 },

79 [FFI_INT16] = { REG_INT, 2, 2 },

80 [FFI_UINT16] = { REG_INT, 2, 2 },

81 [FFI_INT32] = { REG_INT, 4, 4 },

82 [FFI_UINT32] = { REG_INT, 4, 4 },

83 [FFI_INT64] = { REG_INT, 8, 8 },

84 [FFI_UINT64] = { REG_INT, 8, 8 },

85 [FFI_FLOAT] = { REG_FLOAT, sizeof(float), sizeof(float) },

86 [FFI_DOUBLE] = { REG_DOUBLE, sizeof(double), sizeof(double) },

87 [FFI_POINTER] = { REG_INT, sizeof(void *), sizeof(void *) },

88 [FFI_STRING] = { REG_INT, sizeof(void *), sizeof(void *) },

89 [FFI_INT] = { REG_INT, sizeof(int), sizeof(int) },

90 [FFI_UINT] = { REG_INT, sizeof(unsigned), sizeof(unsigned) },

91 [FFI_LONG] = { REG_INT, sizeof(long), sizeof(long) },

92 [FFI_ULONG] = { REG_INT, sizeof(unsigned long), sizeof(unsigned long) },

93 [FFI_SIZE_T] = { REG_INT, sizeof(size_t), sizeof(size_t) },

94 [FFI_AGGREGATE] = { REG_STRUCT, 0, 0 },

95};

97/* ============================================================

98 * Foreign Object Types

99 * ============================================================ */

100

101static Value ffi_library_type_tag = SIGIL_UNDEFINED;

102static Value ffi_pointer_type_tag = SIGIL_UNDEFINED;

103static Value ffi_function_type_tag = SIGIL_UNDEFINED;

104

105/* Library handle */

106typedef struct {

107 void *handle;

108 char *name;

109 int closed;

110} FfiLibrary;

111

112/* Bound function descriptor */

113#define FFI_MAX_ARGS 8

114

115/* Aggregate (struct) field descriptor */

116#define FFI_MAX_STRUCT_FIELDS 32

117

118typedef struct {

119 int field_count;

120 int field_types[FFI_MAX_STRUCT_FIELDS];

121 int field_offsets[FFI_MAX_STRUCT_FIELDS];

122 int struct_size;

123 DCaggr *dc_aggr;

124} FfiAggregate;

125

126typedef struct {

127 void *fn_ptr;

128 int arg_count;

129 int arg_types[FFI_MAX_ARGS];

130 int ret_type;

131 FfiAggregate *arg_aggrs[FFI_MAX_ARGS]; /* non-NULL for struct-by-value args */

132 FfiAggregate *ret_aggr; /* non-NULL for struct-by-value return */

133} FfiFunction;

134

135/* ============================================================

136 * Global dyncall VM

137 * ============================================================ */

138

139/* Global dyncall VM for FFI calls. Created on first use. */

140static DCCallVM *dc_vm = NULL;

141

142static DCCallVM *get_dc_vm(void)

143{

144 if (!dc_vm) {

145 dc_vm = dcNewCallVM(4096);

146 dcMode(dc_vm, DC_CALL_C_DEFAULT);

147 }

148 return dc_vm;

149}

150

151/* Map FFI type to dyncall sigchar for aggregate field descriptors */

152static DCsigchar ffi_type_to_dc_sigchar(int type_id)

153{

154 switch (type_id) {

155 case FFI_BOOL: return DC_SIGCHAR_BOOL;

156 case FFI_INT8: return DC_SIGCHAR_CHAR;

157 case FFI_UINT8: return DC_SIGCHAR_UCHAR;

158 case FFI_INT16: return DC_SIGCHAR_SHORT;

159 case FFI_UINT16: return DC_SIGCHAR_USHORT;

160 case FFI_INT32:

161 case FFI_INT: return DC_SIGCHAR_INT;

162 case FFI_UINT32:

163 case FFI_UINT: return DC_SIGCHAR_UINT;

164 case FFI_INT64:

165 case FFI_LONG: return DC_SIGCHAR_LONGLONG;

166 case FFI_UINT64:

167 case FFI_ULONG:

168 case FFI_SIZE_T: return DC_SIGCHAR_ULONGLONG;

169 case FFI_FLOAT: return DC_SIGCHAR_FLOAT;

170 case FFI_DOUBLE: return DC_SIGCHAR_DOUBLE;

171 case FFI_POINTER:

172 case FFI_STRING: return DC_SIGCHAR_POINTER;

173 default: return DC_SIGCHAR_INT;

174 }

175}

176

177/* Create a DCaggr from a Scheme struct layout list.

178 * Layout format: (size max-align ((field-name field-type offset) ...)) */

179static FfiAggregate *create_aggregate_from_layout(SigilVM *vm, Value layout)

180{

181 if (!sigil_is_pair(layout)) return NULL;

182

183 int struct_size = (int)sigil_as_fixnum(sigil_car(layout));

184 /* Skip max-align (cadr) */

185 Value fields_list = sigil_car(sigil_cdr(sigil_cdr(layout)));

186

187 /* Count fields */

188 int field_count = 0;

189 Value tmp = fields_list;

190 while (sigil_is_pair(tmp)) {

191 field_count++;

192 tmp = sigil_cdr(tmp);

193 }

194

195 if (field_count > FFI_MAX_STRUCT_FIELDS) {

196 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

197 "c-function: struct has too many fields (max %d)", FFI_MAX_STRUCT_FIELDS);

198 return NULL;

199 }

200

201 FfiAggregate *aggr = malloc(sizeof(FfiAggregate));

202 if (!aggr) return NULL;

203

204 aggr->field_count = field_count;

205 aggr->struct_size = struct_size;

206 aggr->dc_aggr = dcNewAggr(field_count, struct_size);

207

208 tmp = fields_list;

209 for (int i = 0; i < field_count; i++) {

210 Value field = sigil_car(tmp);

211 /* field = (field-name field-type offset) */

212 Value field_type_val = sigil_car(sigil_cdr(field));

213 Value field_offset_val = sigil_car(sigil_cdr(sigil_cdr(field)));

214

215 int ftype = (int)sigil_as_fixnum(field_type_val);

216 int foffset = (int)sigil_as_fixnum(field_offset_val);

217

218 aggr->field_types[i] = ftype;

219 aggr->field_offsets[i] = foffset;

220

221 dcAggrField(aggr->dc_aggr, ffi_type_to_dc_sigchar(ftype), foffset, 1);

222 tmp = sigil_cdr(tmp);

223 }

224

225 dcCloseAggr(aggr->dc_aggr);

226 return aggr;

227}

228

229static void free_aggregate(FfiAggregate *aggr)

230{

231 if (aggr) {

232 if (aggr->dc_aggr) dcFreeAggr(aggr->dc_aggr);

233 free(aggr);

234 }

235}

236

237/* ============================================================

238 * Type Helpers

239 * ============================================================ */

240

241static int is_valid_ffi_type(int type_id)

242{

243 return type_id >= 0 && type_id < FFI_TYPE_COUNT;

244}

245

246static int is_ffi_library(Value v)

247{

248 if (!sigil_is_foreign(v)) return 0;

249 return sigil_foreign_type(v) == ffi_library_type_tag;

250}

251

252static int is_ffi_pointer(Value v)

253{

254 if (!sigil_is_foreign(v)) return 0;

255 return sigil_foreign_type(v) == ffi_pointer_type_tag;

256}

257

258static int is_ffi_function(Value v)

259{

260 if (!sigil_is_foreign(v)) return 0;

261 return sigil_foreign_type(v) == ffi_function_type_tag;

262}

263

264static FfiLibrary *as_library(Value v)

265{

266 return (FfiLibrary *)sigil_foreign_data(v);

267}

268

269static FfiFunction *as_function(Value v)

270{

271 return (FfiFunction *)sigil_foreign_data(v);

272}

273

274/* Get raw pointer from an ffi-pointer foreign object.

275 * The raw address is stored directly as the data pointer. */

276static void *as_pointer(Value v)

277{

278 return sigil_foreign_data(v);

279}

280

281/* Make an ffi-pointer Value. NULL maps to SIGIL_FALSE. */

282static Value make_ffi_pointer(SigilVM *vm, void *addr)

283{

284 if (addr == NULL) return SIGIL_FALSE;

285 return sigil_make_foreign(vm, ffi_pointer_type_tag, addr, NULL, 0);

286}

287

288/* Extract a null-terminated C string from a Sigil string. Caller must free. */

289static char *extract_cstring(Value v)

290{

291 SigilString *s = (SigilString *)sigil_as_ptr(v);

292 char *result = malloc(s->byte_length + 1);

293 if (!result) return NULL;

294 memcpy(result, s->data, s->byte_length);

295 result[s->byte_length] = '\0';

296 return result;

297}

298

299/* ============================================================

300 * Platform Abstraction: dlopen/dlsym

301 * ============================================================ */

302

303#ifndef _WIN32

304/* Try dlopen with a specific path */

305static void *try_dlopen(const char *path)

306{

307 return dlopen(path, RTLD_NOW | RTLD_LOCAL);

308}

309

310/* Try to parse a GNU ld linker script and dlopen the first library it

311 * references. Linker scripts are text files like:

312 * GROUP ( /path/to/libfoo.so.6 AS_NEEDED ( ... ) )

313 * dlopen can't read these, but we can extract the real path. */

314static void *try_linker_script(const char *path)

315{

316 FILE *f = fopen(path, "r");

317 if (!f) return NULL;

318

319 /* Read first 512 bytes — linker scripts are small */

320 char buf[512];

321 size_t n = fread(buf, 1, sizeof(buf) - 1, f);

322 fclose(f);

323 buf[n] = '\0';

324

325 /* Must start with a comment or linker directive */

326 if (n < 10 || (buf[0] != '/' && buf[0] != 'G' && buf[0] != 'O'

327 && buf[0] != 'I'))

328 return NULL;

329

330 /* Look for GROUP or INPUT directive followed by ( path ) */

331 char *group = strstr(buf, "GROUP");

332 if (!group) group = strstr(buf, "INPUT");

333 if (!group) return NULL;

334

335 /* Find the opening paren */

336 char *paren = strchr(group, '(');

337 if (!paren) return NULL;

338 paren++;

339

340 /* Skip whitespace to find the first library path */

341 while (*paren == ' ' || *paren == '\t' || *paren == '\n') paren++;

342 if (!*paren) return NULL;

343

344 /* Extract the path (ends at whitespace or ')') */

345 char libpath[256];

346 int i = 0;

347 while (*paren && *paren != ' ' && *paren != '\t' && *paren != '\n'

348 && *paren != ')' && i < (int)sizeof(libpath) - 1) {

349 libpath[i++] = *paren++;

350 }

351 libpath[i] = '\0';

352

353 if (i == 0) return NULL;

354 return try_dlopen(libpath);

355}

356

357/* Search LIBRARY_PATH directories for a library.

358 * dlopen uses LD_LIBRARY_PATH but not LIBRARY_PATH, which is set by

359 * Guix and other package managers for compile-time linking. We also

360 * search LIBRARY_PATH at runtime so FFI users don't need to set

361 * LD_LIBRARY_PATH manually. */

362static void *search_library_path(const char *name)

363{

364 const char *lib_path = getenv("LIBRARY_PATH");

365 if (!lib_path || !*lib_path) return NULL;

366

367 /* Names to try: as-is, with .so/.dylib suffix */

368 const char *suffixes[3];

369 int nsuf = 0;

370 suffixes[nsuf++] = "";

371 if (!strchr(name, '.')) {

372#ifdef __APPLE__

373 suffixes[nsuf++] = ".dylib";

374#else

375 suffixes[nsuf++] = ".so";

376#endif

377 }

378

379 /* Walk colon-separated paths */

380 char pathbuf[512];

381 const char *p = lib_path;

382 while (*p) {

383 const char *end = strchr(p, ':');

384 size_t dirlen = end ? (size_t)(end - p) : strlen(p);

385 if (dirlen > 0 && dirlen < sizeof(pathbuf) - 128) {

386 for (int i = 0; i < nsuf; i++) {

387 snprintf(pathbuf, sizeof(pathbuf), "%.*s/%s%s",

388 (int)dirlen, p, name, suffixes[i]);

389 void *handle = try_dlopen(pathbuf);

390 if (handle) return handle;

391 /* If dlopen failed, the .so might be a linker script */

392 handle = try_linker_script(pathbuf);

393 if (handle) return handle;

394 }

395 }

396 if (!end) break;

397 p = end + 1;

398 }

399 return NULL;

400}

401#endif /* !_WIN32 */

402

403static void *ffi_open_library(const char *name)

404{

405#ifdef _WIN32

406 if (name == NULL) return (void *)GetModuleHandle(NULL);

407 return (void *)LoadLibraryA(name);

408#else

409 if (name == NULL)

410 return dlopen(NULL, RTLD_NOW | RTLD_LOCAL);

411

412 /* Try the name as given first */

413 void *handle = try_dlopen(name);

414 if (handle) return handle;

415

416 /* If dlopen failed, the file might be a GNU ld linker script */

417 handle = try_linker_script(name);

418 if (handle) return handle;

419

420 /* If the name has no extension, try platform-specific suffixes */

421 if (!strchr(name, '.')) {

422 char buf[256];

423#ifdef __APPLE__

424 snprintf(buf, sizeof(buf), "%s.dylib", name);

425#else

426 snprintf(buf, sizeof(buf), "%s.so", name);

427#endif

428 handle = try_dlopen(buf);

429 if (handle) return handle;

430 /* The .so might be a linker script pointing to .so.N */

431 handle = try_linker_script(buf);

432 if (handle) return handle;

433 }

434

435 /* Fall back to searching LIBRARY_PATH (set by Guix, Nix, etc.) */

436 handle = search_library_path(name);

437 if (handle) return handle;

438

439 return NULL;

440#endif

441}

442

443static void ffi_close_library(void *handle)

444{

445#ifdef _WIN32

446 FreeLibrary((HMODULE)handle);

447#else

448 dlclose(handle);

449#endif

450}

451

452static void *ffi_lookup_symbol(void *handle, const char *name)

453{

454#ifdef _WIN32

455 return (void *)GetProcAddress((HMODULE)handle, name);

456#else

457 return dlsym(handle, name);

458#endif

459}

460

461static const char *ffi_last_error(void)

462{

463#ifdef _WIN32

464 static char buf[256];

465 FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),

466 0, buf, sizeof(buf), NULL);

467 return buf;

468#else

469 return dlerror();

470#endif

471}

472

473/* ============================================================

474 * Finalizers

475 * ============================================================ */

476

477static void library_finalizer(void *data)

478{

479 FfiLibrary *lib = (FfiLibrary *)data;

480 if (lib) {

481 /* Deliberately do NOT dlclose here. Unloading a shared library

482 * when its handle object is garbage-collected is unsound: the GC

483 * only knows the handle is unreachable, not whether the program

484 * (or C code acting on its behalf) still holds raw pointers into

485 * the library - c-function fn_ptrs, callbacks registered with C

486 * event loops (GLib main-context sources, signal handlers),

487 * atexit handlers, static data. dlclose on collection unmapped

488 * libgtk-4 out from under a live GMainContext and crashed the

489 * next g_main_context_iteration (dev-bundle builds collect dead

490 * locals promptly, so a let-bound handle died while its library

491 * was still in use). Every mainstream FFI (Python ctypes, JNA,

492 * Guile) keeps libraries mapped until process exit for the same

493 * reason. Explicit c-library-close remains available for callers

494 * who KNOW nothing references the library. */

495 free(lib->name);

496 free(lib);

497 }

498}

499

500static void function_finalizer(void *data)

501{

502 FfiFunction *func = (FfiFunction *)data;

503 if (func) {

504 for (int i = 0; i < func->arg_count; i++) {

505 free_aggregate(func->arg_aggrs[i]);

506 }

507 free_aggregate(func->ret_aggr);

508 free(func);

509 }

510}

511

512/* ============================================================

513 * Value Marshaling: Scheme -> C

514 * ============================================================ */

515

516static intptr_t marshal_to_int(SigilVM *vm, Value v, int ffi_type)

517{

518 (void)vm;

519 switch (ffi_type) {

520 case FFI_BOOL:

521 return sigil_is_truthy(v) ? 1 : 0;

522

523 case FFI_INT8:

524 if (sigil_is_fixnum(v)) return (int8_t)sigil_as_fixnum(v);

525 if (sigil_is_flonum(v)) return (int8_t)(int64_t)sigil_as_flonum(v);

526 return 0;

527

528 case FFI_UINT8:

529 if (sigil_is_fixnum(v)) return (uint8_t)sigil_as_fixnum(v);

530 if (sigil_is_flonum(v)) return (uint8_t)(uint64_t)sigil_as_flonum(v);

531 return 0;

532

533 case FFI_INT16:

534 if (sigil_is_fixnum(v)) return (int16_t)sigil_as_fixnum(v);

535 if (sigil_is_flonum(v)) return (int16_t)(int64_t)sigil_as_flonum(v);

536 return 0;

537

538 case FFI_UINT16:

539 if (sigil_is_fixnum(v)) return (uint16_t)sigil_as_fixnum(v);

540 if (sigil_is_flonum(v)) return (uint16_t)(uint64_t)sigil_as_flonum(v);

541 return 0;

542

543 case FFI_INT32:

544 case FFI_INT:

545 if (sigil_is_fixnum(v)) return (int32_t)sigil_as_fixnum(v);

546 if (sigil_is_flonum(v)) return (int32_t)(int64_t)sigil_as_flonum(v);

547 return 0;

548

549 case FFI_UINT32:

550 case FFI_UINT:

551 if (sigil_is_fixnum(v)) return (uint32_t)sigil_as_fixnum(v);

552 if (sigil_is_flonum(v)) return (uint32_t)(uint64_t)sigil_as_flonum(v);

553 return 0;

554

555 case FFI_INT64:

556 case FFI_LONG:

557 if (sigil_is_fixnum(v)) return (intptr_t)sigil_as_fixnum(v);

558 if (sigil_is_flonum(v)) return (intptr_t)(int64_t)sigil_as_flonum(v);

559 return 0;

560

561 case FFI_UINT64:

562 case FFI_ULONG:

563 case FFI_SIZE_T:

564 if (sigil_is_fixnum(v)) return (intptr_t)(uint64_t)sigil_as_fixnum(v);

565 if (sigil_is_flonum(v)) return (intptr_t)(uint64_t)sigil_as_flonum(v);

566 return 0;

567

568 case FFI_POINTER:

569 if (v == SIGIL_FALSE) return 0; /* null pointer */

570 if (is_ffi_pointer(v)) return (intptr_t)as_pointer(v);

571 if (sigil_is_bytevector(v)) {

572 return (intptr_t)sigil_bytevector_data(v);

573 }

574 return 0;

575

576 case FFI_STRING:

577 if (v == SIGIL_FALSE) return 0;

578 if (sigil_is_string(v)) {

579 /* Caller is responsible for freeing temporary strings */

580 return (intptr_t)extract_cstring(v);

581 }

582 if (is_ffi_pointer(v)) return (intptr_t)as_pointer(v);

583 return 0;

584

585 default:

586 return 0;

587 }

588}

589

590static float marshal_to_float(SigilVM *vm, Value v)

591{

592 (void)vm;

593 if (sigil_is_flonum(v)) return (float)sigil_as_flonum(v);

594 if (sigil_is_fixnum(v)) return (float)sigil_as_fixnum(v);

595 return 0.0f;

596}

597

598static double marshal_to_double(SigilVM *vm, Value v)

599{

600 (void)vm;

601 if (sigil_is_flonum(v)) return sigil_as_flonum(v);

602 if (sigil_is_fixnum(v)) return (double)sigil_as_fixnum(v);

603 return 0.0;

604}

605

606/* ============================================================

607 * Dyncall Dispatch: ffi-call

608 * ============================================================

609 *

610 * Marshals Scheme args to C types via the dyncall VM, calls the

611 * foreign function, and marshals the return value back to Scheme.

612 */

613

614static Value ffi_dispatch(SigilVM *vm, FfiFunction *func, int argc, Value *args)

615{

616 if (argc != func->arg_count) {

617 sigil__vm_error(vm, SIGIL_ERR_ARITY,

618 "ffi-call: expected %d arguments, got %d", func->arg_count, argc);

619 return SIGIL_UNDEFINED;

620 }

621

622 DCCallVM *dvm = get_dc_vm();

623 dcReset(dvm);

624

625 /* Track temporary allocations for cleanup */

626 char *temp_strings[FFI_MAX_ARGS];

627 int temp_string_count = 0;

628 void *temp_structs[FFI_MAX_ARGS];

629 int temp_struct_count = 0;

630 memset(temp_strings, 0, sizeof(temp_strings));

631 memset(temp_structs, 0, sizeof(temp_structs));

632

633 /* For aggregate returns, signal dyncall before pushing args */

634 if (func->ret_type == FFI_AGGREGATE && func->ret_aggr) {

635 dcBeginCallAggr(dvm, func->ret_aggr->dc_aggr);

636 }

637

638 /* Push arguments to dyncall VM */

639 for (int i = 0; i < argc; i++) {

640 int type = func->arg_types[i];

641

642 /* Handle aggregate (struct-by-value) args */

643 if (type == FFI_AGGREGATE && func->arg_aggrs[i]) {

644 FfiAggregate *aggr = func->arg_aggrs[i];

645 /* The Scheme arg should be a pointer to pre-marshaled struct data */

646 void *struct_data = NULL;

647 if (is_ffi_pointer(args[i])) {

648 struct_data = as_pointer(args[i]);

649 } else {

650 sigil__vm_error(vm, SIGIL_ERR_TYPE,

651 "ffi-call: expected pointer for struct-by-value argument %d", i);

652 goto cleanup;

653 }

654 dcArgAggr(dvm, aggr->dc_aggr, struct_data);

655 continue;

656 }

657

658 switch (ffi_type_info[type].reg_class) {

659 case REG_INT: {

660 intptr_t val = marshal_to_int(vm, args[i], type);

661 if (type == FFI_STRING && sigil_is_string(args[i])) {

662 temp_strings[temp_string_count++] = (char *)val;

663 }

664 /* Use appropriate dyncall arg function based on actual type */

665 switch (type) {

666 case FFI_BOOL:

667 dcArgBool(dvm, (DCbool)val);

668 break;

669 case FFI_INT8:

670 dcArgChar(dvm, (DCchar)val);

671 break;

672 case FFI_UINT8:

673 dcArgChar(dvm, (DCchar)(unsigned char)val);

674 break;

675 case FFI_INT16:

676 dcArgShort(dvm, (DCshort)val);

677 break;

678 case FFI_UINT16:

679 dcArgShort(dvm, (DCshort)(unsigned short)val);

680 break;

681 case FFI_INT32:

682 case FFI_INT:

683 dcArgInt(dvm, (DCint)val);

684 break;

685 case FFI_UINT32:

686 case FFI_UINT:

687 dcArgInt(dvm, (DCint)(uint32_t)val);

688 break;

689 case FFI_INT64:

690 case FFI_LONG:

691 dcArgLongLong(dvm, (DClonglong)val);

692 break;

693 case FFI_UINT64:

694 case FFI_ULONG:

695 case FFI_SIZE_T:

696 dcArgLongLong(dvm, (DClonglong)(uint64_t)val);

697 break;

698 case FFI_POINTER:

699 case FFI_STRING:

700 dcArgPointer(dvm, (DCpointer)val);

701 break;

702 default:

703 dcArgLong(dvm, (DClong)val);

704 break;

705 }

706 break;

707 }

708 case REG_FLOAT:

709 dcArgFloat(dvm, marshal_to_float(vm, args[i]));

710 break;

711 case REG_DOUBLE:

712 dcArgDouble(dvm, marshal_to_double(vm, args[i]));

713 break;

714 default:

715 break;

716 }

717 }

718

719 /* Call and marshal return value */

720 Value result = SIGIL_UNDEFINED;

721 void *fn = func->fn_ptr;

722 int ret = func->ret_type;

723

724 if (ret == FFI_AGGREGATE && func->ret_aggr) {

725 /* Aggregate return: allocate buffer, call, return as pointer */

726 void *ret_buf = malloc(func->ret_aggr->struct_size);

727 if (!ret_buf) {

728 sigil__vm_error(vm, SIGIL_ERR_MEMORY, "ffi-call: out of memory for struct return");

729 goto cleanup;

730 }

731 dcCallAggr(dvm, fn, func->ret_aggr->dc_aggr, ret_buf);

732 result = make_ffi_pointer(vm, ret_buf);

733 } else if (ret == FFI_VOID) {

734 dcCallVoid(dvm, fn);

735 result = SIGIL_UNDEFINED;

736 } else {

737 switch (ffi_type_info[ret].reg_class) {

738 case REG_INT:

739 switch (ret) {

740 case FFI_BOOL:

741 result = sigil_bool(dcCallBool(dvm, fn));

742 break;

743 case FFI_INT8:

744 result = sigil_fixnum((int8_t)dcCallChar(dvm, fn));

745 break;

746 case FFI_UINT8:

747 result = sigil_fixnum((uint8_t)(unsigned char)dcCallChar(dvm, fn));

748 break;

749 case FFI_INT16:

750 result = sigil_fixnum((int16_t)dcCallShort(dvm, fn));

751 break;

752 case FFI_UINT16:

753 result = sigil_fixnum((uint16_t)(unsigned short)dcCallShort(dvm, fn));

754 break;

755 case FFI_INT32:

756 case FFI_INT:

757 result = sigil_fixnum(dcCallInt(dvm, fn));

758 break;

759 case FFI_UINT32:

760 case FFI_UINT:

761 result = sigil_fixnum((uint32_t)(unsigned int)dcCallInt(dvm, fn));

762 break;

763 case FFI_INT64:

764 case FFI_LONG: {

765 int64_t v = (int64_t)dcCallLongLong(dvm, fn);

766 if (v >= SIGIL_FIXNUM_MIN && v <= SIGIL_FIXNUM_MAX)

767 result = sigil_fixnum(v);

768 else

769 result = sigil_flonum((double)v);

770 break;

771 }

772 case FFI_UINT64:

773 case FFI_ULONG:

774 case FFI_SIZE_T: {

775 uint64_t v = (uint64_t)dcCallLongLong(dvm, fn);

776 if (v <= (uint64_t)SIGIL_FIXNUM_MAX)

777 result = sigil_fixnum((int64_t)v);

778 else

779 result = sigil_flonum((double)v);

780 break;

781 }

782 case FFI_POINTER:

783 result = make_ffi_pointer(vm, dcCallPointer(dvm, fn));

784 break;

785 case FFI_STRING: {

786 char *s = (char *)dcCallPointer(dvm, fn);

787 if (!s)

788 result = SIGIL_FALSE;

789 else

790 result = sigil_make_string(vm, s, strlen(s));

791 break;

792 }

793 default:

794 result = sigil_fixnum(dcCallInt(dvm, fn));

795 break;

796 }

797 break;

798 case REG_FLOAT:

799 result = sigil_flonum((double)dcCallFloat(dvm, fn));

800 break;

801 case REG_DOUBLE:

802 result = sigil_flonum(dcCallDouble(dvm, fn));

803 break;

804 default:

805 break;

806 }

807 }

808

809cleanup:

810 /* Free temporary strings */

811 for (int i = 0; i < temp_string_count; i++) {

812 free(temp_strings[i]);

813 }

814 /* Free temporary struct buffers */

815 for (int i = 0; i < temp_struct_count; i++) {

816 free(temp_structs[i]);

817 }

818

819 return result;

820}

821

822/* ============================================================

823 * Native Functions

824 * ============================================================ */

825

826/* %ffi-open-library name -> library */

827static Value native_ffi_open_library(SigilVM *vm, int argc, Value *args)

828{

829 (void)argc;

830

831 const char *name = NULL;

832 char *name_buf = NULL;

833

834 if (sigil_is_string(args[0])) {

835 name_buf = extract_cstring(args[0]);

836 name = name_buf;

837 } else if (args[0] != SIGIL_FALSE) {

838 sigil__vm_error(vm, SIGIL_ERR_TYPE,

839 "c-library: expected string or #f, got %s",

840 sigil_is_fixnum(args[0]) ? "integer" : "non-string");

841 return SIGIL_UNDEFINED;

842 }

843 /* If args[0] is #f, name stays NULL (opens current process) */

844

845 void *handle = ffi_open_library(name);

846 if (!handle) {

847 const char *err = ffi_last_error();

848 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

849 "c-library: cannot load \"%s\": %s",

850 name ? name : "(current process)", err ? err : "unknown error");

851 free(name_buf);

852 return SIGIL_UNDEFINED;

853 }

854

855 FfiLibrary *lib = malloc(sizeof(FfiLibrary));

856 if (!lib) {

857 ffi_close_library(handle);

858 free(name_buf);

859 sigil__vm_error(vm, SIGIL_ERR_MEMORY, "c-library: out of memory");

860 return SIGIL_UNDEFINED;

861 }

862

863 lib->handle = handle;

864 lib->name = name_buf; /* Transfer ownership */

865 lib->closed = 0;

866

867 return sigil_make_foreign(vm, ffi_library_type_tag, lib,

868 library_finalizer, sizeof(FfiLibrary));

869}

870

871/* %ffi-close-library lib -> void */

872static Value native_ffi_close_library(SigilVM *vm, int argc, Value *args)

873{

874 (void)argc;

875

876 if (!is_ffi_library(args[0])) {

877 sigil__vm_error(vm, SIGIL_ERR_TYPE,

878 "c-library-close: expected library handle");

879 return SIGIL_UNDEFINED;

880 }

881

882 FfiLibrary *lib = as_library(args[0]);

883 if (!lib->closed) {

884 ffi_close_library(lib->handle);

885 lib->closed = 1;

886 }

887

888 return SIGIL_UNDEFINED;

889}

890

891/* %ffi-lookup-symbol lib name -> pointer */

892static Value native_ffi_lookup_symbol(SigilVM *vm, int argc, Value *args)

893{

894 (void)argc;

895

896 if (!is_ffi_library(args[0])) {

897 sigil__vm_error(vm, SIGIL_ERR_TYPE,

898 "c-symbol: expected library handle");

899 return SIGIL_UNDEFINED;

900 }

901 if (!sigil_is_string(args[1])) {

902 sigil__vm_error(vm, SIGIL_ERR_TYPE,

903 "c-symbol: expected string for symbol name");

904 return SIGIL_UNDEFINED;

905 }

906

907 FfiLibrary *lib = as_library(args[0]);

908 if (lib->closed) {

909 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

910 "c-symbol: library is closed");

911 return SIGIL_UNDEFINED;

912 }

913

914 char *sym_name = extract_cstring(args[1]);

915 void *sym = ffi_lookup_symbol(lib->handle, sym_name);

916 free(sym_name);

917

918 if (!sym) return SIGIL_FALSE;

919 return make_ffi_pointer(vm, sym);

920}

921

922/* %ffi-bind-function lib name arg-types ret-type -> ffi-function */

923static Value native_ffi_bind_function(SigilVM *vm, int argc, Value *args)

924{

925 (void)argc;

926

927 if (!is_ffi_library(args[0])) {

928 sigil__vm_error(vm, SIGIL_ERR_TYPE,

929 "c-function: expected library handle");

930 return SIGIL_UNDEFINED;

931 }

932 if (!sigil_is_string(args[1])) {

933 sigil__vm_error(vm, SIGIL_ERR_TYPE,

934 "c-function: expected string for function name");

935 return SIGIL_UNDEFINED;

936 }

937

938 FfiLibrary *lib = as_library(args[0]);

939 if (lib->closed) {

940 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

941 "c-function: library is closed");

942 return SIGIL_UNDEFINED;

943 }

944

945 /* Look up the symbol */

946 char *func_name = extract_cstring(args[1]);

947 void *fn_ptr = ffi_lookup_symbol(lib->handle, func_name);

948 if (!fn_ptr) {

949 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

950 "c-function: symbol \"%s\" not found in library \"%s\"",

951 func_name, lib->name ? lib->name : "(current process)");

952 free(func_name);

953 return SIGIL_UNDEFINED;

954 }

955 free(func_name);

956

957 /* Parse argument types from list.

958 * Each element is either a fixnum (primitive FFI type) or a list

959 * (struct layout for aggregate by-value passing). */

960 int arg_count = 0;

961 int arg_types[FFI_MAX_ARGS];

962 FfiAggregate *arg_aggrs[FFI_MAX_ARGS];

963 Value arg_layouts[FFI_MAX_ARGS]; /* save layout values for struct args */

964 Value arg_list = args[2];

965

966 memset(arg_aggrs, 0, sizeof(arg_aggrs));

967

968 while (sigil_is_pair(arg_list)) {

969 if (arg_count >= FFI_MAX_ARGS) {

970 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

971 "c-function: too many arguments (max %d)", FFI_MAX_ARGS);

972 return SIGIL_UNDEFINED;

973 }

974 Value type_val = sigil_car(arg_list);

975 if (sigil_is_fixnum(type_val)) {

976 /* Primitive type */

977 int type_id = (int)sigil_as_fixnum(type_val);

978 if (!is_valid_ffi_type(type_id) || type_id == FFI_VOID) {

979 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

980 "c-function: invalid argument type %d", type_id);

981 return SIGIL_UNDEFINED;

982 }

983 arg_types[arg_count] = type_id;

984 arg_layouts[arg_count] = SIGIL_FALSE;

985 } else if (sigil_is_pair(type_val)) {

986 /* Struct layout — create aggregate descriptor */

987 FfiAggregate *aggr = create_aggregate_from_layout(vm, type_val);

988 if (!aggr) return SIGIL_UNDEFINED;

989 arg_types[arg_count] = FFI_AGGREGATE;

990 arg_aggrs[arg_count] = aggr;

991 arg_layouts[arg_count] = type_val;

992 } else {

993 sigil__vm_error(vm, SIGIL_ERR_TYPE,

994 "c-function: argument type must be an FFI type constant or struct layout");

995 return SIGIL_UNDEFINED;

996 }

997 arg_count++;

998 arg_list = sigil_cdr(arg_list);

999 }

1000

1001 /* Return type — fixnum for primitive, list for struct layout */

1002 int ret_type;

1003 FfiAggregate *ret_aggr = NULL;

1004 if (sigil_is_fixnum(args[3])) {

1005 ret_type = (int)sigil_as_fixnum(args[3]);

1006 if (!is_valid_ffi_type(ret_type)) {

1007 /* Clean up arg aggregates */

1008 for (int i = 0; i < arg_count; i++) free_aggregate(arg_aggrs[i]);

1009 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1010 "c-function: invalid return type %d", ret_type);

1011 return SIGIL_UNDEFINED;

1012 }

1013 } else if (sigil_is_pair(args[3])) {

1014 ret_aggr = create_aggregate_from_layout(vm, args[3]);

1015 if (!ret_aggr) {

1016 for (int i = 0; i < arg_count; i++) free_aggregate(arg_aggrs[i]);

1017 return SIGIL_UNDEFINED;

1018 }

1019 ret_type = FFI_AGGREGATE;

1020 } else {

1021 for (int i = 0; i < arg_count; i++) free_aggregate(arg_aggrs[i]);

1022 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1023 "c-function: return type must be an FFI type constant or struct layout");

1024 return SIGIL_UNDEFINED;

1025 }

1026

1027 /* Create function descriptor */

1028 FfiFunction *func = malloc(sizeof(FfiFunction));

1029 if (!func) {

1030 for (int i = 0; i < arg_count; i++) free_aggregate(arg_aggrs[i]);

1031 free_aggregate(ret_aggr);

1032 sigil__vm_error(vm, SIGIL_ERR_MEMORY, "c-function: out of memory");

1033 return SIGIL_UNDEFINED;

1034 }

1035

1036 func->fn_ptr = fn_ptr;

1037 func->arg_count = arg_count;

1038 memcpy(func->arg_types, arg_types, sizeof(int) * arg_count);

1039 memcpy(func->arg_aggrs, arg_aggrs, sizeof(FfiAggregate *) * FFI_MAX_ARGS);

1040 func->ret_type = ret_type;

1041 func->ret_aggr = ret_aggr;

1042

1043 return sigil_make_foreign(vm, ffi_function_type_tag, func,

1044 function_finalizer, sizeof(FfiFunction));

1045}

1046

1047/* %ffi-call func args... -> result */

1048static Value native_ffi_call(SigilVM *vm, int argc, Value *args)

1049{

1050 if (argc < 1) {

1051 sigil__vm_error(vm, SIGIL_ERR_ARITY,

1052 "ffi-call: expected at least 1 argument");

1053 return SIGIL_UNDEFINED;

1054 }

1055

1056 if (!is_ffi_function(args[0])) {

1057 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1058 "ffi-call: expected FFI function binding");

1059 return SIGIL_UNDEFINED;

1060 }

1061

1062 FfiFunction *func = as_function(args[0]);

1063 return ffi_dispatch(vm, func, argc - 1, args + 1);

1064}

1065

1066/* %ffi-type-size type -> integer */

1067static Value native_ffi_type_size(SigilVM *vm, int argc, Value *args)

1068{

1069 (void)argc;

1070

1071 if (!sigil_is_fixnum(args[0])) {

1072 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1073 "c-sizeof: expected FFI type constant");

1074 return SIGIL_UNDEFINED;

1075 }

1076

1077 int type_id = (int)sigil_as_fixnum(args[0]);

1078 if (!is_valid_ffi_type(type_id)) {

1079 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1080 "c-sizeof: invalid type %d", type_id);

1081 return SIGIL_UNDEFINED;

1082 }

1083

1084 return sigil_fixnum(ffi_type_info[type_id].size);

1085}

1086

1087/* %ffi-type-alignment type -> integer */

1088static Value native_ffi_type_alignment(SigilVM *vm, int argc, Value *args)

1089{

1090 (void)argc;

1091

1092 if (!sigil_is_fixnum(args[0])) {

1093 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1094 "c-alignof: expected FFI type constant");

1095 return SIGIL_UNDEFINED;

1096 }

1097

1098 int type_id = (int)sigil_as_fixnum(args[0]);

1099 if (!is_valid_ffi_type(type_id)) {

1100 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1101 "c-alignof: invalid type %d", type_id);

1102 return SIGIL_UNDEFINED;

1103 }

1104

1105 return sigil_fixnum(ffi_type_info[type_id].alignment);

1106}

1107

1108/* %ffi-make-pointer integer -> pointer */

1109static Value native_ffi_make_pointer(SigilVM *vm, int argc, Value *args)

1110{

1111 (void)argc;

1112

1113 intptr_t addr = 0;

1114 if (sigil_is_fixnum(args[0])) {

1115 addr = (intptr_t)sigil_as_fixnum(args[0]);

1116 } else if (sigil_is_flonum(args[0])) {

1117 addr = (intptr_t)(uint64_t)sigil_as_flonum(args[0]);

1118 } else {

1119 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1120 "make-pointer: expected integer");

1121 return SIGIL_UNDEFINED;

1122 }

1123

1124 return make_ffi_pointer(vm, (void *)addr);

1125}

1126

1127/* %ffi-pointer-address pointer -> integer */

1128static Value native_ffi_pointer_address(SigilVM *vm, int argc, Value *args)

1129{

1130 (void)argc;

1131

1132 if (args[0] == SIGIL_FALSE) return sigil_fixnum(0);

1133

1134 if (!is_ffi_pointer(args[0])) {

1135 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1136 "pointer-address: expected pointer");

1137 return SIGIL_UNDEFINED;

1138 }

1139

1140 intptr_t addr = (intptr_t)as_pointer(args[0]);

1141 if (addr >= SIGIL_FIXNUM_MIN && addr <= SIGIL_FIXNUM_MAX)

1142 return sigil_fixnum(addr);

1143 return sigil_flonum((double)addr);

1144}

1145

1146/* %ffi-pointer? obj -> boolean */

1147static Value native_ffi_pointerp(SigilVM *vm, int argc, Value *args)

1148{

1149 (void)vm; (void)argc;

1150 return sigil_bool(is_ffi_pointer(args[0]) || args[0] == SIGIL_FALSE);

1151}

1152

1153/* %ffi-pointer-ref ptr type offset -> value */

1154static Value native_ffi_pointer_ref(SigilVM *vm, int argc, Value *args)

1155{

1156 (void)argc;

1157

1158 if (!is_ffi_pointer(args[0])) {

1159 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1160 "pointer-ref: expected pointer");

1161 return SIGIL_UNDEFINED;

1162 }

1163 if (!sigil_is_fixnum(args[1])) {

1164 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1165 "pointer-ref: expected FFI type constant");

1166 return SIGIL_UNDEFINED;

1167 }

1168 if (!sigil_is_fixnum(args[2])) {

1169 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1170 "pointer-ref: expected integer offset");

1171 return SIGIL_UNDEFINED;

1172 }

1173

1174 uint8_t *base = (uint8_t *)as_pointer(args[0]);

1175 int type_id = (int)sigil_as_fixnum(args[1]);

1176 int64_t offset = sigil_as_fixnum(args[2]);

1177

1178 if (!is_valid_ffi_type(type_id) || type_id == FFI_VOID) {

1179 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1180 "pointer-ref: invalid type %d", type_id);

1181 return SIGIL_UNDEFINED;

1182 }

1183

1184 uint8_t *ptr = base + offset;

1185

1186 switch (type_id) {

1187 case FFI_BOOL: return sigil_bool(*(uint8_t *)ptr);

1188 case FFI_INT8: return sigil_fixnum(*(int8_t *)ptr);

1189 case FFI_UINT8: return sigil_fixnum(*(uint8_t *)ptr);

1190 case FFI_INT16: return sigil_fixnum(*(int16_t *)ptr);

1191 case FFI_UINT16: return sigil_fixnum(*(uint16_t *)ptr);

1192 case FFI_INT32:

1193 case FFI_INT: return sigil_fixnum(*(int32_t *)ptr);

1194 case FFI_UINT32:

1195 case FFI_UINT: return sigil_fixnum(*(uint32_t *)ptr);

1196 case FFI_INT64:

1197 case FFI_LONG: {

1198 int64_t v = *(int64_t *)ptr;

1199 if (v >= SIGIL_FIXNUM_MIN && v <= SIGIL_FIXNUM_MAX) return sigil_fixnum(v);

1200 return sigil_flonum((double)v);

1201 }

1202 case FFI_UINT64:

1203 case FFI_ULONG:

1204 case FFI_SIZE_T: {

1205 uint64_t v = *(uint64_t *)ptr;

1206 if (v <= (uint64_t)SIGIL_FIXNUM_MAX) return sigil_fixnum((int64_t)v);

1207 return sigil_flonum((double)v);

1208 }

1209 case FFI_FLOAT: return sigil_flonum((double)*(float *)ptr);

1210 case FFI_DOUBLE: return sigil_flonum(*(double *)ptr);

1211 case FFI_POINTER: return make_ffi_pointer(vm, *(void **)ptr);

1212 case FFI_STRING: {

1213 char *s = *(char **)ptr;

1214 if (!s) return SIGIL_FALSE;

1215 return sigil_make_string(vm, s, strlen(s));

1216 }

1217 default:

1218 return SIGIL_UNDEFINED;

1219 }

1220}

1221

1222/* %ffi-pointer-set! ptr type offset value -> void */

1223static Value native_ffi_pointer_set(SigilVM *vm, int argc, Value *args)

1224{

1225 (void)argc;

1226

1227 if (!is_ffi_pointer(args[0])) {

1228 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1229 "pointer-set!: expected pointer");

1230 return SIGIL_UNDEFINED;

1231 }

1232 if (!sigil_is_fixnum(args[1])) {

1233 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1234 "pointer-set!: expected FFI type constant");

1235 return SIGIL_UNDEFINED;

1236 }

1237 if (!sigil_is_fixnum(args[2])) {

1238 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1239 "pointer-set!: expected integer offset");

1240 return SIGIL_UNDEFINED;

1241 }

1242

1243 uint8_t *base = (uint8_t *)as_pointer(args[0]);

1244 int type_id = (int)sigil_as_fixnum(args[1]);

1245 int64_t offset = sigil_as_fixnum(args[2]);

1246 Value val = args[3];

1247

1248 if (!is_valid_ffi_type(type_id) || type_id == FFI_VOID) {

1249 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1250 "pointer-set!: invalid type %d", type_id);

1251 return SIGIL_UNDEFINED;

1252 }

1253

1254 uint8_t *ptr = base + offset;

1255

1256 switch (type_id) {

1257 case FFI_BOOL:

1258 *(uint8_t *)ptr = sigil_is_truthy(val) ? 1 : 0;

1259 break;

1260 case FFI_INT8:

1261 *(int8_t *)ptr = (int8_t)(sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (int64_t)sigil_as_flonum(val));

1262 break;

1263 case FFI_UINT8:

1264 *(uint8_t *)ptr = (uint8_t)(sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (uint64_t)sigil_as_flonum(val));

1265 break;

1266 case FFI_INT16:

1267 *(int16_t *)ptr = (int16_t)(sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (int64_t)sigil_as_flonum(val));

1268 break;

1269 case FFI_UINT16:

1270 *(uint16_t *)ptr = (uint16_t)(sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (uint64_t)sigil_as_flonum(val));

1271 break;

1272 case FFI_INT32:

1273 case FFI_INT:

1274 *(int32_t *)ptr = (int32_t)(sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (int64_t)sigil_as_flonum(val));

1275 break;

1276 case FFI_UINT32:

1277 case FFI_UINT:

1278 *(uint32_t *)ptr = (uint32_t)(sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (uint64_t)sigil_as_flonum(val));

1279 break;

1280 case FFI_INT64:

1281 case FFI_LONG:

1282 *(int64_t *)ptr = sigil_is_fixnum(val) ? sigil_as_fixnum(val) : (int64_t)sigil_as_flonum(val);

1283 break;

1284 case FFI_UINT64:

1285 case FFI_ULONG:

1286 case FFI_SIZE_T:

1287 *(uint64_t *)ptr = sigil_is_fixnum(val) ? (uint64_t)sigil_as_fixnum(val) : (uint64_t)sigil_as_flonum(val);

1288 break;

1289 case FFI_FLOAT:

1290 *(float *)ptr = (float)(sigil_is_flonum(val) ? sigil_as_flonum(val) : (double)sigil_as_fixnum(val));

1291 break;

1292 case FFI_DOUBLE:

1293 *(double *)ptr = sigil_is_flonum(val) ? sigil_as_flonum(val) : (double)sigil_as_fixnum(val);

1294 break;

1295 case FFI_POINTER:

1296 if (val == SIGIL_FALSE) {

1297 *(void **)ptr = NULL;

1298 } else if (is_ffi_pointer(val)) {

1299 *(void **)ptr = as_pointer(val);

1300 }

1301 break;

1302 default:

1303 break;

1304 }

1305

1306 return SIGIL_UNDEFINED;

1307}

1308

1309/* %ffi-alloc size -> pointer */

1310static Value native_ffi_alloc(SigilVM *vm, int argc, Value *args)

1311{

1312 (void)argc;

1313

1314 if (!sigil_is_fixnum(args[0])) {

1315 sigil__vm_error(vm, SIGIL_ERR_TYPE, "c-alloc: expected integer size");

1316 return SIGIL_UNDEFINED;

1317 }

1318

1319 size_t size = (size_t)sigil_as_fixnum(args[0]);

1320 void *mem = calloc(1, size);

1321 if (!mem) {

1322 sigil__vm_error(vm, SIGIL_ERR_MEMORY, "c-alloc: allocation failed");

1323 return SIGIL_UNDEFINED;

1324 }

1325

1326 return make_ffi_pointer(vm, mem);

1327}

1328

1329/* %ffi-free ptr -> void */

1330static Value native_ffi_free(SigilVM *vm, int argc, Value *args)

1331{

1332 (void)argc;

1333

1334 if (args[0] == SIGIL_FALSE) return SIGIL_UNDEFINED; /* free(NULL) is a no-op */

1335

1336 if (!is_ffi_pointer(args[0])) {

1337 sigil__vm_error(vm, SIGIL_ERR_TYPE, "c-free: expected pointer");

1338 return SIGIL_UNDEFINED;

1339 }

1340

1341 free(as_pointer(args[0]));

1342 /* Note: the foreign object still exists but its data pointer is dangling.

1343 * The user is responsible for not using it after free. */

1344 return SIGIL_UNDEFINED;

1345}

1346

1347/* %ffi-string->pointer str -> pointer */

1348static Value native_ffi_string_to_pointer(SigilVM *vm, int argc, Value *args)

1349{

1350 (void)argc;

1351

1352 if (!sigil_is_string(args[0])) {

1353 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1354 "string->pointer: expected string");

1355 return SIGIL_UNDEFINED;

1356 }

1357

1358 char *cstr = extract_cstring(args[0]);

1359 if (!cstr) {

1360 sigil__vm_error(vm, SIGIL_ERR_MEMORY,

1361 "string->pointer: allocation failed");

1362 return SIGIL_UNDEFINED;

1363 }

1364

1365 return make_ffi_pointer(vm, cstr);

1366}

1367

1368/* %ffi-pointer->string ptr [len] -> string */

1369static Value native_ffi_pointer_to_string(SigilVM *vm, int argc, Value *args)

1370{

1371 if (args[0] == SIGIL_FALSE) return SIGIL_FALSE;

1372

1373 if (!is_ffi_pointer(args[0])) {

1374 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1375 "pointer->string: expected pointer");

1376 return SIGIL_UNDEFINED;

1377 }

1378

1379 const char *cstr = (const char *)as_pointer(args[0]);

1380 if (!cstr) return SIGIL_FALSE;

1381

1382 size_t len;

1383 if (argc >= 2 && sigil_is_fixnum(args[1])) {

1384 len = (size_t)sigil_as_fixnum(args[1]);

1385 } else {

1386 len = strlen(cstr);

1387 }

1388

1389 return sigil_make_string(vm, cstr, len);

1390}

1391

1392/* %ffi-errno -> integer */

1393static Value native_ffi_errno(SigilVM *vm, int argc, Value *args)

1394{

1395 (void)vm; (void)argc; (void)args;

1396 return sigil_fixnum(errno);

1397}

1398

1399/* %ffi-strerror errno -> string */

1400static Value native_ffi_strerror(SigilVM *vm, int argc, Value *args)

1401{

1402 (void)argc;

1403

1404 if (!sigil_is_fixnum(args[0])) {

1405 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1406 "c-strerror: expected integer");

1407 return SIGIL_UNDEFINED;

1408 }

1409

1410 int err = (int)sigil_as_fixnum(args[0]);

1411 const char *msg = strerror(err);

1412 return sigil_make_string(vm, msg, strlen(msg));

1413}

1414

1415/* %ffi-set-finalizer! ptr finalizer-ptr -> void */

1416static Value native_ffi_set_finalizer(SigilVM *vm, int argc, Value *args)

1417{

1418 (void)argc;

1419

1420 if (!is_ffi_pointer(args[0])) {

1421 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1422 "set-pointer-finalizer!: expected pointer");

1423 return SIGIL_UNDEFINED;

1424 }

1425 if (args[1] != SIGIL_FALSE && !is_ffi_pointer(args[1])) {

1426 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1427 "set-pointer-finalizer!: expected function pointer or #f");

1428 return SIGIL_UNDEFINED;

1429 }

1430

1431 /* Set or clear the finalizer on the foreign object.

1432 * Pass #f to clear the finalizer (prevents double-free when

1433 * explicit destroy is called before GC collects the pointer). */

1434 SigilForeign *foreign = (SigilForeign *)sigil_as_ptr(args[0]);

1435 if (args[1] == SIGIL_FALSE) {

1436 foreign->finalizer = NULL;

1437 } else {

1438 void (*fin)(void *) = (void (*)(void *))as_pointer(args[1]);

1439 foreign->finalizer = fin;

1440 }

1441

1442 return SIGIL_UNDEFINED;

1443}

1444

1445/* %ffi-pointer->bytevector ptr len -> bytevector */

1446static Value native_ffi_pointer_to_bytevector(SigilVM *vm, int argc, Value *args)

1447{

1448 (void)argc;

1449

1450 if (!is_ffi_pointer(args[0])) {

1451 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1452 "pointer->bytevector: expected pointer");

1453 return SIGIL_UNDEFINED;

1454 }

1455 if (!sigil_is_fixnum(args[1])) {

1456 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1457 "pointer->bytevector: expected integer length");

1458 return SIGIL_UNDEFINED;

1459 }

1460

1461 uint8_t *src = (uint8_t *)as_pointer(args[0]);

1462 size_t len = (size_t)sigil_as_fixnum(args[1]);

1463

1464 Value bv = sigil_make_bytevector(vm, len);

1465 memcpy(sigil_bytevector_data(bv), src, len);

1466 return bv;

1467}

1468

1469/* %ffi-bytevector->pointer bv -> pointer */

1470static Value native_ffi_bytevector_to_pointer(SigilVM *vm, int argc, Value *args)

1471{

1472 (void)argc;

1473

1474 if (!sigil_is_bytevector(args[0])) {

1475 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1476 "bytevector->pointer: expected bytevector");

1477 return SIGIL_UNDEFINED;

1478 }

1479

1480 return make_ffi_pointer(vm, sigil_bytevector_data(args[0]));

1481}

1482

1483/* %ffi-library? obj -> boolean */

1484static Value native_ffi_libraryp(SigilVM *vm, int argc, Value *args)

1485{

1486 (void)vm; (void)argc;

1487 return sigil_bool(is_ffi_library(args[0]));

1488}

1489

1490/* %ffi-function? obj -> boolean */

1491static Value native_ffi_functionp(SigilVM *vm, int argc, Value *args)

1492{

1493 (void)vm; (void)argc;

1494 return sigil_bool(is_ffi_function(args[0]));

1495}

1496

1497/* ============================================================

1498 * Callback System: C -> Scheme (dyncall-based)

1499 * ============================================================

1500 *

1501 * Uses dyncall's DCCallback to create function pointers that invoke

1502 * Scheme procedures. Each callback gets its own DCCallback allocation

1503 * with a FfiCallbackData userdata struct.

1504 */

1505

1506/* Callback state stored as userdata for dyncall */

1507typedef struct {

1508 SigilVM *vm;

1509 Value proc;

1510 int arg_count;

1511 int arg_types[FFI_MAX_ARGS];

1512 int ret_type;

1513} FfiCallbackData;

1514

1515/* Linked list of active callbacks for GC tracing */

1516typedef struct FfiCallbackNode {

1517 FfiCallbackData *data;

1518 DCCallback *callback;

1519 struct FfiCallbackNode *next;

1520} FfiCallbackNode;

1521

1522static FfiCallbackNode *callback_list = NULL;

1523

1524/* Build a dyncall signature string from FFI types */

1525static void build_dc_signature(int *arg_types, int arg_count, int ret_type,

1526 char *out)

1527{

1528 int pos = 0;

1529 for (int i = 0; i < arg_count; i++) {

1530 int type = arg_types[i];

1531 switch (type) {

1532 case FFI_BOOL: out[pos++] = DC_SIGCHAR_BOOL; break;

1533 case FFI_INT8: out[pos++] = DC_SIGCHAR_CHAR; break;

1534 case FFI_UINT8: out[pos++] = DC_SIGCHAR_UCHAR; break;

1535 case FFI_INT16: out[pos++] = DC_SIGCHAR_SHORT; break;

1536 case FFI_UINT16: out[pos++] = DC_SIGCHAR_USHORT; break;

1537 case FFI_INT32:

1538 case FFI_INT: out[pos++] = DC_SIGCHAR_INT; break;

1539 case FFI_UINT32:

1540 case FFI_UINT: out[pos++] = DC_SIGCHAR_UINT; break;

1541 case FFI_INT64:

1542 case FFI_LONG: out[pos++] = DC_SIGCHAR_LONGLONG; break;

1543 case FFI_UINT64:

1544 case FFI_ULONG:

1545 case FFI_SIZE_T: out[pos++] = DC_SIGCHAR_ULONGLONG; break;

1546 case FFI_FLOAT: out[pos++] = DC_SIGCHAR_FLOAT; break;

1547 case FFI_DOUBLE: out[pos++] = DC_SIGCHAR_DOUBLE; break;

1548 case FFI_POINTER:

1549 case FFI_STRING: out[pos++] = DC_SIGCHAR_POINTER; break;

1550 default: out[pos++] = DC_SIGCHAR_INT; break;

1551 }

1552 }

1553 out[pos++] = DC_SIGCHAR_ENDARG; /* ')' */

1554 switch (ret_type) {

1555 case FFI_VOID: out[pos++] = DC_SIGCHAR_VOID; break;

1556 case FFI_BOOL: out[pos++] = DC_SIGCHAR_BOOL; break;

1557 case FFI_INT8: out[pos++] = DC_SIGCHAR_CHAR; break;

1558 case FFI_UINT8: out[pos++] = DC_SIGCHAR_UCHAR; break;

1559 case FFI_INT16: out[pos++] = DC_SIGCHAR_SHORT; break;

1560 case FFI_UINT16: out[pos++] = DC_SIGCHAR_USHORT; break;

1561 case FFI_INT32:

1562 case FFI_INT: out[pos++] = DC_SIGCHAR_INT; break;

1563 case FFI_UINT32:

1564 case FFI_UINT: out[pos++] = DC_SIGCHAR_UINT; break;

1565 case FFI_INT64:

1566 case FFI_LONG: out[pos++] = DC_SIGCHAR_LONGLONG; break;

1567 case FFI_UINT64:

1568 case FFI_ULONG:

1569 case FFI_SIZE_T: out[pos++] = DC_SIGCHAR_ULONGLONG; break;

1570 case FFI_FLOAT: out[pos++] = DC_SIGCHAR_FLOAT; break;

1571 case FFI_DOUBLE: out[pos++] = DC_SIGCHAR_DOUBLE; break;

1572 case FFI_POINTER:

1573 case FFI_STRING: out[pos++] = DC_SIGCHAR_POINTER; break;

1574 default: out[pos++] = DC_SIGCHAR_INT; break;

1575 }

1576 out[pos] = '\0';

1577}

1578

1579/* dyncall callback handler */

1580static DCsigchar ffi_dyncall_callback_handler(DCCallback *cb, DCArgs *dc_args,

1581 DCValue *result, void *userdata)

1582{

1583 (void)cb;

1584 FfiCallbackData *cbd = (FfiCallbackData *)userdata;

1585 SigilVM *vm = cbd->vm;

1586

1587 /* Marshal C args to Scheme values */

1588 Value scheme_args[FFI_MAX_ARGS];

1589 for (int i = 0; i < cbd->arg_count; i++) {

1590 int type = cbd->arg_types[i];

1591 switch (ffi_type_info[type].reg_class) {

1592 case REG_INT:

1593 switch (type) {

1594 case FFI_BOOL:

1595 scheme_args[i] = sigil_bool(dcbArgBool(dc_args));

1596 break;

1597 case FFI_INT8:

1598 scheme_args[i] = sigil_fixnum((int8_t)dcbArgChar(dc_args));

1599 break;

1600 case FFI_UINT8:

1601 scheme_args[i] = sigil_fixnum((uint8_t)dcbArgUChar(dc_args));

1602 break;

1603 case FFI_INT16:

1604 scheme_args[i] = sigil_fixnum(dcbArgShort(dc_args));

1605 break;

1606 case FFI_UINT16:

1607 scheme_args[i] = sigil_fixnum(dcbArgUShort(dc_args));

1608 break;

1609 case FFI_INT32:

1610 case FFI_INT:

1611 scheme_args[i] = sigil_fixnum(dcbArgInt(dc_args));

1612 break;

1613 case FFI_UINT32:

1614 case FFI_UINT:

1615 scheme_args[i] = sigil_fixnum((uint32_t)dcbArgUInt(dc_args));

1616 break;

1617 case FFI_INT64:

1618 case FFI_LONG: {

1619 int64_t v = (int64_t)dcbArgLongLong(dc_args);

1620 if (v >= SIGIL_FIXNUM_MIN && v <= SIGIL_FIXNUM_MAX)

1621 scheme_args[i] = sigil_fixnum(v);

1622 else

1623 scheme_args[i] = sigil_flonum((double)v);

1624 break;

1625 }

1626 case FFI_UINT64:

1627 case FFI_ULONG:

1628 case FFI_SIZE_T: {

1629 uint64_t v = (uint64_t)dcbArgULongLong(dc_args);

1630 if (v <= (uint64_t)SIGIL_FIXNUM_MAX)

1631 scheme_args[i] = sigil_fixnum((int64_t)v);

1632 else

1633 scheme_args[i] = sigil_flonum((double)v);

1634 break;

1635 }

1636 case FFI_POINTER:

1637 scheme_args[i] = make_ffi_pointer(vm, dcbArgPointer(dc_args));

1638 break;

1639 case FFI_STRING: {

1640 char *s = (char *)dcbArgPointer(dc_args);

1641 if (!s) scheme_args[i] = SIGIL_FALSE;

1642 else scheme_args[i] = sigil_make_string(vm, s, strlen(s));

1643 break;

1644 }

1645 default:

1646 scheme_args[i] = sigil_fixnum(dcbArgInt(dc_args));

1647 break;

1648 }

1649 break;

1650 case REG_FLOAT:

1651 scheme_args[i] = sigil_flonum((double)dcbArgFloat(dc_args));

1652 break;

1653 case REG_DOUBLE:

1654 scheme_args[i] = sigil_flonum(dcbArgDouble(dc_args));

1655 break;

1656 default:

1657 scheme_args[i] = SIGIL_UNDEFINED;

1658 break;

1659 }

1660 }

1661

1662 /* Call Scheme procedure */

1663 Value ret_val;

1664 switch (cbd->arg_count) {

1665 case 0:

1666 ret_val = sigil_apply0(vm, cbd->proc);

1667 break;

1668 case 1:

1669 ret_val = sigil_apply1(vm, cbd->proc, scheme_args[0]);

1670 break;

1671 case 2:

1672 ret_val = sigil_apply2(vm, cbd->proc, scheme_args[0], scheme_args[1]);

1673 break;

1674 case 3:

1675 ret_val = sigil_apply3(vm, cbd->proc, scheme_args[0], scheme_args[1],

1676 scheme_args[2]);

1677 break;

1678 default:

1679 /* >3 args: dispatch through the generic arity variant (added to the VM

1680 * C-API alongside sigil_apply0..3). Supports up to FFI_MAX_ARGS. */

1681 ret_val = sigil_applyN(vm, cbd->proc, cbd->arg_count, scheme_args);

1682 break;

1683 }

1684

1685 /* Marshal return value */

1686 int ret_type = cbd->ret_type;

1687 if (ret_type == FFI_VOID) {

1688 return DC_SIGCHAR_VOID;

1689 }

1690 switch (ffi_type_info[ret_type].reg_class) {

1691 case REG_INT:

1692 switch (ret_type) {

1693 case FFI_BOOL:

1694 result->B = sigil_is_truthy(ret_val) ? 1 : 0;

1695 return DC_SIGCHAR_BOOL;

1696 case FFI_INT8:

1697 case FFI_UINT8:

1698 result->c = (DCchar)marshal_to_int(vm, ret_val, ret_type);

1699 return DC_SIGCHAR_CHAR;

1700 case FFI_INT16:

1701 case FFI_UINT16:

1702 result->s = (DCshort)marshal_to_int(vm, ret_val, ret_type);

1703 return DC_SIGCHAR_SHORT;

1704 case FFI_INT32:

1705 case FFI_INT:

1706 case FFI_UINT32:

1707 case FFI_UINT:

1708 result->i = (DCint)marshal_to_int(vm, ret_val, ret_type);

1709 return DC_SIGCHAR_INT;

1710 case FFI_INT64:

1711 case FFI_LONG:

1712 case FFI_UINT64:

1713 case FFI_ULONG:

1714 case FFI_SIZE_T:

1715 result->l = (DClonglong)marshal_to_int(vm, ret_val, ret_type);

1716 return DC_SIGCHAR_LONGLONG;

1717 case FFI_POINTER:

1718 case FFI_STRING:

1719 result->p = (DCpointer)marshal_to_int(vm, ret_val, ret_type);

1720 return DC_SIGCHAR_POINTER;

1721 default:

1722 result->i = (DCint)marshal_to_int(vm, ret_val, ret_type);

1723 return DC_SIGCHAR_INT;

1724 }

1725 case REG_FLOAT:

1726 result->f = marshal_to_float(vm, ret_val);

1727 return DC_SIGCHAR_FLOAT;

1728 case REG_DOUBLE:

1729 result->d = marshal_to_double(vm, ret_val);

1730 return DC_SIGCHAR_DOUBLE;

1731 default:

1732 return DC_SIGCHAR_VOID;

1733 }

1734}

1735

1736/* GC trace callback: mark all stored Scheme procedures as live.

1737 * Called from the foreign object tracer for any callback-related object,

1738 * or can be integrated with a future global GC trace hook. */

1739static void ffi_callback_gc_trace(SigilVM *vm)

1740{

1741 FfiCallbackNode *node = callback_list;

1742 while (node) {

1743 if (node->data && node->data->vm == vm) {

1744 sigil__gc_mark_foreign_value(vm, node->data->proc);

1745 }

1746 node = node->next;

1747 }

1748}

1749

1750/* %ffi-callback-create arg-types ret-type proc -> pointer */

1751static Value native_ffi_callback_create(SigilVM *vm, int argc, Value *args)

1752{

1753 (void)argc;

1754

1755 /* Parse arg types */

1756 int arg_count = 0;

1757 int arg_types[FFI_MAX_ARGS];

1758 Value arg_list = args[0];

1759

1760 while (sigil_is_pair(arg_list)) {

1761 if (arg_count >= FFI_MAX_ARGS) {

1762 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1763 "c-callback: too many arguments (max %d)", FFI_MAX_ARGS);

1764 return SIGIL_UNDEFINED;

1765 }

1766 Value type_val = sigil_car(arg_list);

1767 if (!sigil_is_fixnum(type_val)) {

1768 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1769 "c-callback: argument type must be an FFI type constant");

1770 return SIGIL_UNDEFINED;

1771 }

1772 int type_id = (int)sigil_as_fixnum(type_val);

1773 if (!is_valid_ffi_type(type_id) || type_id == FFI_VOID) {

1774 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1775 "c-callback: invalid argument type %d", type_id);

1776 return SIGIL_UNDEFINED;

1777 }

1778 arg_types[arg_count++] = type_id;

1779 arg_list = sigil_cdr(arg_list);

1780 }

1781

1782 /* Return type */

1783 if (!sigil_is_fixnum(args[1])) {

1784 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1785 "c-callback: return type must be an FFI type constant");

1786 return SIGIL_UNDEFINED;

1787 }

1788 int ret_type = (int)sigil_as_fixnum(args[1]);

1789 if (!is_valid_ffi_type(ret_type)) {

1790 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1791 "c-callback: invalid return type %d", ret_type);

1792 return SIGIL_UNDEFINED;

1793 }

1794

1795 /* Procedure. Accept bytecode closures, native primitives, AND

1796 * native-codegen closures (SIGIL_OBJ_NATIVE_CLOSURE) - the last is what

1797 * top-level procedures become in --backend native builds, and both the

1798 * callback handler and the sigil_applyN family already dispatch them via

1799 * sigil_native_bridge_call. Without this, c-callback rejects every callback

1800 * in a native-compiled program. */

1801 Value proc = args[2];

1802 if (!sigil_is_closure(proc) && !sigil_is_native_proc(proc) &&

1803 !sigil_is_native_closure(proc)) {

1804 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1805 "c-callback: expected procedure");

1806 return SIGIL_UNDEFINED;

1807 }

1808

1809 /* Build dyncall signature */

1810 char sig[FFI_MAX_ARGS + 4];

1811 build_dc_signature(arg_types, arg_count, ret_type, sig);

1812

1813 /* Create callback data */

1814 FfiCallbackData *cbd = malloc(sizeof(FfiCallbackData));

1815 if (!cbd) {

1816 sigil__vm_error(vm, SIGIL_ERR_MEMORY, "c-callback: out of memory");

1817 return SIGIL_UNDEFINED;

1818 }

1819 cbd->vm = vm;

1820 cbd->proc = proc;

1821 cbd->arg_count = arg_count;

1822 memcpy(cbd->arg_types, arg_types, sizeof(int) * arg_count);

1823 cbd->ret_type = ret_type;

1824

1825 /* Create dyncall callback */

1826 DCCallback *cb = dcbNewCallback(sig, ffi_dyncall_callback_handler, cbd);

1827 if (!cb) {

1828 free(cbd);

1829 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1830 "c-callback: failed to create callback");

1831 return SIGIL_UNDEFINED;

1832 }

1833

1834 /* Track for GC */

1835 FfiCallbackNode *node = malloc(sizeof(FfiCallbackNode));

1836 if (!node) {

1837 dcbFreeCallback(cb);

1838 free(cbd);

1839 sigil__vm_error(vm, SIGIL_ERR_MEMORY, "c-callback: out of memory");

1840 return SIGIL_UNDEFINED;

1841 }

1842 node->data = cbd;

1843 node->callback = cb;

1844 node->next = callback_list;

1845 callback_list = node;

1846

1847 return make_ffi_pointer(vm, (void *)cb);

1848}

1849

1850/* %ffi-callback-release ptr -> void */

1851static Value native_ffi_callback_release(SigilVM *vm, int argc, Value *args)

1852{

1853 (void)argc;

1854

1855 if (!is_ffi_pointer(args[0]) && args[0] != SIGIL_FALSE) {

1856 sigil__vm_error(vm, SIGIL_ERR_TYPE,

1857 "c-callback-release: expected pointer");

1858 return SIGIL_UNDEFINED;

1859 }

1860

1861 if (args[0] == SIGIL_FALSE) return SIGIL_UNDEFINED;

1862

1863 void *ptr = as_pointer(args[0]);

1864

1865 /* Find and remove from callback list */

1866 FfiCallbackNode **prev = &callback_list;

1867 FfiCallbackNode *node = callback_list;

1868 while (node) {

1869 if ((void *)node->callback == ptr) {

1870 *prev = node->next;

1871 dcbFreeCallback(node->callback);

1872 free(node->data);

1873 free(node);

1874 return SIGIL_UNDEFINED;

1875 }

1876 prev = &node->next;

1877 node = node->next;

1878 }

1879

1880 sigil__vm_error(vm, SIGIL_ERR_RUNTIME,

1881 "c-callback-release: pointer is not a callback");

1882 return SIGIL_UNDEFINED;

1883}

1884

1885/* ============================================================

1886 * Module Initialization

1887 * ============================================================ */

1888

1889#define REGISTER_AND_EXPORT(name, func, arity, doc) \

1890 sigil_module_register_native(vm, name, func, arity, doc); \

1891 sigil_module_export(vm, name)

1892

1893void sigil__init_sigil_ffi_module(SigilVM *vm)

1894{

1895 /* Initialize type tags */

1896 ffi_library_type_tag = sigil_intern_symbol(vm, "ffi-library", 11);

1897 ffi_pointer_type_tag = sigil_intern_symbol(vm, "ffi-pointer", 11);

1898 ffi_function_type_tag = sigil_intern_symbol(vm, "ffi-function", 12);

1899

1900 /* Note: callback Scheme procs are rooted by the Scheme-level callback

1901 * table. ffi_callback_gc_trace() is available for future GC hook

1902 * integration if needed. */

1903 (void)ffi_callback_gc_trace;

1904

1905 SigilModule *module = sigil_begin_module(vm, "(sigil ffi)");

1906 if (!module) return;

1907

1908 /* Library operations */

1909 REGISTER_AND_EXPORT("%ffi-open-library", native_ffi_open_library,

1910 SIGIL_ARITY_EXACT(1), "Open a shared library");

1911 REGISTER_AND_EXPORT("%ffi-close-library", native_ffi_close_library,

1912 SIGIL_ARITY_EXACT(1), "Close a shared library");

1913 REGISTER_AND_EXPORT("%ffi-lookup-symbol", native_ffi_lookup_symbol,

1914 SIGIL_ARITY_EXACT(2), "Look up a symbol in a library");

1915

1916 /* Function binding and calling */

1917 REGISTER_AND_EXPORT("%ffi-bind-function", native_ffi_bind_function,

1918 SIGIL_ARITY_EXACT(4), "Bind a C function");

1919 REGISTER_AND_EXPORT("%ffi-call", native_ffi_call,

1920 SIGIL_ARITY_AT_LEAST(1), "Call an FFI function");

1921

1922 /* Type queries */

1923 REGISTER_AND_EXPORT("%ffi-type-size", native_ffi_type_size,

1924 SIGIL_ARITY_EXACT(1), "Get size of FFI type");

1925 REGISTER_AND_EXPORT("%ffi-type-alignment", native_ffi_type_alignment,

1926 SIGIL_ARITY_EXACT(1), "Get alignment of FFI type");

1927

1928 /* Pointer operations */

1929 REGISTER_AND_EXPORT("%ffi-make-pointer", native_ffi_make_pointer,

1930 SIGIL_ARITY_EXACT(1), "Create pointer from integer");

1931 REGISTER_AND_EXPORT("%ffi-pointer-address", native_ffi_pointer_address,

1932 SIGIL_ARITY_EXACT(1), "Get pointer address as integer");

1933 REGISTER_AND_EXPORT("%ffi-pointer?", native_ffi_pointerp,

1934 SIGIL_ARITY_EXACT(1), "Check if value is an FFI pointer");

1935 REGISTER_AND_EXPORT("%ffi-pointer-ref", native_ffi_pointer_ref,

1936 SIGIL_ARITY_EXACT(3), "Read typed value at pointer offset");

1937 REGISTER_AND_EXPORT("%ffi-pointer-set!", native_ffi_pointer_set,

1938 SIGIL_ARITY_EXACT(4), "Write typed value at pointer offset");

1939

1940 /* Memory management */

1941 REGISTER_AND_EXPORT("%ffi-alloc", native_ffi_alloc,

1942 SIGIL_ARITY_EXACT(1), "Allocate memory");

1943 REGISTER_AND_EXPORT("%ffi-free", native_ffi_free,

1944 SIGIL_ARITY_EXACT(1), "Free allocated memory");

1945

1946 /* String conversions */

1947 REGISTER_AND_EXPORT("%ffi-string->pointer", native_ffi_string_to_pointer,

1948 SIGIL_ARITY_EXACT(1), "Convert string to C string pointer");

1949 REGISTER_AND_EXPORT("%ffi-pointer->string", native_ffi_pointer_to_string,

1950 SIGIL_ARITY_RANGE(1, 2), "Convert C string pointer to string");

1951

1952 /* Error handling */

1953 REGISTER_AND_EXPORT("%ffi-errno", native_ffi_errno,

1954 SIGIL_ARITY_EXACT(0), "Get current errno value");

1955 REGISTER_AND_EXPORT("%ffi-strerror", native_ffi_strerror,

1956 SIGIL_ARITY_EXACT(1), "Convert errno to error message");

1957

1958 /* Finalizers */

1959 REGISTER_AND_EXPORT("%ffi-set-finalizer!", native_ffi_set_finalizer,

1960 SIGIL_ARITY_EXACT(2), "Set pointer finalizer");

1961

1962 /* Bytevector bridge */

1963 REGISTER_AND_EXPORT("%ffi-pointer->bytevector", native_ffi_pointer_to_bytevector,

1964 SIGIL_ARITY_EXACT(2), "Copy pointer data to bytevector");

1965 REGISTER_AND_EXPORT("%ffi-bytevector->pointer", native_ffi_bytevector_to_pointer,

1966 SIGIL_ARITY_EXACT(1), "Get pointer to bytevector data");

1967

1968 /* Type predicates */

1969 REGISTER_AND_EXPORT("%ffi-library?", native_ffi_libraryp,

1970 SIGIL_ARITY_EXACT(1), "Check if value is an FFI library");

1971 REGISTER_AND_EXPORT("%ffi-function?", native_ffi_functionp,

1972 SIGIL_ARITY_EXACT(1), "Check if value is an FFI function binding");

1973

1974 /* Callbacks */

1975 REGISTER_AND_EXPORT("%ffi-callback-create", native_ffi_callback_create,

1976 SIGIL_ARITY_EXACT(3), "Create a callback from a Scheme procedure");

1977 REGISTER_AND_EXPORT("%ffi-callback-release", native_ffi_callback_release,

1978 SIGIL_ARITY_EXACT(1), "Release a callback slot");

1979

1980 sigil_end_module(vm);

1981}

1982

1983#undef REGISTER_AND_EXPORT