diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index fa2520d35e..a945f09967 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -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))) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 064b494d7f..b2d83ec418 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -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?]{ diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 53c08951b5..f29da13eb9 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -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() */ -#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->C: ucs4_string_or_null_to_ucs4_pointer() + * S->C offset: 0 + * C->Scheme: scheme_make_char_string_without_copying() + */ + +#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() */ +#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->C: ucs4_string_or_null_to_utf16_pointer() + * S->C offset: 0 + * C->Scheme: 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) */ -#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: (==NULL)?scheme_false:scheme_make_byte_string_without_copying() */ -#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: (==NULL)?scheme_false:scheme_make_path_without_copying() */ -#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*)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*)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*)C","string/utf-16/null",0,1,&(val)); + return NULL; /* hush the compiler */ + } case FOREIGN_bytes: #ifdef SCHEME_BIG_ENDIAN if (sizeof(char*)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; diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 95f5ad4abd..c83fd900ff 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -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) */" \\ )