Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Gauche implementation now works

This commit is contained in:
retropikzel 2025-03-12 08:10:44 +02:00
parent 526b9c7926
commit 25e9497ae4
2 changed files with 25 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
retropikzel/pffi/gauche.scm
View File

@ -12,6 +12,7 @@
pffi-string->pointer
pffi-pointer->string
pffi-define))
(select-module retropikzel.pffi.gauche)
(dynamic-load "retropikzel/pffi/retropikzel-pffi-gauche")
@ -147,7 +148,7 @@
(define argument->pointer
(lambda (value type)
(cond ((pffi-pointer? value) value)
(cond ;((pffi-pointer? value) value)
((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
@ -168,6 +169,20 @@
(display "Calling function: ")
(display c-name)
(newline)
(display "Return type: ")
(write (pffi-type->libffi-type return-type))
(newline)
(display "Argument types: ")
(write (map pffi-type->libffi-type argument-types))
(newline)
(display "Size of return type: ")
(write (size-of-type return-type))
(newline)
(display "Argument pointers: ")
(write (map argument->pointer
arguments
argument-types))
(newline)
(internal-ffi-call (length argument-types)
(pffi-type->libffi-type return-type)
(map pffi-type->libffi-type argument-types)
@ -176,9 +191,12 @@
(map argument->pointer
arguments
argument-types))
(display "Return value pointer: ")
(write return-value)
(newline)
(cond ((not (equal? return-type 'void))
(display "Return value pointer: ")
(write return-value)
(display "Return value: ")
(write (pffi-pointer-get return-value return-type 0))
(newline)
(pffi-pointer-get return-value return-type 0))))))))

6
src/gauche/pffi.c
View File

@ -655,8 +655,8 @@ ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, S
int atypes_length = (int)Scm_Length(atypes);
ffi_type* c_atypes[atypes_length];
for(int i = 0; i < atypes_length; i++) {
c_atypes[i] = SCM_FOREIGN_POINTER_REF(ffi_type*, Scm_ListRef(atypes, i, SCM_UNDEFINED));
}
printf("DEBUG666\n");
int prep_status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, c_nargs, c_rtype, c_atypes);
void* c_fn = SCM_FOREIGN_POINTER_REF(void*, fn);
@ -664,11 +664,11 @@ ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, S
int avalues_length = (int)Scm_Length(avalues);
void* c_avalues[avalues_length];
for(int i = 0; i < avalues_length; i++) {
c_atypes[i] = SCM_FOREIGN_POINTER_REF(ffi_type*, Scm_ListRef(atypes, i, SCM_UNDEFINED));
ScmObj item = Scm_ListRef(avalues, i, SCM_UNDEFINED);
void* pp = SCM_FOREIGN_POINTER_REF(void*, item);
printf("DEBUG1: %i\n", i);
char* list_p = (char*)c_avalues + (sizeof(void) * i);
/*
if(c_atypes[i] == &ffi_type_pointer) {
c_avalues[i] = &pp;
printf("DEBUG2: %i\n", &c_avalues[i]);
@ -677,6 +677,8 @@ ScmObj internal_ffi_call(ScmObj nargs, ScmObj rtype, ScmObj atypes, ScmObj fn, S
printf("DEBUG2: %i\n", *(int*)pp);
c_avalues[i] = pp;
}
*/
c_avalues[i] = pp;
}
printf("HERE2\n");
printf("DEBUG3.1: %i\n", &c_rvalue);