libguile/strop.c

   1 /* classes: src_files */
   2
   3 /*      Copyright (C) 1994, 1996, 1997, 1999 Free Software Foundation, Inc.
   4
   5 This program is free software; you can redistribute it and/or modify
   6 it under the terms of the GNU General Public License as published by
   7 the Free Software Foundation; either version 2, or (at your option)
   8 any later version.
   9
  10 This program is distributed in the hope that it will be useful,
  11 but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 GNU General Public License for more details.
  14
  15 You should have received a copy of the GNU General Public License
  16 along with this software; see the file COPYING.  If not, write to the
  17 Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 02111-1307 USA */
  19
  20 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  21    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  22
  23
  24 \f
  25
  26 #include <stdio.h>
  27 #include "_scm.h"
  28 #include "chars.h"
  29
  30 #include "scm_validate.h"
  31 #include "strop.h"
  32 #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/
  33 \f
  34
  35
  36 /* implements index if direction > 0 otherwise rindex.  */
  37 static int
  38 scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start,
  39              SCM sub_end, const char *why)
  40 {
  41   unsigned char * p;
  42   int x;
  43   int lower;
  44   int upper;
  45   int ch;
  46
  47   SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, SCM_ARG1, why);
  48   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, why);
  49
  50   if (sub_start == SCM_BOOL_F)
  51     sub_start = SCM_MAKINUM (0);
  52
  53   SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why);
  54   lower = SCM_INUM (sub_start);
  55   if (lower < 0
  56       || lower > SCM_ROLENGTH (*str))
  57     scm_out_of_range (why, sub_start);
  58
  59   if (sub_end == SCM_BOOL_F)
  60     sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
  61
  62   SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why);
  63   upper = SCM_INUM (sub_end);
  64   if (upper < SCM_INUM (sub_start)
  65       || upper > SCM_ROLENGTH (*str))
  66     scm_out_of_range (why, sub_end);
  67
  68   if (direction > 0)
  69     {
  70       p = (unsigned char *)SCM_ROCHARS (*str) + lower;
  71       ch = SCM_ICHR (chr);
  72
  73       for (x = SCM_INUM (sub_start); x < upper; ++x, ++p)
  74         if (*p == ch)
  75           return x;
  76     }
  77   else
  78     {
  79       p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str);
  80       ch = SCM_ICHR (chr);
  81       for (x = upper - 1; x >= lower; --x, --p)
  82         if (*p == ch)
  83           return x;
  84     }
  85
  86   return -1;
  87 }
  88
  89 GUILE_PROC(scm_string_index, "string-index", 2, 2, 0,
  90            (SCM str, SCM chr, SCM frm, SCM to),
  91 "")
  92 #define FUNC_NAME s_scm_string_index
  93 {
  94   int pos;
  95
  96   if (frm == SCM_UNDEFINED)
  97     frm = SCM_BOOL_F;
  98   if (to == SCM_UNDEFINED)
  99     to = SCM_BOOL_F;
 100   pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME);
 101   return (pos < 0
 102           ? SCM_BOOL_F
 103           : SCM_MAKINUM (pos));
 104 }
 105 #undef FUNC_NAME
 106
 107 GUILE_PROC(scm_string_rindex, "string-rindex", 2, 2, 0,
 108            (SCM str, SCM chr, SCM frm, SCM to),
 109 "")
 110 #define FUNC_NAME s_scm_string_rindex
 111 {
 112   int pos;
 113
 114   if (frm == SCM_UNDEFINED)
 115     frm = SCM_BOOL_F;
 116   if (to == SCM_UNDEFINED)
 117     to = SCM_BOOL_F;
 118   pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME);
 119   return (pos < 0
 120           ? SCM_BOOL_F
 121           : SCM_MAKINUM (pos));
 122 }
 123 #undef FUNC_NAME
 124
 125
 126 SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
 127 SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
 128
 129
 130 GUILE_PROC(scm_substring_move_x, "substring-move!", 5, 0, 0,
 131            (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
 132            "")
 133 #define FUNC_NAME s_scm_substring_move_x
 134 {
 135   long s1, s2, e, len;
 136
 137   SCM_VALIDATE_STRING(1,str1);
 138   SCM_VALIDATE_INT_COPY(2,start1,s1);
 139   SCM_VALIDATE_INT_COPY(3,end1,e);
 140   SCM_VALIDATE_STRING(4,str2);
 141   SCM_VALIDATE_INT_COPY(5,start2,s2);
 142   len = e - s1;
 143   SCM_ASSERT_RANGE (3,end1,len >= 0);
 144   SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0);
 145   SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0);
 146   SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0);
 147   SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2));
 148
 149   SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])),
 150                       (void *)(&(SCM_CHARS(str1)[s1])),
 151                       len));
 152
 153   return scm_return_first(SCM_UNSPECIFIED, str1, str2);
 154 }
 155 #undef FUNC_NAME
 156
 157
 158 GUILE_PROC(scm_substring_fill_x, "substring-fill!", 4, 0, 0,
 159            (SCM str, SCM start, SCM end, SCM fill),
 160            "")
 161 #define FUNC_NAME s_scm_substring_fill_x
 162 {
 163   long i, e;
 164   char c;
 165   SCM_VALIDATE_STRING(1,str);
 166   SCM_VALIDATE_INT_COPY(2,start,i);
 167   SCM_VALIDATE_INT_COPY(3,end,e);
 168   SCM_VALIDATE_CHAR_COPY(4,fill,c);
 169   SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0);
 170   SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0);
 171   while (i<e) SCM_CHARS (str)[i++] = c;
 172   return SCM_UNSPECIFIED;
 173 }
 174 #undef FUNC_NAME
 175
 176
 177 GUILE_PROC(scm_string_null_p, "string-null?", 1, 0, 0,
 178            (SCM str),
 179 "")
 180 #define FUNC_NAME s_scm_string_null_p
 181 {
 182   SCM_VALIDATE_ROSTRING(1,str);
 183   return SCM_NEGATE_BOOL(SCM_ROLENGTH (str));
 184 }
 185 #undef FUNC_NAME
 186
 187
 188 GUILE_PROC(scm_string_to_list, "string->list", 1, 0, 0,
 189            (SCM str),
 190 "")
 191 #define FUNC_NAME s_scm_string_to_list
 192 {
 193   long i;
 194   SCM res = SCM_EOL;
 195   unsigned char *src;
 196   SCM_VALIDATE_ROSTRING(1,str);
 197   src = SCM_ROUCHARS (str);
 198   for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res);
 199   return res;
 200 }
 201 #undef FUNC_NAME
 202
 203
 204
 205 GUILE_PROC(scm_string_copy, "string-copy", 1, 0, 0,
 206            (SCM str),
 207 "")
 208 #define FUNC_NAME s_scm_string_copy
 209 {
 210   SCM_VALIDATE_STRINGORSUBSTR(1,str);
 211   return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0);
 212 }
 213 #undef FUNC_NAME
 214
 215
 216 GUILE_PROC(scm_string_fill_x, "string-fill!", 2, 0, 0,
 217            (SCM str, SCM chr),
 218 "")
 219 #define FUNC_NAME s_scm_string_fill_x
 220 {
 221   register char *dst, c;
 222   register long k;
 223   SCM_VALIDATE_STRING_COPY(1,str,dst);
 224   SCM_VALIDATE_CHAR_COPY(2,chr,c);
 225   for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
 226   return SCM_UNSPECIFIED;
 227 }
 228 #undef FUNC_NAME
 229
 230 GUILE_PROC(scm_string_upcase_x, "string-upcase!", 1, 0, 0,
 231            (SCM v),
 232 "")
 233 #define FUNC_NAME s_scm_string_upcase_x
 234 {
 235   register long k;
 236   register unsigned char *cs;
 237   SCM_ASRTGO (SCM_NIMP (v), badarg1);
 238   k = SCM_LENGTH (v);
 239   switch SCM_TYP7
 240     (v)
 241     {
 242     case scm_tc7_string:
 243       cs = SCM_UCHARS (v);
 244       while (k--)
 245         cs[k] = scm_upcase(cs[k]);
 246       break;
 247     default:
 248     badarg1:SCM_WTA (1,v);
 249     }
 250   return v;
 251 }
 252 #undef FUNC_NAME
 253
 254 GUILE_PROC(scm_string_upcase, "string-upcase", 1, 0, 0,
 255            (SCM str),
 256 "")
 257 #define FUNC_NAME s_scm_string_upcase
 258 {
 259   return scm_string_upcase_x(scm_string_copy(str));
 260 }
 261 #undef FUNC_NAME
 262
 263 GUILE_PROC(scm_string_downcase_x, "string-downcase!", 1, 0, 0,
 264            (SCM v),
 265 "")
 266 #define FUNC_NAME s_scm_string_downcase_x
 267 {
 268   register long k;
 269   register unsigned char *cs;
 270   SCM_ASRTGO (SCM_NIMP (v), badarg1);
 271   k = SCM_LENGTH (v);
 272   switch (SCM_TYP7(v))
 273     {
 274       case scm_tc7_string:
 275         cs = SCM_UCHARS (v);
 276         while (k--)
 277           cs[k] = scm_downcase(cs[k]);
 278         break;
 279       default:
 280     badarg1:SCM_WTA (1,v);
 281     }
 282   return v;
 283 }
 284 #undef FUNC_NAME
 285
 286 GUILE_PROC(scm_string_downcase, "string-downcase", 1, 0, 0,
 287            (SCM str),
 288 "")
 289 #define FUNC_NAME s_scm_string_downcase
 290 {
 291   SCM_VALIDATE_STRING(1,str);
 292   return scm_string_downcase_x(scm_string_copy(str));
 293 }
 294 #undef FUNC_NAME
 295
 296 GUILE_PROC(scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
 297            (SCM s),
 298 "")
 299 #define FUNC_NAME s_scm_string_capitalize_x
 300 {
 301   char *str;
 302   int i, len, in_word=0;
 303   SCM_VALIDATE_STRING(1,s);
 304   len = SCM_LENGTH(s);
 305   str = SCM_CHARS(s);
 306   for(i=0; i<len;  i++) {
 307     if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(str[i])))) {
 308       if(!in_word) {
 309         str[i] = scm_upcase(str[i]);
 310         in_word = 1;
 311       } else {
 312         str[i] = scm_downcase(str[i]);
 313       }
 314     }
 315     else in_word = 0;
 316   }
 317   return s;
 318 }
 319 #undef FUNC_NAME
 320
 321 GUILE_PROC(scm_string_capitalize, "string-capitalize", 1, 0, 0,
 322            (SCM s),
 323 "")
 324 #define FUNC_NAME s_scm_string_capitalize
 325 {
 326   SCM_VALIDATE_STRING(1,s);
 327   return scm_string_capitalize_x(scm_string_copy(s));
 328 }
 329 #undef FUNC_NAME
 330
 331 GUILE_PROC(scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 332            (SCM str),
 333 "")
 334 #define FUNC_NAME s_scm_string_ci_to_symbol
 335 {
 336   return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
 337                                ? scm_string_downcase(str)
 338                                : str);
 339 }
 340 #undef FUNC_NAME
 341
 342 void
 343 scm_init_strop ()
 344 {
 345 #include "strop.x"
 346 }