cduce.ml 10.7 KB
Newer Older
1
open Location
2
open Ident
3

4
5
6
7
8
9
10
11
(* retuns a filename without the suffix suff if any *) 
let prefix filename suff =
  if Filename.check_suffix filename suff then
    try
      Filename.chop_extension filename
    with Invalid_argument filename -> failwith "Not a point in the suffix?"
  else filename

12
let quiet = ref false
13
let toplevel = ref false
14

15
let typing_env = State.ref "Cduce.typing_env" Builtin.env
16
let eval_env = State.ref "Cduce.eval_env" Eval.empty
17
18
19
20
21
22
let compile_env = State.ref "Cduce.compile_env" Compile.empty

let do_compile = ref false

let get_global_value v =
  if !do_compile 
23
  then Eval.L.var (Compile.find v !compile_env)
24
  else Eval.find_value v !eval_env
25
26
27

let get_global_type v =
  Typer.find_value v !typing_env
28

29
let enter_global_value x v t =
30
  typing_env := Typer.enter_value x t !typing_env;
31

32
33
  if !do_compile 
  then (compile_env := Compile.enter_global !compile_env x; Eval.L.push v)
34
  else eval_env := Eval.enter_value x v !eval_env
35
  
36
37
38
39
40
let rec is_abstraction = function
  | Ast.Abstraction _ -> true
  | Ast.LocatedExpr (_,e) -> is_abstraction e
  | _ -> false

41
let print_norm ppf d = 
42
  Location.protect ppf 
43
    (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
44

45
46
47
48
let print_sample ppf s =
  Location.protect ppf
    (fun ppf -> Sample.print ppf s)

49
50
51
let print_protect ppf s =
  Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)

52
53
let print_value ppf v =
  Location.protect ppf (fun ppf -> Value.print ppf v)
54

55
56
57
58
let dump_value ppf x t v =
  Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
    U.print (Id.value x) print_norm t print_value v

59
let dump_env ppf =
60
61
  Format.fprintf ppf "Types:%a@." Typer.dump_types !typing_env;
  Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns !typing_env;
62
  Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
63
    Ns.InternalPrinter.dump;
64
  Format.fprintf ppf "Values:@.";
65
66
  Typer.iter_values !typing_env
    (fun x t -> dump_value ppf x t (get_global_value x))
67

68
69
70
71
72
73
74
75
76
let directive_help ppf =
  Format.fprintf ppf
"Toplevel directives:
  #quit;;         quit the interpreter
  #env;;          dump current environment
  #reinit_ns;;    reinitialize namespace processing
  #help;;         shows this help message
"

77
let rec print_exn ppf = function
78
79
  | Location (loc, w, exn) ->
      Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
80
      Format.fprintf ppf "%a" Location.html_hilight (loc,w); 
81
      print_exn ppf exn
82
  | Value.CDuceExn v ->
83
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
84
        print_value v
85
  | Eval.MultipleDeclaration v ->
86
      Format.fprintf ppf "Multiple declaration for global value %a@." 
87
        U.print (Id.value v)
88
  | Typer.WrongLabel (t,l) ->
89
      Format.fprintf ppf "Wrong record selection; field %a " 
90
        Label.print (LabelPool.value l);
91
      Format.fprintf ppf "not present in an expression of type:@.%a@."
92
        print_norm t
93
  | Typer.ShouldHave (t,msg) ->
94
      Format.fprintf ppf "This expression should have type:@.%a@.%a@." 
95
        print_norm t
96
        print_protect msg
97
  | Typer.ShouldHave2 (t1,msg,t2) ->
98
      Format.fprintf ppf "This expression should have type:@.%a@.%a %a@." 
99
        print_norm t1
100
        print_protect msg
101
        print_norm t2
102
  | Typer.Error s ->
103
      Format.fprintf ppf "%a@." print_protect s
104
  | Typer.Constraint (s,t) ->
105
      Format.fprintf ppf "This expression should have type:@.%a@." 
106
        print_norm t;
107
      Format.fprintf ppf "but its inferred type is:@.%a@." 
108
        print_norm s;
109
      Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@." 
110
	print_sample (Sample.get (Types.diff s t))
111
  | Typer.NonExhaustive t ->
112
113
      Format.fprintf ppf "This pattern matching is not exhaustive@.";
      Format.fprintf ppf "Residual type:@.%a@."
114
	print_norm t;
115
      Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
116
117
118
  | Typer.UnboundId (x,tn) ->
      Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
        (if tn then " (it is a type name)" else "")
119
120
121
122
  | Ulexer.Error (i,j,s) ->
      let loc = Location.loc_of_pos (i,j), `Full in
      Format.fprintf ppf "Error %a:@." Location.print_loc loc;
      Format.fprintf ppf "%a%s" Location.html_hilight loc s
123
  | Parser.Error s | Stream.Error s -> 
124
      Format.fprintf ppf "Parsing error: %a@." print_protect s
125
  | Location.Generic s ->
126
      Format.fprintf ppf "%a@." print_protect s
127
  | exn ->
128
(*      raise exn *)
129
      Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
130

131

132
133
134
135
136
let display ppf l =
  if not !quiet then
    List.iter
      (fun (x,t) -> dump_value ppf x t (get_global_value x))
      l
137
138

let eval ppf e =
139
  let (e,t) = Typer.type_expr !typing_env e in
140
141
142
  
  if not !quiet then
    Location.dump_loc ppf (e.Typed.exp_loc,`Full);
143
144
145

  let v =   
    if !do_compile then
146
147
      let e = Compile.compile_eval !compile_env e in 
      Eval.L.expr e
148
149
150
151
152
153
154
    else
      Eval.eval !eval_env e
  in
  if not !quiet then
    Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@." 
      print_norm t print_value v; 
  v
155
  
156
let let_decl ppf p e =
157
  let (tenv,decl,typs) = Typer.type_let_decl !typing_env p e in
158
159
160
161
  
  let () =
    if !do_compile then
      let (env,decl) = Compile.compile_let_decl !compile_env decl in
162
      Eval.L.eval decl;
163
164
165
166
      compile_env := env
    else
      eval_env := Eval.eval_let_decl !eval_env decl
  in
167
  typing_env := tenv;
168
169
170
171
  display ppf typs
  

let let_funs ppf funs =
172
  let (tenv,funs,typs) = Typer.type_let_funs !typing_env funs in
173
  
174
175
176
  let () =
    if !do_compile then
      let (env,funs) = Compile.compile_rec_funs !compile_env funs in
177
      Eval.L.eval funs;
178
179
180
181
      compile_env := env;
    else 
      eval_env := Eval.eval_rec_funs !eval_env funs 
  in
182
  typing_env := tenv;
183
184
  display ppf typs

185

186
let debug ppf = function
187
  | `Subtype (t1,t2) ->
188
      Format.fprintf ppf "[DEBUG:subtype]@.";
189
190
      let t1 = Types.descr (Typer.typ !typing_env t1)
      and t2 = Types.descr (Typer.typ !typing_env t2) in
191
192
      let s = Types.subtype t1 t2 in
      Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
193
  | `Sample t ->
194
195
      Format.fprintf ppf "[DEBUG:sample]@.";
      (try
196
	 let t = Types.descr (Typer.typ !typing_env t) in
197
198
199
	 Format.fprintf ppf "%a@." print_sample (Sample.get t)
       with Not_found ->
	 Format.fprintf ppf "Empty type : no sample !@.")
200
  | `Filter (t,p) -> 
201
      Format.fprintf ppf "[DEBUG:filter]@.";
202
203
      let t = Typer.typ !typing_env t
      and p = Typer.pat !typing_env p in
204
205
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
206
		   Format.fprintf ppf " %a:%a@." U.print (Id.value x)
207
208
		     print_norm (Types.descr t)) f
  | `Accept p ->
209
      Format.fprintf ppf "[DEBUG:accept]@.";
210
      let p = Typer.pat !typing_env p in
211
      let t = Patterns.accept p in
212
      Format.fprintf ppf " %a@." Types.Print.print (Types.descr t)
213
  | `Compile (t,pl) ->
214
      Format.fprintf ppf "[DEBUG:compile]@.";
215
216
      let t = Typer.typ !typing_env t
      and pl = List.map (Typer.pat !typing_env) pl in
217
      Patterns.Compile.debug_compile ppf t pl
218
219
220
221
222
223
224
225
226
  | `Explain (t,e) ->
      Format.fprintf ppf "[DEBUG:explain]@.";
      let t = Typer.typ !typing_env t in
      (match Explain.explain (Types.descr t) (eval ppf e) with
	 | Some p ->
	     Format.fprintf ppf "Explanation: @[%a@]@." 
	       Explain.print_path p
	 | None ->
	     Format.fprintf ppf "Explanation: value has given type@.")
227

228

229
230
231
let rec collect_funs ppf accu = function
  | { descr = Ast.FunDecl e } :: rest -> collect_funs ppf (e::accu) rest
  | rest -> let_funs ppf accu; rest
232
233
234
235
236

let rec collect_types ppf accu = function
  | { descr = Ast.TypeDecl (x,t) } :: rest -> 
      collect_types ppf ((x,t) :: accu) rest
  | rest ->
237
238
      typing_env := 
        Typer.enter_types (Typer.type_defs !typing_env accu) !typing_env;
239
240
      rest

241

242
243
244
245
246
let rec phrases ppf phs = match phs with
  | { descr = Ast.FunDecl _ } :: _ -> 
      phrases ppf (collect_funs ppf [] phs)
  | { descr = Ast.TypeDecl (_,_) } :: _ ->
      phrases ppf (collect_types ppf [] phs)
247
248
249
  | { descr = Ast.SchemaDecl (name, schema) } :: rest ->
      Typer.register_schema name schema;
      phrases ppf rest
250
  | { descr = Ast.Namespace (pr,ns) } :: rest ->
251
      typing_env := Typer.enter_ns pr ns !typing_env;
252
      phrases ppf rest
253
  | { descr = Ast.EvalStatement e } :: rest ->
254
      ignore (eval ppf e);
255
256
      phrases ppf rest
  | { descr = Ast.LetDecl (p,e) } :: rest ->
257
      let_decl ppf p e;
258
259
      phrases ppf rest
  | { descr = Ast.Debug l } :: rest -> 
260
      debug ppf l; 
261
      phrases ppf rest
262
263
264
265
266
267
  | { descr = Ast.Directive `Quit } :: rest ->
      if !toplevel then raise End_of_file;
      phrases ppf rest
  | { descr = Ast.Directive `Env } :: rest ->
      dump_env ppf;
      phrases ppf rest
268
  | { descr = Ast.Directive `Reinit_ns } :: rest ->
269
      Typer.set_ns_table_for_printer !typing_env;
270
      phrases ppf rest
271
272
273
  | { descr = Ast.Directive `Help } :: rest ->
      directive_help ppf;
      phrases ppf rest
274
275
  | [] -> ()

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
let catch_exn ppf_err = function
  | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break) 
      as e -> 
      raise e
  | exn -> 
      print_exn ppf_err exn;
      Format.fprintf ppf_err "@."

let parse rule input =
  try Some (rule input)
  with
      | Stdpp.Exc_located (_, (Location _ as e)) ->
	  Parser.sync (); raise e
      | Stdpp.Exc_located ((i,j), e) -> 
	  Parser.sync (); raise_loc i j e

292
let run rule ppf ppf_err input =
293
294
295
296
  try match parse rule input with
    | Some phs -> phrases ppf phs; true
    | None -> false
  with exn -> catch_exn ppf_err exn; false
297

298
let script = run Parser.prog
299
let topinput = run Parser.top_phrases
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
let comp_unit src = 
  try 
    let ic = open_in src in
    Location.push_source (`File src);
    let input = Stream.of_channel ic in
    match parse Parser.prog input with
      | Some p ->
	  close_in ic;
	  let argv = ident (U.mk "argv") in
	  let (tenv,cenv,codes) = 
	    Compile.comp_unit 
	      (Typer.enter_value argv (Sequence.star Sequence.string)
		 Builtin.env)
	      (Compile.enter_global Compile.empty argv)
	      p in
	  codes
      | None -> exit 1
    with exn -> catch_exn Format.err_formatter exn; exit 1

let run_code argv codes =
  try
    Eval.L.push argv;
    List.iter Eval.L.eval codes
  with exn -> catch_exn Format.err_formatter exn; exit 1


let compile src =
  let codes = comp_unit src in
329
  let oc = open_out ((prefix src ".cd") ^ ".cdo") in
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
  let codes_s = Serialize.Put.run Lambda.Put.compunit codes in
  output_string oc codes_s;
  close_out oc;
  exit 0
  
let compile_run src argv =
  run_code argv (comp_unit src)

let run obj argv =  
  let ic = open_in obj in
  let len = in_channel_length ic in
  let codes = String.create len in
  really_input ic codes 0 len;
  close_in ic;
  let codes = Serialize.Get.run Lambda.Get.compunit codes in
  run_code argv codes


348
349
350
351
352
let serialize_typing_env t () =
  Typer.serialize t !typing_env

let deserialize_typing_env t =
  typing_env := Typer.deserialize t