add FFI types _string/utf-16/null and _string/ucs-4/null
svn: r12911
This commit is contained in:
parent
9ea047a05e
commit
7dc56df949
|
@ -680,8 +680,9 @@
|
|||
;; String types
|
||||
|
||||
;; The internal _string type uses the native ucs-4 encoding, also providing a
|
||||
;; utf-16 type (note: these do not use #f as NULL).
|
||||
(provide _string/ucs-4 _string/utf-16)
|
||||
;; utf-16 type (note: the non-/null variants do not use #f as NULL).
|
||||
(provide _string/ucs-4 _string/utf-16
|
||||
_string/ucs-4/null _string/utf-16/null)
|
||||
|
||||
;; 8-bit string encodings, #f is NULL
|
||||
(define ((false-or-op op) x) (and x (op x)))
|
||||
|
|
|
@ -163,15 +163,24 @@ strings, which corresponds to C's @cpp{char*} type. In addition to
|
|||
translating byte strings, @scheme[#f] corresponds to the @cpp{NULL}
|
||||
pointer.
|
||||
|
||||
@defthing[_string/ucs-4 ctype?]{
|
||||
@deftogether[(
|
||||
@defthing[_string/ucs-4 ctype?]
|
||||
@defthing[_string/ucs-4/null ctype?]
|
||||
)]{
|
||||
|
||||
A type for Scheme's native Unicode strings, which are in UCS-4 format.
|
||||
These correspond to the C @cpp{mzchar*} type used by PLT Scheme.}
|
||||
These correspond to the C @cpp{mzchar*} type used by PLT Scheme. The
|
||||
@schemeidfont{/null} variant treats @scheme[#f] as @cpp{NULL} and
|
||||
vice-versa.}
|
||||
|
||||
|
||||
@defthing[_string/utf-16 ctype?]{
|
||||
@deftogether[(
|
||||
@defthing[_string/utf-16 ctype?]
|
||||
@defthing[_string/utf-16/null ctype?]
|
||||
)]{
|
||||
|
||||
Unicode strings in UTF-16 format.}
|
||||
Unicode strings in UTF-16 format. The @schemeidfont{/null} variant
|
||||
treats @scheme[#f] as @cpp{NULL} and vice-versa.}
|
||||
|
||||
|
||||
@defthing[_path ctype?]{
|
||||
|
|
|
@ -461,7 +461,15 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
|
|||
#endif
|
||||
#endif
|
||||
|
||||
unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
||||
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
|
||||
|
||||
static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
|
||||
{
|
||||
if (SCHEME_FALSEP(ucs)) return NULL;
|
||||
return SCHEME_CHAR_STR_VAL(ucs);
|
||||
}
|
||||
|
||||
static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
||||
{
|
||||
long ulen;
|
||||
unsigned short *res;
|
||||
|
@ -471,11 +479,18 @@ unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
|||
return res;
|
||||
}
|
||||
|
||||
static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
|
||||
{
|
||||
if (SCHEME_FALSEP(ucs)) return NULL;
|
||||
return ucs4_string_to_utf16_pointer(ucs);
|
||||
}
|
||||
|
||||
Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
||||
{
|
||||
long ulen;
|
||||
mzchar *res;
|
||||
int end;
|
||||
if (!utf) return scheme_false;
|
||||
for (end=0; utf[end] != 0; end++) { /**/ }
|
||||
res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
|
||||
return scheme_make_sized_char_string(res, ulen, 0);
|
||||
|
@ -696,7 +711,17 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C->Scheme: scheme_make_char_string_without_copying(<C>)
|
||||
*/
|
||||
|
||||
#define FOREIGN_string_utf_16 (19)
|
||||
#define FOREIGN_string_ucs_4_null (19)
|
||||
/* Type Name: string/ucs-4/null (string_ucs_4_null)
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: mzchar*
|
||||
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
|
||||
* Scheme->C: ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: scheme_make_char_string_without_copying(<C>)
|
||||
*/
|
||||
|
||||
#define FOREIGN_string_utf_16 (20)
|
||||
/* Type Name: string/utf-16 (string_utf_16)
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: unsigned short*
|
||||
|
@ -706,10 +731,20 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
|
||||
*/
|
||||
|
||||
#define FOREIGN_string_utf_16_null (21)
|
||||
/* Type Name: string/utf-16/null (string_utf_16_null)
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: unsigned short*
|
||||
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
|
||||
* Scheme->C: ucs4_string_or_null_to_utf16_pointer(<Scheme>)
|
||||
* S->C offset: 0
|
||||
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
|
||||
*/
|
||||
|
||||
/* Byte strings -- not copying C strings, #f is NULL.
|
||||
* (note: these are not like char* which is just a pointer) */
|
||||
|
||||
#define FOREIGN_bytes (20)
|
||||
#define FOREIGN_bytes (22)
|
||||
/* Type Name: bytes
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: char*
|
||||
|
@ -719,7 +754,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
|
||||
*/
|
||||
|
||||
#define FOREIGN_path (21)
|
||||
#define FOREIGN_path (23)
|
||||
/* Type Name: path
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: char*
|
||||
|
@ -729,7 +764,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
|
||||
*/
|
||||
|
||||
#define FOREIGN_symbol (22)
|
||||
#define FOREIGN_symbol (24)
|
||||
/* Type Name: symbol
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: char*
|
||||
|
@ -742,7 +777,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
/* This is for any C pointer: #f is NULL, cpointer values as well as
|
||||
* ffi-obj and string values pass their pointer. When used as a return
|
||||
* value, either a cpointer object or #f is returned. */
|
||||
#define FOREIGN_pointer (23)
|
||||
#define FOREIGN_pointer (25)
|
||||
/* Type Name: pointer
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: void*
|
||||
|
@ -754,7 +789,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. */
|
||||
#define FOREIGN_scheme (24)
|
||||
#define FOREIGN_scheme (26)
|
||||
/* Type Name: scheme
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: Scheme_Object*
|
||||
|
@ -767,7 +802,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 (27)
|
||||
/* Type Name: fpointer
|
||||
* LibFfi type: ffi_type_pointer
|
||||
* C type: -none-
|
||||
|
@ -795,7 +830,9 @@ typedef union _ForeignAny {
|
|||
double x_doubleS;
|
||||
int x_bool;
|
||||
mzchar* x_string_ucs_4;
|
||||
mzchar* x_string_ucs_4_null;
|
||||
unsigned short* x_string_utf_16;
|
||||
unsigned short* x_string_utf_16_null;
|
||||
char* x_bytes;
|
||||
char* x_path;
|
||||
char* x_symbol;
|
||||
|
@ -804,7 +841,7 @@ typedef union _ForeignAny {
|
|||
} ForeignAny;
|
||||
|
||||
/* This is a tag that is used to identify user-made struct types. */
|
||||
#define FOREIGN_struct (26)
|
||||
#define FOREIGN_struct (28)
|
||||
|
||||
/*****************************************************************************/
|
||||
/* Type objects */
|
||||
|
@ -925,7 +962,9 @@ static int ctype_sizeof(Scheme_Object *type)
|
|||
case FOREIGN_doubleS: return sizeof(double);
|
||||
case FOREIGN_bool: return sizeof(int);
|
||||
case FOREIGN_string_ucs_4: return sizeof(mzchar*);
|
||||
case FOREIGN_string_ucs_4_null: return sizeof(mzchar*);
|
||||
case FOREIGN_string_utf_16: return sizeof(unsigned short*);
|
||||
case FOREIGN_string_utf_16_null: return sizeof(unsigned short*);
|
||||
case FOREIGN_bytes: return sizeof(char*);
|
||||
case FOREIGN_path: return sizeof(char*);
|
||||
case FOREIGN_symbol: return sizeof(char*);
|
||||
|
@ -1201,7 +1240,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
|
|||
case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
|
||||
case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
|
||||
case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
|
||||
case FOREIGN_string_ucs_4_null: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
|
||||
case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
|
||||
case FOREIGN_string_utf_16_null: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
|
||||
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*));
|
||||
|
@ -1465,6 +1506,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
|
||||
return NULL; /* hush the compiler */
|
||||
}
|
||||
case FOREIGN_string_ucs_4_null:
|
||||
#ifdef SCHEME_BIG_ENDIAN
|
||||
if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
|
||||
((int*)W_OFFSET(dst,delta))[0] = 0;
|
||||
delta += (sizeof(int)-sizeof(mzchar*));
|
||||
}
|
||||
#endif
|
||||
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
|
||||
mzchar* tmp;
|
||||
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_string_ucs_4_null;
|
||||
return tmp;
|
||||
}
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","string/ucs-4/null",0,1,&(val));
|
||||
return NULL; /* hush the compiler */
|
||||
}
|
||||
case FOREIGN_string_utf_16:
|
||||
#ifdef SCHEME_BIG_ENDIAN
|
||||
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
|
||||
|
@ -1486,6 +1548,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
|
|||
scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
|
||||
return NULL; /* hush the compiler */
|
||||
}
|
||||
case FOREIGN_string_utf_16_null:
|
||||
#ifdef SCHEME_BIG_ENDIAN
|
||||
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
|
||||
((int*)W_OFFSET(dst,delta))[0] = 0;
|
||||
delta += (sizeof(int)-sizeof(unsigned short*));
|
||||
}
|
||||
#endif
|
||||
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
|
||||
unsigned short* tmp;
|
||||
tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
|
||||
if (basetype_p == NULL ||tmp == NULL) {
|
||||
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
|
||||
return NULL;
|
||||
} else {
|
||||
*basetype_p = FOREIGN_string_utf_16_null;
|
||||
return tmp;
|
||||
}
|
||||
} else {
|
||||
scheme_wrong_type("Scheme->C","string/utf-16/null",0,1,&(val));
|
||||
return NULL; /* hush the compiler */
|
||||
}
|
||||
case FOREIGN_bytes:
|
||||
#ifdef SCHEME_BIG_ENDIAN
|
||||
if (sizeof(char*)<sizeof(int) && ret_loc) {
|
||||
|
@ -2901,6 +2984,13 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
|
||||
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
|
||||
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
|
||||
s = scheme_intern_symbol("string/ucs-4/null");
|
||||
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->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4_null);
|
||||
scheme_add_global("_string/ucs-4/null", (Scheme_Object*)t, menv);
|
||||
s = scheme_intern_symbol("string/utf-16");
|
||||
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
|
||||
t->so.type = ctype_tag;
|
||||
|
@ -2908,6 +2998,13 @@ void scheme_init_foreign(Scheme_Env *env)
|
|||
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
|
||||
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
|
||||
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
|
||||
s = scheme_intern_symbol("string/utf-16/null");
|
||||
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->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16_null);
|
||||
scheme_add_global("_string/utf-16/null", (Scheme_Object*)t, menv);
|
||||
s = scheme_intern_symbol("bytes");
|
||||
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
|
||||
t->so.type = ctype_tag;
|
||||
|
|
|
@ -392,7 +392,15 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
|
|||
#endif
|
||||
#endif
|
||||
|
||||
unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
||||
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
|
||||
|
||||
static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
|
||||
{
|
||||
if (SCHEME_FALSEP(ucs)) return NULL;
|
||||
return SCHEME_CHAR_STR_VAL(ucs);
|
||||
}
|
||||
|
||||
static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
||||
{
|
||||
long ulen;
|
||||
unsigned short *res;
|
||||
|
@ -402,11 +410,18 @@ unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
|
|||
return res;
|
||||
}
|
||||
|
||||
static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
|
||||
{
|
||||
if (SCHEME_FALSEP(ucs)) return NULL;
|
||||
return ucs4_string_to_utf16_pointer(ucs);
|
||||
}
|
||||
|
||||
Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
||||
{
|
||||
long ulen;
|
||||
mzchar *res;
|
||||
int end;
|
||||
if (!utf) return scheme_false;
|
||||
for (end=0; utf[end] != 0; end++) { /**/ }
|
||||
res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
|
||||
return scheme_make_sized_char_string(res, ulen, 0);
|
||||
|
@ -644,6 +659,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
's->c "SCHEME_CHAR_STR_VAL"
|
||||
'c->s "scheme_make_char_string_without_copying")
|
||||
|
||||
(defctype 'string/ucs-4/null
|
||||
'ftype "pointer"
|
||||
'ctype "mzchar*"
|
||||
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
|
||||
's->c "ucs4_string_or_null_to_ucs4_pointer"
|
||||
'c->s "scheme_make_char_string_without_copying")
|
||||
|
||||
(defctype 'string/utf-16
|
||||
'ftype "pointer"
|
||||
'ctype "unsigned short*"
|
||||
|
@ -651,6 +673,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
|
|||
's->c "ucs4_string_to_utf16_pointer"
|
||||
'c->s "utf16_pointer_to_ucs4_string")
|
||||
|
||||
(defctype 'string/utf-16/null
|
||||
'ftype "pointer"
|
||||
'ctype "unsigned short*"
|
||||
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
|
||||
's->c "ucs4_string_or_null_to_utf16_pointer"
|
||||
'c->s "utf16_pointer_to_ucs4_string")
|
||||
|
||||
(~ "/* Byte strings -- not copying C strings, #f is NULL." \\
|
||||
" * (note: these are not like char* which is just a pointer) */" \\
|
||||
)
|
||||
|
|
Loading…
Reference in New Issue
Block a user