~ chicken-core (master) /irregex.scm

  1;;;; irregex.scm - container for irregex-core.scm
  2;
  3; Copyright (c) 2010-2022, The CHICKEN Team
  4; All rights reserved.
  5;
  6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  7; conditions are met:
  8;
  9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 10;     disclaimer.
 11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 12;     disclaimer in the documentation and/or other materials provided with the distribution.
 13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 14;     products derived from this software without specific prior written permission.
 15;
 16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 24; POSSIBILITY OF SUCH DAMAGE.
 25
 26
 27
 28(declare
 29  (unit irregex)
 30  (no-procedure-checks)
 31  (fixnum))
 32
 33(module chicken.irregex
 34    (;; Constructors, accessors and predicates
 35     irregex irregex? string->sre maybe-string->sre sre->irregex
 36     irregex-names irregex-num-submatches string->irregex
 37
 38     ;; Chunking constructor
 39     make-irregex-chunker
 40
 41     ;; Main API
 42     irregex-extract irregex-fold irregex-match irregex-match?
 43     irregex-search irregex-split irregex-replace irregex-replace/all
 44
 45     ;; Chunked main API
 46     irregex-fold/chunked irregex-match/chunked irregex-search/chunked
 47
 48     ;; Match extraction API
 49     irregex-match-data? irregex-match-names
 50     irregex-match-start-index irregex-match-end-index
 51     irregex-match-num-submatches irregex-match-substring
 52     irregex-match-valid-index?
 53
 54     ;; Chunked match API
 55     irregex-match-start-chunk irregex-match-end-chunk
 56     irregex-match-subchunk
 57
 58     ;; Utilities
 59     glob->sre sre->string irregex-opt irregex-quote)
 60
 61
 62(import (except scheme integer->char))
 63(import chicken.base chicken.fixnum chicken.syntax chicken.type)
 64(import (only (scheme base) open-output-string get-output-string))
 65
 66(import-for-syntax chicken.fixnum)
 67
 68(define-inline (integer->char n)
 69  (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
 70
 71(include "common-declarations.scm")
 72
 73;; These should probably be taken out of irregex upstream
 74(declare (unused filter integer-log cset-size remove))
 75
 76;; Due to usual-integrations, find is the one from library.scm,
 77;; so find-tail is unused (it's only used in the "find" definition)
 78(declare (unused find-tail))
 79
 80;; This is to silence an "always true" warning that we can't fix
 81;; because we don't want to needlessly change irregex-core.
 82(declare (type (*allow-utf8-mode?* boolean)))
 83
 84(define-syntax build-cache
 85  (er-macro-transformer 
 86   (lambda (x r c)
 87     ;; (build-cache N ARG FAIL) 
 88     (let* ((n (cadr x))
 89	    (n2 (* n 2))
 90	    (arg (caddr x))
 91	    (fail (cadddr x))
 92	    (%cache (r 'cache))
 93	    (%index (r 'index))
 94	    (%arg (r 'arg))
 95	    (%let (r 'let))
 96	    (%let* (r 'let*))
 97	    (%if (r 'if))
 98	    (%fx+ (r 'fx+))
 99	    (%fxmod (r 'fxmod))
100	    (%equal? (r 'equal?))
101	    (%quote (r 'quote))
102	    (%tmp (r 'tmp))
103	    (%begin (r 'begin))
104	    (cache (make-vector (add1 n2) #f)))
105       (##sys#setslot cache n2 0)	 ; last slot: current index
106       `(,%let* ((,%cache (,%quote ,cache)) ; we mutate a literal vector
107		 (,%arg ,arg))
108		,(let fold ((i 0))
109		   (if (fx>= i n)
110		       ;; this should be thread-safe: a context-switch can only
111		       ;; happen before this code and in the call to FAIL.
112		       `(,%let ((,%tmp ,fail)
113				(,%index (##sys#slot ,%cache ,n2)))
114			       (##sys#setslot ,%cache ,%index ,%arg)
115			       (##sys#setslot ,%cache (,%fx+ ,%index 1) ,%tmp)
116			       (##sys#setislot 
117				,%cache ,n2 (,%fxmod (,%fx+ ,%index 2) ,n2))
118			       ,%tmp)
119		       `(,%if (,%equal? (##sys#slot ,%cache ,(* i 2)) ,%arg)
120			      (##sys#slot ,%cache ,(add1 (* i 2)))
121			      ,(fold (add1 i))))))))))
122
123(declare (unused %substring=?))
124(define-compiler-syntax %substring=?
125  (syntax-rules ()
126    ((_ a b start1 start2 len)
127     (##core#inline "C_u_i_substring_equal_p" a b start1 start2 len))))
128
129(define-compiler-syntax make-irregex 
130  (syntax-rules ()
131    ((_ dfa dfa/search nfa flags submatches lengths names)
132     (##sys#make-structure
133      'regexp dfa dfa/search nfa flags submatches lengths names))))
134
135(define-compiler-syntax make-irregex-match
136  (syntax-rules ()
137    ((_ count names)
138     (##sys#make-structure
139      'regexp-match
140      (make-vector (* 4 (+ 2 count)) #f) ; #1: submatches
141      names                              ; #2: (guess)
142      #f                                 ; #3: chunka
143      #f))))                             ; #4: fail
144
145(declare (unused reverse))
146(define-compiler-syntax reverse
147  (syntax-rules ()
148    ((_ lst) (##sys#fast-reverse lst))))
149
150(declare (unused bit-shl))
151(define-compiler-syntax bit-shl
152  (syntax-rules ()
153    ((_ n i) (fxshl n i))))
154
155(declare (unused bit-shr))
156(define-compiler-syntax bit-shr
157  (syntax-rules ()
158    ((_ n i) (fxshr n i))))
159
160(declare (unused bit-not))
161(define-compiler-syntax bit-not
162  (syntax-rules ()
163    ((_ n) (fxnot n))))
164
165(declare (unused bit-ior))
166(define-compiler-syntax bit-ior
167  (syntax-rules ()
168    ((_ a b) (fxior a b))))
169
170(declare (unused bit-and))
171(define-compiler-syntax bit-and
172  (syntax-rules ()
173    ((_ a b) (fxand a b))))
174
175(define-compiler-syntax match-vector-ref
176  (syntax-rules ()
177    ((_ m i) (##sys#slot (##sys#slot m 1) i))))
178
179(define-compiler-syntax match-vector-set!
180  (syntax-rules ()
181    ((_ m i x) (##sys#setslot (##sys#slot m 1) i x))))
182
183(declare (unused irregex-match-start-chunk-set!))
184(define-compiler-syntax irregex-match-start-chunk-set!
185  (syntax-rules ()
186    ((_ m n start)
187     (vector-set! (##sys#slot m 1) (* n 4) start))))
188
189(declare (unused irregex-match-start-index-set!))
190(define-compiler-syntax irregex-match-start-index-set!
191  (syntax-rules ()
192    ((_ m n start)
193     (vector-set! (##sys#slot m 1) (+ 1 (* n 4)) start))))
194
195(declare (unused irregex-match-end-chunk-set!))
196(define-compiler-syntax irregex-match-end-chunk-set!
197  (syntax-rules ()
198    ((_ m n end)
199     (vector-set! (##sys#slot m 1) (+ 2 (* n 4)) end))))
200
201(declare (unused irregex-match-end-index-set!))
202(define-compiler-syntax irregex-match-end-index-set!
203  (syntax-rules ()
204    ((_ m n end)
205     (vector-set! (##sys#slot m 1) (+ 3 (* n 4)) end))))
206
207(declare (unused irregex-match-chunk&index-from-tag-set!))
208(define-compiler-syntax irregex-match-chunk&index-from-tag-set!
209  (syntax-rules ()
210    ((_ m t chunk index)
211     (begin
212       (vector-set! (##sys#slot m 1) (+ 4 (* t 2)) chunk)
213       (vector-set! (##sys#slot m 1) (+ 5 (* t 2)) index)))))
214
215(include "irregex-core.scm")
216(include "irregex-utils.scm")
217
218(set! *allow-utf8-mode?* #f)
219
220(define glob->sre
221  (let ((list->string list->string)
222        (string->list string->list))
223    (lambda (s)
224      (##sys#check-string s 'glob->sre)
225      (cons
226       ':
227       (let loop ((cs (string->list s)) (dir #t))
228	 (if (null? cs)
229	     '()
230	     (let ((c (car cs))
231		   (rest (cdr cs)) )
232	       (cond ((char=? c #\*)
233		      (if dir
234			  `((or (: (~ ("./\\"))
235				   (* (~ ("/\\"))))
236				(* (~ ("./\\"))))
237			    ,@(loop rest #f))
238			  `((* (~ ("/\\"))) ,@(loop rest #f))))
239		     ((char=? c #\?)  (cons 'any (loop rest #f)))
240		     ((char=? c #\[)
241		      (let loop2 ((rest rest) (s '()))
242			(cond ((not (pair? rest))
243			       (error 'glob->sre
244				      "unexpected end of character class" s))
245			      ((char=? #\] (car rest))
246			       `(,(if (> (length s) 1)
247				      `(or ,@s)
248				      (car s))
249				 ,@(loop (cdr rest) #f)))
250			      ((and (pair? (cdr rest))
251				    (pair? (cddr rest))
252				    (char=? #\- (cadr rest)) )
253			       (loop2 (cdddr rest)
254				      (cons `(/ ,(car rest) ,(caddr rest)) s)))
255			      ((and (pair? (cdr rest))
256				    (char=? #\- (car rest)))
257			       (loop2 (cddr rest)
258				      (cons `(~ ,(cadr rest)) s)))
259			      (else
260			       (loop2 (cdr rest) (cons (car rest) s))))))
261		     (else (cons c (loop rest (memq c '(#\\ #\/)))))))))))))
262
263)