libguile/strorder.c

   1 /*      Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 \f
  43
  44 #include "libguile/_scm.h"
  45 #include "libguile/chars.h"
  46 #include "libguile/strings.h"
  47 #include "libguile/symbols.h"
  48
  49 #include "libguile/validate.h"
  50 #include "libguile/strorder.h"
  51 \f
  52
  53 SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr,
  54              (SCM s1, SCM s2),
  55             "Lexicographic equality predicate; return @code{#t} if the two\n"
  56             "strings are the same length and contain the same characters in\n"
  57             "the same positions, otherwise return @code{#f}.\n"
  58             "\n"
  59             "The procedure @code{string-ci=?} treats upper and lower case\n"
  60             "letters as though they were the same character, but\n"
  61             "@code{string=?} treats upper and lower case as distinct\n"
  62             "characters.")
  63 #define FUNC_NAME s_scm_string_equal_p
  64 {
  65   size_t length;
  66
  67   SCM_VALIDATE_STRING (1, s1);
  68   SCM_VALIDATE_STRING (2, s2);
  69
  70   length = SCM_STRING_LENGTH (s2);
  71   if (SCM_STRING_LENGTH (s1) == length)
  72     {
  73       unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1;
  74       unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1;
  75       size_t i;
  76
  77       /* comparing from back to front typically finds mismatches faster */
  78       for (i = 0; i != length; ++i, --c1, --c2)
  79         if (*c1 != *c2)
  80           return SCM_BOOL_F;
  81
  82       return SCM_BOOL_T;
  83     }
  84   else
  85     {
  86       return SCM_BOOL_F;
  87     }
  88 }
  89 #undef FUNC_NAME
  90
  91
  92 SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr,
  93              (SCM s1, SCM s2),
  94             "Case-insensitive string equality predicate; return @code{#t} if\n"
  95             "the two strings are the same length and their component\n"
  96             "characters match (ignoring case) at each position; otherwise\n"
  97             "return @code{#f}.")
  98 #define FUNC_NAME s_scm_string_ci_equal_p
  99 {
 100   size_t length;
 101
 102   SCM_VALIDATE_STRING (1, s1);
 103   SCM_VALIDATE_STRING (2, s2);
 104
 105   length = SCM_STRING_LENGTH (s2);
 106   if (SCM_STRING_LENGTH (s1) == length)
 107     {
 108       unsigned char *c1 = SCM_STRING_UCHARS (s1) + length - 1;
 109       unsigned char *c2 = SCM_STRING_UCHARS (s2) + length - 1;
 110       size_t i;
 111
 112       /* comparing from back to front typically finds mismatches faster */
 113       for (i = 0; i != length; ++i, --c1, --c2)
 114         if (scm_upcase (*c1) != scm_upcase (*c2))
 115           return SCM_BOOL_F;
 116
 117       return SCM_BOOL_T;
 118     }
 119   else
 120     {
 121       return SCM_BOOL_F;
 122     }
 123 }
 124 #undef FUNC_NAME
 125
 126
 127 /* Helper function for the lexicographic ordering predicates.
 128  * No argument checking is performed.  */
 129 static SCM
 130 string_less_p (SCM s1, SCM s2)
 131 {
 132   size_t i, length1, length2, lengthm;
 133   unsigned char *c1, *c2;
 134
 135   length1 = SCM_STRING_LENGTH (s1);
 136   length2 = SCM_STRING_LENGTH (s2);
 137   lengthm = min (length1, length2);
 138   c1 = SCM_STRING_UCHARS (s1);
 139   c2 = SCM_STRING_UCHARS (s2);
 140
 141   for (i = 0; i != lengthm; ++i, ++c1, ++c2) {
 142     int c = *c1 - *c2;
 143     if (c < 0) return SCM_BOOL_T;
 144     if (c > 0) return SCM_BOOL_F;
 145   }
 146
 147   return SCM_BOOL (length1 < length2);
 148 }
 149
 150
 151 SCM_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr,
 152              (SCM s1, SCM s2),
 153             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 154             "is lexicographically less than @var{s2}.")
 155 #define FUNC_NAME s_scm_string_less_p
 156 {
 157   SCM_VALIDATE_STRING (1, s1);
 158   SCM_VALIDATE_STRING (2, s2);
 159
 160   return string_less_p (s1, s2);
 161 }
 162 #undef FUNC_NAME
 163
 164
 165 SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr,
 166              (SCM s1, SCM s2),
 167             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 168             "is lexicographically less than or equal to @var{s2}.")
 169 #define FUNC_NAME s_scm_string_leq_p
 170 {
 171   SCM_VALIDATE_STRING (1, s1);
 172   SCM_VALIDATE_STRING (2, s2);
 173
 174   return SCM_BOOL_NOT (string_less_p (s2, s1));
 175 }
 176 #undef FUNC_NAME
 177
 178
 179 SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr,
 180              (SCM s1, SCM s2),
 181             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 182             "is lexicographically greater than @var{s2}.")
 183 #define FUNC_NAME s_scm_string_gr_p
 184 {
 185   SCM_VALIDATE_STRING (1, s1);
 186   SCM_VALIDATE_STRING (2, s2);
 187
 188   return string_less_p (s2, s1);
 189 }
 190 #undef FUNC_NAME
 191
 192
 193 SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr,
 194              (SCM s1, SCM s2),
 195             "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
 196             "is lexicographically greater than or equal to @var{s2}.")
 197 #define FUNC_NAME s_scm_string_geq_p
 198 {
 199   SCM_VALIDATE_STRING (1, s1);
 200   SCM_VALIDATE_STRING (2, s2);
 201
 202   return SCM_BOOL_NOT (string_less_p (s1, s2));
 203 }
 204 #undef FUNC_NAME
 205
 206
 207 /* Helper function for the case insensitive lexicographic ordering
 208  * predicates.  No argument checking is performed.  */
 209 static SCM
 210 string_ci_less_p (SCM s1, SCM s2)
 211 {
 212   size_t i, length1, length2, lengthm;
 213   unsigned char *c1, *c2;
 214
 215   length1 = SCM_STRING_LENGTH (s1);
 216   length2 = SCM_STRING_LENGTH (s2);
 217   lengthm = min (length1, length2);
 218   c1 = SCM_STRING_UCHARS (s1);
 219   c2 = SCM_STRING_UCHARS (s2);
 220
 221   for (i = 0; i != lengthm; ++i, ++c1, ++c2) {
 222     int c = scm_upcase (*c1) - scm_upcase (*c2);
 223     if (c < 0) return SCM_BOOL_T;
 224     if (c > 0) return SCM_BOOL_F;
 225   }
 226
 227   return SCM_BOOL (length1 < length2);
 228 }
 229
 230
 231 SCM_DEFINE1 (scm_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr,
 232              (SCM s1, SCM s2),
 233             "Case insensitive lexicographic ordering predicate; return\n"
 234             "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
 235             "regardless of case.")
 236 #define FUNC_NAME s_scm_string_ci_less_p
 237 {
 238   SCM_VALIDATE_STRING (1, s1);
 239   SCM_VALIDATE_STRING (2, s2);
 240
 241   return string_ci_less_p (s1, s2);
 242 }
 243 #undef FUNC_NAME
 244
 245
 246 SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr,
 247              (SCM s1, SCM s2),
 248             "Case insensitive lexicographic ordering predicate; return\n"
 249             "@code{#t} if @var{s1} is lexicographically less than or equal\n"
 250             "to @var{s2} regardless of case.")
 251 #define FUNC_NAME s_scm_string_ci_leq_p
 252 {
 253   SCM_VALIDATE_STRING (1, s1);
 254   SCM_VALIDATE_STRING (2, s2);
 255
 256   return SCM_BOOL_NOT (string_ci_less_p (s2, s1));
 257 }
 258 #undef FUNC_NAME
 259
 260
 261 SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr,
 262              (SCM s1, SCM s2),
 263             "Case insensitive lexicographic ordering predicate; return\n"
 264             "@code{#t} if @var{s1} is lexicographically greater than\n"
 265             "@var{s2} regardless of case.")
 266 #define FUNC_NAME s_scm_string_ci_gr_p
 267 {
 268   SCM_VALIDATE_STRING (1, s1);
 269   SCM_VALIDATE_STRING (2, s2);
 270
 271   return string_ci_less_p (s2, s1);
 272 }
 273 #undef FUNC_NAME
 274
 275
 276 SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr,
 277              (SCM s1, SCM s2),
 278             "Case insensitive lexicographic ordering predicate; return\n"
 279             "@code{#t} if @var{s1} is lexicographically greater than or\n"
 280             "equal to @var{s2} regardless of case.")
 281 #define FUNC_NAME s_scm_string_ci_geq_p
 282 {
 283   SCM_VALIDATE_STRING (1, s1);
 284   SCM_VALIDATE_STRING (2, s2);
 285
 286   return SCM_BOOL_NOT (string_ci_less_p (s1, s2));
 287 }
 288 #undef FUNC_NAME
 289
 290 \f
 291
 292 void
 293 scm_init_strorder ()
 294 {
 295 #ifndef SCM_MAGIC_SNARFER
 296 #include "libguile/strorder.x"
 297 #endif
 298 }
 299
 300
 301 /*
 302   Local Variables:
 303   c-file-style: "gnu"
 304   End:
 305 */