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

change _pointer to mean a reference to non-GCed memory; add _gcpointer (v4.2.2.6)

Browse Source 
svn: r16546
This commit is contained in:
Matthew Flatt 2009-11-04 19:28:04 +00:00
parent 4edc044cb6
commit c49b22fa2c
21 changed files with 285 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/scheme/foreign.ss
View File

@ -62,13 +62,13 @@
(provide* ctype-sizeof ctype-alignof compiler-sizeof
(unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) (unsafe cast)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum
_float _double _double*
_bool _pointer _scheme _fpointer function-ptr
_bool _pointer _gcpointer _scheme _fpointer function-ptr
(unsafe memcpy) (unsafe memmove) (unsafe memset)
(unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
@ -1257,6 +1257,49 @@
;; Similar to the above, but can tolerate null pointers (#f).
(define* _cpointer/null (cpointer-maker #t))
(define (cast p from-type to-type)
(unless (ctype? from-type)
(raise-type-error 'cast "ctype" from-type))
(unless (ctype? to-type)
(raise-type-error 'cast "ctype" to-type))
(unless (= (ctype-sizeof to-type)
(ctype-sizeof from-type))
(raise-mismatch-error (format "representation sizes of types differ: ~e to "
from-type)
to-type))
(let ([p2 (malloc from-type)])
(ptr-set! p2 from-type p)
(ptr-ref p2 to-type)))
(define* (_or-null ctype)
(let ([coretype (ctype-coretype ctype)])
(unless (memq coretype '(pointer gcpointer fpointer))
(raise-type-error '_or-null "ctype buit on pointer, gcpointer, or fpointer" ctype))
(make-ctype
(case coretype
[(pointer) _pointer]
[(gcpointer) _gcpointer]
[(fpointer) _fpointer])
(lambda (v) (and v (cast _pointer v)))
(lambda (v) (and v (cast ctype v))))))
(define* (_gcable ctype)
(unless (memq (ctype-coretype ctype) '(pointer gcpointer))
(raise-type-error '_or-null "pointer ctype" ctype))
(let loop ([ctype ctype])
(if (eq? ctype 'pointer)
_gcpointer
(make-ctype
(loop (ctype-basetype ctype))
(ctype-scheme->c ctype)
(ctype-c->scheme ctype)))))
(define (ctype-coretype c)
(let loop ([c (ctype-basetype c)])
(if (symbol? c)
c
(loop c))))
;; A macro version of the above two functions, using the defined name for a tag
;; string, and defining a predicate too. The name should look like `_foo', the
;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag'

4
collects/scribblings/foreign/derived.scrbl
View File

@ -9,12 +9,12 @@ The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!]
operations manage tags to distinguish pointer types.
@defproc*[([(_cpointer [tag any/c]
[ptr-type ctype? _pointer]
[ptr-type ctype? _xpointer]
[scheme-to-c (any/c . -> . any/c) values]
[c-to-scheme (any/c . -> . any/c) values])
ctype]
[(_cpointer/null [tag any/c]
[ptr-type ctype? _pointer]
[ptr-type ctype? _xpointer]
[scheme-to-c (any/c . -> . any/c) values]
[c-to-scheme (any/c . -> . any/c) values])
ctype])]{

14
collects/scribblings/foreign/misc.scrbl
View File

@ -54,6 +54,20 @@ Like @scheme[list->cblock], but for Scheme vectors.}
@section{Unsafe Miscellaneous Operations}
@defproc[(cast [v any/c][from-type ctype?][to-type ctype?]) any/c]{
Converts @scheme[v] from a value matching @scheme[from-type] to a
value matching @scheme[to-type], where @scheme[(ctype-size from-type)]
matches @scheme[(ctype-size to-type)].
The conversion is equivalent to
@schemeblock[
(let ([p (malloc from-type)])
(ptr-set! p from-type v)
(ptr-ref p to-type))
]}
@defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?])
list?]{

4
collects/scribblings/foreign/pointers.scrbl
View File

@ -260,8 +260,8 @@ specification is required at minimum:
]
If no mode is specified, then @scheme['nonatomic] allocation is used
when the type is any pointer-based type, and @scheme['atomic]
allocation is used otherwise.}
when the type is a @scheme[_gcpointer]- or @scheme[_scheme]-based
type, and @scheme['atomic] allocation is used otherwise.}
@defproc[(free [cptr cpointer?]) void]{

41
collects/scribblings/foreign/types.scrbl
View File

@ -271,7 +271,28 @@ Corresponds to Scheme ``C pointer'' objects. These pointers can have
an arbitrary Scheme object attached as a type tag. The tag is ignored
by built-in functionality; it is intended to be used by interfaces.
See @secref["foreign:tagged-pointers"] for creating pointer types that
use these tags for safety.}
use these tags for safety. A @scheme[#f] value is converted to
@cpp{NULL} and vice-versa.
The address referenced by a @scheme[_pointer] value must not refer to
memory managed by the garbage collector (unless the address
corresponds to a value that supports interior pointers and that is
otherwise referenced to preserve the value from garbage collection).
The reference is not traced or updated by the garbage collector.}
@defthing[_gcpointer ctype?]{
Like @scheme[_pointer], but for a value that can refer to memory
managed by the garbage collector.
Although a @scheme[_gcpointer] can reference to memory that is not
managed by the garbage collector, beware of using an address that
might eventually become managed by the garbage collector. For example,
if a reference is created by @scheme[malloc] with @scheme['raw] and
released by @scheme[free], then the @scheme[free] may allow the memory
formerly occupied by the reference to be used later by the garbage
collector.}
@defthing[_scheme ctype?]{
@ -295,6 +316,24 @@ A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
and normally @scheme[_cprocedure] should be used instead of
@scheme[_fpointer].}
@defproc[(_or-null [ctype ctype?]) ctype?]{
Creates a type that is like @scheme[ctype], but @scheme[#f] is
converted to @cpp{NULL} and vice-versa. The given @scheme[ctype] must
have the same C representation as @scheme[_pointer],
@scheme[_gcpointer], or @scheme[_fpointer].}
@defproc[(_gcable [ctype ctype?]) ctype?]{
Creates a type that is like @scheme[ctype], but whose base
representation is like @scheme[_gcpointer] instead of
@scheme[_pointer]. The given @scheme[ctype] must have a base
representation like @scheme[_pointer] or @scheme[_gcpointer] (and in
the later case, the result is the @scheme[ctype]).}
@; ------------------------------------------------------------
@section[#:tag "foreign:procedures"]{Function Types}

31
collects/scribblings/inside/values.scrbl
View File

@ -667,7 +667,21 @@ Creates a C-pointer object that encapsulates @var{ptr} and uses
the original @var{ptr} from the Scheme object, and
@cppi{SCHEME_CPTR_TYPE} extracts the type tag.
The @cppi{SCHEME_CPTR_OFFSETVAL} macro returns @cpp{0}
for the result Scheme object.}
for the result Scheme object.
The @var{ptr} can refer to either memory managed by the garbage
collector or by some other memory manager. Beware, however, of
retaining a @var{ptr} that refers to memory released by another
memory manager, since the enclosing memory range might later become
managed by the garbage collector (in which case @var{ptr} might
become an invalid pointer that can crash the garbage collector).}
@function[(Scheme_Object* scheme_make_external_cptr
[void* ptr]
[const-Scheme_Object* typetag])]{
Like @cpp{scheme_make_cptr}, but @var{ptr} is never treated as
referencing memory managed by the garbage collector.}
@function[(Scheme_Object* scheme_make_offset_cptr
[void* ptr]
@ -677,7 +691,20 @@ Creates a C-pointer object that encapsulates @var{ptr} and uses
Creates a C-pointer object that encapsulates both @var{ptr} and @var{offset}.
The @cppi{SCHEME_CPTR_OFFSETVAL} macro returns @var{offset}
for the result Scheme object (and the macro be used to change the offset,
since it also works on objects with no offset).}
since it also works on objects with no offset).
The @var{ptr} can refer to either memory managed by the garbage
collector or by some other memory manager; see also
@cpp{scheme_make_cptr}.}
@function[(Scheme_Object* scheme_make_offset_external_cptr
[void* ptr]
[long offset]
[const-Scheme_Object* typetag])]{
Like @cpp{scheme_make_offset_cptr}, but @var{ptr} is never treated as
referencing memory managed by the garbage collector.}
@function[(void scheme_set_type_printer
[Scheme_Type type]

88
src/foreign/foreign.c
View File

@ -766,14 +766,24 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* Predicate: SCHEME_FFIANYPTRP(<Scheme>)
* Scheme->C: SCHEME_FFIANYPTR_VAL(<Scheme>)
* S->C offset: FFIANYPTR
* C->Scheme: scheme_make_foreign_external_cpointer(<C>)
*/
#define FOREIGN_gcpointer (24)
/* Type Name: gcpointer
* LibFfi type: ffi_type_gcpointer
* C type: void*
* Predicate: SCHEME_FFIANYPTRP(<Scheme>)
* Scheme->C: SCHEME_FFIANYPTR_VAL(<Scheme>)
* S->C offset: FFIANYPTR
* C->Scheme: scheme_make_foreign_cpointer(<C>)
*/
/* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like MzScheme's. */
#define FOREIGN_scheme (24)
#define FOREIGN_scheme (25)
/* Type Name: scheme
* LibFfi type: ffi_type_pointer
* LibFfi type: ffi_type_gcpointer
* C type: Scheme_Object*
* Predicate: 1
* Scheme->C: <Scheme>
@ -784,7 +794,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for
* creating function types. */
#define FOREIGN_fpointer (25)
#define FOREIGN_fpointer (26)
/* Type Name: fpointer
* LibFfi type: ffi_type_pointer
* C type: void*
@ -817,12 +827,13 @@ typedef union _ForeignAny {
char* x_path;
char* x_symbol;
void* x_pointer;
void* x_gcpointer;
Scheme_Object* x_scheme;
void* x_fpointer;
} ForeignAny;
/* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (26)
#define FOREIGN_struct (27)
/*****************************************************************************/
/* Type objects */
@ -876,6 +887,8 @@ int ctype_FIXUP(void *p) {
END_XFORM_SKIP;
#endif
static ffi_type ffi_type_gcpointer;
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
@ -951,6 +964,7 @@ static int ctype_sizeof(Scheme_Object *type)
case FOREIGN_path: return sizeof(char*);
case FOREIGN_symbol: return sizeof(char*);
case FOREIGN_pointer: return sizeof(void*);
case FOREIGN_gcpointer: return sizeof(void*);
case FOREIGN_scheme: return sizeof(Scheme_Object*);
case FOREIGN_fpointer: return sizeof(void*);
/* for structs */
@ -1148,6 +1162,9 @@ END_XFORM_SKIP;
#define scheme_make_foreign_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
#define scheme_make_foreign_external_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
#define MYNAME "cpointer?"
static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
{
@ -1206,7 +1223,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void: return scheme_void;
case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8));
@ -1230,7 +1247,8 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
case FOREIGN_pointer: return scheme_make_foreign_external_cpointer(REF_CTYPE(void*));
case FOREIGN_gcpointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
case FOREIGN_fpointer: return (REF_CTYPE(void*));
case FOREIGN_struct:
@ -1599,6 +1617,23 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_gcpointer:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(void*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(void*));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; long toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff;
(((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","gcpointer",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_scheme:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(Scheme_Object*)<sizeof(int) && ret_loc) {
@ -1609,13 +1644,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (1) {
Scheme_Object* tmp;
tmp = (Scheme_Object*)(val);
if (basetype_p == NULL || tmp == NULL) {
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_scheme;
return tmp;
}
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
return NULL; /* hush the compiler */
@ -1845,7 +1874,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;
else if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
@ -1862,7 +1891,10 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
if (((from != NULL) || (foff != 0)) && (res != NULL))
memcpy(res, W_OFFSET(from, foff), size);
return scheme_make_foreign_cpointer(res);
if (SAME_OBJ(mode, raw_sym))
return scheme_make_foreign_external_cpointer(res);
else
return scheme_make_foreign_cpointer(res);
}
#undef MYNAME
@ -1906,7 +1938,7 @@ static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
#define MYNAME "malloc-immobile-cell"
static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[])
{
return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0]));
}
#undef MYNAME
@ -1961,10 +1993,16 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
return scheme_void;
} else {
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
else
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
}
}
@ -2741,6 +2779,7 @@ void scheme_init_foreign(Scheme_Env *env)
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
scheme_add_global("ffi-lib?",
scheme_make_prim_w_arity(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv);
@ -2981,11 +3020,18 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
scheme_add_global("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("gcpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer);
scheme_add_global("_gcpointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("scheme");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
scheme_add_global("_scheme", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fpointer");

40
src/foreign/foreign.ssc
View File

@ -704,6 +704,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* ffi-obj and string values pass their pointer. When used as a return
* value, either a cpointer object or #f is returned. */
@(defctype 'pointer
'ctype "void*"
'macro "FFIANYPTR"
'offset "FFIANYPTR"
'c->s "scheme_make_foreign_external_cpointer")
@(defctype 'gcpointer
'ftype "gcpointer"
'ctype "void*"
'macro "FFIANYPTR"
'offset "FFIANYPTR"
@ -721,7 +728,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like MzScheme's. */
@(defctype 'scheme
'ftype "pointer"
'ftype "gcpointer"
'ctype "Scheme_Object*"
'pred (lambda (x aux) "1")
's->c (lambda (x aux) x)
@ -759,6 +766,8 @@ typedef union _ForeignAny {
[scheme_to_c "Scheme_Object*"]
[c_to_scheme "Scheme_Object*"]]
static ffi_type ffi_type_gcpointer;
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
@ -950,6 +959,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
#define scheme_make_foreign_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
#define scheme_make_foreign_external_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
@cdefine[cpointer? 1]{
return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
}
@ -999,7 +1011,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
} else switch (CTYPE_PRIMLABEL(type)) {
@(map-types
@list{case FOREIGN_@|cname|: return @;
@ -1307,7 +1319,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
if (mode == NULL)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
? scheme_malloc : scheme_malloc_atomic;
else if (SAME_OBJ(mode, nonatomic_sym)) mf = scheme_malloc;
else if (SAME_OBJ(mode, atomic_sym)) mf = scheme_malloc_atomic;
@ -1324,7 +1336,10 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
if (((from != NULL) || (foff != 0)) && (res != NULL))
memcpy(res, W_OFFSET(from, foff), size);
return scheme_make_foreign_cpointer(res);
if (SAME_OBJ(mode, raw_sym))
return scheme_make_foreign_external_cpointer(res);
else
return scheme_make_foreign_cpointer(res);
}
/* (end-stubborn-change ptr) */
@ -1359,7 +1374,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
/* (malloc-immobile-cell v) */
@cdefine[malloc-immobile-cell 1]{
return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0]));
}
/* (free-immobile-cell b) */
@ -1410,10 +1425,16 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
return scheme_void;
} else {
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
return scheme_make_offset_external_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
else
return scheme_make_offset_cptr
(SCHEME_FFIANYPTR_VAL(argv[0]),
SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
(SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
}
}
@ -2112,6 +2133,7 @@ void scheme_init_foreign(Scheme_Env *env)
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
@(maplines
(lambda (x)

2
src/mzscheme/include/mzscheme.exp
View File

@ -300,6 +300,8 @@ scheme_get_unsigned_long_long_val
scheme_real_to_double
scheme_make_cptr
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

2
src/mzscheme/include/mzscheme3m.exp
View File

@ -311,6 +311,8 @@ scheme_get_unsigned_long_long_val
scheme_real_to_double
scheme_make_cptr
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

2
src/mzscheme/include/mzwin.def
View File

@ -288,6 +288,8 @@ EXPORTS
scheme_real_to_double
scheme_make_cptr
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

2
src/mzscheme/include/mzwin3m.def
View File

@ -303,6 +303,8 @@ EXPORTS
scheme_real_to_double
scheme_make_cptr
scheme_make_offset_cptr
scheme_make_external_cptr
scheme_make_offset_external_cptr
scheme_get_proc_name
scheme_utf8_decode
scheme_utf8_decode_as_prefix

3
src/mzscheme/include/scheme.h
View File

@ -564,7 +564,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
typedef struct Scheme_Cptr
{
Scheme_Object so;
Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable) */
void *val;
Scheme_Object *type;
} Scheme_Cptr;
@ -577,6 +577,7 @@ typedef struct Scheme_Offset_Cptr
#define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
#define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
#define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
#define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so)
#define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
#define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)

16
src/mzscheme/src/mzmark.c
View File

@ -156,14 +156,18 @@ static int cpointer_obj_SIZE(void *p) {
}
static int cpointer_obj_MARK(void *p) {
gcMARK(SCHEME_CPTR_VAL(p));
if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
gcMARK(SCHEME_CPTR_VAL(p));
}
gcMARK(SCHEME_CPTR_TYPE(p));
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
}
static int cpointer_obj_FIXUP(void *p) {
gcFIXUP(SCHEME_CPTR_VAL(p));
if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
gcFIXUP(SCHEME_CPTR_VAL(p));
}
gcFIXUP(SCHEME_CPTR_TYPE(p));
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
@ -179,14 +183,18 @@ static int offset_cpointer_obj_SIZE(void *p) {
}
static int offset_cpointer_obj_MARK(void *p) {
gcMARK(SCHEME_CPTR_VAL(p));
if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
gcMARK(SCHEME_CPTR_VAL(p));
}
gcMARK(SCHEME_CPTR_TYPE(p));
return
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
}
static int offset_cpointer_obj_FIXUP(void *p) {
gcFIXUP(SCHEME_CPTR_VAL(p));
if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
gcFIXUP(SCHEME_CPTR_VAL(p));
}
gcFIXUP(SCHEME_CPTR_TYPE(p));
return
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));

8
src/mzscheme/src/mzmarksrc.c
View File

@ -56,7 +56,9 @@ quotesyntax_obj {
cpointer_obj {
mark:
gcMARK(SCHEME_CPTR_VAL(p));
if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
gcMARK(SCHEME_CPTR_VAL(p));
}
gcMARK(SCHEME_CPTR_TYPE(p));
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
@ -64,7 +66,9 @@ cpointer_obj {
offset_cpointer_obj {
mark:
gcMARK(SCHEME_CPTR_VAL(p));
if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
gcMARK(SCHEME_CPTR_VAL(p));
}
gcMARK(SCHEME_CPTR_TYPE(p));
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));

17
src/mzscheme/src/salloc.c
View File

@ -342,6 +342,14 @@ Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag)
return o;
}
Scheme_Object *scheme_make_external_cptr(GC_CAN_IGNORE void *cptr, Scheme_Object *typetag)
{
Scheme_Object *o;
o = scheme_make_cptr(NULL, typetag);
SCHEME_CPTR_VAL(o) = cptr;
return o;
}
Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag)
{
Scheme_Object *o;
@ -355,6 +363,15 @@ Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *t
return o;
}
Scheme_Object *scheme_make_offset_external_cptr(GC_CAN_IGNORE void *cptr, long offset, Scheme_Object *typetag)
{
Scheme_Object *o;
o = scheme_make_offset_cptr(NULL, offset, typetag);
SCHEME_CPTR_VAL(o) = cptr;
return o;
}
/************************************************************************/
/* allocation */
/************************************************************************/

2
src/mzscheme/src/schemef.h
View File

@ -576,6 +576,8 @@ XFORM_NONGCING MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag);
MZ_EXTERN Scheme_Object *scheme_make_external_cptr(void *cptr, Scheme_Object *typetag);
MZ_EXTERN Scheme_Object *scheme_make_offset_external_cptr(void *cptr, long offset, Scheme_Object *typetag);
MZ_EXTERN const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error);

2
src/mzscheme/src/schemex.h
View File

@ -475,6 +475,8 @@ int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
double (*scheme_real_to_double)(Scheme_Object *r);
Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, long offset, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_external_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_external_cptr)(void *cptr, long offset, Scheme_Object *typetag);
const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
/*========================================================================*/
/* strings */

2
src/mzscheme/src/schemex.inc
View File

@ -337,6 +337,8 @@
scheme_extension_table->scheme_real_to_double = scheme_real_to_double;
scheme_extension_table->scheme_make_cptr = scheme_make_cptr;
scheme_extension_table->scheme_make_offset_cptr = scheme_make_offset_cptr;
scheme_extension_table->scheme_make_external_cptr = scheme_make_external_cptr;
scheme_extension_table->scheme_make_offset_external_cptr = scheme_make_offset_external_cptr;
scheme_extension_table->scheme_get_proc_name = scheme_get_proc_name;
scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode;
scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix;

2
src/mzscheme/src/schemexm.h
View File

@ -337,6 +337,8 @@
#define scheme_real_to_double (scheme_extension_table->scheme_real_to_double)
#define scheme_make_cptr (scheme_extension_table->scheme_make_cptr)
#define scheme_make_offset_cptr (scheme_extension_table->scheme_make_offset_cptr)
#define scheme_make_external_cptr (scheme_extension_table->scheme_make_external_cptr)
#define scheme_make_offset_external_cptr (scheme_extension_table->scheme_make_offset_external_cptr)
#define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name)
#define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode)
#define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix)

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.2.5"
#define MZSCHEME_VERSION "4.2.2.6"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 2
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)