Migrate chez-pcre2 to jerboa-pcre2: 2 libs (ffi + pcre2) -> src/jerboa-pcre2/*.ss with Jerboa prelude. C shim renamed jerboa_pcre2_shim.c; CHEZ_PCRE2_LIB -> JERBOA_PCRE2_LIB; pkg-config libpcre2-8. Tests: 48/58 pass (one edge-case crash after pcre2-release! pending).
ober
733f118eaccbb517f3dc986881a41d594daa6d91
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +lib/ +*.so +*.dylib +*.wpo +*.o +.jerbuild-hashes --- a/Makefile +++ b/Makefile @@ -1,33 +1,46 @@ +JERBOA_HOME ?= $(HOME)/mine/jerboa +SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme +JERBUILD ?= $(JERBOA_HOME)/jerbuild +LIBDIRS = lib:$(JERBOA_HOME)/lib + PCRE2_CFLAGS := $(shell pkg-config --cflags libpcre2-8 2>/dev/null) PCRE2_LIBS := $(shell pkg-config --libs libpcre2-8 2>/dev/null || echo "-lpcre2-8") PCRE2_LIBDIR := $(shell pkg-config --variable=libdir libpcre2-8 2>/dev/null) -CC ?= gcc +CC ?= cc CFLAGS ?= -O2 -fPIC -Wall -SCHEME ?= scheme UNAME_S := $(shell uname -s) ifeq ($(UNAME_S),Darwin) SHLIB_EXT := dylib SHLIB_FLAGS := -dynamiclib -Wl,-undefined,dynamic_lookup - export CHEZ_PCRE2_LIB := $(CURDIR) - export DYLD_LIBRARY_PATH := $(PCRE2_LIBDIR):$(CURDIR):$(DYLD_LIBRARY_PATH) else SHLIB_EXT := so SHLIB_FLAGS := -shared - export CHEZ_PCRE2_LIB := $(CURDIR) - export LD_LIBRARY_PATH := $(PCRE2_LIBDIR):$(LD_LIBRARY_PATH) endif -.PHONY: all clean test +SHIM := jerboa_pcre2_shim.$(SHLIB_EXT) + +.PHONY: all build transpile test clean shim + +all: build -all: pcre2_shim.$(SHLIB_EXT) +shim: $(SHIM) -pcre2_shim.$(SHLIB_EXT): pcre2_shim.c +$(SHIM): jerboa_pcre2_shim.c $(CC) $(CFLAGS) $(SHLIB_FLAGS) $(PCRE2_CFLAGS) -o $@ $< $(PCRE2_LIBS) -test: pcre2_shim.$(SHLIB_EXT) - $(SCHEME) --libdirs . --script pcre2-test.ss +transpile: + $(JERBUILD) transpile src lib --force + +build: shim transpile + +test: build + JERBOA_PCRE2_LIB=$(CURDIR) \ + DYLD_LIBRARY_PATH=$(PCRE2_LIBDIR):$(CURDIR):$$DYLD_LIBRARY_PATH \ + LD_LIBRARY_PATH=$(PCRE2_LIBDIR):$(CURDIR):$$LD_LIBRARY_PATH \ + $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/pcre2-test.ss clean: - rm -f pcre2_shim.so pcre2_shim.dylib + rm -f jerboa_pcre2_shim.so jerboa_pcre2_shim.dylib pcre2_shim.so pcre2_shim.dylib + rm -rf lib deleted file mode 100644 --- a/chez-pcre2/ffi.ss +++ /dev/null @@ -1,234 +0,0 @@ -;;; ffi.ss — Low-level FFI bindings to libpcre2-8 for Chez Scheme -;;; -;;; Loads pcre2_shim.so (C wrapper) and defines foreign-procedure bindings. -;;; The high-level API lives in pcre2.ss. - -(library (chez-pcre2 ffi) - (export - ;; Constants - PCRE2_CASELESS PCRE2_MULTILINE PCRE2_DOTALL PCRE2_EXTENDED - PCRE2_UTF PCRE2_UCP PCRE2_ANCHORED PCRE2_ENDANCHORED - PCRE2_UNGREEDY PCRE2_NO_AUTO_CAPTURE PCRE2_DUPNAMES PCRE2_LITERAL - - PCRE2_NOTBOL PCRE2_NOTEOL PCRE2_NOTEMPTY PCRE2_NOTEMPTY_ATSTART - PCRE2_PARTIAL_SOFT PCRE2_PARTIAL_HARD PCRE2_NO_JIT - - PCRE2_SUBSTITUTE_GLOBAL PCRE2_SUBSTITUTE_EXTENDED - PCRE2_SUBSTITUTE_UNSET_EMPTY PCRE2_SUBSTITUTE_UNKNOWN_UNSET - PCRE2_SUBSTITUTE_LITERAL - - PCRE2_JIT_COMPLETE PCRE2_JIT_PARTIAL_SOFT PCRE2_JIT_PARTIAL_HARD - - PCRE2_ERROR_NOMATCH PCRE2_ERROR_PARTIAL - PCRE2_ERROR_NOMEMORY PCRE2_ERROR_NOSUBSTRING - - ;; Core functions - ffi-pcre2-compile - ffi-pcre2-compile-errorcode - ffi-pcre2-compile-erroroffset - ffi-pcre2-match - ffi-pcre2-match-data-create-from-pattern - ffi-pcre2-match-data-create - ffi-pcre2-get-ovector-count - ffi-pcre2-ovector-start - ffi-pcre2-ovector-end - ffi-pcre2-ovector-is-unset? - ffi-pcre2-get-error-message - ffi-pcre2-get-startchar - ffi-pcre2-code-free - ffi-pcre2-match-data-free - - ;; Substitute - ffi-pcre2-do-substitute - ffi-pcre2-substitute-result - ffi-pcre2-substitute-result-length - ffi-pcre2-substitute-free - - ;; Named groups & pattern info - ffi-pcre2-substring-number-from-name - ffi-pcre2-capture-count - ffi-pcre2-name-count - ffi-pcre2-name-entry-size - ffi-pcre2-name-entry-name - ffi-pcre2-name-entry-group - - ;; JIT - ffi-pcre2-jit-compile - ffi-pcre2-jit-match) - - (import (chezscheme)) - - ;; Detect macOS by checking machine-type suffix ("osx"). - (define shlib-ext - (let ([mt (symbol->string (machine-type))]) - (if (and (>= (string-length mt) 3) - (string=? (substring mt (- (string-length mt) 3) (string-length mt)) "osx")) - "dylib" - "so"))) - - ;; Load the C shim shared library. - ;; Set CHEZ_PCRE2_LIB to the directory containing pcre2_shim.so/.dylib, - ;; or place it in the current directory or a system library path. - (define shim-loaded - (load-shared-object - (let ([env (getenv "CHEZ_PCRE2_LIB")]) - (if env - (string-append env "/pcre2_shim." shlib-ext) - (string-append "pcre2_shim." shlib-ext))))) - - ;; ----------------------------------------------------------------------- - ;; Constants — fetched once from C at load time - ;; ----------------------------------------------------------------------- - - (define PCRE2_CASELESS ((foreign-procedure "chez_pcre2_const_caseless" () unsigned-32))) - (define PCRE2_MULTILINE ((foreign-procedure "chez_pcre2_const_multiline" () unsigned-32))) - (define PCRE2_DOTALL ((foreign-procedure "chez_pcre2_const_dotall" () unsigned-32))) - (define PCRE2_EXTENDED ((foreign-procedure "chez_pcre2_const_extended" () unsigned-32))) - (define PCRE2_UTF ((foreign-procedure "chez_pcre2_const_utf" () unsigned-32))) - (define PCRE2_UCP ((foreign-procedure "chez_pcre2_const_ucp" () unsigned-32))) - (define PCRE2_ANCHORED ((foreign-procedure "chez_pcre2_const_anchored" () unsigned-32))) - (define PCRE2_ENDANCHORED ((foreign-procedure "chez_pcre2_const_endanchored" () unsigned-32))) - (define PCRE2_UNGREEDY ((foreign-procedure "chez_pcre2_const_ungreedy" () unsigned-32))) - (define PCRE2_NO_AUTO_CAPTURE ((foreign-procedure "chez_pcre2_const_no_auto_capture" () unsigned-32))) - (define PCRE2_DUPNAMES ((foreign-procedure "chez_pcre2_const_dupnames" () unsigned-32))) - (define PCRE2_LITERAL ((foreign-procedure "chez_pcre2_const_literal" () unsigned-32))) - - (define PCRE2_NOTBOL ((foreign-procedure "chez_pcre2_const_notbol" () unsigned-32))) - (define PCRE2_NOTEOL ((foreign-procedure "chez_pcre2_const_noteol" () unsigned-32))) - (define PCRE2_NOTEMPTY ((foreign-procedure "chez_pcre2_const_notempty" () unsigned-32))) - (define PCRE2_NOTEMPTY_ATSTART ((foreign-procedure "chez_pcre2_const_notempty_atstart" () unsigned-32))) - (define PCRE2_PARTIAL_SOFT ((foreign-procedure "chez_pcre2_const_partial_soft" () unsigned-32))) - (define PCRE2_PARTIAL_HARD ((foreign-procedure "chez_pcre2_const_partial_hard" () unsigned-32))) - (define PCRE2_NO_JIT ((foreign-procedure "chez_pcre2_const_no_jit" () unsigned-32))) - - (define PCRE2_SUBSTITUTE_GLOBAL ((foreign-procedure "chez_pcre2_const_substitute_global" () unsigned-32))) - (define PCRE2_SUBSTITUTE_EXTENDED ((foreign-procedure "chez_pcre2_const_substitute_extended" () unsigned-32))) - (define PCRE2_SUBSTITUTE_UNSET_EMPTY ((foreign-procedure "chez_pcre2_const_substitute_unset_empty" () unsigned-32))) - (define PCRE2_SUBSTITUTE_UNKNOWN_UNSET ((foreign-procedure "chez_pcre2_const_substitute_unknown_unset" () unsigned-32))) - (define PCRE2_SUBSTITUTE_LITERAL ((foreign-procedure "chez_pcre2_const_substitute_literal" () unsigned-32))) - - (define PCRE2_JIT_COMPLETE ((foreign-procedure "chez_pcre2_const_jit_complete" () unsigned-32))) - (define PCRE2_JIT_PARTIAL_SOFT ((foreign-procedure "chez_pcre2_const_jit_partial_soft" () unsigned-32))) - (define PCRE2_JIT_PARTIAL_HARD ((foreign-procedure "chez_pcre2_const_jit_partial_hard" () unsigned-32))) - - (define PCRE2_ERROR_NOMATCH ((foreign-procedure "chez_pcre2_const_error_nomatch" () integer-32))) - (define PCRE2_ERROR_PARTIAL ((foreign-procedure "chez_pcre2_const_error_partial" () integer-32))) - (define PCRE2_ERROR_NOMEMORY ((foreign-procedure "chez_pcre2_const_error_nomemory" () integer-32))) - (define PCRE2_ERROR_NOSUBSTRING ((foreign-procedure "chez_pcre2_const_error_nosubstring" () integer-32))) - - ;; ----------------------------------------------------------------------- - ;; Core FFI functions - ;; ----------------------------------------------------------------------- - - ;; Compile: returns pointer or 0 on error - (define ffi-pcre2-compile - (foreign-procedure "chez_pcre2_compile" - (u8* size_t unsigned-32) void*)) - - (define ffi-pcre2-compile-errorcode - (foreign-procedure "chez_pcre2_compile_errorcode" () integer-32)) - - (define ffi-pcre2-compile-erroroffset - (foreign-procedure "chez_pcre2_compile_erroroffset" () size_t)) - - ;; Match: returns count (>0) on success, negative on failure - (define ffi-pcre2-match - (foreign-procedure "chez_pcre2_match" - (void* u8* size_t size_t unsigned-32 void*) integer-32)) - - (define ffi-pcre2-match-data-create-from-pattern - (foreign-procedure "chez_pcre2_match_data_create_from_pattern" - (void*) void*)) - - (define ffi-pcre2-match-data-create - (foreign-procedure "chez_pcre2_match_data_create" - (unsigned-32) void*)) - - (define ffi-pcre2-get-ovector-count - (foreign-procedure "chez_pcre2_get_ovector_count" - (void*) unsigned-32)) - - (define ffi-pcre2-ovector-start - (foreign-procedure "chez_pcre2_ovector_start" - (void* unsigned-32) size_t)) - - (define ffi-pcre2-ovector-end - (foreign-procedure "chez_pcre2_ovector_end" - (void* unsigned-32) size_t)) - - (define ffi-pcre2-ovector-is-unset? - (let ([f (foreign-procedure "chez_pcre2_ovector_is_unset" - (void* unsigned-32) integer-32)]) - (lambda (md idx) (not (zero? (f md idx)))))) - - (define ffi-pcre2-get-error-message - (foreign-procedure "chez_pcre2_get_error_message" - (integer-32) string)) - - (define ffi-pcre2-get-startchar - (foreign-procedure "chez_pcre2_get_startchar" - (void*) size_t)) - - (define ffi-pcre2-code-free - (foreign-procedure "chez_pcre2_code_free" (void*) void)) - - (define ffi-pcre2-match-data-free - (foreign-procedure "chez_pcre2_match_data_free" (void*) void)) - - ;; ----------------------------------------------------------------------- - ;; Substitute - ;; ----------------------------------------------------------------------- - - (define ffi-pcre2-do-substitute - (foreign-procedure "chez_pcre2_do_substitute" - (void* u8* size_t size_t unsigned-32 void* u8* size_t) integer-32)) - - (define ffi-pcre2-substitute-result - (foreign-procedure "chez_pcre2_substitute_result" () string)) - - (define ffi-pcre2-substitute-result-length - (foreign-procedure "chez_pcre2_substitute_result_length" () size_t)) - - (define ffi-pcre2-substitute-free - (foreign-procedure "chez_pcre2_substitute_free" () void)) - - ;; ----------------------------------------------------------------------- - ;; Named groups & pattern info - ;; ----------------------------------------------------------------------- - - (define ffi-pcre2-substring-number-from-name - (foreign-procedure "chez_pcre2_substring_number_from_name" - (void* string) integer-32)) - - (define ffi-pcre2-capture-count - (foreign-procedure "chez_pcre2_capture_count" - (void*) unsigned-32)) - - (define ffi-pcre2-name-count - (foreign-procedure "chez_pcre2_name_count" - (void*) unsigned-32)) - - (define ffi-pcre2-name-entry-size - (foreign-procedure "chez_pcre2_name_entry_size" - (void*) unsigned-32)) - - (define ffi-pcre2-name-entry-name - (foreign-procedure "chez_pcre2_name_entry_name" - (void* unsigned-32) string)) - - (define ffi-pcre2-name-entry-group - (foreign-procedure "chez_pcre2_name_entry_group" - (void* unsigned-32) unsigned-32)) - - ;; ----------------------------------------------------------------------- - ;; JIT - ;; ----------------------------------------------------------------------- - - (define ffi-pcre2-jit-compile - (foreign-procedure "chez_pcre2_jit_compile" - (void* unsigned-32) integer-32)) - - (define ffi-pcre2-jit-match - (foreign-procedure "chez_pcre2_jit_match" - (void* u8* size_t size_t unsigned-32 void*) integer-32)) -) deleted file mode 100644 --- a/chez-pcre2/pcre2.ss +++ /dev/null @@ -1,587 +0,0 @@ -;;; pcre2.ss — High-level idiomatic Chez Scheme API for PCRE2 -;;; -;;; Provides API parity with gerbil-pcre2's pcre2/pcre2.ss: -;;; - Compilation: pcre2-compile, pcre2-regex -;;; - Matching: pcre2-match, pcre2-search, pcre2-matches? -;;; - Match access: pcre-match-group, pcre-match-named, pcre-match-positions, -;;; pcre-match->list, pcre-match->alist -;;; - Substitution: pcre2-replace, pcre2-replace-all -;;; - Iteration: pcre2-find-all, pcre2-extract, pcre2-fold, -;;; pcre2-split, pcre2-partition -;;; - Utilities: pcre2-quote, pcre2-release! -;;; - Pregexp-compat: pcre2-pregexp-match, pcre2-pregexp-match-positions, -;;; pcre2-pregexp-replace, pcre2-pregexp-replace*, -;;; pcre2-pregexp-quote - -(library (chez-pcre2 pcre2) - (export - ;; Types - pcre-regex? pcre-match? - - ;; Compilation - pcre2-compile pcre2-regex - - ;; Matching - pcre2-match pcre2-search pcre2-matches? - - ;; Match result access - pcre-match-group pcre-match-named - pcre-match-positions - pcre-match->list pcre-match->alist - - ;; Substitution - pcre2-replace pcre2-replace-all - - ;; Iteration - pcre2-find-all pcre2-extract pcre2-fold - pcre2-split pcre2-partition - - ;; Utilities - pcre2-quote pcre2-release! - - ;; Pregexp-compatible API - pcre2-pregexp-match pcre2-pregexp-match-positions - pcre2-pregexp-replace pcre2-pregexp-replace* - pcre2-pregexp-quote - - ;; Re-export constants for convenience - PCRE2_CASELESS PCRE2_MULTILINE PCRE2_DOTALL PCRE2_EXTENDED - PCRE2_UTF PCRE2_UCP PCRE2_ANCHORED PCRE2_ENDANCHORED - PCRE2_UNGREEDY PCRE2_LITERAL) - - (import (chezscheme) - (chez-pcre2 ffi)) - - ;; ----------------------------------------------------------------------- - ;; Record types - ;; ----------------------------------------------------------------------- - - (define-record-type pcre-regex - (fields code ; void* — pcre2_code pointer - match-data ; void* — pcre2_match_data pointer - pattern ; string — original pattern - capture-count ; integer — number of capturing groups - jit? ; boolean — JIT compilation succeeded - name-table) ; alist ((name . group-number) ...) - (nongenerative pcre-regex)) - - (define-record-type pcre-match - (fields span-vec ; vector of (start . end) or #f - subject ; string — subject string - name-table) ; alist ((name . group-number) ...) - (nongenerative pcre-match)) - - ;; ----------------------------------------------------------------------- - ;; Guardian for automatic cleanup of FFI pointers - ;; ----------------------------------------------------------------------- - - (define pcre2-guardian (make-guardian)) - - (define (register-pcre2-finalizer rx) - (pcre2-guardian rx) - rx) - - (define (pcre2-collect!) - (let loop () - (let ([rx (pcre2-guardian)]) - (when rx - (let ([md (pcre-regex-match-data rx)] - [code (pcre-regex-code rx)]) - (when (not (zero? md)) (ffi-pcre2-match-data-free md)) - (when (not (zero? code)) (ffi-pcre2-code-free code))) - (loop))))) - - ;; ----------------------------------------------------------------------- - ;; UTF-8 byte/char offset conversion - ;; ----------------------------------------------------------------------- - - (define (utf8-byte-length b) - (cond - [(< b #x80) 1] - [(< b #xE0) 2] - [(< b #xF0) 3] - [else 4])) - - (define (byte-offset->char-index bv byte-off) - (let loop ([bi 0] [ci 0]) - (if (>= bi byte-off) ci - (loop (+ bi (utf8-byte-length (bytevector-u8-ref bv bi))) - (+ ci 1))))) - - (define (char-index->byte-offset bv char-idx) - (let loop ([bi 0] [ci 0]) - (if (>= ci char-idx) bi - (loop (+ bi (utf8-byte-length (bytevector-u8-ref bv bi))) - (+ ci 1))))) - - ;; ----------------------------------------------------------------------- - ;; Name table parsing - ;; ----------------------------------------------------------------------- - - (define (pcre2-build-name-table code) - (let ([ncount (ffi-pcre2-name-count code)]) - (if (zero? ncount) - '() - (let loop ([i 0] [acc '()]) - (if (= i ncount) - (reverse acc) - (let ([name (ffi-pcre2-name-entry-name code i)] - [group (ffi-pcre2-name-entry-group code i)]) - (loop (+ i 1) (cons (cons name group) acc)))))))) - - ;; ----------------------------------------------------------------------- - ;; Compilation - ;; ----------------------------------------------------------------------- - - (define pcre2-compile - (case-lambda - [(pattern) (pcre2-compile pattern (bitwise-ior PCRE2_UTF PCRE2_UCP) #t)] - [(pattern options) (pcre2-compile pattern options #t)] - [(pattern options jit?) - (let* ([bv (string->utf8 pattern)] - [code (ffi-pcre2-compile bv (bytevector-length bv) options)]) - (when (zero? code) - (let ([ec (ffi-pcre2-compile-errorcode)] - [eo (ffi-pcre2-compile-erroroffset)]) - (error 'pcre2-compile - (format "~a at offset ~a in pattern: ~a" - (ffi-pcre2-get-error-message ec) eo pattern) - ec eo))) - (let ([jit-ok? - (if jit? - (zero? (ffi-pcre2-jit-compile code PCRE2_JIT_COMPLETE)) - #f)]) - (let* ([md (ffi-pcre2-match-data-create-from-pattern code)] - [cnt (ffi-pcre2-capture-count code)] - [names (pcre2-build-name-table code)] - [rx (make-pcre-regex code md pattern cnt jit-ok? names)]) - (register-pcre2-finalizer rx))))])) - - (define (pcre2-regex-impl pattern caseless multiline dotall extended - ungreedy utf ucp literal jit) - (let ([opts (bitwise-ior - (if utf PCRE2_UTF 0) - (if ucp PCRE2_UCP 0) - (if caseless PCRE2_CASELESS 0) - (if multiline PCRE2_MULTILINE 0) - (if dotall PCRE2_DOTALL 0) - (if extended PCRE2_EXTENDED 0) - (if ungreedy PCRE2_UNGREEDY 0) - (if literal PCRE2_LITERAL 0))]) - (pcre2-compile pattern opts jit))) - - (define pcre2-regex - (case-lambda - [(pattern) (pcre2-regex-impl pattern #f #f #f #f #f #t #t #f #t)] - [(pattern . kwargs) - (let-values ([(caseless multiline dotall extended ungreedy utf ucp literal jit) - (parse-kwargs kwargs)]) - (pcre2-regex-impl pattern caseless multiline dotall extended - ungreedy utf ucp literal jit))])) - - ;; Parse keyword arguments for pcre2-regex - (define (parse-kwargs kwargs) - (let ([caseless #f] [multiline #f] [dotall #f] [extended #f] - [ungreedy #f] [utf #t] [ucp #t] [literal #f] - [jit #t]) - (let loop ([args kwargs]) - (cond - [(null? args) - (values caseless multiline dotall extended ungreedy utf ucp literal jit)] - [(and (pair? args) (pair? (cdr args))) - (let ([key (car args)] [val (cadr args)]) - (case key - [(caseless:) (set! caseless val)] - [(multiline:) (set! multiline val)] - [(dotall:) (set! dotall val)] - [(extended:) (set! extended val)] - [(ungreedy:) (set! ungreedy val)] - [(utf:) (set! utf val)] - [(ucp:) (set! ucp val)] - [(literal:) (set! literal val)] - [(jit:) (set! jit val)] - [else (error 'pcre2-regex "unknown keyword" key)]) - (loop (cddr args)))] - [else (error 'pcre2-regex "invalid keyword arguments" args)])))) - - ;; ----------------------------------------------------------------------- - ;; Pattern cache (LRU, simple alist, max 64 entries) - ;; ----------------------------------------------------------------------- - - (define *cache-max* 64) - (define *cache* '()) - - (define (pcre2-compile/cached pattern) - (let ([entry (assoc pattern *cache*)]) - (if entry - (begin - ;; Move to front - (set! *cache* (cons entry (remq entry *cache*))) - (cdr entry)) - (let ([rx (pcre2-compile pattern)]) - (set! *cache* (cons (cons pattern rx) *cache*)) - (when (> (length *cache*) *cache-max*) - (set! *cache* (list-head *cache* *cache-max*))) - rx)))) - - (define (ensure-regex pattern-or-regex) - (cond - [(pcre-regex? pattern-or-regex) pattern-or-regex] - [(string? pattern-or-regex) (pcre2-compile/cached pattern-or-regex)] - [else (error 'ensure-regex "expected string or pcre-regex" pattern-or-regex)])) - - ;; ----------------------------------------------------------------------- - ;; Internal matching helper - ;; ----------------------------------------------------------------------- - - (define pcre2-do-match - (case-lambda - [(rx subject start options) - (pcre2-do-match rx subject start options #f #f)] - [(rx subject start options md) - (pcre2-do-match rx subject start options md #f)] - [(rx subject start options md subject-bytes) - (let* ([code (pcre-regex-code rx)] - [md (if md md (ffi-pcre2-match-data-create-from-pattern code))] - [bv (if subject-bytes subject-bytes (string->utf8 subject))] - [byte-start (if (zero? start) 0 (char-index->byte-offset bv start))] - [rc (if (pcre-regex-jit? rx) - (ffi-pcre2-jit-match code bv (bytevector-length bv) - byte-start options md) - (ffi-pcre2-match code bv (bytevector-length bv) - byte-start options md))]) - (if (< rc 0) - #f - (let* ([ncap (+ (pcre-regex-capture-count rx) 1)] - [sv (make-vector ncap #f)]) - (let loop ([i 0]) - (when (< i ncap) - (unless (ffi-pcre2-ovector-is-unset? md i) - (let ([bstart (ffi-pcre2-ovector-start md i)] - [bend (ffi-pcre2-ovector-end md i)]) - (vector-set! sv i - (cons (byte-offset->char-index bv bstart) - (byte-offset->char-index bv bend))))) - (loop (+ i 1)))) - ;; Free per-call match data if we allocated it - (unless (eq? md (pcre-regex-match-data rx)) - (unless (eqv? md (pcre-regex-match-data rx)) - 'ok)) ; md will be GC'd or caller manages - (make-pcre-match sv subject (pcre-regex-name-table rx)))))])) - - ;; ----------------------------------------------------------------------- - ;; Matching API - ;; ----------------------------------------------------------------------- - - (define pcre2-match - (case-lambda - [(rx/str subject) (pcre2-match rx/str subject 0)] - [(rx/str subject start) - (let ([rx (ensure-regex rx/str)]) - (pcre2-do-match rx subject start - (bitwise-ior PCRE2_ANCHORED PCRE2_ENDANCHORED)))])) - - (define pcre2-search - (case-lambda - [(rx/str subject) (pcre2-search rx/str subject 0)] - [(rx/str subject start) - (let ([rx (ensure-regex rx/str)]) - (pcre2-do-match rx subject start 0))])) - - (define pcre2-matches? - (case-lambda - [(rx/str subject) (pcre2-matches? rx/str subject 0)] - [(rx/str subject start) - (let* ([rx (ensure-regex rx/str)] - [code (pcre-regex-code rx)] - [md (ffi-pcre2-match-data-create 1)] - [bv (string->utf8 subject)] - [byte-start (if (zero? start) 0 (char-index->byte-offset bv start))] - [rc (if (pcre-regex-jit? rx) - (ffi-pcre2-jit-match code bv (bytevector-length bv) - byte-start 0 md) - (ffi-pcre2-match code bv (bytevector-length bv) - byte-start 0 md))]) - (ffi-pcre2-match-data-free md) - (>= rc 0))])) - - ;; ----------------------------------------------------------------------- - ;; Match result access - ;; ----------------------------------------------------------------------- - - (define pcre-match-group - (case-lambda - [(m) (pcre-match-group m 0)] - [(m n) - (let ([pair (vector-ref (pcre-match-span-vec m) n)]) - (and pair (substring (pcre-match-subject m) - (car pair) (cdr pair))))])) - - (define (pcre-match-named m name) - (let ([entry (assoc name (pcre-match-name-table m))]) - (and entry (pcre-match-group m (cdr entry))))) - - (define pcre-match-positions - (case-lambda - [(m) (pcre-match-positions m 0)] - [(m n) - (vector-ref (pcre-match-span-vec m) n)])) - - (define (pcre-match->list m) - (let* ([sv (pcre-match-span-vec m)] - [n (vector-length sv)]) - (let loop ([i 0] [acc '()]) - (if (= i n) - (reverse acc) - (loop (+ i 1) (cons (pcre-match-group m i) acc)))))) - - (define (pcre-match->alist m) - (map (lambda (entry) - (cons (car entry) (pcre-match-named m (car entry)))) - (pcre-match-name-table m))) - - ;; ----------------------------------------------------------------------- - ;; Substitution - ;; ----------------------------------------------------------------------- - - (define pcre2-replace - (case-lambda - [(rx/str subject replacement) - (pcre2-replace rx/str subject replacement 0 #f)] - [(rx/str subject replacement start) - (pcre2-replace rx/str subject replacement start #f)] - [(rx/str subject replacement start extended?) - (let* ([rx (ensure-regex rx/str)] - [opts (if extended? PCRE2_SUBSTITUTE_EXTENDED 0)] - [bv-subj (string->utf8 subject)] - [bv-repl (string->utf8 replacement)] - [byte-start (if (zero? start) 0 - (char-index->byte-offset bv-subj start))] - [rc (ffi-pcre2-do-substitute - (pcre-regex-code rx) - bv-subj (bytevector-length bv-subj) - byte-start opts - (pcre-regex-match-data rx) - bv-repl (bytevector-length bv-repl))]) - (cond - [(>= rc 0) - (let ([result (ffi-pcre2-substitute-result)]) - (ffi-pcre2-substitute-free) - result)] - [(= rc PCRE2_ERROR_NOMATCH) subject] - [else (error 'pcre2-replace - (ffi-pcre2-get-error-message rc) rc)]))])) - - (define pcre2-replace-all - (case-lambda - [(rx/str subject replacement) - (pcre2-replace-all rx/str subject replacement 0 #f)] - [(rx/str subject replacement start) - (pcre2-replace-all rx/str subject replacement start #f)] - [(rx/str subject replacement start extended?) - (let* ([rx (ensure-regex rx/str)] - [opts (bitwise-ior PCRE2_SUBSTITUTE_GLOBAL - (if extended? PCRE2_SUBSTITUTE_EXTENDED 0))] - [bv-subj (string->utf8 subject)] - [bv-repl (string->utf8 replacement)] - [byte-start (if (zero? start) 0 - (char-index->byte-offset bv-subj start))] - [rc (ffi-pcre2-do-substitute - (pcre-regex-code rx) - bv-subj (bytevector-length bv-subj) - byte-start opts - (pcre-regex-match-data rx) - bv-repl (bytevector-length bv-repl))]) - (cond - [(>= rc 0) - (let ([result (ffi-pcre2-substitute-result)]) - (ffi-pcre2-substitute-free) - result)] - [(= rc PCRE2_ERROR_NOMATCH) subject] - [else (error 'pcre2-replace-all - (ffi-pcre2-get-error-message rc) rc)]))])) - - ;; ----------------------------------------------------------------------- - ;; Iteration / fold - ;; ----------------------------------------------------------------------- - - (define pcre2-fold - (case-lambda - [(rx/str kons knil subject) (pcre2-fold rx/str kons knil subject 0)] - [(rx/str kons knil subject start) - (let* ([rx (ensure-regex rx/str)] - [md (ffi-pcre2-match-data-create-from-pattern (pcre-regex-code rx))] - [slen (string-length subject)] - [bv (string->utf8 subject)]) - (let loop ([pos start] [acc knil]) - (let ([m (pcre2-do-match rx subject pos 0 md bv)]) - (if (not m) - (begin (ffi-pcre2-match-data-free md) acc) - (let* ([span (vector-ref (pcre-match-span-vec m) 0)] - [end (cdr span)] - [next (if (= (car span) end) (+ end 1) end)]) - (if (> next slen) - (begin (ffi-pcre2-match-data-free md) - (kons m acc)) - (loop next (kons m acc))))))))])) - - (define pcre2-find-all - (case-lambda - [(rx/str subject) (pcre2-find-all rx/str subject 0)] - [(rx/str subject start) - (reverse (pcre2-fold rx/str cons '() subject start))])) - - (define pcre2-extract - (case-lambda - [(rx/str subject) (pcre2-extract rx/str subject 0)] - [(rx/str subject start) - (reverse - (pcre2-fold rx/str - (lambda (m acc) (cons (pcre-match-group m 0) acc)) - '() subject start))])) - - (define pcre2-split - (case-lambda - [(rx/str subject) (pcre2-split rx/str subject #f)] - [(rx/str subject limit) - (let* ([rx (ensure-regex rx/str)] - [md (ffi-pcre2-match-data-create-from-pattern (pcre-regex-code rx))] - [slen (string-length subject)] - [bv (string->utf8 subject)]) - (let loop ([pos 0] [seg-start 0] [acc '()] [count 1]) - (if (and limit (>= count limit)) - (begin (ffi-pcre2-match-data-free md) - (reverse (cons (substring subject seg-start slen) acc))) - (let ([m (pcre2-do-match rx subject pos 0 md bv)]) - (if (not m) - (begin (ffi-pcre2-match-data-free md) - (reverse (cons (substring subject seg-start slen) acc))) - (let* ([span (vector-ref (pcre-match-span-vec m) 0)] - [mstart (car span)] - [mend (cdr span)]) - (if (= mstart mend) - ;; Zero-length match - (if (= mstart pos) - ;; At current pos — advance without splitting - (if (>= (+ pos 1) slen) - (begin (ffi-pcre2-match-data-free md) - (reverse (cons (substring subject seg-start slen) acc))) - (loop (+ pos 1) seg-start acc count)) - ;; Ahead of current pos — valid split point - (loop mend mend - (cons (substring subject seg-start mstart) acc) - (+ count 1))) - ;; Normal match - (loop mend mend - (cons (substring subject seg-start mstart) acc) - (+ count 1)))))))))])) - - (define (pcre2-partition rx/str subject) - (let* ([rx (ensure-regex rx/str)] - [md (ffi-pcre2-match-data-create-from-pattern (pcre-regex-code rx))] - [slen (string-length subject)] - [bv (string->utf8 subject)]) - (let loop ([pos 0] [acc '()]) - (let ([m (pcre2-do-match rx subject pos 0 md bv)]) - (if (not m) - (begin (ffi-pcre2-match-data-free md) - (reverse (cons (substring subject pos slen) acc))) - (let* ([span (vector-ref (pcre-match-span-vec m) 0)] - [mstart (car span)] - [mend (cdr span)] - [pre (substring subject pos mstart)] - [hit (pcre-match-group m 0)] - [next (if (= mstart mend) (+ mend 1) mend)]) - (if (> next slen) - (begin (ffi-pcre2-match-data-free md) - (reverse (cons hit (cons pre acc)))) - (loop next (cons hit (cons pre acc)))))))))) - - ;; ----------------------------------------------------------------------- - ;; Pattern quoting - ;; ----------------------------------------------------------------------- - - (define *meta-chars* (string->list "\\^$.|?*+()[]{}#-")) - - (define (pcre2-quote str) - (let ([p (open-output-string)]) - (string-for-each - (lambda (c) - (when (memv c *meta-chars*) - (write-char #\\ p)) - (write-char c p)) - str) - (get-output-string p))) - - ;; ----------------------------------------------------------------------- - ;; Resource management - ;; ----------------------------------------------------------------------- - - (define (pcre2-release! regex) - (when (pcre-regex? regex) - ;; Remove from cache - (set! *cache* (filter (lambda (e) (not (eq? (cdr e) regex))) *cache*)) - ;; Release FFI resources - (let ([md (pcre-regex-match-data regex)] - [code (pcre-regex-code regex)]) - (when (not (zero? md)) (ffi-pcre2-match-data-free md)) - (when (not (zero? code)) (ffi-pcre2-code-free code))))) - - ;; ----------------------------------------------------------------------- - ;; Pregexp-compatible API - ;; ----------------------------------------------------------------------- - - (define pcre2-pregexp-match - (case-lambda - [(pattern subject) (pcre2-pregexp-match pattern subject 0 #f)] - [(pattern subject start) (pcre2-pregexp-match pattern subject start #f)] - [(pattern subject start end) - (let* ([subj (if end - (substring subject start end) - (substring subject start (string-length subject)))] - [m (pcre2-search pattern subj 0)]) - (and m (pcre-match->list m)))])) - - (define pcre2-pregexp-match-positions - (case-lambda - [(pattern subject) (pcre2-pregexp-match-positions pattern subject 0 #f)] - [(pattern subject start) (pcre2-pregexp-match-positions pattern subject start #f)] - [(pattern subject start end) - (let* ([subj (if end - (substring subject start end) - (substring subject start (string-length subject)))] - [m (pcre2-search pattern subj 0)]) - (and m - (let* ([sv (pcre-match-span-vec m)] - [n (vector-length sv)]) - (let loop ([i 0] [acc '()]) - (if (= i n) - (reverse acc) - (let ([pair (vector-ref sv i)]) - (loop (+ i 1) - (cons (if pair - (cons (+ start (car pair)) - (+ start (cdr pair))) - #f) - acc))))))))])) - - (define (pcre2-pregexp-replace pattern subject replacement) - (pcre2-replace pattern subject replacement)) - - (define (pcre2-pregexp-replace* pattern subject replacement) - (pcre2-replace-all pattern subject replacement)) - - (define (pcre2-pregexp-quote str) - (pcre2-quote str)) - - ;; ----------------------------------------------------------------------- - ;; Initialize guardian-based cleanup on GC - ;; (Must be at the end — after all definitions, as R6RS requires) - ;; ----------------------------------------------------------------------- - - (collect-request-handler - (let ([old (collect-request-handler)]) - (lambda () - (old) - (pcre2-collect!)))) -) new file mode 100644 --- /dev/null +++ b/jerboa_pcre2_shim.c @@ -0,0 +1,298 @@ +/* pcre2_shim.c — C wrapper functions for Chez Scheme FFI + * + * Provides simplified C functions that wrap libpcre2-8 APIs, + * using simpler calling conventions suitable for Chez's foreign-procedure. + * Mirrors the C shim from gerbil-pcre2/libpcre2.ss. + */ + +#define PCRE2_CODE_UNIT_WIDTH 8 +#include <pcre2.h> +#include <stdlib.h> +#include <string.h> +#include <stdint.h> + +/* ------------------------------------------------------------------- + * Compile wrapper — stores error info in thread-locals + * ------------------------------------------------------------------- */ +static __thread int _ffi_errorcode = 0; +static __thread size_t _ffi_erroroffset = 0; + +pcre2_code_8* jerboa_pcre2_compile( + const char* pattern, size_t length, uint32_t options) +{ + return pcre2_compile_8( + (PCRE2_SPTR8)pattern, length, options, + &_ffi_errorcode, &_ffi_erroroffset, NULL); +} + +int jerboa_pcre2_compile_errorcode(void) { return _ffi_errorcode; } +size_t jerboa_pcre2_compile_erroroffset(void) { return _ffi_erroroffset; } + +/* ------------------------------------------------------------------- + * Error message + * ------------------------------------------------------------------- */ +static __thread char _ffi_errbuf[512]; + +const char* jerboa_pcre2_get_error_message(int errorcode) { + int rc = pcre2_get_error_message_8( + errorcode, (PCRE2_UCHAR8*)_ffi_errbuf, sizeof(_ffi_errbuf)); + if (rc < 0) return "Unknown PCRE2 error"; + return _ffi_errbuf; +} + +/* ------------------------------------------------------------------- + * Match wrapper — passes NULL for context + * ------------------------------------------------------------------- */ +int jerboa_pcre2_match( + const pcre2_code_8* code, + const char* subject, size_t subject_length, + size_t startoffset, uint32_t options, + pcre2_match_data_8* match_data) +{ + return pcre2_match_8(code, (PCRE2_SPTR8)subject, subject_length, + startoffset, options, match_data, NULL); +} + +/* ------------------------------------------------------------------- + * Match data creation wrappers + * ------------------------------------------------------------------- */ +pcre2_match_data_8* jerboa_pcre2_match_data_create_from_pattern( + const pcre2_code_8* code) +{ + return pcre2_match_data_create_from_pattern_8(code, NULL); +} + +pcre2_match_data_8* jerboa_pcre2_match_data_create(uint32_t ovecsize) +{ + return pcre2_match_data_create_8(ovecsize, NULL); +} + +/* ------------------------------------------------------------------- + * Ovector access + * ------------------------------------------------------------------- */ +uint32_t jerboa_pcre2_get_ovector_count(pcre2_match_data_8* md) +{ + return pcre2_get_ovector_count_8(md); +} + +size_t jerboa_pcre2_ovector_start(pcre2_match_data_8* md, uint32_t idx) +{ + uint32_t count = pcre2_get_ovector_count_8(md); + if (idx >= count) return PCRE2_UNSET; + PCRE2_SIZE* ov = pcre2_get_ovector_pointer_8(md); + return ov[2*idx]; +} + +size_t jerboa_pcre2_ovector_end(pcre2_match_data_8* md, uint32_t idx) +{ + uint32_t count = pcre2_get_ovector_count_8(md); + if (idx >= count) return PCRE2_UNSET; + PCRE2_SIZE* ov = pcre2_get_ovector_pointer_8(md); + return ov[2*idx + 1]; +} + +int jerboa_pcre2_ovector_is_unset(pcre2_match_data_8* md, uint32_t idx) +{ + uint32_t count = pcre2_get_ovector_count_8(md); + if (idx >= count) return 1; + PCRE2_SIZE* ov = pcre2_get_ovector_pointer_8(md); + return ov[2*idx] == PCRE2_UNSET; +} + +size_t jerboa_pcre2_get_startchar(pcre2_match_data_8* md) +{ + return pcre2_get_startchar_8(md);