1(foreign-declare "2 #include <assert.h>3 #include <stdlib.h>4 #include <stdbool.h>5 #include <regex.h>67 #include <sys/types.h>89 regmatch_t *10 make_submatches(size_t n)11 {12 regmatch_t *r;1314 if (!(r = malloc(sizeof(*r) * n)))15 return NULL;1617 return r;18 }1920 void21 submatches_free(regmatch_t *pmatch)22 {23 free(pmatch);24 }2526 regmatch_t *27 submatches_get(size_t nmatch, regmatch_t *pmatch, size_t idx)28 {29 if (idx >= nmatch)30 return NULL;3132 return &pmatch[idx];33 }3435 ssize_t36 submatch_start(regmatch_t *m)37 {38 return (ssize_t)m->rm_so;39 }4041 ssize_t42 submatch_end(regmatch_t *m)43 {44 return (ssize_t)m->rm_eo;45 }4647 regex_t *48 make_regex(int *err, char *pattern, bool igncase, bool ext, bool nl)49 {50 int r;51 int cflags;52 regex_t *re;5354 cflags = 0;55 if (igncase) cflags |= REG_ICASE;56 if (ext) cflags |= REG_EXTENDED;57 if (nl) cflags |= REG_NEWLINE;5859 if (!(re = malloc(sizeof(*re)))) {60 *err = REG_ESPACE;61 return NULL;62 }63 if ((r = regcomp(re, pattern, cflags))) {64 *err = r;65 return NULL;66 }6768 return re;69 }7071 void72 regex_free(regex_t *re)73 {74 regfree(re);75 free(re);76 }7778 size_t79 regex_subexprs(regex_t *re)80 {81 return re->re_nsub;82 }8384 char *85 regex_error(regex_t *re, int err)86 {87 int r;88 char *buf;89 int bufsiz;9091 /* Find out how big a buffer is needed and alloc it. */92 bufsiz = regerror(err, re, (char *)NULL, (size_t)0);93 assert(bufsiz > 0);94 if (!(buf = malloc(bufsiz)))95 return NULL;9697 r = regerror(err, re, buf, bufsiz);98 assert(r <= bufsiz);99 (void)r; /* NDEBUG */100101 return buf;102 }103104 int105 regex_exec(regex_t* re, char *string, size_t nmatch, regmatch_t *pmatch, bool notbol, bool noteol)106 {107 int r;108 int eflags;109110 eflags = 0;111 if (notbol) eflags |= REG_NOTBOL;112 if (noteol) eflags |= REG_NOTEOL;113114 return regexec(re, string, nmatch, pmatch, eflags);115 }116")117118;; Constants from regex.h119(define regex-ok 0)120(define regex-nomatch (foreign-value "REG_NOMATCH" int))121122;; Type alias for R7RS bytevectors (not exported by the R7RS egg).123;; See: https://bugs.call-cc.org/ticket/1796124(define-type bytevector u8vector)125126;; Wrapper around the {{regex_t*}} raw C pointer, created to allow127;; utilizing CHICKEN type annotations for {{regex_t*}} values.128129(define-record-type Regex130 (%make-regex ptr)131 regex?132 (ptr regex-pointer))133134;; Convenience type alias135(define-type regex (struct Regex))136137;; Type annotations for Regex type constructor and accessors.138(: %make-regex (pointer -> regex))139(: regex-pointer (regex -> pointer))140141;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;142143;; Wrapper around {{regmatch_t*}} raw C pointer which additionally144;; tracks the amount of allocated submatches (which must not be equal145;; to the amount of matched submatches).146147(define-record-type Submatches148 (%make-submatches ptr count)149 submatches?150 (ptr submatches-pointer)151 (count submatches-count))152153;; Type annotations for Submatches type constructor and accessors.154(: %make-submatches (pointer integer -> (struct Submatches)))155(: submatches-pointer ((struct Submatches) -> pointer))156(: submatches-count ((struct Submatches) -> integer))157158;; Submatch is either a boolean (#f) for a non-matching optional159;; submatch or a pair of bytevector offsets.160(define-type submatch (or false (pair integer integer)))161162;; Convenience type alias for vector of submatches.163(define-type submatch-vector (vector-of submatch))164165;; Allocate memory to store the correct amount of submatches for166;; a given regular expression.167168(: make-submatches (regex -> (struct Submatches)))169(define (make-submatches regex)170 (define %%make-submatches171 (foreign-lambda c-pointer "make_submatches" size_t))172173 (let* ((n (+ (regex-subexprs regex) 1)) ;; reserve space for zero subexpression174 (p (%%make-submatches n)))175 (if p176 (begin177 (set-finalizer! p submatches-free)178 (%make-submatches p n))179 (error "out of memory"))))180181;; Free memory allocated for a raw {{regmatch_t*}} pointer. Invoked182;; automatically via a CHICKEN garbage collector finalizer.183184(: submatches-free (pointer -> undefined))185(define (submatches-free pointer)186 (define %submatches-free187 (foreign-lambda void "submatches_free" nonnull-c-pointer))188189 (%submatches-free pointer))190191;; Retrieve a single submatch by index. The zero index refers to the192;; substring that corresponds to the entire regular expression. As such,193;; actual submatches start at index 1.194195(: submatches-get ((struct Submatches) integer -> pointer))196(define (submatches-get subm idx)197 (define %submatches-get198 (foreign-lambda c-pointer "submatches_get" size_t nonnull-c-pointer size_t))199200 (let* ((ptr (submatches-pointer subm))201 (cnt (submatches-count subm))202 (ret (%submatches-get cnt ptr idx)))203 (if ret204 ret205 (error (string-append "out of bounds submatch: " (number->string idx))))))206207;; Retrieve the start byte offset of a given submatch.208209(: submatch-start (pointer -> integer))210(define (submatch-start match)211 (define %submatch-start212 (foreign-lambda ssize_t "submatch_start" nonnull-c-pointer))213214 (%submatch-start match))215216;; Retrieve the end byte offset of a given submatch.217218(: submatch-end (pointer -> integer))219(define (submatch-end match)220 (define %submatch-end221 (foreign-lambda ssize_t "submatch_end" nonnull-c-pointer))222223 (%submatch-end match))224225;; Convert single submatch to a pair or a boolean (in the case226;; of a non-matching optional submatch).227228(: ->submatch (pointer -> submatch))229(define (pointer->submatch pointer)230 (let ((start (submatch-start pointer))231 (end (submatch-end pointer)))232 (if (and (eqv? start -1) (eqv? end -1))233 #f234 (cons start end))))235236;; Convert encountered submatches to a vector.237238(: submatches->vector ((struct Submatches) -> submatch-vector))239(define (submatches->vector subm)240 (define (%submatches->vector idx vec)241 (if (>= idx (submatches-count subm))242 idx243 (let ((sptr (submatches-get subm idx)))244 (vector-set! vec idx (pointer->submatch sptr))245 (%submatches->vector (+ idx 1) vec))))246247 (let* ((vec (make-vector (submatches-count subm)))248 (matched (%submatches->vector 0 vec)))249 ;; Resize vector to actual amount of matched submatches.250 (vector-copy vec 0 matched)))251252;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;253254;;> Returns a pre-compiled regular expression object for the given255;;> {{pattern}}. The optional arguments {{ignorecase}} and {{extended}}256;;> specify whether the case should be ignored during matching and if ERE257;;> (instead of BRE) syntax should be used. The remaining {{multiline}}258;;> optional argument will cause the string to be treated as multiple259;;> lines (affects handling of {{^}} and {{$}}). If an error occurs260;;> during regex compilation, an exception is raised.261262(: make-regex (string #!optional boolean boolean boolean -> regex))263(define (make-regex pattern #!optional ignorecase extended multiline)264 (define %%make-regex265 (foreign-lambda c-pointer "make_regex" (nonnull-c-pointer int) nonnull-c-string bool bool bool))266267 (let-location ((err integer 0))268 (let ((re (%%make-regex (location err) pattern ignorecase extended multiline)))269 (if re270 (begin271 (set-finalizer! re regex-free)272 (%make-regex re))273 (regex-error re err)))))274275;; Returns amount of subexpressions in given regular expressions.276277(: regex-subexprs (regex -> integer))278(define (regex-subexprs regex)279 (define %regex-subexprs280 (foreign-lambda size_t "regex_subexprs" nonnull-c-pointer))281282 (%regex-subexprs (regex-pointer regex)))283284;; Extracts error condition from given {{regex_t*}} pointer value285;; and associated error code as returned by {{regcomp(3)}}. This286;; procedure always raises an error.287288(: regex-error (pointer integer -> noreturn))289(define (regex-error regex err-code)290 (define %regex-error291 (foreign-lambda c-string* "regex_error" c-pointer int))292293 ;; Due to the c-string* type specifier, CHICKEN will copy memory294 ;; allocated for the error message to a temporary storage and295 ;; free it automatically.296 (let ((err-msg (%regex-error regex err-code)))297 (if err-msg298 (error (string-append "regex error: " err-msg))299 (error "out of memory"))))300301;; Low-Level wrapper around {{regexec(3)}} used internally by both302;; {{regex-exec}} and {{regex-match?}} (see documentation below).303;; Returns {{#t}} if the regex matches, {{#f}} if it doesn't, and raises304;; an error if {{regexec(3)}} failed.305306(: %regex-exec (regex string integer (or false pointer) boolean boolean -> boolean))307(define (%regex-exec regex string submatches-count submatches-ptr notbol noteol)308 (define %%regex-exec309 (foreign-lambda int "regex_exec" nonnull-c-pointer nonnull-c-string310 size_t c-pointer bool bool))311312 (let* ((p (regex-pointer regex))313 (r (%%regex-exec p string submatches-count submatches-ptr notbol noteol)))314 (cond315 ((eqv? r regex-ok) #t)316 ((eqv? r regex-nomatch) #f)317 (else (regex-error p r)))))318319;;> Execute the given {{regex}} on the given {{bytevector}}. Returns320;;> {{#f}} if the match failed, or a vector of matching subexpressions.321;;> In the vector, each element is either {{#f}} (for non-participating322;;> optional submatches) or a pair of bytevector offsets. The first323;;> element in the pair specifies the beginning of the submatch in the324;;> bytevector, the second element specifies the end of the submatch.325;;> The first pair in the vector corresponds to the matched substring326;;> for the entire regular expression.327;;>328;;> The optional {{notbol}} and {{noteol}} procedure arguments control329;;> whether the first/last character of the input should be considered330;;> the start/end of the line.331332(: regex-exec (regex bytevector #!optional boolean boolean -> (or false submatch-vector)))333(define (regex-exec regex bytevector #!optional notbol noteol)334 (let* ((subm (make-submatches regex))335 (scnt (submatches-count subm))336 (sptr (submatches-pointer subm)))337 (if (%regex-exec regex (utf8->string bytevector) scnt sptr notbol noteol)338 (submatches->vector subm)339 #f)))340341;;> Check whether the given {{regex}} is matched by the given342;;> {{string}}. If so, {{#t}} is returned, otherwise {{#f}} is returned.343;;> This procedure is essentially a variant of {{regex-exec}} which344;;> supports strings instead of bytevectors directly and thus doesn't345;;> support submatches. Refer to {{regex-exec}} for documentation on346;;> the optional {{notbol}} and {{noteol}} procedure parameters.347348(: regex-match? (regex string #!optional boolean boolean -> boolean))349(define (regex-match? regex string #!optional notbol noteol)350 (%regex-exec regex string 0 #f notbol noteol))351352;; Frees all resources allocate for a {{regex_t*}} pointer value. Invoked353;; automatically via a CHICKEN garbage collector finalizer.354355(: regex-free (pointer -> undefined))356(define (regex-free ptr)357 (define %regex-free358 (foreign-lambda void "regex_free" nonnull-c-pointer))359360 (%regex-free ptr))