/* -*-C-*-
$Id: rgxprim.c,v 1.13 1999/01/02 06:11:34 cph Exp $
Copyright (c) 1987-1999 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/* Primitives for regular expression matching and search. */
#include "scheme.h"
#include "prims.h"
#include "edwin.h"
#include "syntax.h"
#include "regex.h"
extern int re_max_failures;
#define RE_CHAR_SET_P(object) \
((STRING_P (object)) && \
((STRING_LENGTH (object)) == (MAX_ASCII / ASCII_LENGTH)))
#define CHAR_SET_P(argument) \
((STRING_P (argument)) && ((STRING_LENGTH (argument)) == MAX_ASCII))
#define CHAR_TRANSLATION_P(argument) \
((STRING_P (argument)) && ((STRING_LENGTH (argument)) == MAX_ASCII))
#define RE_REGISTERS_P(object) \
(((object) == SHARP_F) || \
((VECTOR_P (object)) && \
((VECTOR_LENGTH (object)) == (RE_NREGS + RE_NREGS))))
#define RE_MATCH_RESULTS(result, vector) do \
{ \
if ((result) >= 0) \
{ \
if ((vector) != SHARP_F) \
{ \
int i; \
long index; \
\
for (i = 0; (i < RE_NREGS); i += 1) \
{ \
index = ((registers . start) [i]); \
VECTOR_SET \
(vector, \
i, \
((index == -1) \
? SHARP_F \
: (long_to_integer (index)))); \
index = ((registers . end) [i]); \
VECTOR_SET \
(vector, \
(i + RE_NREGS), \
((index == -1) \
? SHARP_F \
: (long_to_integer (index)))); \
} \
} \
PRIMITIVE_RETURN (long_to_integer (result)); \
} \
else if (((result) == (-1)) || ((result) == (-4))) \
PRIMITIVE_RETURN (SHARP_F); \
else if ((result) == (-2)) \
error_bad_range_arg (1); \
else \
error_external_return (); \
/*NOTREACHED*/ \
return (0); \
} while (0)
DEFINE_PRIMITIVE ("RE-CHAR-SET-ADJOIN!", Prim_re_char_set_adjoin, 2, 2, 0)
{
int ascii;
PRIMITIVE_HEADER (2);
CHECK_ARG (1, RE_CHAR_SET_P);
ascii = (arg_ascii_integer (2));
(* (STRING_LOC ((ARG_REF (1)), (ascii / ASCII_LENGTH)))) |=
(1 << (ascii % ASCII_LENGTH));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("RE-COMPILE-FASTMAP", Prim_re_compile_fastmap, 4, 4, 0)
{
fast SCHEME_OBJECT pattern;
fast int can_be_null;
PRIMITIVE_HEADER (4);
CHECK_ARG (1, STRING_P);
pattern = (ARG_REF (1));
CHECK_ARG (2, CHAR_TRANSLATION_P);
CHECK_ARG (3, SYNTAX_TABLE_P);
CHECK_ARG (4, CHAR_SET_P);
can_be_null =
(re_compile_fastmap
((STRING_LOC (pattern, 0)),
(STRING_LOC (pattern, (STRING_LENGTH (pattern)))),
(STRING_LOC ((ARG_REF (2)), 0)),
(ARG_REF (3)),
(STRING_LOC ((ARG_REF (4)), 0))));
if (can_be_null >= 0)
PRIMITIVE_RETURN (long_to_integer (can_be_null));
else if (can_be_null == (-2))
error_bad_range_arg (1);
else
error_external_return ();
/*NOTREACHED*/
return (0);
}
/* (re-match-substring regexp translation syntax-table registers
string start end)
Attempt to match REGEXP against the substring [STRING, START, END].
Return the index of the end of the match (exclusive) if successful.
Otherwise return false. REGISTERS, if not false, is set to contain
the appropriate indices for the match registers. */
#define RE_SUBSTRING_PRIMITIVE(procedure) \
{ \
fast SCHEME_OBJECT regexp; \
long match_start, match_end, text_end; \
unsigned char * text; \
struct re_buffer buffer; \
struct re_registers registers; \
int result; \
PRIMITIVE_HEADER (7); \
CHECK_ARG (1, STRING_P); \
regexp = (ARG_REF (1)); \
CHECK_ARG (2, CHAR_TRANSLATION_P); \
CHECK_ARG (3, SYNTAX_TABLE_P); \
CHECK_ARG (4, RE_REGISTERS_P); \
CHECK_ARG (5, STRING_P); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
text = (STRING_LOC ((ARG_REF (5)), 0)); \
text_end = (STRING_LENGTH (ARG_REF (5))); \
if (match_end > text_end) error_bad_range_arg (7); \
if (match_start > match_end) error_bad_range_arg (6); \
re_max_failures = 20000; \
re_buffer_initialize \
((& buffer), (STRING_LOC ((ARG_REF (2)), 0)), (ARG_REF (3)), \
text, 0, text_end, text_end, text_end); \
result = \
(procedure ((STRING_LOC (regexp, 0)), \
(STRING_LOC (regexp, (STRING_LENGTH (regexp)))), \
(& buffer), \
(((ARG_REF (4)) == SHARP_F) ? NULL : (& registers)), \
(& (text [match_start])), \
(& (text [match_end])))); \
RE_MATCH_RESULTS (result, (ARG_REF (4))); \
}
DEFINE_PRIMITIVE ("RE-MATCH-SUBSTRING", Prim_re_match_substring, 7, 7, 0)
RE_SUBSTRING_PRIMITIVE (re_match)
DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-FORWARD", Prim_re_search_substr_forward, 7, 7, 0)
RE_SUBSTRING_PRIMITIVE (re_search_forward)
DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-BACKWARD", Prim_re_search_substr_backward, 7, 7, 0)
RE_SUBSTRING_PRIMITIVE (re_search_backward)
#define RE_BUFFER_PRIMITIVE(procedure) \
{ \
fast SCHEME_OBJECT regexp, group; \
long match_start, match_end, text_start, text_end, gap_start; \
unsigned char * text; \
struct re_buffer buffer; \
struct re_registers registers; \
int result; \
PRIMITIVE_HEADER (7); \
CHECK_ARG (1, STRING_P); \
regexp = (ARG_REF (1)); \
CHECK_ARG (2, CHAR_TRANSLATION_P); \
CHECK_ARG (3, SYNTAX_TABLE_P); \
CHECK_ARG (4, RE_REGISTERS_P); \
CHECK_ARG (5, GROUP_P); \
group = (ARG_REF (5)); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
text = (STRING_LOC ((GROUP_TEXT (group)), 0)); \
text_start = (MARK_INDEX (GROUP_START_MARK (group))); \
text_end = (MARK_INDEX (GROUP_END_MARK (group))); \
gap_start = (GROUP_GAP_START (group)); \
if (text_end > gap_start) \
text_end += (GROUP_GAP_LENGTH (group)); \
if (match_end > gap_start) \
{ \
match_end += (GROUP_GAP_LENGTH (group)); \
if (match_start >= gap_start) \
match_start += (GROUP_GAP_LENGTH (group)); \
} \
if (match_start > match_end) error_bad_range_arg (6); \
if (match_end > text_end) error_bad_range_arg (7); \
if (match_start < text_start) error_bad_range_arg (6); \
re_max_failures = 20000; \
re_buffer_initialize \
((& buffer), (STRING_LOC ((ARG_REF (2)), 0)), (ARG_REF (3)), \
text, text_start, text_end, gap_start, (GROUP_GAP_END (group))); \
result = \
(procedure ((STRING_LOC (regexp, 0)), \
(STRING_LOC (regexp, (STRING_LENGTH (regexp)))), \
(& buffer), \
(((ARG_REF (4)) == SHARP_F) ? NULL : (& registers)), \
(& (text [match_start])), \
(& (text [match_end])))); \
RE_MATCH_RESULTS (result, (ARG_REF (4))); \
}
DEFINE_PRIMITIVE ("RE-MATCH-BUFFER", Prim_re_match_buffer, 7, 7, 0)
RE_BUFFER_PRIMITIVE (re_match)
DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-FORWARD", Prim_re_search_buffer_forward, 7, 7, 0)
RE_BUFFER_PRIMITIVE (re_search_forward)
DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-BACKWARD", Prim_re_search_buffer_backward, 7, 7, 0)
RE_BUFFER_PRIMITIVE (re_search_backward)
syntax highlighted by Code2HTML, v. 0.9.1