Source

compiler-libs-hack / ocaml / otherlibs / str / str.ml

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file ../../LICENSE.  *)
(*                                                                     *)
(***********************************************************************)

(** String utilities *)

let string_before s n = String.sub s 0 n

let string_after s n = String.sub s n (String.length s - n)

let first_chars s n = String.sub s 0 n

let last_chars s n = String.sub s (String.length s - n) n

(** Representation of character sets **)

module Charset =
  struct
    type t = string (* of length 32 *)

    (*let empty = String.make 32 '\000'*)
    let full = String.make 32 '\255'

    let make_empty () = String.make 32 '\000'

    let add s c =
      let i = Char.code c in
      s.[i lsr 3] <- Char.chr(Char.code s.[i lsr 3] lor (1 lsl (i land 7)))

    let add_range s c1 c2 =
      for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done

    let singleton c =
      let s = make_empty () in add s c; s

    (*let range c1 c2 =
      let s = make_empty () in add_range s c1 c2; s
    *)
    let complement s =
      let r = String.create 32 in
      for i = 0 to 31 do
        r.[i] <- Char.chr(Char.code s.[i] lxor 0xFF)
      done;
      r

    let union s1 s2 =
      let r = String.create 32 in
      for i = 0 to 31 do
        r.[i] <- Char.chr(Char.code s1.[i] lor Char.code s2.[i])
      done;
      r

    let disjoint s1 s2 =
      try
        for i = 0 to 31 do
          if Char.code s1.[i] land Char.code s2.[i] <> 0 then raise Exit
        done;
        true
      with Exit ->
        false

    let iter fn s =
      for i = 0 to 31 do
        let c = Char.code s.[i] in
        if c <> 0 then
          for j = 0 to 7 do
            if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j))
          done
      done

    let expand s =
      let r = String.make 256 '\000' in
      iter (fun c -> r.[Char.code c] <- '\001') s;
      r

    let fold_case s =
      let r = make_empty() in
      iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s;
      r

  end

(** Abstract syntax tree for regular expressions *)

type re_syntax =
    Char of char
  | String of string
  | CharClass of Charset.t * bool  (* true = complemented, false = normal *)
  | Seq of re_syntax list
  | Alt of re_syntax * re_syntax
  | Star of re_syntax
  | Plus of re_syntax
  | Option of re_syntax
  | Group of int * re_syntax
  | Refgroup of int
  | Bol
  | Eol
  | Wordboundary

(** Representation of compiled regular expressions *)

type regexp = {
  prog: int array;         (* bytecode instructions *)
  cpool: string array;     (* constant pool (string literals) *)
  normtable: string;       (* case folding table (if any) *)
  numgroups: int;          (* number of \(...\) groups *)
  numregisters: int;       (* number of nullable Star or Plus *)
  startchars: int          (* index of set of starting chars, or -1 if none *)
}

(** Opcodes for bytecode instructions; see strstubs.c for description *)

let op_CHAR = 0
let op_CHARNORM = 1
let op_STRING = 2
let op_STRINGNORM = 3
let op_CHARCLASS = 4
let op_BOL = 5
let op_EOL = 6
let op_WORDBOUNDARY = 7
let op_BEGGROUP = 8
let op_ENDGROUP = 9
let op_REFGROUP = 10
let op_ACCEPT = 11
let op_SIMPLEOPT = 12
let op_SIMPLESTAR = 13
let op_SIMPLEPLUS = 14
let op_GOTO = 15
let op_PUSHBACK = 16
let op_SETMARK = 17
let op_CHECKPROGRESS = 18

(* Encoding of bytecode instructions *)

let instr opc arg = opc lor (arg lsl 8)

(* Computing relative displacements for GOTO and PUSHBACK instructions *)

let displ dest from = dest - from - 1

(** Compilation of a regular expression *)

(* Determine if a regexp can match the empty string *)

let rec is_nullable = function
    Char c -> false
  | String s -> s = ""
  | CharClass(cl, cmpl) -> false
  | Seq rl -> List.for_all is_nullable rl
  | Alt (r1, r2) -> is_nullable r1 || is_nullable r2
  | Star r -> true
  | Plus r -> is_nullable r
  | Option r -> true
  | Group(n, r) -> is_nullable r
  | Refgroup n -> true
  | Bol -> true
  | Eol -> true
  | Wordboundary -> true

(* first r returns a set of characters C such that:
     for all string s, s matches r => the first character of s is in C.
   For convenience, return Charset.full if r is nullable. *)

let rec first = function
    Char c -> Charset.singleton c
  | String s -> if s = "" then Charset.full else Charset.singleton s.[0]
  | CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl
  | Seq rl -> first_seq rl
  | Alt (r1, r2) -> Charset.union (first r1) (first r2)
  | Star r -> Charset.full
  | Plus r -> first r
  | Option r -> Charset.full
  | Group(n, r) -> first r
  | Refgroup n -> Charset.full
  | Bol -> Charset.full
  | Eol -> Charset.full
  | Wordboundary -> Charset.full

and first_seq = function
    [] -> Charset.full
  | (Bol | Eol | Wordboundary) :: rl -> first_seq rl
  | Star r :: rl -> Charset.union (first r) (first_seq rl)
  | Option r :: rl -> Charset.union (first r) (first_seq rl)
  | r :: rl -> first r

(* Transform a Char or CharClass regexp into a character class *)

let charclass_of_regexp fold_case re =
  let (cl1, compl) =
    match re with
    | Char c -> (Charset.singleton c, false)
    | CharClass(cl, compl) -> (cl, compl)
    | _ -> assert false in
  let cl2 = if fold_case then Charset.fold_case cl1 else cl1 in
  if compl then Charset.complement cl2 else cl2

(* The case fold table: maps characters to their lowercase equivalent *)

let fold_case_table =
  let t = String.create 256 in
  for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done;
  t

module StringMap =
  Map.Make(struct type t = string let compare (x:t) y = compare x y end)

(* Compilation of a regular expression *)

let compile fold_case re =

  (* Instruction buffering *)
  let prog = ref (Array.make 32 0)
  and progpos = ref 0
  and cpool = ref StringMap.empty
  and cpoolpos = ref 0
  and numgroups = ref 1
  and numregs = ref 0 in
  (* Add a new instruction *)
  let emit_instr opc arg =
    if !progpos >= Array.length !prog then begin
      let newlen = ref (Array.length !prog) in
      while !progpos >= !newlen do newlen := !newlen * 2 done;
      let nprog = Array.make !newlen 0 in
      Array.blit !prog 0 nprog 0 (Array.length !prog);
      prog := nprog
    end;
    (!prog).(!progpos) <- (instr opc arg);
    incr progpos in
  (* Reserve an instruction slot and return its position *)
  let emit_hole () =
    let p = !progpos in incr progpos; p in
  (* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *)
  let patch_instr pos opc dest =
    (!prog).(pos) <- (instr opc (displ dest pos)) in
  (* Return the cpool index for the given string, adding it if not
     already there *)
  let cpool_index s =
    try
      StringMap.find s !cpool
    with Not_found ->
      let p = !cpoolpos in
      cpool := StringMap.add s p !cpool;
      incr cpoolpos;
      p in
  (* Allocate fresh register if regexp is nullable *)
  let allocate_register_if_nullable r =
    if is_nullable r then begin
      let n = !numregs in
      if n >= 64 then failwith "too many r* or r+ where r is nullable";
      incr numregs;
      n
    end else
      -1 in
  (* Main recursive compilation function *)
  let rec emit_code = function
    Char c ->
      if fold_case then
        emit_instr op_CHARNORM (Char.code (Char.lowercase c))
      else
        emit_instr op_CHAR (Char.code c)
  | String s ->
      begin match String.length s with
        0 -> ()
      | 1 ->
        if fold_case then
          emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0]))
        else
          emit_instr op_CHAR (Char.code s.[0])
      | _ ->
        try
          (* null characters are not accepted by the STRING* instructions;
             if one is found, split string at null character *)
          let i = String.index s '\000' in
          emit_code (String (string_before s i));
          emit_instr op_CHAR 0;
          emit_code (String (string_after s (i+1)))
        with Not_found ->
          if fold_case then
            emit_instr op_STRINGNORM (cpool_index (String.lowercase s))
          else
            emit_instr op_STRING (cpool_index s)
      end
  | CharClass(cl, compl) ->
      let cl1 = if fold_case then Charset.fold_case cl else cl in
      let cl2 = if compl then Charset.complement cl1 else cl1 in
      emit_instr op_CHARCLASS (cpool_index cl2)
  | Seq rl ->
      emit_seq_code rl
  | Alt(r1, r2) ->
      (*      PUSHBACK lbl1
              <match r1>
              GOTO lbl2
        lbl1: <match r2>
        lbl2: ... *)
      let pos_pushback = emit_hole() in
      emit_code r1;
      let pos_goto_end = emit_hole() in
      let lbl1 = !progpos in
      emit_code r2;
      let lbl2 = !progpos in
      patch_instr pos_pushback op_PUSHBACK lbl1;
      patch_instr pos_goto_end op_GOTO lbl2
  | Star r ->
      (* Implement longest match semantics for compatibility with old Str *)
      (* General translation:
           lbl1: PUSHBACK lbl2
                 SETMARK regno
                 <match r>
                 CHECKPROGRESS regno
                 GOTO lbl1
           lbl2:
         If r cannot match the empty string, code can be simplified:
           lbl1: PUSHBACK lbl2
                 <match r>
                 GOTO lbl1
           lbl2:
        *)
      let regno = allocate_register_if_nullable r in
      let lbl1 = emit_hole() in
      if regno >= 0 then emit_instr op_SETMARK regno;
      emit_code r;
      if regno >= 0 then emit_instr op_CHECKPROGRESS regno;
      emit_instr op_GOTO (displ lbl1 !progpos);
      let lbl2 = !progpos in
      patch_instr lbl1 op_PUSHBACK lbl2
  | Plus r ->
      (* Implement longest match semantics for compatibility with old Str *)
      (* General translation:
           lbl1: <match r>
                 CHECKPROGRESS regno
                 PUSHBACK lbl2
                 SETMARK regno
                 GOTO lbl1
           lbl2:
         If r cannot match the empty string, code can be simplified:
           lbl1: <match r>
                 PUSHBACK lbl2
                 GOTO_PLUS lbl1
           lbl2:
      *)
      let regno = allocate_register_if_nullable r in
      let lbl1 = !progpos in
      emit_code r;
      if regno >= 0 then emit_instr op_CHECKPROGRESS regno;
      let pos_pushback = emit_hole() in
      if regno >= 0 then emit_instr op_SETMARK regno;
      emit_instr op_GOTO (displ lbl1 !progpos);
      let lbl2 = !progpos in
      patch_instr pos_pushback op_PUSHBACK lbl2
  | Option r ->
      (* Implement longest match semantics for compatibility with old Str *)
      (*      PUSHBACK lbl
              <match r>
         lbl:
      *)
      let pos_pushback = emit_hole() in
      emit_code r;
      let lbl = !progpos in
      patch_instr pos_pushback op_PUSHBACK lbl
  | Group(n, r) ->
      if n >= 32 then failwith "too many \\(...\\) groups";
      emit_instr op_BEGGROUP n;
      emit_code r;
      emit_instr op_ENDGROUP n;
      numgroups := max !numgroups (n+1)
  | Refgroup n ->
      emit_instr op_REFGROUP n
  | Bol ->
      emit_instr op_BOL 0
  | Eol ->
      emit_instr op_EOL 0
  | Wordboundary ->
      emit_instr op_WORDBOUNDARY 0

  and emit_seq_code = function
    [] -> ()
  | Star(Char _ | CharClass _ as r) :: rl
    when disjoint_modulo_case (first r) (first_seq rl) ->
      emit_instr op_SIMPLESTAR (cpool_index (charclass_of_regexp fold_case r));
      emit_seq_code rl
  | Plus(Char _ | CharClass _ as r) :: rl
    when disjoint_modulo_case (first r) (first_seq rl) ->
      emit_instr op_SIMPLEPLUS (cpool_index (charclass_of_regexp fold_case r));
      emit_seq_code rl
  | Option(Char _ | CharClass _ as r) :: rl
    when disjoint_modulo_case (first r) (first_seq rl) ->
      emit_instr op_SIMPLEOPT (cpool_index (charclass_of_regexp fold_case r));
      emit_seq_code rl
  | r :: rl ->
      emit_code r;
      emit_seq_code rl

  and disjoint_modulo_case c1 c2 =
    if fold_case
    then Charset.disjoint (Charset.fold_case c1) (Charset.fold_case c2)
    else Charset.disjoint c1 c2
  in

  emit_code re;
  emit_instr op_ACCEPT 0;
  let start = first re in
  let start' = if fold_case then Charset.fold_case start else start in
  let start_pos =
    if start = Charset.full
    then -1
    else cpool_index (Charset.expand start') in
  let constantpool = Array.make !cpoolpos "" in
  StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool;
  { prog = Array.sub !prog 0 !progpos;
    cpool = constantpool;
    normtable = if fold_case then fold_case_table else "";
    numgroups = !numgroups;
    numregisters = !numregs;
    startchars = start_pos }

(** Parsing of a regular expression *)

(* Efficient buffering of sequences *)

module SeqBuffer = struct

  type t = { sb_chars: Buffer.t; mutable sb_next: re_syntax list }

  let create() = { sb_chars = Buffer.create 16; sb_next = [] }

  let flush buf =
    let s = Buffer.contents buf.sb_chars in
    Buffer.clear buf.sb_chars;
    match String.length s with
      0 -> ()
    | 1 -> buf.sb_next <- Char s.[0] :: buf.sb_next
    | _ -> buf.sb_next <- String s :: buf.sb_next

  let add buf re =
    match re with
      Char c -> Buffer.add_char buf.sb_chars c
    | _ -> flush buf; buf.sb_next <- re :: buf.sb_next

  let extract buf =
    flush buf; Seq(List.rev buf.sb_next)

end

(* The character class corresponding to `.' *)

let dotclass = Charset.complement (Charset.singleton '\n')

(* Parse a regular expression *)

let parse s =
  let len = String.length s in
  let group_counter = ref 1 in

  let rec regexp0 i =
    let (r, j) = regexp1 i in
    regexp0cont r j
  and regexp0cont r1 i =
    if i + 2 <= len && s.[i] = '\\' && s.[i+1] = '|' then
      let (r2, j) = regexp1 (i+2) in
      regexp0cont (Alt(r1, r2)) j
    else
      (r1, i)
  and regexp1 i =
    regexp1cont (SeqBuffer.create()) i
  and regexp1cont sb i =
    if i >= len
    || i + 2 <= len && s.[i] = '\\' && (let c = s.[i+1] in c = '|' || c = ')')
    then
      (SeqBuffer.extract sb, i)
    else
      let (r, j) = regexp2 i in
      SeqBuffer.add sb r;
      regexp1cont sb j
  and regexp2 i =
    let (r, j) = regexp3 i in
    regexp2cont r j
  and regexp2cont r i =
    if i >= len then (r, i) else
      match s.[i] with
        '?' -> regexp2cont (Option r) (i+1)
      | '*' -> regexp2cont (Star r) (i+1)
      | '+' -> regexp2cont (Plus r) (i+1)
      |  _  -> (r, i)
  and regexp3 i =
    match s.[i] with
      '\\' -> regexpbackslash (i+1)
    | '['  -> let (c, compl, j) = regexpclass0 (i+1) in
              (CharClass(c, compl), j)
    | '^'  -> (Bol, i+1)
    | '$'  -> (Eol, i+1)
    | '.'  -> (CharClass(dotclass, false), i+1)
    | c    -> (Char c, i+1)
  and regexpbackslash i =
    if i >= len then (Char '\\', i) else
      match s.[i] with
        '|' | ')' ->
          assert false
      | '(' ->
          let group_no = !group_counter in
          if group_no < 32 then incr group_counter;
          let (r, j) = regexp0 (i+1) in
          if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then
            if group_no < 32
            then (Group(group_no, r), j + 2)
            else (r, j + 2)
          else
            failwith "\\( group not closed by \\)"
      | '1' .. '9' as c ->
          (Refgroup(Char.code c - 48), i + 1)
      | 'b' ->
          (Wordboundary, i + 1)
      | c ->
          (Char c, i + 1)
  and regexpclass0 i =
    if i < len && s.[i] = '^'
    then let (c, j) = regexpclass1 (i+1) in (c, true, j)
    else let (c, j) = regexpclass1 i in (c, false, j)
  and regexpclass1 i =
    let c = Charset.make_empty() in
    let j = regexpclass2 c i i in
    (c, j)
  and regexpclass2 c start i =
    if i >= len then failwith "[ class not closed by ]";
    if s.[i] = ']' && i > start then i+1 else begin
      let c1 = s.[i] in
      if i+2 < len && s.[i+1] = '-' && s.[i+2] <> ']' then begin
        let c2 = s.[i+2] in
        Charset.add_range c c1 c2;
        regexpclass2 c start (i+3)
      end else begin
        Charset.add c c1;
        regexpclass2 c start (i+1)
      end
    end in

  let (r, j) = regexp0 0 in
  if j = len then r else failwith "spurious \\) in regular expression"

(** Parsing and compilation *)

let regexp e = compile false (parse e)

let regexp_case_fold e = compile true (parse e)

let quote s =
  let len = String.length s in
  let buf = String.create (2 * len) in
  let pos = ref 0 in
  for i = 0 to len - 1 do
    match s.[i] with
      '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c ->
        buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2
    | c ->
        buf.[!pos] <- c; pos := !pos + 1
  done;
  String.sub buf 0 !pos

let regexp_string s = compile false (String s)

let regexp_string_case_fold s = compile true (String s)

(** Matching functions **)

external re_string_match: regexp -> string -> int -> int array
     = "re_string_match"
external re_partial_match: regexp -> string -> int -> int array
     = "re_partial_match"
external re_search_forward: regexp -> string -> int -> int array
     = "re_search_forward"
external re_search_backward: regexp -> string -> int -> int array
     = "re_search_backward"

let last_search_result = ref [||]

let string_match re s pos =
  let res = re_string_match re s pos in
  last_search_result := res;
  Array.length res > 0

let string_partial_match re s pos =
  let res = re_partial_match re s pos in
  last_search_result := res;
  Array.length res > 0

let search_forward re s pos =
  let res = re_search_forward re s pos in
  last_search_result := res;
  if Array.length res = 0 then raise Not_found else res.(0)

let search_backward re s pos =
  let res = re_search_backward re s pos in
  last_search_result := res;
  if Array.length res = 0 then raise Not_found else res.(0)

let group_beginning n =
  let n2 = n + n in
  if n < 0 || n2 >= Array.length !last_search_result then
    invalid_arg "Str.group_beginning"
  else
    let pos = !last_search_result.(n2) in
    if pos = -1 then raise Not_found else pos

let group_end n =
  let n2 = n + n in
  if n < 0 || n2 >= Array.length !last_search_result then
    invalid_arg "Str.group_end"
  else
    let pos = !last_search_result.(n2 + 1) in
    if pos = -1 then raise Not_found else pos

let matched_group n txt =
  let n2 = n + n in
  if n < 0 || n2 >= Array.length !last_search_result then
    invalid_arg "Str.matched_group"
  else
    let b = !last_search_result.(n2)
    and e = !last_search_result.(n2 + 1) in
    if b = -1 then raise Not_found else String.sub txt b (e - b)

let match_beginning () = group_beginning 0
and match_end () = group_end 0
and matched_string txt = matched_group 0 txt

(** Replacement **)

external re_replacement_text: string -> int array -> string -> string
    = "re_replacement_text"

let replace_matched repl matched =
  re_replacement_text repl !last_search_result matched

let substitute_first expr repl_fun text =
  try
    let pos = search_forward expr text 0 in
    String.concat "" [string_before text pos;
                      repl_fun text;
                      string_after text (match_end())]
  with Not_found ->
    text

let opt_search_forward re s pos =
  try Some(search_forward re s pos) with Not_found -> None

let global_substitute expr repl_fun text =
  let rec replace accu start last_was_empty =
    let startpos = if last_was_empty then start + 1 else start in
    if startpos > String.length text then
      string_after text start :: accu
    else
      match opt_search_forward expr text startpos with
      | None ->
          string_after text start :: accu
      | Some pos ->
          let end_pos = match_end() in
          let repl_text = repl_fun text in
          replace (repl_text :: String.sub text start (pos-start) :: accu)
                  end_pos (end_pos = pos)
  in
    String.concat "" (List.rev (replace [] 0 false))

let global_replace expr repl text =
  global_substitute expr (replace_matched repl) text
and replace_first expr repl text =
  substitute_first expr (replace_matched repl) text

(** Splitting *)

let opt_search_forward_progress expr text start =
  match opt_search_forward expr text start with
  | None -> None
  | Some pos ->
      if match_end() > start then
        Some pos
      else if start < String.length text then
        opt_search_forward expr text (start + 1)
      else None

let bounded_split expr text num =
  let start =
    if string_match expr text 0 then match_end() else 0 in
  let rec split accu start n =
    if start >= String.length text then accu else
    if n = 1 then string_after text start :: accu else
      match opt_search_forward_progress expr text start with
      | None ->
          string_after text start :: accu
      | Some pos ->
          split (String.sub text start (pos-start) :: accu)
                (match_end()) (n-1)
  in
    List.rev (split [] start num)

let split expr text = bounded_split expr text 0

let bounded_split_delim expr text num =
  let rec split accu start n =
    if start > String.length text then accu else
    if n = 1 then string_after text start :: accu else
      match opt_search_forward_progress expr text start with
      | None ->
          string_after text start :: accu
      | Some pos ->
          split (String.sub text start (pos-start) :: accu)
                (match_end()) (n-1)
  in
    if text = "" then [] else List.rev (split [] 0 num)

let split_delim expr text = bounded_split_delim expr text 0

type split_result = Text of string | Delim of string

let bounded_full_split expr text num =
  let rec split accu start n =
    if start >= String.length text then accu else
    if n = 1 then Text(string_after text start) :: accu else
      match opt_search_forward_progress expr text start with
      | None ->
          Text(string_after text start) :: accu
      | Some pos ->
          let s = matched_string text in
          if pos > start then
            split (Delim(s) :: Text(String.sub text start (pos-start)) :: accu)
                  (match_end()) (n-1)
          else
            split (Delim(s) :: accu)
                  (match_end()) (n-1)
  in
    List.rev (split [] 0 num)

let full_split expr text = bounded_full_split expr text 0