mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 23:50:56 -08:00
Preliminary implementation of the UFFI.
This commit is contained in:
jjgarcia
parent
b5d5a86d43
commit
62d43f4892
25 changed files with 759 additions and 250 deletions
|
|
@ -47,7 +47,7 @@ OBJS = main.o symbol.o package.o list.o\
|
|||
time.o unixint.o\
|
||||
mapfun.o multival.o hash.o format.o pathname.o\
|
||||
structure.o load.o unixfsys.o unixsys.o \
|
||||
all_symbols.o @EXTRA_OBJS@
|
||||
all_symbols.o ffi.o @EXTRA_OBJS@
|
||||
|
||||
.SUFFIXES: .c .o .d
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#include <ctype.h>
|
||||
#include "ecl.h"
|
||||
#include "internal.h"
|
||||
#include <limits.h>
|
||||
|
||||
#define CL_PACKAGE 0
|
||||
#define SI_PACKAGE 4
|
||||
|
|
|
|||
|
|
@ -382,13 +382,11 @@ ONCE_MORE:
|
|||
obj->cblock.data_text_size = 0;
|
||||
obj->cblock.links = OBJNULL;
|
||||
break;
|
||||
#ifdef ECL_FFI
|
||||
case t_foreign:
|
||||
obj->foreign.tag = Cnil;
|
||||
obj->foreign.size = 0;
|
||||
obj->foreign.data = NUL;;
|
||||
break;
|
||||
#endif
|
||||
default:
|
||||
printf("\ttype = %d\n", t);
|
||||
error("alloc botch.");
|
||||
|
|
@ -696,9 +694,7 @@ init_alloc(void)
|
|||
#else
|
||||
init_tm(t_instance, "IINSTANCE", sizeof(struct ecl_instance), 32);
|
||||
#endif /* CLOS */
|
||||
#ifdef ECL_FFI
|
||||
init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1);
|
||||
#endif
|
||||
#ifdef ECL_THREADS
|
||||
init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2);
|
||||
init_tm(t_process, "tLOCK", sizeof(struct ecl_lock), 2);
|
||||
|
|
|
|||
|
|
@ -186,9 +186,7 @@ init_alloc(void)
|
|||
#else
|
||||
init_tm(t_instance, "INSTANCE", sizeof(struct ecl_instance));
|
||||
#endif /* CLOS */
|
||||
#ifdef ECL_FFI
|
||||
init_tm(t_instance, "FOREIGN", sizeof(struct ecl_foreign));
|
||||
#endif
|
||||
init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign));
|
||||
#ifdef ECL_THREADS
|
||||
init_tm(t_process, "PROCESS", sizeof(struct ecl_process));
|
||||
init_tm(t_lock, "LOCK", sizeof(struct ecl_lock));
|
||||
|
|
|
|||
296
src/c/ffi.d
296
src/c/ffi.d
|
|
@ -14,7 +14,41 @@
|
|||
|
||||
#include "ecl.h"
|
||||
|
||||
#ifdef ECL_FFI
|
||||
cl_object
|
||||
ecl_make_foreign_data(cl_object tag, cl_index size, void *data)
|
||||
{
|
||||
cl_object output = cl_alloc_object(t_foreign);
|
||||
output->foreign.tag = tag == Cnil ? @':void' : tag;
|
||||
output->foreign.size = size;
|
||||
output->foreign.data = (char*)data;
|
||||
return output;
|
||||
}
|
||||
|
||||
cl_object
|
||||
ecl_allocate_foreign_data(cl_object tag, cl_index size)
|
||||
{
|
||||
cl_object output = cl_alloc_object(t_foreign);
|
||||
output->foreign.tag = tag;
|
||||
output->foreign.size = size;
|
||||
output->foreign.data = (char*)cl_alloc_atomic(size);
|
||||
return output;
|
||||
}
|
||||
|
||||
void *
|
||||
ecl_foreign_data_pointer_safe(cl_object f)
|
||||
{
|
||||
if (type_of(f) != t_foreign)
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
return f->foreign.data;
|
||||
}
|
||||
|
||||
char *
|
||||
ecl_string_pointer_safe(cl_object f)
|
||||
{
|
||||
if (type_of(f) != t_string)
|
||||
FEwrong_type_argument(@'string', f);
|
||||
return f->string.self;
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_allocate_foreign_data(cl_object tag, cl_object size)
|
||||
|
|
@ -30,40 +64,274 @@ si_allocate_foreign_data(cl_object tag, cl_object size)
|
|||
cl_object
|
||||
si_free_foreign_data(cl_object f)
|
||||
{
|
||||
if (type_of(f) != t_foreign)
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
if (f->foreign.size)
|
||||
}
|
||||
if (f->foreign.size) {
|
||||
cl_dealloc(f->foreign.data, f->foreign.size);
|
||||
}
|
||||
f->foreign.size = 0;
|
||||
f->foreign.data = NULL;
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_foreign_data_address(cl_object f)
|
||||
{
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
@(return make_unsigned_integer((cl_index)f->foreign.data))
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_foreign_data_tag(cl_object f)
|
||||
{
|
||||
if (type_of(f) != t_foreign)
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
@(return f->foreign.tag);
|
||||
}
|
||||
|
||||
cl_object
|
||||
ecl_make_foreign_data(cl_object tag, cl_index size, void *data)
|
||||
si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize,
|
||||
cl_object tag)
|
||||
{
|
||||
cl_object output = cl_alloc_object(t_foreign);
|
||||
cl_index ndx = fixnnint(andx);
|
||||
cl_index size = fixnnint(asize);
|
||||
cl_object output;
|
||||
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
if (ndx >= f->foreign.size || (f->foreign.size - ndx) < size) {
|
||||
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
|
||||
}
|
||||
output = cl_alloc_object(t_foreign);
|
||||
output->foreign.tag = tag;
|
||||
output->foreign.size = size;
|
||||
output->foreign.data = (char*)data;
|
||||
return output;
|
||||
output->foreign.data = f->foreign.data + ndx;
|
||||
@(return output)
|
||||
}
|
||||
|
||||
void *
|
||||
ecl_foreign_data_pointer_safe(cl_object f, cl_object tag)
|
||||
cl_object
|
||||
si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag)
|
||||
{
|
||||
cl_index ndx = fixnnint(andx);
|
||||
cl_index size = fixnnint(asize);
|
||||
cl_object output;
|
||||
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
if (ndx >= f->foreign.size || (f->foreign.size - ndx) < size) {
|
||||
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
|
||||
}
|
||||
output = ecl_allocate_foreign_data(tag, size);
|
||||
memcpy(output->foreign.data, f->foreign.data + ndx, size);
|
||||
@(return output)
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_foreign_data_set(cl_object f, cl_object andx, cl_object value)
|
||||
{
|
||||
cl_index ndx = fixnnint(andx);
|
||||
cl_index size, limit;
|
||||
cl_object output;
|
||||
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
if (type_of(value) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', value);
|
||||
}
|
||||
size = value->foreign.size;
|
||||
limit = f->foreign.size;
|
||||
if (ndx >= limit || (limit - ndx) < size) {
|
||||
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
|
||||
}
|
||||
memcpy(f->foreign.data + ndx, value->foreign.data, size);
|
||||
@(return value)
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object tag)
|
||||
{
|
||||
cl_object output;
|
||||
cl_index ndx = fixnnint(andx);
|
||||
cl_index limit = f->foreign.size;
|
||||
void *p;
|
||||
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
if (ndx >= limit) {
|
||||
ERROR: FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
|
||||
}
|
||||
p = (void*)(f->foreign.data + ndx);
|
||||
if (tag == @':byte') {
|
||||
if (ndx + sizeof(int8_t) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(int8_t *)p);
|
||||
} else if (tag == @':unsigned-byte') {
|
||||
if (ndx + sizeof(uint8_t) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(uint8_t *)p);
|
||||
} else if (tag == @':char') {
|
||||
if (ndx + sizeof(char) > limit) goto ERROR;
|
||||
output = CODE_CHAR(*(char *)p);
|
||||
} else if (tag == @':unsigned-char') {
|
||||
if (ndx + sizeof(unsigned char) > limit) goto ERROR;
|
||||
output = CODE_CHAR(*(unsigned char *)p);
|
||||
} else if (tag == @':short') {
|
||||
if (ndx + sizeof(short) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(short *)p);
|
||||
} else if (tag == @':unsigned-short') {
|
||||
if (ndx + sizeof(unsigned short) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(unsigned short *)p);
|
||||
} else if (tag == @':int') {
|
||||
if (ndx + sizeof(int) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(int *)p);
|
||||
} else if (tag == @':unsigned-int') {
|
||||
if (ndx + sizeof(unsigned int) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(unsigned int *)p);
|
||||
} else if (tag == @':long') {
|
||||
if (ndx + sizeof(long) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(long *)p);
|
||||
} else if (tag == @':unsigned-long') {
|
||||
if (ndx + sizeof(unsigned long) > limit) goto ERROR;
|
||||
output = MAKE_FIXNUM(*(unsigned long *)p);
|
||||
} else if (tag == @':pointer-void') {
|
||||
if (ndx + sizeof(void *) > limit) goto ERROR;
|
||||
output = ecl_make_foreign_data(@':pointer-void', 0, *(void **)p);
|
||||
} else if (tag == @':object') {
|
||||
if (ndx + sizeof(cl_object) > limit) goto ERROR;
|
||||
output = *(cl_object *)p;
|
||||
} else if (tag == @':float') {
|
||||
if (ndx + sizeof(float) > limit) goto ERROR;
|
||||
output = make_shortfloat(*(float *)p);
|
||||
} else if (tag == @':double') {
|
||||
if (ndx + sizeof(double) > limit) goto ERROR;
|
||||
output = make_longfloat(*(double *)p);
|
||||
} else {
|
||||
FEerror("~A does not denote a foreign type.", 1, tag);
|
||||
}
|
||||
@(return output)
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object tag, cl_object value)
|
||||
{
|
||||
cl_object output;
|
||||
cl_index ndx = fixnnint(andx);
|
||||
cl_index limit = f->foreign.size;
|
||||
void *p;
|
||||
|
||||
if (type_of(f) != t_foreign) {
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
}
|
||||
if (ndx >= limit) {
|
||||
ERROR: FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
|
||||
}
|
||||
p = (void*)(f->foreign.data + ndx);
|
||||
if (tag == @':byte') {
|
||||
if (ndx + sizeof(int8_t) > limit) goto ERROR;
|
||||
*(int8_t *)p = fixint(value);
|
||||
} else if (tag == @':unsigned-byte') {
|
||||
if (ndx + sizeof(uint8_t) > limit) goto ERROR;
|
||||
*(uint8_t *)p = fixnnint(value);
|
||||
} else if (tag == @':char') {
|
||||
if (ndx + sizeof(char) > limit) goto ERROR;
|
||||
*(char *)p = char_code(value);
|
||||
} else if (tag == @':unsigned-char') {
|
||||
if (ndx + sizeof(unsigned char) > limit) goto ERROR;
|
||||
*(unsigned char*)p = char_code(value);
|
||||
} else if (tag == @':short') {
|
||||
if (ndx + sizeof(short) > limit) goto ERROR;
|
||||
*(short *)p = fixint(value);
|
||||
} else if (tag == @':unsigned-short') {
|
||||
if (ndx + sizeof(unsigned short) > limit) goto ERROR;
|
||||
*(unsigned short *)p = fixnnint(value);
|
||||
} else if (tag == @':int') {
|
||||
if (ndx + sizeof(int) > limit) goto ERROR;
|
||||
*(int *)p = fixint(value);
|
||||
} else if (tag == @':unsigned-int') {
|
||||
if (ndx + sizeof(unsigned int) > limit) goto ERROR;
|
||||
*(unsigned int *)p = fixnnint(value);
|
||||
} else if (tag == @':long') {
|
||||
if (ndx + sizeof(long) > limit) goto ERROR;
|
||||
*(long *)p = fixint(value);
|
||||
} else if (tag == @':unsigned-long') {
|
||||
if (ndx + sizeof(unsigned long) > limit) goto ERROR;
|
||||
*(unsigned long *)p = fixnnint(value);
|
||||
} else if (tag == @':pointer-void') {
|
||||
if (ndx + sizeof(void *) > limit) goto ERROR;
|
||||
*(void **)p = ecl_foreign_data_pointer_safe(value);
|
||||
} else if (tag == @':object') {
|
||||
if (ndx + sizeof(cl_object) > limit) goto ERROR;
|
||||
*(cl_object *)p = value;
|
||||
} else if (tag == @':float') {
|
||||
if (ndx + sizeof(float) > limit) goto ERROR;
|
||||
*(float *)p = object_to_float(value);
|
||||
} else if (tag == @':double') {
|
||||
if (ndx + sizeof(double) > limit) goto ERROR;
|
||||
*(double *)p = object_to_double(value);
|
||||
} else {
|
||||
FEerror("~A does not denote a foreign type.", 1, tag);
|
||||
}
|
||||
@(return output)
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_size_of_foreign_elt_type(cl_object tag)
|
||||
{
|
||||
cl_fixnum size;
|
||||
|
||||
if (tag == @':byte') {
|
||||
size = sizeof(int8_t);
|
||||
} else if (tag == @':unsigned-byte') {
|
||||
size = sizeof(uint8_t);
|
||||
} else if (tag == @':char') {
|
||||
size = sizeof(char);
|
||||
} else if (tag == @':unsigned-char') {
|
||||
size = sizeof(unsigned char);
|
||||
} else if (tag == @':short') {
|
||||
size = sizeof(short);
|
||||
} else if (tag == @':unsigned-short') {
|
||||
size = sizeof(unsigned short);
|
||||
} else if (tag == @':int') {
|
||||
size = sizeof(int);
|
||||
} else if (tag == @':unsigned-int') {
|
||||
size = sizeof(unsigned int);
|
||||
} else if (tag == @':long') {
|
||||
size = sizeof(long);
|
||||
} else if (tag == @':unsigned-long') {
|
||||
size = sizeof(unsigned long);
|
||||
} else if (tag == @':pointer-void') {
|
||||
size = sizeof(void *);
|
||||
} else if (tag == @':object') {
|
||||
size = sizeof(cl_object);
|
||||
} else if (tag == @':float') {
|
||||
size = sizeof(float);
|
||||
} else if (tag == @':double') {
|
||||
size = sizeof(double);
|
||||
} else {
|
||||
FEerror("~A does not denote a foreign type.", 1, tag);
|
||||
}
|
||||
@(return MAKE_FIXNUM(size))
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_null_pointer_p(cl_object f)
|
||||
{
|
||||
if (type_of(f) != t_foreign)
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
if (f->foreign.tag != tag)
|
||||
FEwrong_type_argument(cl_list(2, @'si::foreign-data', tag), f);
|
||||
return f->foreign.data;
|
||||
@(return ((f->foreign.data == NULL)? Ct : Cnil))
|
||||
}
|
||||
|
||||
#endif /* ECL_FFI */
|
||||
cl_object
|
||||
si_foreign_data_recast(cl_object f, cl_object size, cl_object tag)
|
||||
{
|
||||
if (type_of(f) != t_foreign)
|
||||
FEwrong_type_argument(@'si::foreign-data', f);
|
||||
f->foreign.size = fixnnint(size);
|
||||
f->foreign.tag = tag;
|
||||
@(return f)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -375,13 +375,11 @@ BEGIN:
|
|||
i = x->cblock.data_size;
|
||||
p = x->cblock.data;
|
||||
goto MARK_DATA;
|
||||
#ifdef ECL_FFI
|
||||
case t_foreign:
|
||||
if (x->foreign.size)
|
||||
mark_contblock(x->foreign.data, x->foreign.size);
|
||||
mark_next(x->foreign.tag);
|
||||
break;
|
||||
#endif /* ECL_FFI */
|
||||
MARK_DATA:
|
||||
if (p) {
|
||||
mark_contblock(p, i * sizeof(cl_object));
|
||||
|
|
|
|||
|
|
@ -260,10 +260,8 @@ cl_class_of(cl_object x)
|
|||
case t_cfun:
|
||||
case t_cclosure:
|
||||
t = @'function'; break;
|
||||
#ifdef ECL_FFI
|
||||
case t_foreign:
|
||||
t = @'si::foreign-data'; break;
|
||||
#endif
|
||||
#ifdef ECL_THREADS
|
||||
case t_process:
|
||||
t = @'mp::process'; break;
|
||||
|
|
|
|||
|
|
@ -311,7 +311,8 @@ cl_boot(int argc, char **argv)
|
|||
make_keyword("COMMON"),
|
||||
make_keyword("ANSI-CL"),
|
||||
make_keyword("COMMON-LISP"),
|
||||
make_keyword(ECL_ARCHITECTURE));
|
||||
make_keyword(ECL_ARCHITECTURE),
|
||||
make_keyword("FFI"));
|
||||
|
||||
#define ADD_FEATURE(name) features = CONS(make_keyword(name),features)
|
||||
|
||||
|
|
@ -333,9 +334,6 @@ cl_boot(int argc, char **argv)
|
|||
#ifdef PDE
|
||||
ADD_FEATURE("PDE");
|
||||
#endif
|
||||
#ifdef ECL_FFI
|
||||
ADD_FEATURE("FFI");
|
||||
#endif
|
||||
#ifdef unix
|
||||
ADD_FEATURE("UNIX");
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -340,6 +340,9 @@ BEGIN:
|
|||
equal(x->pathname.type, y->pathname.type) &&
|
||||
equal(x->pathname.version, y->pathname.version));
|
||||
|
||||
case t_foreign:
|
||||
return (x->foreign.data == y->foreign.data);
|
||||
|
||||
default:
|
||||
return(eql(x,y));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1152,7 +1152,6 @@ _write_object(cl_object x, int level)
|
|||
call_print_object(x, level);
|
||||
break;
|
||||
#endif /* CLOS */
|
||||
#ifdef ECL_FFI
|
||||
case t_foreign:
|
||||
if (cl_env.print_readably) FEprint_not_readable(x);
|
||||
write_str("#<foreign ");
|
||||
|
|
@ -1160,7 +1159,6 @@ _write_object(cl_object x, int level)
|
|||
write_addr(x->foreign.data);
|
||||
write_ch('>');
|
||||
break;
|
||||
#endif /* ECL_FFI */
|
||||
#ifdef ECL_THREADS
|
||||
case t_process:
|
||||
if (cl_env.print_readably) FEprint_not_readable(x);
|
||||
|
|
|
|||
|
|
@ -1351,12 +1351,51 @@ cl_symbols[] = {
|
|||
{EXT_ "INSTANCE", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
#endif
|
||||
|
||||
#ifdef ECL_FFI
|
||||
{SYS_ "ALLOCATE-FOREIGN-DATA", SI_ORDINARY, si_allocate_foreign_data, 2, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-ADDRESS", SI_ORDINARY, si_foreign_data_address, 1, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-POINTER", SI_ORDINARY, si_foreign_data_pointer, 4, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-RECAST", SI_ORDINARY, si_foreign_data_recast, 3, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-REF", SI_ORDINARY, si_foreign_data_ref, 4, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-REF-ELT", SI_ORDINARY, si_foreign_data_ref_elt, 3, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-SET", SI_ORDINARY, si_foreign_data_set, 3, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-SET-ELT", SI_ORDINARY, si_foreign_data_set_elt, 4, OBJNULL},
|
||||
{SYS_ "FOREIGN-DATA-TAG", SI_ORDINARY, si_foreign_data_tag, 1, OBJNULL},
|
||||
{SYS_ "FREE-FOREIGN-DATA", SI_ORDINARY, si_free_foreign_data, 1, OBJNULL},
|
||||
#endif
|
||||
{SYS_ "NULL-POINTER-P", SI_ORDINARY, si_null_pointer_p, 1, OBJNULL},
|
||||
{SYS_ "SIZE-OF-FOREIGN-ELT-TYPE", SI_ORDINARY, si_size_of_foreign_elt_type, 1, OBJNULL},
|
||||
{KEY_ "ARRAY", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "BYTE", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "CHAR", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "DOUBLE", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "FIXNUM", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "FLOAT", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "INT", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "LONG", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "POINTER-SELF", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "POINTER-VOID", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "SHORT", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "STRUCT", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "UNION", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "VOID", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "UNSIGNED-BYTE", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "UNSIGNED-CHAR", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "UNSIGNED-INT", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "UNSIGNED-LONG", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "UNSIGNED-SHORT", KEYWORD, NULL, -1, OBJNULL},
|
||||
{SYS_ "C-CHAR-BIT", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(CHAR_BIT)},
|
||||
{SYS_ "C-CHAR-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(CHAR_MAX)},
|
||||
{SYS_ "C-CHAR-MIN", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(CHAR_MIN)},
|
||||
{SYS_ "C-INT-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(INT_MAX)},
|
||||
{SYS_ "C-INT-MIN", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(INT_MIN)},
|
||||
{SYS_ "C-SHORT-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(SHRT_MAX)},
|
||||
{SYS_ "C-SHORT-MIN", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(SHRT_MIN)},
|
||||
{SYS_ "C-LONG-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(LONG_MAX)},
|
||||
{SYS_ "C-LONG-MIN", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(LONG_MAX)},
|
||||
{SYS_ "C-UCHAR-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(UCHAR_MAX)},
|
||||
{SYS_ "C-UINT-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(UINT_MAX)},
|
||||
{SYS_ "C-USHORT-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(USHRT_MAX)},
|
||||
{SYS_ "C-ULONG-MAX", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(ULONG_MAX)},
|
||||
|
||||
#ifdef GBC_BOEHM
|
||||
{SYS_ "GC", SI_ORDINARY, si_gc, 1, OBJNULL},
|
||||
|
|
|
|||
|
|
@ -346,10 +346,8 @@ cl_type_of(cl_object x)
|
|||
case t_cclosure:
|
||||
t = @'function'; break;
|
||||
|
||||
#ifdef ECL_FFI
|
||||
case t_foreign:
|
||||
t = @'si::foreign-data'; break;
|
||||
#endif
|
||||
#ifdef ECL_THREADS
|
||||
case t_process:
|
||||
t = @'mp::process'; break;
|
||||
|
|
|
|||
|
|
@ -271,7 +271,7 @@
|
|||
(defun call-loc-fixed (fname fun args narg-loc maxarg)
|
||||
(cond ((not (eq 'ARGS-PUSHED args))
|
||||
(when (/= (length args) maxarg)
|
||||
(error "Too many arguments to function ~S." fname))
|
||||
(cmperr "Wrong number of arguments to function ~S." fname))
|
||||
(list 'CALL-FIX fun (coerce-locs args) fname))
|
||||
((stringp fun)
|
||||
(wt "if(" narg-loc "!=" maxarg ") FEwrong_num_arguments_anonym();")
|
||||
|
|
|
|||
|
|
@ -16,26 +16,38 @@
|
|||
;;
|
||||
|
||||
(defconstant +representation-types+
|
||||
'(:byte ((signed-byte 8) "byte")
|
||||
'(;; These types can be used by ECL to unbox data
|
||||
;; They are sorted from the most specific, to the least specific one.
|
||||
:byte ((signed-byte 8) "byte")
|
||||
:unsigned-byte ((unsigned-byte 8) "unsigned byte")
|
||||
:fixnum (fixnum "cl_fixnum")
|
||||
:int ((signed-byte 32) "int")
|
||||
:unsigned-int ((unsigned-byte 32) "unsigned int")
|
||||
:long ((signed-byte 32) "long")
|
||||
:unsigned-long ((unsigned-byte 32) "unsigned long")
|
||||
:int ((integer #.si:c-int-min #.si:c-int-max) "int")
|
||||
:unsigned-int ((integer 0 #.si:c-uint-max) "unsigned int")
|
||||
:long ((integer #.si:c-long-min #.si:c-long-max) "long")
|
||||
:unsigned-long ((integer 0 #.si:c-ulong-max) "unsigned long")
|
||||
:cl-index ((integer 0 #.most-positive-fixnum) "cl_index")
|
||||
:float (short-float "float")
|
||||
:double (long-float "double")
|
||||
:char (character "char")
|
||||
:unsigned-char (character "char")
|
||||
:void (nil "void")
|
||||
:object (t "cl_object")
|
||||
:bool (t "bool")))
|
||||
:bool (t "bool")
|
||||
;; These types are never selected to unbox data.
|
||||
;; They are here, because we need to know how to print them.
|
||||
:void (nil "void")
|
||||
:pointer-void (nil "void*")
|
||||
:cstring (nil "char*")
|
||||
:short ((integer #.si:c-short-min #.si:c-short-max) "short")
|
||||
:unsigned-short ((integer 0 #.si:c-short-max) "unsigned short")
|
||||
))
|
||||
|
||||
|
||||
(defun rep-type->lisp-type (rep-type)
|
||||
(let ((output (getf +representation-types+ rep-type)))
|
||||
(cond (output (first output))
|
||||
(cond (output
|
||||
(or (first output)
|
||||
(error "Representation type ~S cannot be coerced to lisp"
|
||||
rep-type)))
|
||||
((lisp-type-p rep-type) rep-type)
|
||||
(t (error "Unknown representation type ~S" rep-type)))))
|
||||
|
||||
|
|
@ -49,7 +61,7 @@
|
|||
|
||||
(defun rep-type-name (type)
|
||||
(or (second (getf +representation-types+ type))
|
||||
(error "Unknown type name ~S found in compiled expression" type)))
|
||||
(error "Not a valid type name ~S" type)))
|
||||
|
||||
(defun lisp-type-p (type)
|
||||
(subtypep type 'T))
|
||||
|
|
@ -179,8 +191,31 @@
|
|||
(wt "((" loc ")?Ct:Cnil)"))
|
||||
((:char :unsigned-char)
|
||||
(wt "CODE_CHAR(" loc ")"))
|
||||
((:cstring)
|
||||
(wt "make_string_copy(" loc ")"))
|
||||
((:pointer-void)
|
||||
(wt "ecl_make_foreign_data(Cnil, 0, " loc ")"))
|
||||
(otherwise
|
||||
(coercion-error))))
|
||||
((:pointer-void)
|
||||
(case loc-rep-type
|
||||
((:object)
|
||||
;; Only foreign data types can be coerced to a pointer
|
||||
(wt "ecl_foreign_data_pointer_safe(" loc ")"))
|
||||
((:cstring)
|
||||
(wt "(char *)(" loc ")"))
|
||||
(otherwise
|
||||
(coercion-error))))
|
||||
((:cstring)
|
||||
(case loc-rep-type
|
||||
((:object)
|
||||
(if (safe-compile)
|
||||
(wt "ecl_string_pointer_safe(" loc ")")
|
||||
(wt "(" loc ")->string.self")))
|
||||
((:pointer-void)
|
||||
(wt "(char *)(" loc ")"))
|
||||
(otherwise
|
||||
(coercion error))))
|
||||
(t
|
||||
(coercion-error))))))
|
||||
|
||||
|
|
@ -190,8 +225,9 @@
|
|||
;;
|
||||
|
||||
(defun c1c-inline (args)
|
||||
;; We are on the safe side by assuming that the form has side effects
|
||||
(destructuring-bind (arguments arg-types output-type c-expression
|
||||
&key side-effects one-liner
|
||||
&key (side-effects t) one-liner
|
||||
&aux output-rep-type)
|
||||
args
|
||||
(if (lisp-type-p output-type)
|
||||
|
|
@ -307,9 +343,8 @@
|
|||
(wt (add-object object))))))
|
||||
(#\#
|
||||
(let* ((k (char-downcase (read-char s)))
|
||||
(index (- (char-code k)
|
||||
(char-code (if (char<= #\0 k #\9) #\0 #\a)))))
|
||||
(when (or (< index 0) (>= index (length coerced-arguments)))
|
||||
(index (digit-char-p k 36)))
|
||||
(unless (and index (< index (length coerced-arguments)))
|
||||
(cmperr "C-INLINE: Variable code exceeds number of arguments"))
|
||||
(wt (nth index coerced-arguments))))
|
||||
(otherwise
|
||||
|
|
|
|||
14
src/configure
vendored
14
src/configure
vendored
|
|
@ -873,7 +873,6 @@ Optional Packages:
|
|||
--with-oldloop Use the old MIT LOOP macro.
|
||||
--with-cmuformat Use the FORMAT routine from CMUCL.
|
||||
--with-clos-streams Allow user defined stream objects.
|
||||
--with-ffi Run-time foreign data manipulation.
|
||||
--with-cxx Build ECL using C++ compiler.
|
||||
--with-x use the X Window System
|
||||
|
||||
|
|
@ -1477,12 +1476,6 @@ if test "${with_clos_streams+set}" = set; then
|
|||
closstreams="yes"
|
||||
fi;
|
||||
|
||||
# Check whether --with-ffi or --without-ffi was given.
|
||||
if test "${with_ffi+set}" = set; then
|
||||
withval="$with_ffi"
|
||||
ffi="yes"
|
||||
fi;
|
||||
|
||||
# Check whether --with-cxx or --without-cxx was given.
|
||||
if test "${with_cxx+set}" = set; then
|
||||
withval="$with_cxx"
|
||||
|
|
@ -4400,13 +4393,6 @@ if test "${closstreams}"; then
|
|||
#define ECL_CLOS_STREAMS 1
|
||||
_ACEOF
|
||||
|
||||
fi
|
||||
if test "${ffi}"; then
|
||||
cat >>confdefs.h <<\_ACEOF
|
||||
#define ECL_FFI 1
|
||||
_ACEOF
|
||||
|
||||
EXTRA_OBJS="${EXTRA_OBJS} ffi.${OBJEXT}"
|
||||
fi
|
||||
if test "${locative}" ; then
|
||||
EXTRA_OBJS="${EXTRA_OBJS} unify.${OBJEXT}"
|
||||
|
|
|
|||
|
|
@ -93,9 +93,6 @@ AC_ARG_WITH(cmuformat,
|
|||
AC_ARG_WITH(clos-streams,
|
||||
[--with-clos-streams Allow user defined stream objects.],
|
||||
closstreams="yes")
|
||||
AC_ARG_WITH(ffi,
|
||||
[--with-ffi Run-time foreign data manipulation.],
|
||||
ffi="yes")
|
||||
AC_ARG_WITH(cxx,
|
||||
[--with-cxx Build ECL using C++ compiler.],
|
||||
usecxx="${withval}",usecxx="no")
|
||||
|
|
@ -241,10 +238,6 @@ fi
|
|||
if test "${closstreams}"; then
|
||||
AC_DEFINE(ECL_CLOS_STREAMS)
|
||||
fi
|
||||
if test "${ffi}"; then
|
||||
AC_DEFINE(ECL_FFI)
|
||||
EXTRA_OBJS="${EXTRA_OBJS} ffi.${OBJEXT}"
|
||||
fi
|
||||
if test "${locative}" ; then
|
||||
EXTRA_OBJS="${EXTRA_OBJS} unify.${OBJEXT}"
|
||||
AC_DEFINE(LOCATIVE)
|
||||
|
|
|
|||
|
|
@ -1,49 +0,0 @@
|
|||
;;; -*- Mode: Lisp; Package: USER; Base: 10; Syntax: Common-Lisp -*-
|
||||
|
||||
(in-package "COMMON-LISP-USER")
|
||||
|
||||
(load "sys:cmp.so")
|
||||
|
||||
;;; Aid function:
|
||||
|
||||
(defvar *only-load* nil)
|
||||
|
||||
;;; Then compile and load the true system:
|
||||
|
||||
(proclaim '(optimize (safety 2) (speed 1)))
|
||||
|
||||
(let* ((files (list
|
||||
"split-sequence"
|
||||
"package"
|
||||
"depdefs"
|
||||
"clx"
|
||||
"dependent"
|
||||
"macros" ; these are just macros
|
||||
"bufmac" ; these are just macros
|
||||
"buffer"
|
||||
"display"
|
||||
"gcontext"
|
||||
"input"
|
||||
"requests"
|
||||
"fonts"
|
||||
"graphics"
|
||||
"text"
|
||||
"attributes"
|
||||
"translate"
|
||||
"keysyms"
|
||||
"manager"
|
||||
"image"
|
||||
"resource"))
|
||||
(objects (mapcar #'(lambda (x)
|
||||
(load (setq x (merge-pathnames ".lisp" x)))
|
||||
(unless *only-load*
|
||||
(compile-file x :system-p t)))
|
||||
files)))
|
||||
(unless *only-load*
|
||||
#-dlopen
|
||||
(c::build-static-library "eclx" :lisp-files objects)
|
||||
#+dlopen
|
||||
(c::build-shared-library "eclx" :lisp-files objects)))
|
||||
|
||||
;(load "clx2/demo/hello.lisp")
|
||||
;(xlib::hello-world "")
|
||||
|
|
@ -475,13 +475,23 @@ extern cl_object cl_safe_eval(cl_object form, cl_object env, cl_object err_value
|
|||
|
||||
/* ffi.c */
|
||||
|
||||
#ifdef ECL_FFI
|
||||
extern cl_object si_allocate_foreign_data(cl_object tag, cl_object size);
|
||||
extern cl_object si_free_foreign_data(cl_object x);
|
||||
extern cl_object si_foreign_data_address(cl_object f);
|
||||
extern cl_object si_foreign_data_pointer(cl_object f, cl_object ndx, cl_object size, cl_object tag);
|
||||
extern cl_object si_foreign_data_ref(cl_object f, cl_object ndx, cl_object size, cl_object tag);
|
||||
extern cl_object si_foreign_data_ref_elt(cl_object f, cl_object ndx, cl_object tag);
|
||||
extern cl_object si_foreign_data_set(cl_object f, cl_object ndx, cl_object value);
|
||||
extern cl_object si_foreign_data_set_elt(cl_object f, cl_object ndx, cl_object tag, cl_object value);
|
||||
extern cl_object si_foreign_data_tag(cl_object x);
|
||||
extern cl_object si_foreign_data_recast(cl_object f, cl_object size, cl_object tag);
|
||||
extern cl_object si_free_foreign_data(cl_object x);
|
||||
extern cl_object si_null_pointer_p(cl_object f);
|
||||
extern cl_object si_size_of_foreign_elt_type(cl_object tag);
|
||||
|
||||
extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data);
|
||||
extern void *ecl_foreign_data_pointer_safe(cl_object f, cl_object tag);
|
||||
#endif
|
||||
extern cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size);
|
||||
extern void *ecl_foreign_data_pointer_safe(cl_object f);
|
||||
extern char *ecl_string_pointer_safe(cl_object f);
|
||||
|
||||
/* file.c */
|
||||
|
||||
|
|
|
|||
|
|
@ -392,14 +392,12 @@ struct ecl_cclosure { /* compiled closure header */
|
|||
cl_object block; /* descriptor of C code block for GC */
|
||||
};
|
||||
|
||||
#ifdef ECL_FFI
|
||||
struct ecl_foreign { /* user defined datatype */
|
||||
HEADER;
|
||||
cl_object tag; /* a tag identifying the type */
|
||||
cl_index size; /* the amount of memory allocated */
|
||||
char *data; /* the data itself */
|
||||
};
|
||||
#endif
|
||||
|
||||
/*
|
||||
dummy type
|
||||
|
|
@ -478,9 +476,7 @@ union cl_lispunion {
|
|||
struct ecl_lock lock; /* lock */
|
||||
#endif
|
||||
struct ecl_codeblock cblock; /* codeblock */
|
||||
#ifdef ECL_FFI
|
||||
struct ecl_foreign foreign; /* user defined data type */
|
||||
#endif
|
||||
};
|
||||
|
||||
/*
|
||||
|
|
@ -522,9 +518,7 @@ typedef enum {
|
|||
t_lock,
|
||||
#endif
|
||||
t_codeblock, /* 21 */
|
||||
#ifdef ECL_FFI
|
||||
t_foreign, /* 22 */
|
||||
#endif
|
||||
t_end,
|
||||
t_other,
|
||||
t_contiguous, /* contiguous block */
|
||||
|
|
|
|||
|
|
@ -114,7 +114,7 @@ number is zero. The optional X is simply ignored."
|
|||
bytecodes cfun cclosure
|
||||
#-clos structure #+clos instance #+clos generic-function
|
||||
#+threads mp::process #+threads mp::lock
|
||||
#+ffi si::foreign))
|
||||
si::foreign))
|
||||
(tl type-list (cdr tl))
|
||||
(i 0 (+ i (if (nth 2 l) (nth 2 l) 0))))
|
||||
((null l) (setq npage i))
|
||||
|
|
|
|||
|
|
@ -23,7 +23,11 @@ The complete syntax of a lambda-list is:
|
|||
The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be
|
||||
retrieved by (documentation 'NAME 'function)."
|
||||
(multiple-value-setq (body doc-string) (remove-documentation body))
|
||||
(let* ((function `#'(ext::lambda-block ,name ,vl ,@body)))
|
||||
(let* ((block-name (if (and (consp name)
|
||||
(eq (first name) 'setf))
|
||||
(second name)
|
||||
name))
|
||||
(function `#'(ext::lambda-block ,block-name ,vl ,@body)))
|
||||
(when *dump-defun-definitions*
|
||||
(print function)
|
||||
(setq function `(si::bc-disassemble ,function)))
|
||||
|
|
@ -82,9 +86,6 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)."
|
|||
`(PROGN (SYS:*MAKE-SPECIAL ',var)
|
||||
,@(si::expand-set-documentation var 'variable doc-string)
|
||||
(SETQ ,var ,form)
|
||||
(EVAL-WHEN (COMPILE) ; Beppe
|
||||
(WHEN ,(CONSTANTP form)
|
||||
(PROCLAIM '(TYPE ,(type-of form) ,var))))
|
||||
; (eval-when (load eval) ; Beppe
|
||||
; (compiler::proclaim-var (type-of ,var) ',var))
|
||||
#+PDE (SYS:RECORD-SOURCE-PATHNAME ',var 'DEFPARAMETER)
|
||||
|
|
|
|||
|
|
@ -1,112 +0,0 @@
|
|||
;;;; Copyright (c) 2001, Juan Jose Garcia-Ripoll
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
;;;; Routines to handle foreign objects, structures, arrays, etc.
|
||||
|
||||
(in-package "FFI")
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; OPERATIONS WITH FOREIGN TYPES
|
||||
;;
|
||||
|
||||
(defmacro def-foreign-type (name type)
|
||||
`(si::set-sysprop ',name 'FOREIGN-TYPE ',type))
|
||||
|
||||
(defun basic-foreign-type-size (type)
|
||||
(case type
|
||||
((:unsigned-char :char :byte :unsigned-byte) 1)
|
||||
((:short :unsigned-short) 2)
|
||||
((:int :unsigned-int) 4)
|
||||
((:long :unsigned-long) 4)
|
||||
((:float) 4)
|
||||
((:double) 8)
|
||||
((:pointer-void) 4)
|
||||
(:void 0)
|
||||
(t (error-foreign-type type))))
|
||||
|
||||
(defun error-foreign-type (type)
|
||||
(error 'simple-type-error
|
||||
:format-control "~S is not a valid foreign type"
|
||||
:format-args (list type)
|
||||
:datum type
|
||||
:expected-type 'FOREIGN-TYPE))
|
||||
|
||||
(defun compute-foreign-type-size (type &aux name args)
|
||||
(if (symbolp type)
|
||||
(if (setq args (si::get-sysprop type 'FOREIGN-TYPE))
|
||||
(compute-foreign-type-size type)
|
||||
(basic-foreign-type-size type))
|
||||
(case (first type)
|
||||
(* (basic-foreign-type-size :pointer-void))
|
||||
(:struct
|
||||
(reduce #'+ (rest type) :key #'second :initial-value 0))
|
||||
(:union
|
||||
(reduce #'max (rest type) :initial-value 0))
|
||||
(:enum
|
||||
(basic-foreign-type-size :int))
|
||||
(:array
|
||||
(let ((elt-type-size (compute-foreign-type-size (second type))))
|
||||
(unless (integerp (third type))
|
||||
(error-foreign-type type))
|
||||
(* elt-type-size (third type)))))))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; ENUMERATIONS
|
||||
;;
|
||||
|
||||
(defmacro def-enum (enum-name &optional keys &key (separator-string "#"))
|
||||
(let ((counter 0)
|
||||
(output '())
|
||||
(name))
|
||||
(dolist (i keys)
|
||||
(cond ((symbolp i) (setq name i))
|
||||
((listp i) (setq name (first i) counter (second i))))
|
||||
(unless (and (symbolp name) (integerp counter))
|
||||
(error "~S is not a valid enumeration key" (list name counter)))
|
||||
(setq name (intern (concatenate 'string
|
||||
(symbol-name enum-name)
|
||||
separator-string
|
||||
(symbol-name name))))
|
||||
(push (list name counter) output)
|
||||
(incf counter))
|
||||
`(progn
|
||||
(def-foreign-type ,enum-name (ENUM ,@output))
|
||||
,@(mapcar #'(lambda (x) (cons 'DEFCONSTANT x)) output))))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; ARRAYS
|
||||
;;
|
||||
|
||||
(defmacro def-array (name elt-type)
|
||||
`(def-foreign-type ,name (:array ,elt-type)))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; UTILITIES
|
||||
;;
|
||||
|
||||
(defun null-char-p (char)
|
||||
(or (eql char 0)
|
||||
(eql char (code-char 0))))
|
||||
|
||||
(defun ensure-char-character (char)
|
||||
(cond ((integerp char)
|
||||
(code-char char))
|
||||
((characterp char)
|
||||
char)
|
||||
(t
|
||||
(error 'simple-type-error :datum char :expected-type 'character))))
|
||||
|
||||
(defun ensure-char-integer (char)
|
||||
(cond ((integerp char)
|
||||
char)
|
||||
((characterp char)
|
||||
(char-code char))
|
||||
(t
|
||||
(error 'simple-type-error :datum char :expected-type 'character))))
|
||||
|
||||
359
src/lsp/ffi.lsp
359
src/lsp/ffi.lsp
|
|
@ -26,10 +26,16 @@
|
|||
|
||||
(in-package "FFI")
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; FOREIGN TYPES
|
||||
;;;
|
||||
|
||||
(defvar *ffi-types* (make-hash-table :size 128))
|
||||
|
||||
(dolist (i '(clines defcfun defentry defla defcbody defunC))
|
||||
(let ((fname i))
|
||||
(si::fset i
|
||||
#'(lambda (x)
|
||||
#'(lambda (&rest x)
|
||||
(error "The special form ~S cannot be used in the interpreter"
|
||||
fname)))))
|
||||
|
||||
|
|
@ -42,3 +48,354 @@
|
|||
'((,arg-types ,type
|
||||
t ; side-effect-p
|
||||
nil ,code)))))
|
||||
|
||||
(defun foreign-elt-type-p (name)
|
||||
(and (symbolp name)
|
||||
(member name '(:byte :unsigned-byte :short :unsigned-short
|
||||
:int :unsigned-int :char :unsigned-char
|
||||
:long :unsigned-long :pointer-void :object
|
||||
:float :double)
|
||||
:test 'eq)))
|
||||
|
||||
(defmacro def-foreign-type (name definition)
|
||||
`(eval-when (compile load eval)
|
||||
(setf (gethash ',name ffi::*ffi-types*) ',definition)))
|
||||
|
||||
|
||||
(defun size-of-foreign-type (name)
|
||||
(let* ((size 0)
|
||||
(type (gethash name *ffi-types* name)))
|
||||
(unless type
|
||||
(error "Incomplete or unknown foreign type ~A" name))
|
||||
(cond ((symbolp type)
|
||||
(setf size (si::size-of-foreign-elt-type type)))
|
||||
((atom type)
|
||||
(error "~A is not a valid foreign type identifier" name))
|
||||
((eq (setf name (first type)) :struct)
|
||||
(setf size (slot-position type nil)))
|
||||
((eq name :array)
|
||||
(when (eq (setf size (second array)) '*)
|
||||
(error "Incomplete foreign type"))
|
||||
(setf size (* size (size-of-foreign-type (third array)))))
|
||||
((eq name '*)
|
||||
(si::size-of-foreign-elt-type :pointer-void))
|
||||
(t
|
||||
(error "~A does not denote a foreign type" name)))
|
||||
size))
|
||||
|
||||
(defun allocate-foreign-object (type &optional (size 0 size-flag))
|
||||
(declare (fixnum size))
|
||||
(let ((type-size (size-of-foreign-type type)))
|
||||
(cond ((null size-flag)
|
||||
(si::allocate-foreign-data type type-size))
|
||||
((>= size 0)
|
||||
(let ((bytes (* size type-size)))
|
||||
(si::allocate-foreign-data `(array ,size ,type) bytes)))
|
||||
(t
|
||||
(error "~A is not a valid array dimension size" size)))))
|
||||
|
||||
(defun free-foreign-object (ptr)
|
||||
(si::free-foreign-data ptr))
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; ENUMERATION TYPES
|
||||
;;;
|
||||
|
||||
(defmacro def-enum (name values-list &key (separator-string "#"))
|
||||
(let ((constants '())
|
||||
(value 0)
|
||||
field)
|
||||
(setf name (string name)
|
||||
separator-string (string separator-string))
|
||||
(dolist (item values-list)
|
||||
(cond ((symbolp item)
|
||||
(setf field (string item))
|
||||
(incf value))
|
||||
((and (consp item)
|
||||
(symbolp (setf field (first item)))
|
||||
(integerp (setf value (second item)))
|
||||
(endp (cddr item))))
|
||||
(t
|
||||
(error "Not a valid argument to DEF-ENUM~%~a" values-list)))
|
||||
(setf field (concatenate 'string
|
||||
(symbol-name name)
|
||||
separator-string
|
||||
field))
|
||||
(push `(defconstant ,(intern field (symbol-package name))
|
||||
',value)
|
||||
forms))
|
||||
`(progn
|
||||
(def-foreign-type ,name :int)
|
||||
,@forms)))
|
||||
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; STRUCTURE TYPES
|
||||
;;;
|
||||
;;; The structure type is represented by the following list:
|
||||
;;;
|
||||
;;; (STRUCT (SLOT-NAME1 . SLOT-TYPE1)*)
|
||||
;;;
|
||||
;;; FIXME! We do not care about slot alignment!
|
||||
;;;
|
||||
|
||||
(defmacro def-struct (name &rest slots)
|
||||
(let ((struct-type (list :struct))
|
||||
field
|
||||
type)
|
||||
(dolist (item (subst `(* ,struct-type) :pointer-self slots))
|
||||
(if (and (consp item)
|
||||
(= (length item) 2)
|
||||
(symbolp (setf field (first item))))
|
||||
(setf type (second item))
|
||||
(error "Not a valid DEF-STRUCT slot ~A" item))
|
||||
(push (cons field type) struct-type))
|
||||
`(def-foreign-type ,name ,(nreverse struct-type))))
|
||||
|
||||
(defun slot-position (type field)
|
||||
(setf type (gethash type *ffi-types* type))
|
||||
(let ((ndx 0)
|
||||
(is-union nil))
|
||||
(cond ((atom type)
|
||||
(error "~A is not a foreign STRUCT or UNION type" type))
|
||||
((eq (first type) :struct))
|
||||
((eq (first type) :union)
|
||||
(setf is-union t))
|
||||
(t
|
||||
(error "~A is not a foreign STRUCT or UNION type" type)))
|
||||
(dolist (slot (rest type))
|
||||
(let* ((slot-name (car slot))
|
||||
(slot-type (cdr slot))
|
||||
(slot-size (size-of-foreign-type slot-type)))
|
||||
(when (eq slot-name field)
|
||||
(return-from slot-position (values ndx slot-type slot-size)))
|
||||
(unless is-union
|
||||
(incf ndx slot-size))))
|
||||
(values ndx nil nil)))
|
||||
|
||||
(defun get-slot-value (object struct-type field)
|
||||
(multiple-value-bind (slot-ndx slot-type slot-size)
|
||||
(slot-position struct-type field)
|
||||
(unless slot-size
|
||||
(error "~A is not a field of the type ~A" field struct-type))
|
||||
(if (foreign-elt-type-p slot-type)
|
||||
(si::foreign-data-ref-elt object slot-ndx slot-type)
|
||||
(si::foreign-data-ref object slot-ndx slot-size slot-type))))
|
||||
|
||||
(defun (setf get-slot-value) (value object struct-type field)
|
||||
(multiple-value-bind (slot-ndx slot-type slot-size)
|
||||
(slot-position struct-type field)
|
||||
(unless slot-size
|
||||
(error "~A is not a field of the type ~A" field struct-type))
|
||||
(if (foreign-elt-type-p slot-type)
|
||||
(si::foreign-data-set-elt object slot-ndx slot-type value)
|
||||
(si::foreign-data-set object slot-ndx value))))
|
||||
|
||||
(defun get-slot-pointer (object struct-type field)
|
||||
(multiple-value-bind (slot-ndx slot-type slot-size)
|
||||
(slot-position struct-type field)
|
||||
(unless slot-size
|
||||
(error "~A is not a field of the type ~A" field struct-type))
|
||||
(si::foreign-data-pointer object ndx slot-size field-type)))
|
||||
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; ARRAYS
|
||||
;;;
|
||||
|
||||
(defmacro def-array-pointer (name element-type)
|
||||
`(def-foreign-type ,name (* (array * ,element-type))))
|
||||
|
||||
(defun deref-array (array array-type position)
|
||||
(let* ((element-type (third array-type))
|
||||
(element-size (size-of-foreign-type array-type))
|
||||
(ndx (* position element-size))
|
||||
(length (second array-type)))
|
||||
(unless (or (eq length *)
|
||||
(> length position -1))
|
||||
(error "Out of bounds when accessing array ~A." array))
|
||||
(if (foreign-elt-type-p element-type)
|
||||
(si::foreign-data-ref-elt array ndx element-type)
|
||||
(si::foreign-data-ref array ndx element-size element-type))))
|
||||
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; UNIONS
|
||||
;;;
|
||||
|
||||
(defmacro def-union (name &rest slots)
|
||||
(let ((struct-type (list :union))
|
||||
field
|
||||
type)
|
||||
(dolist (item (subst `(* ,struct-type) :pointer-self slots))
|
||||
(unless (and (consp item)
|
||||
(= (length item) 2)
|
||||
(symbolp (setf field (first item))))
|
||||
(error "Not a valid DEF-UNION slot ~A" item))
|
||||
(push (cons field type) struct-type))
|
||||
`(def-foreign-type ,name (nreverse struct-type))))
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; POINTERS
|
||||
;;;
|
||||
|
||||
(defvar +null-cstring-pointer+ (si:allocate-foreign-data :pointer-void 0))
|
||||
|
||||
(defun pointer-address (ptr)
|
||||
(error "POINTER-ADDRESS not yet implemented."))
|
||||
|
||||
(defun deref-pointer (ptr type)
|
||||
;; FIXME! No checking!
|
||||
(setf type (gethash type *ffi-types* type))
|
||||
(if (foreign-elt-type-p type)
|
||||
(si::foreign-data-ref-elt ptr ndx type)
|
||||
(error "Cannot dereference pointer to foreign data, ~A" ptr))
|
||||
|
||||
(defun (setf deref-pointer) (value ptr type)
|
||||
;; FIXME! No checking!
|
||||
(setf type (gethash type *ffi-types* type))
|
||||
(if (foreign-elt-type-p type)
|
||||
(si::foreign-data-set-elt ptr ndx type value)
|
||||
(si::foreign-data-set ptr ndx value)))
|
||||
|
||||
(defun make-null-pointer (type)
|
||||
(setf type (gethash type *ffi-types* type))
|
||||
(si::allocate-foreign-data type 0))
|
||||
|
||||
(defun null-pointer-p (object)
|
||||
(si::null-pointer-p object))
|
||||
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; CHARACTERS AND STRINGS
|
||||
;;;
|
||||
;;; ECL always returns characters when dereferencing (:array * :char)
|
||||
;;;
|
||||
|
||||
(defun null-char-p (char)
|
||||
(eq char #.(code-char 0)))
|
||||
|
||||
(defun ensure-char-character (char)
|
||||
(cond ((characterp char) char)
|
||||
((integerp char) (code-char char))
|
||||
(t (error "~a cannot be coerced to type CHARACTER" char))))
|
||||
|
||||
(defun ensure-char-integer (char)
|
||||
(cond ((characterp char) (char-code char))
|
||||
((integerp char) char)
|
||||
(t (error "~a cannot be coerced to type INTEGER" char))))
|
||||
|
||||
(defmacro convert-from-cstring (object)
|
||||
object)
|
||||
|
||||
(defmacro convert-to-cstring (object)
|
||||
object)
|
||||
|
||||
(defmacro free-cstring (object)
|
||||
object)
|
||||
|
||||
(defmacro with-cstring ((cstring string) &body body)
|
||||
`(let ((,cstring ,string)) ,@body))
|
||||
|
||||
(defun foreign-string-length (foreign-string)
|
||||
(c-inline (foreign-string) (t) :int
|
||||
"strlen((#0)->foreign.data)"
|
||||
:side-effects nil
|
||||
:one-liner t))
|
||||
|
||||
(defun convert-from-foreign-string (foreign-string
|
||||
&key length null-terminated-p)
|
||||
(cond ((and (not length) null-terminated-p)
|
||||
(setf length (foreign-string-length foreign-string)))
|
||||
((not (integerp length))
|
||||
(error "~A is not a valid string length" length)))
|
||||
(c-inline (foreign-string length) (t fixnum) string
|
||||
"{
|
||||
cl_index length = #1;
|
||||
cl_object output = cl_alloc_simple_string(length);
|
||||
@(return) = memcpy(output->string.self, (#0)->foreign.data, length);
|
||||
}"
|
||||
:one-liner nil
|
||||
:side-effects t))
|
||||
|
||||
(defun convert-to-foreign-string (string-designator)
|
||||
(let ((lisp-string (string string-designator)))
|
||||
(c-inline (lisp-string) (t) t
|
||||
"{
|
||||
cl_object lisp_string = #0;
|
||||
cl_index size = lisp_string->string.dim;
|
||||
cl_object output = ecl_allocate_foreign_data(@(* :char), size);
|
||||
memcpy(output->foreign.data, lisp_string->string.self, size);
|
||||
@(return) = output;
|
||||
}"
|
||||
:one-liner nil
|
||||
:side-effects t)
|
||||
))
|
||||
|
||||
(defun allocate-foreign-string (size &key unsigned)
|
||||
(si::allocate-foreign-data `(* ,(if unsigned :unsigned-char :char))
|
||||
size))
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; MACROLOGY
|
||||
;;;
|
||||
|
||||
(defmacro with-foreign-object ((var type) &body body)
|
||||
`(let ((,var (allocate-foreign-object type)))
|
||||
(unwind-protect
|
||||
(progn ,@body)
|
||||
(free-foreign-object ,var))))
|
||||
|
||||
(defmacro with-cast-pointer (bind &body body)
|
||||
(let (binding-name ptr type)
|
||||
(case (length bind)
|
||||
(2 (setf binding-name (first bind)
|
||||
ptr binding-name
|
||||
type (second bind)))
|
||||
(3 (setf binding-name (first bind)
|
||||
ptr (second bind)
|
||||
type (third bind)))
|
||||
(otherwise (error "Arguments missing in WITH-CAST-POINTER")))
|
||||
`(let ((,binding-name (si::foreign-data-pointer ,ptr 0
|
||||
(size-of-foreign-type ',type)
|
||||
',type)))
|
||||
,@body)))
|
||||
|
||||
;;;----------------------------------------------------------------------
|
||||
;;; INTERFACE TO C FUNCTIONS AND VARIABLES
|
||||
;;;
|
||||
|
||||
(defun lisp-to-c-name (name)
|
||||
(cond ((stringp name)
|
||||
(values name (intern (string-upcase (substitute #\- #\_ name)))))
|
||||
((and (consp name)
|
||||
(= (length name) 2))
|
||||
(values (first name) (second name)))))
|
||||
|
||||
(defmacro def-function (name args &key module (returning :void))
|
||||
(multiple-value-bind (c-name lisp-name)
|
||||
(lisp-to-c-name)
|
||||
(let* ((arguments (mapcar #'first args))
|
||||
(arg-types (mapcar #'second args))
|
||||
(nargs (length arguments))
|
||||
(c-string (format nil "~s(~s)" c-name
|
||||
(subseq 'string "0,1,2,3,4,5,6,7,8,9,a,b,c,d,e,f"
|
||||
:end (if arguments (1- (* nargs 2)) 0))))
|
||||
(casting-required (not (or (eq returning :cstring)
|
||||
(foreign-elt-type-p returning))))
|
||||
(inline-form `(c-inline ,arguments ,arg-types
|
||||
,(if casting-required :pointer-void returning)
|
||||
,c-string
|
||||
:one-liner t
|
||||
:side-effects t)))
|
||||
(when casting-required
|
||||
(setf inline-form
|
||||
`(si::foreign-data-recast ,inline-form
|
||||
(size-of-foreign-type ',returning)
|
||||
',returning)))
|
||||
(when (> nargs 36)
|
||||
(error "FFI can only handle C functions with up to 36 arguments"))
|
||||
`(defun ,lisp-name (,@arguments)
|
||||
,inline-form)
|
||||
)))
|
||||
|
||||
|
|
|
|||
|
|
@ -35,8 +35,6 @@
|
|||
"src:lsp;format.lsp"
|
||||
"src:lsp;defpackage.lsp"
|
||||
"src:lsp;ffi.lsp"
|
||||
#+ffi
|
||||
"src:lsp;ffi-objects.lsp"
|
||||
#+tk
|
||||
"src:lsp;tk-init.lsp"
|
||||
"build:lsp;config.lsp"
|
||||
|
|
|
|||
|
|
@ -263,6 +263,7 @@
|
|||
"c/disassembler.d"
|
||||
"c/multival.d"
|
||||
"c/threads.d"
|
||||
"c/ffi.d"
|
||||
"lsp/ansi.lsp"
|
||||
"lsp/arraylib.lsp"
|
||||
"lsp/assert.lsp"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue