Author: kzk
Date: Sat Aug 13 01:37:43 2005
New Revision: 1195
Modified:
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* sigscheme/sigscheme.c
- implement char-upcase and char-downcase
* sigscheme.sigscheme.h
- implement char-upcase and char-downcase
* sigscheme/operations.c
- (ScmOp_string_to_number): add check for digit character
- (ScmOp_char_upcase, ScmOp_char_downcase): new func
- (ScmOp_make_string): fill string with space when no fill character
is specified.
Modified: branches/r5rs/sigscheme/operations.c
==============================================================================
--- branches/r5rs/sigscheme/operations.c (original)
+++ branches/r5rs/sigscheme/operations.c Sat Aug 13 01:37:43 2005
@@ -190,7 +190,7 @@
{
return SCM_FALSE;
}
-
+
/* check dot pair */
if (!SCM_CONSP(SCM_CDR(obj1)))
{
@@ -274,14 +274,14 @@
return Scm_NewInt(0);
if (!SCM_INTP(obj1))
- SigScm_ErrorObj("+ : integer required but got ", obj1);
+ SigScm_ErrorObj("+ : integer required but got ", obj1);
if (SCM_NULLP(obj2))
return Scm_NewInt(SCM_INT_VALUE(obj1));
if (!SCM_INTP(obj2))
SigScm_ErrorObj("+ : integer required but got ", obj2);
-
+
return Scm_NewInt(SCM_INT_VALUE(obj1) + SCM_INT_VALUE(obj2));
}
@@ -295,7 +295,7 @@
if (!SCM_INTP(obj2))
SigScm_ErrorObj("- : integer required but got ", obj2);
-
+
return Scm_NewInt(SCM_INT_VALUE(obj1) - SCM_INT_VALUE(obj2));
}
@@ -714,9 +714,20 @@
/* TODO : support radix */
ScmObj ScmOp_string_to_number(ScmObj string)
{
+ char *str = NULL;
+ char *p = NULL;
+ size_t len = 0;
+
if (!SCM_STRINGP(string))
SigScm_ErrorObj("string->number : string required but got ", string);
+ str = SCM_STRING_STR(string);
+ len = strlen(str);
+ for (p = str; p < str + len; p++) {
+ if (isdigit(*p) == 0)
+ return SCM_FALSE;
+ }
+
return Scm_NewInt((int)atof(SCM_STRING_STR(string)));
}
@@ -972,7 +983,7 @@
if (SCM_NULLP(obj)) break;
if (!SCM_CONSP(obj)) return -1;
if (len != 0 && obj == slow) return -1; /* circular */
-
+
obj = SCM_CDR(obj);
len++;
if (SCM_NULLP(obj)) break;
@@ -1311,6 +1322,36 @@
return SCM_FALSE;
}
+ScmObj ScmOp_char_upcase(ScmObj obj)
+{
+ if (!SCM_CHARP(obj))
+ SigScm_ErrorObj("char-upcase : char required but got ", obj);
+
+ /* check multibyte */
+ if (strlen(SCM_CHAR_CH(obj)) != 1)
+ return obj;
+
+ /* to upcase */
+ SCM_CHAR_CH(obj)[0] = toupper(SCM_CHAR_CH(obj)[0]);
+
+ return obj;
+}
+
+ScmObj ScmOp_char_downcase(ScmObj obj)
+{
+ if (!SCM_CHARP(obj))
+ SigScm_ErrorObj("char-upcase : char required but got ", obj);
+
+ /* check multibyte */
+ if (strlen(SCM_CHAR_CH(obj)) != 1)
+ return obj;
+
+ /* to upcase */
+ SCM_CHAR_CH(obj)[0] = tolower(SCM_CHAR_CH(obj)[0]);
+
+ return obj;
+}
+
/*==============================================================================
R5RS : 6.3 Other data types : 6.3.5 Strings
==============================================================================*/
@@ -1326,9 +1367,11 @@
{
int argc = SCM_INT_VALUE(ScmOp_length(arg));
int len = 0;
+ char *tmp = NULL;
ScmObj str = SCM_NIL;
ScmObj ch = SCM_NIL;
+ /* sanity check */
if (argc != 1 && argc != 2)
SigScm_Error("make-string : invalid use\n");
if (!SCM_INTP(SCM_CAR(arg)))
@@ -1336,14 +1379,27 @@
if (argc == 2 && !SCM_CHARP(SCM_CAR(SCM_CDR(arg))))
SigScm_ErrorObj("make-string : character required but got ",
SCM_CAR(SCM_CDR(arg)));
+ /* get length */
len = SCM_INT_VALUE(SCM_CAR(arg));
if (len == 0)
return Scm_NewStringCopying("");
- if (argc == 1)
- return Scm_NewString_With_StrLen(NULL, len);
+ /* specify filler */
+ if (argc == 1) {
+ /* specify length only, so fill string with space(' ') */
+ tmp = (char*)malloc(sizeof(char) * (1 + 1));
+ tmp[0] = ' ';
+ tmp[1] = '\0';
+ ch = Scm_NewChar(tmp);
+ } else {
+ /* also specify filler char */
+ ch = SCM_CAR(SCM_CDR(arg));
+ }
+
+ /* make string */
str = Scm_NewString_With_StrLen(NULL, len);
- ch = SCM_CAR(SCM_CDR(arg));
+
+ /* and fill! */
ScmOp_string_fill(str, ch);
return str;
@@ -1893,9 +1949,9 @@
if (!SCM_CLOSUREP(proc))
SigScm_ErrorObj("call-with-current-continuation : closure required but
got ", proc);
-
+
cont = Scm_NewContinuation();
-
+
/* setjmp and check result */
jmpret = setjmp(SCM_CONTINUATION_JMPENV(cont));
if (jmpret) {
Modified: branches/r5rs/sigscheme/sigscheme.c
==============================================================================
--- branches/r5rs/sigscheme/sigscheme.c (original)
+++ branches/r5rs/sigscheme/sigscheme.c Sat Aug 13 01:37:43 2005
@@ -217,6 +217,8 @@
Scm_RegisterFunc1("char-whitespace?" , ScmOp_char_whitespacep);
Scm_RegisterFunc1("char-upper-case?" , ScmOp_char_upper_casep);
Scm_RegisterFunc1("char-lower-case?" , ScmOp_char_lower_casep);
+ Scm_RegisterFunc1("char-upcase" , ScmOp_char_upcase);
+ Scm_RegisterFunc1("char-downcase" , ScmOp_char_downcase);
Scm_RegisterFunc1("string?" , ScmOp_stringp);
Scm_RegisterFuncL("make-string" , ScmOp_make_string);
Scm_RegisterFuncL("string" , ScmOp_string);
Modified: branches/r5rs/sigscheme/sigscheme.h
==============================================================================
--- branches/r5rs/sigscheme/sigscheme.h (original)
+++ branches/r5rs/sigscheme/sigscheme.h Sat Aug 13 01:37:43 2005
@@ -253,6 +253,8 @@
ScmObj ScmOp_char_whitespacep(ScmObj obj);
ScmObj ScmOp_char_upper_casep(ScmObj obj);
ScmObj ScmOp_char_lower_casep(ScmObj obj);
+ScmObj ScmOp_char_upcase(ScmObj obj);
+ScmObj ScmOp_char_downcase(ScmObj obj);
ScmObj ScmOp_stringp(ScmObj obj);
ScmObj ScmOp_make_string(ScmObj arg, ScmObj env);
