lambda.ml 9.15 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
  | Builtin of string
10
  | Global of int (* Only for the toplevel *)
11
12
  | Dummy

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

22
23
24
type schema_component_kind =
  [ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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

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

  | Const of Types.Const.t
  | Pair of expr * expr
  | Xml of expr * expr * expr
53
  | XmlNs of expr * expr * expr * Ns.table
54
  | Record of expr Imap.t
55
56
57
58
59
60
  | 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
61
  | Try of expr * branches
62
  | Validate of expr * string * Ns.qname
63
64
  | RemoveField of expr * label
  | Dot of expr * label
65
  | Ref of expr * Types.Node.t
66
  | Op of string * expr list
67
  | OpResolved of Obj.t * expr list
68
  | NsTable of Ns.table * expr
69
70
71

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

79
80
81
82
83
84
85
86
87
88
89
90
91
92
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

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

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

type code = code_item list
106
107
108
109


let nbits = 5

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

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

  open Serialize.Put
117

118
119
  let var_loc s = function
    | Stack i ->
120
	bits 3 s 0;
121
	int s i
122
    | Ext (cu,i) ->
123
124
125
126
	bits 3 s 1;
	Types.CompUnit.serialize s cu;
	int s i
    | External (cu,i) ->
127
	assert (i >= 0);
128
	bits 3 s 2;
129
130
	Types.CompUnit.serialize s cu;
	int s i
131
    | Builtin b ->
132
	bits 3 s 3;
133
134
135
	Serialize.Put.string s b
    | Env i ->
	bits 3 s 4;
136
137
	int s i
    | Dummy ->
138
	bits 3 s 5
139
    | Global _ -> assert false
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
	
  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;
166
167
168
169
170
171
172
173
174
	expr s e3;
	bool s false
    | XmlNs (e1,e2,e3,ns) ->
	bits nbits s 5;
	expr s e1;
	expr s e2;
	expr s e3;
	bool s true;
	Ns.serialize_table s ns
175
176
    | Record r ->
	bits nbits s 6;
177
178
	Serialize.Put.list (Serialize.Put.pair LabelPool.serialize expr) s 
	  (Imap.elements r)
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
    | 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
203
    | Validate (e,sch,t) ->
204
205
206
	bits nbits s 13;
	expr s e;
	string s sch;
207
	Ns.QName.serialize s t
208
(*	assert false (* TODO:Need to store a pointer to the schema ... *) *)
209
210
211
212
213
214
215
216
217
218
219
220
    | 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
221
222
223
224
    | Op (op,args) ->
	bits nbits s 19;
	string s op;
	list expr s args
225
226
    | OpResolved _ ->
	assert false
227
228
229
230
    | NsTable (ns,e) ->
	bits nbits s 20;
	Ns.serialize_table s ns;
	expr s e
231
    | Check (t0,e,t) ->
232
	bits nbits s 21;
233
	Types.serialize s t0;
234
235
236
	expr s e;
	Types.Node.serialize s t
	
237
238
239
240
241
242
	  
  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
243
244

  let code_item s = function
245
246
247
248
    | 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
249
250
251
252
253
254

  let codes = list code_item

  let compunit s c =
    magic s magic_compunit;
    codes s c
255
256
257
258
259
260
261
262
263
264
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 =
265
    match bits 3 s with
266
      | 0 -> Stack (int s)
267
268
269
270
      | 1 ->
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  Ext (cu,pos)
271
272
273
274
      | 2 ->
	  let cu = Types.CompUnit.deserialize s in
	  let pos = int s in
	  External (cu,pos)
275
276
277
278
279
      | 3 ->
	  let s = Serialize.Get.string s in
	  Builtin s
      | 4 -> Env (int s)
      | 5 -> Dummy
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
      | _ -> 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
304
305
306
307
308
	  if bool s then
	    let ns = Ns.deserialize_table s in
	    XmlNs (e1,e2,e3,ns)
	  else
	    Xml (e1,e2,e3)
309
310
311
312
      | 6 -> 
	  let r = Serialize.Get.list 
	    (Serialize.Get.pair LabelPool.deserialize expr) s in
	  Record (Imap.create (Array.of_list r))
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
      | 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)
337
338
339
      | 13 -> 
	  let e = expr s in
	  let sch = string s in
340
	  let t = Ns.QName.deserialize s in
341
	  Validate (e,sch,t)
342
343
344
345
346
347
348
349
350
351
352
353
      | 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)
354
355
356
357
      | 19 ->
	  let op = string s in
	  let args = list expr s in
	  Op (op,args)
358
359
360
361
      | 20 ->
	  let ns = Ns.deserialize_table s in
	  let e = expr s in
	  NsTable (ns,e)
362
      | 21 ->
363
	  let t0 = Types.deserialize s in
364
365
	  let e = expr s in
	  let t = Types.Node.deserialize s in
366
	  Check (t0,e,t)
367
368
369
370
371
372
373
374
375
      | _ -> 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;
376
      brs_compiled = None }
377

378
379
  let code_item s =
    match bits 2 s with
380
381
382
383
384
385
386
      | 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)
387
388
389
390
391
392
393
394
      | _ -> assert false

  let codes = list code_item

  let compunit s =
    magic s magic_compunit;
    codes s

395
end