libguile/strorder.c

   1 /*      Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009, 2010 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 static SCM scm_i_string_equal_p (SCM s1, SCM s2, SCM rest);
  46 SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
  47             (SCM s1, SCM s2, SCM rest),
  48             "Lexicographic equality predicate; return @code{#t} if the two\n"
  49             "strings are the same length and contain the same characters in\n"
  50             "the same positions, otherwise return @code{#f}.\n"
  51             "\n"
  52             "The procedure @code{string-ci=?} treats upper and lower case\n"
  53             "letters as though they were the same character, but\n"
  54             "@code{string=?} treats upper and lower case as distinct\n"
  55             "characters.")
  56 #define FUNC_NAME s_scm_i_string_equal_p
  57 {
  58   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
  59     return SCM_BOOL_T;
  60   while (!scm_is_null (rest))
  61     {
  62       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq)))
  63         return SCM_BOOL_F;
  64       s1 = s2;
  65       s2 = scm_car (rest);
  66       rest = scm_cdr (rest);
  67     }
  68   return srfi13_cmp (s1, s2, scm_string_eq);
  69 }
  70 #undef FUNC_NAME
  71
  72 SCM scm_string_equal_p (SCM s1, SCM s2)
  73 #define FUNC_NAME s_scm_i_string_equal_p
  74 {
  75   return srfi13_cmp (s1, s2, scm_string_eq);
  76 }
  77 #undef FUNC_NAME
  78
  79 static SCM scm_i_string_ci_equal_p (SCM s1, SCM s2, SCM rest);
  80 SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
  81             (SCM s1, SCM s2, SCM rest),
  82             "Case-insensitive string equality predicate; return @code{#t} if\n"
  83             "the two strings are the same length and their component\n"
  84             "characters match (ignoring case) at each position; otherwise\n"
  85             "return @code{#f}.")
  86 #define FUNC_NAME s_scm_i_string_ci_equal_p
  87 {
  88   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
  89     return SCM_BOOL_T;
  90   while (!scm_is_null (rest))
  91     {
  92       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq)))
  93         return SCM_BOOL_F;
  94       s1 = s2;
  95       s2 = scm_car (rest);
  96       rest = scm_cdr (rest);
  97     }
  98   return srfi13_cmp (s1, s2, scm_string_ci_eq);
  99 }
 100 #undef FUNC_NAME
 101
 102 SCM scm_string_ci_equal_p (SCM s1, SCM s2)
 103 #define FUNC_NAME s_scm_i_string_ci_equal_p
 104 {
 105   return srfi13_cmp (s1, s2, scm_string_ci_eq);
 106 }
 107 #undef FUNC_NAME
 108
 109 static SCM scm_i_string_less_p (SCM s1, SCM s2, SCM rest);
 110 SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
 111             (SCM s1, SCM s2, SCM rest),
 112             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 113             "is lexicographically less than @var{s2}.")
 114 #define FUNC_NAME s_scm_i_string_less_p
 115 {
 116   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 117     return SCM_BOOL_T;
 118   while (!scm_is_null (rest))
 119     {
 120       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt)))
 121         return SCM_BOOL_F;
 122       s1 = s2;
 123       s2 = scm_car (rest);
 124       rest = scm_cdr (rest);
 125     }
 126   return srfi13_cmp (s1, s2, scm_string_lt);
 127 }
 128 #undef FUNC_NAME
 129
 130 SCM scm_string_less_p (SCM s1, SCM s2)
 131 #define FUNC_NAME s_scm_i_string_less_p
 132 {
 133   return srfi13_cmp (s1, s2, scm_string_lt);
 134 }
 135 #undef FUNC_NAME
 136
 137 static SCM scm_i_string_leq_p (SCM s1, SCM s2, SCM rest);
 138 SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
 139             (SCM s1, SCM s2, SCM rest),
 140             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 141             "is lexicographically less than or equal to @var{s2}.")
 142 #define FUNC_NAME s_scm_i_string_leq_p
 143 {
 144   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 145     return SCM_BOOL_T;
 146   while (!scm_is_null (rest))
 147     {
 148       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le)))
 149         return SCM_BOOL_F;
 150       s1 = s2;
 151       s2 = scm_car (rest);
 152       rest = scm_cdr (rest);
 153     }
 154   return srfi13_cmp (s1, s2, scm_string_le);
 155 }
 156 #undef FUNC_NAME
 157
 158 SCM scm_string_leq_p (SCM s1, SCM s2)
 159 #define FUNC_NAME s_scm_i_string_leq_p
 160 {
 161   return srfi13_cmp (s1, s2, scm_string_le);
 162 }
 163 #undef FUNC_NAME
 164
 165 static SCM scm_i_string_gr_p (SCM s1, SCM s2, SCM rest);
 166 SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
 167             (SCM s1, SCM s2, SCM rest),
 168             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 169             "is lexicographically greater than @var{s2}.")
 170 #define FUNC_NAME s_scm_i_string_gr_p
 171 {
 172   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 173     return SCM_BOOL_T;
 174   while (!scm_is_null (rest))
 175     {
 176       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt)))
 177         return SCM_BOOL_F;
 178       s1 = s2;
 179       s2 = scm_car (rest);
 180       rest = scm_cdr (rest);
 181     }
 182   return srfi13_cmp (s1, s2, scm_string_gt);
 183 }
 184 #undef FUNC_NAME
 185
 186 SCM scm_string_gr_p (SCM s1, SCM s2)
 187 #define FUNC_NAME s_scm_i_string_gr_p
 188 {
 189   return srfi13_cmp (s1, s2, scm_string_gt);
 190 }
 191 #undef FUNC_NAME
 192
 193 static SCM scm_i_string_geq_p (SCM s1, SCM s2, SCM rest);
 194 SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
 195             (SCM s1, SCM s2, SCM rest),
 196             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 197             "is lexicographically greater than or equal to @var{s2}.")
 198 #define FUNC_NAME s_scm_i_string_geq_p
 199 {
 200   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 201     return SCM_BOOL_T;
 202   while (!scm_is_null (rest))
 203     {
 204       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge)))
 205         return SCM_BOOL_F;
 206       s1 = s2;
 207       s2 = scm_car (rest);
 208       rest = scm_cdr (rest);
 209     }
 210   return srfi13_cmp (s1, s2, scm_string_ge);
 211 }
 212 #undef FUNC_NAME
 213
 214 SCM scm_string_geq_p (SCM s1, SCM s2)
 215 #define FUNC_NAME s_scm_i_string_geq_p
 216 {
 217   return srfi13_cmp (s1, s2, scm_string_ge);
 218 }
 219 #undef FUNC_NAME
 220
 221 static SCM scm_i_string_ci_less_p (SCM s1, SCM s2, SCM rest);
 222 SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
 223             (SCM s1, SCM s2, SCM rest),
 224             "Case insensitive lexicographic ordering predicate; return\n"
 225             "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
 226             "regardless of case.")
 227 #define FUNC_NAME s_scm_i_string_ci_less_p
 228 {
 229   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 230     return SCM_BOOL_T;
 231   while (!scm_is_null (rest))
 232     {
 233       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt)))
 234         return SCM_BOOL_F;
 235       s1 = s2;
 236       s2 = scm_car (rest);
 237       rest = scm_cdr (rest);
 238     }
 239   return srfi13_cmp (s1, s2, scm_string_ci_lt);
 240 }
 241 #undef FUNC_NAME
 242
 243 SCM scm_string_ci_less_p (SCM s1, SCM s2)
 244 #define FUNC_NAME s_scm_i_string_ci_less_p
 245 {
 246   return srfi13_cmp (s1, s2, scm_string_ci_lt);
 247 }
 248 #undef FUNC_NAME
 249
 250 static SCM scm_i_string_ci_leq_p (SCM s1, SCM s2, SCM rest);
 251 SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
 252             (SCM s1, SCM s2, SCM rest),
 253             "Case insensitive lexicographic ordering predicate; return\n"
 254             "@code{#t} if @var{s1} is lexicographically less than or equal\n"
 255             "to @var{s2} regardless of case.")
 256 #define FUNC_NAME s_scm_i_string_ci_leq_p
 257 {
 258   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 259     return SCM_BOOL_T;
 260   while (!scm_is_null (rest))
 261     {
 262       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le)))
 263         return SCM_BOOL_F;
 264       s1 = s2;
 265       s2 = scm_car (rest);
 266       rest = scm_cdr (rest);
 267     }
 268   return srfi13_cmp (s1, s2, scm_string_ci_le);
 269 }
 270 #undef FUNC_NAME
 271
 272 SCM scm_string_ci_leq_p (SCM s1, SCM s2)
 273 #define FUNC_NAME s_scm_i_string_ci_leq_p
 274 {
 275   return srfi13_cmp (s1, s2, scm_string_ci_le);
 276 }
 277 #undef FUNC_NAME
 278
 279 static SCM scm_i_string_ci_gr_p (SCM s1, SCM s2, SCM rest);
 280 SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
 281             (SCM s1, SCM s2, SCM rest),
 282             "Case insensitive lexicographic ordering predicate; return\n"
 283             "@code{#t} if @var{s1} is lexicographically greater than\n"
 284             "@var{s2} regardless of case.")
 285 #define FUNC_NAME s_scm_i_string_ci_gr_p
 286 {
 287   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 288     return SCM_BOOL_T;
 289   while (!scm_is_null (rest))
 290     {
 291       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt)))
 292         return SCM_BOOL_F;
 293       s1 = s2;
 294       s2 = scm_car (rest);
 295       rest = scm_cdr (rest);
 296     }
 297   return srfi13_cmp (s1, s2, scm_string_ci_gt);
 298 }
 299 #undef FUNC_NAME
 300
 301 SCM scm_string_ci_gr_p (SCM s1, SCM s2)
 302 #define FUNC_NAME s_scm_i_string_ci_gr_p
 303 {
 304   return srfi13_cmp (s1, s2, scm_string_ci_gt);
 305 }
 306 #undef FUNC_NAME
 307
 308 static SCM scm_i_string_ci_geq_p (SCM s1, SCM s2, SCM rest);
 309 SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
 310             (SCM s1, SCM s2, SCM rest),
 311             "Case insensitive lexicographic ordering predicate; return\n"
 312             "@code{#t} if @var{s1} is lexicographically greater than or\n"
 313             "equal to @var{s2} regardless of case.")
 314 #define FUNC_NAME s_scm_i_string_ci_geq_p
 315 {
 316   if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
 317     return SCM_BOOL_T;
 318   while (!scm_is_null (rest))
 319     {
 320       if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge)))
 321         return SCM_BOOL_F;
 322       s1 = s2;
 323       s2 = scm_car (rest);
 324       rest = scm_cdr (rest);
 325     }
 326   return srfi13_cmp (s1, s2, scm_string_ci_ge);
 327 }
 328 #undef FUNC_NAME
 329
 330 SCM scm_string_ci_geq_p (SCM s1, SCM s2)
 331 #define FUNC_NAME s_scm_i_string_ci_geq_p
 332 {
 333   return srfi13_cmp (s1, s2, scm_string_ci_ge);
 334 }
 335 #undef FUNC_NAME
 336
 337 \f
 338
 339 void
 340 scm_init_strorder ()
 341 {
 342 #include "libguile/strorder.x"
 343 }
 344
 345
 346 /*
 347   Local Variables:
 348   c-file-style: "gnu"
 349   End:
 350 */