lambda.ml 8.65 KB
Newer Older
1
2
3
4
5
open Ident

type var_loc =
  | Stack of int
  | Env of int
6
  | Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
7
8
  | External of Types.CompUnit.t * int 
      (* If pos < 0, the first arg is the value *)
9
  | Global of int (* Only for the toplevel *)
10
11
  | Dummy

12
13
14
let print_var_loc ppf = function
  | Stack i -> Format.fprintf ppf "Stack %i" i
  | Env i -> Format.fprintf ppf "Env %i" i
15
  | Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
16
  | External (cu,i) -> Format.fprintf ppf "External (_,%i)" i
17
  | Global i -> Format.fprintf ppf "Global %i" i
18
19
  | Dummy -> Format.fprintf ppf "Dummy"

20
21
22
type schema_component_kind =
  [ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
let serialize_schema_component_kind s x =
  Serialize.Put.bits 3 s (match x with
	    | Some `Type -> 0
	    | Some `Element -> 1
	    | Some `Attribute -> 2
	    | Some `Attribute_group -> 3
	    | Some `Model_group -> 4
	    | None -> 5)

let deserialize_schema_component_kind s =
  match Serialize.Get.bits 3 s with
    | 0 -> Some `Type
    | 1 -> Some `Element
    | 2 -> Some `Attribute
    | 3 -> Some `Attribute_group
    | 4 -> Some `Model_group
    | 5 -> None
    | _ -> assert false

42
43
type expr = 
  | Var of var_loc
44
45
  | Apply of bool * expr * expr
  | Abstraction of var_loc array * (Types.t * Types.t) list * branches
46
  | Check of Types.t * expr * Types.Node.t 
47
48
49
50
51
52
53
54
55
56
57

  | Const of Types.Const.t
  | Pair of expr * expr
  | Xml of expr * expr * expr
  | Record of expr label_map
  | String of U.uindex * U.uindex * U.t * expr

  | Match of expr * branches
  | Map of expr * branches
  | Transform of expr * branches
  | Xtrans of expr * branches
58
  | Try of expr * branches
59
  | Validate of expr * string * Ns.qname
60
61
  | RemoveField of expr * label
  | Dot of expr * label
62
  | Ref of expr * Types.Node.t
63
  | Op of string * expr list
64
  | OpResolved of Obj.t * expr list
65
  | NsTable of Ns.table * expr
66
67
68

and branches = {
  brs: (Patterns.node * expr) list;
69
  brs_tail: bool;
70
  brs_input: Types.t;
71
  brs_accept_chars: bool;
72
  mutable brs_compiled: 
73
74
75
    (Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option;
  mutable brs_compiled2: 
    (Patterns.Compile2.dispatcher * (int list * expr) option array) option;
76
77
}

78
79
80
81
82
83
84
85
86
87
88
89
90
91
let rec dump_expr ppf = function
  | Var v -> print_var_loc ppf v
  | Apply (tr,f,x) -> Format.fprintf ppf "Apply (%b,%a,%a)" tr dump_expr f dump_expr x
  | Abstraction (env,iface,brs) ->
      Format.fprintf ppf "Abstraction ([";
      for i = 0 to Array.length env - 1 do
	Format.fprintf ppf "{%a}," print_var_loc env.(i);
      done;
      Format.fprintf ppf "],%a)" dump_branches brs
  | _ -> Format.fprintf ppf "other expr";

and dump_branches ppf brs =
  List.iter (fun (p,e) -> Format.fprintf ppf "_ -> %a |" dump_expr e) brs.brs

92
type code_item =
93
94
95
96
  | Push of expr
  | Pop
  | Split of Patterns.node
  | SetGlobal of Types.CompUnit.t * int
97
98

let print_code_item ppf = function
99
100
101
102
  | Push _ -> Format.fprintf ppf "Push@."
  | Pop -> Format.fprintf ppf "Pop@."
  | Split _ -> Format.fprintf ppf "Split@."
  | SetGlobal (_,_) -> Format.fprintf ppf "SetGlobal@."
103
104

type code = code_item list
105
106
107
108


let nbits = 5

109
let magic_compunit = "CDUCE:0.3:COMPUNIT"
110

111
112
113
114
115
module Put = struct
  let unary_op = ref (fun _ _ -> assert false; ())
  let binary_op = ref (fun _ _ -> assert false; ())

  open Serialize.Put
116

117
118
  let var_loc s = function
    | Stack i ->
119
	bits 3 s 0;
120
	int s i
121
    | Ext (cu,i) ->
122
123
124
125
126
	bits 3 s 1;
	Types.CompUnit.serialize s cu;
	int s i
    | External (cu,i) ->
	bits 3 s 2;
127
128
	Types.CompUnit.serialize s cu;
	int s i
129
    | Env i ->
130
	bits 3 s 3;
131
132
	int s i
    | Dummy ->
133
	bits 3 s 4
134
    | Global _ -> assert false
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
	
  let rec expr s = function
    | Var v -> 
	bits nbits s 0;
	var_loc s v
    | Apply (tail,e1,e2) ->
	bits nbits s 1;
	bool s tail;
	expr s e1;
	expr s e2
    | Abstraction (slots,iface,brs) ->
	bits nbits s 2;
	array var_loc s slots;
	list (pair Types.serialize Types.serialize) s iface;
	branches s brs
    | Const c ->
	bits nbits s 3;
	Types.Const.serialize s c
    | Pair (e1,e2) ->
	bits nbits s 4;
	expr s e1;
	expr s e2
    | Xml (e1,e2,e3) ->
	bits nbits s 5;
	expr s e1;
	expr s e2;
	expr s e3
    | Record r ->
	bits nbits s 6;
	LabelMap.serialize expr s r
    | String (i,j,st,q) ->
	bits nbits s 7;
	U.serialize_sub s st i j;
	expr s q
    | Match (e,brs) ->
	bits nbits s 8;
	expr s e;
	branches s brs
    | Map (e,brs) ->
	bits nbits s 9;
	expr s e;
	branches s brs
    | Transform (e,brs) ->
	bits nbits s 10;
	expr s e;
	branches s brs
    | Xtrans (e,brs) ->
	bits nbits s 11;
	expr s e;
	branches s brs
    | Try (e,brs) ->
	bits nbits s 12;
	expr s e;
	branches s brs
189
    | Validate (e,sch,t) ->
190
191
192
	bits nbits s 13;
	expr s e;
	string s sch;
193
	Ns.QName.serialize s t
194
(*	assert false (* TODO:Need to store a pointer to the schema ... *) *)
195
196
197
198
199
200
201
202
203
204
205
206
    | RemoveField (e,l) ->
	bits nbits s 14;
	expr s e;
	LabelPool.serialize s l
    | Dot (e,l) ->
	bits nbits s 15;
	expr s e;
	LabelPool.serialize s l
    | Ref (e,t) ->
	bits nbits s 18;
	expr s e;
	Types.Node.serialize s t
207
208
209
210
    | Op (op,args) ->
	bits nbits s 19;
	string s op;
	list expr s args
211
212
    | OpResolved _ ->
	assert false
213
214
215
216
    | NsTable (ns,e) ->
	bits nbits s 20;
	Ns.serialize_table s ns;
	expr s e
217
    | Check (t0,e,t) ->
218
	bits nbits s 21;
219
	Types.serialize s t0;
220
221
222
	expr s e;
	Types.Node.serialize s t
	
223
224
225
226
227
228
	  
  and branches s brs =
    list (pair Patterns.Node.serialize expr) s brs.brs;
    bool s brs.brs_tail;
    Types.serialize s brs.brs_input;
    bool s brs.brs_accept_chars
229
230

  let code_item s = function
231
232
233
234
    | Push e -> bits 2 s 0; expr s e
    | Pop -> bits 2 s 1
    | Split p -> bits 2 s 2; Patterns.Node.serialize s p
    | SetGlobal (cu,i) -> bits 2 s 3; Types.CompUnit.serialize s cu; int s i
235
236
237
238
239
240

  let codes = list code_item

  let compunit s c =
    magic s magic_compunit;
    codes s c
241
242
243
244
245
246
247
248
249
250
end
	

module Get = struct
  let unary_op = ref (fun _ -> assert false)
  let binary_op = ref (fun _ -> assert false)

  open Serialize.Get

  let var_loc s =
251
    match bits 3 s with
252
      | 0 -> Stack (int s)
253
254
255
256
      | 1 ->
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  Ext (cu,pos)
257
258
259
260
261
262
      | 2 ->
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  External (cu,pos)
      | 3 -> Env (int s)
      | 4 -> Dummy
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
      | _ -> assert false

  let rec expr s =
    match bits nbits s with
      | 0 -> Var (var_loc s)
      | 1 ->
	  let recurs = bool s in
	  let e1 = expr s in
	  let e2 = expr s in
	  Apply (recurs,e1,e2)
      | 2 ->
	  let slots = array var_loc s in
	  let iface = list (pair Types.deserialize Types.deserialize) s in
	  let brs = branches s in
	  Abstraction (slots,iface,brs)
      | 3 -> Const (Types.Const.deserialize s)
      | 4 ->
	  let e1 = expr s in
	  let e2 = expr s in
	  Pair (e1,e2)
      | 5 ->
	  let e1 = expr s in
	  let e2 = expr s in
	  let e3 = expr s in
	  Xml (e1,e2,e3)
      | 6 -> Record (LabelMap.deserialize expr s)
      | 7 -> 
	  let st = U.deserialize s in
	  let e = expr s in
	  String (U.start_index st, U.end_index st, st, e)
      | 8 ->
	  let e = expr s in
	  let brs = branches s in
	  Match (e,brs)
      | 9 ->
	  let e = expr s in
	  let brs = branches s in
	  Map (e,brs)
      | 10 ->
	  let e = expr s in
	  let brs = branches s in
	  Transform (e,brs)
      | 11 ->
	  let e = expr s in
	  let brs = branches s in
	  Xtrans (e,brs)
      | 12 ->
	  let e = expr s in
	  let brs = branches s in
	  Try (e,brs)
313
314
315
      | 13 -> 
	  let e = expr s in
	  let sch = string s in
316
	  let t = Ns.QName.deserialize s in
317
	  Validate (e,sch,t)
318
319
320
321
322
323
324
325
326
327
328
329
      | 14 ->
	  let e = expr s in
	  let l = LabelPool.deserialize s in
	  RemoveField (e,l)
      | 15 ->
	  let e = expr s in
	  let l = LabelPool.deserialize s in
	  Dot (e,l)
      | 18 ->
	  let e = expr s in
	  let t = Types.Node.deserialize s in
	  Ref (e,t)
330
331
332
333
      | 19 ->
	  let op = string s in
	  let args = list expr s in
	  Op (op,args)
334
335
336
337
      | 20 ->
	  let ns = Ns.deserialize_table s in
	  let e = expr s in
	  NsTable (ns,e)
338
      | 21 ->
339
	  let t0 = Types.deserialize s in
340
341
	  let e = expr s in
	  let t = Types.Node.deserialize s in
342
	  Check (t0,e,t)
343
344
345
346
347
348
349
350
351
      | _ -> assert false

  and branches s =
    let brs = list (pair Patterns.Node.deserialize expr) s in
    let tail = bool s in
    let input = Types.deserialize s in
    let accept_chars = bool s in
    { brs = brs; brs_tail = tail; brs_input = input; 
      brs_accept_chars = accept_chars;
352
      brs_compiled = None; brs_compiled2 = None
353
354
    }

355
356
  let code_item s =
    match bits 2 s with
357
358
359
360
361
362
363
      | 0 -> Push (expr s)
      | 1 -> Pop
      | 2 -> Split (Patterns.Node.deserialize s)
      | 3 -> 
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  SetGlobal (cu,pos)
364
365
366
367
368
369
370
371
      | _ -> assert false

  let codes = list code_item

  let compunit s =
    magic s magic_compunit;
    codes s

372
end