// Various Unicode functions. // This C module wraps the functions defined in unicode.c. // // This file is part of Beastie // SPDX-FileCopyrightText: 2025 Norman Gray // SPDX-License-Identifier: BSD-2-Clause #include "config.h" #ifndef ALL_FUNCTIONS #define ALL_FUNCTIONS 1 #endif #include #include #include #include #include #if __GNUC__ // PATH_MAX is defined in linux/limits.h // (and yes, PATH_MAX is unreliable for various intricate reasons, // but as long as it's a sane value, we are not, I think, vulnerable // to those problems here). #if HAVE_LINUX_LIMITS_H #include #endif #endif #if HAVE_ALLOCA_H #include #endif #include "s7.h" #include "util.h" #include "unicode-scm.h" #if ALL_FUNCTIONS #include "uniprops.h" #endif // forward definition static int is_ustring_p(s7_pointer obj); #if HAVE_ICU // The (collation) locale is set and read using unicode_{get,set}_locale. // We call the other ICU locale functions directly from here, rather than via // unicode.c. Indirecting through there initially seems/seemed // tidier, but turns out messy for no real benefit. #include // #include #endif #if ALL_FUNCTIONS // a couple of Unicode/UTF-8 helper functions s7_pointer unicode_decode_utf8_proc(s7_scheme* sc, s7_pointer args) { // The 'string' argument here is a sequence of bytes s7_pointer str = s7_car(args); if (! s7_is_string(str)) { return s7_wrong_type_arg_error(sc, "unicode-decode/utf8", 1, str, "a string (here, a sequence of bytes)"); } const char* s = s7_string(str); size_t slen = s7_string_length(str); const char* errmsg = NULL; ustring_t us = make_ustring(&errmsg); if (us == NULL) { return_beastie_error(sc, "can't make empty ustring"); } // s7_pointer res = s7_nil(sc); unsigned char nused; // const char* errmsg; while (slen > 0) { codepoint_t cp = decode_utf8((unsigned char*)s, slen, &nused, &errmsg); if (cp == UNICODE_BAD_DECODE) { scheme_eval("print-warning", s7_make_string(sc, "unicode-decode/utf8: can't decode ~s (~a)"), str, s7_make_string(sc, errmsg), NULL); cp = UNICODE_REPLACEMENT_CHARACTER; } //res = s7_cons(sc, s7_make_integer(sc, cp), res); if (ustring_append_cp(us, cp, &errmsg) == NULL) { // this should be impossible, given returns from decode_utf8 return_beastie_error(sc, "can't add codepoint %d to ustring (%s)", cp, errmsg); } s += nused; slen -= nused; } //return s7_reverse(sc, res); return make_ustring_obj(sc, us); } #endif /* ALL_FUNCTIONS */ // Return a single codepoint from the input port argument, // or the (current-input-port) if that's absent. // Returns eof-object? at end of input. // Thus, if there is no argument, then this acts like an iterator. s7_pointer unicode_decode1_port_utf8_proc(s7_scheme* sc, s7_pointer args) { s7_pointer p; if (s7_is_null(sc, args)) { p = s7_current_input_port(sc); }else { p = s7_car(args); if (! s7_is_input_port(sc, p)) { return s7_wrong_type_arg_error(sc, "unicode-decode1/port/utf8", 1, p, "input port"); } } unsigned char s[4]; codepoint_t cp = UNICODE_BAD_DECODE; for (int i=0; i < 4 && cp == UNICODE_BAD_DECODE; i++) { s7_pointer c0 = s7_read_char(sc, p); if (s7_is_eq(c0, s7_eof_object(sc))) { cp = 0; } else { s[i] = s7_character(c0); cp = decode_utf8(s, i+1, NULL, NULL); //fprintf(stderr, "[%d] %x -> %x\n", i, s[i], cp); } } if (cp == 0) { return s7_eof_object(sc); } else if (cp == UNICODE_BAD_DECODE) { return s7_make_integer(sc, UNICODE_REPLACEMENT_CHARACTER); } else { return s7_make_integer(sc, cp); } } #if ALL_FUNCTIONS s7_pointer unicode_encode1_utf8_proc(s7_scheme* sc, s7_pointer args) { // encode one character or integer s7_pointer cp_arg = s7_car(args); s7_int cp; if (s7_is_integer(cp_arg)) { cp = s7_integer(cp_arg); } else if (s7_is_character(cp_arg)) { cp = s7_character(cp_arg); } else { return s7_wrong_type_arg_error(sc, "unicode-encode1/utf8", 1, cp_arg, "a character or integer"); } int slen; const unsigned char* s = encode_utf8(cp, &slen); return s7_make_string_with_length(sc, (const char*)s, slen); } s7_pointer unicode_encode_utf8_proc(s7_scheme* sc, s7_pointer args) { // encode a list or iterator of characters or integers, // as a sequence of bytes (returned as an s7 string) s7_pointer cp_list = s7_car(args); s7_pointer iter; if (s7_is_list(sc, cp_list)) { iter = s7_make_iterator(sc, cp_list); } else if (s7_is_iterator(cp_list)) { iter = cp_list; } else { return s7_wrong_type_arg_error(sc, "unicode-encode/utf8", 1, cp_list, "a list or iterator"); } StringBuilder sb = make_stringbuilder(); int slen; while (1) { s7_int cp; s7_pointer cp1; cp1 = s7_iterate(sc, iter); if (s7_iterator_is_at_end(sc, iter)) { break; // JUMP OUT } if (s7_is_integer(cp1)) { cp = s7_integer(cp1); } else if (s7_is_character(cp1)) { cp = s7_character(cp1); } else { return s7_error(sc, s7_make_symbol(sc, "wrong-type-arg"), s7_list(sc, 3, s7_make_string(sc, "unicode-encode/utf8: argument ~s should be a list of char or integer, but includes ~s"), cp_list, cp1)); } const unsigned char* s = encode_utf8(cp, &slen); if (s == NULL) { scheme_eval("print-warning", s7_make_string(sc, "unicode-encode/utf8: codepoint ~a is a surrogate or out of range"), cp1, NULL); break; // JUMP OUT } stringbuilder_append_sn(sb, (const char*)s, slen); } s7_pointer rval = s7_make_string_with_length(sc, sb->buf, sb->len); stringbuilder_free(sb); return rval; } // Unicode-reader implementation. // A unicode-reader will read data from a file or string, and return it as a sequence of Unicode codepoints. static int unicode_reader_type_tag = 0; //static int unicode_reader_same_source_scheme(s7_scheme* sc, s7_pointer a1, s7_pointer a2); int is_unicode_reader_p(s7_pointer obj) { return s7_is_c_object(obj) && s7_c_object_type(obj) == unicode_reader_type_tag; } s7_pointer is_unicode_reader_proc(s7_scheme* sc, s7_pointer args) { // args is of length 1 return s7_make_boolean(sc, is_unicode_reader_p(s7_car(args))); } static s7_pointer free_unicode_reader_object(s7_scheme* sc, s7_pointer obj) { unicode_reader* p = (unicode_reader*)s7_c_object_value(obj); unicode_reader_free(p); return NULL; } static s7_pointer mark_unicode_reader(s7_scheme *sc, s7_pointer obj) { // no scheme objects held: nothing to do return NULL; } int unicode_reader_same_source_p(s7_scheme* sc, unicode_reader* r1, unicode_reader* r2) { int result; if (r1->filename) { if (r2->filename) { // both files struct stat S1; if (stat(r1->filename, &S1) != 0) { // would this be better with a warning and a #f return? return_beastie_error(sc, "can't stat file <%s> (%s)", r1->filename, strerror(errno)); } struct stat S2; if (stat(r2->filename, &S2) != 0) { return_beastie_error(sc, "can't stat file <%s> (%s)", r2->filename, strerror(errno)); } result = (S1.st_ino == S2.st_ino); } else { // r1 is a file, r2 is a string result = 0; } } else { if (r2->filename) { // r1 is a string, r2 is a file result = 0; } else { // both strings // #if HAVE_ICU // // What a palaver... // // You'd have thought that // // result = utext_equals(r1->ut, r2->ut); // // would be enough, but no, that's sensitive to the two // // UTexts being a different points in an iteration. // int64_t l1 = utext_nativeLength(r1->ut); // int64_t l2 = utext_nativeLength(r2->ut); // if (l1 == l2) { // if (utext_getNativeIndex(r1->ut) // == utext_getNativeIndex(r2->ut)) { // // same position in the iteration // // UErrorCode status = U_ZERO_ERROR; // // UChar* b1 = alloca(l1 * sizeof(UChar)); // // UChar* b2 = alloca(l2 * sizeof(UChar)); // // utext_extract(r1->ut, 0, l1, b1, l1, &status); // // utext_extract(r2->ut, 0, l2, b2, l2, &status); // // if (U_FAILURE(status)) printf("extract failed!\n"); // const UChar* b1 = r1->ut->chunkContents; // const UChar* b2 = r2->ut->chunkContents; // result = 1; // for (int i=0; i%d vs <%.*S>%d -> %s\n", // l1, b1, l1, l2, b2, l2, (result ? "same" : "different")); // // printf(" current: %x / %x, utext_equals=%d\n", // // utext_current32(r1->ut), // // utext_current32(r2->ut), // // utext_equals(r1->ut, r2->ut)); // } else { // printf("indexes differ: %d vs %d\n", // utext_getNativeIndex(r1->ut), // utext_getNativeIndex(r2->ut)); // result = 0; // } // } else { // result = 0; // } // #else // result = (strcmp((const char*)r1->buf, (const char*)r2->buf) == 0); // #endif result = ustring_equal(r1->us, r2->us, 0); } } return result; } // Two unicode_reader objects are equivalent? if they point to the same source, // and they are equal? if they additionally point to the same offset within it. // s7 documents `equivalent?` as "...if one thing is basically // the same as some other thing, they satisfy the function // equivalent?." static s7_pointer unicode_reader_is_equivalent_proc(s7_scheme* sc, s7_pointer args) { s7_pointer a1 = s7_car(args); // guaranteed to be a unicode-reader? s7_pointer a2 = s7_cadr(args); if (is_unicode_reader_p(a2)) { unicode_reader* r1 = (unicode_reader*)s7_c_object_value(a1); unicode_reader* r2 = (unicode_reader*)s7_c_object_value(a2); return unicode_reader_same_source_p(sc, r1, r2) ? s7_t(sc) : s7_f(sc); } else { return s7_f(sc); } } static s7_pointer unicode_reader_is_equal_proc(s7_scheme* sc, s7_pointer args) { s7_pointer a1 = s7_car(args); // guaranteed to be a unicode-reader? s7_pointer a2 = s7_cadr(args); if (! is_unicode_reader_p(a2)) { return s7_f(sc); } unicode_reader* r1 = (unicode_reader*)s7_c_object_value(a1); unicode_reader* r2 = (unicode_reader*)s7_c_object_value(a2); int equivalent_p; // see function unicode_reader_is_equivalent_proc if (unicode_reader_same_source_p(sc, r1, r2)) { equivalent_p = 1; } else { equivalent_p = 0; } int result; if (equivalent_p) { if (r1->filename) { // they're both files, reading the same file; // they are also deemed to be the same either if they're // at the same offset, or if both are closed, implying at EOF #if HAVE_ICU int ofs1 = (r1->at_eof_p ? -1 : ftell(u_fgetfile(r1->in))); int ofs2 = (r2->at_eof_p ? -1 : ftell(u_fgetfile(r2->in))); #else int ofs1 = (r1->at_eof_p ? -1 : ftell(r1->in)); int ofs2 = (r2->at_eof_p ? -1 : ftell(r2->in)); #endif result = (ofs1 == ofs2); } else { // both strings result = (r1->count == r2->count); } } else { result = 0; } return result ? s7_t(sc) : s7_f(sc); } #if 0 // Given two unicode_reader objects, determine whether they point to the same source. // This will be true if they are both strings and the strings are equal, // or if they are both files and the files have the same inode. static int unicode_reader_same_source_scheme(s7_scheme* sc, s7_pointer a1, s7_pointer a2) { unicode_reader* r1 = (unicode_reader*)s7_c_object_value(a1); unicode_reader* r2 = (unicode_reader*)s7_c_object_value(a2); int result; if (r1->filename) { if (r2->filename) { // both files struct stat S1; if (stat(r1->filename, &S1) != 0) { // would this be better with a warning and a #f return? return_beastie_error(sc, "can't stat file <%s> (%s)", r1->filename, strerror(errno)); } struct stat S2; if (stat(r2->filename, &S2) != 0) { return_beastie_error(sc, "can't stat file <%s> (%s)", r2->filename, strerror(errno)); } result = (S1.st_ino == S2.st_ino); } else { // r1 is a file, r2 is a string result = 0; } } else { if (r2->filename) { // r1 is a string, r2 is a file result = 0; } else { // both strings result = (strcmp((const char*)r1->buf, (const char*)r2->buf) == 0); } } return result; } #endif // There's no need to expose this function (I don't think...), // since equivalent? does this // { "unicode-reader-same-source*?", // unicode_reader_same_source_proc, // 2, 0, false, // "`(unicode-reader-same-source*? rdr1 rdr2)` :\n" // "return `#t` if the readers have the same source, and `#f` otherwise\n" // "(mostly for internal housekeeping).\n" // "This is not the same as an equality test between values of `unicode-reader-source`,\n" // "since two different paths to the same file will be detected as the same\n" // "by this procedure."}, // // s7_pointer unicode_reader_same_source_proc(s7_scheme* sc, s7_pointer args) // { // s7_pointer a1 = s7_car(args); // s7_pointer a2 = s7_cadr(args); // // if (is_unicode_reader_p(a1) && is_unicode_reader_p(a2)) { // return unicode_reader_same_source(sc, a1, a2) ? s7_t(sc) : s7_f(sc); // } else { // return s7_f(sc); // } // // } // this function is what is passed to the // s7_c_type_set_to_string function s7_pointer unicode_reader_source_proc(s7_scheme* sc, s7_pointer args) { s7_pointer reader = s7_car(args); if (! is_unicode_reader_p(reader)) { return s7_wrong_type_arg_error(sc, "unicode-reader", 1, reader, "a unicode-reader?"); } unicode_reader* p = (unicode_reader*)s7_c_object_value(reader); char buf[PATH_MAX]; char is_file_p; size_t slen = unicode_reader_get_source(p, buf, PATH_MAX, &is_file_p); s7_pointer result; if (is_file_p) { result = s7_make_string_with_length(sc, buf, slen); } else { char* b = alloca(slen + 3); snprintf(b, slen+3, "\"%s\"", buf); result = s7_make_string_with_length(sc, b, slen+2); } // const size_t obuflen = PATH_MAX + sizeof(""); // char obuf[obuflen]; // size_t reslen = snprintf(obuf, obuflen, // (is_file_p // ? "" // : ""), // buf); // return s7_make_string_with_length(sc, obuf, reslen); return result; } #if 0 s7_pointer unicode_reader_source_proc(s7_scheme* sc, s7_pointer args) { s7_pointer reader = s7_car(args); if (! is_unicode_reader_p(reader)) { return s7_wrong_type_arg_error(sc, "unicode-reader", 1, reader, "a unicode-reader?"); } unicode_reader* ur = (unicode_reader*)s7_c_object_value(reader); s7_pointer result; #if 0 if (ur->filename) { result = s7_make_string(sc, ur->filename); } else { // it's a string source char* b = alloca(ur->buflen + 3); sprintf(b, "\"%s\"", ur->buf); result = s7_make_string(sc, b); } #endif return result; } #endif // Provide a string? indication of a reader's location s7_pointer unicode_reader_location(s7_scheme* sc, unicode_reader* ur) { char buf[PATH_MAX]; char is_file_p; size_t nchars = unicode_reader_get_source(ur, buf, PATH_MAX, &is_file_p); char* b; // how long is the longest integer, when written? 2^128 = 10^39? const size_t intlen = 64; if (is_file_p) { // report position as a line number size_t blen = nchars + intlen; b = alloca(blen); snprintf(b, blen, "%s:%zu", buf, ur->line_count); } else { // it's a string source; report position in characters const int maxchars = 32; size_t blen = maxchars + sizeof("\"%.*s...\"[%zu]") + intlen; b = alloca(blen); int nwritten = snprintf(b, blen, "\"%s\"[%zu]", buf, ur->count); if (nwritten < 0) { // error -- whut?! snprintf(b, blen, "??get_source:error"); } else if (nwritten > blen) { // truncated: so try again, shortening the output // (this is an alternative to testing the target size // and branching on that, which produces a semi-heuristic gcc // -Wformat-truncation warning that isn't as helpful // as it thinks it is; but this replacement is arguably a // nicer pattern). snprintf(b, blen, "\"%.*s...\"[%zu]", maxchars, buf, ur->count); } } return s7_make_string(sc, b); }; // call unicode_reader_location from scheme s7_pointer unicode_reader_location_proc(s7_scheme* sc, s7_pointer args) { s7_pointer reader = s7_car(args); if (! is_unicode_reader_p(reader)) { return s7_wrong_type_arg_error(sc, "unicode-reader", 1, reader, "a unicode-reader?"); } return unicode_reader_location(sc, (unicode_reader*)s7_c_object_value(reader)); } s7_pointer make_unicode_reader_file_proc(s7_scheme* sc, s7_pointer args) { s7_pointer fn = s7_car(args); s7_pointer ascii_p = s7_cadr(args); const char* infile; int free_infile_p = 0; if (s7_is_boolean(fn) && !s7_boolean(sc, fn)) { infile = NULL; } else if (is_ustring_p(fn)) { infile = (const char*)ustring_to_utf8((ustring_t)s7_c_object_value(fn), NULL); free_infile_p = 1; } else if (s7_is_string(fn)) { infile = s7_string(fn); } else { return s7_wrong_type_arg_error(sc, "make-unicode-reader/file*", 1, fn, "a ustring? or string? (filename), or #f"); } const char* errmsg; unicode_reader* ur = make_unicode_reader_file(infile, 128, &errmsg); if (free_infile_p) free((void*)infile); if (ur == NULL) { return_beastie_error(sc, "can't make unicode-reader: %s", errmsg); } if (s7_boolean(sc, ascii_p)) { ur->ascii_p = 1; } return s7_make_c_object(sc, unicode_reader_type_tag, (void*)ur); } s7_pointer make_unicode_reader_string_proc(s7_scheme* sc, s7_pointer args) { s7_pointer str = s7_car(args); s7_pointer ascii_p = s7_cadr(args); if (! s7_is_string(str)) { return s7_wrong_type_arg_error(sc, "make-unicode-reader/string*", 1, str, "a string"); } const char* errmsg; // The typecast is a bit of a hack, here, but in practice this // argument is going to be passed as a scheme string, though we're // going to process it as if it were bytes. unicode_reader* ur = make_unicode_reader_string((unsigned char*)s7_string(str), &errmsg); if (ur == NULL) { scheme_eval("print-warning", s7_make_string(sc, "Can't make unicode-reader: ~a"), s7_make_string(sc, errmsg), NULL); return s7_f(sc); } if (s7_boolean(sc, ascii_p)) { ur->ascii_p = 1; } return s7_make_c_object(sc, unicode_reader_type_tag, (void*)ur); } s7_pointer unicode_reader_read_proc(s7_scheme* sc, s7_pointer args) { s7_pointer reader = s7_car(args); s7_pointer optarg = (s7_list_length(sc, args) > 1 ? s7_cadr(args) : NULL); if (! is_unicode_reader_p(reader)) { return s7_wrong_type_arg_error(sc, "unicode-reader-read", 1, reader, "a unicode-reader?"); } s7_pointer result; unicode_reader* ur = (unicode_reader*)s7_c_object_value(reader); if (optarg) { if (s7_is_symbol(optarg) && strcmp(s7_symbol_name(optarg), "location") == 0) { result = unicode_reader_location(sc, ur); } else { return s7_wrong_type_arg_error(sc, "unicode-reader-read", 2, optarg, "a symbol 'location"); } } else { unicode_reader* ur = (unicode_reader*)s7_c_object_value(reader); const char* errmsg; codepoint_t cp = unicode_reader_next_cp(ur, &errmsg); if (cp == UNICODE_EOF) { result = s7_eof_object(sc); } else if (cp == UNICODE_BAD_DECODE) { scheme_eval("print-warning", s7_make_string(sc, "Error reading Unicode from stream at ~a (~a)"), unicode_reader_location(sc, ur), s7_make_string(sc, errmsg), NULL); result = s7_make_integer(sc, UNICODE_REPLACEMENT_CHARACTER); } else if (ur->ascii_p && cp > 0 && cp < 0x80) { result = s7_make_character(sc, cp); } else { result = s7_make_integer(sc, cp); } } return result; } #endif /* ALL_FUNCTIONS */ // ustring support. // A ustring is a unicode string, with a selection of Unicode-friendly operations defined on it. // It has an iterator, so if `us` is a ustring?, then `(map list us)` // will produce a list of lists of codepoint integers. static int ustring_type_tag = 0; // see support for ustring iterators below static s7_pointer make_ustring_iterator_func = NULL; // Make a s7 ustring object from a ustring_t. // After this, the scheme object owns the given ustring, // in the sense that it alone is responsible for freeing it. s7_pointer make_ustring_obj(s7_scheme* sc, ustring_t us) { s7_pointer obj = s7_make_c_object(sc, ustring_type_tag, (void*)us); // Give the object an openlet. // Create this for each object, rather than letting them share a common one, // so that we can store things in this let if we want. s7_c_object_set_let(sc, obj, s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "make-iterator"), make_ustring_iterator_func))); // the following s7_openlet is currently needed (May 2025), // but shouldn't be, according to Bill Schottstaedt // (still needed in v 23 April 2026) s7_openlet(sc, obj); return obj; } // Make a ustring object (called from s7). // If there are any arguments, then these are immediately appended to the string. // The types of these are checked within the functions we call. s7_pointer make_ustring_proc(s7_scheme* sc, s7_pointer args) { const char* errmsg; ustring_t us = make_ustring(&errmsg); if (us == NULL) { return_beastie_error(sc, "can't make ustring: %s", errmsg); } s7_pointer us_obj = make_ustring_obj(sc, us); if (s7_is_null(sc, args)) { return us_obj; } else { return ustring_append_inplace_proc(sc, s7_cons(sc, us_obj, args)); } } static int is_ustring_p(s7_pointer obj) { return s7_is_c_object(obj) && s7_c_object_type(obj) == ustring_type_tag; } s7_pointer is_ustring_proc(s7_scheme* sc, s7_pointer args) { // args is of length 1 return s7_make_boolean(sc, is_ustring_p(s7_car(args))); } static s7_pointer ustring_free_object(s7_scheme* sc, s7_pointer obj) { ustring_t p = (ustring_t)s7_c_object_value(obj); p->cache_store_ = NULL; // redundant but tidy ustring_free(p); return NULL; } static s7_pointer ustring_mark(s7_scheme *sc, s7_pointer obj) { ustring_t p = (ustring_t)s7_c_object_value(obj); if (p->cache_store_ != NULL) { // this object should be managed exclusively by this module, // which must set it to an s7_pointer and nothing else s7_mark((s7_pointer)p->cache_store_); } return NULL; } // Hash a ustring into an unsigned 32-bit integer. // This is an _unsophisticated_ hash function, // merely using the K&R/Java hash function s7_pointer ustring_hash_proc(s7_scheme* sc, s7_pointer args) { s7_pointer str = s7_car(args); if (! is_ustring_p(str)) { return s7_wrong_type_arg_error(sc, "ustring->hash", 1, str, "a ustring"); } ustring_t us = (ustring_t)s7_c_object_value(str); uint32_t h = 0; UChar* p; int i; #if 1 for (p=us->s_, i=us->len_; i > 0; p++, i--) { h = h * 31 + *p; // or 33? } #else // or the PJW/ElfHash function, just for kicks uint32_t high; for (p=us->s_, i=us->len_; i > 0; p++, i--) { h = (h << 4) + *p; if ((high = h) & 0xf0000000) { h ^= high >> 24; h &= ~high; } } #endif return s7_make_integer(sc, h); } s7_pointer ustring_is_equal_proc(s7_scheme* sc, s7_pointer args) { s7_pointer a1 = s7_car(args); s7_pointer a2 = s7_cadr(args); #if !HAVE_ICU s7_pointer rest = s7_cddr(args); #endif ustring_t s1, s2; if (s7_is_string(a1)) { s1 = make_ustring(NULL); ustring_append_utf8(s1, (const uint8_t*)s7_string(a1), NULL); } else if (is_ustring_p(a1)) { s1 = (ustring_t)s7_c_object_value(a1); } else { return s7_f(sc); } if (s7_is_string(a2)) { s2 = make_ustring(NULL); ustring_append_utf8(s2, (const uint8_t*)s7_string(a2), NULL); } else if (is_ustring_p(a2)) { s2 = (ustring_t)s7_c_object_value(a2); } else { return s7_f(sc); } uint8_t flags = 0; #if !HAVE_ICU // ignore this argument (currently) in the ICU case, since it's // hard to implement in unicode.c:ustring_lt while (! s7_is_null(sc, rest)) { if (s7_is_keyword(s7_car(rest))) { s7_pointer kw_sym = s7_keyword_to_symbol(sc, s7_car(rest)); const char* kw_str = s7_symbol_name(kw_sym); if (strcmp(kw_str, "collapse-replacements") == 0) { flags |= USTRING_EQUAL_COLLAPSE_REPLACEMENTS; } else { scheme_eval("print-warning", s7_make_string(sc, "ustring=?: unexpected keyword :~s"), kw_sym, NULL); } } else { return s7_wrong_type_arg_error(sc, "ustring=?", 3, rest, "keyword :collapse-replacements"); } rest = s7_cdr(rest); } #endif return ustring_equal(s1, s2, flags) ? s7_t(sc) : s7_f(sc); } s7_pointer ustring_lt_proc(s7_scheme* sc, s7_pointer args) { s7_pointer a1 = s7_car(args); // not guaranteed to be a ustring? s7_pointer a2 = s7_cadr(args); if (is_ustring_p(a1) && is_ustring_p(a2)) { ustring_t s1 = (ustring_t)s7_c_object_value(a1); ustring_t s2 = (ustring_t)s7_c_object_value(a2); return ustring_lt(s1, s2) ? s7_t(sc) : s7_f(sc); } else { return s7_f(sc); } } #if ALL_FUNCTIONS #if HAVE_ICU s7_pointer unicode_set_locale_proc(s7_scheme* sc, s7_pointer args) { s7_pointer locale = s7_car(args); const char* locale_string = NULL; if (s7_is_string(locale)) { locale_string = s7_string(locale); } else if (s7_is_boolean(locale) && !s7_boolean(sc, locale)) { // locale passed as #f, indicating we want to reset to the default locale_string = NULL; } else { return s7_wrong_type_arg_error(sc, "unicode-set-locale!", 1, locale, "a string or #f"); } // we want to return the locale before the change const char* current_locale = unicode_get_locale(); s7_pointer rval; if (current_locale == NULL) { rval = s7_f(sc); } else { rval = s7_make_string(sc, current_locale); } char* errmsg; if (unicode_set_locale(locale_string, &errmsg) != 0) { scheme_eval("print-warning", s7_make_string(sc, "unicode-set-locale: failed: ~a"), s7_make_string(sc, errmsg), NULL); free(errmsg); rval = s7_f(sc); } return rval; } // each of the following functions takes a ustring and a locale, // and returns non-zero on success #define MAKE_CHAR_LOOKUP_FUNCTION(fnname, icu_function) \ static int fnname(s7_scheme* sc, \ const char* locale, ustring_t us, \ const char** errmsg) \ { \ UErrorCode status = U_ZERO_ERROR; \ char buf[ULOC_FULLNAME_CAPACITY]; \ int rval = 0; \ \ icu_function(locale, buf, ULOC_FULLNAME_CAPACITY, &status); \ if (U_FAILURE(status)) { \ *errmsg = u_errorName(status); \ } else if (ustring_append_utf8(us, (const unsigned char*)buf, errmsg) != NULL) { \ rval = 1; \ } \ return rval; \ } MAKE_CHAR_LOOKUP_FUNCTION(unicode_get_locale_name, uloc_getName); MAKE_CHAR_LOOKUP_FUNCTION(unicode_get_locale_name_canonical, uloc_canonicalize); MAKE_CHAR_LOOKUP_FUNCTION(unicode_get_locale_language, uloc_getLanguage); MAKE_CHAR_LOOKUP_FUNCTION(unicode_get_locale_country, uloc_getCountry); #define MAKE_UCHAR_LOOKUP_FUNCTION(fnname, icu_function) \ static int fnname(s7_scheme* sc, \ const char* locale, ustring_t us, \ const char** errmsg) \ { \ UErrorCode status = U_ZERO_ERROR; \ UChar buf[ULOC_FULLNAME_CAPACITY]; \ int rval = 0; \ \ int32_t rlen = icu_function(locale, NULL, \ buf, ULOC_FULLNAME_CAPACITY, &status); \ if (U_FAILURE(status)) { \ *errmsg = u_errorName(status); \ } else if (ustring_append_uchars(us, buf, rlen, rlen, errmsg) != NULL) { \ /* content all BMP */ \ rval = 1; \ } \ return rval; \ } MAKE_UCHAR_LOOKUP_FUNCTION(unicode_get_locale_name_display, uloc_getDisplayName); MAKE_UCHAR_LOOKUP_FUNCTION(unicode_get_locale_language_display, uloc_getDisplayLanguage); MAKE_UCHAR_LOOKUP_FUNCTION(unicode_get_locale_country_display, uloc_getDisplayCountry); static struct { const char* key; int (*f)(s7_scheme* sc, const char* locale, ustring_t us, const char** errmsg); } unicode_locale_lookups[] = { { "name", &unicode_get_locale_name }, { "language", &unicode_get_locale_language }, { "country", &unicode_get_locale_country }, { "canonical-name", &unicode_get_locale_name_canonical }, { "display-name", &unicode_get_locale_name_display }, { "display-language", &unicode_get_locale_language_display }, { "display-country", &unicode_get_locale_country_display }, }; static const int n_unicode_locale_lookups = sizeof(unicode_locale_lookups)/sizeof(unicode_locale_lookups[0]); s7_pointer unicode_get_locale_proc(s7_scheme* sc, s7_pointer args) { // If there is no argument, then return a list of all of the locales; // if there are two arguments, (unicode-get-local locale-id info), // then return the 'info' (a symbol) for the local 'local-id' (a // string). s7_pointer rval; s7_pointer locale_scm; s7_pointer info_scm; if (s7_is_null(sc, args)) { locale_scm = info_scm = NULL; } else { locale_scm = s7_car(args); if (s7_is_boolean(locale_scm)) { if (s7_boolean(sc, locale_scm)) { return s7_wrong_type_arg_error(sc, "unicode-get-locale", 1, locale_scm, "a string? or #f"); } locale_scm = NULL; } else if (! s7_is_string(locale_scm)) { return s7_wrong_type_arg_error(sc, "unicode-get-locale", 1, locale_scm, "a string?"); } if (s7_is_null(sc, s7_cdr(args))) { info_scm = NULL; } else { info_scm = s7_cadr(args); if (! s7_is_symbol(info_scm)) { return s7_wrong_type_arg_error(sc, "unicode-get-locale", 2, info_scm, "a symbol?"); } if (! s7_is_null(sc, s7_cddr(args))) { return s7_error(sc, s7_make_symbol(sc, "wrong-number-of-args"), s7_list(sc, 2, s7_make_string(sc, "unicode-get-locale: expected at most 2 args, got ~s"), s7_make_integer(sc, s7_list_length(sc, args)))); } } } const char* locale; if (locale_scm == NULL) { locale = unicode_get_locale(); // current locale } else { locale = s7_string(locale_scm); } if (info_scm == NULL) { rval = s7_nil(sc); for (int i=0; i=0; i--) { const char* l = uloc_getAvailable(i); rval = s7_cons(sc, s7_make_string(sc, l), rval); } return rval; } #else // HAVE_ICU s7_pointer unicode_set_locale_proc(s7_scheme* sc, s7_pointer args) { return s7_f(sc); } s7_pointer unicode_get_locale_proc(s7_scheme* sc, s7_pointer args) { int nargs = s7_list_length(sc, args); if (nargs == 0 || nargs == 1) { return s7_nil(sc); } else if (nargs == 2) { return s7_f(sc); } else { return s7_error(sc, s7_make_symbol(sc, "wrong-number-of-args"), s7_list(sc, 2, s7_make_string(sc, "unicode-get-locale: expected at most 2 args, got ~s"), s7_make_integer(sc, s7_list_length(sc, args)))); } } s7_pointer unicode_get_locale_list_proc(s7_scheme* sc, s7_pointer args) { return s7_nil(sc); } #endif // HAVE_ICU #endif /* ALL_FUNCTIONS */ // The serialised form of a ustring is #[...], with internal escapes \[, \\ and \n. // Something like #«...» would be cute, but s7 can't cope with a non-ASCII character after the '#'. // Trying #<...> looks good, and is vaguely guillemet-ish, but of course collides with eg #. // Trying #"..." looks good, but collides with the #"""...""" strings, // and probably works badly with Emacs quote matching. // // There is an optional second argument to object->string. If this is // * #f or :display, then display the result // * #t or :write or absent/default, then use write // * :readable, produce a version which can be read in. // // Here, the :write and :readable cases are identical. // // Compare ustring-read-handler* in unicode.scm, which should be able // to read anything written here. s7_pointer ustring_to_string_proc(s7_scheme* sc, s7_pointer args) { if (! is_ustring_p(s7_car(args))) { return s7_wrong_type_arg_error(sc, "ustring->string", 1, s7_car(args), "a ustring?"); } int write_p; if (s7_list_length(sc, args) > 1) { s7_pointer fmt = s7_cadr(args); if (s7_is_keyword(fmt)) { const char* name = s7_symbol_name(s7_keyword_to_symbol(sc, fmt)); if (strcmp(name, "display") == 0) { write_p = 0; } else if (strcmp(name, "write") == 0 || strcmp(name, "readable") == 0) { write_p = 1; } else { return s7_wrong_type_arg_error(sc, "ustring->string", 2, fmt, ":display/:write/:readable"); } } else if (s7_is_boolean(fmt)) { write_p = s7_boolean(sc, fmt); } else { return s7_wrong_type_arg_error(sc, "ustring->string", 2, fmt, "keyword?"); } } else { write_p = 1; } ustring_t p = (ustring_t)s7_c_object_value(s7_car(args)); const char* errmsg; const uint8_t* b = ustring_to_utf8(p, &errmsg); if (b == NULL) { return_beastie_error(sc, "ustring->string: out of memory!: %s", errmsg); } #if 0 fprintf(stderr, "ustring_to_string: nargs=%lld\n", s7_list_length(sc,args)); s7w4("arg2=", s7_cdr(args), "\n", 1); #endif // TODO: cache this? s7_pointer result; if (write_p) { StringBuilder sb = make_stringbuilder(); stringbuilder_append_s(sb, "#\""); for (const uint8_t* p=b; *p != '\0'; p++) { char escchar = '\0'; switch (*p) { case '\\': escchar = '\\'; break; case '"': escchar = '"'; break; case '\n': escchar = 'n'; break; } if (escchar) { stringbuilder_append_c(sb, '\\'); stringbuilder_append_c(sb, escchar); } else { stringbuilder_append_c(sb, *p); } } stringbuilder_append_c(sb, '"'); result = s7_make_string_with_length(sc, sb->buf, sb->len); stringbuilder_free(sb); } else { result = s7_make_string(sc, (const char*)b); } free((void*)b); return result; } // this is equivalent to // (string->symbol (object->string us :display)), // but (a) more direct, and (b) object->string seems to have a // problem with the format argument in s7 11.4 s7_pointer ustring_to_symbol_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_arg = s7_car(args); if (! is_ustring_p(us_arg)) { return s7_wrong_type_arg_error(sc, "ustring->symbol", 1, us_arg, "a ustring?"); } ustring_t us = (ustring_t)s7_c_object_value(us_arg); const char* errmsg; const uint8_t* b = ustring_to_utf8(us, &errmsg); if (b == NULL) { return_beastie_error(sc, "ustring->symbol: out of memory!: %s", errmsg); } s7_pointer result = s7_make_symbol(sc, (const char*)b); free((void*)b); return result; } s7_pointer symbol_to_ustring_proc(s7_scheme* sc, s7_pointer args) { s7_pointer sym_arg = s7_car(args); if (! s7_is_symbol(sym_arg)) { return s7_wrong_type_arg_error(sc, "symbol->ustring", 1, sym_arg, "a symbol?"); } const char* sym = s7_symbol_name(sym_arg); return make_ustring_obj(sc, ustring_append_utf8(make_ustring(NULL), (byte_t*)sym, NULL)); } // Given a ustring_t object `target` and a list `to_append` of s7_pointer, // append each of the list items to the ustring_t. // // errmsg must be non-NULL static ustring_t ustring_append_list(s7_scheme* sc, ustring_t target, s7_pointer to_append, const char** errmsg) { int argidx = 2; // for error messages, noting that target comes from arg1 while (! s7_is_null(sc, to_append) && *errmsg == NULL) { s7_pointer s1 = s7_car(to_append); if (s7_is_integer(s1) || s7_is_character(s1)) { ustring_append_cp(target, s7_is_integer(s1) ? s7_integer(s1) : s7_character(s1), errmsg); } else if (s7_is_string(s1)) { ustring_append_utf8(target, (uint8_t*)s7_string(s1), errmsg); } else if (is_ustring_p(s1)) { ustring_append_ustring(target, s7_c_object_value(s1), errmsg); } else if (s7_is_list(sc, s1)) { ustring_append_list(sc, target, s1, errmsg); } else { s7_wrong_type_arg_error(sc, "ustring-append", argidx, s1, "integer?/char?/string?/ustring?/list?"); // NOT REACHED return NULL; } to_append = s7_cdr(to_append); argidx++; } return NULL; } // (ustring-append! a1 a2 ...) // append a2... to the ustring a1, in place s7_pointer ustring_append_inplace_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); if (! is_ustring_p(us_obj)) { s7w("ustring_append: args=", args, "\n"); return s7_wrong_type_arg_error(sc, "ustring-append!", 1, us_obj, "a ustring?"); } s7_pointer rest = s7_cdr(args); if (! s7_is_null(sc, rest)) { // if only one arg, nothing to do const char* errmsg = NULL; ustring_append_list(sc, s7_c_object_value(us_obj), rest, &errmsg); if (errmsg != NULL) { return_beastie_error(sc, "ustring-append!: %s", errmsg); } } return us_obj; } // (ustring-append a1 a2 ...) // create a new ustring, and add a1... to it s7_pointer ustring_append_new_proc(s7_scheme* sc, s7_pointer args) { return make_ustring_proc(sc, args); } s7_pointer ustring_length_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); if (! is_ustring_p(us_obj)) { return s7_wrong_type_arg_error(sc, "ustring-length", 1, us_obj, "a ustring?"); } ustring_t us = s7_c_object_value(us_obj); return s7_make_integer(sc, ustring_length(us)); } // I'd quite like to get rid of ustring-ref, and have ustring-car be the only accessor! s7_pointer ustring_ref_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); s7_pointer idx_obj = s7_cadr(args); if (! is_ustring_p(us_obj)) { return s7_wrong_type_arg_error(sc, "ustring-ref", 1, us_obj, "a ustring?"); } ustring_t us = s7_c_object_value(us_obj); if (! s7_is_integer(idx_obj)) { s7w("ustring_ref_proc: us=", us_obj, "\n"); return s7_wrong_type_arg_error(sc, "ustring-ref", 2, idx_obj, "an integer"); } int idx = s7_integer(idx_obj); codepoint_t cp = ustring_ref(us, idx); if (cp == 0) { const char msglen = 64; char* msg = alloca(msglen); snprintf(msg, msglen, "ustring reference %d out of range", idx); return s7_error(sc, s7_make_symbol(sc, "out-of-range"), s7_cons(sc, s7_make_string(sc, msg), s7_nil(sc))); } else { return s7_make_integer(sc, cp); } } #if ALL_FUNCTIONS s7_pointer ustring_car_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); if (! is_ustring_p(us_obj)) { return s7_wrong_type_arg_error(sc, "ustring-car", 1, us_obj, "a ustring?"); } ustring_t us = s7_c_object_value(us_obj); return (ustring_length(us) == 0 ? s7_f(sc) : s7_make_integer(sc, ustring_ref(us, 0))); } s7_pointer ustring_substring_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); s7_pointer start_obj = s7_cadr(args); s7_pointer end_obj; if (s7_list_length(sc, args) > 2) { end_obj = s7_caddr(args); } else { end_obj = NULL; } if (! is_ustring_p(us_obj)) { return s7_wrong_type_arg_error(sc, "ustring-substring", 1, us_obj, "a ustring?"); } ustring_t us = s7_c_object_value(us_obj); if (! s7_is_integer(start_obj)) { return s7_wrong_type_arg_error(sc, "ustring-substring", 2, start_obj, "an integer"); } int start = s7_integer(start_obj); if (start < 0) { // should this be beastie-error instead? return s7_wrong_type_arg_error(sc, "ustring-substring", 2, start_obj, "a positive integer"); } int end; if (end_obj == NULL) { end = -1; } else if (s7_is_integer(end_obj)) { end = s7_integer(end_obj); } else if (s7_is_boolean(end_obj) && !s7_boolean(sc, end_obj)) { // it's #f end = -1; } else { return s7_wrong_type_arg_error(sc, "ustring-substring", 3, end_obj, "an integer or #f"); } if (end >= 0 && end < start) { // should this be beastie-error instead? return s7_wrong_type_arg_error(sc, "ustring-substring", 3, end_obj, "a positive integer, greater than start, or #f"); } const char* errmsg = NULL; ustring_t result = ustring_substring(us, start, end, &errmsg); if (result == NULL) { return_beastie_error(sc, "ustring-substring: %s", errmsg); // does not return } return make_ustring_obj(sc, result); } s7_pointer ustring_index_proc(s7_scheme* sc, s7_pointer args) { // (ustring-index* us cp start-idx end-idx) // Return the index of the first occurrence of the codepoint cp // in the ustring us. If start-idx and end-idx are not #f, // they are the starting index and one-past the end index. s7_pointer us_obj = s7_car(args); s7_pointer cp_obj = s7_cadr(args); s7_pointer start_obj = s7_caddr(args); s7_pointer end_obj = s7_cadddr(args); if (! is_ustring_p(us_obj)) s7_wrong_type_arg_error(sc, "ustring-index*", 1, us_obj, "a ustring?"); ustring_t us = s7_c_object_value(us_obj); if (! s7_is_integer(cp_obj)) s7_wrong_type_arg_error(sc, "ustring-index*", 2, cp_obj, "a codepoint (integer)"); codepoint_t cp = s7_integer(cp_obj); if (!s7_is_integer(start_obj)) s7_wrong_type_arg_error(sc, "ustring-index*", 3, start_obj, "an integer"); int start_idx = s7_integer(start_obj); int end_idx = 0; if (s7_is_integer(end_obj)) { end_idx = s7_integer(end_obj); } else if (s7_is_boolean(end_obj) && !s7_boolean(sc, end_obj)) { // :end #f end_idx = ustring_length(us); } else { s7_wrong_type_arg_error(sc, "ustring-index*", 4, end_obj, "an integer or #f"); } int oor = 0; // index 0 is never out of range if (start_idx < 0 || start_idx > ustring_length(us)) { oor = start_idx; } else if (end_idx < 0 || end_idx > ustring_length(us)) { oor = end_idx; } if (oor != 0) { const char msglen = 64; char* msg = alloca(msglen); snprintf(msg, msglen, "ustring-index %d out of range", oor); return s7_error(sc, s7_make_symbol(sc, "out-of-range"), s7_cons(sc, s7_make_string(sc, msg), s7_nil(sc))); } int result = -1; for (int i=start_idx; is_[i] == cp) { result = i; break; } } return (result>=0 ? s7_make_integer(sc, result) : s7_f(sc)); } s7_pointer ustring_map_internal_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); s7_pointer op_obj = s7_cadr(args); if (! is_ustring_p(us_obj)) s7_wrong_type_arg_error(sc, "ustring-map-internal*", 1, us_obj, "a ustring?"); if (! s7_is_symbol(op_obj)) s7_wrong_type_arg_error(sc, "ustring-map-internal*", 2, op_obj, "a symbol?"); codepoint_t (*op_fn)(const codepoint_t); const char* op = s7_symbol_name(op_obj); if (strcmp(op, "uppercase") == 0) { op_fn = UNIPROP_FUNC(uppercase_character); } else if (strcmp(op, "lowercase") == 0) { op_fn = UNIPROP_FUNC(lowercase_character); } else if (strcmp(op, "titlecase") == 0) { op_fn = UNIPROP_FUNC(titlecase_character); } else { s7_wrong_type_arg_error(sc, "ustring-map-internal*", 2, op_obj, "symbol upper/lower/titlecase"); // NOT REACHED return NULL; } ustring_t us = s7_c_object_value(us_obj); ustring_map_func(us, op_fn); return us_obj; } s7_pointer ustring_cache_object_get_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); if (! is_ustring_p(us_obj)) s7_wrong_type_arg_error(sc, "ustring-cache-object-get*", 1, us_obj, "a ustring?"); // we don't care what the cache object is ustring_t us = s7_c_object_value(us_obj); const void* store = ustring_cache_store_get(us); if (store == NULL) { return s7_f(sc); } else { return (s7_pointer)store; } } s7_pointer ustring_cache_object_set_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_obj = s7_car(args); s7_pointer new_obj = s7_cadr(args); if (! is_ustring_p(us_obj)) s7_wrong_type_arg_error(sc, "ustring-cache-object-set!*", 1, us_obj, "a ustring?"); ustring_t us = s7_c_object_value(us_obj); if (s7_boolean(sc, new_obj)) { // we don't care what the cache object is ustring_cache_store_set(us, (void*)new_obj); } else { // the new value is #f, but store NULL (ie, erase the cache) // rather than storing that ustring_cache_store_set(us, NULL); } // to match the standard set! procedure, we should return the new value return new_obj; } #endif /* ALL_FUNCTIONS */ // ustring-iterator -- the iterator for ustring? objects. // This wraps a unicode_reader, defined in unicode.c. static int ustring_iterator_type_tag = 0; struct ustring_iterator_s { // we hold on to the ustring, so that we can mark it when required s7_pointer ustring; unicode_reader* ur; }; typedef struct ustring_iterator_s* ustring_iterator_t; s7_pointer make_ustring_iterator_proc(s7_scheme* sc, s7_pointer args) { s7_pointer us_arg = s7_car(args); if (! is_ustring_p(us_arg)) { return s7_wrong_type_arg_error(sc, "make-ustring-iterator*", 1, us_arg, "a ustring?"); } const ustring_t us = (ustring_t)s7_c_object_value(us_arg); ustring_iterator_t usi = malloc(sizeof(struct ustring_iterator_s)); if (usi == NULL) { return_beastie_error(sc, "make-ustring-iterator*: can't allocate %zu bytes!", sizeof(struct ustring_iterator_s)); } usi->ustring = us_arg; // we don't own this const char* errmsg; usi->ur = make_unicode_reader_ustring(us, &errmsg); if (usi->ur == NULL) { free(usi); return_beastie_error(sc, "make-ustring-iterator*: can't create ustring reader: %s", errmsg); } return s7_make_iterator(sc, s7_make_c_object(sc, ustring_iterator_type_tag, (void*)usi)); } static int ustring_iterator_p(s7_pointer obj) { return s7_is_c_object(obj) && s7_c_object_type(obj) == ustring_iterator_type_tag; } static s7_pointer ustring_iterator_free(s7_scheme* sc, s7_pointer obj) { ustring_iterator_t usi = (ustring_iterator_t)s7_c_object_value(obj); unicode_reader_free(usi->ur); // ...but we do not free the ustring free(usi); return NULL; } static s7_pointer ustring_iterator_mark(s7_scheme* sc, s7_pointer obj) { ustring_iterator_t usi = (ustring_iterator_t)s7_c_object_value(obj); s7_mark(usi->ustring); return NULL; } static s7_pointer ustring_iterator_is_equal_proc(s7_scheme* sc, s7_pointer args) { // all iterators are deemed unequal return s7_f(sc); } static s7_pointer ustring_iterator_to_string_proc(s7_scheme* sc, s7_pointer args) { return s7_make_string(sc, "#"); // pretty basic! } s7_pointer ustring_iterator_yield_proc(s7_scheme* sc, s7_pointer args) { ustring_iterator_t usi = (ustring_iterator_t)s7_c_object_value(s7_car(args)); codepoint_t cp = unicode_reader_next_cp(usi->ur, NULL); if (cp == UNICODE_EOF) { return s7_eof_object(sc); } else { return s7_make_integer(sc, cp); } } s7_pointer ustring_iterator_length_proc(s7_scheme* sc, s7_pointer args) { if (! ustring_iterator_p(s7_car(args))) { return s7_wrong_type_arg_error(sc, "ustring-iterator-length", 1, s7_car(args), "a ustring?"); } ustring_iterator_t usi = (ustring_iterator_t)s7_c_object_value(s7_car(args)); const ustring_t us = (ustring_t)s7_c_object_value(usi->ustring); return s7_make_integer(sc, ustring_length(us)); } // pull it all together s7_pointer unicode_load_hook(s7_scheme* sc, s7_pointer args) { if (ustring_type_tag != 0) { // been here before! return args; } #if ALL_FUNCTIONS // define the unicode-reader type unicode_reader_type_tag = s7_make_c_type(sc, "unicode-reader"); s7_c_type_set_gc_free(sc, unicode_reader_type_tag, free_unicode_reader_object); s7_c_type_set_gc_mark(sc, unicode_reader_type_tag, mark_unicode_reader); s7_c_type_set_is_equivalent(sc, unicode_reader_type_tag, unicode_reader_is_equivalent_proc); s7_c_type_set_is_equal(sc, unicode_reader_type_tag, unicode_reader_is_equal_proc); s7_c_type_set_to_string(sc, unicode_reader_type_tag, unicode_reader_source_proc); s7_c_type_set_ref(sc, unicode_reader_type_tag, unicode_reader_read_proc); #endif /* ALL_FUNCTIONS */ // ...and the ustring type ustring_type_tag = s7_make_c_type(sc, "ustring"); s7_c_type_set_gc_free(sc, ustring_type_tag, ustring_free_object); s7_c_type_set_gc_mark(sc, ustring_type_tag, ustring_mark); s7_c_type_set_is_equivalent(sc, ustring_type_tag, ustring_is_equal_proc); s7_c_type_set_is_equal(sc, ustring_type_tag, ustring_is_equal_proc); s7_c_type_set_to_string(sc, ustring_type_tag, ustring_to_string_proc); s7_c_type_set_ref(sc, ustring_type_tag, ustring_ref_proc); // ...and the iterator ustring_iterator_type_tag = s7_make_c_type(sc, "ustring-iterator"); s7_c_type_set_gc_free(sc, ustring_iterator_type_tag, ustring_iterator_free); s7_c_type_set_gc_mark(sc, ustring_iterator_type_tag, ustring_iterator_mark); s7_c_type_set_is_equivalent(sc, ustring_iterator_type_tag, ustring_iterator_is_equal_proc); s7_c_type_set_is_equal(sc, ustring_iterator_type_tag, ustring_iterator_is_equal_proc); s7_c_type_set_to_string(sc, ustring_iterator_type_tag, ustring_iterator_to_string_proc); s7_c_type_set_ref(sc, ustring_iterator_type_tag, ustring_iterator_yield_proc); s7_c_type_set_length(sc, ustring_iterator_type_tag, ustring_iterator_length_proc); make_ustring_iterator_func = s7_make_function(sc, "make-ustring-iterator*", make_ustring_iterator_proc, 1, 0, false, "make a ustring iterator"); s7_gc_protect(sc, make_ustring_iterator_func); // I presume I need to do this... // I don't think I need to expose this function, // other than via the per-object environment char* initialise_error = NULL; if (initialise_unicode_module(&initialise_error) != 0) { s7_pointer msg = prepare_beastie_error(sc, "Can't initialise unicode module: %s", initialise_error); free(initialise_error); return s7_error(sc, s7_make_symbol(sc, "beastie"), msg); // doesn't return } // no changes to the environment are required -- simply return the arguments return args; }