libguile/regex-posix.c

   1 /*      Copyright (C) 1997, 1998 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 /* regex-posix.c -- POSIX regular expression support.
  44
  45    This code was written against Henry Spencer's famous regex package.
  46    The principal reference for POSIX behavior was the man page for this
  47    library, not the 1003.2 document itself.  Ergo, other `POSIX'
  48    libraries which do not agree with the Spencer implementation may
  49    produce varying behavior.  Sigh. */
  50
  51 #include <stdio.h>
  52 #include <sys/types.h>
  53
  54 #include "_scm.h"
  55
  56 /* Supposedly, this file is never compiled unless we know we have
  57    POSIX regular expressions.  But we still put this in an #ifdef so
  58    the file is CPP'able (for dependency scanning) even on systems that
  59    don't have a <regex.h> header.  */
  60 #ifdef HAVE_REGCOMP
  61 #ifdef HAVE_REGEX_H
  62 #include <regex.h>
  63 #else
  64 #ifdef HAVE_RXPOSIX_H
  65 #include <rxposix.h>            /* GNU Rx library */
  66 #else
  67 #ifdef HAVE_RX_RXPOSIX_H
  68 #include <rx/rxposix.h>         /* GNU Rx library on Linux */
  69 #endif
  70 #endif
  71 #endif
  72 #endif
  73
  74 #include "smob.h"
  75 #include "symbols.h"
  76 #include "vectors.h"
  77 #include "strports.h"
  78 #include "ports.h"
  79 #include "feature.h"
  80
  81 #include "regex-posix.h"
  82
  83 /* This is defined by some regex libraries and omitted by others. */
  84 #ifndef REG_BASIC
  85 #define REG_BASIC 0
  86 #endif
  87
  88 long scm_tc16_regex_t;
  89
  90 static scm_sizet
  91 scm_free_regex_t (obj)
  92      SCM obj;
  93 {
  94   regfree (SCM_RGX (obj));
  95   free (SCM_RGX (obj));
  96   return sizeof(regex_t);
  97 }
  98
  99 static int
 100 scm_print_regex_t (obj, port, pstate)
 101      SCM obj;
 102      SCM port;
 103      scm_print_state *pstate;
 104 {
 105   regex_t *r;
 106   r = SCM_RGX (obj);
 107   scm_puts ("#<rgx ", port);
 108   scm_intprint (obj, 16, port);
 109   scm_puts (">", port);
 110   return 1;
 111 }
 112
 113
 114 static scm_smobfuns regex_t_smob =
 115 { 0, scm_free_regex_t, scm_print_regex_t, 0 };
 116 \f
 117
 118 SCM_SYMBOL (scm_regexp_error_key, "regular-expression-syntax");
 119
 120 static char *
 121 scm_regexp_error_msg (regerrno, rx)
 122      int regerrno;
 123      SCM rx;
 124 {
 125   SCM errmsg;
 126   int l;
 127
 128   /* FIXME: must we wrap any external calls in SCM_DEFER_INTS...SCM_ALLOW_INTS?
 129      Or are these only necessary when a SCM object may be left in an
 130      undetermined state (half-formed)?  If the latter then I believe we
 131      may do without the critical section code. -twp */
 132
 133   /* We could simply make errmsg a char pointer, and allocate space with
 134      malloc.  But since we are about to pass the pointer to scm_error, which
 135      never returns, we would never have the opportunity to free it.  Creating
 136      it as a SCM object means that the system will GC it at some point. */
 137
 138   errmsg = scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED);
 139   SCM_DEFER_INTS;
 140   l = regerror (regerrno, SCM_RGX (rx), SCM_CHARS (errmsg), 80);
 141   if (l > 80)
 142     {
 143       errmsg = scm_make_string (SCM_MAKINUM (l), SCM_UNDEFINED);
 144       regerror (regerrno, SCM_RGX (rx), SCM_CHARS (errmsg), l);
 145     }
 146   SCM_ALLOW_INTS;
 147   return SCM_CHARS (errmsg);
 148 }
 149
 150 SCM_PROC (s_regexp_p, "regexp?", 1, 0, 0, scm_regexp_p);
 151
 152 SCM
 153 scm_regexp_p (x)
 154      SCM x;
 155 {
 156   return (SCM_NIMP (x) && SCM_RGXP (x) ? SCM_BOOL_T : SCM_BOOL_F);
 157 }
 158
 159 SCM_PROC (s_make_regexp, "make-regexp", 1, 0, 1, scm_make_regexp);
 160
 161 SCM
 162 scm_make_regexp (SCM pat, SCM flags)
 163 {
 164   SCM result, flag;
 165   regex_t *rx;
 166   int status, cflags;
 167
 168   SCM_ASSERT (SCM_NIMP(pat) && SCM_ROSTRINGP(pat), pat, SCM_ARG1,
 169               s_make_regexp);
 170   SCM_COERCE_SUBSTR (pat);
 171
 172   /* Examine list of regexp flags.  If REG_BASIC is supplied, then
 173      turn off REG_EXTENDED flag (on by default). */
 174   cflags = REG_EXTENDED;
 175   flag = flags;
 176   while (SCM_NNULLP (flag))
 177     {
 178       if (SCM_INUM (SCM_CAR (flag)) == REG_BASIC)
 179         cflags &= ~REG_EXTENDED;
 180       else
 181         cflags |= SCM_INUM (SCM_CAR (flag));
 182       flag = SCM_CDR (flag);
 183     }
 184
 185   SCM_DEFER_INTS;
 186   rx = (regex_t *) scm_must_malloc (sizeof (regex_t), s_make_regexp);
 187   status = regcomp (rx, SCM_ROCHARS (pat),
 188                     /* Make sure they're not passing REG_NOSUB;
 189                        regexp-exec assumes we're getting match data.  */
 190                     cflags & ~REG_NOSUB);
 191   if (status != 0)
 192     {
 193       SCM_ALLOW_INTS;
 194       scm_error (scm_regexp_error_key,
 195                  s_make_regexp,
 196                  scm_regexp_error_msg (status, rx),
 197                  SCM_BOOL_F,
 198                  SCM_BOOL_F);
 199       /* never returns */
 200     }
 201   SCM_NEWCELL (result);
 202   SCM_SETCAR (result, scm_tc16_regex_t);
 203   SCM_SETCDR (result, rx);
 204   SCM_ALLOW_INTS;
 205   return result;
 206 }
 207
 208 SCM_PROC (s_regexp_exec, "regexp-exec", 2, 2, 0, scm_regexp_exec);
 209
 210 SCM
 211 scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags)
 212 {
 213   int status, nmatches, offset;
 214   regmatch_t *matches;
 215   SCM mvec = SCM_BOOL_F;
 216
 217   SCM_ASSERT (SCM_NIMP (rx) && SCM_RGXP (rx), rx, SCM_ARG1, s_regexp_exec);
 218   SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG2,
 219               s_regexp_exec);
 220
 221   if (SCM_UNBNDP (start))
 222     offset = 0;
 223   else
 224     {
 225       SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG3, s_regexp_exec);
 226       offset = SCM_INUM (start);
 227       SCM_ASSERT (offset >= 0 && (unsigned) offset <= SCM_LENGTH (str), start,
 228                   SCM_OUTOFRANGE, s_regexp_exec);
 229     }
 230
 231   if (SCM_UNBNDP (flags))
 232     flags = SCM_INUM0;
 233   SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_regexp_exec);
 234
 235   SCM_COERCE_SUBSTR (str);
 236
 237   /* re_nsub doesn't account for the `subexpression' representing the
 238      whole regexp, so add 1 to nmatches. */
 239
 240   nmatches = SCM_RGX(rx)->re_nsub + 1;
 241   SCM_DEFER_INTS;
 242   matches = (regmatch_t *) scm_must_malloc (sizeof (regmatch_t) * nmatches,
 243                                             s_regexp_exec);
 244   status = regexec (SCM_RGX (rx), SCM_ROCHARS (str) + offset,
 245                     nmatches, matches,
 246                     SCM_INUM (flags));
 247   if (!status)
 248     {
 249       int i;
 250       /* The match vector must include a cell for the string that was matched,
 251          so add 1. */
 252       mvec = scm_make_vector (SCM_MAKINUM (nmatches + 1), SCM_UNSPECIFIED);
 253       SCM_VELTS(mvec)[0] = str;
 254       for (i = 0; i < nmatches; ++i)
 255         if (matches[i].rm_so == -1)
 256           SCM_VELTS(mvec)[i+1] = scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1));
 257         else
 258           SCM_VELTS(mvec)[i+1]
 259             = scm_cons(SCM_MAKINUM(matches[i].rm_so + offset),
 260                        SCM_MAKINUM(matches[i].rm_eo + offset));
 261     }
 262   scm_must_free ((char *) matches);
 263   SCM_ALLOW_INTS;
 264
 265   if (status != 0 && status != REG_NOMATCH)
 266     scm_error (scm_regexp_error_key,
 267                s_regexp_exec,
 268                scm_regexp_error_msg (status),
 269                SCM_BOOL_F,
 270                SCM_BOOL_F);
 271   return mvec;
 272 }
 273
 274 void
 275 scm_init_regex_posix ()
 276 {
 277   scm_tc16_regex_t = scm_newsmob (&regex_t_smob);
 278
 279   /* Compilation flags.  */
 280   scm_sysintern ("regexp/basic", scm_long2num (REG_BASIC));
 281   scm_sysintern ("regexp/extended", scm_long2num (REG_EXTENDED));
 282   scm_sysintern ("regexp/icase", scm_long2num (REG_ICASE));
 283   scm_sysintern ("regexp/newline", scm_long2num (REG_NEWLINE));
 284
 285   /* Execution flags.  */
 286   scm_sysintern ("regexp/notbol", scm_long2num (REG_NOTBOL));
 287   scm_sysintern ("regexp/noteol", scm_long2num (REG_NOTEOL));
 288
 289 #include "regex-posix.x"
 290
 291   scm_add_feature ("regex");
 292 }