Commit e7e1ebcc authored by Erick's avatar Erick

Added new primitives: char-foldcase, string-foldcase, string-foldcase!

parent 17425537
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 20-Dec-2003 23:23 (eg)
;;;; Last file update: 27-May-2011 23:16 (eg)
;;;; Last file update: 14-Aug-2011 12:51 (eg)
;;;;
(load "srfi.stk")
......@@ -70,6 +70,8 @@
(define elisp-rgxp (string->regexp "@end lisp"))
(define R4RS-rgxp (string->regexp "R4RS"))
(define R5RS-rgxp (string->regexp "R5RS"))
(define R6RS-rgxp (string->regexp "R6RS"))
(define R7RS-rgxp (string->regexp "R7RS"))
(define STklos-rgxp (string->regexp "STklos"))
(define linebrk-rgxp (string->regexp "@l"))
......@@ -104,10 +106,14 @@
(set! def (regexp-replace-all lisp-rgxp def ",(fontified-code ["))
(set! def (regexp-replace-all elisp-rgxp def "])"))
;; rewrite R5RS
(set! def (regexp-replace-all R5RS-rgxp def ",(rfive)"))
;; rewrite R4RS
(set! def (regexp-replace-all R4RS-rgxp def ",(rfour)"))
;; rewrite R5RS
(set! def (regexp-replace-all R5RS-rgxp def ",(rfive)"))
;; rewrite R6RS
(set! def (regexp-replace-all R6RS-rgxp def ",(rsix)"))
;; rewrite R5RS
(set! def (regexp-replace-all R7RS-rgxp def ",(rseven)"))
;; rewrite STklos
(set! def (regexp-replace-all STklos-rgxp def ",(stklos)"))
;; rewrite linebreak
......
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 7-Nov-2010 14:23 (eg)
;; Last file update: 14-Aug-2011 13:08 (eg)
;;
;; ======================================================================
......@@ -231,7 +231,8 @@ which is also shown in this table.])
(insertdoc 'char-ci>=?)
(insertdoc 'char-lower-case?)
(insertdoc 'integer->char)
(insertdoc 'char-downcase))
(insertdoc 'char-downcase)
(insertdoc 'char-foldcase))
;;;
......@@ -304,6 +305,10 @@ function listed below just don't need to load the full SRFI to be used])
(insertdoc 'string-titlecase)
(insertdoc 'string-titlecase!))
(p [These functions are inspired from R6RS and R7RS.])
(insertdoc 'string-foldcase)
(insertdoc 'string-foldcase!)
;;;
;;; VECTORS
......
;; ======================================================================
;;
;;
;; STklos Reference Manual
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;;
;; This program 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 General Public License for more details.
;;
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 10-Aug-2010 09:20 (eg)
;; Last file update: 14-Aug-2011 12:54 (eg)
;;
;; ======================================================================
(customize-environment!
(customize-environment!
(html :load "eg-web-book.ske")
(pdf :user-style "doc-style.tex"))
......@@ -34,6 +34,8 @@
(define (stk) (sc "STk"))
(define (rfour) (sc [R,(sup "4")RS]))
(define (rfive) (sc [R,(sup "5")RS]))
(define (rsix) (sc [R,(sup "6")RS]))
(define (rseven) (sc [R,(sup "7")RS]))
(define (srfi n) (bold (format "SRFI-~a" n)))
(define (TODO txt) (bold (color :bg "yellow" :fg "red" txt)) "")
(define (~) (symbol "nbs"))
......@@ -52,9 +54,9 @@
;;;
(read-database "../DOCDB")
(define *logo-for-tex*
(define *logo-for-tex*
(case *engine-type*
((tex)
((tex)
(! "\\position(7, 12){\\externalfigure[images/dice.png][frame=off,width=2cm]}"))
(else "")))
;;;
......@@ -68,7 +70,7 @@
"F-06903 Sophia Antipolis, Cedex"
"France"
*logo-for-tex*))
(linebreak 3)
[This document provides a complete list of procedures and special
forms implemented in version ,(bold *stklos-version*) of
......@@ -80,7 +82,7 @@ document.]
(skribe-include "intro.skb")
(skribe-include "expr.skb")
(skribe-include "progstruct.skb")
(skribe-include "progstruct.skb")
(skribe-include "stdproc.skb")
(skribe-include "regexp.skb")
(skribe-include "match.skb")
......
......@@ -2,7 +2,7 @@
*
* c h a r . c -- Chaacters management
*
* Copyright 1993-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -23,7 +23,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: ??????
* Last file update: 19-Jul-2011 20:12 (eg)
* Last file update: 14-Aug-2011 13:07 (eg)
*/
#include <ctype.h>
......@@ -92,6 +92,159 @@ static struct charelem chartable [] = {
};
static struct {
uint16_t ch;
uint16_t fold;
} casefold_table [] = {
{ 0xb5, 0x3bc }, /* µ -> μ */
{ 0x17f, 0x73 }, /* ſ -> s */
{ 0x345, 0x3b9 }, /* ͅ -> ι */
{ 0x3c2, 0x3c3 }, /* ς -> σ */
{ 0x3cf, 0x3d7 }, /* Ϗ -> ϗ */
{ 0x3d0, 0x3b2 }, /* ϐ -> β */
{ 0x3d1, 0x3b8 }, /* ϑ -> θ */
{ 0x3d5, 0x3c6 }, /* ϕ -> φ */
{ 0x3d6, 0x3c0 }, /* ϖ -> π */
{ 0x3f0, 0x3ba }, /* ϰ -> κ */
{ 0x3f1, 0x3c1 }, /* ϱ -> ρ */
{ 0x3f5, 0x3b5 }, /* ϵ -> ε */
{ 0x524, 0x525 }, /* Ԥ -> ԥ */
{ 0x526, 0x527 }, /* Ԧ -> ԧ */
{ 0x1e9b, 0x1e61 }, /* ẛ -> ṡ */
{ 0x1fbe, 0x3b9 }, /* ι -> ι */
{ 0x2c70, 0x252 }, /* Ɒ -> ɒ */
{ 0x2c7e, 0x23f }, /* Ȿ -> ȿ */
{ 0x2c7f, 0x240 }, /* Ɀ -> ɀ */
{ 0x2ceb, 0x2cec }, /* Ⳬ -> ⳬ */
{ 0x2ced, 0x2cee }, /* Ⳮ -> ⳮ */
{ 0xa640, 0xa641 }, /* Ꙁ -> ꙁ */
{ 0xa642, 0xa643 }, /* Ꙃ -> ꙃ */
{ 0xa644, 0xa645 }, /* Ꙅ -> ꙅ */
{ 0xa646, 0xa647 }, /* Ꙇ -> ꙇ */
{ 0xa648, 0xa649 }, /* Ꙉ -> ꙉ */
{ 0xa64a, 0xa64b }, /* Ꙋ -> ꙋ */
{ 0xa64c, 0xa64d }, /* Ꙍ -> ꙍ */
{ 0xa64e, 0xa64f }, /* Ꙏ -> ꙏ */
{ 0xa650, 0xa651 }, /* Ꙑ -> ꙑ */
{ 0xa652, 0xa653 }, /* Ꙓ -> ꙓ */
{ 0xa654, 0xa655 }, /* Ꙕ -> ꙕ */
{ 0xa656, 0xa657 }, /* Ꙗ -> ꙗ */
{ 0xa658, 0xa659 }, /* Ꙙ -> ꙙ */
{ 0xa65a, 0xa65b }, /* Ꙛ -> ꙛ */
{ 0xa65c, 0xa65d }, /* Ꙝ -> ꙝ */
{ 0xa65e, 0xa65f }, /* Ꙟ -> ꙟ */
{ 0xa660, 0xa661 }, /* Ꙡ -> ꙡ */
{ 0xa662, 0xa663 }, /* Ꙣ -> ꙣ */
{ 0xa664, 0xa665 }, /* Ꙥ -> ꙥ */
{ 0xa666, 0xa667 }, /* Ꙧ -> ꙧ */
{ 0xa668, 0xa669 }, /* Ꙩ -> ꙩ */
{ 0xa66a, 0xa66b }, /* Ꙫ -> ꙫ */
{ 0xa66c, 0xa66d }, /* Ꙭ -> ꙭ */
{ 0xa680, 0xa681 }, /* Ꚁ -> ꚁ */
{ 0xa682, 0xa683 }, /* Ꚃ -> ꚃ */
{ 0xa684, 0xa685 }, /* Ꚅ -> ꚅ */
{ 0xa686, 0xa687 }, /* Ꚇ -> ꚇ */
{ 0xa688, 0xa689 }, /* Ꚉ -> ꚉ */
{ 0xa68a, 0xa68b }, /* Ꚋ -> ꚋ */
{ 0xa68c, 0xa68d }, /* Ꚍ -> ꚍ */
{ 0xa68e, 0xa68f }, /* Ꚏ -> ꚏ */
{ 0xa690, 0xa691 }, /* Ꚑ -> ꚑ */
{ 0xa692, 0xa693 }, /* Ꚓ -> ꚓ */
{ 0xa694, 0xa695 }, /* Ꚕ -> ꚕ */
{ 0xa696, 0xa697 }, /* Ꚗ -> ꚗ */
{ 0xa722, 0xa723 }, /* Ꜣ -> ꜣ */
{ 0xa724, 0xa725 }, /* Ꜥ -> ꜥ */
{ 0xa726, 0xa727 }, /* Ꜧ -> ꜧ */
{ 0xa728, 0xa729 }, /* Ꜩ -> ꜩ */
{ 0xa72a, 0xa72b }, /* Ꜫ -> ꜫ */
{ 0xa72c, 0xa72d }, /* Ꜭ -> ꜭ */
{ 0xa72e, 0xa72f }, /* Ꜯ -> ꜯ */
{ 0xa732, 0xa733 }, /* Ꜳ -> ꜳ */
{ 0xa734, 0xa735 }, /* Ꜵ -> ꜵ */
{ 0xa736, 0xa737 }, /* Ꜷ -> ꜷ */
{ 0xa738, 0xa739 }, /* Ꜹ -> ꜹ */
{ 0xa73a, 0xa73b }, /* Ꜻ -> ꜻ */
{ 0xa73c, 0xa73d }, /* Ꜽ -> ꜽ */
{ 0xa73e, 0xa73f }, /* Ꜿ -> ꜿ */
{ 0xa740, 0xa741 }, /* Ꝁ -> ꝁ */
{ 0xa742, 0xa743 }, /* Ꝃ -> ꝃ */
{ 0xa744, 0xa745 }, /* Ꝅ -> ꝅ */
{ 0xa746, 0xa747 }, /* Ꝇ -> ꝇ */
{ 0xa748, 0xa749 }, /* Ꝉ -> ꝉ */
{ 0xa74a, 0xa74b }, /* Ꝋ -> ꝋ */
{ 0xa74c, 0xa74d }, /* Ꝍ -> ꝍ */
{ 0xa74e, 0xa74f }, /* Ꝏ -> ꝏ */
{ 0xa750, 0xa751 }, /* Ꝑ -> ꝑ */
{ 0xa752, 0xa753 }, /* Ꝓ -> ꝓ */
{ 0xa754, 0xa755 }, /* Ꝕ -> ꝕ */
{ 0xa756, 0xa757 }, /* Ꝗ -> ꝗ */
{ 0xa758, 0xa759 }, /* Ꝙ -> ꝙ */
{ 0xa75a, 0xa75b }, /* Ꝛ -> ꝛ */
{ 0xa75c, 0xa75d }, /* Ꝝ -> ꝝ */
{ 0xa75e, 0xa75f }, /* Ꝟ -> ꝟ */
{ 0xa760, 0xa761 }, /* Ꝡ -> ꝡ */
{ 0xa762, 0xa763 }, /* Ꝣ -> ꝣ */
{ 0xa764, 0xa765 }, /* Ꝥ -> ꝥ */
{ 0xa766, 0xa767 }, /* Ꝧ -> ꝧ */
{ 0xa768, 0xa769 }, /* Ꝩ -> ꝩ */
{ 0xa76a, 0xa76b }, /* Ꝫ -> ꝫ */
{ 0xa76c, 0xa76d }, /* Ꝭ -> ꝭ */
{ 0xa76e, 0xa76f }, /* Ꝯ -> ꝯ */
{ 0xa779, 0xa77a }, /* Ꝺ -> ꝺ */
{ 0xa77b, 0xa77c }, /* Ꝼ -> ꝼ */
{ 0xa77d, 0x1d79 }, /* Ᵹ -> ᵹ */
{ 0xa77e, 0xa77f }, /* Ꝿ -> ꝿ */
{ 0xa780, 0xa781 }, /* Ꞁ -> ꞁ */
{ 0xa782, 0xa783 }, /* Ꞃ -> ꞃ */
{ 0xa784, 0xa785 }, /* Ꞅ -> ꞅ */
{ 0xa786, 0xa787 }, /* Ꞇ -> ꞇ */
{ 0xa78b, 0xa78c }, /* Ꞌ -> ꞌ */
{ 0xa78d, 0x265 }, /* Ɥ -> ɥ */
{ 0xa790, 0xa791 }, /* Ꞑ -> ꞑ */
{ 0xa7a0, 0xa7a1 }, /* Ꞡ -> ꞡ */
{ 0xa7a2, 0xa7a3 }, /* Ꞣ -> ꞣ */
{ 0xa7a4, 0xa7a5 }, /* Ꞥ -> ꞥ */
{ 0xa7a6, 0xa7a7 }, /* Ꞧ -> ꞧ */
{ 0xa7a8, 0xa7a9 } /* Ꞩ -> ꞩ */
};
int STk_casefold_char(int ch)
{
static int min = -1, max= -1, len = -1;
if (len == -1) {
/* Never run before. Initialize static variables */
len = sizeof(casefold_table) / sizeof(casefold_table[0]);
min = casefold_table[0].ch;
max = casefold_table[len-1].ch;
}
if (min <= ch && ch <= max) {
/* seach the value in the casefold_table by dichotomy */
int left, right, i;
left = 0; right = len-1;
do {
i = (left + right) / 2;
if (ch == casefold_table[i].ch)
return casefold_table[i].fold;
else
if (ch < casefold_table[i].ch)
right = i -1;
else
left = i +1;
}
while (left <= right);
}
/* not found of not in the interval of special character => return the
* corresponding lowercase character
*/
return towlower(ch);
}
/*===========================================================================*\
*
* Utilities
......@@ -146,7 +299,7 @@ int STk_string2char(char *s)
}
char *STk_char2string(char c) /* convert a char to it's */
char *STk_char2string(int c) /* convert a character to it's */
{ /* external representation */
register struct charelem *p;
......@@ -308,7 +461,17 @@ DEFINE_PRIMITIVE("integer->char", integer2char, subr1, (SCM i))
{
int c = STk_integer_value(i);
if (c < 0 || c > MAX_CHAR_CODE) STk_error("bad integer ~S", i);
if (STk_use_utf8) {
/* Unicode defines characters in the range [0, #xd7FF] U [#xE000, #x10FFFF] */
if (! ((0 <= c && c <= 0xd7ff) || (0xE000 <=c && c <= 0x10FFFF)))
STk_error("bad integer ~S (must be in range [0, #xd7FF] U [#xE000, #x10FFFF]",
i);
}
else
/* Monobyte character: use them in the range [0, #xFF] */
if (! (0 <= c && c <= 0xff))
STk_error("bad integer ~S (must be in range [0, #xFF]", i);
return MAKE_CHARACTER(c);
}
......@@ -329,7 +492,7 @@ DEFINE_PRIMITIVE("char-upcase", char_upcase, subr1, (SCM c))
{
if (!CHARACTERP(c)) error_bad_char(c);
return MAKE_CHARACTER(STk_use_utf8 ?
towupper(CHARACTER_VAL(c)):
towupper(CHARACTER_VAL(c)):
toupper((unsigned char) CHARACTER_VAL(c)));
}
......@@ -337,9 +500,28 @@ DEFINE_PRIMITIVE("char-downcase", char_downcase, subr1, (SCM c))
{
if (!CHARACTERP(c)) error_bad_char(c);
return MAKE_CHARACTER(STk_use_utf8 ?
towlower(CHARACTER_VAL(c)) :
towlower(CHARACTER_VAL(c)) :
tolower((unsigned char) CHARACTER_VAL(c)));
}
/*
<doc char-foldcase
* (char-foldcase char)
*
* This procedure applies the Unicode simple case folding algorithm and returns
* the result. Note that language-sensitive folding is not used. If
* the argument is an uppercase letter, the result will be either a
* lowercase letter or the same as the argument if the lowercase letter
* does not exist.
doc>
*/
DEFINE_PRIMITIVE("char-foldcase", char_foldcase, subr1, (SCM c))
{
if (!CHARACTERP(c)) error_bad_char(c);
return MAKE_CHARACTER(STk_use_utf8 ?
STk_casefold_char(CHARACTER_VAL(c)):
tolower((unsigned char) CHARACTER_VAL(c)));
}
int STk_init_char(void)
{
......@@ -369,6 +551,7 @@ int STk_init_char(void)
ADD_PRIMITIVE(char_upcase);
ADD_PRIMITIVE(char_downcase);
ADD_PRIMITIVE(char_foldcase);
return TRUE;
}
......@@ -36,7 +36,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 17-Jan-1994 17:49
* Last file update: 27-Jul-2011 22:48 (eg)
* Last file update: 11-Aug-2011 23:38 (eg)
*/
#include "stklos.h"
......@@ -657,7 +657,7 @@ DEFINE_PRIMITIVE("hash-table-ref", hash_ref, subr23, (SCM ht, SCM key, SCM def))
/*
<doc EXT hash-table-ref/default
* (hash-table-ref/default hash key)
* (hash-table-ref/default hash key default)
*
* This function is equivalent to
* @lisp
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 19-Jul-2011 20:12 (eg)
* Last file update: 14-Aug-2011 12:28 (eg)
*/
......@@ -87,7 +87,6 @@ extern "C"
#endif
#define MAX_TOKEN_SIZE 1024 /* max size of a token */
#define MAX_CHAR_CODE 0x10FFFF /* Max code for a char */
#define CPP_CONCAT(x, y) x##y
......@@ -368,8 +367,9 @@ int STk_init_box(void);
#define CHARACTER_VAL(n) ((AS_LONG(n) >> 3))
#define CHARACTERP(n) ((AS_LONG(n) & 7) == 6)
char *STk_char2string(char c);
char *STk_char2string(int c);
int STk_string2char(char *s);
int STk_casefold_char(int ch);
int STk_init_char(void);
......
......@@ -22,13 +22,14 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??????
* Last file update: 10-Aug-2011 00:34 (eg)
* Last file update: 14-Aug-2011 12:32 (eg)
*/
#include <ctype.h>
#include <wctype.h>
#include "stklos.h"
/* min size added to a string when reallocated in a string-set! */
#define UTF8_STRING_INCR 8
......@@ -958,7 +959,8 @@ DEFINE_PRIMITIVE("string-mutable?", string_mutable, subr1, (SCM obj))
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("string-downcase", string_downcase, vsubr, (int argc, SCM *argv))
static SCM string_xxcase(int argc, SCM *argv, int (*toxx)(int),
wint_t (*towxx)(wint_t))
{
SCM s;
int start, end;
......@@ -971,7 +973,7 @@ DEFINE_PRIMITIVE("string-downcase", string_downcase, vsubr, (int argc, SCM *argv
char *startp = STk_utf8_index(STRING_CHARS(s), start, STRING_SIZE(s));
/* collect all characters in an allocated array of int and convert it */
wchars = string2int(startp, end-start, &len, towlower);
wchars = string2int(startp, end-start, &len, towxx);
return make_string_from_int_array(wchars, end-start, len);
} else {
......@@ -980,12 +982,18 @@ DEFINE_PRIMITIVE("string-downcase", string_downcase, vsubr, (int argc, SCM *argv
endp = STRING_CHARS(s) + end;
for (p=STRING_CHARS(s)+start, q=STRING_CHARS(z); p < endp; p++, q++)
*q = tolower(*p);
*q = toxx(*p);
return z;
}
}
DEFINE_PRIMITIVE("string-downcase", string_downcase, vsubr, (int argc, SCM *argv))
{
return string_xxcase(argc, *argv, tolower, towlower);
}
/*
<doc EXT string-downcase!
* (string-downcase! str)
......@@ -999,7 +1007,8 @@ DEFINE_PRIMITIVE("string-downcase", string_downcase, vsubr, (int argc, SCM *argv
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *argv))
static SCM string_dxxcase(int argc, SCM *argv, int (*toxx)(int),
wint_t (*towxx)(wint_t))
{
SCM s;
int i, start, end;
......@@ -1014,7 +1023,7 @@ DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *ar
char *endp = STk_utf8_index(STRING_CHARS(s), end, STRING_SIZE(s));
/* collect all characters in an allocated array of int and convert it */
wchars = string2int(startp, end-start, &len, towlower);
wchars = string2int(startp, end-start, &len, towxx);
if (len == endp-startp) {
copy_array(wchars, end-start, startp);
}
......@@ -1029,12 +1038,16 @@ DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *ar
} else { /* monobyte string */
char *p , *endp = STRING_CHARS(s) + end;
for (p=STRING_CHARS(s)+start; p < endp; p++) *p = tolower(*p);
for (p=STRING_CHARS(s)+start; p < endp; p++) *p = toxx(*p);
}
return STk_void;
}
DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *argv))
{
return string_dxxcase(argc, argv, tolower, towlower);
}
/*
<doc EXT string-upcase
......@@ -1042,7 +1055,7 @@ DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *ar
* (string-upcase str start)
* (string-upcase str start end)
*
* Returns a string in which the upper case letters of string |str| between the
* Returns a string in which the lower case letters of string |str| between the
* |start| and |end| indices have been replaced by their upper case equivalent.
* If |start| is omited, it defaults to 0. If |end| is omited, it defaults to
* the length of |str|.
......@@ -1050,33 +1063,9 @@ doc>
*/
DEFINE_PRIMITIVE("string-upcase", string_upcase, vsubr, (int argc, SCM *argv))
{
SCM s;
int start, end;
s = control_index(argc, argv, &start, &end);
if (STk_use_utf8 && !STRING_MONOBYTE(s)) {
uint32_t *wchars;
int len;
char *startp = STk_utf8_index(STRING_CHARS(s), start, STRING_SIZE(s));
/* collect all characters in an allocated array of int and convert it */
wchars = string2int(startp, end-start, &len, towupper);
return make_string_from_int_array(wchars, end-start, len);
} else {
char *endp, *p, *q;
SCM z = STk_makestring(end-start, NULL);
endp = STRING_CHARS(s) + end;
for (p=STRING_CHARS(s)+start, q=STRING_CHARS(z); p < endp; p++, q++)
*q = toupper(*p);
return z;
}
return string_xxcase(argc, argv, toupper, towupper);
}
/*
<doc EXT string-upcase!
* (string-upcase! str)
......@@ -1088,39 +1077,42 @@ doc>
*/
DEFINE_PRIMITIVE("string-upcase!", string_dupcase, vsubr, (int argc, SCM *argv))
{
SCM s;
int i, start, end;
return string_dxxcase(argc, argv, toupper, towupper);
}
s = control_index(argc, argv, &start, &end);
if (BOXED_INFO(s) & STRING_CONST) error_change_const_string(s);
if (STk_use_utf8 && !STRING_MONOBYTE(s)) { /* multibyte string */
uint32_t *wchars;
int len;
char *startp = STk_utf8_index(STRING_CHARS(s), start, STRING_SIZE(s));
char *endp = STk_utf8_index(STRING_CHARS(s), end, STRING_SIZE(s));
/*
<doc EXT string-foldcase
* (string-foldcase str)
* (string-foldcase str start)
* (string-foldcase str start end)
*
* Returns a string in which the Unicode simple case-folding algorithm has
* been applied on |str| between the |start| and |end| indices.
* If |start| is omited, it defaults to 0. If |end| is omited, it defaults to
* the length of |str|.
doc>
*/
DEFINE_PRIMITIVE("string-foldcase", string_foldcase, vsubr, (int argc, SCM *argv))
{
return string_xxcase(argc, argv, tolower, (wint_t (*) (wint_t))STk_casefold_char);
}
/* collect all characters in an allocated array of int and convert it */
wchars = string2int(startp, end-start, &len, towupper);
if (len == endp-startp) {
copy_array(wchars, end-start, startp);
}
else {
/* This code is inefficient, but it seems that that the converted case
character always use the same length encoding. It is likely that this
code is never used in practice
*/
for (i= start; i < end; i++)
STk_string_set(s, MAKE_INT(i), MAKE_CHARACTER(*wchars++));
}
} else { /* monobyte string */
char *p , *endp = STRING_CHARS(s) + end;
/*
<doc EXT string-foldcase!
* (string-foldcase! str)
* (string-foldcase! str start)
* (string-foldcase! str start end)
*
* This is the in-place side-effecting variant of |string-foldcase|.
doc>
*/
DEFINE_PRIMITIVE("string-foldcase!", string_dfoldcase, vsubr, (int argc, SCM *argv))
{
return string_dxxcase(argc, argv, toupper,(wint_t (*) (wint_t))STk_casefold_char);
}
for (p=STRING_CHARS(s)+start; p < endp; p++) *p = toupper(*p);
}
return STk_void;
}
/*
<doc EXT string-titlecase
......@@ -1325,6 +1317,8 @@ int STk_init_string(void)
ADD_PRIMITIVE(string_ddowncase);
ADD_PRIMITIVE(string_upcase);
ADD_PRIMITIVE(string_dupcase);
ADD_PRIMITIVE(string_foldcase);
ADD_PRIMITIVE(string_dfoldcase);
ADD_PRIMITIVE(string_titlecase);
ADD_PRIMITIVE(string_dtitlecase);
ADD_PRIMITIVE(string_blit);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment