home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / rgxprim.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  8KB  |  231 lines
  1. /* -*-C-*-
  2.  
  3. $Id: rgxprim.c,v 1.13 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Primitives for regular expression matching and search. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "edwin.h"
  27. #include "syntax.h"
  28. #include "regex.h"
  29.  
  30. extern int re_max_failures;
  31.  
  32. #define RE_CHAR_SET_P(object)                        \
  33.   ((STRING_P (object)) &&                        \
  34.    ((STRING_LENGTH (object)) == (MAX_ASCII / ASCII_LENGTH)))
  35.  
  36. #define CHAR_SET_P(argument)                        \
  37.   ((STRING_P (argument)) && ((STRING_LENGTH (argument)) == MAX_ASCII))
  38.  
  39. #define CHAR_TRANSLATION_P(argument)                    \
  40.   ((STRING_P (argument)) && ((STRING_LENGTH (argument)) == MAX_ASCII))
  41.  
  42. #define RE_REGISTERS_P(object)                        \
  43.   (((object) == SHARP_F) ||                        \
  44.    ((VECTOR_P (object)) &&                        \
  45.     ((VECTOR_LENGTH (object)) == (RE_NREGS + RE_NREGS))))
  46.  
  47. #define RE_MATCH_RESULTS(result, vector) do                \
  48. {                                    \
  49.   if ((result) >= 0)                            \
  50.     {                                    \
  51.       if ((vector) != SHARP_F)                        \
  52.     {                                \
  53.       int i;                            \
  54.       long index;                            \
  55.                                     \
  56.       for (i = 0; (i < RE_NREGS); i += 1)                \
  57.         {                                \
  58.           index = ((registers . start) [i]);            \
  59.           VECTOR_SET                        \
  60.         (vector,                        \
  61.          i,                            \
  62.          ((index == -1)                        \
  63.           ? SHARP_F                        \
  64.           : (long_to_integer (index))));            \
  65.           index = ((registers . end) [i]);                \
  66.           VECTOR_SET                        \
  67.         (vector,                        \
  68.          (i + RE_NREGS),                    \
  69.          ((index == -1)                        \
  70.           ? SHARP_F                        \
  71.           : (long_to_integer (index))));            \
  72.         }                                \
  73.     }                                \
  74.       PRIMITIVE_RETURN (long_to_integer (result));            \
  75.     }                                    \
  76.   else if (((result) == (-1)) || ((result) == (-4)))            \
  77.     PRIMITIVE_RETURN (SHARP_F);                        \
  78.   else if ((result) == (-2))                        \
  79.     error_bad_range_arg (1);                        \
  80.   else                                    \
  81.     error_external_return ();                        \
  82.   /*NOTREACHED*/                            \
  83.   return (0);                                \
  84. } while (0)
  85.  
  86. DEFINE_PRIMITIVE ("RE-CHAR-SET-ADJOIN!", Prim_re_char_set_adjoin, 2, 2, 0)
  87. {
  88.   int ascii;
  89.   PRIMITIVE_HEADER (2);
  90.   CHECK_ARG (1, RE_CHAR_SET_P);
  91.   ascii = (arg_ascii_integer (2));
  92.   (* (STRING_LOC ((ARG_REF (1)), (ascii / ASCII_LENGTH)))) |=
  93.     (1 << (ascii % ASCII_LENGTH));
  94.   PRIMITIVE_RETURN (UNSPECIFIC);
  95. }
  96.  
  97. DEFINE_PRIMITIVE ("RE-COMPILE-FASTMAP", Prim_re_compile_fastmap, 4, 4, 0)
  98. {
  99.   fast SCHEME_OBJECT pattern;
  100.   fast int can_be_null;
  101.   PRIMITIVE_HEADER (4);
  102.   CHECK_ARG (1, STRING_P);
  103.   pattern = (ARG_REF (1));
  104.   CHECK_ARG (2, CHAR_TRANSLATION_P);
  105.   CHECK_ARG (3, SYNTAX_TABLE_P);
  106.   CHECK_ARG (4, CHAR_SET_P);
  107.   can_be_null =
  108.     (re_compile_fastmap
  109.      ((STRING_LOC (pattern, 0)),
  110.       (STRING_LOC (pattern, (STRING_LENGTH (pattern)))),
  111.       (STRING_LOC ((ARG_REF (2)), 0)),
  112.       (ARG_REF (3)),
  113.       (STRING_LOC ((ARG_REF (4)), 0))));
  114.   if (can_be_null >= 0)
  115.     PRIMITIVE_RETURN (long_to_integer (can_be_null));
  116.   else if (can_be_null == (-2))
  117.     error_bad_range_arg (1);
  118.   else
  119.     error_external_return ();
  120.   /*NOTREACHED*/
  121.   return (0);
  122. }
  123.  
  124. /* (re-match-substring regexp translation syntax-table registers
  125.                string start end)
  126.  
  127.    Attempt to match REGEXP against the substring [STRING, START, END].
  128.    Return the index of the end of the match (exclusive) if successful.
  129.    Otherwise return false.  REGISTERS, if not false, is set to contain
  130.    the appropriate indices for the match registers. */
  131.  
  132. #define RE_SUBSTRING_PRIMITIVE(procedure)                \
  133. {                                    \
  134.   fast SCHEME_OBJECT regexp;                        \
  135.   long match_start, match_end, text_end;                \
  136.   unsigned char * text;                            \
  137.   struct re_buffer buffer;                        \
  138.   struct re_registers registers;                    \
  139.   int result;                                \
  140.   PRIMITIVE_HEADER (7);                            \
  141.   CHECK_ARG (1, STRING_P);                        \
  142.   regexp = (ARG_REF (1));                        \
  143.   CHECK_ARG (2, CHAR_TRANSLATION_P);                    \
  144.   CHECK_ARG (3, SYNTAX_TABLE_P);                    \
  145.   CHECK_ARG (4, RE_REGISTERS_P);                    \
  146.   CHECK_ARG (5, STRING_P);                        \
  147.   match_start = (arg_nonnegative_integer (6));                \
  148.   match_end = (arg_nonnegative_integer (7));                \
  149.   text = (STRING_LOC ((ARG_REF (5)), 0));                \
  150.   text_end = (STRING_LENGTH (ARG_REF (5)));                \
  151.   if (match_end > text_end) error_bad_range_arg (7);            \
  152.   if (match_start > match_end) error_bad_range_arg (6);            \
  153.   re_max_failures = 20000;                        \
  154.   re_buffer_initialize                            \
  155.     ((& buffer), (STRING_LOC ((ARG_REF (2)), 0)), (ARG_REF (3)),    \
  156.      text, 0, text_end, text_end, text_end);                \
  157.   result =                                \
  158.     (procedure ((STRING_LOC (regexp, 0)),                \
  159.         (STRING_LOC (regexp, (STRING_LENGTH (regexp)))),    \
  160.         (& buffer),                        \
  161.         (((ARG_REF (4)) == SHARP_F) ? NULL : (& registers)),    \
  162.         (& (text [match_start])),                \
  163.         (& (text [match_end]))));                \
  164.   RE_MATCH_RESULTS (result, (ARG_REF (4)));                \
  165. }
  166.  
  167. DEFINE_PRIMITIVE ("RE-MATCH-SUBSTRING", Prim_re_match_substring, 7, 7, 0)
  168.      RE_SUBSTRING_PRIMITIVE (re_match)
  169.  
  170. DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-FORWARD", Prim_re_search_substr_forward, 7, 7, 0)
  171.      RE_SUBSTRING_PRIMITIVE (re_search_forward)
  172.  
  173. DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-BACKWARD", Prim_re_search_substr_backward, 7, 7, 0)
  174.      RE_SUBSTRING_PRIMITIVE (re_search_backward)
  175.  
  176. #define RE_BUFFER_PRIMITIVE(procedure)                    \
  177. {                                    \
  178.   fast SCHEME_OBJECT regexp, group;                    \
  179.   long match_start, match_end, text_start, text_end, gap_start;        \
  180.   unsigned char * text;                            \
  181.   struct re_buffer buffer;                        \
  182.   struct re_registers registers;                    \
  183.   int result;                                \
  184.   PRIMITIVE_HEADER (7);                            \
  185.   CHECK_ARG (1, STRING_P);                        \
  186.   regexp = (ARG_REF (1));                        \
  187.   CHECK_ARG (2, CHAR_TRANSLATION_P);                    \
  188.   CHECK_ARG (3, SYNTAX_TABLE_P);                    \
  189.   CHECK_ARG (4, RE_REGISTERS_P);                    \
  190.   CHECK_ARG (5, GROUP_P);                        \
  191.   group = (ARG_REF (5));                        \
  192.   match_start = (arg_nonnegative_integer (6));                \
  193.   match_end = (arg_nonnegative_integer (7));                \
  194.   text = (STRING_LOC ((GROUP_TEXT (group)), 0));            \
  195.   text_start = (MARK_INDEX (GROUP_START_MARK (group)));            \
  196.   text_end = (MARK_INDEX (GROUP_END_MARK (group)));            \
  197.   gap_start = (GROUP_GAP_START (group));                \
  198.   if (text_end > gap_start)                        \
  199.     text_end += (GROUP_GAP_LENGTH (group));                \
  200.   if (match_end > gap_start)                        \
  201.     {                                    \
  202.       match_end += (GROUP_GAP_LENGTH (group));                \
  203.       if (match_start >= gap_start)                    \
  204.     match_start += (GROUP_GAP_LENGTH (group));            \
  205.     }                                    \
  206.   if (match_start > match_end) error_bad_range_arg (6);            \
  207.   if (match_end > text_end) error_bad_range_arg (7);            \
  208.   if (match_start < text_start) error_bad_range_arg (6);        \
  209.   re_max_failures = 20000;                        \
  210.   re_buffer_initialize                            \
  211.     ((& buffer), (STRING_LOC ((ARG_REF (2)), 0)), (ARG_REF (3)),    \
  212.      text, text_start, text_end, gap_start, (GROUP_GAP_END (group)));    \
  213.   result =                                \
  214.     (procedure ((STRING_LOC (regexp, 0)),                \
  215.         (STRING_LOC (regexp, (STRING_LENGTH (regexp)))),    \
  216.         (& buffer),                        \
  217.         (((ARG_REF (4)) == SHARP_F) ? NULL : (& registers)),    \
  218.         (& (text [match_start])),                \
  219.         (& (text [match_end]))));                \
  220.   RE_MATCH_RESULTS (result, (ARG_REF (4)));                \
  221. }
  222.  
  223. DEFINE_PRIMITIVE ("RE-MATCH-BUFFER", Prim_re_match_buffer, 7, 7, 0)
  224.      RE_BUFFER_PRIMITIVE (re_match)
  225.  
  226. DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-FORWARD", Prim_re_search_buffer_forward, 7, 7, 0)
  227.      RE_BUFFER_PRIMITIVE (re_search_forward)
  228.  
  229. DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-BACKWARD", Prim_re_search_buffer_backward, 7, 7, 0)
  230.      RE_BUFFER_PRIMITIVE (re_search_backward)
  231.