source: project/chicken/branches/beyond-hope/regex.scm @ 10439

Last change on this file since 10439 was 10439, checked in by felix winkelmann, 13 years ago

painfully slowly debugging compiler

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