home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Extensions / sregexp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-16  |  2.5 KB  |  117 lines
  1. /*
  2.  * sregexp.c -- Regular expressions for STk.
  3.  * tromey Fri Jul 22 1994
  4.  *
  5.  */
  6.  
  7. #include <stk.h>
  8. #include "tclRegexp.h"
  9.  
  10. /*
  11.  * Regular expression type.  A regular expression is a function that
  12.  * takes one argument.  It returns #f if no match, or a regular
  13.  * expression match object on match.
  14.  */
  15.  
  16. static void free_regexp (SCM ht);
  17. static SCM apply_regexp (SCM x, SCM args, SCM env);
  18.  
  19. static int tc_regexp;
  20.  
  21. static STk_extended_scheme_type regexp_type = {
  22.   "regexp",            /* name */
  23.   EXT_ISPROC | EXT_EVALPARAM,    /* flags */
  24.   NULL,                /* gc_mark_fct */
  25.   free_regexp,            /* gc_sweep_fct */
  26.   apply_regexp,            /* apply_fct */
  27.   NULL,                /* display_fct */
  28.   NULL                /* compare_fct */
  29. };
  30.  
  31. #define REGEXP(x)     ((struct regexp *) (x)->storage_as.extension.data)
  32. #define REGEXPP(x)     (TYPEP((x), tc_regexp))
  33.  
  34. /*
  35.  * GC interface.
  36.  */
  37.  
  38. static void free_regexp (SCM reg)
  39. {
  40.   free (REGEXP (reg));
  41. }
  42.  
  43. /*
  44.  * Return #t if object is a regexp, #f otherwise.
  45.  */
  46. static PRIMITIVE regexp_p(SCM obj)
  47. {
  48.   return (REGEXPP (obj) ? Truth : Ntruth);
  49. }
  50.  
  51. /*
  52.  * Return compiled form of regexp represented by string.  Error if not
  53.  * a string, or if regexp has a syntax error.
  54.  */
  55. static PRIMITIVE string_to_regexp (SCM obj)
  56. {
  57.   struct regexp *r;
  58.   SCM z;
  59.  
  60.   if (NSTRINGP (obj)) err ("not a string", obj);
  61.   
  62.   if ((r=TclRegComp(CHARS (obj))) == NULL)
  63.     Err("string->regexp: error compiling regexp", obj);
  64.   
  65.   /* Regexp is Ok. Make a new cell and return it */
  66.   NEWCELL(z, tc_regexp);
  67.   z->storage_as.extension.data = (void *) r;
  68.   return z;
  69. }
  70.  
  71. /*
  72.  * Try to match string against regular expression.  Returns sub-match
  73.  * object, or #f if no match.
  74.  */
  75. static PRIMITIVE apply_regexp(SCM regexp, SCM l, SCM env)
  76. {
  77.   SCM string;
  78.   char *the_chars;
  79.  
  80.   if (STk_llength (l) != 1) err ("apply: bad number of args", l);
  81.   string = CAR (l);
  82.  
  83.   if (NSTRINGP (string)) err ("regexp: bad string", string);
  84.   the_chars = CHARS (string);
  85.   
  86.   if (TclRegExec(REGEXP(regexp), the_chars, the_chars)) {
  87.     struct regexp *r = REGEXP(regexp);
  88.     SCM z         = NIL;
  89.     int i;
  90.     
  91.     /* Find the length of the result */
  92.     for (i=0; r->startp[i]; i++) {/*Nothing*/}
  93.  
  94.     /* Build result */
  95.     for (--i; i >= 0; i--) {
  96.       z = Cons(LIST2(STk_makeinteger(r->startp[i]-the_chars), 
  97.              STk_makeinteger(r->endp[i]-the_chars)),
  98.            z);
  99.     }
  100.     return z;
  101.   }
  102.   return Ntruth;
  103. }
  104.  
  105. /*
  106.  * Initialization.
  107.  */
  108.  
  109. PRIMITIVE STk_init_sregexp(void)
  110. {
  111.   tc_regexp = STk_add_new_type (®exp_type);
  112.  
  113.   STk_add_new_primitive ("string->regexp", tc_subr_1, string_to_regexp);
  114.   STk_add_new_primitive ("regexp?", tc_subr_1, regexp_p);
  115.   return UNDEFINED;
  116. }
  117.