suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix ptr-set! to allow installing function points into an offset cpointer

Browse Source 
svn: r12910
This commit is contained in:
Matthew Flatt 2008-12-19 23:39:55 +00:00
parent 69556b1881
commit 9ea047a05e
2 changed files with 22 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/foreign/foreign.c
View File

@ -2166,13 +2166,15 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
else size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (argc > 3) {
scheme_signal_error
(MYNAME": setting fpointer value with extra arguments");
} else if (SCHEME_CPTRP(argv[0])) {
ptr = SCHEME_CPTR_VAL(argv[0]);
if (SCHEME_CPTRP(argv[0])) {
/* offset is ok */
} else if SCHEME_FFIOBJP(argv[0]) {
if (argc > 3) {
scheme_signal_error
(MYNAME": cannot set fpointer value with offset");
}
ptr = ((ffi_obj_struct*)(argv[0]))->obj;
} else {
scheme_signal_error
@ -2183,9 +2185,11 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
} else if (argc > 4) {
}
if (argc > 4) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
delta += SCHEME_INT_VAL(argv[3]);

18
src/foreign/foreign.ssc
View File

@ -1616,13 +1616,15 @@ static Scheme_Object *do_memop(const char *who, int mode,
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
else size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (argc > 3) {
scheme_signal_error
(MYNAME": setting fpointer value with extra arguments");
} else if (SCHEME_CPTRP(argv[0])) {
ptr = SCHEME_CPTR_VAL(argv[0]);
if (SCHEME_CPTRP(argv[0])) {
/* offset is ok */
} else if SCHEME_FFIOBJP(argv[0]) {
if (argc > 3) {
scheme_signal_error
(MYNAME": cannot set fpointer value with offset");
}
ptr = ((ffi_obj_struct*)(argv[0]))->obj;
} else {
scheme_signal_error
@ -1633,9 +1635,11 @@ static Scheme_Object *do_memop(const char *who, int mode,
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
} else if (argc > 4) {
}
if (argc > 4) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
delta += SCHEME_INT_VAL(argv[3]);