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