libguile/strorder.c

   1 /*      Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25 #include "libguile/chars.h"
  26 #include "libguile/strings.h"
  27 #include "libguile/symbols.h"
  28
  29 #include "libguile/validate.h"
  30 #include "libguile/strorder.h"
  31 #include "libguile/srfi-13.h"
  32 \f
  33
  34 SCM_C_INLINE_KEYWORD static SCM
  35 srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM, SCM, SCM))
  36 {
  37   if (scm_is_true (cmp (s1, s2,
  38                         SCM_UNDEFINED, SCM_UNDEFINED,
  39                         SCM_UNDEFINED, SCM_UNDEFINED)))
  40     return SCM_BOOL_T;
  41   else
  42     return SCM_BOOL_F;
  43 }
  44
  45 SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
  46             (SCM s1, SCM s2, SCM rest),
  47             "Lexicographic equality predicate; return @code{#t} if the two\n"
  48             "strings are the same length and contain the same characters in\n"
  49             "the same positions, otherwise return @code{#f}.\n"
  50             "\n"
  51             "The procedure @code{string-ci=?} treats upper and lower case\n"
  52             "letters as though they were the same character, but\n"
  53             "@code{string=?} treats upper and lower case as distinct\n"
  54             "characters.")
  55 #define FUNC_NAME s_scm_i_string_equal_p
  56 {
  57   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
  58     return SCM_BOOL_T;
  59   while (!scm_is_null (rest))
  60     {
  61       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq)))
  62         return SCM_BOOL_F;
  63       s1 = s2;
  64       s2 = scm_car (rest);
  65       rest = scm_cdr (rest);
  66     }
  67   return srfi13_cmp (s1, s2, scm_string_eq);
  68 }
  69 #undef FUNC_NAME
  70
  71 SCM scm_string_equal_p (SCM s1, SCM s2)
  72 #define FUNC_NAME s_scm_i_string_equal_p
  73 {
  74   return srfi13_cmp (s1, s2, scm_string_eq);
  75 }
  76 #undef FUNC_NAME
  77
  78 SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
  79             (SCM s1, SCM s2, SCM rest),
  80             "Case-insensitive string equality predicate; return @code{#t} if\n"
  81             "the two strings are the same length and their component\n"
  82             "characters match (ignoring case) at each position; otherwise\n"
  83             "return @code{#f}.")
  84 #define FUNC_NAME s_scm_i_string_ci_equal_p
  85 {
  86   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
  87     return SCM_BOOL_T;
  88   while (!scm_is_null (rest))
  89     {
  90       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq)))
  91         return SCM_BOOL_F;
  92       s1 = s2;
  93       s2 = scm_car (rest);
  94       rest = scm_cdr (rest);
  95     }
  96   return srfi13_cmp (s1, s2, scm_string_ci_eq);
  97 }
  98 #undef FUNC_NAME
  99
 100 SCM scm_string_ci_equal_p (SCM s1, SCM s2)
 101 #define FUNC_NAME s_scm_i_string_ci_equal_p
 102 {
 103   return srfi13_cmp (s1, s2, scm_string_ci_eq);
 104 }
 105 #undef FUNC_NAME
 106
 107 SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
 108             (SCM s1, SCM s2, SCM rest),
 109             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 110             "is lexicographically less than @var{s2}.")
 111 #define FUNC_NAME s_scm_i_string_less_p
 112 {
 113   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 114     return SCM_BOOL_T;
 115   while (!scm_is_null (rest))
 116     {
 117       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt)))
 118         return SCM_BOOL_F;
 119       s1 = s2;
 120       s2 = scm_car (rest);
 121       rest = scm_cdr (rest);
 122     }
 123   return srfi13_cmp (s1, s2, scm_string_lt);
 124 }
 125 #undef FUNC_NAME
 126
 127 SCM scm_string_less_p (SCM s1, SCM s2)
 128 #define FUNC_NAME s_scm_i_string_less_p
 129 {
 130   return srfi13_cmp (s1, s2, scm_string_lt);
 131 }
 132 #undef FUNC_NAME
 133
 134 SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
 135             (SCM s1, SCM s2, SCM rest),
 136             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 137             "is lexicographically less than or equal to @var{s2}.")
 138 #define FUNC_NAME s_scm_i_string_leq_p
 139 {
 140   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 141     return SCM_BOOL_T;
 142   while (!scm_is_null (rest))
 143     {
 144       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le)))
 145         return SCM_BOOL_F;
 146       s1 = s2;
 147       s2 = scm_car (rest);
 148       rest = scm_cdr (rest);
 149     }
 150   return srfi13_cmp (s1, s2, scm_string_le);
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM scm_string_leq_p (SCM s1, SCM s2)
 155 #define FUNC_NAME s_scm_i_string_leq_p
 156 {
 157   return srfi13_cmp (s1, s2, scm_string_le);
 158 }
 159 #undef FUNC_NAME
 160
 161 SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
 162             (SCM s1, SCM s2, SCM rest),
 163             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 164             "is lexicographically greater than @var{s2}.")
 165 #define FUNC_NAME s_scm_i_string_gr_p
 166 {
 167   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 168     return SCM_BOOL_T;
 169   while (!scm_is_null (rest))
 170     {
 171       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt)))
 172         return SCM_BOOL_F;
 173       s1 = s2;
 174       s2 = scm_car (rest);
 175       rest = scm_cdr (rest);
 176     }
 177   return srfi13_cmp (s1, s2, scm_string_gt);
 178 }
 179 #undef FUNC_NAME
 180
 181 SCM scm_string_gr_p (SCM s1, SCM s2)
 182 #define FUNC_NAME s_scm_i_string_gr_p
 183 {
 184   return srfi13_cmp (s1, s2, scm_string_gt);
 185 }
 186 #undef FUNC_NAME
 187
 188 SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
 189             (SCM s1, SCM s2, SCM rest),
 190             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 191             "is lexicographically greater than or equal to @var{s2}.")
 192 #define FUNC_NAME s_scm_i_string_geq_p
 193 {
 194   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 195     return SCM_BOOL_T;
 196   while (!scm_is_null (rest))
 197     {
 198       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge)))
 199         return SCM_BOOL_F;
 200       s1 = s2;
 201       s2 = scm_car (rest);
 202       rest = scm_cdr (rest);
 203     }
 204   return srfi13_cmp (s1, s2, scm_string_ge);
 205 }
 206 #undef FUNC_NAME
 207
 208 SCM scm_string_geq_p (SCM s1, SCM s2)
 209 #define FUNC_NAME s_scm_i_string_geq_p
 210 {
 211   return srfi13_cmp (s1, s2, scm_string_ge);
 212 }
 213 #undef FUNC_NAME
 214
 215 SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
 216             (SCM s1, SCM s2, SCM rest),
 217             "Case insensitive lexicographic ordering predicate; return\n"
 218             "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
 219             "regardless of case.")
 220 #define FUNC_NAME s_scm_i_string_ci_less_p
 221 {
 222   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 223     return SCM_BOOL_T;
 224   while (!scm_is_null (rest))
 225     {
 226       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt)))
 227         return SCM_BOOL_F;
 228       s1 = s2;
 229       s2 = scm_car (rest);
 230       rest = scm_cdr (rest);
 231     }
 232   return srfi13_cmp (s1, s2, scm_string_ci_lt);
 233 }
 234 #undef FUNC_NAME
 235
 236 SCM scm_string_ci_less_p (SCM s1, SCM s2)
 237 #define FUNC_NAME s_scm_i_string_ci_less_p
 238 {
 239   return srfi13_cmp (s1, s2, scm_string_ci_lt);
 240 }
 241 #undef FUNC_NAME
 242
 243 SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
 244             (SCM s1, SCM s2, SCM rest),
 245             "Case insensitive lexicographic ordering predicate; return\n"
 246             "@code{#t} if @var{s1} is lexicographically less than or equal\n"
 247             "to @var{s2} regardless of case.")
 248 #define FUNC_NAME s_scm_i_string_ci_leq_p
 249 {
 250   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 251     return SCM_BOOL_T;
 252   while (!scm_is_null (rest))
 253     {
 254       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le)))
 255         return SCM_BOOL_F;
 256       s1 = s2;
 257       s2 = scm_car (rest);
 258       rest = scm_cdr (rest);
 259     }
 260   return srfi13_cmp (s1, s2, scm_string_ci_le);
 261 }
 262 #undef FUNC_NAME
 263
 264 SCM scm_string_ci_leq_p (SCM s1, SCM s2)
 265 #define FUNC_NAME s_scm_i_string_ci_leq_p
 266 {
 267   return srfi13_cmp (s1, s2, scm_string_ci_le);
 268 }
 269 #undef FUNC_NAME
 270
 271 SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
 272             (SCM s1, SCM s2, SCM rest),
 273             "Case insensitive lexicographic ordering predicate; return\n"
 274             "@code{#t} if @var{s1} is lexicographically greater than\n"
 275             "@var{s2} regardless of case.")
 276 #define FUNC_NAME s_scm_i_string_ci_gr_p
 277 {
 278   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 279     return SCM_BOOL_T;
 280   while (!scm_is_null (rest))
 281     {
 282       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt)))
 283         return SCM_BOOL_F;
 284       s1 = s2;
 285       s2 = scm_car (rest);
 286       rest = scm_cdr (rest);
 287     }
 288   return srfi13_cmp (s1, s2, scm_string_ci_gt);
 289 }
 290 #undef FUNC_NAME
 291
 292 SCM scm_string_ci_gr_p (SCM s1, SCM s2)
 293 #define FUNC_NAME s_scm_i_string_ci_gr_p
 294 {
 295   return srfi13_cmp (s1, s2, scm_string_ci_gt);
 296 }
 297 #undef FUNC_NAME
 298
 299 SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
 300             (SCM s1, SCM s2, SCM rest),
 301             "Case insensitive lexicographic ordering predicate; return\n"
 302             "@code{#t} if @var{s1} is lexicographically greater than or\n"
 303             "equal to @var{s2} regardless of case.")
 304 #define FUNC_NAME s_scm_i_string_ci_geq_p
 305 {
 306   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 307     return SCM_BOOL_T;
 308   while (!scm_is_null (rest))
 309     {
 310       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge)))
 311         return SCM_BOOL_F;
 312       s1 = s2;
 313       s2 = scm_car (rest);
 314       rest = scm_cdr (rest);
 315     }
 316   return srfi13_cmp (s1, s2, scm_string_ci_ge);
 317 }
 318 #undef FUNC_NAME
 319
 320 SCM scm_string_ci_geq_p (SCM s1, SCM s2)
 321 #define FUNC_NAME s_scm_i_string_ci_geq_p
 322 {
 323   return srfi13_cmp (s1, s2, scm_string_ci_ge);
 324 }
 325 #undef FUNC_NAME
 326
 327 \f
 328
 329 void
 330 scm_init_strorder ()
 331 {
 332 #include "libguile/strorder.x"
 333 }
 334
 335
 336 /*
 337   Local Variables:
 338   c-file-style: "gnu"
 339   End:
 340 */