12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147 |
- /* Copyright 2001,2004,2006-2007,2009,2011,2018-2019,2022
- Free Software Foundation, Inc.
- This file is part of Guile.
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
- Guile is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
- License for more details.
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <stdio.h>
- #include <string.h>
- #include <unictype.h>
- #include "boolean.h"
- #include "chars.h"
- #include "eval.h"
- #include "gsubr.h"
- #include "list.h"
- #include "modules.h"
- #include "numbers.h"
- #include "pairs.h"
- #include "ports.h"
- #include "procs.h"
- #include "smob.h"
- #include "strings.h"
- #include "symbols.h"
- #include "values.h"
- #include "srfi-14.h"
- /* Include the pre-computed standard charset data. */
- #include "srfi-14.i.c"
- static const scm_t_bits SCM_CHARSET_F_IMMUTABLE = 1 << 16;
- static inline int
- scm_charset_is_immutable (SCM charset)
- {
- return SCM_SMOB_DATA_0 (charset) & SCM_CHARSET_F_IMMUTABLE;
- }
- #define SCM_VALIDATE_MUTABLE_CHARSET(pos, x) \
- do { \
- SCM_ASSERT_TYPE (SCM_CHARSETP (x) && !scm_charset_is_immutable (x), \
- x, pos, FUNC_NAME, "mutable charset"); \
- } while (0)
- static const scm_t_char_range cs_full_ranges[] = {
- {0x0000, SCM_CODEPOINT_SURROGATE_START - 1},
- {SCM_CODEPOINT_SURROGATE_END + 1, SCM_CODEPOINT_MAX}
- };
- static const size_t cs_full_len = 2;
- #define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
- #define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
- #define SCM_CHARSET_SET(cs, idx) \
- scm_i_charset_set (SCM_CHARSET_DATA (cs), idx)
- #define SCM_CHARSET_UNSET(cs, idx) \
- scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx)
- /* Smob type code for character sets. */
- int scm_tc16_charset = 0;
- int scm_tc16_charset_cursor = 0;
- /* True if N exists in charset CS. */
- int
- scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n)
- {
- size_t i;
- i = 0;
- while (i < cs->len)
- {
- if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
- return 1;
- i++;
- }
- return 0;
- }
- /* Put N into charset CS. */
- void
- scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
- {
- size_t i;
- size_t len;
- len = cs->len;
- i = 0;
- while (i < len)
- {
- /* Already in this range */
- if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
- {
- return;
- }
- if (n == cs->ranges[i].lo - 1)
- {
- /* This char is one below the current range. */
- if (i > 0 && cs->ranges[i - 1].hi + 1 == n)
- {
- /* It is also one above the previous range. */
- /* This is an impossible condition: in the previous
- iteration, the test for 'one above the current range'
- should already have inserted the character here. */
- abort ();
- }
- else
- {
- /* Expand the range down by one. */
- cs->ranges[i].lo = n;
- return;
- }
- }
- else if (n == cs->ranges[i].hi + 1)
- {
- /* This char is one above the current range. */
- if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n)
- {
- /* It is also one below the next range, so combine them. */
- cs->ranges[i].hi = cs->ranges[i + 1].hi;
- if (i < len - 2)
- memmove (cs->ranges + (i + 1), cs->ranges + (i + 2),
- sizeof (scm_t_char_range) * (len - i - 2));
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len -
- 1),
- "character-set");
- cs->len = len - 1;
- return;
- }
- else
- {
- /* Expand the range up by one. */
- cs->ranges[i].hi = n;
- return;
- }
- }
- else if (n < cs->ranges[i].lo - 1)
- {
- /* This is a new range below the current one. */
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len + 1),
- "character-set");
- memmove (cs->ranges + (i + 1), cs->ranges + i,
- sizeof (scm_t_char_range) * (len - i));
- cs->ranges[i].lo = n;
- cs->ranges[i].hi = n;
- cs->len = len + 1;
- return;
- }
- i++;
- }
- /* This is a new range above all previous ranges. */
- if (len == 0)
- {
- cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
- }
- else
- {
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len + 1),
- "character-set");
- }
- cs->ranges[len].lo = n;
- cs->ranges[len].hi = n;
- cs->len = len + 1;
- return;
- }
- /* Put LO to HI inclusive into charset CS. */
- static void
- scm_i_charset_set_range (scm_t_char_set *cs, scm_t_wchar lo, scm_t_wchar hi)
- {
- size_t i;
- i = 0;
- while (i < cs->len)
- {
- /* Already in this range */
- if (cs->ranges[i].lo <= lo && cs->ranges[i].hi >= hi)
- return;
- /* cur: +---+
- new: +---+
- */
- if (cs->ranges[i].lo - 1 > hi)
- {
- /* Add a new range below the current one. */
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * cs->len,
- sizeof (scm_t_char_range) * (cs->len + 1),
- "character-set");
- memmove (cs->ranges + (i + 1), cs->ranges + i,
- sizeof (scm_t_char_range) * (cs->len - i));
- cs->ranges[i].lo = lo;
- cs->ranges[i].hi = hi;
- cs->len += 1;
- return;
- }
- /* cur: +---+ or +---+ or +---+
- new: +---+ +---+ +---+
- */
- if (cs->ranges[i].lo > lo
- && (cs->ranges[i].lo - 1 <= hi && cs->ranges[i].hi >= hi))
- {
- cs->ranges[i].lo = lo;
- return;
- }
- /* cur: +---+ or +---+ or +---+
- new: +---+ +---+ +---+
- */
- else if (cs->ranges[i].hi + 1 >= lo && cs->ranges[i].hi < hi)
- {
- if (cs->ranges[i].lo > lo)
- cs->ranges[i].lo = lo;
- if (cs->ranges[i].hi < hi)
- cs->ranges[i].hi = hi;
- while (i < cs->len - 1)
- {
- /* cur: --+ +---+
- new: -----+
- */
- if (cs->ranges[i + 1].lo - 1 > hi)
- break;
-
- /* cur: --+ +---+ or --+ +---+ or --+ +--+
- new: -----+ ------+ ---------+
- */
- /* Combine this range with the previous one. */
- if (cs->ranges[i + 1].hi > hi)
- cs->ranges[i].hi = cs->ranges[i + 1].hi;
- if (i + 1 < cs->len)
- memmove (cs->ranges + i + 1, cs->ranges + i + 2,
- sizeof (scm_t_char_range) * (cs->len - i - 2));
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * cs->len,
- sizeof (scm_t_char_range) * (cs->len - 1),
- "character-set");
- cs->len -= 1;
- }
- return;
- }
- i ++;
- }
- /* This is a new range above all previous ranges. */
- if (cs->len == 0)
- {
- cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
- }
- else
- {
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * cs->len,
- sizeof (scm_t_char_range) * (cs->len + 1),
- "character-set");
- }
- cs->len += 1;
- cs->ranges[cs->len - 1].lo = lo;
- cs->ranges[cs->len - 1].hi = hi;
- return;
- }
- /* If N is in charset CS, remove it. */
- void
- scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
- {
- size_t i;
- size_t len;
- len = cs->len;
- i = 0;
- while (i < len)
- {
- if (n < cs->ranges[i].lo)
- /* Not in this set. */
- return;
- if (n == cs->ranges[i].lo && n == cs->ranges[i].hi)
- {
- /* Remove this one-character range. */
- if (len == 1)
- {
- scm_gc_free (cs->ranges,
- sizeof (scm_t_char_range) * cs->len,
- "character-set");
- cs->ranges = NULL;
- cs->len = 0;
- return;
- }
- else if (i < len - 1)
- {
- memmove (cs->ranges + i, cs->ranges + (i + 1),
- sizeof (scm_t_char_range) * (len - i - 1));
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len -
- 1),
- "character-set");
- cs->len = len - 1;
- return;
- }
- else if (i == len - 1)
- {
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len -
- 1),
- "character-set");
- cs->len = len - 1;
- return;
- }
- }
- else if (n == cs->ranges[i].lo)
- {
- /* Shrink this range from the left. */
- cs->ranges[i].lo = n + 1;
- return;
- }
- else if (n == cs->ranges[i].hi)
- {
- /* Shrink this range from the right. */
- cs->ranges[i].hi = n - 1;
- return;
- }
- else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi)
- {
- /* Split this range into two pieces. */
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len + 1),
- "character-set");
- if (i < len - 1)
- memmove (cs->ranges + (i + 2), cs->ranges + (i + 1),
- sizeof (scm_t_char_range) * (len - i - 1));
- cs->ranges[i + 1].hi = cs->ranges[i].hi;
- cs->ranges[i + 1].lo = n + 1;
- cs->ranges[i].hi = n - 1;
- cs->len = len + 1;
- return;
- }
- i++;
- }
- /* This value is above all ranges, so do nothing here. */
- return;
- }
- static int
- charsets_equal (scm_t_char_set *a, scm_t_char_set *b)
- {
- if (a->len != b->len)
- return 0;
- /* Empty charsets may have ranges == NULL. We must avoid passing
- NULL to memcmp, even if the length is zero, to avoid undefined
- behavior. */
- if (a->len == 0)
- return 1;
- if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0)
- return 0;
- return 1;
- }
- /* Return true if every character in A is also in B. */
- static int
- charsets_leq (scm_t_char_set *a, scm_t_char_set *b)
- {
- size_t i = 0, j = 0;
- scm_t_wchar alo, ahi;
- if (a->len == 0)
- return 1;
- if (b->len == 0)
- return 0;
- while (i < a->len)
- {
- alo = a->ranges[i].lo;
- ahi = a->ranges[i].hi;
- while (b->ranges[j].hi < alo)
- {
- if (j < b->len - 1)
- j++;
- else
- return 0;
- }
- if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi)
- return 0;
- i++;
- }
- return 1;
- }
- /* Merge B into A. */
- static void
- charsets_union (scm_t_char_set *a, scm_t_char_set *b)
- {
- size_t i = 0;
- scm_t_wchar blo, bhi;
- if (b->len == 0)
- return;
- if (a->len == 0)
- {
- a->len = b->len;
- a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len,
- "character-set");
- memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len);
- return;
- }
- while (i < b->len)
- {
- blo = b->ranges[i].lo;
- bhi = b->ranges[i].hi;
- scm_i_charset_set_range (a, blo, bhi);
- i++;
- }
- return;
- }
- /* Remove elements not both in A and B from A. */
- static void
- charsets_intersection (scm_t_char_set *a, scm_t_char_set *b)
- {
- size_t i = 0;
- scm_t_wchar blo, bhi, n;
- scm_t_char_set *c;
- if (a->len == 0)
- return;
- if (b->len == 0)
- {
- scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
- "character-set");
- a->len = 0;
- return;
- }
- c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set));
- c->len = 0;
- c->ranges = NULL;
- while (i < b->len)
- {
- blo = b->ranges[i].lo;
- bhi = b->ranges[i].hi;
- for (n = blo; n <= bhi; n++)
- if (scm_i_charset_get (a, n))
- scm_i_charset_set (c, n);
- i++;
- }
- scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
- "character-set");
- a->len = c->len;
- if (c->len != 0)
- a->ranges = c->ranges;
- else
- a->ranges = NULL;
- free (c);
- return;
- }
- #define SCM_ADD_RANGE(low, high) \
- do { \
- p->ranges[idx].lo = (low); \
- p->ranges[idx++].hi = (high); \
- } while (0)
- #define SCM_ADD_RANGE_SKIP_SURROGATES(low, high) \
- do { \
- p->ranges[idx].lo = (low); \
- p->ranges[idx++].hi = SCM_CODEPOINT_SURROGATE_START - 1; \
- p->ranges[idx].lo = SCM_CODEPOINT_SURROGATE_END + 1; \
- p->ranges[idx++].hi = (high); \
- } while (0)
- /* Make P the compelement of Q. */
- static void
- charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
- {
- int k, idx;
- idx = 0;
- if (q->len == 0)
- {
- /* Fill with all valid codepoints. */
- p->len = 2;
- p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2,
- "character-set");
- SCM_ADD_RANGE_SKIP_SURROGATES (0, SCM_CODEPOINT_MAX);
- return;
- }
- if (p->len > 0)
- scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
- "character-set");
- /* Count the number of ranges needed for the output. */
- p->len = 0;
- if (q->ranges[0].lo > 0)
- p->len++;
- if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
- p->len++;
- p->len += q->len;
- p->ranges =
- (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len,
- "character-set");
- if (q->ranges[0].lo > 0)
- {
- if (q->ranges[0].lo > SCM_CODEPOINT_SURROGATE_END)
- SCM_ADD_RANGE_SKIP_SURROGATES (0, q->ranges[0].lo - 1);
- else
- SCM_ADD_RANGE (0, q->ranges[0].lo - 1);
- }
- for (k = 1; k < q->len; k++)
- {
- if (q->ranges[k - 1].hi < SCM_CODEPOINT_SURROGATE_START
- && q->ranges[k].lo - 1 > SCM_CODEPOINT_SURROGATE_END)
- SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
- else
- SCM_ADD_RANGE (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
- }
- if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
- {
- if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_SURROGATE_START)
- SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
- else
- SCM_ADD_RANGE (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
- }
- return;
- }
- #undef SCM_ADD_RANGE
- #undef SCM_ADD_RANGE_SKIP_SURROGATES
- /* Replace A with elements only found in one of A or B. */
- static void
- charsets_xor (scm_t_char_set *a, scm_t_char_set *b)
- {
- size_t i = 0;
- scm_t_wchar blo, bhi, n;
- if (b->len == 0)
- {
- return;
- }
- if (a->len == 0)
- {
- a->ranges =
- (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) *
- b->len, "character-set");
- a->len = b->len;
- memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len);
- return;
- }
- while (i < b->len)
- {
- blo = b->ranges[i].lo;
- bhi = b->ranges[i].hi;
- for (n = blo; n <= bhi; n++)
- {
- if (scm_i_charset_get (a, n))
- scm_i_charset_unset (a, n);
- else
- scm_i_charset_set (a, n);
- }
- i++;
- }
- return;
- }
- /* Smob print hook for character sets. */
- static int
- charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
- {
- size_t i;
- int first = 1;
- scm_t_char_set *p;
- const size_t max_ranges_to_print = 50;
- p = SCM_CHARSET_DATA (charset);
- scm_puts ("#<charset {", port);
- for (i = 0; i < p->len; i++)
- {
- if (first)
- first = 0;
- else
- scm_puts (" ", port);
- scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
- if (p->ranges[i].lo != p->ranges[i].hi)
- {
- scm_puts ("..", port);
- scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
- }
- if (i >= max_ranges_to_print)
- {
- /* Too many to print here. Quit early. */
- scm_puts (" ...", port);
- break;
- }
- }
- scm_puts ("}>", port);
- return 1;
- }
- /* Smob print hook for character sets cursors. */
- static int
- charset_cursor_print (SCM cursor, SCM port,
- scm_print_state *pstate SCM_UNUSED)
- {
- scm_t_char_set_cursor *cur;
- cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- scm_puts ("#<charset-cursor ", port);
- if (cur->range == (size_t) (-1))
- scm_puts ("(empty)", port);
- else
- {
- scm_write (scm_from_size_t (cur->range), port);
- scm_puts (":", port);
- scm_write (scm_from_int32 (cur->n), port);
- }
- scm_puts (">", port);
- return 1;
- }
- /* Create a new, empty character set. */
- static SCM
- make_char_set (const char *func_name)
- {
- scm_t_char_set *p;
- p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set");
- memset (p, 0, sizeof (scm_t_char_set));
- SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
- }
- SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
- "otherwise.")
- #define FUNC_NAME s_scm_char_set_p
- {
- return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
- (SCM char_sets),
- "Return @code{#t} if all given character sets are equal.")
- #define FUNC_NAME s_scm_char_set_eq
- {
- int argnum = 1;
- scm_t_char_set *cs1_data = NULL;
- SCM_VALIDATE_REST_ARGUMENT (char_sets);
- while (!scm_is_null (char_sets))
- {
- SCM csi = SCM_CAR (char_sets);
- scm_t_char_set *csi_data;
- SCM_VALIDATE_SMOB (argnum, csi, charset);
- argnum++;
- csi_data = SCM_CHARSET_DATA (csi);
- if (cs1_data == NULL)
- cs1_data = csi_data;
- else if (!charsets_equal (cs1_data, csi_data))
- return SCM_BOOL_F;
- char_sets = SCM_CDR (char_sets);
- }
- return SCM_BOOL_T;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
- (SCM char_sets),
- "Return @code{#t} if every character set @var{char_set}i is a subset\n"
- "of character set @var{char_set}i+1.")
- #define FUNC_NAME s_scm_char_set_leq
- {
- int argnum = 1;
- scm_t_char_set *prev_data = NULL;
- SCM_VALIDATE_REST_ARGUMENT (char_sets);
- while (!scm_is_null (char_sets))
- {
- SCM csi = SCM_CAR (char_sets);
- scm_t_char_set *csi_data;
- SCM_VALIDATE_SMOB (argnum, csi, charset);
- argnum++;
- csi_data = SCM_CHARSET_DATA (csi);
- if (prev_data)
- {
- if (!charsets_leq (prev_data, csi_data))
- return SCM_BOOL_F;
- }
- prev_data = csi_data;
- char_sets = SCM_CDR (char_sets);
- }
- return SCM_BOOL_T;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
- (SCM cs, SCM bound),
- "Compute a hash value for the character set @var{cs}. If\n"
- "@var{bound} is given and non-zero, it restricts the\n"
- "returned value to the range 0 @dots{} @var{bound} - 1.")
- #define FUNC_NAME s_scm_char_set_hash
- {
- const unsigned long default_bnd = 871;
- unsigned long bnd;
- scm_t_char_set *p;
- unsigned long val = 0;
- int k;
- scm_t_wchar c;
- SCM_VALIDATE_SMOB (1, cs, charset);
- if (SCM_UNBNDP (bound))
- bnd = default_bnd;
- else
- {
- bnd = scm_to_ulong (bound);
- if (bnd == 0)
- bnd = default_bnd;
- }
- p = SCM_CHARSET_DATA (cs);
- for (k = 0; k < p->len; k++)
- {
- for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++)
- val = c + (val << 1);
- }
- return scm_from_ulong (val % bnd);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
- (SCM cs), "Return a cursor into the character set @var{cs}.")
- #define FUNC_NAME s_scm_char_set_cursor
- {
- scm_t_char_set *cs_data;
- scm_t_char_set_cursor *cur_data;
- SCM_VALIDATE_SMOB (1, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- cur_data =
- (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor),
- "charset-cursor");
- if (cs_data->len == 0)
- {
- cur_data->range = (size_t) (-1);
- cur_data->n = 0;
- }
- else
- {
- cur_data->range = 0;
- cur_data->n = cs_data->ranges[0].lo;
- }
- SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
- (SCM cs, SCM cursor),
- "Return the character at the current cursor position\n"
- "@var{cursor} in the character set @var{cs}. It is an error to\n"
- "pass a cursor for which @code{end-of-char-set?} returns true.")
- #define FUNC_NAME s_scm_char_set_ref
- {
- scm_t_char_set *cs_data;
- scm_t_char_set_cursor *cur_data;
- size_t i;
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
- cs_data = SCM_CHARSET_DATA (cs);
- cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- /* Validate that this cursor is still true. */
- i = cur_data->range;
- if (i == (size_t) (-1)
- || i >= cs_data->len
- || cur_data->n < cs_data->ranges[i].lo
- || cur_data->n > cs_data->ranges[i].hi)
- SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
- return SCM_MAKE_CHAR (cur_data->n);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
- (SCM cs, SCM cursor),
- "Advance the character set cursor @var{cursor} to the next\n"
- "character in the character set @var{cs}. It is an error if the\n"
- "cursor given satisfies @code{end-of-char-set?}.")
- #define FUNC_NAME s_scm_char_set_cursor_next
- {
- scm_t_char_set *cs_data;
- scm_t_char_set_cursor *cur_data;
- size_t i;
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
- cs_data = SCM_CHARSET_DATA (cs);
- cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- /* Validate that this cursor is still true. */
- i = cur_data->range;
- if (i == (size_t) (-1)
- || i >= cs_data->len
- || cur_data->n < cs_data->ranges[i].lo
- || cur_data->n > cs_data->ranges[i].hi)
- SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
- /* Increment the cursor. */
- if (cur_data->n == cs_data->ranges[i].hi)
- {
- if (i + 1 < cs_data->len)
- {
- cur_data->range = i + 1;
- cur_data->n = cs_data->ranges[i + 1].lo;
- }
- else
- {
- /* This is the end of the road. */
- cur_data->range = (size_t) (-1);
- cur_data->n = 0;
- }
- }
- else
- {
- cur_data->n = cur_data->n + 1;
- }
- return cursor;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
- (SCM cursor),
- "Return @code{#t} if @var{cursor} has reached the end of a\n"
- "character set, @code{#f} otherwise.")
- #define FUNC_NAME s_scm_end_of_char_set_p
- {
- scm_t_char_set_cursor *cur_data;
- SCM_VALIDATE_SMOB (1, cursor, charset_cursor);
- cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- if (cur_data->range == (size_t) (-1))
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
- (SCM kons, SCM knil, SCM cs),
- "Fold the procedure @var{kons} over the character set @var{cs},\n"
- "initializing it with @var{knil}.")
- #define FUNC_NAME s_scm_char_set_fold
- {
- scm_t_char_set *cs_data;
- int k;
- scm_t_wchar n;
- SCM_VALIDATE_PROC (1, kons);
- SCM_VALIDATE_SMOB (3, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return knil;
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil);
- }
- return knil;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
- (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
- "This is a fundamental constructor for character sets.\n"
- "@itemize @bullet\n"
- "@item @var{g} is used to generate a series of ``seed'' values\n"
- "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
- "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
- "@item @var{p} tells us when to stop -- when it returns true\n"
- "when applied to one of the seed values.\n"
- "@item @var{f} maps each seed value to a character. These\n"
- "characters are added to the base character set @var{base_cs} to\n"
- "form the result; @var{base_cs} defaults to the empty set.\n"
- "@end itemize")
- #define FUNC_NAME s_scm_char_set_unfold
- {
- SCM result, tmp;
- SCM_VALIDATE_PROC (1, p);
- SCM_VALIDATE_PROC (2, f);
- SCM_VALIDATE_PROC (3, g);
- if (!SCM_UNBNDP (base_cs))
- {
- SCM_VALIDATE_SMOB (5, base_cs, charset);
- result = scm_char_set_copy (base_cs);
- }
- else
- result = make_char_set (FUNC_NAME);
- tmp = scm_call_1 (p, seed);
- while (scm_is_false (tmp))
- {
- SCM ch = scm_call_1 (f, seed);
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- SCM_CHARSET_SET (result, SCM_CHAR (ch));
- seed = scm_call_1 (g, seed);
- tmp = scm_call_1 (p, seed);
- }
- return result;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
- (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
- "This is a fundamental constructor for character sets.\n"
- "@itemize @bullet\n"
- "@item @var{g} is used to generate a series of ``seed'' values\n"
- "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
- "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
- "@item @var{p} tells us when to stop -- when it returns true\n"
- "when applied to one of the seed values.\n"
- "@item @var{f} maps each seed value to a character. These\n"
- "characters are added to the base character set @var{base_cs} to\n"
- "form the result; @var{base_cs} defaults to the empty set.\n"
- "@end itemize")
- #define FUNC_NAME s_scm_char_set_unfold_x
- {
- SCM tmp;
- SCM_VALIDATE_PROC (1, p);
- SCM_VALIDATE_PROC (2, f);
- SCM_VALIDATE_PROC (3, g);
- SCM_VALIDATE_MUTABLE_CHARSET (5, base_cs);
- tmp = scm_call_1 (p, seed);
- while (scm_is_false (tmp))
- {
- SCM ch = scm_call_1 (f, seed);
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
- seed = scm_call_1 (g, seed);
- tmp = scm_call_1 (p, seed);
- }
- return base_cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
- (SCM proc, SCM cs),
- "Apply @var{proc} to every character in the character set\n"
- "@var{cs}. The return value is not specified.")
- #define FUNC_NAME s_scm_char_set_for_each
- {
- scm_t_char_set *cs_data;
- int k;
- scm_t_wchar n;
- SCM_VALIDATE_PROC (1, proc);
- SCM_VALIDATE_SMOB (2, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return SCM_UNSPECIFIED;
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- scm_call_1 (proc, SCM_MAKE_CHAR (n));
- }
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
- (SCM proc, SCM cs),
- "Map the procedure @var{proc} over every character in @var{cs}.\n"
- "@var{proc} must be a character -> character procedure.")
- #define FUNC_NAME s_scm_char_set_map
- {
- SCM result;
- int k;
- scm_t_char_set *cs_data;
- scm_t_wchar n;
- SCM_VALIDATE_PROC (1, proc);
- SCM_VALIDATE_SMOB (2, cs, charset);
- result = make_char_set (FUNC_NAME);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return result;
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char",
- scm_list_1 (proc));
- SCM_CHARSET_SET (result, SCM_CHAR (ch));
- }
- return result;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
- (SCM cs),
- "Return a newly allocated character set containing all\n"
- "characters in @var{cs}.")
- #define FUNC_NAME s_scm_char_set_copy
- {
- SCM ret;
- scm_t_char_set *p1, *p2;
- SCM_VALIDATE_SMOB (1, cs, charset);
- ret = make_char_set (FUNC_NAME);
- p1 = SCM_CHARSET_DATA (cs);
- p2 = SCM_CHARSET_DATA (ret);
- p2->len = p1->len;
- if (p1->len == 0)
- p2->ranges = NULL;
- else
- {
- p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len,
- "character-set");
- memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len);
- }
- return ret;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
- (SCM rest),
- "Return a character set containing all given characters.")
- #define FUNC_NAME s_scm_char_set
- {
- SCM cs;
- int argnum = 1;
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs = make_char_set (FUNC_NAME);
- while (!scm_is_null (rest))
- {
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
- argnum++;
- rest = SCM_CDR (rest);
- SCM_CHARSET_SET (cs, c);
- }
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
- (SCM list, SCM base_cs),
- "Convert the character list @var{list} to a character set. If\n"
- "the character set @var{base_cs} is given, the character in this\n"
- "set are also included in the result.")
- #define FUNC_NAME s_scm_list_to_char_set
- {
- SCM cs;
- SCM_VALIDATE_LIST (1, list);
- if (SCM_UNBNDP (base_cs))
- cs = make_char_set (FUNC_NAME);
- else
- {
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
- }
- while (!scm_is_null (list))
- {
- SCM chr = SCM_CAR (list);
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (0, chr, c);
- list = SCM_CDR (list);
- SCM_CHARSET_SET (cs, c);
- }
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
- (SCM list, SCM base_cs),
- "Convert the character list @var{list} to a character set. The\n"
- "characters are added to @var{base_cs} and @var{base_cs} is\n"
- "returned.")
- #define FUNC_NAME s_scm_list_to_char_set_x
- {
- SCM_VALIDATE_LIST (1, list);
- SCM_VALIDATE_MUTABLE_CHARSET (2, base_cs);
- while (!scm_is_null (list))
- {
- SCM chr = SCM_CAR (list);
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (0, chr, c);
- list = SCM_CDR (list);
- SCM_CHARSET_SET (base_cs, c);
- }
- return base_cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
- (SCM str, SCM base_cs),
- "Convert the string @var{str} to a character set. If the\n"
- "character set @var{base_cs} is given, the characters in this\n"
- "set are also included in the result.")
- #define FUNC_NAME s_scm_string_to_char_set
- {
- SCM cs;
- size_t k = 0, len;
- SCM_VALIDATE_STRING (1, str);
- if (SCM_UNBNDP (base_cs))
- cs = make_char_set (FUNC_NAME);
- else
- {
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
- }
- len = scm_i_string_length (str);
- while (k < len)
- {
- scm_t_wchar c = scm_i_string_ref (str, k++);
- SCM_CHARSET_SET (cs, c);
- }
- scm_remember_upto_here_1 (str);
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
- (SCM str, SCM base_cs),
- "Convert the string @var{str} to a character set. The\n"
- "characters from the string are added to @var{base_cs}, and\n"
- "@var{base_cs} is returned.")
- #define FUNC_NAME s_scm_string_to_char_set_x
- {
- size_t k = 0, len;
- SCM_VALIDATE_STRING (1, str);
- SCM_VALIDATE_MUTABLE_CHARSET (2, base_cs);
- len = scm_i_string_length (str);
- while (k < len)
- {
- scm_t_wchar c = scm_i_string_ref (str, k++);
- SCM_CHARSET_SET (base_cs, c);
- }
- scm_remember_upto_here_1 (str);
- return base_cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
- (SCM pred, SCM cs, SCM base_cs),
- "Return a character set containing every character from @var{cs}\n"
- "so that it satisfies @var{pred}. If provided, the characters\n"
- "from @var{base_cs} are added to the result.")
- #define FUNC_NAME s_scm_char_set_filter
- {
- SCM ret;
- int k;
- scm_t_wchar n;
- scm_t_char_set *p;
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- if (!SCM_UNBNDP (base_cs))
- {
- SCM_VALIDATE_SMOB (3, base_cs, charset);
- ret = scm_char_set_copy (base_cs);
- }
- else
- ret = make_char_set (FUNC_NAME);
- p = SCM_CHARSET_DATA (cs);
- if (p->len == 0)
- return ret;
- for (k = 0; k < p->len; k++)
- for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
- if (scm_is_true (res))
- SCM_CHARSET_SET (ret, n);
- }
- return ret;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
- (SCM pred, SCM cs, SCM base_cs),
- "Return a character set containing every character from @var{cs}\n"
- "so that it satisfies @var{pred}. The characters are added to\n"
- "@var{base_cs} and @var{base_cs} is returned.")
- #define FUNC_NAME s_scm_char_set_filter_x
- {
- int k;
- scm_t_wchar n;
- scm_t_char_set *p;
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- SCM_VALIDATE_MUTABLE_CHARSET (3, base_cs);
- p = SCM_CHARSET_DATA (cs);
- if (p->len == 0)
- return base_cs;
- for (k = 0; k < p->len; k++)
- for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
- if (scm_is_true (res))
- SCM_CHARSET_SET (base_cs, n);
- }
- return base_cs;
- }
- #undef FUNC_NAME
- /* Return a character set containing all the characters from [LOWER,UPPER),
- giving range errors if ERROR, adding chars from BASE_CS, and recycling
- BASE_CS if REUSE is true. */
- static SCM
- scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
- SCM error, SCM base_cs, int reuse)
- {
- SCM cs;
- size_t clower, cupper;
- clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper) - 1;
- SCM_ASSERT_RANGE (2, upper, cupper >= clower);
- if (!SCM_UNBNDP (error))
- {
- if (scm_is_true (error))
- {
- SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
- SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
- if (clower < SCM_CODEPOINT_SURROGATE_START
- && cupper > SCM_CODEPOINT_SURROGATE_END)
- scm_error(scm_out_of_range_key,
- FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
- scm_list_2 (lower, upper), scm_list_1 (upper));
- }
- }
- if (SCM_UNBNDP (base_cs))
- cs = make_char_set (FUNC_NAME);
- else
- {
- if (reuse)
- {
- SCM_VALIDATE_MUTABLE_CHARSET (3, base_cs);
- cs = base_cs;
- }
- else
- {
- SCM_VALIDATE_SMOB (3, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
- }
- }
- if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
- && (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
- return cs;
- if (clower > SCM_CODEPOINT_MAX)
- clower = SCM_CODEPOINT_MAX;
- if (clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
- clower = SCM_CODEPOINT_SURROGATE_END + 1;
- if (cupper > SCM_CODEPOINT_MAX)
- cupper = SCM_CODEPOINT_MAX;
- if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
- cupper = SCM_CODEPOINT_SURROGATE_START - 1;
- if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
- {
- scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, SCM_CODEPOINT_SURROGATE_START - 1);
- scm_i_charset_set_range (SCM_CHARSET_DATA (cs), SCM_CODEPOINT_SURROGATE_END + 1, cupper);
- }
- else
- scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, cupper);
- return cs;
- }
- SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
- (SCM lower, SCM upper, SCM error, SCM base_cs),
- "Return a character set containing all characters whose\n"
- "character codes lie in the half-open range\n"
- "[@var{lower},@var{upper}).\n"
- "\n"
- "If @var{error} is a true value, an error is signaled if the\n"
- "specified range contains characters which are not valid\n"
- "Unicode code points. If @var{error} is @code{#f},\n"
- "these characters are silently left out of the resulting\n"
- "character set.\n"
- "\n"
- "The characters in @var{base_cs} are added to the result, if\n"
- "given.")
- #define FUNC_NAME s_scm_ucs_range_to_char_set
- {
- return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
- error, base_cs, 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
- (SCM lower, SCM upper, SCM error, SCM base_cs),
- "Return a character set containing all characters whose\n"
- "character codes lie in the half-open range\n"
- "[@var{lower},@var{upper}).\n"
- "\n"
- "If @var{error} is a true value, an error is signaled if the\n"
- "specified range contains characters which are not contained in\n"
- "the implemented character range. If @var{error} is @code{#f},\n"
- "these characters are silently left out of the resulting\n"
- "character set.\n"
- "\n"
- "The characters are added to @var{base_cs} and @var{base_cs} is\n"
- "returned.")
- #define FUNC_NAME s_scm_ucs_range_to_char_set_x
- {
- SCM_VALIDATE_SMOB (4, base_cs, charset);
- return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
- error, base_cs, 1);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0,
- (SCM x),
- "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.")
- #define FUNC_NAME s_scm_to_char_set
- {
- if (scm_is_string (x))
- return scm_string_to_char_set (x, SCM_UNDEFINED);
- else if (SCM_CHARP (x))
- return scm_char_set (scm_list_1 (x));
- else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x))
- return x;
- else
- scm_wrong_type_arg (NULL, 0, x);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
- (SCM cs),
- "Return the number of elements in character set @var{cs}.")
- #define FUNC_NAME s_scm_char_set_size
- {
- int k, count = 0;
- scm_t_char_set *cs_data;
- SCM_VALIDATE_SMOB (1, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return scm_from_int (0);
- for (k = 0; k < cs_data->len; k++)
- count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1;
- return scm_from_int (count);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
- (SCM pred, SCM cs),
- "Return the number of the elements int the character set\n"
- "@var{cs} which satisfy the predicate @var{pred}.")
- #define FUNC_NAME s_scm_char_set_count
- {
- int k, count = 0;
- scm_t_wchar n;
- scm_t_char_set *cs_data;
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return scm_from_int (0);
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
- if (scm_is_true (res))
- count++;
- }
- return SCM_I_MAKINUM (count);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
- (SCM cs),
- "Return a list containing the elements of the character set\n"
- "@var{cs}.")
- #define FUNC_NAME s_scm_char_set_to_list
- {
- int k;
- scm_t_wchar n;
- SCM result = SCM_EOL;
- scm_t_char_set *p;
- SCM_VALIDATE_SMOB (1, cs, charset);
- p = SCM_CHARSET_DATA (cs);
- if (p->len == 0)
- return SCM_EOL;
- for (k = p->len - 1; k >= 0; k--)
- for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--)
- result = scm_cons (SCM_MAKE_CHAR (n), result);
- return result;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
- (SCM cs),
- "Return a string containing the elements of the character set\n"
- "@var{cs}. The order in which the characters are placed in the\n"
- "string is not defined.")
- #define FUNC_NAME s_scm_char_set_to_string
- {
- int k;
- int count = 0;
- int idx = 0;
- int wide = 0;
- SCM result;
- scm_t_wchar n;
- scm_t_char_set *cs_data;
- char *buf;
- scm_t_wchar *wbuf;
- SCM_VALIDATE_SMOB (1, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return scm_nullstr;
- if (cs_data->ranges[cs_data->len - 1].hi > 255)
- wide = 1;
- count = scm_to_int (scm_char_set_size (cs));
- if (wide)
- result = scm_i_make_wide_string (count, &wbuf, 0);
- else
- result = scm_i_make_string (count, &buf, 0);
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- if (wide)
- wbuf[idx++] = n;
- else
- buf[idx++] = n;
- }
- return result;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
- (SCM cs, SCM ch),
- "Return @code{#t} iff the character @var{ch} is contained in the\n"
- "character set @var{cs}.")
- #define FUNC_NAME s_scm_char_set_contains_p
- {
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_CHAR (2, ch);
- return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch)));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
- (SCM pred, SCM cs),
- "Return a true value if every character in the character set\n"
- "@var{cs} satisfies the predicate @var{pred}.")
- #define FUNC_NAME s_scm_char_set_every
- {
- int k;
- scm_t_wchar n;
- SCM res = SCM_BOOL_T;
- scm_t_char_set *cs_data;
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return SCM_BOOL_T;
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
- if (scm_is_false (res))
- return res;
- }
- return SCM_BOOL_T;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
- (SCM pred, SCM cs),
- "Return a true value if any character in the character set\n"
- "@var{cs} satisfies the predicate @var{pred}.")
- #define FUNC_NAME s_scm_char_set_any
- {
- int k;
- scm_t_wchar n;
- scm_t_char_set *cs_data;
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- cs_data = SCM_CHARSET_DATA (cs);
- if (cs_data->len == 0)
- return SCM_BOOL_T;
- for (k = 0; k < cs_data->len; k++)
- for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
- if (scm_is_true (res))
- return res;
- }
- return SCM_BOOL_F;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
- (SCM cs, SCM rest),
- "Add all character arguments to the first argument, which must\n"
- "be a character set.")
- #define FUNC_NAME s_scm_char_set_adjoin
- {
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs = scm_char_set_copy (cs);
- while (!scm_is_null (rest))
- {
- SCM chr = SCM_CAR (rest);
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
- SCM_CHARSET_SET (cs, c);
- }
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
- (SCM cs, SCM rest),
- "Delete all character arguments from the first argument, which\n"
- "must be a character set.")
- #define FUNC_NAME s_scm_char_set_delete
- {
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs = scm_char_set_copy (cs);
- while (!scm_is_null (rest))
- {
- SCM chr = SCM_CAR (rest);
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
- SCM_CHARSET_UNSET (cs, c);
- }
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
- (SCM cs, SCM rest),
- "Add all character arguments to the first argument, which must\n"
- "be a character set.")
- #define FUNC_NAME s_scm_char_set_adjoin_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- while (!scm_is_null (rest))
- {
- SCM chr = SCM_CAR (rest);
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
- SCM_CHARSET_SET (cs, c);
- }
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
- (SCM cs, SCM rest),
- "Delete all character arguments from the first argument, which\n"
- "must be a character set.")
- #define FUNC_NAME s_scm_char_set_delete_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- while (!scm_is_null (rest))
- {
- SCM chr = SCM_CAR (rest);
- scm_t_wchar c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
- SCM_CHARSET_UNSET (cs, c);
- }
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
- (SCM cs), "Return the complement of the character set @var{cs}.")
- #define FUNC_NAME s_scm_char_set_complement
- {
- SCM res;
- scm_t_char_set *p, *q;
- SCM_VALIDATE_SMOB (1, cs, charset);
- res = make_char_set (FUNC_NAME);
- p = SCM_CHARSET_DATA (res);
- q = SCM_CHARSET_DATA (cs);
- charsets_complement (p, q);
- return res;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
- (SCM rest),
- "Return the union of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_union
- {
- int c = 1;
- SCM res;
- scm_t_char_set *p;
- SCM_VALIDATE_REST_ARGUMENT (rest);
- res = make_char_set (FUNC_NAME);
- p = SCM_CHARSET_DATA (res);
- while (!scm_is_null (rest))
- {
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
- charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs));
- }
- return res;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
- (SCM rest),
- "Return the intersection of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_intersection
- {
- SCM res;
- SCM_VALIDATE_REST_ARGUMENT (rest);
- if (scm_is_null (rest))
- res = make_char_set (FUNC_NAME);
- else
- {
- scm_t_char_set *p;
- int argnum = 2;
- res = scm_char_set_copy (SCM_CAR (rest));
- p = SCM_CHARSET_DATA (res);
- rest = SCM_CDR (rest);
- while (scm_is_pair (rest))
- {
- SCM cs = SCM_CAR (rest);
- scm_t_char_set *cs_data;
- SCM_VALIDATE_SMOB (argnum, cs, charset);
- argnum++;
- cs_data = SCM_CHARSET_DATA (cs);
- rest = SCM_CDR (rest);
- charsets_intersection (p, cs_data);
- }
- }
- return res;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_difference
- {
- int c = 2;
- SCM res, compl;
- scm_t_char_set *p, *q;
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- res = scm_char_set_copy (cs1);
- p = SCM_CHARSET_DATA (res);
- compl = make_char_set (FUNC_NAME);
- q = SCM_CHARSET_DATA (compl);
- while (!scm_is_null (rest))
- {
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
- charsets_complement (q, SCM_CHARSET_DATA (cs));
- charsets_intersection (p, q);
- }
- return res;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
- (SCM rest),
- "Return the exclusive-or of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_xor
- {
- SCM res;
- SCM_VALIDATE_REST_ARGUMENT (rest);
- if (scm_is_null (rest))
- res = make_char_set (FUNC_NAME);
- else
- {
- int argnum = 2;
- scm_t_char_set *p;
- res = scm_char_set_copy (SCM_CAR (rest));
- p = SCM_CHARSET_DATA (res);
- rest = SCM_CDR (rest);
- while (scm_is_pair (rest))
- {
- SCM cs = SCM_CAR (rest);
- scm_t_char_set *cs_data;
- SCM_VALIDATE_SMOB (argnum, cs, charset);
- argnum++;
- cs_data = SCM_CHARSET_DATA (cs);
- rest = SCM_CDR (rest);
- charsets_xor (p, cs_data);
- }
- }
- return res;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference and the intersection of all argument\n"
- "character sets.")
- #define FUNC_NAME s_scm_char_set_diff_plus_intersection
- {
- int c = 2;
- SCM res1, res2;
- scm_t_char_set *p, *q;
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- res1 = scm_char_set_copy (cs1);
- res2 = make_char_set (FUNC_NAME);
- p = SCM_CHARSET_DATA (res1);
- q = SCM_CHARSET_DATA (res2);
- while (!scm_is_null (rest))
- {
- SCM cs = SCM_CAR (rest);
- scm_t_char_set *r;
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- r = SCM_CHARSET_DATA (cs);
- charsets_union (q, r);
- charsets_intersection (p, r);
- rest = SCM_CDR (rest);
- }
- return scm_values_2 (res1, res2);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
- (SCM cs), "Return the complement of the character set @var{cs}.")
- #define FUNC_NAME s_scm_char_set_complement_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
- cs = scm_char_set_complement (cs);
- return cs;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the union of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_union_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs1 = scm_char_set_union (scm_cons (cs1, rest));
- return cs1;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the intersection of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_intersection_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
- return cs1;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_difference_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs1 = scm_char_set_difference (cs1, rest);
- return cs1;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the exclusive-or of all argument character sets.")
- #define FUNC_NAME s_scm_char_set_xor_x
- {
- SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
- /* a side-effecting variant should presumably give consistent results:
- (define a (char-set #\a))
- (char-set-xor a a a) -> char set #\a
- (char-set-xor! a a a) -> char set #\a
- */
- cs1 = scm_char_set_xor (scm_cons (cs1, rest));
- return cs1;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
- "char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2,
- SCM rest),
- "Return the difference and the intersection of all argument\n"
- "character sets.")
- #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
- {
- SCM diff, intersect;
- diff = scm_char_set_difference (cs1, scm_cons (cs2, rest));
- intersect =
- scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
- cs1 = diff;
- cs2 = intersect;
- return scm_values_2 (cs1, cs2);
- }
- #undef FUNC_NAME
- /* Standard character sets. */
- SCM scm_char_set_lower_case;
- SCM scm_char_set_upper_case;
- SCM scm_char_set_title_case;
- SCM scm_char_set_letter;
- SCM scm_char_set_digit;
- SCM scm_char_set_letter_and_digit;
- SCM scm_char_set_graphic;
- SCM scm_char_set_printing;
- SCM scm_char_set_whitespace;
- SCM scm_char_set_iso_control;
- SCM scm_char_set_punctuation;
- SCM scm_char_set_symbol;
- SCM scm_char_set_hex_digit;
- SCM scm_char_set_blank;
- SCM scm_char_set_ascii;
- SCM scm_char_set_empty;
- SCM scm_char_set_designated;
- SCM scm_char_set_full;
- /* Create an empty character set and return it after binding it to NAME. */
- static inline SCM
- define_charset (const char *name, size_t len, const scm_t_char_range *ranges)
- {
- SCM cs;
- scm_t_char_set *p = scm_gc_malloc_pointerless (sizeof (scm_t_char_set),
- "charset");
- p->len = len;
- /* Strip const qualifier but add immutable flag on SCM. */
- p->ranges = (scm_t_char_range *) ranges;
- SCM_NEWSMOB (cs, scm_tc16_charset | SCM_CHARSET_F_IMMUTABLE, p);
- scm_c_define (name, cs);
- return cs;
- }
- SCM_DEFINE (scm_sys_char_set_dump, "%char-set-dump", 1, 0, 0, (SCM charset),
- "Returns an association list containing debugging information\n"
- "for @var{charset}. The association list has the following entries."
- "@table @code\n"
- "@item char-set\n"
- "The char-set itself.\n"
- "@item len\n"
- "The number of character ranges the char-set contains\n"
- "@item ranges\n"
- "A list of lists where each sublist a range of code points\n"
- "and their associated characters"
- "@end table")
- #define FUNC_NAME s_scm_sys_char_set_dump
- {
- SCM e1, e2, e3;
- SCM ranges = SCM_EOL, elt;
- size_t i;
- scm_t_char_set *cs;
- char codepoint_string_lo[13], codepoint_string_hi[13];
- SCM_VALIDATE_SMOB (1, charset, charset);
- cs = SCM_CHARSET_DATA (charset);
- e1 = scm_cons (scm_from_latin1_symbol ("char-set"),
- charset);
- e2 = scm_cons (scm_from_latin1_symbol ("n"),
- scm_from_size_t (cs->len));
- for (i = 0; i < cs->len; i++)
- {
- if (cs->ranges[i].lo > 0xFFFF)
- sprintf (codepoint_string_lo, "U+%06x", cs->ranges[i].lo);
- else
- sprintf (codepoint_string_lo, "U+%04x", cs->ranges[i].lo);
- if (cs->ranges[i].hi > 0xFFFF)
- sprintf (codepoint_string_hi, "U+%06x", cs->ranges[i].hi);
- else
- sprintf (codepoint_string_hi, "U+%04x", cs->ranges[i].hi);
- elt = scm_list_4 (SCM_MAKE_CHAR (cs->ranges[i].lo),
- SCM_MAKE_CHAR (cs->ranges[i].hi),
- scm_from_locale_string (codepoint_string_lo),
- scm_from_locale_string (codepoint_string_hi));
- ranges = scm_append (scm_list_2 (ranges,
- scm_list_1 (elt)));
- }
- e3 = scm_cons (scm_from_latin1_symbol ("ranges"),
- ranges);
- return scm_list_3 (e1, e2, e3);
- }
- #undef FUNC_NAME
- #define DEFINE_CHARSET(name, stem) \
- define_charset ("char-set:" name, cs_##stem##_len, cs_##stem##_ranges)
- void
- scm_init_srfi_14 (void)
- {
- scm_tc16_charset = scm_make_smob_type ("character-set", 0);
- scm_set_smob_print (scm_tc16_charset, charset_print);
- scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0);
- scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print);
- scm_char_set_upper_case = DEFINE_CHARSET ("upper-case", upper_case);
- scm_char_set_lower_case = DEFINE_CHARSET ("lower-case", lower_case);
- scm_char_set_title_case = DEFINE_CHARSET ("title-case", title_case);
- scm_char_set_letter = DEFINE_CHARSET ("letter", letter);
- scm_char_set_digit = DEFINE_CHARSET ("digit", digit);
- scm_char_set_letter_and_digit = DEFINE_CHARSET ("letter+digit",
- letter_plus_digit);
- scm_char_set_graphic = DEFINE_CHARSET ("graphic", graphic);
- scm_char_set_printing = DEFINE_CHARSET ("printing", printing);
- scm_char_set_whitespace = DEFINE_CHARSET ("whitespace", whitespace);
- scm_char_set_iso_control = DEFINE_CHARSET ("iso-control", iso_control);
- scm_char_set_punctuation = DEFINE_CHARSET ("punctuation", punctuation);
- scm_char_set_symbol = DEFINE_CHARSET ("symbol", symbol);
- scm_char_set_hex_digit = DEFINE_CHARSET ("hex-digit", hex_digit);
- scm_char_set_blank = DEFINE_CHARSET ("blank", blank);
- scm_char_set_ascii = DEFINE_CHARSET ("ascii", ascii);
- scm_char_set_empty = DEFINE_CHARSET ("empty", empty);
- scm_char_set_designated = DEFINE_CHARSET ("designated", designated);
- scm_char_set_full = DEFINE_CHARSET ("full", full);
- #include "srfi-14.x"
- }
- /* End of srfi-14.c. */
|