blob: fa4579ce243d869e30d68083ef9aabd16a7533c9 (
plain)
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
|
(* TEST
flags = " -w -a ";
setup-ocamlc.byte-build-env;
ocamlc.byte;
check-ocamlc.byte-output;
*)
(* The module begins *)
exception Out_of_range
class type ['a] cursor =
object
method get : 'a
method incr : unit -> unit
method is_last : bool
end
class type ['a] storage =
object ('self)
method first : 'a cursor
method len : int
method nth : int -> 'a cursor
method copy : 'self
method sub : int -> int -> 'self
method concat : 'a storage -> 'self
method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b
method iter : ('a -> unit) -> unit
end
class virtual ['a, 'cursor] storage_base =
object (self : 'self)
constraint 'cursor = 'a #cursor
method virtual first : 'cursor
method virtual len : int
method virtual copy : 'self
method virtual sub : int -> int -> 'self
method virtual concat : 'a storage -> 'self
method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 ->
let cur = self#first in
let rec loop count a =
if count >= self#len then a else
let a' = f cur#get count a in
cur#incr (); loop (count + 1) a'
in
loop 0 a0
method iter proc =
let p = self#first in
for i = 0 to self#len - 2 do proc p#get; p#incr () done;
if self#len > 0 then proc p#get else ()
end
class type ['a] obj_input_channel =
object
method get : unit -> 'a
method close : unit -> unit
end
class type ['a] obj_output_channel =
object
method put : 'a -> unit
method flush : unit -> unit
method close : unit -> unit
end
module UChar =
struct
type t = int
let highest_bit = 1 lsl 30
let lower_bits = highest_bit - 1
let char_of c =
try Char.chr c with Invalid_argument _ -> raise Out_of_range
let of_char = Char.code
let code c =
if c lsr 30 = 0
then c
else raise Out_of_range
let chr n =
if n >= 0 && (n lsr 31 = 0) then n else raise Out_of_range
let uint_code c = c
let chr_of_uint n = n
end
type uchar = UChar.t
let int_of_uchar u = UChar.uint_code u
let uchar_of_int n = UChar.chr_of_uint n
class type ucursor = [uchar] cursor
class type ustorage = [uchar] storage
class virtual ['ucursor] ustorage_base = [uchar, 'ucursor] storage_base
module UText =
struct
(* the internal representation is UCS4 with big endian*)
(* The most significant digit appears first. *)
let get_buf s i =
let n = Bytes.get s i |> Char.code in
let n = (n lsl 8) lor (Bytes.get s (i + 1) |> Char.code) in
let n = (n lsl 8) lor (Bytes.get s (i + 2) |> Char.code) in
let n = (n lsl 8) lor (Bytes.get s (i + 3) |> Char.code) in
UChar.chr_of_uint n
let set_buf s i u =
let n = UChar.uint_code u in
begin
Bytes.set s i (Char.chr (n lsr 24));
Bytes.set s (i + 1) (Char.chr (n lsr 16 lor 0xff));
Bytes.set s (i + 2) (Char.chr (n lsr 8 lor 0xff));
Bytes.set s (i + 3) (Char.chr (n lor 0xff));
end
let init_buf buf pos init =
if init#len = 0 then () else
let cur = init#first in
for i = 0 to init#len - 2 do
set_buf buf (pos + i lsl 2) (cur#get); cur#incr ()
done;
set_buf buf (pos + (init#len - 1) lsl 2) (cur#get)
let make_buf init =
let s = Bytes.create (init#len lsl 2) in
init_buf s 0 init; s
class text_raw buf =
object (self : 'self)
inherit [cursor] ustorage_base
val contents = buf
method first = new cursor (self :> text_raw) 0
method len = (Bytes.length contents) / 4
method get i = get_buf contents (4 * i)
method nth i = new cursor (self :> text_raw) i
method copy = {< contents = Bytes.copy contents >}
method sub pos len =
{< contents = Bytes.sub contents (pos * 4) (len * 4) >}
method concat (text : ustorage) =
let buf = Bytes.create (Bytes.length contents + 4 * text#len) in
Bytes.blit contents 0 buf 0 (Bytes.length contents);
init_buf buf (Bytes.length contents) text;
{< contents = buf >}
end
and cursor text i =
object
val contents = text
val mutable pos = i
method get = contents#get pos
method incr () = pos <- pos + 1
method is_last = (pos + 1 >= contents#len)
end
class string_raw buf =
object
inherit text_raw buf
method set i u = set_buf contents (4 * i) u
end
class text init = text_raw (make_buf init)
class string init = string_raw (make_buf init)
let of_string s =
let buf = Bytes.make (4 * String.length s) '\000' in
for i = 0 to String.length s - 1 do
Bytes.set buf (4 * i) s.[i]
done;
new text_raw buf
let make len u =
let s = Bytes.create (4 * len) in
for i = 0 to len - 1 do set_buf s (4 * i) u done;
new string_raw s
let create len = make len (UChar.chr 0)
let copy s = s#copy
let sub s start len = s#sub start len
let fill s start len u =
for i = start to start + len - 1 do s#set i u done
let blit src srcoff dst dstoff len =
for i = 0 to len - 1 do
let u = src#get (srcoff + i) in
dst#set (dstoff + i) u
done
let concat s1 s2 = s1#concat (s2 (* : #ustorage *) :> uchar storage)
let iter proc s = s#iter proc
end
|
