bytevectors.c 59 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102
  1. /* Copyright 2009-2015,2018-2019
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #ifdef HAVE_LIMITS_H
  19. # include <limits.h>
  20. #endif
  21. #include <byteswap.h>
  22. #include <errno.h>
  23. #include <striconveh.h>
  24. #include <uniconv.h>
  25. #include <unistr.h>
  26. #include <string.h>
  27. #include <alloca.h>
  28. #include <gmp.h>
  29. /* FIXME want to remove this dependence. See bitvectors.h */
  30. #include "array-handle.h"
  31. #include "boolean.h"
  32. #include "dynwind.h"
  33. #include "extensions.h"
  34. #include "gsubr.h"
  35. #include "list.h"
  36. #include "numbers.h"
  37. #include "pairs.h"
  38. #include "ports.h"
  39. #include "srfi-4.h"
  40. #include "strings.h"
  41. #include "symbols.h"
  42. #include "uniform.h"
  43. #include "version.h"
  44. #include "bytevectors.h"
  45. /* Utilities. */
  46. /* Convenience macros. These are used by the various templates (macros) that
  47. are parameterized by integer signedness. */
  48. #define INT8_T_signed int8_t
  49. #define INT8_T_unsigned uint8_t
  50. #define INT16_T_signed int16_t
  51. #define INT16_T_unsigned uint16_t
  52. #define INT32_T_signed int32_t
  53. #define INT32_T_unsigned uint32_t
  54. #define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
  55. #define is_unsigned_int8(_x) ((_x) <= 255UL)
  56. #define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
  57. #define is_unsigned_int16(_x) ((_x) <= 65535UL)
  58. #define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
  59. #define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
  60. #define SIGNEDNESS_signed 1
  61. #define SIGNEDNESS_unsigned 0
  62. #define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
  63. #define INT_SWAP(_size) bswap_ ## _size
  64. #define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
  65. #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
  66. #define INTEGER_ACCESSOR_PROLOGUE(validate, _len, _sign) \
  67. size_t c_len, c_index; \
  68. _sign char *c_bv; \
  69. \
  70. SCM_VALIDATE_##validate (1, bv); \
  71. c_index = scm_to_size_t (index); \
  72. \
  73. c_len = SCM_BYTEVECTOR_LENGTH (bv); \
  74. c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
  75. \
  76. if (SCM_UNLIKELY (c_len < c_index \
  77. || (c_len - c_index < (_len) / 8))) \
  78. scm_out_of_range (FUNC_NAME, index);
  79. #define INTEGER_GETTER_PROLOGUE(_len, _sign) \
  80. INTEGER_ACCESSOR_PROLOGUE (BYTEVECTOR, _len, _sign)
  81. #define INTEGER_SETTER_PROLOGUE(_len, _sign) \
  82. INTEGER_ACCESSOR_PROLOGUE (MUTABLE_BYTEVECTOR, _len, _sign)
  83. /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
  84. #define INTEGER_REF(_len, _sign) \
  85. SCM result; \
  86. \
  87. INTEGER_GETTER_PROLOGUE (_len, _sign); \
  88. SCM_VALIDATE_SYMBOL (3, endianness); \
  89. \
  90. { \
  91. INT_TYPE (_len, _sign) c_result; \
  92. \
  93. memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
  94. if (!scm_is_eq (endianness, scm_i_native_endianness)) \
  95. c_result = INT_SWAP (_len) (c_result); \
  96. \
  97. result = SCM_I_MAKINUM (c_result); \
  98. } \
  99. \
  100. return result;
  101. /* Template for fixed-size integer access using the native endianness. */
  102. #define INTEGER_NATIVE_REF(_len, _sign) \
  103. SCM result; \
  104. \
  105. INTEGER_GETTER_PROLOGUE (_len, _sign); \
  106. \
  107. { \
  108. INT_TYPE (_len, _sign) c_result; \
  109. \
  110. memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
  111. result = SCM_I_MAKINUM (c_result); \
  112. } \
  113. \
  114. return result;
  115. /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
  116. #define INTEGER_SET(_len, _sign) \
  117. INTEGER_SETTER_PROLOGUE (_len, _sign); \
  118. SCM_VALIDATE_SYMBOL (3, endianness); \
  119. \
  120. { \
  121. scm_t_signed_bits c_value; \
  122. INT_TYPE (_len, _sign) c_value_short; \
  123. \
  124. if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
  125. scm_wrong_type_arg (FUNC_NAME, 3, value); \
  126. \
  127. c_value = SCM_I_INUM (value); \
  128. if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
  129. scm_out_of_range (FUNC_NAME, value); \
  130. \
  131. c_value_short = (INT_TYPE (_len, _sign)) c_value; \
  132. if (!scm_is_eq (endianness, scm_i_native_endianness)) \
  133. c_value_short = INT_SWAP (_len) (c_value_short); \
  134. \
  135. memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
  136. } \
  137. \
  138. return SCM_UNSPECIFIED;
  139. /* Template for fixed-size integer modification using the native
  140. endianness. */
  141. #define INTEGER_NATIVE_SET(_len, _sign) \
  142. INTEGER_SETTER_PROLOGUE (_len, _sign); \
  143. \
  144. { \
  145. scm_t_signed_bits c_value; \
  146. INT_TYPE (_len, _sign) c_value_short; \
  147. \
  148. if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
  149. scm_wrong_type_arg (FUNC_NAME, 3, value); \
  150. \
  151. c_value = SCM_I_INUM (value); \
  152. if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
  153. scm_out_of_range (FUNC_NAME, value); \
  154. \
  155. c_value_short = (INT_TYPE (_len, _sign)) c_value; \
  156. \
  157. memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
  158. } \
  159. \
  160. return SCM_UNSPECIFIED;
  161. /* Bytevector type. */
  162. #define SCM_BYTEVECTOR_HEADER_BYTES \
  163. (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
  164. #define SCM_BYTEVECTOR_SET_FLAG(bv, flag) \
  165. SCM_SET_BYTEVECTOR_FLAGS ((bv), SCM_BYTEVECTOR_FLAGS (bv) | flag)
  166. #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
  167. SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
  168. #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
  169. SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
  170. #define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
  171. SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
  172. #define SCM_VALIDATE_MUTABLE_BYTEVECTOR(pos, v) \
  173. SCM_MAKE_VALIDATE_MSG (pos, v, MUTABLE_BYTEVECTOR_P, "mutable bytevector")
  174. /* The empty bytevector. */
  175. SCM scm_null_bytevector = SCM_UNSPECIFIED;
  176. static inline SCM
  177. make_bytevector (size_t len, scm_t_array_element_type element_type)
  178. {
  179. SCM ret;
  180. size_t c_len;
  181. if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
  182. || scm_i_array_element_type_sizes[element_type] < 8))
  183. /* This would be an internal Guile programming error */
  184. abort ();
  185. /* Make sure that the total allocation size will not overflow size_t,
  186. with ~30 extra bytes to spare to avoid an overflow within the
  187. allocator. */
  188. if (SCM_UNLIKELY (len >= (((size_t) -(SCM_BYTEVECTOR_HEADER_BYTES + 32))
  189. / (scm_i_array_element_type_sizes[element_type]/8))))
  190. scm_num_overflow ("make-bytevector");
  191. if (SCM_UNLIKELY (len == 0 && element_type == SCM_ARRAY_ELEMENT_TYPE_VU8
  192. && SCM_BYTEVECTOR_P (scm_null_bytevector)))
  193. ret = scm_null_bytevector;
  194. else
  195. {
  196. signed char *contents;
  197. c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
  198. contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
  199. SCM_GC_BYTEVECTOR);
  200. ret = SCM_PACK_POINTER (contents);
  201. contents += SCM_BYTEVECTOR_HEADER_BYTES;
  202. SCM_SET_BYTEVECTOR_FLAGS (ret,
  203. element_type | SCM_F_BYTEVECTOR_CONTIGUOUS);
  204. SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
  205. SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
  206. SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
  207. }
  208. return ret;
  209. }
  210. /* Return a bytevector of LEN elements of type ELEMENT_TYPE, with element
  211. values taken from CONTENTS. Assume that the storage for CONTENTS will be
  212. automatically reclaimed when it becomes unreachable. */
  213. static inline SCM
  214. make_bytevector_from_buffer (size_t len, void *contents,
  215. scm_t_array_element_type element_type)
  216. {
  217. SCM ret;
  218. if (SCM_UNLIKELY (len == 0))
  219. ret = make_bytevector (len, element_type);
  220. else
  221. {
  222. size_t c_len;
  223. ret = SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
  224. SCM_GC_BYTEVECTOR));
  225. c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
  226. SCM_SET_BYTEVECTOR_FLAGS (ret, element_type);
  227. SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
  228. SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
  229. SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
  230. }
  231. return ret;
  232. }
  233. /* Return a new bytevector of size LEN octets. */
  234. SCM
  235. scm_c_make_bytevector (size_t len)
  236. {
  237. return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
  238. }
  239. /* Return a new bytevector of size LEN elements. */
  240. SCM
  241. scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
  242. {
  243. return make_bytevector (len, element_type);
  244. }
  245. /* Return a bytevector of size LEN made up of CONTENTS. The area
  246. pointed to by CONTENTS must be protected from GC somehow: either
  247. because it was allocated using `scm_gc_malloc ()', or because it is
  248. part of PARENT. */
  249. SCM
  250. scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
  251. {
  252. SCM ret;
  253. ret = make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
  254. SCM_BYTEVECTOR_SET_PARENT (ret, parent);
  255. return ret;
  256. }
  257. SCM
  258. scm_c_take_typed_bytevector (signed char *contents, size_t len,
  259. scm_t_array_element_type element_type, SCM parent)
  260. {
  261. SCM ret;
  262. ret = make_bytevector_from_buffer (len, contents, element_type);
  263. SCM_BYTEVECTOR_SET_PARENT (ret, parent);
  264. return ret;
  265. }
  266. /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
  267. size) and return the new bytevector (possibly different from BV). */
  268. SCM
  269. scm_c_shrink_bytevector (SCM bv, size_t c_new_len)
  270. {
  271. SCM new_bv;
  272. size_t c_len;
  273. if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
  274. /* This would be an internal Guile programming error */
  275. abort ();
  276. c_len = SCM_BYTEVECTOR_LENGTH (bv);
  277. if (SCM_UNLIKELY (c_new_len > c_len))
  278. abort ();
  279. SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
  280. if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
  281. {
  282. signed char *c_bv;
  283. c_bv = scm_gc_realloc (SCM2PTR (bv),
  284. c_len + SCM_BYTEVECTOR_HEADER_BYTES,
  285. c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
  286. SCM_GC_BYTEVECTOR);
  287. new_bv = PTR2SCM (c_bv);
  288. SCM_BYTEVECTOR_SET_CONTENTS (new_bv, c_bv + SCM_BYTEVECTOR_HEADER_BYTES);
  289. }
  290. else
  291. {
  292. signed char *c_bv;
  293. c_bv = scm_gc_realloc (SCM_BYTEVECTOR_CONTENTS (bv),
  294. c_len, c_new_len, SCM_GC_BYTEVECTOR);
  295. SCM_BYTEVECTOR_SET_CONTENTS (bv, c_bv);
  296. new_bv = bv;
  297. }
  298. return new_bv;
  299. }
  300. int
  301. scm_is_bytevector (SCM obj)
  302. {
  303. return SCM_BYTEVECTOR_P (obj);
  304. }
  305. size_t
  306. scm_c_bytevector_length (SCM bv)
  307. #define FUNC_NAME "scm_c_bytevector_length"
  308. {
  309. SCM_VALIDATE_BYTEVECTOR (1, bv);
  310. return SCM_BYTEVECTOR_LENGTH (bv);
  311. }
  312. #undef FUNC_NAME
  313. uint8_t
  314. scm_c_bytevector_ref (SCM bv, size_t index)
  315. #define FUNC_NAME "scm_c_bytevector_ref"
  316. {
  317. size_t c_len;
  318. const uint8_t *c_bv;
  319. SCM_VALIDATE_BYTEVECTOR (1, bv);
  320. c_len = SCM_BYTEVECTOR_LENGTH (bv);
  321. c_bv = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (bv);
  322. if (SCM_UNLIKELY (index >= c_len))
  323. scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
  324. return c_bv[index];
  325. }
  326. #undef FUNC_NAME
  327. void
  328. scm_c_bytevector_set_x (SCM bv, size_t index, uint8_t value)
  329. #define FUNC_NAME "scm_c_bytevector_set_x"
  330. {
  331. size_t c_len;
  332. uint8_t *c_bv;
  333. SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv);
  334. c_len = SCM_BYTEVECTOR_LENGTH (bv);
  335. c_bv = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (bv);
  336. if (SCM_UNLIKELY (index >= c_len))
  337. scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
  338. c_bv[index] = value;
  339. }
  340. #undef FUNC_NAME
  341. int
  342. scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
  343. {
  344. ssize_t ubnd, inc, i;
  345. scm_t_array_handle h;
  346. scm_array_get_handle (bv, &h);
  347. scm_putc ('#', port);
  348. scm_write (scm_array_handle_element_type (&h), port);
  349. scm_putc ('(', port);
  350. for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
  351. i <= ubnd; i += inc)
  352. {
  353. if (i > 0)
  354. scm_putc (' ', port);
  355. scm_write (scm_array_handle_ref (&h, i), port);
  356. }
  357. scm_putc (')', port);
  358. return 1;
  359. }
  360. /* General operations. */
  361. static SCM sym_big;
  362. static SCM sym_little;
  363. SCM scm_endianness_big, scm_endianness_little;
  364. /* Host endianness (a symbol). */
  365. SCM scm_i_native_endianness = SCM_UNSPECIFIED;
  366. /* Byte-swapping. */
  367. #ifndef bswap_24
  368. # define bswap_24(_x) \
  369. ((((_x) & 0xff0000) >> 16) | \
  370. (((_x) & 0x00ff00)) | \
  371. (((_x) & 0x0000ff) << 16))
  372. #endif
  373. SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
  374. (void),
  375. "Return a symbol denoting the machine's native endianness.")
  376. #define FUNC_NAME s_scm_native_endianness
  377. {
  378. return scm_i_native_endianness;
  379. }
  380. #undef FUNC_NAME
  381. SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
  382. (SCM obj),
  383. "Return true if @var{obj} is a bytevector.")
  384. #define FUNC_NAME s_scm_bytevector_p
  385. {
  386. return scm_from_bool (scm_is_bytevector (obj));
  387. }
  388. #undef FUNC_NAME
  389. SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
  390. (SCM len, SCM fill),
  391. "Return a newly allocated bytevector of @var{len} bytes, "
  392. "optionally filled with @var{fill}.")
  393. #define FUNC_NAME s_scm_make_bytevector
  394. {
  395. SCM bv;
  396. size_t c_len;
  397. uint8_t c_fill = 0;
  398. SCM_VALIDATE_SIZE_COPY (1, len, c_len);
  399. if (!scm_is_eq (fill, SCM_UNDEFINED))
  400. {
  401. int value;
  402. value = scm_to_int (fill);
  403. if (SCM_UNLIKELY ((value < -128) || (value > 255)))
  404. scm_out_of_range (FUNC_NAME, fill);
  405. c_fill = (uint8_t) value;
  406. }
  407. bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
  408. if (!scm_is_eq (fill, SCM_UNDEFINED))
  409. {
  410. size_t i;
  411. uint8_t *contents;
  412. contents = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (bv);
  413. for (i = 0; i < c_len; i++)
  414. contents[i] = c_fill;
  415. }
  416. else
  417. memset (SCM_BYTEVECTOR_CONTENTS (bv), 0, c_len);
  418. return bv;
  419. }
  420. #undef FUNC_NAME
  421. SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
  422. (SCM bv),
  423. "Return the length (in bytes) of @var{bv}.")
  424. #define FUNC_NAME s_scm_bytevector_length
  425. {
  426. return scm_from_size_t (scm_c_bytevector_length (bv));
  427. }
  428. #undef FUNC_NAME
  429. SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
  430. (SCM bv1, SCM bv2),
  431. "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
  432. "have the same length and contents.")
  433. #define FUNC_NAME s_scm_bytevector_eq_p
  434. {
  435. SCM result = SCM_BOOL_F;
  436. size_t c_len1, c_len2;
  437. SCM_VALIDATE_BYTEVECTOR (1, bv1);
  438. SCM_VALIDATE_BYTEVECTOR (2, bv2);
  439. c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
  440. c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
  441. if (c_len1 == c_len2 && (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1)
  442. == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2)))
  443. {
  444. signed char *c_bv1, *c_bv2;
  445. c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
  446. c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
  447. result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
  448. }
  449. return result;
  450. }
  451. #undef FUNC_NAME
  452. SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
  453. (SCM bv, SCM fill),
  454. "Fill bytevector @var{bv} with @var{fill}, a byte.")
  455. #define FUNC_NAME s_scm_bytevector_fill_x
  456. {
  457. size_t c_len, i;
  458. uint8_t *c_bv, c_fill;
  459. int value;
  460. SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv);
  461. value = scm_to_int (fill);
  462. if (SCM_UNLIKELY ((value < -128) || (value > 255)))
  463. scm_out_of_range (FUNC_NAME, fill);
  464. c_fill = (uint8_t) value;
  465. c_len = SCM_BYTEVECTOR_LENGTH (bv);
  466. c_bv = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (bv);
  467. for (i = 0; i < c_len; i++)
  468. c_bv[i] = c_fill;
  469. return SCM_UNSPECIFIED;
  470. }
  471. #undef FUNC_NAME
  472. SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
  473. (SCM source, SCM source_start, SCM target, SCM target_start,
  474. SCM len),
  475. "Copy @var{len} bytes from @var{source} into @var{target}, "
  476. "starting reading from @var{source_start} (a positive index "
  477. "within @var{source}) and start writing at "
  478. "@var{target_start}.")
  479. #define FUNC_NAME s_scm_bytevector_copy_x
  480. {
  481. size_t c_len, c_source_len, c_target_len;
  482. size_t c_source_start, c_target_start;
  483. signed char *c_source, *c_target;
  484. SCM_VALIDATE_BYTEVECTOR (1, source);
  485. SCM_VALIDATE_MUTABLE_BYTEVECTOR (3, target);
  486. c_len = scm_to_size_t (len);
  487. c_source_start = scm_to_size_t (source_start);
  488. c_target_start = scm_to_size_t (target_start);
  489. c_source = SCM_BYTEVECTOR_CONTENTS (source);
  490. c_target = SCM_BYTEVECTOR_CONTENTS (target);
  491. c_source_len = SCM_BYTEVECTOR_LENGTH (source);
  492. c_target_len = SCM_BYTEVECTOR_LENGTH (target);
  493. if (SCM_UNLIKELY (c_source_len < c_source_start
  494. || (c_source_len - c_source_start < c_len)))
  495. scm_out_of_range (FUNC_NAME, source_start);
  496. if (SCM_UNLIKELY (c_target_len < c_target_start
  497. || (c_target_len - c_target_start < c_len)))
  498. scm_out_of_range (FUNC_NAME, target_start);
  499. memmove (c_target + c_target_start,
  500. c_source + c_source_start,
  501. c_len);
  502. return SCM_UNSPECIFIED;
  503. }
  504. #undef FUNC_NAME
  505. SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
  506. (SCM bv),
  507. "Return a newly allocated copy of @var{bv}.")
  508. #define FUNC_NAME s_scm_bytevector_copy
  509. {
  510. SCM copy;
  511. size_t c_len;
  512. signed char *c_bv, *c_copy;
  513. SCM_VALIDATE_BYTEVECTOR (1, bv);
  514. c_len = SCM_BYTEVECTOR_LENGTH (bv);
  515. c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
  516. copy = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
  517. c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
  518. memcpy (c_copy, c_bv, c_len);
  519. return copy;
  520. }
  521. #undef FUNC_NAME
  522. /* Operations on bytes and octets. */
  523. SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
  524. (SCM bv, SCM index),
  525. "Return the octet located at @var{index} in @var{bv}.")
  526. #define FUNC_NAME s_scm_bytevector_u8_ref
  527. {
  528. INTEGER_NATIVE_REF (8, unsigned);
  529. }
  530. #undef FUNC_NAME
  531. SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
  532. (SCM bv, SCM index),
  533. "Return the byte located at @var{index} in @var{bv}.")
  534. #define FUNC_NAME s_scm_bytevector_s8_ref
  535. {
  536. INTEGER_NATIVE_REF (8, signed);
  537. }
  538. #undef FUNC_NAME
  539. SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
  540. (SCM bv, SCM index, SCM value),
  541. "Return the octet located at @var{index} in @var{bv}.")
  542. #define FUNC_NAME s_scm_bytevector_u8_set_x
  543. {
  544. INTEGER_NATIVE_SET (8, unsigned);
  545. }
  546. #undef FUNC_NAME
  547. SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
  548. (SCM bv, SCM index, SCM value),
  549. "Return the octet located at @var{index} in @var{bv}.")
  550. #define FUNC_NAME s_scm_bytevector_s8_set_x
  551. {
  552. INTEGER_NATIVE_SET (8, signed);
  553. }
  554. #undef FUNC_NAME
  555. SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
  556. (SCM bv),
  557. "Return a newly allocated list of octets containing the "
  558. "contents of @var{bv}.")
  559. #define FUNC_NAME s_scm_bytevector_to_u8_list
  560. {
  561. SCM lst, pair;
  562. size_t c_len, i;
  563. uint8_t *c_bv;
  564. SCM_VALIDATE_BYTEVECTOR (1, bv);
  565. c_len = SCM_BYTEVECTOR_LENGTH (bv);
  566. c_bv = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (bv);
  567. lst = scm_make_list (scm_from_size_t (c_len), SCM_UNSPECIFIED);
  568. for (i = 0, pair = lst;
  569. i < c_len;
  570. i++, pair = SCM_CDR (pair))
  571. {
  572. SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
  573. }
  574. return lst;
  575. }
  576. #undef FUNC_NAME
  577. SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
  578. (SCM lst),
  579. "Turn @var{lst}, a list of octets, into a bytevector.")
  580. #define FUNC_NAME s_scm_u8_list_to_bytevector
  581. {
  582. SCM bv, item;
  583. size_t c_len, i;
  584. uint8_t *c_bv;
  585. SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
  586. bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
  587. c_bv = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (bv);
  588. for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
  589. {
  590. item = SCM_CAR (lst);
  591. if (SCM_LIKELY (SCM_I_INUMP (item)))
  592. {
  593. scm_t_signed_bits c_item;
  594. c_item = SCM_I_INUM (item);
  595. if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
  596. c_bv[i] = (uint8_t) c_item;
  597. else
  598. goto type_error;
  599. }
  600. else
  601. goto type_error;
  602. }
  603. return bv;
  604. type_error:
  605. scm_wrong_type_arg (FUNC_NAME, 1, item);
  606. return SCM_BOOL_F;
  607. }
  608. #undef FUNC_NAME
  609. /* Compute the two's complement of VALUE (a positive integer) on SIZE octets
  610. using (2^(SIZE * 8) - VALUE). */
  611. static inline void
  612. twos_complement (mpz_t value, size_t size)
  613. {
  614. unsigned long bit_count;
  615. /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
  616. checking on SIZE performed earlier. */
  617. bit_count = (unsigned long) size << 3UL;
  618. if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
  619. mpz_ui_sub (value, 1UL << bit_count, value);
  620. else
  621. {
  622. mpz_t max;
  623. mpz_init (max);
  624. mpz_ui_pow_ui (max, 2, bit_count);
  625. mpz_sub (value, max, value);
  626. mpz_clear (max);
  627. }
  628. }
  629. static inline SCM
  630. bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
  631. SCM endianness)
  632. {
  633. SCM result;
  634. mpz_t c_mpz;
  635. int c_endianness, negative_p = 0;
  636. if (signed_p)
  637. {
  638. if (scm_is_eq (endianness, sym_big))
  639. negative_p = c_bv[0] & 0x80;
  640. else
  641. negative_p = c_bv[c_size - 1] & 0x80;
  642. }
  643. c_endianness = scm_is_eq (endianness, sym_big) ? 1 : -1;
  644. mpz_init (c_mpz);
  645. mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
  646. c_size /* word is C_SIZE-byte long */,
  647. c_endianness,
  648. 0 /* nails */, c_bv);
  649. if (signed_p && negative_p)
  650. {
  651. twos_complement (c_mpz, c_size);
  652. mpz_neg (c_mpz, c_mpz);
  653. }
  654. result = scm_from_mpz (c_mpz);
  655. mpz_clear (c_mpz); /* FIXME: Needed? */
  656. return result;
  657. }
  658. static inline int
  659. bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
  660. SCM value, SCM endianness)
  661. {
  662. mpz_t c_mpz;
  663. int c_endianness, c_sign, err = 0;
  664. c_endianness = scm_is_eq (endianness, sym_big) ? 1 : -1;
  665. mpz_init (c_mpz);
  666. scm_to_mpz (value, c_mpz);
  667. c_sign = mpz_sgn (c_mpz);
  668. if (c_sign < 0)
  669. {
  670. if (SCM_LIKELY (signed_p))
  671. {
  672. mpz_neg (c_mpz, c_mpz);
  673. twos_complement (c_mpz, c_size);
  674. }
  675. else
  676. {
  677. err = -1;
  678. goto finish;
  679. }
  680. }
  681. if (c_sign == 0)
  682. /* Zero. */
  683. memset (c_bv, 0, c_size);
  684. else
  685. {
  686. size_t word_count, value_words;
  687. value_words = ((mpz_sizeinbase (c_mpz, 2) + (8 * c_size) - 1) /
  688. (8 * c_size));
  689. if (SCM_UNLIKELY (value_words > 1))
  690. {
  691. err = -2;
  692. goto finish;
  693. }
  694. mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
  695. c_size, c_endianness,
  696. 0 /* nails */, c_mpz);
  697. if (SCM_UNLIKELY (word_count != 1))
  698. /* Shouldn't happen since we already checked with VALUE_SIZE. */
  699. abort ();
  700. }
  701. finish:
  702. mpz_clear (c_mpz);
  703. return err;
  704. }
  705. #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(validate, _sign) \
  706. size_t c_len, c_index, c_size; \
  707. char *c_bv; \
  708. \
  709. SCM_VALIDATE_##validate (1, bv); \
  710. c_index = scm_to_size_t (index); \
  711. c_size = scm_to_size_t (size); \
  712. \
  713. c_len = SCM_BYTEVECTOR_LENGTH (bv); \
  714. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
  715. \
  716. /* C_SIZE must have its 3 higher bits set to zero so that \
  717. multiplying it by 8 yields a number that fits in a \
  718. size_t. */ \
  719. if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
  720. scm_out_of_range (FUNC_NAME, size); \
  721. if (SCM_UNLIKELY (c_len < c_index \
  722. || (c_len - c_index < c_size))) \
  723. scm_out_of_range (FUNC_NAME, index);
  724. #define GENERIC_INTEGER_GETTER_PROLOGUE(_sign) \
  725. GENERIC_INTEGER_ACCESSOR_PROLOGUE (BYTEVECTOR, _sign)
  726. #define GENERIC_INTEGER_SETTER_PROLOGUE(_sign) \
  727. GENERIC_INTEGER_ACCESSOR_PROLOGUE (MUTABLE_BYTEVECTOR, _sign)
  728. /* Template of an integer reference function. */
  729. #define GENERIC_INTEGER_REF(_sign) \
  730. SCM result; \
  731. \
  732. if (c_size < 3) \
  733. { \
  734. int swap; \
  735. _sign int value; \
  736. \
  737. swap = !scm_is_eq (endianness, scm_i_native_endianness); \
  738. switch (c_size) \
  739. { \
  740. case 1: \
  741. { \
  742. _sign char c_value8; \
  743. memcpy (&c_value8, c_bv, 1); \
  744. value = c_value8; \
  745. } \
  746. break; \
  747. case 2: \
  748. { \
  749. INT_TYPE (16, _sign) c_value16; \
  750. memcpy (&c_value16, c_bv, 2); \
  751. if (swap) \
  752. value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
  753. else \
  754. value = c_value16; \
  755. } \
  756. break; \
  757. default: \
  758. abort (); \
  759. } \
  760. \
  761. result = SCM_I_MAKINUM ((_sign int) value); \
  762. } \
  763. else \
  764. result = bytevector_large_ref ((char *) c_bv, \
  765. c_size, SIGNEDNESS (_sign), \
  766. endianness); \
  767. \
  768. return result;
  769. static inline SCM
  770. bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
  771. {
  772. GENERIC_INTEGER_REF (signed);
  773. }
  774. static inline SCM
  775. bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
  776. {
  777. GENERIC_INTEGER_REF (unsigned);
  778. }
  779. /* Template of an integer assignment function. */
  780. #define GENERIC_INTEGER_SET(_sign) \
  781. if (c_size < 3) \
  782. { \
  783. scm_t_signed_bits c_value; \
  784. \
  785. if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
  786. goto range_error; \
  787. \
  788. c_value = SCM_I_INUM (value); \
  789. switch (c_size) \
  790. { \
  791. case 1: \
  792. if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
  793. { \
  794. _sign char c_value8; \
  795. c_value8 = (_sign char) c_value; \
  796. memcpy (c_bv, &c_value8, 1); \
  797. } \
  798. else \
  799. goto range_error; \
  800. break; \
  801. \
  802. case 2: \
  803. if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
  804. { \
  805. int swap; \
  806. INT_TYPE (16, _sign) c_value16; \
  807. \
  808. swap = !scm_is_eq (endianness, scm_i_native_endianness); \
  809. \
  810. if (swap) \
  811. c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
  812. else \
  813. c_value16 = c_value; \
  814. \
  815. memcpy (c_bv, &c_value16, 2); \
  816. } \
  817. else \
  818. goto range_error; \
  819. break; \
  820. \
  821. default: \
  822. abort (); \
  823. } \
  824. } \
  825. else \
  826. { \
  827. int err; \
  828. \
  829. err = bytevector_large_set (c_bv, c_size, \
  830. SIGNEDNESS (_sign), \
  831. value, endianness); \
  832. if (err) \
  833. goto range_error; \
  834. } \
  835. \
  836. return; \
  837. \
  838. range_error: \
  839. scm_out_of_range (FUNC_NAME, value); \
  840. return;
  841. static inline void
  842. bytevector_signed_set (char *c_bv, size_t c_size,
  843. SCM value, SCM endianness,
  844. const char *func_name)
  845. #define FUNC_NAME func_name
  846. {
  847. GENERIC_INTEGER_SET (signed);
  848. }
  849. #undef FUNC_NAME
  850. static inline void
  851. bytevector_unsigned_set (char *c_bv, size_t c_size,
  852. SCM value, SCM endianness,
  853. const char *func_name)
  854. #define FUNC_NAME func_name
  855. {
  856. GENERIC_INTEGER_SET (unsigned);
  857. }
  858. #undef FUNC_NAME
  859. #undef GENERIC_INTEGER_SET
  860. #undef GENERIC_INTEGER_REF
  861. SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
  862. (SCM bv, SCM index, SCM endianness, SCM size),
  863. "Return the @var{size}-octet long unsigned integer at index "
  864. "@var{index} in @var{bv}.")
  865. #define FUNC_NAME s_scm_bytevector_uint_ref
  866. {
  867. GENERIC_INTEGER_GETTER_PROLOGUE (unsigned);
  868. return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
  869. }
  870. #undef FUNC_NAME
  871. SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
  872. (SCM bv, SCM index, SCM endianness, SCM size),
  873. "Return the @var{size}-octet long unsigned integer at index "
  874. "@var{index} in @var{bv}.")
  875. #define FUNC_NAME s_scm_bytevector_sint_ref
  876. {
  877. GENERIC_INTEGER_GETTER_PROLOGUE (signed);
  878. return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
  879. }
  880. #undef FUNC_NAME
  881. SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
  882. (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
  883. "Set the @var{size}-octet long unsigned integer at @var{index} "
  884. "to @var{value}.")
  885. #define FUNC_NAME s_scm_bytevector_uint_set_x
  886. {
  887. GENERIC_INTEGER_SETTER_PROLOGUE (unsigned);
  888. bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
  889. FUNC_NAME);
  890. return SCM_UNSPECIFIED;
  891. }
  892. #undef FUNC_NAME
  893. SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
  894. (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
  895. "Set the @var{size}-octet long signed integer at @var{index} "
  896. "to @var{value}.")
  897. #define FUNC_NAME s_scm_bytevector_sint_set_x
  898. {
  899. GENERIC_INTEGER_SETTER_PROLOGUE (signed);
  900. bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
  901. FUNC_NAME);
  902. return SCM_UNSPECIFIED;
  903. }
  904. #undef FUNC_NAME
  905. /* Operations on integers of arbitrary size. */
  906. #define INTEGERS_TO_LIST(_sign) \
  907. SCM lst, pair; \
  908. size_t i, c_len, c_size; \
  909. \
  910. SCM_VALIDATE_BYTEVECTOR (1, bv); \
  911. SCM_VALIDATE_SYMBOL (2, endianness); \
  912. c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
  913. \
  914. c_len = SCM_BYTEVECTOR_LENGTH (bv); \
  915. if (SCM_UNLIKELY (c_len % c_size != 0)) \
  916. scm_wrong_type_arg_msg \
  917. (FUNC_NAME, 0, size, \
  918. "an exact positive integer that divides the bytevector length"); \
  919. else if (SCM_UNLIKELY (c_len == 0)) \
  920. lst = SCM_EOL; \
  921. else \
  922. { \
  923. const char *c_bv; \
  924. \
  925. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
  926. \
  927. lst = scm_make_list (scm_from_size_t (c_len / c_size), \
  928. SCM_UNSPECIFIED); \
  929. for (i = 0, pair = lst; \
  930. i <= c_len - c_size; \
  931. i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
  932. { \
  933. SCM_SETCAR (pair, \
  934. bytevector_ ## _sign ## _ref (c_bv, c_size, \
  935. endianness)); \
  936. } \
  937. } \
  938. \
  939. return lst;
  940. SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
  941. 3, 0, 0,
  942. (SCM bv, SCM endianness, SCM size),
  943. "Return a list of signed integers of @var{size} octets "
  944. "representing the contents of @var{bv}.")
  945. #define FUNC_NAME s_scm_bytevector_to_sint_list
  946. {
  947. INTEGERS_TO_LIST (signed);
  948. }
  949. #undef FUNC_NAME
  950. SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
  951. 3, 0, 0,
  952. (SCM bv, SCM endianness, SCM size),
  953. "Return a list of unsigned integers of @var{size} octets "
  954. "representing the contents of @var{bv}.")
  955. #define FUNC_NAME s_scm_bytevector_to_uint_list
  956. {
  957. INTEGERS_TO_LIST (unsigned);
  958. }
  959. #undef FUNC_NAME
  960. #undef INTEGER_TO_LIST
  961. #define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
  962. SCM bv; \
  963. size_t c_len; \
  964. size_t c_size; \
  965. char *c_bv, *c_bv_ptr; \
  966. \
  967. SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
  968. SCM_VALIDATE_SYMBOL (2, endianness); \
  969. c_size = scm_to_size_t (size); \
  970. \
  971. if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
  972. scm_out_of_range (FUNC_NAME, size); \
  973. \
  974. bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
  975. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
  976. \
  977. for (c_bv_ptr = c_bv; \
  978. !scm_is_null (lst); \
  979. lst = SCM_CDR (lst), c_bv_ptr += c_size) \
  980. { \
  981. bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
  982. SCM_CAR (lst), endianness, \
  983. FUNC_NAME); \
  984. } \
  985. \
  986. return bv;
  987. SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
  988. 3, 0, 0,
  989. (SCM lst, SCM endianness, SCM size),
  990. "Return a bytevector containing the unsigned integers "
  991. "listed in @var{lst} and encoded on @var{size} octets "
  992. "according to @var{endianness}.")
  993. #define FUNC_NAME s_scm_uint_list_to_bytevector
  994. {
  995. INTEGER_LIST_TO_BYTEVECTOR (unsigned);
  996. }
  997. #undef FUNC_NAME
  998. SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
  999. 3, 0, 0,
  1000. (SCM lst, SCM endianness, SCM size),
  1001. "Return a bytevector containing the signed integers "
  1002. "listed in @var{lst} and encoded on @var{size} octets "
  1003. "according to @var{endianness}.")
  1004. #define FUNC_NAME s_scm_sint_list_to_bytevector
  1005. {
  1006. INTEGER_LIST_TO_BYTEVECTOR (signed);
  1007. }
  1008. #undef FUNC_NAME
  1009. #undef INTEGER_LIST_TO_BYTEVECTOR
  1010. /* Operations on 16-bit integers. */
  1011. SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
  1012. 3, 0, 0,
  1013. (SCM bv, SCM index, SCM endianness),
  1014. "Return the unsigned 16-bit integer from @var{bv} at "
  1015. "@var{index}.")
  1016. #define FUNC_NAME s_scm_bytevector_u16_ref
  1017. {
  1018. INTEGER_REF (16, unsigned);
  1019. }
  1020. #undef FUNC_NAME
  1021. SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
  1022. 3, 0, 0,
  1023. (SCM bv, SCM index, SCM endianness),
  1024. "Return the signed 16-bit integer from @var{bv} at "
  1025. "@var{index}.")
  1026. #define FUNC_NAME s_scm_bytevector_s16_ref
  1027. {
  1028. INTEGER_REF (16, signed);
  1029. }
  1030. #undef FUNC_NAME
  1031. SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
  1032. 2, 0, 0,
  1033. (SCM bv, SCM index),
  1034. "Return the unsigned 16-bit integer from @var{bv} at "
  1035. "@var{index} using the native endianness.")
  1036. #define FUNC_NAME s_scm_bytevector_u16_native_ref
  1037. {
  1038. INTEGER_NATIVE_REF (16, unsigned);
  1039. }
  1040. #undef FUNC_NAME
  1041. SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
  1042. 2, 0, 0,
  1043. (SCM bv, SCM index),
  1044. "Return the unsigned 16-bit integer from @var{bv} at "
  1045. "@var{index} using the native endianness.")
  1046. #define FUNC_NAME s_scm_bytevector_s16_native_ref
  1047. {
  1048. INTEGER_NATIVE_REF (16, signed);
  1049. }
  1050. #undef FUNC_NAME
  1051. SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
  1052. 4, 0, 0,
  1053. (SCM bv, SCM index, SCM value, SCM endianness),
  1054. "Store @var{value} in @var{bv} at @var{index} according to "
  1055. "@var{endianness}.")
  1056. #define FUNC_NAME s_scm_bytevector_u16_set_x
  1057. {
  1058. INTEGER_SET (16, unsigned);
  1059. }
  1060. #undef FUNC_NAME
  1061. SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
  1062. 4, 0, 0,
  1063. (SCM bv, SCM index, SCM value, SCM endianness),
  1064. "Store @var{value} in @var{bv} at @var{index} according to "
  1065. "@var{endianness}.")
  1066. #define FUNC_NAME s_scm_bytevector_s16_set_x
  1067. {
  1068. INTEGER_SET (16, signed);
  1069. }
  1070. #undef FUNC_NAME
  1071. SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
  1072. 3, 0, 0,
  1073. (SCM bv, SCM index, SCM value),
  1074. "Store the unsigned integer @var{value} at index @var{index} "
  1075. "of @var{bv} using the native endianness.")
  1076. #define FUNC_NAME s_scm_bytevector_u16_native_set_x
  1077. {
  1078. INTEGER_NATIVE_SET (16, unsigned);
  1079. }
  1080. #undef FUNC_NAME
  1081. SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
  1082. 3, 0, 0,
  1083. (SCM bv, SCM index, SCM value),
  1084. "Store the signed integer @var{value} at index @var{index} "
  1085. "of @var{bv} using the native endianness.")
  1086. #define FUNC_NAME s_scm_bytevector_s16_native_set_x
  1087. {
  1088. INTEGER_NATIVE_SET (16, signed);
  1089. }
  1090. #undef FUNC_NAME
  1091. /* Operations on 32-bit integers. */
  1092. /* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
  1093. arbitrary 32-bit integers. Thus we fall back to using the
  1094. `large_{ref,set}' variants on 32-bit machines. */
  1095. #define LARGE_INTEGER_REF(_len, _sign) \
  1096. INTEGER_GETTER_PROLOGUE(_len, _sign); \
  1097. SCM_VALIDATE_SYMBOL (3, endianness); \
  1098. \
  1099. return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
  1100. SIGNEDNESS (_sign), endianness));
  1101. #define LARGE_INTEGER_SET(_len, _sign) \
  1102. int err; \
  1103. INTEGER_SETTER_PROLOGUE (_len, _sign); \
  1104. SCM_VALIDATE_SYMBOL (4, endianness); \
  1105. \
  1106. err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
  1107. SIGNEDNESS (_sign), value, endianness); \
  1108. if (SCM_UNLIKELY (err)) \
  1109. scm_out_of_range (FUNC_NAME, value); \
  1110. \
  1111. return SCM_UNSPECIFIED;
  1112. #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
  1113. INTEGER_GETTER_PROLOGUE(_len, _sign); \
  1114. return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
  1115. SIGNEDNESS (_sign), scm_i_native_endianness));
  1116. #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
  1117. int err; \
  1118. INTEGER_SETTER_PROLOGUE (_len, _sign); \
  1119. \
  1120. err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
  1121. SIGNEDNESS (_sign), value, \
  1122. scm_i_native_endianness); \
  1123. if (SCM_UNLIKELY (err)) \
  1124. scm_out_of_range (FUNC_NAME, value); \
  1125. \
  1126. return SCM_UNSPECIFIED;
  1127. SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
  1128. 3, 0, 0,
  1129. (SCM bv, SCM index, SCM endianness),
  1130. "Return the unsigned 32-bit integer from @var{bv} at "
  1131. "@var{index}.")
  1132. #define FUNC_NAME s_scm_bytevector_u32_ref
  1133. {
  1134. #if SIZEOF_VOID_P > 4
  1135. INTEGER_REF (32, unsigned);
  1136. #else
  1137. LARGE_INTEGER_REF (32, unsigned);
  1138. #endif
  1139. }
  1140. #undef FUNC_NAME
  1141. SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
  1142. 3, 0, 0,
  1143. (SCM bv, SCM index, SCM endianness),
  1144. "Return the signed 32-bit integer from @var{bv} at "
  1145. "@var{index}.")
  1146. #define FUNC_NAME s_scm_bytevector_s32_ref
  1147. {
  1148. #if SIZEOF_VOID_P > 4
  1149. INTEGER_REF (32, signed);
  1150. #else
  1151. LARGE_INTEGER_REF (32, signed);
  1152. #endif
  1153. }
  1154. #undef FUNC_NAME
  1155. SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
  1156. 2, 0, 0,
  1157. (SCM bv, SCM index),
  1158. "Return the unsigned 32-bit integer from @var{bv} at "
  1159. "@var{index} using the native endianness.")
  1160. #define FUNC_NAME s_scm_bytevector_u32_native_ref
  1161. {
  1162. #if SIZEOF_VOID_P > 4
  1163. INTEGER_NATIVE_REF (32, unsigned);
  1164. #else
  1165. LARGE_INTEGER_NATIVE_REF (32, unsigned);
  1166. #endif
  1167. }
  1168. #undef FUNC_NAME
  1169. SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
  1170. 2, 0, 0,
  1171. (SCM bv, SCM index),
  1172. "Return the unsigned 32-bit integer from @var{bv} at "
  1173. "@var{index} using the native endianness.")
  1174. #define FUNC_NAME s_scm_bytevector_s32_native_ref
  1175. {
  1176. #if SIZEOF_VOID_P > 4
  1177. INTEGER_NATIVE_REF (32, signed);
  1178. #else
  1179. LARGE_INTEGER_NATIVE_REF (32, signed);
  1180. #endif
  1181. }
  1182. #undef FUNC_NAME
  1183. SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
  1184. 4, 0, 0,
  1185. (SCM bv, SCM index, SCM value, SCM endianness),
  1186. "Store @var{value} in @var{bv} at @var{index} according to "
  1187. "@var{endianness}.")
  1188. #define FUNC_NAME s_scm_bytevector_u32_set_x
  1189. {
  1190. #if SIZEOF_VOID_P > 4
  1191. INTEGER_SET (32, unsigned);
  1192. #else
  1193. LARGE_INTEGER_SET (32, unsigned);
  1194. #endif
  1195. }
  1196. #undef FUNC_NAME
  1197. SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
  1198. 4, 0, 0,
  1199. (SCM bv, SCM index, SCM value, SCM endianness),
  1200. "Store @var{value} in @var{bv} at @var{index} according to "
  1201. "@var{endianness}.")
  1202. #define FUNC_NAME s_scm_bytevector_s32_set_x
  1203. {
  1204. #if SIZEOF_VOID_P > 4
  1205. INTEGER_SET (32, signed);
  1206. #else
  1207. LARGE_INTEGER_SET (32, signed);
  1208. #endif
  1209. }
  1210. #undef FUNC_NAME
  1211. SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
  1212. 3, 0, 0,
  1213. (SCM bv, SCM index, SCM value),
  1214. "Store the unsigned integer @var{value} at index @var{index} "
  1215. "of @var{bv} using the native endianness.")
  1216. #define FUNC_NAME s_scm_bytevector_u32_native_set_x
  1217. {
  1218. #if SIZEOF_VOID_P > 4
  1219. INTEGER_NATIVE_SET (32, unsigned);
  1220. #else
  1221. LARGE_INTEGER_NATIVE_SET (32, unsigned);
  1222. #endif
  1223. }
  1224. #undef FUNC_NAME
  1225. SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
  1226. 3, 0, 0,
  1227. (SCM bv, SCM index, SCM value),
  1228. "Store the signed integer @var{value} at index @var{index} "
  1229. "of @var{bv} using the native endianness.")
  1230. #define FUNC_NAME s_scm_bytevector_s32_native_set_x
  1231. {
  1232. #if SIZEOF_VOID_P > 4
  1233. INTEGER_NATIVE_SET (32, signed);
  1234. #else
  1235. LARGE_INTEGER_NATIVE_SET (32, signed);
  1236. #endif
  1237. }
  1238. #undef FUNC_NAME
  1239. /* Operations on 64-bit integers. */
  1240. /* For 64-bit integers, we use only the `large_{ref,set}' variant. */
  1241. SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
  1242. 3, 0, 0,
  1243. (SCM bv, SCM index, SCM endianness),
  1244. "Return the unsigned 64-bit integer from @var{bv} at "
  1245. "@var{index}.")
  1246. #define FUNC_NAME s_scm_bytevector_u64_ref
  1247. {
  1248. LARGE_INTEGER_REF (64, unsigned);
  1249. }
  1250. #undef FUNC_NAME
  1251. SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
  1252. 3, 0, 0,
  1253. (SCM bv, SCM index, SCM endianness),
  1254. "Return the signed 64-bit integer from @var{bv} at "
  1255. "@var{index}.")
  1256. #define FUNC_NAME s_scm_bytevector_s64_ref
  1257. {
  1258. LARGE_INTEGER_REF (64, signed);
  1259. }
  1260. #undef FUNC_NAME
  1261. SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
  1262. 2, 0, 0,
  1263. (SCM bv, SCM index),
  1264. "Return the unsigned 64-bit integer from @var{bv} at "
  1265. "@var{index} using the native endianness.")
  1266. #define FUNC_NAME s_scm_bytevector_u64_native_ref
  1267. {
  1268. LARGE_INTEGER_NATIVE_REF (64, unsigned);
  1269. }
  1270. #undef FUNC_NAME
  1271. SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
  1272. 2, 0, 0,
  1273. (SCM bv, SCM index),
  1274. "Return the unsigned 64-bit integer from @var{bv} at "
  1275. "@var{index} using the native endianness.")
  1276. #define FUNC_NAME s_scm_bytevector_s64_native_ref
  1277. {
  1278. LARGE_INTEGER_NATIVE_REF (64, signed);
  1279. }
  1280. #undef FUNC_NAME
  1281. SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
  1282. 4, 0, 0,
  1283. (SCM bv, SCM index, SCM value, SCM endianness),
  1284. "Store @var{value} in @var{bv} at @var{index} according to "
  1285. "@var{endianness}.")
  1286. #define FUNC_NAME s_scm_bytevector_u64_set_x
  1287. {
  1288. LARGE_INTEGER_SET (64, unsigned);
  1289. }
  1290. #undef FUNC_NAME
  1291. SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
  1292. 4, 0, 0,
  1293. (SCM bv, SCM index, SCM value, SCM endianness),
  1294. "Store @var{value} in @var{bv} at @var{index} according to "
  1295. "@var{endianness}.")
  1296. #define FUNC_NAME s_scm_bytevector_s64_set_x
  1297. {
  1298. LARGE_INTEGER_SET (64, signed);
  1299. }
  1300. #undef FUNC_NAME
  1301. SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
  1302. 3, 0, 0,
  1303. (SCM bv, SCM index, SCM value),
  1304. "Store the unsigned integer @var{value} at index @var{index} "
  1305. "of @var{bv} using the native endianness.")
  1306. #define FUNC_NAME s_scm_bytevector_u64_native_set_x
  1307. {
  1308. LARGE_INTEGER_NATIVE_SET (64, unsigned);
  1309. }
  1310. #undef FUNC_NAME
  1311. SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
  1312. 3, 0, 0,
  1313. (SCM bv, SCM index, SCM value),
  1314. "Store the signed integer @var{value} at index @var{index} "
  1315. "of @var{bv} using the native endianness.")
  1316. #define FUNC_NAME s_scm_bytevector_s64_native_set_x
  1317. {
  1318. LARGE_INTEGER_NATIVE_SET (64, signed);
  1319. }
  1320. #undef FUNC_NAME
  1321. /* Operations on IEEE-754 numbers. */
  1322. /* There are two possible word endians, visible in glibc's <ieee754.h>.
  1323. However, in R6RS, when the endianness is `little', little endian is
  1324. assumed for both the byte order and the word order. This is clear from
  1325. Section 2.1 of R6RS-lib (in response to
  1326. http://www.r6rs.org/formal-comments/comment-187.txt). */
  1327. union scm_ieee754_float
  1328. {
  1329. float f;
  1330. uint32_t i;
  1331. };
  1332. union scm_ieee754_double
  1333. {
  1334. double d;
  1335. uint64_t i;
  1336. };
  1337. /* Convert to/from a floating-point number with different endianness. This
  1338. method is probably not the most efficient but it should be portable. */
  1339. static inline void
  1340. float_to_foreign_endianness (union scm_ieee754_float *target,
  1341. float source)
  1342. {
  1343. union scm_ieee754_float input;
  1344. input.f = source;
  1345. target->i = bswap_32 (input.i);
  1346. }
  1347. static inline float
  1348. float_from_foreign_endianness (const union scm_ieee754_float *source)
  1349. {
  1350. union scm_ieee754_float result;
  1351. result.i = bswap_32 (source->i);
  1352. return (result.f);
  1353. }
  1354. static inline void
  1355. double_to_foreign_endianness (union scm_ieee754_double *target,
  1356. double source)
  1357. {
  1358. union scm_ieee754_double input;
  1359. input.d = source;
  1360. target->i = bswap_64 (input.i);
  1361. }
  1362. static inline double
  1363. double_from_foreign_endianness (const union scm_ieee754_double *source)
  1364. {
  1365. union scm_ieee754_double result;
  1366. result.i = bswap_64 (source->i);
  1367. return (result.d);
  1368. }
  1369. /* Template macros to abstract over doubles and floats.
  1370. XXX: Guile can only convert to/from doubles. */
  1371. #define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
  1372. #define IEEE754_TO_SCM(_c_type) scm_from_double
  1373. #define IEEE754_FROM_SCM(_c_type) scm_to_double
  1374. #define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
  1375. _c_type ## _from_foreign_endianness
  1376. #define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
  1377. _c_type ## _to_foreign_endianness
  1378. /* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
  1379. #define VALIDATE_REAL(pos, v) \
  1380. do { \
  1381. SCM_ASSERT_TYPE (scm_is_real (v), v, pos, FUNC_NAME, "real"); \
  1382. } while (0)
  1383. /* Templace getters and setters. */
  1384. #define IEEE754_GETTER_PROLOGUE(_type) \
  1385. INTEGER_GETTER_PROLOGUE (sizeof (_type) << 3UL, signed);
  1386. #define IEEE754_SETTER_PROLOGUE(_type) \
  1387. INTEGER_SETTER_PROLOGUE (sizeof (_type) << 3UL, signed);
  1388. #define IEEE754_REF(_type) \
  1389. _type c_result; \
  1390. \
  1391. IEEE754_GETTER_PROLOGUE (_type); \
  1392. SCM_VALIDATE_SYMBOL (3, endianness); \
  1393. \
  1394. if (scm_is_eq (endianness, scm_i_native_endianness)) \
  1395. memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
  1396. else \
  1397. { \
  1398. IEEE754_UNION (_type) c_raw; \
  1399. \
  1400. memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
  1401. c_result = \
  1402. IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
  1403. } \
  1404. \
  1405. return (IEEE754_TO_SCM (_type) (c_result));
  1406. #define IEEE754_NATIVE_REF(_type) \
  1407. _type c_result; \
  1408. \
  1409. IEEE754_GETTER_PROLOGUE (_type); \
  1410. \
  1411. memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
  1412. return (IEEE754_TO_SCM (_type) (c_result));
  1413. #define IEEE754_SET(_type) \
  1414. _type c_value; \
  1415. \
  1416. IEEE754_SETTER_PROLOGUE (_type); \
  1417. VALIDATE_REAL (3, value); \
  1418. SCM_VALIDATE_SYMBOL (4, endianness); \
  1419. c_value = IEEE754_FROM_SCM (_type) (value); \
  1420. \
  1421. if (scm_is_eq (endianness, scm_i_native_endianness)) \
  1422. memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
  1423. else \
  1424. { \
  1425. IEEE754_UNION (_type) c_raw; \
  1426. \
  1427. IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
  1428. memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
  1429. } \
  1430. \
  1431. return SCM_UNSPECIFIED;
  1432. #define IEEE754_NATIVE_SET(_type) \
  1433. _type c_value; \
  1434. \
  1435. IEEE754_SETTER_PROLOGUE (_type); \
  1436. VALIDATE_REAL (3, value); \
  1437. c_value = IEEE754_FROM_SCM (_type) (value); \
  1438. \
  1439. memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
  1440. return SCM_UNSPECIFIED;
  1441. /* Single precision. */
  1442. SCM_DEFINE (scm_bytevector_ieee_single_ref,
  1443. "bytevector-ieee-single-ref",
  1444. 3, 0, 0,
  1445. (SCM bv, SCM index, SCM endianness),
  1446. "Return the IEEE-754 single from @var{bv} at "
  1447. "@var{index}.")
  1448. #define FUNC_NAME s_scm_bytevector_ieee_single_ref
  1449. {
  1450. IEEE754_REF (float);
  1451. }
  1452. #undef FUNC_NAME
  1453. SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
  1454. "bytevector-ieee-single-native-ref",
  1455. 2, 0, 0,
  1456. (SCM bv, SCM index),
  1457. "Return the IEEE-754 single from @var{bv} at "
  1458. "@var{index} using the native endianness.")
  1459. #define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
  1460. {
  1461. IEEE754_NATIVE_REF (float);
  1462. }
  1463. #undef FUNC_NAME
  1464. SCM_DEFINE (scm_bytevector_ieee_single_set_x,
  1465. "bytevector-ieee-single-set!",
  1466. 4, 0, 0,
  1467. (SCM bv, SCM index, SCM value, SCM endianness),
  1468. "Store real @var{value} in @var{bv} at @var{index} according to "
  1469. "@var{endianness}.")
  1470. #define FUNC_NAME s_scm_bytevector_ieee_single_set_x
  1471. {
  1472. IEEE754_SET (float);
  1473. }
  1474. #undef FUNC_NAME
  1475. SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
  1476. "bytevector-ieee-single-native-set!",
  1477. 3, 0, 0,
  1478. (SCM bv, SCM index, SCM value),
  1479. "Store the real @var{value} at index @var{index} "
  1480. "of @var{bv} using the native endianness.")
  1481. #define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
  1482. {
  1483. IEEE754_NATIVE_SET (float);
  1484. }
  1485. #undef FUNC_NAME
  1486. /* Double precision. */
  1487. SCM_DEFINE (scm_bytevector_ieee_double_ref,
  1488. "bytevector-ieee-double-ref",
  1489. 3, 0, 0,
  1490. (SCM bv, SCM index, SCM endianness),
  1491. "Return the IEEE-754 double from @var{bv} at "
  1492. "@var{index}.")
  1493. #define FUNC_NAME s_scm_bytevector_ieee_double_ref
  1494. {
  1495. IEEE754_REF (double);
  1496. }
  1497. #undef FUNC_NAME
  1498. SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
  1499. "bytevector-ieee-double-native-ref",
  1500. 2, 0, 0,
  1501. (SCM bv, SCM index),
  1502. "Return the IEEE-754 double from @var{bv} at "
  1503. "@var{index} using the native endianness.")
  1504. #define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
  1505. {
  1506. IEEE754_NATIVE_REF (double);
  1507. }
  1508. #undef FUNC_NAME
  1509. SCM_DEFINE (scm_bytevector_ieee_double_set_x,
  1510. "bytevector-ieee-double-set!",
  1511. 4, 0, 0,
  1512. (SCM bv, SCM index, SCM value, SCM endianness),
  1513. "Store real @var{value} in @var{bv} at @var{index} according to "
  1514. "@var{endianness}.")
  1515. #define FUNC_NAME s_scm_bytevector_ieee_double_set_x
  1516. {
  1517. IEEE754_SET (double);
  1518. }
  1519. #undef FUNC_NAME
  1520. SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
  1521. "bytevector-ieee-double-native-set!",
  1522. 3, 0, 0,
  1523. (SCM bv, SCM index, SCM value),
  1524. "Store the real @var{value} at index @var{index} "
  1525. "of @var{bv} using the native endianness.")
  1526. #define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
  1527. {
  1528. IEEE754_NATIVE_SET (double);
  1529. }
  1530. #undef FUNC_NAME
  1531. #undef IEEE754_UNION
  1532. #undef IEEE754_TO_SCM
  1533. #undef IEEE754_FROM_SCM
  1534. #undef IEEE754_FROM_FOREIGN_ENDIANNESS
  1535. #undef IEEE754_TO_FOREIGN_ENDIANNESS
  1536. #undef IEEE754_REF
  1537. #undef IEEE754_NATIVE_REF
  1538. #undef IEEE754_SET
  1539. #undef IEEE754_NATIVE_SET
  1540. /* Operations on strings. */
  1541. /* Produce a function that returns the length of a UTF-encoded string. */
  1542. #define UTF_STRLEN_FUNCTION(_utf_width) \
  1543. static inline size_t \
  1544. utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
  1545. { \
  1546. size_t len = 0; \
  1547. const uint ## _utf_width ## _t *ptr; \
  1548. for (ptr = str; \
  1549. *ptr != 0; \
  1550. ptr++) \
  1551. { \
  1552. len++; \
  1553. } \
  1554. \
  1555. return (len * ((_utf_width) / 8)); \
  1556. }
  1557. UTF_STRLEN_FUNCTION (8)
  1558. /* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
  1559. #define UTF_STRLEN(_utf_width, _str) \
  1560. utf ## _utf_width ## _strlen (_str)
  1561. /* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
  1562. ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
  1563. encoding name). */
  1564. static inline void
  1565. utf_encoding_name (char *name, size_t utf_width, SCM endianness)
  1566. {
  1567. strcpy (name, "UTF-");
  1568. strcat (name, ((utf_width == 8)
  1569. ? "8"
  1570. : ((utf_width == 16)
  1571. ? "16"
  1572. : ((utf_width == 32)
  1573. ? "32"
  1574. : "??"))));
  1575. strcat (name,
  1576. ((scm_is_eq (endianness, sym_big))
  1577. ? "BE"
  1578. : ((scm_is_eq (endianness, sym_little))
  1579. ? "LE"
  1580. : "unknown")));
  1581. }
  1582. /* Maximum length of a UTF encoding name. */
  1583. #define MAX_UTF_ENCODING_NAME_LEN 16
  1584. /* Produce the body of a `string->utf' function. */
  1585. #define STRING_TO_UTF(_utf_width) \
  1586. SCM utf; \
  1587. int err; \
  1588. char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
  1589. char *c_utf = NULL; \
  1590. size_t c_strlen, c_utf_len = 0; \
  1591. \
  1592. SCM_VALIDATE_STRING (1, str); \
  1593. if (scm_is_eq (endianness, SCM_UNDEFINED)) \
  1594. endianness = sym_big; \
  1595. else \
  1596. SCM_VALIDATE_SYMBOL (2, endianness); \
  1597. \
  1598. utf_encoding_name (c_utf_name, (_utf_width), endianness); \
  1599. \
  1600. c_strlen = scm_i_string_length (str); \
  1601. if (scm_i_is_narrow_string (str)) \
  1602. { \
  1603. err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
  1604. "ISO-8859-1", c_utf_name, \
  1605. iconveh_question_mark, NULL, \
  1606. &c_utf, &c_utf_len); \
  1607. if (SCM_UNLIKELY (err)) \
  1608. scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
  1609. scm_list_1 (str), err); \
  1610. } \
  1611. else \
  1612. { \
  1613. const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
  1614. c_utf = u32_conv_to_encoding (c_utf_name, \
  1615. iconveh_question_mark, \
  1616. (uint32_t *) wbuf, \
  1617. c_strlen, NULL, NULL, &c_utf_len); \
  1618. if (SCM_UNLIKELY (c_utf == NULL)) \
  1619. scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
  1620. scm_list_1 (str), errno); \
  1621. } \
  1622. scm_dynwind_begin (0); \
  1623. scm_dynwind_free (c_utf); \
  1624. utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
  1625. memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
  1626. scm_dynwind_end (); \
  1627. \
  1628. return (utf);
  1629. SCM_DEFINE (scm_string_to_utf8, "string->utf8",
  1630. 1, 0, 0,
  1631. (SCM str),
  1632. "Return a newly allocated bytevector that contains the UTF-8 "
  1633. "encoding of @var{str}.")
  1634. #define FUNC_NAME s_scm_string_to_utf8
  1635. {
  1636. SCM utf;
  1637. uint8_t *c_utf;
  1638. size_t c_utf_len = 0;
  1639. SCM_VALIDATE_STRING (1, str);
  1640. c_utf = (uint8_t *) scm_to_utf8_stringn (str, &c_utf_len);
  1641. utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
  1642. memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
  1643. free (c_utf);
  1644. return (utf);
  1645. }
  1646. #undef FUNC_NAME
  1647. SCM_DEFINE (scm_string_to_utf16, "string->utf16",
  1648. 1, 1, 0,
  1649. (SCM str, SCM endianness),
  1650. "Return a newly allocated bytevector that contains the UTF-16 "
  1651. "encoding of @var{str}.")
  1652. #define FUNC_NAME s_scm_string_to_utf16
  1653. {
  1654. STRING_TO_UTF (16);
  1655. }
  1656. #undef FUNC_NAME
  1657. static void
  1658. swap_u32 (scm_t_wchar *vals, size_t len)
  1659. {
  1660. size_t n;
  1661. for (n = 0; n < len; n++)
  1662. vals[n] = bswap_32 (vals[n]);
  1663. }
  1664. SCM_DEFINE (scm_string_to_utf32, "string->utf32",
  1665. 1, 1, 0,
  1666. (SCM str, SCM endianness),
  1667. "Return a newly allocated bytevector that contains the UTF-32 "
  1668. "encoding of @var{str}.")
  1669. #define FUNC_NAME s_scm_string_to_utf32
  1670. {
  1671. SCM bv;
  1672. scm_t_wchar *wchars;
  1673. size_t wchar_len, bytes_len;
  1674. wchars = scm_to_utf32_stringn (str, &wchar_len);
  1675. bytes_len = wchar_len * sizeof (scm_t_wchar);
  1676. if (!scm_is_eq (SCM_UNBNDP (endianness) ? scm_endianness_big : endianness,
  1677. scm_i_native_endianness))
  1678. swap_u32 (wchars, wchar_len);
  1679. bv = make_bytevector (bytes_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
  1680. memcpy (SCM_BYTEVECTOR_CONTENTS (bv), wchars, bytes_len);
  1681. free (wchars);
  1682. return bv;
  1683. }
  1684. #undef FUNC_NAME
  1685. /* Produce the body of a function that converts a UTF-encoded bytevector to a
  1686. string. */
  1687. #define UTF_TO_STRING(_utf_width) \
  1688. SCM str = SCM_BOOL_F; \
  1689. int err; \
  1690. char *c_str = NULL; \
  1691. char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
  1692. char *c_utf; \
  1693. size_t c_strlen = 0, c_utf_len = 0; \
  1694. \
  1695. SCM_VALIDATE_BYTEVECTOR (1, utf); \
  1696. if (scm_is_eq (endianness, SCM_UNDEFINED)) \
  1697. endianness = sym_big; \
  1698. else \
  1699. SCM_VALIDATE_SYMBOL (2, endianness); \
  1700. \
  1701. c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
  1702. c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
  1703. utf_encoding_name (c_utf_name, (_utf_width), endianness); \
  1704. \
  1705. err = mem_iconveh (c_utf, c_utf_len, \
  1706. c_utf_name, "UTF-8", \
  1707. iconveh_question_mark, NULL, \
  1708. &c_str, &c_strlen); \
  1709. if (SCM_UNLIKELY (err)) \
  1710. scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
  1711. scm_list_1 (utf), err); \
  1712. else \
  1713. { \
  1714. str = scm_from_utf8_stringn (c_str, c_strlen); \
  1715. free (c_str); \
  1716. } \
  1717. return (str);
  1718. SCM_DEFINE (scm_utf8_to_string, "utf8->string",
  1719. 1, 0, 0,
  1720. (SCM utf),
  1721. "Return a newly allocate string that contains from the UTF-8-"
  1722. "encoded contents of bytevector @var{utf}.")
  1723. #define FUNC_NAME s_scm_utf8_to_string
  1724. {
  1725. SCM str;
  1726. const char *c_utf;
  1727. size_t c_utf_len = 0;
  1728. SCM_VALIDATE_BYTEVECTOR (1, utf);
  1729. c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
  1730. c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
  1731. str = scm_from_utf8_stringn (c_utf, c_utf_len);
  1732. return (str);
  1733. }
  1734. #undef FUNC_NAME
  1735. SCM_DEFINE (scm_utf16_to_string, "utf16->string",
  1736. 1, 1, 0,
  1737. (SCM utf, SCM endianness),
  1738. "Return a newly allocate string that contains from the UTF-16-"
  1739. "encoded contents of bytevector @var{utf}.")
  1740. #define FUNC_NAME s_scm_utf16_to_string
  1741. {
  1742. UTF_TO_STRING (16);
  1743. }
  1744. #undef FUNC_NAME
  1745. SCM_DEFINE (scm_utf32_to_string, "utf32->string",
  1746. 1, 1, 0,
  1747. (SCM utf, SCM endianness),
  1748. "Return a newly allocate string that contains from the UTF-32-"
  1749. "encoded contents of bytevector @var{utf}.")
  1750. #define FUNC_NAME s_scm_utf32_to_string
  1751. {
  1752. UTF_TO_STRING (32);
  1753. }
  1754. #undef FUNC_NAME
  1755. /* Initialization. */
  1756. void
  1757. scm_bootstrap_bytevectors (void)
  1758. {
  1759. /* This must be instantiated here because the generalized-vector API may
  1760. want to access bytevectors even though `(rnrs bytevectors)' hasn't been
  1761. loaded. */
  1762. scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
  1763. scm_endianness_big = sym_big = scm_from_latin1_symbol ("big");
  1764. scm_endianness_little = sym_little = scm_from_latin1_symbol ("little");
  1765. #ifdef WORDS_BIGENDIAN
  1766. scm_i_native_endianness = sym_big;
  1767. #else
  1768. scm_i_native_endianness = sym_little;
  1769. #endif
  1770. scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
  1771. "scm_init_bytevectors",
  1772. (scm_t_extension_init_func) scm_init_bytevectors,
  1773. NULL);
  1774. }
  1775. void
  1776. scm_init_bytevectors (void)
  1777. {
  1778. #include "bytevectors.x"
  1779. }