#|-------------------- 1.1 |# "./agrep.meta" 541
;; -*- Hen -*-

((egg "agrep.egg") ; This should never change

 ; List here all the files that should be bundled as part of your egg.  

 (files "agrep.setup" "agrep.scm" "skeleton.h" "engine.scm" "agrep.meta" "tests/run.scm")

 ; Your egg's license:

 (license "GPL-3")

 ; Pick one from the list of categories (see below) for your egg and
 ; enter it here.

 (category data)

 ; A list of eggs agrep depends on.

 (needs easyffi datatype)

 (test-depends test)

 (doc-from-wiki)

 (author "Ivan Raikov")

 (synopsis "Approximate grep."))


#|-------------------- 1.1 |# "./agrep.scm" 10478
;;
;; Approximate grep library. Code ported from the Caml agrep library by
;; Xavier Leroy.
;;
;;
;; Copyright 2009-2010 Ivan Raikov and the Okinawa Institute of Science and
;; 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 3 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.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;


(module agrep

	(string-match
	 substring-match
	 errors-substring-match
	 pattern
	 string->pattern
	 iso8859_15_case_insensitive
	 iso8859_15_accent_insensitive	 
	 iso8859_15_case_and_accent_insensitive	 
	 )

	(import scheme chicken)
	(require-extension datatype )
	(require-library srfi-1 srfi-4 srfi-13 srfi-14)
	(import (only srfi-1 every fold)
		(only srfi-4 make-u32vector u32vector? )
		(only srfi-13 string-length)
		srfi-14)

(include "engine.scm")


;; Deep syntax for patterns 

(define-datatype pattern pattern?
  (CBase (len integer?) (bm u32vector?))
  (CAnd  (p1 pattern?)  (p2 pattern?))
  (COr   (p1 pattern?)  (p2 pattern?)))
  

;; String matching 

(define (string-match pat text #!key (numerrs 0) (wholeword #f))
  (if (negative? numerrs) (error 'string-match "numerrs < 0"))
  (let recur ((pat pat))
    (cases pattern pat
	   (CBase (len bm)
		  (agrep-match text 0 (string-length text) len bm numerrs wholeword))
	   (CAnd (p1 p2)
		 (and (recur p1) (recur p2)))
	   (Cor (p1 p2)
		(or (recur p1) (recur p2))))))

(define (substring-match pat text pos len  #!key (numerrs 0) (wholeword #f))
  (if (or (< pos 0) (< (string-length text) (+ pos len)))
      (error 'substring-match "invalid pos len arguments" pos len))
  (if (negative? numerrs) (error 'string-match "numerrs < 0"))
  (let recur ((pat pat))
    (cases pattern pat
	   (CBase (plen bm)
		  (agrep-match text pos len plen bm numerrs wholeword))
	   (CAnd (p1 p2)
		 (and (recur p1) (recur p2)))
	   (Cor (p1 p2)
		(or (recur p1) (recur p2))))))
    

(define (errors-substring-match pat text pos len #!key (numerrs 0) (wholeword #f))
  (if (or (< pos 0) (< (string-length text) (+ pos len)))
      (error 'substring-match "invalid pos len arguments" pos len))
  (if (negative? numerrs) (error 'string-match "numerrs < 0"))
  (let recur ((pat pat))
    (cases pattern pat
	   (CBase (plen bm)
		  (agrep-match text pos len plen bm numerrs wholeword))
	   (CAnd (p1 p2)
		 (max (recur p1) (recur p2)))
	   (Cor (p1 p2)
		(min (recur p1) (recur p2))))))



;; Shallow syntax for patterns 

(define-datatype simple-pattern simple-pattern?
  (Char (c char?))
  (String (s string?))
  (Charset (cs char-set?))
  (Wildcard))

(define-datatype complex-pattern complex-pattern?
  (Simple (ps (lambda (x) (every simple-pattern? x))))
  (PAnd (p1 complex-pattern?) (p2 complex-pattern?))
  (POr (p1 complex-pattern?) (p2 complex-pattern?)))


;; Compilation of shallow syntax into deep syntax 

(define (add-char transl bm len c r)
  (if (not transl)
      (let ((t (char->integer c)))
	(agrep-set-bit bm len t r))
      (let ((t (transl c)))
	(agrep-set-bit bm len t r))))


(define (simple-pattern-len sp)
  (fold (lambda (p len)
	  (cases simple-pattern p
		 (Char (c)      (+ 1 len))
		 (String (s)    (+ (string-length s) len))
		 (Charset (cs)  (+ 1 len))
		 (Wildcard ()   len)))
	  0 sp))

(define (compile-simple-pattern sp #!key (transl #f) (nentries 257))
  (let* ((len (simple-pattern-len sp))
	 (bm  (agrep-alloc-bitmatrix len (+ 1 nentries))))
    (let fill ((pos 0) (sp sp))
      (if (pair? sp)
	  (cases simple-pattern (car sp)
		 (Char (c)
		       (add-char transl bm len c pos)
		       (fill (+ 1 pos) (cdr sp)))
		 (String (s)
			 (let ((pos1 (fold (lambda (c pos) (add-char transl bm len c pos)
						   (+ 1 pos))
					   pos (string->list s))))
			   (fill pos1 (cdr sp))))
		 (Charset (cs)
			  (for-each (lambda (c) (add-char transl bm len c pos))
				    (char-set->list cs))
			  (fill (+ 1 pos) (cdr sp)))
		 (Wildcard ()
			   (agrep-set-bit bm len nentries pos)
			   (fill pos (cdr sp))))
	  '()))
    (CBase len bm)))
		 
(define (compile-pattern pat #!key (transl #f) (nentries 257))
  (cases complex-pattern pat
	 (Simple (sp)   (compile-simple-pattern sp transl: transl nentries: nentries))
	 (PAnd (p1 p2)  (CAnd (compile-pattern p1 transl: transl nentries: nentries) 
			      (compile-pattern p2 transl: transl nentries: nentries)))
	 (POr (p1 p2)   (COr  (compile-pattern p1 transl: transl nentries: nentries)
			      (compile-pattern p2 transl: transl nentries: nentries)))))



;; From concrete syntax to shallow abstract syntax 

(define (parse-pattern s)

  (define (parse-class cls lst)
    (cond ((null? lst) 
	   (error 'parse-pattern "syntax error"))
	  ((eq? (car lst) #\]) 
	   (values cls (cdr lst)))
	  ((and (eq? (car lst) #\\) (pair? (cdr lst)))
	   (parse-class (char-set-union cls (char-set (cadr lst))) (cddr lst)))
	  ((and (pair? (cdr lst)) (pair? (cddr lst))
		(eq? (cadr lst) #\-) (not (eq? (caddr lst) #\])))
	   (let ((l (char->integer (car lst))) (u (char->integer (caddr lst))))
	     (values (char-set-union cls (ucs-range->char-set  l u)) (cdddr lst))))
	  (else
	   (values (char-set-union cls (char-set (car lst))) (cdr lst)))))

  (define (parse-char-class lst)
    (let ((cls (char-set)))
      (cond ((and (pair? lst) (eq? (car lst) #\^))
	     (let-values (((cls j) (parse-class cls (cdr lst))))
	       (values (char-set-complement cls) j)))
	    (else
	     (parse-class cls lst)))))


  (define (parse-simple-list sl lst)
    (if (null? lst)  (values sl lst)
	(case (car lst)
	  ((#\) #\| #\&)  (values sl lst))
	  ((#\()
	   (error 'parse-pattern "syntax error" lst))
	  ((#\?)
	   (parse-simple-list (cons (Charset char-set:full) sl) (cdr lst)))
	  ((#\*)
	   (parse-simple-list (cons (Wildcard) sl) (cdr lst)))
	  ((#\\)
	   (parse-simple-list (cons (Char (cadr lst)) sl) (cddr lst)))
	  ((#\[)
	   (let-values (((cls lst1)  (parse-char-class (cdr lst))))
	     (parse-simple-list (cons (Charset cls) sl) lst1)))
	  (else
	   (parse-simple-list (cons (Char (car lst)) sl) (cdr lst))))))

  (define (parse-base lst)
    (if (null? lst) (values (Simple '()) lst)
	(let ((s (car lst)))
	  (case s
	    ((#\) #\| #\&)  (values (Simple '()) lst))
	    ((#\()   
	     (let-values (((p lst1) (parse-or (cdr lst))))
	       (values p lst1)))
	    (else
	     (let-values (((sl lst1)  (parse-simple-list '() lst)))
	       (values (Simple (reverse sl)) lst1)))))))

  (define (parse-ands p1 lst)
    (if (null? lst) (values p1 lst)
        (let ((s (car lst)))
          (case s
                ((#\) #\|)  (values p1 lst))
                ((#\&)     
                 (let-values (((p2 lst2)  (parse-base (cdr lst) )))
                    (parse-ands (PAnd p1 p2) lst2)))
                (else (error 'parse-pattern "syntax error" lst))))))


  (define (parse-and lst)
    (let-values (((p1 lst1) (parse-base lst)))
      (parse-ands p1 lst1)))



  (define (parse-ors p1 lst1)
    (if (null? lst1)  (values p1 lst1)
	(let ((s (car lst1)))
	  (case s
	    ((#\))  (values p1 lst1))
	    ((#\|)  (let-values (((p2 lst2) (parse-and (cdr lst1))))
		      (parse-ors (POr p1 p2) lst2)))
	    (else   (error 'parse-pattern "syntax error in pattern" lst1))))))

  (define (parse-or lst)
    (let-values (((p1 lst1) (parse-and lst)))
      (parse-ors p1 lst1)))

  (let ((lst (string->list s)))
    (let-values (((p lst1) (parse-or lst)))
       (assert (null? lst1))
       p)))


(define (pattern s #!key (transl #f))
  (compile-pattern (parse-pattern (string->list s)) transl: transl))

(define (string->pattern s #!key (transl #f))
  (compile-pattern (Simple (list (String s))) transl: transl))


;; Translation tables for ISO 8859-15 (Latin 1 with Euro) 

(define iso8859_15_case_insensitive
  (let ((case_insensitive 
	 (list->vector (string->list "\u0000\u0001\u0002\u0003\u0004\u0005\u0006\u0007\u0008\t\n\u0011\u0012\u0013\u0014\u0015\u0016\u0017\u0018\u0019\u0020\u0021\u0022\u0023\u0024\u0025\u0026\u0027\u0028\u0029\u0030\u0031 !\"#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\u0127\u0128\u0129\u0130\u0131\u0132\u0133\u0134\u0135\u0136\u0137\u0138\u0139\u0140\u0141\u0142\u0143\u0144\u0145\u0146\u0147\u0148\u0149\u0150\u0151\u0152\u0153\u0154\u0155\u0156\u0157\u0158\u0159 ¡¢£¤¥¨§¨©ª«¬­®¯°±²³¸µ¶·¸¹º»½½ÿ¿àáâãäåæçèéêëìíîïðñòóôõö×øùúûüýþßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ"))))
    (lambda (c) (vector-ref case_insensitive (char->integer c)))
    ))

(define iso8859_15_accent_insensitive
  (let ((accent_insensitive 
	 "\u0000\u0001\u0002\u0003\u0004\u0005\u0006\u0007\u0008\t\n\u0011\u0012\u0013\u0014\u0015\u0016\u0017\u0018\u0019\u0020\u0021\u0022\u0023\u0024\u0025\u0026\u0027\u0028\u0029\u0030\u0031 !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\u0127\u0128\u0129\u0130\u0131\u0132\u0133\u0134\u0135\u0136\u0137\u0138\u0139\u0140\u0141\u0142\u0143\u0144\u0145\u0146\u0147\u0148\u0149\u0150\u0151\u0152\u0153\u0154\u0155\u0156\u0157\u0158\u0159 ¡¢£¤¥S§s©ª«¬­®¯°±²³Zµ¶·z¹º»OoY¿AAAAAAACEEEEIIIIÐNOOOOO×OUUUUYÞsaaaaaaaceeeeiiiiðnooooo÷ouuuuyþy"))
    (lambda (c) (vector-ref accent_insensitive (char->integer c)))
    ))

(define iso8859_15_case_and_accent_insensitive
  (let ((case_and_accent_insensitive 
	 "\u0000\u0001\u0002\u0003\u0004\u0005\u0006\u0007\u0008\t\n\u0011\u0012\u0013\u0014\u0015\u0016\u0017\u0018\u0019\u0020\u0021\u0022\u0023\u0024\u0025\u0026\u0027\u0028\u0029\u0030\u0031 !\"#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\u0127\u0128\u0129\u0130\u0131\u0132\u0133\u0134\u0135\u0136\u0137\u0138\u0139\u0140\u0141\u0142\u0143\u0144\u0145\u0146\u0147\u0148\u0149\u0150\u0151\u0152\u0153\u0154\u0155\u0156\u0157\u0158\u0159 ¡¢£¤¥s§s©ª«¬­®¯°±²³zµ¶·z¹º»ooy¿aaaaaaaceeeeiiiiðnooooo×ouuuuyþsaaaaaaaceeeeiiiiðnooooo÷ouuuuyþy"))
    (lambda (c) (vector-ref case_and_accent_insensitive (char->integer c)))
    ))


)



#|-------------------- 1.1 |# "./agrep.setup" 464
;; -*- Hen -*-

(define (dynld-name fn)		
  (make-pathname #f fn ##sys#load-dynamic-extension))	

(compile -O -d2 -I. -s agrep.scm  -X easyffi -j agrep) 
(compile -O2 -d0 -s agrep.import.scm)

(install-extension

  ; Name of your extension:
  'agrep

  ; Files to install for your extension:
  `(,(dynld-name "agrep") ,(dynld-name "agrep.import") 
    )

  ; Assoc list with properties for your extension:
  `((version 1.1)
    (documentation "agrep.html")))
    

#|-------------------- 1.1 |# "./engine.scm" 9014
;;
;; Chicken agrep library interface. Code ported from the Caml agrep
;; library by Xavier Leroy.
;;
;;
;; Copyright 2009-2010 Ivan Raikov and the Okinawa Institute of Science and
;; 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 3 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.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;

(import scheme chicken foreign srfi-4)

;; Error handling, initialization and finalization

;; The following three functions are borrowed from the
;; Chicken-specific parts of SWIG
#>
static void chicken_Panic (C_char *) C_noret;
static void chicken_Panic (C_char *msg)
{
  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
  C_word scmmsg = C_string2 (&a, msg);
  C_halt (scmmsg);
  exit (5); /* should never get here */
}

static void chicken_ThrowException(C_word value) C_noret;
static void chicken_ThrowException(C_word value)
{
  char *aborthook = C_text("\003sysabort");

  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
  C_word abort = C_intern2(&a, aborthook);

  abort = C_block_item(abort, 0);
  if (C_immediatep(abort))
    chicken_Panic(C_text("`##sys#abort' is not defined"));

  C_save(value);
  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
}

void chicken_agrep_exception (int code, int msglen, const char *msg) 
{
  C_word *a;
  C_word scmmsg;
  C_word list;

  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
  scmmsg = C_string2 (&a, (char *) msg);
  list = C_list(&a, 2, C_fix(code), scmmsg);
  chicken_ThrowException(list);
}

<#

; Include into generated code, but don't parse:
#>

#include <stdlib.h>
#include <string.h>
#include <errno.h>

typedef unsigned char uchar;
typedef unsigned int uint;

#define BITS_PER_WORD (8 * sizeof(unsigned int))
#define Setbit(ptr,nbit) \
  ((ptr)[(nbit) / BITS_PER_WORD] |= (1UL << ((nbit) % BITS_PER_WORD)))

unsigned char word_constituent[256] = {
  /* 0 - 31 */
     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  /*   ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */
     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,
  /* @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ \ ] ^ _ */
     0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,
  /* ` a b c d e f g h i j k l m n o p q r s t u v w x y z { | } ~ \127 */
     0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,
  /* 128-159 */
     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  /*   ¡ ¢ £ ¤ ¥ ¦ § ¨ © ª « ¬ ­ ® ¯ ° ± ² ³ ´ µ ¶ · ¸ ¹ º » ¼ ½ ¾ ¿ */
     0,0,0,0,0,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,1,0,0,0,1,1,1,0,
  /* À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö × Ø Ù Ú Û Ü Ý Þ ß */
     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1,
  /* à á â ã ä å æ ç è é ê ë ì í î ï ð ñ ò ó ô õ ö ÷ ø ù ú û ü ý þ ÿ */
     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1
};


/* Specialized versions of string matching code */

#undef WHOLE_WORD

#define FUNCTION_NAME match_0errs
#define NERRS 0
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define FUNCTION_NAME match_1errs
#define NERRS 1
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define FUNCTION_NAME match_2errs
#define NERRS 2
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define FUNCTION_NAME match_3errs
#define NERRS 3
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define WHOLE_WORD

#define FUNCTION_NAME match_word_0errs
#define NERRS 0
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define FUNCTION_NAME match_word_1errs
#define NERRS 1
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define FUNCTION_NAME match_word_2errs
#define NERRS 2
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

#define FUNCTION_NAME match_word_3errs
#define NERRS 3
#include "skeleton.h"
#undef FUNCTION_NAME
#undef NERRS

<#

(define BITS-PER-WORD (foreign-value "BITS_PER_WORD" int))

;; Allocate bit matrix object

(define (agrep-alloc-bitmatrix patlen nentries)
  (let* ((nwords  (fx/ (fx+ patlen (fx- BITS-PER-WORD 1)) BITS-PER-WORD))
	 (size    (+ nwords nentries)))
    (make-u32vector size 0)))


(define agrep-set-bit
  (foreign-lambda* void  ((u32vector matrix) 
			  (unsigned-int v_patlen)
			  (unsigned-int v_index)
			  (unsigned-int v_bitnum))
#<<END
  uint nwords = (v_patlen + BITS_PER_WORD - 1) / BITS_PER_WORD;

  Setbit((unsigned int *) (matrix + nwords * v_index), v_bitnum);

  C_return (C_SCHEME_UNDEFINED);
END
))

#>

void *stat_alloc (size_t size)
{
   void *p;

   if ((p = malloc (size)) == NULL)
     { 
        chicken_agrep_exception (ENOMEM, 25, "unable to allocate memory"); 
     }

   return p;
}

void stat_free (void *p)
{

   if (p == NULL)
     { 
        chicken_agrep_exception (EINVAL, 18, "null pointer freed"); 
     }

   free (p);
}

/* General code: arbitrary errors, arbitrary pattern length */

uint match_general(uint * table, uint m,
	           uint nerrs, int wholeword,
         	   uchar * text, size_t length)
{
  uint  nwords, n, j;
  uint  ** R;
  uint  * Rpbefore;
  uint  Found_offset, Found_mask;
  uint  * Ssharp;
  uint  * Rc, * Rp;
  uint  carry;
  uint  match_empty;
  int   retcode;

  nwords = (m + BITS_PER_WORD - 1) / BITS_PER_WORD;
  R = stat_alloc((nerrs + 1) * sizeof(uint *));
  for (n = 0; n <= nerrs; n++) 
	 R[n] = stat_alloc(nwords * sizeof(uint));
  Rpbefore = stat_alloc(nwords * sizeof(uint));

  /* Initialize Found */
  Found_offset = m / BITS_PER_WORD;
  Found_mask = 1UL << (m % BITS_PER_WORD);
  /* Initialize R */
  for (n = 0; n <= nerrs; n++) 
  {
    memset(R[n], 0, nwords * sizeof(uint));
    for (j = 0; j <= n; j++) Setbit(R[n], j);
  }
  /* Initialize Ssharp & match_empty */
  Ssharp = table + 256 * nwords;
  match_empty = 1;
  /* Main loop */
  for (/*nothing*/; length > 0; length--, text++) {
    uint * S = table + (*text) * nwords;
    if (wholeword)
      match_empty = word_constituent[text[0]] ^ word_constituent[text[1]];
    /* Special case for 0 errors */
    Rc = R[0];
    carry = match_empty;
    for (j = 0; j < nwords; j++) {
      uint Rcbefore = Rc[j];
      uint toshift = Rcbefore & S[j];
      Rc[j] = (toshift << 1) | (Rcbefore & Ssharp[j]) | carry;
      carry = toshift >> (BITS_PER_WORD - 1);
      Rpbefore[j] = Rcbefore;
    }
    if (Rc[Found_offset] & Found_mask && match_empty)
      { retcode = 0; goto exit; }
    /* General case for > 0 errors */
    for (n = 1; n <= nerrs; n++) {
      Rp = Rc;
      Rc = R[n];
      carry = match_empty;
      for (j = 0; j < nwords; j++) {
        uint Rcbefore = Rc[j];
        uint toshift = (Rcbefore & S[j]) | Rpbefore[j] | Rp[j];
        Rc[j] = (toshift << 1)
              | Rpbefore[j]
              | (Rcbefore & Ssharp[j])
              | carry;
        carry = toshift >> (BITS_PER_WORD - 1);
        Rpbefore[j] = Rcbefore;
      }
      if (Rc[Found_offset] & Found_mask && match_empty)
        { retcode = n; goto exit; }
    }
  }

  /* Not found */
  retcode = C_WORD_MAX;

  /* Cleanup */
 exit:
  for (n = 0; n <= nerrs; n++) stat_free(R[n]);
  stat_free(R);
  stat_free(Rpbefore);

  return retcode;
}
<#



(define agrep-match 
    (foreign-primitive scheme-object ((c-string v_text)
				      (unsigned-int v_ofs)
				      (unsigned-int v_len)
				      (unsigned-int v_patlen)
				      (u32vector v_table)
				      (unsigned-int v_nerrs)
				      (bool v_wholeword))
						    
#<<END
  uchar * text = (v_text+v_ofs);
  size_t len   = v_len;
  uint patlen  = v_patlen;

  if (patlen < BITS_PER_WORD) 
  {
    switch (((v_nerrs) << 1) | v_wholeword) 
    {
     case 2*0+0: C_return(C_fix( match_0errs((uint *)v_table, patlen, text, len)));
     case 2*0+1: C_return(C_fix( match_word_0errs((uint *) v_table, patlen, text, len)));
     case 2*1+0: C_return(C_fix( match_1errs((uint *) v_table, patlen, text, len)));
     case 2*1+1: C_return(C_fix( match_word_1errs((uint *) v_table, patlen, text, len)));
     case 2*2+0: C_return(C_fix( match_2errs((uint *) v_table, patlen, text, len)));
     case 2*2+1: C_return(C_fix( match_word_2errs((uint *) v_table, patlen, text, len)));
     case 2*3+0: C_return(C_fix( match_3errs((uint *) v_table, patlen, text, len)));
     case 2*3+1: C_return(C_fix( match_word_3errs((uint *) v_table, patlen, text, len)));
    }
  }
  C_return(C_fix(match_general((uint *) v_table, patlen,
                               v_nerrs, v_wholeword,
                               text, len)));
END
))

#|-------------------- 1.1 |# "./skeleton.h" 2501
/***********************************************************************/
/*                                                                     */
/*            The "agrep" library for Objective Caml                   */
/*                                                                     */
/*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            */
/*                                                                     */
/*  Copyright 2002 Institut National de Recherche en Informatique et   */
/*  en Automatique.  All rights reserved.  This file is distributed    */
/*  under the terms of the GNU Library General Public License.         */
/*                                                                     */
/***********************************************************************/

#ifndef ulong
#define ulong unsigned long
#endif

static unsigned int FUNCTION_NAME(uint * table, size_t pattern_length,
			          uchar * text, size_t length)
{
  ulong R0;
#if NERRS >= 1
  ulong R1, R0before;
#endif
#if NERRS >= 2
  ulong R2, R1before;
#endif
#if NERRS == 3
  ulong R3, R2before;
#endif
  ulong Found, Ssharp;
#ifdef WHOLE_WORD
  ulong word_boundary;
#endif

  Ssharp = table[256];
  Found = 1UL << pattern_length;
  R0 = 1;
#if NERRS >= 1
  R1 = 3;
#endif
#if NERRS >= 2
  R2 = 7;
#endif
#if NERRS == 3
  R3 = 0xF;
#endif
  for (/*nothing*/; length > 0; length--, text++) {
    ulong S = table[*text];
#if NERRS >= 1
    R0before = R0;
#endif
#if NERRS >= 2
    R1before = R1;
#endif
#if NERRS == 3
    R2before = R2;
#endif
#ifdef WHOLE_WORD
    word_boundary = word_constituent[text[0]] ^ word_constituent[text[1]];
#  define MATCH_EMPTY word_boundary
#else
#  define MATCH_EMPTY 1
#endif
    R0 = ((R0 & S) << 1) | (R0 & Ssharp) | MATCH_EMPTY;
#if NERRS >= 1
    R1 = (((R1 & S) | R0before | R0) << 1) 
         | R0before
         | (R1 & Ssharp)
         | MATCH_EMPTY;
#endif
#if NERRS >= 2
    R2 = (((R2 & S) | R1before | R1) << 1) 
         | R1before
         | (R2 & Ssharp)
         | MATCH_EMPTY;
#endif
#if NERRS == 3
    R3 = (((R3 & S) | R2before | R2) << 1) 
         | R2before
         | (R3 & Ssharp)
         | MATCH_EMPTY;
#endif
    if ((R0 & Found) && MATCH_EMPTY) return (0);
#if NERRS >= 1
    if ((R1 & Found) && MATCH_EMPTY) return (1);
#endif
#if NERRS >= 2
    if ((R2 & Found) && MATCH_EMPTY) return (2);
#endif
#if NERRS == 3
    if ((R3 & Found) && MATCH_EMPTY) return (3);
#endif
  }
  return (C_WORD_MAX);
}

#undef MATCH_EMPTY