lambda.ml 6 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
open Ident

type var_loc =
  | Stack of int
  | Env of int
  | Global of int
  | Dummy

type expr = 
  | Var of var_loc
11
12
  | Apply of bool * expr * expr
  | Abstraction of var_loc array * (Types.t * Types.t) list * branches
13
14
15
16
17
18
19
20
21
22
23

  | 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
24
  | Try of expr * branches
25
26
27
  | Validate of expr * string * string
  | RemoveField of expr * label
  | Dot of expr * label
28
29
30
  | UnaryOp of int * expr
  | BinaryOp of int * expr * expr
  | Ref of expr * Types.Node.t
31
32
33

and branches = {
  brs: (Patterns.node * expr) list;
34
  brs_tail: bool;
35
  brs_input: Types.t;
36
  brs_accept_chars: bool;
37
38
39
40
  mutable brs_compiled: 
    (Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
}

41
42
43
44
45
46
47
48
49
50
51
type code_item =
  | Eval of expr
  | Let_decl of Patterns.node * expr
  | Let_funs of expr list

let print_code_item ppf = function
  | Eval _ -> Format.fprintf ppf "Eval@."
  | Let_decl _ -> Format.fprintf ppf "Let_decl@."
  | Let_funs _ -> Format.fprintf ppf "Let_funs@."

type code = code_item list
52
53
54
55


let nbits = 5

56
57
let magic_compunit = "CDUCE:0.2:COMPUNIT"

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
module Put = struct
  let unary_op = ref (fun _ _ -> assert false; ())
  let binary_op = ref (fun _ _ -> assert false; ())

  open Serialize.Put
		    
  let var_loc s = function
    | Stack i ->
	bits 2 s 0;
	int s i
    | Global i ->
	bits 2 s 1;
	int s i
    | Env i ->
	bits 2 s 2;
	int s i
    | Dummy ->
	bits 2 s 3
	
  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
    | Validate (e,sch,t) ->
131
	assert false (* TODO:Need to store a pointer to the schema ... *)
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
    | 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
    | UnaryOp (op,e) ->
	bits nbits s 16;
	!unary_op s op;
	expr s e
    | BinaryOp (op,e1,e2) ->
	bits nbits s 17;
	!binary_op s op;
	expr s e1;
	expr s e2
    | Ref (e,t) ->
	bits nbits s 18;
	expr s e;
	Types.Node.serialize s t
	  
  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
159
160
161
162
163
164
165
166
167
168
169

  let code_item s = function
    | Eval e -> bits 2 s 0; expr s e
    | Let_decl (p,e) -> bits 2 s 1; Patterns.Node.serialize s p; expr s e
    | Let_funs e -> bits 2 s 2; list expr s e

  let codes = list code_item

  let compunit s c =
    magic s magic_compunit;
    codes s c
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
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 =
    match bits 2 s with
      | 0 -> Stack (int s)
      | 1 -> Global (int s)
      | 2 -> Env (int s)
      | 3 -> Dummy
      | _ -> 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)
      | 13 -> assert false
      | 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)
      | 16 ->
	  let op = !unary_op s in
	  let e = expr s in
	  UnaryOp (op,e)
      | 17 ->
	  let op = !binary_op s in
	  let e1 = expr s in
	  let e2 = expr s in
	  BinaryOp (op,e1,e2)
      | 18 ->
	  let e = expr s in
	  let t = Types.Node.deserialize s in
	  Ref (e,t)
      | _ -> 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;
      brs_compiled = None
    }

269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
  let code_item s =
    match bits 2 s with
      | 0 -> Eval (expr s)
      | 1 -> 
	  let p = Patterns.Node.deserialize s in
	  let e = expr s in
	  Let_decl (p,e)
      | 2 -> 
	  Let_funs (list expr s)
      | _ -> assert false

  let codes = list code_item

  let compunit s =
    magic s magic_compunit;
    codes s

286
end