libguile/strorder.c

   1 /*      Copyright (C) 1995,1996 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 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "chars.h"
  46
  47 #include "strorder.h"
  48 \f
  49
  50 SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p);
  51
  52 SCM
  53 scm_string_equal_p (s1, s2)
  54      SCM s1;
  55      SCM s2;
  56 {
  57   register scm_sizet i;
  58   register unsigned char *c1, *c2;
  59   SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_equal_p);
  60   SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_equal_p);
  61
  62   i = SCM_ROLENGTH (s2);
  63   if (SCM_ROLENGTH (s1) != i)
  64     {
  65       return SCM_BOOL_F;
  66     }
  67   c1 = SCM_ROUCHARS (s1);
  68   c2 = SCM_ROUCHARS (s2);
  69   while (0 != i--)
  70     if (*c1++ != *c2++)
  71       return SCM_BOOL_F;
  72   return SCM_BOOL_T;
  73 }
  74
  75 SCM_PROC1 (s_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, scm_string_ci_equal_p);
  76
  77 SCM
  78 scm_string_ci_equal_p (s1, s2)
  79      SCM s1;
  80      SCM s2;
  81 {
  82   register scm_sizet i;
  83   register unsigned char *c1, *c2;
  84   SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_equal_p);
  85   SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_equal_p);
  86   i = SCM_ROLENGTH (s2);
  87   if (SCM_ROLENGTH (s1) != i)
  88     {
  89       return SCM_BOOL_F;
  90     }
  91   c1 = SCM_ROUCHARS (s1);
  92   c2 = SCM_ROUCHARS (s2);
  93   while (0 != i--)
  94     if (scm_upcase(*c1++) != scm_upcase(*c2++))
  95       return SCM_BOOL_F;
  96   return SCM_BOOL_T;
  97 }
  98
  99 SCM_PROC1 (s_string_less_p, "string<?", scm_tc7_rpsubr, scm_string_less_p);
 100
 101 SCM
 102 scm_string_less_p (s1, s2)
 103      SCM s1;
 104      SCM s2;
 105 {
 106   register scm_sizet i, len, s2len;
 107   register unsigned char *c1, *c2;
 108   register int c;
 109
 110   SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_less_p);
 111   SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_less_p);
 112   len = SCM_ROLENGTH (s1);
 113   s2len = i = SCM_ROLENGTH (s2);
 114   if (len>i) i = len;
 115   c1 = SCM_ROUCHARS (s1);
 116   c2 = SCM_ROUCHARS (s2);
 117
 118   for (i = 0;i<len;i++) {
 119     c = (*c1++ - *c2++);
 120     if (c>0)
 121       return SCM_BOOL_F;
 122     if (c<0)
 123       return SCM_BOOL_T;
 124   }
 125   {
 126     SCM answer;
 127     answer = (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F;
 128     return answer;
 129   }
 130 }
 131
 132 SCM_PROC1 (s_string_leq_p, "string<=?", scm_tc7_rpsubr, scm_string_leq_p);
 133
 134 SCM
 135 scm_string_leq_p (s1, s2)
 136      SCM s1;
 137      SCM s2;
 138 {
 139   return SCM_BOOL_NOT (scm_string_less_p (s2, s1));
 140 }
 141
 142 SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p);
 143
 144 SCM
 145 scm_string_gr_p (s1, s2)
 146      SCM s1;
 147      SCM s2;
 148 {
 149   return scm_string_less_p (s2, s1);
 150 }
 151
 152 SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p);
 153
 154 SCM
 155 scm_string_geq_p (s1, s2)
 156      SCM s1;
 157      SCM s2;
 158 {
 159   return SCM_BOOL_NOT (scm_string_less_p (s1, s2));
 160 }
 161
 162 SCM_PROC1 (s_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, scm_string_ci_less_p);
 163
 164 SCM
 165 scm_string_ci_less_p (s1, s2)
 166      SCM s1;
 167      SCM s2;
 168 {
 169   register scm_sizet i, len, s2len;
 170   register unsigned char *c1, *c2;
 171   register int c;
 172   SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_less_p);
 173   SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_less_p);
 174   len = SCM_ROLENGTH (s1);
 175   s2len = i = SCM_ROLENGTH (s2);
 176   if (len>i) i=len;
 177   c1 = SCM_ROUCHARS (s1);
 178   c2 = SCM_ROUCHARS (s2);
 179   for (i = 0;i<len;i++) {
 180     c = (scm_upcase(*c1++) - scm_upcase(*c2++));
 181     if (c>0) return SCM_BOOL_F;
 182     if (c<0) return SCM_BOOL_T;
 183   }
 184   return (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F;
 185 }
 186
 187 SCM_PROC1 (s_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, scm_string_ci_leq_p);
 188
 189 SCM
 190 scm_string_ci_leq_p (s1, s2)
 191      SCM s1;
 192      SCM s2;
 193 {
 194   return SCM_BOOL_NOT (scm_string_ci_less_p (s2, s1));
 195 }
 196
 197 SCM_PROC1 (s_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, scm_string_ci_gr_p);
 198
 199 SCM
 200 scm_string_ci_gr_p (s1, s2)
 201      SCM s1;
 202      SCM s2;
 203 {
 204   return scm_string_ci_less_p (s2, s1);
 205 }
 206
 207 SCM_PROC1 (s_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, scm_string_ci_geq_p);
 208
 209 SCM
 210 scm_string_ci_geq_p (s1, s2)
 211      SCM s1;
 212      SCM s2;
 213 {
 214   return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2));
 215 }
 216
 217 \f
 218
 219 void
 220 scm_init_strorder ()
 221 {
 222 #include "strorder.x"
 223 }
 224