source: project/chicken/branches/prerelease/regex.scm @ 9599

Last change on this file since 9599 was 9599, checked in by Ivan Raikov, 12 years ago

Merged trunk with prerelease branch.

File size: 23.4 KB
Line 
1;;;; regex.scm - Unit for using the PCRE regex package
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(cond-expand
29 [chicken-compile-shared]
30 [else (declare (unit regex))] )
31
32(declare
33  (usual-integrations)
34  (disable-interrupts)
35  (generic) ; PCRE options use lotsa bits
36  (disable-warning var)
37  (bound-to-procedure
38    ;; Forward reference
39    regex-chardef-table? make-anchored-pattern
40    ;; Imports
41    get-output-string open-output-string
42    string->list list->string string-length string-ref substring make-string string-append
43    reverse list-ref
44    char=? char-alphabetic? char-numeric? char->integer
45    set-finalizer!
46    ##sys#pointer?
47    ##sys#slot ##sys#setslot ##sys#size
48    ##sys#make-structure ##sys#structure?
49    ##sys#error ##sys#signal-hook
50    ##sys#substring ##sys#fragments->string ##sys#make-c-string ##sys#string-append
51    ##sys#write-char-0 )
52  (export
53    regex-chardef-table? regex-chardef-table
54    regexp? regexp regexp*
55    regexp-optimize
56    make-anchored-pattern
57    string-match string-match-positions string-search string-search-positions
58    string-split-fields string-substitute string-substitute*
59    glob? glob->regexp
60    grep
61    regexp-escape ) )
62
63(cond-expand
64 [paranoia]
65 [else
66  (declare
67    (no-bound-checks)
68    (no-procedure-checks-for-usual-bindings) ) ] )
69
70(cond-expand
71 [unsafe
72  (eval-when (compile)
73    (define-macro (##sys#check-chardef-table . _) '(##core#undefined))
74    (define-macro (##sys#check-integer . _) '(##core#undefined))
75    (define-macro (##sys#check-blob . _) '(##core#undefined))
76    (define-macro (##sys#check-vector . _) '(##core#undefined))
77    (define-macro (##sys#check-structure . _) '(##core#undefined))
78    (define-macro (##sys#check-range . _) '(##core#undefined))
79    (define-macro (##sys#check-pair . _) '(##core#undefined))
80    (define-macro (##sys#check-list . _) '(##core#undefined))
81    (define-macro (##sys#check-symbol . _) '(##core#undefined))
82    (define-macro (##sys#check-string . _) '(##core#undefined))
83    (define-macro (##sys#check-char . _) '(##core#undefined))
84    (define-macro (##sys#check-exact . _) '(##core#undefined))
85    (define-macro (##sys#check-port . _) '(##core#undefined))
86    (define-macro (##sys#check-number . _) '(##core#undefined))
87    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
88 [else
89  (define (##sys#check-chardef-table x loc)
90    (unless (regex-chardef-table? x)
91      (##sys#error loc "invalid character definition tables structure" x) ) )
92  (declare
93    (bound-to-procedure
94      ;; Imports
95      ##sys#check-string ##sys#check-list ##sys#check-exact ##sys#check-vector
96      ##sys#check-structure ##sys#check-symbol ##sys#check-blob ##sys#check-integer )
97    (export
98      ##sys#check-chardef-table )
99    (emit-exports "regex.exports") ) ] )
100
101
102;;;
103
104#>#include "pcre.h"<#
105
106
107;;;
108
109(register-feature! 'regex 'pcre)
110
111
112;;; From unit lolevel:
113
114(define-inline (%tag-pointer ptr tag)
115  (let ([tp (##sys#make-tagged-pointer tag)])
116    (##core#inline "C_copy_pointer" ptr tp)
117    tp ) )
118
119(define-inline (%tagged-pointer? x tag)
120  (and (##core#inline "C_blockp" x)
121       (##core#inline "C_taggedpointerp" x)
122       (eq? tag (##sys#slot x 1)) ) )
123
124
125;;; PCRE Types:
126
127(define-foreign-type pcre (c-pointer "pcre"))
128(define-foreign-type nonnull-pcre (nonnull-c-pointer "pcre"))
129
130(define-foreign-type pcre_extra (c-pointer "pcre_extra"))
131(define-foreign-type nonnull-pcre_extra (nonnull-c-pointer "pcre_extra"))
132
133(define-foreign-variable PCRE_CASELESS unsigned-integer)
134(define-foreign-variable PCRE_EXTENDED unsigned-integer)
135(define-foreign-variable PCRE_UTF8 unsigned-integer)
136
137;FIXME the use of 'define-foreign-enum' causes unused global variable warning!
138
139(define-foreign-enum (pcre-option unsigned-integer)
140  (caseless             PCRE_CASELESS)
141  (multiline            PCRE_MULTILINE)
142  (dotall               PCRE_DOTALL)
143  (extended             PCRE_EXTENDED)
144  (anchored             PCRE_ANCHORED)
145  (dollar-endonly       PCRE_DOLLAR_ENDONLY)
146  (extra                PCRE_EXTRA)
147  (notbol               PCRE_NOTBOL)
148  (noteol               PCRE_NOTEOL)
149  (ungreedy             PCRE_UNGREEDY)
150  (notempty             PCRE_NOTEMPTY)
151  (utf8                 PCRE_UTF8)
152  (no-auto-capture      PCRE_NO_AUTO_CAPTURE)
153  (no-utf8-check        PCRE_NO_UTF8_CHECK)
154  (auto-callout         PCRE_AUTO_CALLOUT)
155  (partial              PCRE_PARTIAL)
156  (dfa-shortest         PCRE_DFA_SHORTEST)
157  (dfa-restart          PCRE_DFA_RESTART)
158  (firstline            PCRE_FIRSTLINE)
159  (dupnames             PCRE_DUPNAMES)
160  (newline-cr           PCRE_NEWLINE_CR)
161  (newline-lf           PCRE_NEWLINE_LF)
162  (newline-crlf         PCRE_NEWLINE_CRLF)
163  (newline-any          PCRE_NEWLINE_ANY)
164  (newline-anycrlf      PCRE_NEWLINE_ANYCRLF)
165  (bsr-anycrlf          PCRE_BSR_ANYCRLF)
166  (bsr-unicode          PCRE_BSR_UNICODE) )
167
168
169;;; The regexp structure primitives:
170
171(define re-finalizer
172  (foreign-lambda void "pcre_free" c-pointer) )
173
174(define-inline (%make-regexp code)
175  (set-finalizer! code re-finalizer)
176  (##sys#make-structure 'regexp code #f 0) )
177
178(define-inline (%regexp? x)
179  (##sys#structure? x 'regexp) )
180
181(define-inline (%regexp-code rx)
182  (##sys#slot rx 1) )
183
184(define-inline (%regexp-extra rx)
185  (##sys#slot rx 2) )
186
187(define-inline (%regexp-options rx)
188  (##sys#slot rx 3) )
189
190(define-inline (%regexp-extra-set! rx extra)
191  (when extra (set-finalizer! extra re-finalizer))
192  (##sys#setslot rx 2 extra) )
193
194(define-inline (%regexp-options-set! rx options)
195  (##sys#setslot rx 3 options) )
196
197
198;;; Character Definition Tables:
199
200;; The minimum necessary to handle chardef table parameters.
201
202;;
203
204(define (regex-chardef-table? x)
205  (%tagged-pointer? x 'chardef-table) )
206
207;; Get a character definitions tables structure for the current locale.
208
209(define regex-chardef-table
210  (let ([re-maketables
211          (foreign-lambda* (c-pointer unsigned-char) ()
212            "return (pcre_maketables ());")]
213        [re-make-chardef-table-type
214          (lambda (tables)
215            (%tag-pointer tables 'chardef-table) ) ] )
216    (lambda (#!optional tables)
217      ; Using this to type tag a ref is a bit of a hack but beats
218      ; having another public variable.
219      (if tables
220          ; then existing reference so just tag it
221          (if (##sys#pointer? tables)
222              (re-make-chardef-table-type tables)
223              (##sys#signal-hook #:type-error 'regex-chardef-table
224               "bad argument type - not a pointer" tables) )
225          ; else make a new chardef tables
226          (let ([tables (re-maketables)])
227            (if tables
228                (let ([tables (re-make-chardef-table-type tables)])
229                  (set-finalizer! tables re-finalizer)
230                  tables )
231                (##sys#error-hook 6 'regex-chardef-table) ) ) ) ) ) )
232
233
234;;; Regexp record:
235
236(define (regexp? x)
237  (%regexp? x) )
238
239
240;;; PCRE errors:
241
242#>
243static const char *C_regex_error;
244static int C_regex_error_offset;
245<#
246
247(define-foreign-variable C_regex_error c-string)
248(define-foreign-variable C_regex_error_offset int)
249
250(define re-error
251  (let ([string-append string-append])
252    (lambda (loc msg . args)
253      (apply ##sys#error loc (string-append msg " - " C_regex_error) args) ) ) )
254
255;;; Compile regular expression:
256
257;FIXME nonnull-unsigned-c-string causes problems - converted string is too long!
258
259(define re-compile
260  (foreign-lambda* pcre ((nonnull-c-string patt) (unsigned-integer options) ((const (c-pointer unsigned-char)) tables))
261    "return(pcre_compile(patt, options, &C_regex_error, &C_regex_error_offset, tables));") )
262
263(define (re-checked-compile pattern options tables loc)
264  (##sys#check-string pattern loc)
265  (or (re-compile pattern options #f)
266      (re-error loc "cannot compile regular expression" pattern C_regex_error_offset) ) )
267
268;; Compile with subset of options and no tables
269
270(define (regexp pattern . options)
271  (let ([options->integer
272          (lambda ()
273            (if (null? options)
274                0
275                (+ (if (car options) PCRE_CASELESS 0)
276                   (let ((options (cdr options)))
277                     (if (null? options)
278                         0
279                         (+ (if (car options) PCRE_EXTENDED 0)
280                            (let ((options (cdr options)))
281                              (if (and (pair? options) (car options)) PCRE_UTF8 0 ) ) ) ) ) ) ) )])
282    (%make-regexp (re-checked-compile pattern (options->integer) #f 'regexp)) ) )
283
284;; Compile with full options and tables available
285
286(define (regexp* pattern . args)
287  (let-optionals args ([options '()] [tables #f])
288    (##sys#check-string pattern 'regexp*)
289    (##sys#check-list options 'regexp*)
290    (when tables (##sys#check-chardef-table tables 'regexp*))
291    (%make-regexp (re-checked-compile pattern (pcre-option->number options) tables 'regexp*)) ) )
292
293
294;;; Optimize compiled regular expression:
295
296;; Invoke optimizer
297
298(define re-study
299  (foreign-lambda* pcre_extra (((const nonnull-pcre) code))
300    "return(pcre_study(code, 0, &C_regex_error));"))
301
302;; Optimize compiled regular expression
303;; Returns whether optimization performed
304
305(define (regexp-optimize rx)
306  (##sys#check-structure rx 'regexp 'regexp-optimize)
307  (let ([extra (re-study (%regexp-code rx))])
308    (cond [C_regex_error
309            (re-error 'regexp-optimize "cannot optimize regular expression" rx)]
310          [extra
311            (%regexp-extra-set! rx extra)
312            #t]
313          [else
314            #f] ) ) )
315
316
317;;; Captured results vector:
318
319;; Match positions vector (PCRE ovector)
320
321#>
322#define OVECTOR_LENGTH_MULTIPLE 3
323#define STATIC_OVECTOR_LEN 256
324static int C_regex_ovector[OVECTOR_LENGTH_MULTIPLE * STATIC_OVECTOR_LEN];
325<#
326
327;;
328
329(define ovector-start-ref
330  (foreign-lambda* int ((int i))
331    "return(C_regex_ovector[i * 2]);") )
332
333(define ovector-end-ref
334  (foreign-lambda* int ((int i))
335    "return(C_regex_ovector[(i * 2) + 1]);") )
336
337
338;;; Gather matched result strings or positions:
339
340(define (gather-result-positions result)
341  (let ([mc (car result)]
342        [cc (cadr result)])
343    (and (fx> mc 0)
344         (let loop ([i 0])
345           (cond [(fx>= i cc)
346                   '()]
347                 [(fx>= i mc)
348                   (cons #f (loop (fx+ i 1)))]
349                 [else
350                  (let ([start (ovector-start-ref i)])
351                    (cons (and (fx>= start 0)
352                               (list start (ovector-end-ref i)))
353                          (loop (fx+ i 1)) ) ) ] ) ) ) ) )
354
355(define gather-results
356  (let ([substring substring])
357    (lambda (str result)
358      (let ([ps (gather-result-positions result)])
359        (and ps
360             (##sys#map (lambda (poss) (and poss (apply substring str poss))) ps) ) ) ) ) )
361
362
363;;; Common match string with compile regular expression:
364
365(define re-match
366  (foreign-lambda* int (((const nonnull-pcre) code) ((const pcre_extra) extra)
367                        (nonnull-scheme-pointer str) (int start) (int range)
368                        (unsigned-integer options))
369    "return(pcre_exec(code, extra, str, start + range, start, options, C_regex_ovector, STATIC_OVECTOR_LEN * OVECTOR_LENGTH_MULTIPLE));") )
370
371(define re-match-capture-count
372  (foreign-lambda* int (((const nonnull-pcre) code) ((const pcre_extra) extra))
373    "int cc;"
374    "pcre_fullinfo(code, extra, PCRE_INFO_CAPTURECOUNT, &cc);"
375    "return(cc + 1);") )
376
377(define (perform-match rgxp str si ri loc)
378  (let* ([extra #f]
379         [options 0]
380         [rx
381          (cond [(string? rgxp)
382                  (re-checked-compile rgxp 0 #f loc)]
383                [(%regexp? rgxp)
384                  (set! extra (%regexp-extra rgxp))
385                  (set! options (%regexp-options rgxp))
386                  (%regexp-code rgxp)]
387                [else
388                  (##sys#signal-hook #:type-error
389                                     loc
390                                     "bad argument type - not a string or compiled regular expression"
391                                     rgxp)] )]
392         [cc (re-match-capture-count rx extra)]
393         [mc (re-match rx extra str si ri options)])
394    (when (string? rgxp) (re-finalizer rx))
395    (list mc cc) ) )
396
397
398;;; Match string with regular expression:
399
400;; Note that start is a BYTE offset
401
402(define string-match)
403(define string-match-positions)
404(let ()
405
406  (define (prepare-match rgxp str start loc)
407    (##sys#check-string str loc)
408    (let ([si (if (pair? start) (car start) 0)])
409      (##sys#check-exact si loc)
410      (perform-match (if (string? rgxp)
411                         (make-anchored-pattern rgxp (fx< 0 si))
412                         rgxp)
413                     str si (fx- (##sys#size str) si)
414                     loc) ) )
415
416  (set! string-match
417    (lambda (rgxp str . start)
418      (gather-results str (prepare-match rgxp str start 'string-match)) ) )
419
420  (set! string-match-positions
421    (lambda (rgxp str . start)
422      (gather-result-positions (prepare-match rgxp str start 'string-match-positions)) ) ) )
423
424
425;;; Search string with regular expression:
426
427;; Note that start & range are BYTE offsets
428
429
430(define string-search)
431(define string-search-positions)
432(let ()
433
434  (define (prepare-search rgxp str start-and-range loc)
435    (##sys#check-string str loc)
436    (let* ([range (and (pair? start-and-range) (cdr start-and-range)) ]
437           [si (if range (car start-and-range) 0)]
438           [ri (if (pair? range) (car range) (fx- (##sys#size str) si))] )
439      (##sys#check-exact si loc)
440      (##sys#check-exact ri loc)
441      (perform-match rgxp str si ri loc) ) )
442
443  (set! string-search
444    (lambda (rgxp str . start-and-range)
445      (gather-results str (prepare-search rgxp str start-and-range 'string-search)) ) )
446
447  (set! string-search-positions
448    (lambda (rgxp str . start-and-range)
449      (gather-result-positions (prepare-search rgxp str start-and-range 'string-search-positions)) ) ) )
450
451
452;;; Split string into fields:
453
454(define string-split-fields
455  (let ([reverse reverse]
456        [substring substring]
457        [string-search-positions string-search-positions] )
458    (lambda (rgxp str . mode-and-start)
459      (##sys#check-string str 'string-split-fields)
460      (let* ([argc (length mode-and-start)]
461             [len (##sys#size str)]
462             [mode (if (fx> argc 0) (car mode-and-start) #t)]
463             [start (if (fx> argc 1) (cadr mode-and-start) 0)]
464             [fini (case mode
465                     [(#:suffix)
466                      (lambda (ms start)
467                        (if (fx< start len)
468                            (##sys#error 'string-split-fields
469                                         "record does not end with suffix" str rgxp)
470                            (reverse ms) ) ) ]
471                     [(#:infix)
472                      (lambda (ms start)
473                        (if (fx>= start len)
474                            (reverse (cons "" ms))
475                            (reverse (cons (substring str start len) ms)) ) ) ]
476                     [else (lambda (ms start) (reverse ms)) ] ) ]
477             [fetch (case mode
478                      [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
479                      [else (lambda (start from to) (substring str from to))] ) ] )
480        (let loop ([ms '()] [start start])
481          (let ([m (string-search-positions rgxp str start)])
482            (if m
483                (let* ([mp (car m)]
484                       [from (car mp)]
485                       [to (cadr mp)] )
486                  (if (fx= from to)
487                      (if (fx= to len)
488                          (fini ms start)
489                          (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
490                      (loop (cons (fetch start from to) ms) to) ) )
491                (fini ms start) ) ) ) ) ) ) )
492
493
494;;; Substitute matching strings:
495
496(define string-substitute
497  (let ([substring substring]
498        [reverse reverse]
499        [make-string make-string]
500        [string-search-positions string-search-positions] )
501    (lambda (regex subst string . flag)
502      (##sys#check-string subst 'string-substitute)
503      (let* ([which (if (pair? flag) (car flag) 1)]
504             [substlen (##sys#size subst)]
505             [substlen-1 (fx- substlen 1)]
506             [result '()]
507             [total 0] )
508        (define (push x)
509          (set! result (cons x result))
510          (set! total (fx+ total (##sys#size x))) )
511        (define (substitute matches)
512          (let loop ([start 0] [index 0])
513            (if (fx>= index substlen-1)
514                (push (if (fx= start 0) subst (substring subst start substlen)))
515                (let ([c (##core#inline "C_subchar" subst index)]
516                      [index+1 (fx+ index 1)] )
517                  (if (char=? c #\\)
518                      (let ([c2 (##core#inline "C_subchar" subst index+1)])
519                        (if (and (not (char=? #\\ c2)) (char-numeric? c2))
520                            (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
521                              (push (substring subst start index))
522                              (push (substring string (car mi) (cadr mi)))
523                              (loop (fx+ index 2) index+1) )
524                            (loop start (fx+ index+1 1)) ) )
525                      (loop start index+1) ) ) ) ) )
526        (let loop ([index 0] [count 1])
527          (let ([matches (string-search-positions regex string index)])
528            (cond [matches
529                   (let* ([range (car matches)]
530                          [upto (cadr range)] )
531                     (cond ((fx= 0 (fx- (cadr range) (car range)))
532                            (##sys#error
533                             'string-substitute "empty substitution match"
534                             regex) )
535                           ((or (not (fixnum? which)) (fx= count which))
536                            (push (substring string index (car range)))
537                            (substitute matches)
538                            (loop upto #f) )
539                           (else
540                            (push (substring string index upto))
541                            (loop upto (fx+ count 1)) ) ) ) ]
542                  [else
543                   (push (substring string index (##sys#size string)))
544                   (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
545
546(define string-substitute*
547  (let ([string-substitute string-substitute])
548    (lambda (str smap . mode)
549      (##sys#check-string str 'string-substitute*)
550      (##sys#check-list smap 'string-substitute*)
551      (let ((mode (and (pair? mode) (car mode))))
552        (let loop ((str str) (smap smap))
553          (if (null? smap)
554              str
555              (let ((sm (car smap)))
556                (loop (string-substitute (car sm) (cdr sm) str mode)
557                      (cdr smap) ) ) ) ) ) ) ) )
558
559
560;;; Glob support:
561
562;FIXME is it worthwhile making this accurate?
563(define (glob? str)
564  (##sys#check-string str 'glob?)
565  (let loop ([idx (fx- (string-length str) 1)])
566    (and (fx<= 0 idx)
567         (case (string-ref str idx)
568           [(#\* #\] #\?)
569             (or (fx= 0 idx)
570                 (not (char=? #\\ (string-ref str (fx- idx 1))))
571                 (loop (fx- idx 2)))]
572           [else
573             (loop (fx- idx 1))]) ) ) )
574
575(define glob->regexp
576  (let ([list->string list->string]
577        [string->list string->list] )
578    (lambda (s)
579      (##sys#check-string s 'glob->regexp)
580      (list->string
581       (let loop ((cs (string->list s)))
582         (if (null? cs)
583             '()
584             (let ([c (car cs)]
585                   [rest (cdr cs)] )
586               (cond [(char=? c #\*)  `(#\. #\* ,@(loop rest))]
587                     [(char=? c #\?)  (cons '#\. (loop rest))]
588                     [(char=? c #\[)
589                      (cons
590                       #\[
591                       (let loop2 ((rest rest))
592                         (match rest
593                           [(#\] . more)        (cons #\] (loop more))]
594                           [(#\- c . more)      `(#\- ,c ,@(loop2 more))]
595                           [(c1 #\- c2 . more)  `(,c1 #\- ,c2 ,@(loop2 more))]
596                           [(c . more)          (cons c (loop2 more))]
597                           [()
598                            (error 'glob->regexp "unexpected end of character class" s)] ) ) ) ]
599                     [(or (char-alphabetic? c) (char-numeric? c)) (cons c (loop rest))]
600                     [else `(#\\ ,c ,@(loop rest))] ) ) ) ) ) ) ) )
601
602
603;;; Grep-like function on list:
604
605(define grep
606  (let ([string-search string-search])
607    (lambda (rgxp lst)
608      (##sys#check-list lst 'grep)
609      (let loop ([lst lst])
610        (if (null? lst)
611            '()
612            (let ([x (car lst)]
613                  [r (cdr lst)] )
614              (if (string-search rgxp x)
615                  (cons x (loop r))
616                  (loop r) ) ) ) ) ) ) )
617
618
619;;; Escape regular expression (suggested by Peter Bex):
620
621(define regexp-escape
622  (let ([open-output-string open-output-string]
623        [get-output-string get-output-string] )
624    (lambda (str)
625      (##sys#check-string str 'regexp-escape)
626      (let ([out (open-output-string)]
627            [len (##sys#size str)] )
628        (let loop ([i 0])
629          (cond [(fx>= i len) (get-output-string out)]
630                [(memq (##core#inline "C_subchar" str i)
631                       '(#\. #\\ #\? #\* #\+ #\^ #\$ #\( #\) #\[ #\] #\| #\{ #\}))
632                 (##sys#write-char-0 #\\ out)
633                 (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
634                 (loop (fx+ i 1)) ]
635                [else
636                 (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
637                 (loop (fx+ i 1)) ] ) ) ) ) ) )
638
639
640;;; Anchored pattern:
641
642(define make-anchored-pattern
643  (let ([string-append string-append])
644    (lambda (rgxp . args)
645      (let-optionals args ([nos #f] [noe #f])
646        (cond [(string? rgxp)
647                (string-append (if nos "" "^") rgxp (if noe "" "$"))]
648              [else
649                (##sys#check-structure rgxp 'regexp 'make-anchored-pattern)
650                (when (or nos noe)
651                  (warning 'make-anchored-pattern
652                           "cannot select partial anchor for compiled regular expression") )
653                (%regexp-options-set! rgxp
654                                      (bitwise-or (%regexp-options regexp)
655                                                  (pcre-option->number 'anchored)))
656                rgxp] ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.