strings.c 62 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345
  1. /* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  2. *
  3. * This library is free software; you can redistribute it and/or
  4. * modify it under the terms of the GNU Lesser General Public License
  5. * as published by the Free Software Foundation; either version 3 of
  6. * the License, or (at your option) any later version.
  7. *
  8. * This library is distributed in the hope that it will be useful, but
  9. * WITHOUT ANY WARRANTY; without even the implied warranty of
  10. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. * Lesser General Public License for more details.
  12. *
  13. * You should have received a copy of the GNU Lesser General Public
  14. * License along with this library; if not, write to the Free Software
  15. * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16. * 02110-1301 USA
  17. */
  18. #ifdef HAVE_CONFIG_H
  19. # include <config.h>
  20. #endif
  21. #include <alloca.h>
  22. #include <string.h>
  23. #include <stdio.h>
  24. #include <ctype.h>
  25. #include <uninorm.h>
  26. #include <unistr.h>
  27. #include <uniconv.h>
  28. #include "striconveh.h"
  29. #include "libguile/_scm.h"
  30. #include "libguile/chars.h"
  31. #include "libguile/root.h"
  32. #include "libguile/strings.h"
  33. #include "libguile/error.h"
  34. #include "libguile/generalized-vectors.h"
  35. #include "libguile/deprecation.h"
  36. #include "libguile/validate.h"
  37. #include "libguile/private-options.h"
  38. /* {Strings}
  39. */
  40. /* Stringbufs
  41. *
  42. * XXX - keeping an accurate refcount during GC seems to be quite
  43. * tricky, so we just keep score of whether a stringbuf might be
  44. * shared, not whether it definitely is.
  45. *
  46. * The scheme I (mvo) tried to keep an accurate reference count would
  47. * recount all strings that point to a stringbuf during the mark-phase
  48. * of the GC. This was done since one cannot access the stringbuf of
  49. * a string when that string is freed (in order to decrease the
  50. * reference count). The memory of the stringbuf might have been
  51. * reused already for something completely different.
  52. *
  53. * This recounted worked for a small number of threads beating on
  54. * cow-strings, but it failed randomly with more than 10 threads, say.
  55. * I couldn't figure out what went wrong, so I used the conservative
  56. * approach implemented below.
  57. *
  58. * There are 2 storage strategies for stringbufs: 8-bit and wide. 8-bit
  59. * strings are ISO-8859-1-encoded strings; wide strings are 32-bit (UCS-4)
  60. * strings.
  61. */
  62. /* The size in words of the stringbuf header (type tag + size). */
  63. #define STRINGBUF_HEADER_SIZE 2U
  64. #define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM))
  65. #define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED
  66. #define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE
  67. #define STRINGBUF_TAG scm_tc7_stringbuf
  68. #define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
  69. #define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
  70. #define STRINGBUF_CONTENTS(buf) ((void *) \
  71. SCM_CELL_OBJECT_LOC (buf, \
  72. STRINGBUF_HEADER_SIZE))
  73. #define STRINGBUF_CHARS(buf) ((unsigned char *) STRINGBUF_CONTENTS (buf))
  74. #define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) STRINGBUF_CONTENTS (buf))
  75. #define STRINGBUF_LENGTH(buf) (SCM_CELL_WORD_1 (buf))
  76. #define SET_STRINGBUF_SHARED(buf) \
  77. do \
  78. { \
  79. /* Don't modify BUF if it's already marked as shared since it might be \
  80. a read-only, statically allocated stringbuf. */ \
  81. if (SCM_LIKELY (!STRINGBUF_SHARED (buf))) \
  82. SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED); \
  83. } \
  84. while (0)
  85. #ifdef SCM_STRING_LENGTH_HISTOGRAM
  86. static size_t lenhist[1001];
  87. #endif
  88. /* Make a stringbuf with space for LEN 8-bit Latin-1-encoded
  89. characters. */
  90. static SCM
  91. make_stringbuf (size_t len)
  92. {
  93. /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
  94. scm_i_symbol_chars, all stringbufs are null-terminated. Once
  95. SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
  96. has been changed for scm_i_symbol_chars, this null-termination
  97. can be dropped.
  98. */
  99. SCM buf;
  100. #ifdef SCM_STRING_LENGTH_HISTOGRAM
  101. if (len < 1000)
  102. lenhist[len]++;
  103. else
  104. lenhist[1000]++;
  105. #endif
  106. buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1,
  107. "string"));
  108. SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG);
  109. SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len);
  110. STRINGBUF_CHARS (buf)[len] = 0;
  111. return buf;
  112. }
  113. /* Make a stringbuf with space for LEN 32-bit UCS-4-encoded
  114. characters. */
  115. static SCM
  116. make_wide_stringbuf (size_t len)
  117. {
  118. SCM buf;
  119. size_t raw_len;
  120. #ifdef SCM_STRING_LENGTH_HISTOGRAM
  121. if (len < 1000)
  122. lenhist[len]++;
  123. else
  124. lenhist[1000]++;
  125. #endif
  126. raw_len = (len + 1) * sizeof (scm_t_wchar);
  127. buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len,
  128. "string"));
  129. SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE);
  130. SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len);
  131. STRINGBUF_WIDE_CHARS (buf)[len] = 0;
  132. return buf;
  133. }
  134. /* Return a UCS-4-encoded stringbuf containing the (possibly Latin-1-encoded)
  135. characters from BUF. */
  136. static SCM
  137. wide_stringbuf (SCM buf)
  138. {
  139. SCM new_buf;
  140. if (STRINGBUF_WIDE (buf))
  141. new_buf = buf;
  142. else
  143. {
  144. size_t i, len;
  145. scm_t_wchar *mem;
  146. len = STRINGBUF_LENGTH (buf);
  147. new_buf = make_wide_stringbuf (len);
  148. mem = STRINGBUF_WIDE_CHARS (new_buf);
  149. for (i = 0; i < len; i++)
  150. mem[i] = (scm_t_wchar) STRINGBUF_CHARS (buf)[i];
  151. mem[len] = 0;
  152. }
  153. return new_buf;
  154. }
  155. /* Return a Latin-1-encoded stringbuf containing the (possibly UCS-4-encoded)
  156. characters from BUF, if possible. */
  157. static SCM
  158. narrow_stringbuf (SCM buf)
  159. {
  160. SCM new_buf;
  161. if (!STRINGBUF_WIDE (buf))
  162. new_buf = buf;
  163. else
  164. {
  165. size_t i, len;
  166. scm_t_wchar *wmem;
  167. unsigned char *mem;
  168. len = STRINGBUF_LENGTH (buf);
  169. wmem = STRINGBUF_WIDE_CHARS (buf);
  170. for (i = 0; i < len; i++)
  171. if (wmem[i] > 0xFF)
  172. /* BUF cannot be narrowed. */
  173. return buf;
  174. new_buf = make_stringbuf (len);
  175. mem = STRINGBUF_CHARS (new_buf);
  176. for (i = 0; i < len; i++)
  177. mem[i] = (unsigned char) wmem[i];
  178. mem[len] = 0;
  179. }
  180. return new_buf;
  181. }
  182. scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  183. /* Copy-on-write strings.
  184. */
  185. #define STRING_TAG scm_tc7_string
  186. #define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
  187. #define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
  188. #define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str))
  189. #define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
  190. #define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
  191. #define IS_STRING(str) (SCM_HAS_TYP7 (str, STRING_TAG))
  192. /* Read-only strings.
  193. */
  194. #define RO_STRING_TAG scm_tc7_ro_string
  195. #define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
  196. /* Mutation-sharing substrings
  197. */
  198. #define SH_STRING_TAG (scm_tc7_string + 0x100)
  199. #define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
  200. /* START and LENGTH as for STRINGs. */
  201. #define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
  202. SCM scm_nullstr;
  203. /* Create a scheme string with space for LEN 8-bit Latin-1-encoded
  204. characters. CHARSP, if not NULL, will be set to location of the
  205. char array. If READ_ONLY_P, the returned string is read-only;
  206. otherwise it is writable. */
  207. SCM
  208. scm_i_make_string (size_t len, char **charsp, int read_only_p)
  209. {
  210. static SCM null_stringbuf = SCM_BOOL_F;
  211. SCM buf;
  212. SCM res;
  213. if (len == 0)
  214. {
  215. if (SCM_UNLIKELY (scm_is_false (null_stringbuf)))
  216. {
  217. null_stringbuf = make_stringbuf (0);
  218. SET_STRINGBUF_SHARED (null_stringbuf);
  219. }
  220. buf = null_stringbuf;
  221. }
  222. else
  223. buf = make_stringbuf (len);
  224. if (charsp)
  225. *charsp = (char *) STRINGBUF_CHARS (buf);
  226. res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
  227. SCM_UNPACK (buf),
  228. (scm_t_bits) 0, (scm_t_bits) len);
  229. return res;
  230. }
  231. /* Create a scheme string with space for LEN 32-bit UCS-4-encoded
  232. characters. CHARSP, if not NULL, will be set to location of the
  233. character array. If READ_ONLY_P, the returned string is read-only;
  234. otherwise it is writable. */
  235. SCM
  236. scm_i_make_wide_string (size_t len, scm_t_wchar **charsp, int read_only_p)
  237. {
  238. SCM buf = make_wide_stringbuf (len);
  239. SCM res;
  240. if (charsp)
  241. *charsp = STRINGBUF_WIDE_CHARS (buf);
  242. res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
  243. SCM_UNPACK (buf),
  244. (scm_t_bits) 0, (scm_t_bits) len);
  245. return res;
  246. }
  247. static void
  248. validate_substring_args (SCM str, size_t start, size_t end)
  249. {
  250. if (!IS_STRING (str))
  251. scm_wrong_type_arg_msg (NULL, 0, str, "string");
  252. if (start > STRING_LENGTH (str))
  253. scm_out_of_range (NULL, scm_from_size_t (start));
  254. if (end > STRING_LENGTH (str) || end < start)
  255. scm_out_of_range (NULL, scm_from_size_t (end));
  256. }
  257. static inline void
  258. get_str_buf_start (SCM *str, SCM *buf, size_t *start)
  259. {
  260. *start = STRING_START (*str);
  261. if (IS_SH_STRING (*str))
  262. {
  263. *str = SH_STRING_STRING (*str);
  264. *start += STRING_START (*str);
  265. }
  266. *buf = STRING_STRINGBUF (*str);
  267. }
  268. SCM
  269. scm_i_substring (SCM str, size_t start, size_t end)
  270. {
  271. if (start == end)
  272. return scm_i_make_string (0, NULL, 0);
  273. else
  274. {
  275. SCM buf;
  276. size_t str_start;
  277. get_str_buf_start (&str, &buf, &str_start);
  278. scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  279. SET_STRINGBUF_SHARED (buf);
  280. scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  281. return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
  282. (scm_t_bits)str_start + start,
  283. (scm_t_bits) end - start);
  284. }
  285. }
  286. SCM
  287. scm_i_substring_read_only (SCM str, size_t start, size_t end)
  288. {
  289. if (start == end)
  290. return scm_i_make_string (0, NULL, 1);
  291. else
  292. {
  293. SCM buf;
  294. size_t str_start;
  295. get_str_buf_start (&str, &buf, &str_start);
  296. scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  297. SET_STRINGBUF_SHARED (buf);
  298. scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  299. return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
  300. (scm_t_bits)str_start + start,
  301. (scm_t_bits) end - start);
  302. }
  303. }
  304. SCM
  305. scm_i_substring_copy (SCM str, size_t start, size_t end)
  306. {
  307. if (start == end)
  308. return scm_i_make_string (0, NULL, 0);
  309. else
  310. {
  311. size_t len = end - start;
  312. SCM buf, my_buf, substr;
  313. size_t str_start;
  314. int wide = 0;
  315. get_str_buf_start (&str, &buf, &str_start);
  316. if (scm_i_is_narrow_string (str))
  317. {
  318. my_buf = make_stringbuf (len);
  319. memcpy (STRINGBUF_CHARS (my_buf),
  320. STRINGBUF_CHARS (buf) + str_start + start, len);
  321. }
  322. else
  323. {
  324. my_buf = make_wide_stringbuf (len);
  325. u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf),
  326. (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start
  327. + start), len);
  328. wide = 1;
  329. }
  330. scm_remember_upto_here_1 (buf);
  331. substr = scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
  332. (scm_t_bits) 0, (scm_t_bits) len);
  333. if (wide)
  334. scm_i_try_narrow_string (substr);
  335. return substr;
  336. }
  337. }
  338. SCM
  339. scm_i_substring_shared (SCM str, size_t start, size_t end)
  340. {
  341. if (start == 0 && end == STRING_LENGTH (str))
  342. return str;
  343. else if (start == end)
  344. return scm_i_make_string (0, NULL, 0);
  345. else
  346. {
  347. size_t len = end - start;
  348. if (IS_SH_STRING (str))
  349. {
  350. start += STRING_START (str);
  351. str = SH_STRING_STRING (str);
  352. }
  353. return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
  354. (scm_t_bits)start, (scm_t_bits) len);
  355. }
  356. }
  357. SCM
  358. scm_c_substring (SCM str, size_t start, size_t end)
  359. {
  360. validate_substring_args (str, start, end);
  361. return scm_i_substring (str, start, end);
  362. }
  363. SCM
  364. scm_c_substring_read_only (SCM str, size_t start, size_t end)
  365. {
  366. validate_substring_args (str, start, end);
  367. return scm_i_substring_read_only (str, start, end);
  368. }
  369. SCM
  370. scm_c_substring_copy (SCM str, size_t start, size_t end)
  371. {
  372. validate_substring_args (str, start, end);
  373. return scm_i_substring_copy (str, start, end);
  374. }
  375. SCM
  376. scm_c_substring_shared (SCM str, size_t start, size_t end)
  377. {
  378. validate_substring_args (str, start, end);
  379. return scm_i_substring_shared (str, start, end);
  380. }
  381. /* Internal accessors
  382. */
  383. /* Returns the number of characters in STR. This may be different
  384. than the memory size of the string storage. */
  385. size_t
  386. scm_i_string_length (SCM str)
  387. {
  388. return STRING_LENGTH (str);
  389. }
  390. /* True if the string is 'narrow', meaning it has a 8-bit Latin-1
  391. encoding. False if it is 'wide', having a 32-bit UCS-4
  392. encoding. */
  393. int
  394. scm_i_is_narrow_string (SCM str)
  395. {
  396. if (IS_SH_STRING (str))
  397. str = SH_STRING_STRING (str);
  398. return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
  399. }
  400. /* Try to coerce a string to be narrow. It if is narrow already, do
  401. nothing. If it is wide, shrink it to narrow if none of its
  402. characters are above 0xFF. Return true if the string is narrow or
  403. was made to be narrow. */
  404. int
  405. scm_i_try_narrow_string (SCM str)
  406. {
  407. if (IS_SH_STRING (str))
  408. str = SH_STRING_STRING (str);
  409. SET_STRING_STRINGBUF (str, narrow_stringbuf (STRING_STRINGBUF (str)));
  410. return scm_i_is_narrow_string (str);
  411. }
  412. /* Return a pointer to the raw data of the string, which can be either Latin-1
  413. or UCS-4 encoded data, depending on `scm_i_is_narrow_string (STR)'. */
  414. const void *
  415. scm_i_string_data (SCM str)
  416. {
  417. SCM buf;
  418. size_t start;
  419. const char *data;
  420. get_str_buf_start (&str, &buf, &start);
  421. data = STRINGBUF_CONTENTS (buf);
  422. data += start * (scm_i_is_narrow_string (str) ? 1 : 4);
  423. return data;
  424. }
  425. /* Returns a pointer to the 8-bit Latin-1 encoded character array of
  426. STR. */
  427. const char *
  428. scm_i_string_chars (SCM str)
  429. {
  430. SCM buf;
  431. size_t start;
  432. get_str_buf_start (&str, &buf, &start);
  433. if (scm_i_is_narrow_string (str))
  434. return (const char *) STRINGBUF_CHARS (buf) + start;
  435. else
  436. scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s",
  437. scm_list_1 (str));
  438. return NULL;
  439. }
  440. /* Returns a pointer to the 32-bit UCS-4 encoded character array of
  441. STR. */
  442. const scm_t_wchar *
  443. scm_i_string_wide_chars (SCM str)
  444. {
  445. SCM buf;
  446. size_t start;
  447. get_str_buf_start (&str, &buf, &start);
  448. if (!scm_i_is_narrow_string (str))
  449. return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf) + start;
  450. else
  451. scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
  452. scm_list_1 (str));
  453. }
  454. /* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
  455. a new string buffer, so that it can be modified without modifying
  456. other strings. Also, lock the string mutex. Later, one must call
  457. scm_i_string_stop_writing to unlock the mutex. */
  458. SCM
  459. scm_i_string_start_writing (SCM orig_str)
  460. {
  461. SCM buf, str = orig_str;
  462. size_t start;
  463. get_str_buf_start (&str, &buf, &start);
  464. if (IS_RO_STRING (str))
  465. scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
  466. scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  467. if (STRINGBUF_SHARED (buf))
  468. {
  469. /* Clone the stringbuf. */
  470. size_t len = STRING_LENGTH (str);
  471. SCM new_buf;
  472. scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  473. if (scm_i_is_narrow_string (str))
  474. {
  475. new_buf = make_stringbuf (len);
  476. memcpy (STRINGBUF_CHARS (new_buf),
  477. STRINGBUF_CHARS (buf) + STRING_START (str), len);
  478. }
  479. else
  480. {
  481. new_buf = make_wide_stringbuf (len);
  482. u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
  483. (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf)
  484. + STRING_START (str)), len);
  485. }
  486. SET_STRING_STRINGBUF (str, new_buf);
  487. start -= STRING_START (str);
  488. /* FIXME: The following operations are not atomic, so other threads
  489. looking at STR may see an inconsistent state. Nevertheless it can't
  490. hurt much since (i) accessing STR while it is being mutated can't
  491. yield a crash, and (ii) concurrent accesses to STR should be
  492. protected by a mutex at the application level. The latter may not
  493. apply when STR != ORIG_STR, though. */
  494. SET_STRING_START (str, 0);
  495. SET_STRING_STRINGBUF (str, new_buf);
  496. buf = new_buf;
  497. scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  498. }
  499. return orig_str;
  500. }
  501. /* Return a pointer to the 8-bit Latin-1 chars of a string. */
  502. char *
  503. scm_i_string_writable_chars (SCM str)
  504. {
  505. SCM buf;
  506. size_t start;
  507. get_str_buf_start (&str, &buf, &start);
  508. if (scm_i_is_narrow_string (str))
  509. return (char *) STRINGBUF_CHARS (buf) + start;
  510. else
  511. scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s",
  512. scm_list_1 (str));
  513. return NULL;
  514. }
  515. /* Return a pointer to the UCS-4 codepoints of a string. */
  516. static scm_t_wchar *
  517. scm_i_string_writable_wide_chars (SCM str)
  518. {
  519. SCM buf;
  520. size_t start;
  521. get_str_buf_start (&str, &buf, &start);
  522. if (!scm_i_is_narrow_string (str))
  523. return STRINGBUF_WIDE_CHARS (buf) + start;
  524. else
  525. scm_misc_error (NULL, "Invalid write access of chars of narrow string: ~s",
  526. scm_list_1 (str));
  527. }
  528. /* Unlock the string mutex that was locked when
  529. scm_i_string_start_writing was called. */
  530. void
  531. scm_i_string_stop_writing (void)
  532. {
  533. scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  534. }
  535. /* Return the Xth character of STR as a UCS-4 codepoint. */
  536. scm_t_wchar
  537. scm_i_string_ref (SCM str, size_t x)
  538. {
  539. if (scm_i_is_narrow_string (str))
  540. return (scm_t_wchar) (unsigned char) (scm_i_string_chars (str)[x]);
  541. else
  542. return scm_i_string_wide_chars (str)[x];
  543. }
  544. /* Returns index+1 of the first char in STR that matches C, or
  545. 0 if the char is not found. */
  546. int
  547. scm_i_string_contains_char (SCM str, char ch)
  548. {
  549. size_t i;
  550. size_t len = scm_i_string_length (str);
  551. i = 0;
  552. if (scm_i_is_narrow_string (str))
  553. {
  554. while (i < len)
  555. {
  556. if (scm_i_string_chars (str)[i] == ch)
  557. return i+1;
  558. i++;
  559. }
  560. }
  561. else
  562. {
  563. while (i < len)
  564. {
  565. if (scm_i_string_wide_chars (str)[i]
  566. == (unsigned char) ch)
  567. return i+1;
  568. i++;
  569. }
  570. }
  571. return 0;
  572. }
  573. int
  574. scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr)
  575. {
  576. if (scm_i_is_narrow_string (sstr))
  577. {
  578. const char *a = scm_i_string_chars (sstr) + start_x;
  579. const char *b = cstr;
  580. return strncmp (a, b, strlen(b));
  581. }
  582. else
  583. {
  584. size_t i;
  585. const scm_t_wchar *a = scm_i_string_wide_chars (sstr) + start_x;
  586. const char *b = cstr;
  587. for (i = 0; i < strlen (b); i++)
  588. {
  589. if (a[i] != (unsigned char) b[i])
  590. return 1;
  591. }
  592. }
  593. return 0;
  594. }
  595. /* Set the Pth character of STR to UCS-4 codepoint CHR. */
  596. void
  597. scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
  598. {
  599. if (IS_SH_STRING (str))
  600. {
  601. p += STRING_START (str);
  602. str = SH_STRING_STRING (str);
  603. }
  604. if (chr > 0xFF && scm_i_is_narrow_string (str))
  605. SET_STRING_STRINGBUF (str, wide_stringbuf (STRING_STRINGBUF (str)));
  606. if (scm_i_is_narrow_string (str))
  607. {
  608. char *dst = scm_i_string_writable_chars (str);
  609. dst[p] = chr;
  610. }
  611. else
  612. {
  613. scm_t_wchar *dst = scm_i_string_writable_wide_chars (str);
  614. dst[p] = chr;
  615. }
  616. }
  617. /* Symbols.
  618. Basic symbol creation and accessing is done here, the rest is in
  619. symbols.[hc]. This has been done to keep stringbufs and the
  620. internals of strings and string-like objects confined to this file.
  621. */
  622. #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
  623. SCM
  624. scm_i_make_symbol (SCM name, scm_t_bits flags,
  625. unsigned long hash, SCM props)
  626. {
  627. SCM buf;
  628. size_t start = STRING_START (name);
  629. size_t length = STRING_LENGTH (name);
  630. if (IS_SH_STRING (name))
  631. {
  632. name = SH_STRING_STRING (name);
  633. start += STRING_START (name);
  634. }
  635. buf = STRING_STRINGBUF (name);
  636. if (start == 0 && length == STRINGBUF_LENGTH (buf))
  637. {
  638. /* reuse buf. */
  639. scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  640. SET_STRINGBUF_SHARED (buf);
  641. scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  642. }
  643. else
  644. {
  645. /* make new buf. */
  646. if (scm_i_is_narrow_string (name))
  647. {
  648. SCM new_buf = make_stringbuf (length);
  649. memcpy (STRINGBUF_CHARS (new_buf),
  650. STRINGBUF_CHARS (buf) + start, length);
  651. buf = new_buf;
  652. }
  653. else
  654. {
  655. SCM new_buf = make_wide_stringbuf (length);
  656. u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
  657. (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start,
  658. length);
  659. buf = new_buf;
  660. }
  661. }
  662. return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
  663. (scm_t_bits) hash, SCM_UNPACK (props));
  664. }
  665. SCM
  666. scm_i_c_make_symbol (const char *name, size_t len,
  667. scm_t_bits flags, unsigned long hash, SCM props)
  668. {
  669. SCM buf = make_stringbuf (len);
  670. memcpy (STRINGBUF_CHARS (buf), name, len);
  671. return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
  672. (scm_t_bits) hash, SCM_UNPACK (props));
  673. }
  674. /* Returns the number of characters in SYM. This may be different
  675. from the memory size of SYM. */
  676. size_t
  677. scm_i_symbol_length (SCM sym)
  678. {
  679. return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
  680. }
  681. size_t
  682. scm_c_symbol_length (SCM sym)
  683. #define FUNC_NAME "scm_c_symbol_length"
  684. {
  685. SCM_VALIDATE_SYMBOL (1, sym);
  686. return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
  687. }
  688. #undef FUNC_NAME
  689. /* True if the name of SYM is stored as a Latin-1 encoded string.
  690. False if it is stored as a 32-bit UCS-4-encoded string. */
  691. int
  692. scm_i_is_narrow_symbol (SCM sym)
  693. {
  694. SCM buf;
  695. buf = SYMBOL_STRINGBUF (sym);
  696. return !STRINGBUF_WIDE (buf);
  697. }
  698. /* Returns a pointer to the 8-bit Latin-1 encoded character array that
  699. contains the name of SYM. */
  700. const char *
  701. scm_i_symbol_chars (SCM sym)
  702. {
  703. SCM buf;
  704. buf = SYMBOL_STRINGBUF (sym);
  705. if (!STRINGBUF_WIDE (buf))
  706. return (const char *) STRINGBUF_CHARS (buf);
  707. else
  708. scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S",
  709. scm_list_1 (sym));
  710. }
  711. /* Return a pointer to the 32-bit UCS-4-encoded character array of a
  712. symbol's name. */
  713. const scm_t_wchar *
  714. scm_i_symbol_wide_chars (SCM sym)
  715. {
  716. SCM buf;
  717. buf = SYMBOL_STRINGBUF (sym);
  718. if (STRINGBUF_WIDE (buf))
  719. return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf);
  720. else
  721. scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S",
  722. scm_list_1 (sym));
  723. }
  724. SCM
  725. scm_i_symbol_substring (SCM sym, size_t start, size_t end)
  726. {
  727. SCM buf = SYMBOL_STRINGBUF (sym);
  728. scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  729. SET_STRINGBUF_SHARED (buf);
  730. scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  731. return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf),
  732. (scm_t_bits)start, (scm_t_bits) end - start);
  733. }
  734. /* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */
  735. scm_t_wchar
  736. scm_i_symbol_ref (SCM sym, size_t x)
  737. {
  738. if (scm_i_is_narrow_symbol (sym))
  739. return (scm_t_wchar) (unsigned char) (scm_i_symbol_chars (sym)[x]);
  740. else
  741. return scm_i_symbol_wide_chars (sym)[x];
  742. }
  743. /* Debugging
  744. */
  745. SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
  746. "Returns an association list containing debugging information\n"
  747. "for @var{str}. The association list has the following entries."
  748. "@table @code\n"
  749. "@item string\n"
  750. "The string itself.\n"
  751. "@item start\n"
  752. "The start index of the string into its stringbuf\n"
  753. "@item length\n"
  754. "The length of the string\n"
  755. "@item shared\n"
  756. "If this string is a substring, it returns its parent string.\n"
  757. "Otherwise, it returns @code{#f}\n"
  758. "@item read-only\n"
  759. "@code{#t} if the string is read-only\n"
  760. "@item stringbuf-chars\n"
  761. "A new string containing this string's stringbuf's characters\n"
  762. "@item stringbuf-length\n"
  763. "The number of characters in this stringbuf\n"
  764. "@item stringbuf-shared\n"
  765. "@code{#t} if this stringbuf is shared\n"
  766. "@item stringbuf-wide\n"
  767. "@code{#t} if this stringbuf's characters are stored in a\n"
  768. "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
  769. "buffer\n"
  770. "@end table")
  771. #define FUNC_NAME s_scm_sys_string_dump
  772. {
  773. SCM e1, e2, e3, e4, e5, e6, e7, e8, e9;
  774. SCM buf;
  775. SCM_VALIDATE_STRING (1, str);
  776. /* String info */
  777. e1 = scm_cons (scm_from_latin1_symbol ("string"),
  778. str);
  779. e2 = scm_cons (scm_from_latin1_symbol ("start"),
  780. scm_from_size_t (STRING_START (str)));
  781. e3 = scm_cons (scm_from_latin1_symbol ("length"),
  782. scm_from_size_t (STRING_LENGTH (str)));
  783. if (IS_SH_STRING (str))
  784. {
  785. e4 = scm_cons (scm_from_latin1_symbol ("shared"),
  786. SH_STRING_STRING (str));
  787. buf = STRING_STRINGBUF (SH_STRING_STRING (str));
  788. }
  789. else
  790. {
  791. e4 = scm_cons (scm_from_latin1_symbol ("shared"),
  792. SCM_BOOL_F);
  793. buf = STRING_STRINGBUF (str);
  794. }
  795. if (IS_RO_STRING (str))
  796. e5 = scm_cons (scm_from_latin1_symbol ("read-only"),
  797. SCM_BOOL_T);
  798. else
  799. e5 = scm_cons (scm_from_latin1_symbol ("read-only"),
  800. SCM_BOOL_F);
  801. /* Stringbuf info */
  802. if (!STRINGBUF_WIDE (buf))
  803. {
  804. size_t len = STRINGBUF_LENGTH (buf);
  805. char *cbuf;
  806. SCM sbc = scm_i_make_string (len, &cbuf, 0);
  807. memcpy (cbuf, STRINGBUF_CHARS (buf), len);
  808. e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
  809. sbc);
  810. }
  811. else
  812. {
  813. size_t len = STRINGBUF_LENGTH (buf);
  814. scm_t_wchar *cbuf;
  815. SCM sbc = scm_i_make_wide_string (len, &cbuf, 0);
  816. u32_cpy ((scm_t_uint32 *) cbuf,
  817. (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
  818. e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
  819. sbc);
  820. }
  821. e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
  822. scm_from_size_t (STRINGBUF_LENGTH (buf)));
  823. if (STRINGBUF_SHARED (buf))
  824. e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
  825. SCM_BOOL_T);
  826. else
  827. e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
  828. SCM_BOOL_F);
  829. if (STRINGBUF_WIDE (buf))
  830. e9 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
  831. SCM_BOOL_T);
  832. else
  833. e9 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
  834. SCM_BOOL_F);
  835. return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, SCM_UNDEFINED);
  836. }
  837. #undef FUNC_NAME
  838. SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
  839. "Returns an association list containing debugging information\n"
  840. "for @var{sym}. The association list has the following entries."
  841. "@table @code\n"
  842. "@item symbol\n"
  843. "The symbol itself\n"
  844. "@item hash\n"
  845. "Its hash value\n"
  846. "@item interned\n"
  847. "@code{#t} if it is an interned symbol\n"
  848. "@item stringbuf-chars\n"
  849. "A new string containing this symbols's stringbuf's characters\n"
  850. "@item stringbuf-length\n"
  851. "The number of characters in this stringbuf\n"
  852. "@item stringbuf-shared\n"
  853. "@code{#t} if this stringbuf is shared\n"
  854. "@item stringbuf-wide\n"
  855. "@code{#t} if this stringbuf's characters are stored in a\n"
  856. "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
  857. "buffer\n"
  858. "@end table")
  859. #define FUNC_NAME s_scm_sys_symbol_dump
  860. {
  861. SCM e1, e2, e3, e4, e5, e6, e7;
  862. SCM buf;
  863. SCM_VALIDATE_SYMBOL (1, sym);
  864. e1 = scm_cons (scm_from_latin1_symbol ("symbol"),
  865. sym);
  866. e2 = scm_cons (scm_from_latin1_symbol ("hash"),
  867. scm_from_ulong (scm_i_symbol_hash (sym)));
  868. e3 = scm_cons (scm_from_latin1_symbol ("interned"),
  869. scm_symbol_interned_p (sym));
  870. buf = SYMBOL_STRINGBUF (sym);
  871. /* Stringbuf info */
  872. if (!STRINGBUF_WIDE (buf))
  873. {
  874. size_t len = STRINGBUF_LENGTH (buf);
  875. char *cbuf;
  876. SCM sbc = scm_i_make_string (len, &cbuf, 0);
  877. memcpy (cbuf, STRINGBUF_CHARS (buf), len);
  878. e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
  879. sbc);
  880. }
  881. else
  882. {
  883. size_t len = STRINGBUF_LENGTH (buf);
  884. scm_t_wchar *cbuf;
  885. SCM sbc = scm_i_make_wide_string (len, &cbuf, 0);
  886. u32_cpy ((scm_t_uint32 *) cbuf,
  887. (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
  888. e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
  889. sbc);
  890. }
  891. e5 = scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
  892. scm_from_size_t (STRINGBUF_LENGTH (buf)));
  893. if (STRINGBUF_SHARED (buf))
  894. e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
  895. SCM_BOOL_T);
  896. else
  897. e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
  898. SCM_BOOL_F);
  899. if (STRINGBUF_WIDE (buf))
  900. e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
  901. SCM_BOOL_T);
  902. else
  903. e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
  904. SCM_BOOL_F);
  905. return scm_list_n (e1, e2, e3, e4, e5, e6, e7, SCM_UNDEFINED);
  906. }
  907. #undef FUNC_NAME
  908. #ifdef SCM_STRING_LENGTH_HISTOGRAM
  909. SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "")
  910. #define FUNC_NAME s_scm_sys_stringbuf_hist
  911. {
  912. int i;
  913. for (i = 0; i < 1000; i++)
  914. if (lenhist[i])
  915. fprintf (stderr, " %3d: %u\n", i, lenhist[i]);
  916. fprintf (stderr, ">999: %u\n", lenhist[1000]);
  917. return SCM_UNSPECIFIED;
  918. }
  919. #undef FUNC_NAME
  920. #endif
  921. SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
  922. (SCM obj),
  923. "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
  924. #define FUNC_NAME s_scm_string_p
  925. {
  926. return scm_from_bool (IS_STRING (obj));
  927. }
  928. #undef FUNC_NAME
  929. SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
  930. SCM_DEFINE (scm_string, "string", 0, 0, 1,
  931. (SCM chrs),
  932. "@deffnx {Scheme Procedure} list->string chrs\n"
  933. "Return a newly allocated string composed of the arguments,\n"
  934. "@var{chrs}.")
  935. #define FUNC_NAME s_scm_string
  936. {
  937. SCM result = SCM_BOOL_F;
  938. SCM rest;
  939. size_t len;
  940. size_t p = 0;
  941. long i;
  942. int wide = 0;
  943. /* Verify that this is a list of chars. */
  944. i = scm_ilength (chrs);
  945. SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
  946. len = (size_t) i;
  947. rest = chrs;
  948. while (len > 0 && scm_is_pair (rest))
  949. {
  950. SCM elt = SCM_CAR (rest);
  951. SCM_VALIDATE_CHAR (SCM_ARGn, elt);
  952. if (SCM_CHAR (elt) > 0xFF)
  953. wide = 1;
  954. rest = SCM_CDR (rest);
  955. len--;
  956. scm_remember_upto_here_1 (elt);
  957. }
  958. /* Construct a string containing this list of chars. */
  959. len = (size_t) i;
  960. rest = chrs;
  961. if (wide == 0)
  962. {
  963. char *buf;
  964. result = scm_i_make_string (len, NULL, 0);
  965. result = scm_i_string_start_writing (result);
  966. buf = scm_i_string_writable_chars (result);
  967. while (len > 0 && scm_is_pair (rest))
  968. {
  969. SCM elt = SCM_CAR (rest);
  970. buf[p] = (unsigned char) SCM_CHAR (elt);
  971. p++;
  972. rest = SCM_CDR (rest);
  973. len--;
  974. scm_remember_upto_here_1 (elt);
  975. }
  976. }
  977. else
  978. {
  979. scm_t_wchar *buf;
  980. result = scm_i_make_wide_string (len, NULL, 0);
  981. result = scm_i_string_start_writing (result);
  982. buf = scm_i_string_writable_wide_chars (result);
  983. while (len > 0 && scm_is_pair (rest))
  984. {
  985. SCM elt = SCM_CAR (rest);
  986. buf[p] = SCM_CHAR (elt);
  987. p++;
  988. rest = SCM_CDR (rest);
  989. len--;
  990. scm_remember_upto_here_1 (elt);
  991. }
  992. }
  993. scm_i_string_stop_writing ();
  994. if (len > 0)
  995. scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
  996. if (!scm_is_null (rest))
  997. scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
  998. return result;
  999. }
  1000. #undef FUNC_NAME
  1001. SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
  1002. (SCM k, SCM chr),
  1003. "Return a newly allocated string of\n"
  1004. "length @var{k}. If @var{chr} is given, then all elements of\n"
  1005. "the string are initialized to @var{chr}, otherwise the contents\n"
  1006. "of the string are all set to @code{#\nul}.")
  1007. #define FUNC_NAME s_scm_make_string
  1008. {
  1009. return scm_c_make_string (scm_to_size_t (k), chr);
  1010. }
  1011. #undef FUNC_NAME
  1012. SCM
  1013. scm_c_make_string (size_t len, SCM chr)
  1014. #define FUNC_NAME NULL
  1015. {
  1016. size_t p;
  1017. char *contents = NULL;
  1018. SCM res = scm_i_make_string (len, &contents, 0);
  1019. /* If no char is given, initialize string contents to NULL. */
  1020. if (SCM_UNBNDP (chr))
  1021. memset (contents, 0, len);
  1022. else
  1023. {
  1024. SCM_VALIDATE_CHAR (0, chr);
  1025. res = scm_i_string_start_writing (res);
  1026. for (p = 0; p < len; p++)
  1027. scm_i_string_set_x (res, p, SCM_CHAR (chr));
  1028. scm_i_string_stop_writing ();
  1029. }
  1030. return res;
  1031. }
  1032. #undef FUNC_NAME
  1033. SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
  1034. (SCM string),
  1035. "Return the number of characters in @var{string}.")
  1036. #define FUNC_NAME s_scm_string_length
  1037. {
  1038. SCM_VALIDATE_STRING (1, string);
  1039. return scm_from_size_t (STRING_LENGTH (string));
  1040. }
  1041. #undef FUNC_NAME
  1042. SCM_DEFINE (scm_string_bytes_per_char, "string-bytes-per-char", 1, 0, 0,
  1043. (SCM string),
  1044. "Return the bytes used to represent a character in @var{string}."
  1045. "This will return 1 or 4.")
  1046. #define FUNC_NAME s_scm_string_bytes_per_char
  1047. {
  1048. SCM_VALIDATE_STRING (1, string);
  1049. if (!scm_i_is_narrow_string (string))
  1050. return scm_from_int (4);
  1051. return scm_from_int (1);
  1052. }
  1053. #undef FUNC_NAME
  1054. size_t
  1055. scm_c_string_length (SCM string)
  1056. {
  1057. if (!IS_STRING (string))
  1058. scm_wrong_type_arg_msg (NULL, 0, string, "string");
  1059. return STRING_LENGTH (string);
  1060. }
  1061. SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
  1062. (SCM str, SCM k),
  1063. "Return character @var{k} of @var{str} using zero-origin\n"
  1064. "indexing. @var{k} must be a valid index of @var{str}.")
  1065. #define FUNC_NAME s_scm_string_ref
  1066. {
  1067. size_t len;
  1068. unsigned long idx;
  1069. SCM_VALIDATE_STRING (1, str);
  1070. len = scm_i_string_length (str);
  1071. if (SCM_LIKELY (len > 0))
  1072. idx = scm_to_unsigned_integer (k, 0, len - 1);
  1073. else
  1074. scm_out_of_range (NULL, k);
  1075. if (scm_i_is_narrow_string (str))
  1076. return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
  1077. else
  1078. return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[idx]);
  1079. }
  1080. #undef FUNC_NAME
  1081. SCM
  1082. scm_c_string_ref (SCM str, size_t p)
  1083. {
  1084. if (p >= scm_i_string_length (str))
  1085. scm_out_of_range (NULL, scm_from_size_t (p));
  1086. if (scm_i_is_narrow_string (str))
  1087. return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
  1088. else
  1089. return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[p]);
  1090. }
  1091. SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
  1092. (SCM str, SCM k, SCM chr),
  1093. "Store @var{chr} in element @var{k} of @var{str} and return\n"
  1094. "an unspecified value. @var{k} must be a valid index of\n"
  1095. "@var{str}.")
  1096. #define FUNC_NAME s_scm_string_set_x
  1097. {
  1098. size_t len;
  1099. unsigned long idx;
  1100. SCM_VALIDATE_STRING (1, str);
  1101. len = scm_i_string_length (str);
  1102. if (SCM_LIKELY (len > 0))
  1103. idx = scm_to_unsigned_integer (k, 0, len - 1);
  1104. else
  1105. scm_out_of_range (NULL, k);
  1106. SCM_VALIDATE_CHAR (3, chr);
  1107. str = scm_i_string_start_writing (str);
  1108. scm_i_string_set_x (str, idx, SCM_CHAR (chr));
  1109. scm_i_string_stop_writing ();
  1110. return SCM_UNSPECIFIED;
  1111. }
  1112. #undef FUNC_NAME
  1113. void
  1114. scm_c_string_set_x (SCM str, size_t p, SCM chr)
  1115. {
  1116. if (p >= scm_i_string_length (str))
  1117. scm_out_of_range (NULL, scm_from_size_t (p));
  1118. str = scm_i_string_start_writing (str);
  1119. scm_i_string_set_x (str, p, SCM_CHAR (chr));
  1120. scm_i_string_stop_writing ();
  1121. }
  1122. SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
  1123. (SCM str, SCM start, SCM end),
  1124. "Return a newly allocated string formed from the characters\n"
  1125. "of @var{str} beginning with index @var{start} (inclusive) and\n"
  1126. "ending with index @var{end} (exclusive).\n"
  1127. "@var{str} must be a string, @var{start} and @var{end} must be\n"
  1128. "exact integers satisfying:\n\n"
  1129. "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
  1130. #define FUNC_NAME s_scm_substring
  1131. {
  1132. size_t len, from, to;
  1133. SCM_VALIDATE_STRING (1, str);
  1134. len = scm_i_string_length (str);
  1135. from = scm_to_unsigned_integer (start, 0, len);
  1136. if (SCM_UNBNDP (end))
  1137. to = len;
  1138. else
  1139. to = scm_to_unsigned_integer (end, from, len);
  1140. return scm_i_substring (str, from, to);
  1141. }
  1142. #undef FUNC_NAME
  1143. SCM_DEFINE (scm_substring_read_only, "substring/read-only", 2, 1, 0,
  1144. (SCM str, SCM start, SCM end),
  1145. "Return a newly allocated string formed from the characters\n"
  1146. "of @var{str} beginning with index @var{start} (inclusive) and\n"
  1147. "ending with index @var{end} (exclusive).\n"
  1148. "@var{str} must be a string, @var{start} and @var{end} must be\n"
  1149. "exact integers satisfying:\n"
  1150. "\n"
  1151. "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
  1152. "\n"
  1153. "The returned string is read-only.\n")
  1154. #define FUNC_NAME s_scm_substring_read_only
  1155. {
  1156. size_t len, from, to;
  1157. SCM_VALIDATE_STRING (1, str);
  1158. len = scm_i_string_length (str);
  1159. from = scm_to_unsigned_integer (start, 0, len);
  1160. if (SCM_UNBNDP (end))
  1161. to = len;
  1162. else
  1163. to = scm_to_unsigned_integer (end, from, len);
  1164. return scm_i_substring_read_only (str, from, to);
  1165. }
  1166. #undef FUNC_NAME
  1167. SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0,
  1168. (SCM str, SCM start, SCM end),
  1169. "Return a newly allocated string formed from the characters\n"
  1170. "of @var{str} beginning with index @var{start} (inclusive) and\n"
  1171. "ending with index @var{end} (exclusive).\n"
  1172. "@var{str} must be a string, @var{start} and @var{end} must be\n"
  1173. "exact integers satisfying:\n\n"
  1174. "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
  1175. #define FUNC_NAME s_scm_substring_copy
  1176. {
  1177. /* For the Scheme version, START is mandatory, but for the C
  1178. version, it is optional. See scm_string_copy in srfi-13.c for a
  1179. rationale.
  1180. */
  1181. size_t from, to;
  1182. SCM_VALIDATE_STRING (1, str);
  1183. scm_i_get_substring_spec (scm_i_string_length (str),
  1184. start, &from, end, &to);
  1185. return scm_i_substring_copy (str, from, to);
  1186. }
  1187. #undef FUNC_NAME
  1188. SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
  1189. (SCM str, SCM start, SCM end),
  1190. "Return string that indirectly refers to the characters\n"
  1191. "of @var{str} beginning with index @var{start} (inclusive) and\n"
  1192. "ending with index @var{end} (exclusive).\n"
  1193. "@var{str} must be a string, @var{start} and @var{end} must be\n"
  1194. "exact integers satisfying:\n\n"
  1195. "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
  1196. #define FUNC_NAME s_scm_substring_shared
  1197. {
  1198. size_t len, from, to;
  1199. SCM_VALIDATE_STRING (1, str);
  1200. len = scm_i_string_length (str);
  1201. from = scm_to_unsigned_integer (start, 0, len);
  1202. if (SCM_UNBNDP (end))
  1203. to = len;
  1204. else
  1205. to = scm_to_unsigned_integer (end, from, len);
  1206. return scm_i_substring_shared (str, from, to);
  1207. }
  1208. #undef FUNC_NAME
  1209. SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
  1210. (SCM args),
  1211. "Return a newly allocated string whose characters form the\n"
  1212. "concatenation of the given strings, @var{args}.")
  1213. #define FUNC_NAME s_scm_string_append
  1214. {
  1215. SCM res;
  1216. size_t len = 0;
  1217. int wide = 0;
  1218. SCM l, s;
  1219. size_t i;
  1220. union
  1221. {
  1222. char *narrow;
  1223. scm_t_wchar *wide;
  1224. } data;
  1225. SCM_VALIDATE_REST_ARGUMENT (args);
  1226. for (l = args; !scm_is_null (l); l = SCM_CDR (l))
  1227. {
  1228. s = SCM_CAR (l);
  1229. SCM_VALIDATE_STRING (SCM_ARGn, s);
  1230. len += scm_i_string_length (s);
  1231. if (!scm_i_is_narrow_string (s))
  1232. wide = 1;
  1233. }
  1234. data.narrow = NULL;
  1235. if (!wide)
  1236. res = scm_i_make_string (len, &data.narrow, 0);
  1237. else
  1238. res = scm_i_make_wide_string (len, &data.wide, 0);
  1239. for (l = args; !scm_is_null (l); l = SCM_CDR (l))
  1240. {
  1241. size_t len;
  1242. s = SCM_CAR (l);
  1243. SCM_VALIDATE_STRING (SCM_ARGn, s);
  1244. len = scm_i_string_length (s);
  1245. if (!wide)
  1246. {
  1247. memcpy (data.narrow, scm_i_string_chars (s), len);
  1248. data.narrow += len;
  1249. }
  1250. else
  1251. {
  1252. if (scm_i_is_narrow_string (s))
  1253. {
  1254. for (i = 0; i < scm_i_string_length (s); i++)
  1255. data.wide[i] = (unsigned char) scm_i_string_chars (s)[i];
  1256. }
  1257. else
  1258. u32_cpy ((scm_t_uint32 *) data.wide,
  1259. (scm_t_uint32 *) scm_i_string_wide_chars (s), len);
  1260. data.wide += len;
  1261. }
  1262. scm_remember_upto_here_1 (s);
  1263. }
  1264. return res;
  1265. }
  1266. #undef FUNC_NAME
  1267. /* Charset conversion error handling. */
  1268. SCM_SYMBOL (scm_encoding_error_key, "encoding-error");
  1269. SCM_SYMBOL (scm_decoding_error_key, "decoding-error");
  1270. /* Raise an exception informing that character CHR could not be written
  1271. to PORT in its current encoding. */
  1272. void
  1273. scm_encoding_error (const char *subr, int err, const char *message,
  1274. SCM port, SCM chr)
  1275. {
  1276. scm_throw (scm_encoding_error_key,
  1277. scm_list_n (scm_from_latin1_string (subr),
  1278. scm_from_latin1_string (message),
  1279. scm_from_int (err),
  1280. port, chr,
  1281. SCM_UNDEFINED));
  1282. }
  1283. /* Raise an exception informing of an encoding error on PORT. This
  1284. means that a character could not be written in PORT's encoding. */
  1285. void
  1286. scm_decoding_error (const char *subr, int err, const char *message, SCM port)
  1287. {
  1288. scm_throw (scm_decoding_error_key,
  1289. scm_list_n (scm_from_latin1_string (subr),
  1290. scm_from_latin1_string (message),
  1291. scm_from_int (err),
  1292. port,
  1293. SCM_UNDEFINED));
  1294. }
  1295. /* String conversion to/from C. */
  1296. static void
  1297. decoding_error (const char *func_name, int errno_save,
  1298. const char *str, size_t len)
  1299. {
  1300. /* Raise an error and pass the raw C string as a bytevector to the `throw'
  1301. handler. */
  1302. SCM bv;
  1303. signed char *buf;
  1304. buf = scm_gc_malloc_pointerless (len, "bytevector");
  1305. memcpy (buf, str, len);
  1306. bv = scm_c_take_gc_bytevector (buf, len, SCM_BOOL_F);
  1307. scm_decoding_error (func_name, errno_save,
  1308. "input locale conversion error", bv);
  1309. }
  1310. SCM
  1311. scm_from_stringn (const char *str, size_t len, const char *encoding,
  1312. scm_t_string_failed_conversion_handler handler)
  1313. {
  1314. size_t u32len, i;
  1315. scm_t_wchar *u32;
  1316. int wide = 0;
  1317. SCM res;
  1318. /* The order of these checks is important. */
  1319. if (!str && len != 0)
  1320. scm_misc_error ("scm_from_stringn", "NULL string pointer", SCM_EOL);
  1321. if (len == (size_t) -1)
  1322. len = strlen (str);
  1323. if (encoding == NULL || len == 0)
  1324. return scm_from_latin1_stringn (str, len);
  1325. else if (strcmp (encoding, "UTF-8") == 0)
  1326. return scm_from_utf8_stringn (str, len);
  1327. u32len = 0;
  1328. u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding,
  1329. (enum iconv_ilseq_handler)
  1330. handler,
  1331. str, len,
  1332. NULL,
  1333. NULL, &u32len);
  1334. if (SCM_UNLIKELY (u32 == NULL))
  1335. decoding_error (__func__, errno, str, len);
  1336. i = 0;
  1337. while (i < u32len)
  1338. if (u32[i++] > 0xFF)
  1339. {
  1340. wide = 1;
  1341. break;
  1342. }
  1343. if (!wide)
  1344. {
  1345. char *dst;
  1346. res = scm_i_make_string (u32len, &dst, 0);
  1347. for (i = 0; i < u32len; i ++)
  1348. dst[i] = (unsigned char) u32[i];
  1349. dst[u32len] = '\0';
  1350. }
  1351. else
  1352. {
  1353. scm_t_wchar *wdst;
  1354. res = scm_i_make_wide_string (u32len, &wdst, 0);
  1355. u32_cpy ((scm_t_uint32 *) wdst, (scm_t_uint32 *) u32, u32len);
  1356. wdst[u32len] = 0;
  1357. }
  1358. free (u32);
  1359. return res;
  1360. }
  1361. SCM
  1362. scm_from_locale_string (const char *str)
  1363. {
  1364. return scm_from_locale_stringn (str, -1);
  1365. }
  1366. SCM
  1367. scm_from_locale_stringn (const char *str, size_t len)
  1368. {
  1369. return scm_from_stringn (str, len, locale_charset (),
  1370. scm_i_get_conversion_strategy (SCM_BOOL_F));
  1371. }
  1372. SCM
  1373. scm_from_latin1_string (const char *str)
  1374. {
  1375. return scm_from_latin1_stringn (str, -1);
  1376. }
  1377. SCM
  1378. scm_from_latin1_stringn (const char *str, size_t len)
  1379. {
  1380. char *buf;
  1381. SCM result;
  1382. if (len == (size_t) -1)
  1383. len = strlen (str);
  1384. /* Make a narrow string and copy STR as is. */
  1385. result = scm_i_make_string (len, &buf, 0);
  1386. memcpy (buf, str, len);
  1387. return result;
  1388. }
  1389. SCM
  1390. scm_from_utf8_string (const char *str)
  1391. {
  1392. return scm_from_utf8_stringn (str, -1);
  1393. }
  1394. SCM
  1395. scm_from_utf8_stringn (const char *str, size_t len)
  1396. {
  1397. size_t i, char_len;
  1398. const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
  1399. int ascii = 1, narrow = 1;
  1400. SCM res;
  1401. if (len == (size_t) -1)
  1402. len = strlen (str);
  1403. i = 0;
  1404. char_len = 0;
  1405. while (i < len)
  1406. {
  1407. if (ustr[i] <= 127)
  1408. {
  1409. char_len++;
  1410. i++;
  1411. }
  1412. else
  1413. {
  1414. ucs4_t c;
  1415. int nbytes;
  1416. ascii = 0;
  1417. nbytes = u8_mbtouc (&c, ustr + i, len - i);
  1418. if (nbytes < 0)
  1419. /* Bad UTF-8. */
  1420. decoding_error (__func__, errno, str, len);
  1421. if (c > 255)
  1422. narrow = 0;
  1423. char_len++;
  1424. i += nbytes;
  1425. }
  1426. }
  1427. if (ascii)
  1428. {
  1429. char *dst;
  1430. res = scm_i_make_string (char_len, &dst, 0);
  1431. memcpy (dst, str, len);
  1432. }
  1433. else if (narrow)
  1434. {
  1435. char *dst;
  1436. size_t j;
  1437. ucs4_t c;
  1438. res = scm_i_make_string (char_len, &dst, 0);
  1439. for (i = 0, j = 0; i < len; j++)
  1440. {
  1441. i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
  1442. dst[j] = (signed char) c;
  1443. }
  1444. }
  1445. else
  1446. {
  1447. scm_t_wchar *dst;
  1448. size_t j;
  1449. ucs4_t c;
  1450. res = scm_i_make_wide_string (char_len, &dst, 0);
  1451. for (i = 0, j = 0; i < len; j++)
  1452. {
  1453. i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
  1454. dst[j] = c;
  1455. }
  1456. }
  1457. return res;
  1458. }
  1459. SCM
  1460. scm_from_utf32_string (const scm_t_wchar *str)
  1461. {
  1462. return scm_from_utf32_stringn (str, -1);
  1463. }
  1464. SCM
  1465. scm_from_utf32_stringn (const scm_t_wchar *str, size_t len)
  1466. {
  1467. SCM result;
  1468. scm_t_wchar *buf;
  1469. if (len == (size_t) -1)
  1470. len = u32_strlen ((uint32_t *) str);
  1471. result = scm_i_make_wide_string (len, &buf, 0);
  1472. memcpy (buf, str, len * sizeof (scm_t_wchar));
  1473. scm_i_try_narrow_string (result);
  1474. return result;
  1475. }
  1476. /* Create a new scheme string from the C string STR. The memory of
  1477. STR may be used directly as storage for the new string. */
  1478. /* FIXME: GC-wise, the only way to use the memory area pointed to by STR
  1479. would be to register a finalizer to eventually free(3) STR, which isn't
  1480. worth it. Should we just deprecate the `scm_take_' functions? */
  1481. SCM
  1482. scm_take_locale_stringn (char *str, size_t len)
  1483. {
  1484. SCM res;
  1485. res = scm_from_locale_stringn (str, len);
  1486. free (str);
  1487. return res;
  1488. }
  1489. SCM
  1490. scm_take_locale_string (char *str)
  1491. {
  1492. return scm_take_locale_stringn (str, -1);
  1493. }
  1494. /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
  1495. *LENP-byte locale-encoded string, to `\xXX', `\uXXXX', or `\UXXXXXX'.
  1496. Set *LENP to the size of the resulting string.
  1497. FIXME: This is a hack we should get rid of. See
  1498. <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00004.html>
  1499. for details. */
  1500. static void
  1501. unistring_escapes_to_guile_escapes (char *buf, size_t *lenp)
  1502. {
  1503. char *before, *after;
  1504. size_t i, j;
  1505. before = buf;
  1506. after = buf;
  1507. i = 0;
  1508. j = 0;
  1509. while (i < *lenp)
  1510. {
  1511. if ((i <= *lenp - 6)
  1512. && before[i] == '\\'
  1513. && before[i + 1] == 'u'
  1514. && before[i + 2] == '0' && before[i + 3] == '0')
  1515. {
  1516. /* Convert \u00NN to \xNN */
  1517. after[j] = '\\';
  1518. after[j + 1] = 'x';
  1519. after[j + 2] = tolower ((int) before[i + 4]);
  1520. after[j + 3] = tolower ((int) before[i + 5]);
  1521. i += 6;
  1522. j += 4;
  1523. }
  1524. else if ((i <= *lenp - 10)
  1525. && before[i] == '\\'
  1526. && before[i + 1] == 'U'
  1527. && before[i + 2] == '0' && before[i + 3] == '0')
  1528. {
  1529. /* Convert \U00NNNNNN to \UNNNNNN */
  1530. after[j] = '\\';
  1531. after[j + 1] = 'U';
  1532. after[j + 2] = tolower ((int) before[i + 4]);
  1533. after[j + 3] = tolower ((int) before[i + 5]);
  1534. after[j + 4] = tolower ((int) before[i + 6]);
  1535. after[j + 5] = tolower ((int) before[i + 7]);
  1536. after[j + 6] = tolower ((int) before[i + 8]);
  1537. after[j + 7] = tolower ((int) before[i + 9]);
  1538. i += 10;
  1539. j += 8;
  1540. }
  1541. else
  1542. {
  1543. after[j] = before[i];
  1544. i++;
  1545. j++;
  1546. }
  1547. }
  1548. *lenp = j;
  1549. }
  1550. /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
  1551. *LENP-byte locale-encoded string, to `\xXXXX;'. Set *LEN to the size
  1552. of the resulting string. BUF must be large enough to handle the
  1553. worst case when `\uXXXX' escapes (6 characters) are replaced by
  1554. `\xXXXX;' (7 characters). */
  1555. static void
  1556. unistring_escapes_to_r6rs_escapes (char *buf, size_t *lenp)
  1557. {
  1558. char *before, *after;
  1559. size_t i, j;
  1560. /* The worst case is if the input string contains all 4-digit hex escapes.
  1561. "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */
  1562. size_t max_out_len = (*lenp * 7) / 6 + 1;
  1563. size_t nzeros, ndigits;
  1564. before = buf;
  1565. after = alloca (max_out_len);
  1566. i = 0;
  1567. j = 0;
  1568. while (i < *lenp)
  1569. {
  1570. if (((i <= *lenp - 6) && before[i] == '\\' && before[i + 1] == 'u')
  1571. || ((i <= *lenp - 10) && before[i] == '\\' && before[i + 1] == 'U'))
  1572. {
  1573. if (before[i + 1] == 'u')
  1574. ndigits = 4;
  1575. else if (before[i + 1] == 'U')
  1576. ndigits = 8;
  1577. else
  1578. abort ();
  1579. /* Add the R6RS hex escape initial sequence. */
  1580. after[j] = '\\';
  1581. after[j + 1] = 'x';
  1582. /* Move string positions to the start of the hex numbers. */
  1583. i += 2;
  1584. j += 2;
  1585. /* Find the number of initial zeros in this hex number. */
  1586. nzeros = 0;
  1587. while (before[i + nzeros] == '0' && nzeros < ndigits)
  1588. nzeros++;
  1589. /* Copy the number, skipping initial zeros, and then move the string
  1590. positions. */
  1591. if (nzeros == ndigits)
  1592. {
  1593. after[j] = '0';
  1594. i += ndigits;
  1595. j += 1;
  1596. }
  1597. else
  1598. {
  1599. int pos;
  1600. for (pos = 0; pos < ndigits - nzeros; pos++)
  1601. after[j + pos] = tolower ((int) before[i + nzeros + pos]);
  1602. i += ndigits;
  1603. j += (ndigits - nzeros);
  1604. }
  1605. /* Add terminating semicolon. */
  1606. after[j] = ';';
  1607. j++;
  1608. }
  1609. else
  1610. {
  1611. after[j] = before[i];
  1612. i++;
  1613. j++;
  1614. }
  1615. }
  1616. *lenp = j;
  1617. memcpy (before, after, j);
  1618. }
  1619. char *
  1620. scm_to_locale_string (SCM str)
  1621. {
  1622. return scm_to_locale_stringn (str, NULL);
  1623. }
  1624. char *
  1625. scm_to_locale_stringn (SCM str, size_t *lenp)
  1626. {
  1627. return scm_to_stringn (str, lenp,
  1628. locale_charset (),
  1629. scm_i_get_conversion_strategy (SCM_BOOL_F));
  1630. }
  1631. char *
  1632. scm_to_latin1_string (SCM str)
  1633. {
  1634. return scm_to_latin1_stringn (str, NULL);
  1635. }
  1636. char *
  1637. scm_to_latin1_stringn (SCM str, size_t *lenp)
  1638. #define FUNC_NAME "scm_to_latin1_stringn"
  1639. {
  1640. char *result;
  1641. SCM_VALIDATE_STRING (1, str);
  1642. if (scm_i_is_narrow_string (str))
  1643. {
  1644. size_t len = scm_i_string_length (str);
  1645. if (lenp)
  1646. *lenp = len;
  1647. result = scm_strndup (scm_i_string_data (str), len);
  1648. }
  1649. else
  1650. result = scm_to_stringn (str, lenp, NULL,
  1651. SCM_FAILED_CONVERSION_ERROR);
  1652. return result;
  1653. }
  1654. #undef FUNC_NAME
  1655. char *
  1656. scm_to_utf8_string (SCM str)
  1657. {
  1658. return scm_to_utf8_stringn (str, NULL);
  1659. }
  1660. static size_t
  1661. latin1_u8_strlen (const scm_t_uint8 *str, size_t len)
  1662. {
  1663. size_t ret, i;
  1664. for (i = 0, ret = 0; i < len; i++)
  1665. ret += (str[i] < 128) ? 1 : 2;
  1666. return ret;
  1667. }
  1668. static scm_t_uint8*
  1669. latin1_to_u8 (const scm_t_uint8 *str, size_t latin_len,
  1670. scm_t_uint8 *u8_result, size_t *u8_lenp)
  1671. {
  1672. size_t i, n;
  1673. size_t u8_len = latin1_u8_strlen (str, latin_len);
  1674. if (!(u8_result && u8_lenp && *u8_lenp > u8_len))
  1675. u8_result = scm_malloc (u8_len + 1);
  1676. if (u8_lenp)
  1677. *u8_lenp = u8_len;
  1678. for (i = 0, n = 0; i < latin_len; i++)
  1679. n += u8_uctomb (u8_result + n, str[i], u8_len - n);
  1680. if (n != u8_len)
  1681. abort ();
  1682. u8_result[n] = 0;
  1683. return u8_result;
  1684. }
  1685. char *
  1686. scm_to_utf8_stringn (SCM str, size_t *lenp)
  1687. {
  1688. if (scm_i_is_narrow_string (str))
  1689. return (char *) latin1_to_u8 ((scm_t_uint8 *) scm_i_string_chars (str),
  1690. scm_i_string_length (str),
  1691. NULL, lenp);
  1692. else
  1693. return (char *) u32_to_u8 ((scm_t_uint32*)scm_i_string_wide_chars (str),
  1694. scm_i_string_length (str),
  1695. NULL, lenp);
  1696. }
  1697. scm_t_wchar *
  1698. scm_to_utf32_string (SCM str)
  1699. {
  1700. return scm_to_utf32_stringn (str, NULL);
  1701. }
  1702. scm_t_wchar *
  1703. scm_to_utf32_stringn (SCM str, size_t *lenp)
  1704. #define FUNC_NAME "scm_to_utf32_stringn"
  1705. {
  1706. scm_t_wchar *result;
  1707. SCM_VALIDATE_STRING (1, str);
  1708. if (scm_i_is_narrow_string (str))
  1709. {
  1710. scm_t_uint8 *codepoints;
  1711. size_t i, len;
  1712. codepoints = (scm_t_uint8*) scm_i_string_chars (str);
  1713. len = scm_i_string_length (str);
  1714. if (lenp)
  1715. *lenp = len;
  1716. result = scm_malloc ((len + 1) * sizeof (scm_t_wchar));
  1717. for (i = 0; i < len; i++)
  1718. result[i] = codepoints[i];
  1719. result[len] = 0;
  1720. }
  1721. else
  1722. {
  1723. size_t len;
  1724. len = scm_i_string_length (str);
  1725. if (lenp)
  1726. *lenp = len;
  1727. result = scm_malloc ((len + 1) * sizeof (scm_t_wchar));
  1728. memcpy (result, scm_i_string_wide_chars (str),
  1729. len * sizeof (scm_t_wchar));
  1730. result[len] = 0;
  1731. }
  1732. return result;
  1733. }
  1734. #undef FUNC_NAME
  1735. /* Return a malloc(3)-allocated buffer containing the contents of STR encoded
  1736. according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
  1737. the returned buffer. If the conversion to ENCODING fails, apply the strategy
  1738. defined by HANDLER. */
  1739. char *
  1740. scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
  1741. scm_t_string_failed_conversion_handler handler)
  1742. {
  1743. char *buf;
  1744. size_t ilen, len, i;
  1745. int ret;
  1746. const char *enc;
  1747. if (!scm_is_string (str))
  1748. scm_wrong_type_arg_msg (NULL, 0, str, "string");
  1749. ilen = scm_i_string_length (str);
  1750. if (ilen == 0)
  1751. {
  1752. buf = scm_malloc (1);
  1753. buf[0] = '\0';
  1754. if (lenp)
  1755. *lenp = 0;
  1756. return buf;
  1757. }
  1758. if (lenp == NULL)
  1759. for (i = 0; i < ilen; i++)
  1760. if (scm_i_string_ref (str, i) == '\0')
  1761. scm_misc_error (NULL,
  1762. "string contains #\\nul character: ~S",
  1763. scm_list_1 (str));
  1764. if (scm_i_is_narrow_string (str) && (encoding == NULL))
  1765. {
  1766. /* If using native Latin-1 encoding, just copy the string
  1767. contents. */
  1768. if (lenp)
  1769. {
  1770. buf = scm_malloc (ilen);
  1771. memcpy (buf, scm_i_string_chars (str), ilen);
  1772. *lenp = ilen;
  1773. return buf;
  1774. }
  1775. else
  1776. {
  1777. buf = scm_malloc (ilen + 1);
  1778. memcpy (buf, scm_i_string_chars (str), ilen);
  1779. buf[ilen] = '\0';
  1780. return buf;
  1781. }
  1782. }
  1783. buf = NULL;
  1784. len = 0;
  1785. enc = encoding;
  1786. if (enc == NULL)
  1787. enc = "ISO-8859-1";
  1788. if (scm_i_is_narrow_string (str))
  1789. {
  1790. ret = mem_iconveh (scm_i_string_chars (str), ilen,
  1791. "ISO-8859-1", enc,
  1792. (enum iconv_ilseq_handler) handler, NULL,
  1793. &buf, &len);
  1794. if (ret != 0)
  1795. scm_encoding_error (__func__, errno,
  1796. "cannot convert narrow string to output locale",
  1797. SCM_BOOL_F,
  1798. /* FIXME: Faulty character unknown. */
  1799. SCM_BOOL_F);
  1800. }
  1801. else
  1802. {
  1803. buf = u32_conv_to_encoding (enc,
  1804. (enum iconv_ilseq_handler) handler,
  1805. (scm_t_uint32 *) scm_i_string_wide_chars (str),
  1806. ilen,
  1807. NULL,
  1808. NULL, &len);
  1809. if (buf == NULL)
  1810. scm_encoding_error (__func__, errno,
  1811. "cannot convert wide string to output locale",
  1812. SCM_BOOL_F,
  1813. /* FIXME: Faulty character unknown. */
  1814. SCM_BOOL_F);
  1815. }
  1816. if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
  1817. {
  1818. if (SCM_R6RS_ESCAPES_P)
  1819. {
  1820. /* The worst case is if the input string contains all 4-digit
  1821. hex escapes. "\uXXXX" (six characters) becomes "\xXXXX;"
  1822. (seven characters). Make BUF large enough to hold
  1823. that. */
  1824. buf = scm_realloc (buf, (len * 7) / 6 + 1);
  1825. unistring_escapes_to_r6rs_escapes (buf, &len);
  1826. }
  1827. else
  1828. unistring_escapes_to_guile_escapes (buf, &len);
  1829. buf = scm_realloc (buf, len);
  1830. }
  1831. if (lenp)
  1832. *lenp = len;
  1833. else
  1834. {
  1835. buf = scm_realloc (buf, len + 1);
  1836. buf[len] = '\0';
  1837. }
  1838. scm_remember_upto_here_1 (str);
  1839. return buf;
  1840. }
  1841. size_t
  1842. scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
  1843. {
  1844. size_t len;
  1845. char *result = NULL;
  1846. if (!scm_is_string (str))
  1847. scm_wrong_type_arg_msg (NULL, 0, str, "string");
  1848. result = scm_to_locale_stringn (str, &len);
  1849. memcpy (buf, result, (len > max_len) ? max_len : len);
  1850. free (result);
  1851. scm_remember_upto_here_1 (str);
  1852. return len;
  1853. }
  1854. /* Unicode string normalization. */
  1855. /* This function is a partial clone of SCM_STRING_TO_U32_BUF from
  1856. libguile/i18n.c. It would be useful to have this factored out into a more
  1857. convenient location, but its use of alloca makes that tricky to do. */
  1858. static SCM
  1859. normalize_str (SCM string, uninorm_t form)
  1860. {
  1861. SCM ret;
  1862. scm_t_uint32 *w_str;
  1863. scm_t_wchar *cbuf;
  1864. size_t rlen, len = scm_i_string_length (string);
  1865. if (scm_i_is_narrow_string (string))
  1866. {
  1867. size_t i;
  1868. const char *buf = scm_i_string_chars (string);
  1869. w_str = alloca (sizeof (scm_t_wchar) * (len + 1));
  1870. for (i = 0; i < len; i ++)
  1871. w_str[i] = (unsigned char) buf[i];
  1872. w_str[len] = 0;
  1873. }
  1874. else
  1875. w_str = (scm_t_uint32 *) scm_i_string_wide_chars (string);
  1876. w_str = u32_normalize (form, w_str, len, NULL, &rlen);
  1877. ret = scm_i_make_wide_string (rlen, &cbuf, 0);
  1878. u32_cpy ((scm_t_uint32 *) cbuf, w_str, rlen);
  1879. free (w_str);
  1880. scm_i_try_narrow_string (ret);
  1881. return ret;
  1882. }
  1883. SCM_DEFINE (scm_string_normalize_nfc, "string-normalize-nfc", 1, 0, 0,
  1884. (SCM string),
  1885. "Returns the NFC normalized form of @var{string}.")
  1886. #define FUNC_NAME s_scm_string_normalize_nfc
  1887. {
  1888. SCM_VALIDATE_STRING (1, string);
  1889. return normalize_str (string, UNINORM_NFC);
  1890. }
  1891. #undef FUNC_NAME
  1892. SCM_DEFINE (scm_string_normalize_nfd, "string-normalize-nfd", 1, 0, 0,
  1893. (SCM string),
  1894. "Returns the NFD normalized form of @var{string}.")
  1895. #define FUNC_NAME s_scm_string_normalize_nfd
  1896. {
  1897. SCM_VALIDATE_STRING (1, string);
  1898. return normalize_str (string, UNINORM_NFD);
  1899. }
  1900. #undef FUNC_NAME
  1901. SCM_DEFINE (scm_string_normalize_nfkc, "string-normalize-nfkc", 1, 0, 0,
  1902. (SCM string),
  1903. "Returns the NFKC normalized form of @var{string}.")
  1904. #define FUNC_NAME s_scm_string_normalize_nfkc
  1905. {
  1906. SCM_VALIDATE_STRING (1, string);
  1907. return normalize_str (string, UNINORM_NFKC);
  1908. }
  1909. #undef FUNC_NAME
  1910. SCM_DEFINE (scm_string_normalize_nfkd, "string-normalize-nfkd", 1, 0, 0,
  1911. (SCM string),
  1912. "Returns the NFKD normalized form of @var{string}.")
  1913. #define FUNC_NAME s_scm_string_normalize_nfkd
  1914. {
  1915. SCM_VALIDATE_STRING (1, string);
  1916. return normalize_str (string, UNINORM_NFKD);
  1917. }
  1918. #undef FUNC_NAME
  1919. /* converts C scm_array of strings to SCM scm_list of strings.
  1920. If argc < 0, a null terminated scm_array is assumed.
  1921. The current locale encoding is assumed */
  1922. SCM
  1923. scm_makfromstrs (int argc, char **argv)
  1924. {
  1925. int i = argc;
  1926. SCM lst = SCM_EOL;
  1927. if (0 > i)
  1928. for (i = 0; argv[i]; i++);
  1929. while (i--)
  1930. lst = scm_cons (scm_from_locale_string (argv[i]), lst);
  1931. return lst;
  1932. }
  1933. /* Return a newly allocated array of char pointers to each of the strings
  1934. in args, with a terminating NULL pointer. The strings are encoded using
  1935. the current locale. */
  1936. char **
  1937. scm_i_allocate_string_pointers (SCM list)
  1938. #define FUNC_NAME "scm_i_allocate_string_pointers"
  1939. {
  1940. char **result;
  1941. int list_len = scm_ilength (list);
  1942. int i;
  1943. if (list_len < 0)
  1944. scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
  1945. result = scm_gc_malloc ((list_len + 1) * sizeof (char *),
  1946. "string pointers");
  1947. result[list_len] = NULL;
  1948. /* The list might have been modified in another thread, so
  1949. we check LIST before each access.
  1950. */
  1951. for (i = 0; i < list_len && scm_is_pair (list); i++)
  1952. {
  1953. SCM str = SCM_CAR (list);
  1954. size_t len; /* String length in bytes */
  1955. char *c_str = scm_to_locale_stringn (str, &len);
  1956. /* OPTIMIZE-ME: Right now, scm_to_locale_stringn always uses
  1957. scm_malloc to allocate the returned string, which must be
  1958. explicitly deallocated. This forces us to copy the string a
  1959. second time into a new buffer. Ideally there would be variants
  1960. of scm_to_*_stringn that can return garbage-collected buffers. */
  1961. result[i] = scm_gc_malloc_pointerless (len + 1, "string");
  1962. memcpy (result[i], c_str, len);
  1963. result[i][len] = '\0';
  1964. free (c_str);
  1965. list = SCM_CDR (list);
  1966. }
  1967. return result;
  1968. }
  1969. #undef FUNC_NAME
  1970. void
  1971. scm_i_get_substring_spec (size_t len,
  1972. SCM start, size_t *cstart,
  1973. SCM end, size_t *cend)
  1974. {
  1975. if (SCM_UNBNDP (start))
  1976. *cstart = 0;
  1977. else
  1978. *cstart = scm_to_unsigned_integer (start, 0, len);
  1979. if (SCM_UNBNDP (end))
  1980. *cend = len;
  1981. else
  1982. *cend = scm_to_unsigned_integer (end, *cstart, len);
  1983. }
  1984. static SCM
  1985. string_handle_ref (scm_t_array_handle *h, size_t index)
  1986. {
  1987. return scm_c_string_ref (h->array, index);
  1988. }
  1989. static void
  1990. string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
  1991. {
  1992. scm_c_string_set_x (h->array, index, val);
  1993. }
  1994. static void
  1995. string_get_handle (SCM v, scm_t_array_handle *h)
  1996. {
  1997. h->array = v;
  1998. h->ndims = 1;
  1999. h->dims = &h->dim0;
  2000. h->dim0.lbnd = 0;
  2001. h->dim0.ubnd = scm_c_string_length (v) - 1;
  2002. h->dim0.inc = 1;
  2003. h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR;
  2004. h->elements = h->writable_elements = NULL;
  2005. }
  2006. SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f,
  2007. string_handle_ref, string_handle_set,
  2008. string_get_handle)
  2009. SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
  2010. void
  2011. scm_init_strings ()
  2012. {
  2013. scm_nullstr = scm_i_make_string (0, NULL, 0);
  2014. #include "libguile/strings.x"
  2015. }
  2016. /*
  2017. Local Variables:
  2018. c-file-style: "gnu"
  2019. End:
  2020. */