| 1 |
open Location |
open Location |
| 2 |
open Ident |
open Ident |
| 3 |
|
|
| 4 |
|
exception InvalidInputFilename of string |
| 5 |
|
exception InvalidObjectFilename of string |
| 6 |
|
|
| 7 |
|
(* if set to false toplevel exception aren't cought. Useful for debugging with |
| 8 |
|
* OCAMLRUNPARAM="b" *) |
| 9 |
|
let catch_exceptions = true |
| 10 |
|
|
| 11 |
|
(* retuns a filename without the suffix suff if any *) |
| 12 |
|
let prefix filename suff = |
| 13 |
|
if Filename.check_suffix filename suff then |
| 14 |
|
try |
| 15 |
|
Filename.chop_extension filename |
| 16 |
|
with Invalid_argument filename -> failwith "Not a point in the suffix?" |
| 17 |
|
else filename |
| 18 |
|
|
| 19 |
let quiet = ref false |
let quiet = ref false |
| 20 |
|
let toplevel = ref false |
| 21 |
|
|
| 22 |
|
let typing_env = State.ref "Cduce.typing_env" Builtin.env |
| 23 |
|
let eval_env = State.ref "Cduce.eval_env" Eval.empty |
| 24 |
|
let compile_env = State.ref "Cduce.compile_env" Compile.empty |
| 25 |
|
|
| 26 |
|
let do_compile = ref false |
| 27 |
|
|
| 28 |
|
let get_global_value v = |
| 29 |
|
if !do_compile |
| 30 |
|
then Eval.L.var (Compile.find v !compile_env) |
| 31 |
|
else Eval.find_value v !eval_env |
| 32 |
|
|
| 33 |
|
let get_global_type v = |
| 34 |
|
Typer.find_value v !typing_env |
| 35 |
|
|
| 36 |
let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty |
let enter_global_value x v t = |
| 37 |
let glb_env = State.ref "Cduce.glb_env" Typer.TypeEnv.empty |
typing_env := Typer.enter_value x t !typing_env; |
| 38 |
let eval_env = Eval.global_env |
|
| 39 |
|
if !do_compile |
| 40 |
|
then (compile_env := Compile.enter_global !compile_env x; Eval.L.push v) |
| 41 |
|
else eval_env := Eval.enter_value x v !eval_env |
| 42 |
|
|
| 43 |
|
let rec is_abstraction = function |
| 44 |
|
| Ast.Abstraction _ -> true |
| 45 |
|
| Ast.LocatedExpr (_,e) -> is_abstraction e |
| 46 |
|
| _ -> false |
| 47 |
|
|
| 48 |
let print_norm ppf d = |
let print_norm ppf d = |
| 49 |
Location.protect ppf |
Location.protect ppf |
| 50 |
(fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d)) |
(fun ppf -> Types.Print.print ppf ((*Types.normalize*) d)) |
| 51 |
|
|
| 52 |
|
let print_sample ppf s = |
| 53 |
|
Location.protect ppf |
| 54 |
|
(fun ppf -> Sample.print ppf s) |
| 55 |
|
|
| 56 |
|
let print_protect ppf s = |
| 57 |
|
Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s) |
| 58 |
|
|
| 59 |
let print_value ppf v = |
let print_value ppf v = |
| 60 |
Location.protect ppf (fun ppf -> Value.print ppf v) |
Location.protect ppf (fun ppf -> Value.print ppf v) |
| 61 |
|
|
| 62 |
let dump_env ppf = |
let dump_value ppf x t v = |
| 63 |
Format.fprintf ppf "Global types:"; |
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@." |
| 64 |
Typer.TypeEnv.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env; |
U.print (Id.value x) print_norm t print_value v |
|
Format.fprintf ppf ".@\n"; |
|
|
Eval.Env.iter |
|
|
(fun x v -> |
|
|
let t = Typer.Env.find x !typing_env in |
|
|
Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n" |
|
|
(Id.value x) |
|
|
print_norm t |
|
|
print_value v |
|
|
) |
|
|
!eval_env |
|
| 65 |
|
|
| 66 |
|
let dump_env ppf = |
| 67 |
|
Format.fprintf ppf "Types:%a@." Typer.dump_types !typing_env; |
| 68 |
|
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns !typing_env; |
| 69 |
|
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t" |
| 70 |
|
Ns.InternalPrinter.dump; |
| 71 |
|
Format.fprintf ppf "Schemas: %s@." |
| 72 |
|
(String.concat " " (Typer.get_schema_names ())); |
| 73 |
|
Format.fprintf ppf "Values:@."; |
| 74 |
|
Typer.iter_values !typing_env |
| 75 |
|
(fun x t -> dump_value ppf x t (get_global_value x)) |
| 76 |
|
|
| 77 |
|
let directive_help ppf = |
| 78 |
|
Format.fprintf ppf |
| 79 |
|
"Toplevel directives: |
| 80 |
|
#quit;; quit the interpreter |
| 81 |
|
#env;; dump current environment |
| 82 |
|
#reinit_ns;; reinitialize namespace processing |
| 83 |
|
#help;; shows this help message |
| 84 |
|
#dump_value <expr>;; dump an XML-ish representation of the resulting |
| 85 |
|
value of a given expression |
| 86 |
|
#print_schema <name>;; |
| 87 |
|
#print_type <name>;; |
| 88 |
|
" |
| 89 |
|
|
| 90 |
let rec print_exn ppf = function |
let rec print_exn ppf = function |
| 91 |
| Location (loc, exn) -> |
| Location (loc, w, exn) -> |
| 92 |
Format.fprintf ppf "Error %a:@\n" Location.print_loc loc; |
Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w); |
| 93 |
Format.fprintf ppf "%a" Location.html_hilight loc; |
Format.fprintf ppf "%a" Location.html_hilight (loc,w); |
| 94 |
print_exn ppf exn |
print_exn ppf exn |
| 95 |
| Value.CDuceExn v -> |
| Value.CDuceExn v -> |
| 96 |
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n" |
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@." |
| 97 |
print_value v |
print_value v |
| 98 |
| Typer.WrongLabel (t,l) -> |
| Typer.WrongLabel (t,l) -> |
| 99 |
Format.fprintf ppf "Wrong record selection: the label %s@\n" |
Format.fprintf ppf "Wrong record selection; field %a " |
| 100 |
(LabelPool.value l); |
Label.print (LabelPool.value l); |
| 101 |
Format.fprintf ppf "applied to an expression of type %a@\n" |
Format.fprintf ppf "not present in an expression of type:@.%a@." |
| 102 |
print_norm t |
print_norm t |
| 103 |
| Typer.ShouldHave (t,msg) -> |
| Typer.ShouldHave (t,msg) -> |
| 104 |
Format.fprintf ppf "This expression should have type %a@\n%s@\n" |
Format.fprintf ppf "This expression should have type:@.%a@.%a@." |
| 105 |
print_norm t |
print_norm t |
| 106 |
msg |
print_protect msg |
| 107 |
| Typer.Constraint (s,t,msg) -> |
| Typer.ShouldHave2 (t1,msg,t2) -> |
| 108 |
Format.fprintf ppf "This expression should have type %a@\n" |
Format.fprintf ppf "This expression should have type:@.%a@.%a %a@." |
| 109 |
|
print_norm t1 |
| 110 |
|
print_protect msg |
| 111 |
|
print_norm t2 |
| 112 |
|
| Typer.Error s -> |
| 113 |
|
Format.fprintf ppf "%a@." print_protect s |
| 114 |
|
| Typer.Constraint (s,t) -> |
| 115 |
|
Format.fprintf ppf "This expression should have type:@.%a@." |
| 116 |
print_norm t; |
print_norm t; |
| 117 |
Format.fprintf ppf "but its infered type is: %a@\n" |
Format.fprintf ppf "but its inferred type is:@.%a@." |
| 118 |
print_norm s; |
print_norm s; |
| 119 |
Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" |
Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@." |
| 120 |
Types.Sample.print (Types.Sample.get (Types.diff s t)); |
print_sample (Sample.get (Types.diff s t)) |
|
Format.fprintf ppf "%s@\n" msg |
|
| 121 |
| Typer.NonExhaustive t -> |
| Typer.NonExhaustive t -> |
| 122 |
Format.fprintf ppf "This pattern matching is not exhaustive@\n"; |
Format.fprintf ppf "This pattern matching is not exhaustive@."; |
| 123 |
Format.fprintf ppf "Residual type: %a@\n" |
Format.fprintf ppf "Residual type:@.%a@." |
| 124 |
print_norm t; |
print_norm t; |
| 125 |
Format.fprintf ppf "Sample value: %a@\n" |
Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t) |
| 126 |
Types.Sample.print (Types.Sample.get t) |
| Typer.UnboundId (x,tn) -> |
| 127 |
| Typer.UnboundId x -> |
Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x) |
| 128 |
Format.fprintf ppf "Unbound identifier %s@\n" x |
(if tn then " (it is a type name)" else "") |
| 129 |
| Wlexer.Illegal_character c -> |
| Ulexer.Error (i,j,s) -> |
| 130 |
Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c) |
let loc = Location.loc_of_pos (i,j), `Full in |
| 131 |
| Wlexer.Unterminated_comment -> |
Format.fprintf ppf "Error %a:@." Location.print_loc loc; |
| 132 |
Format.fprintf ppf "Comment not terminated@\n" |
Format.fprintf ppf "%a%s" Location.html_hilight loc s |
|
| Wlexer.Unterminated_string -> |
|
|
Format.fprintf ppf "String literal not terminated@\n" |
|
|
| Wlexer.Unterminated_string_in_comment -> |
|
|
Format.fprintf ppf "This comment contains an unterminated string literal@\n" |
|
| 133 |
| Parser.Error s | Stream.Error s -> |
| Parser.Error s | Stream.Error s -> |
| 134 |
Format.fprintf ppf "Parsing error: %s@\n" s |
Format.fprintf ppf "Parsing error: %a@." print_protect s |
| 135 |
|
| Librarian.InconsistentCrc id -> |
| 136 |
|
Format.fprintf ppf "Link error:@."; |
| 137 |
|
let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in |
| 138 |
|
Format.fprintf ppf "Inconsistent checksum (compilation unit: %s)@." |
| 139 |
|
name |
| 140 |
|
| Librarian.NoImplementation id -> |
| 141 |
|
Format.fprintf ppf "Link error:@."; |
| 142 |
|
let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in |
| 143 |
|
Format.fprintf ppf "No implementation found for compilation unit: %s@." |
| 144 |
|
name |
| 145 |
|
| Librarian.Loop id -> |
| 146 |
|
Format.fprintf ppf "Compilation error:@."; |
| 147 |
|
let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in |
| 148 |
|
Format.fprintf ppf "Loop between compilation unit (compilation unit: %s)@." |
| 149 |
|
name |
| 150 |
|
| InvalidInputFilename f -> |
| 151 |
|
Format.fprintf ppf "Compilation error:@."; |
| 152 |
|
Format.fprintf ppf "Source filename must have extension .cd@."; |
| 153 |
|
| InvalidObjectFilename f -> |
| 154 |
|
Format.fprintf ppf "Compilation error:@."; |
| 155 |
|
Format.fprintf ppf "Object filename must have extension .cdo and no path@."; |
| 156 |
|
| Librarian.InvalidObject f -> |
| 157 |
|
Format.fprintf ppf "Invalid object file %s@." f |
| 158 |
|
| Librarian.CannotOpen f -> |
| 159 |
|
Format.fprintf ppf "Cannot open file %s@." f |
| 160 |
| Location.Generic s -> |
| Location.Generic s -> |
| 161 |
Format.fprintf ppf "%s@\n" s |
Format.fprintf ppf "%a@." print_protect s |
| 162 |
| exn -> |
| exn -> |
| 163 |
raise exn |
(* raise exn *) |
| 164 |
(* |
Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn) |
| 165 |
Format.fprintf ppf "%s@\n" (Printexc.to_string exn) |
|
| 166 |
*) |
|
| 167 |
|
let display ppf l = |
| 168 |
|
if not !quiet then |
| 169 |
|
List.iter |
| 170 |
|
(fun (x,t) -> dump_value ppf x t (get_global_value x)) |
| 171 |
|
l |
| 172 |
|
|
| 173 |
|
let eval ppf e = |
| 174 |
|
let (e,t) = Typer.type_expr !typing_env e in |
| 175 |
|
|
| 176 |
|
if not !quiet then |
| 177 |
|
Location.dump_loc ppf (e.Typed.exp_loc,`Full); |
| 178 |
|
|
| 179 |
|
let v = |
| 180 |
|
if !do_compile then |
| 181 |
|
let e = Compile.compile_eval !compile_env e in |
| 182 |
|
Eval.L.expr e |
| 183 |
|
else |
| 184 |
|
Eval.eval !eval_env e |
| 185 |
|
in |
| 186 |
|
if not !quiet then |
| 187 |
|
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@." |
| 188 |
|
print_norm t print_value v; |
| 189 |
|
v |
| 190 |
|
|
| 191 |
|
let let_decl ppf p e = |
| 192 |
|
let (tenv,decl,typs) = Typer.type_let_decl !typing_env p e in |
| 193 |
|
|
| 194 |
|
let () = |
| 195 |
|
if !do_compile then |
| 196 |
|
let (env,decl) = Compile.compile_let_decl !compile_env decl in |
| 197 |
|
Eval.L.eval decl; |
| 198 |
|
compile_env := env |
| 199 |
|
else |
| 200 |
|
eval_env := Eval.eval_let_decl !eval_env decl |
| 201 |
|
in |
| 202 |
|
typing_env := tenv; |
| 203 |
|
display ppf typs |
| 204 |
|
|
| 205 |
|
|
| 206 |
|
let let_funs ppf funs = |
| 207 |
|
let (tenv,funs,typs) = Typer.type_let_funs !typing_env funs in |
| 208 |
|
|
| 209 |
|
let () = |
| 210 |
|
if !do_compile then |
| 211 |
|
let (env,funs) = Compile.compile_rec_funs !compile_env funs in |
| 212 |
|
Eval.L.eval funs; |
| 213 |
|
compile_env := env; |
| 214 |
|
else |
| 215 |
|
eval_env := Eval.eval_rec_funs !eval_env funs |
| 216 |
|
in |
| 217 |
|
typing_env := tenv; |
| 218 |
|
display ppf typs |
| 219 |
|
|
| 220 |
|
|
| 221 |
let debug ppf = function |
let debug ppf = function |
| 222 |
| `Subtype (t1,t2) -> |
| `Subtype (t1,t2) -> |
| 223 |
Format.fprintf ppf "[DEBUG:subtype]@\n"; |
Format.fprintf ppf "[DEBUG:subtype]@."; |
| 224 |
let t1 = Types.descr (Typer.typ !glb_env t1) |
let t1 = Types.descr (Typer.typ !typing_env t1) |
| 225 |
and t2 = Types.descr (Typer.typ !glb_env t2) in |
and t2 = Types.descr (Typer.typ !typing_env t2) in |
| 226 |
Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2 |
let s = Types.subtype t1 t2 in |
| 227 |
(Types.subtype t1 t2) |
Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s |
| 228 |
|
| `Sample t -> |
| 229 |
|
Format.fprintf ppf "[DEBUG:sample]@."; |
| 230 |
|
(try |
| 231 |
|
let t = Types.descr (Typer.typ !typing_env t) in |
| 232 |
|
Format.fprintf ppf "%a@." print_sample (Sample.get t) |
| 233 |
|
with Not_found -> |
| 234 |
|
Format.fprintf ppf "Empty type : no sample !@.") |
| 235 |
| `Filter (t,p) -> |
| `Filter (t,p) -> |
| 236 |
Format.fprintf ppf "[DEBUG:filter]@\n"; |
Format.fprintf ppf "[DEBUG:filter]@."; |
| 237 |
let t = Typer.typ !glb_env t |
let t = Typer.typ !typing_env t |
| 238 |
and p = Typer.pat !glb_env p in |
and p = Typer.pat !typing_env p in |
| 239 |
let f = Patterns.filter (Types.descr t) p in |
let f = Patterns.filter (Types.descr t) p in |
| 240 |
List.iter (fun (x,t) -> |
List.iter (fun (x,t) -> |
| 241 |
Format.fprintf ppf " %s:%a@\n" (Id.value x) |
Format.fprintf ppf " %a:%a@." U.print (Id.value x) |
| 242 |
print_norm (Types.descr t)) f |
print_norm (Types.descr t)) f |
|
| `Compile2 (t,pl) -> |
|
|
Format.fprintf ppf "[DEBUG:compile2]@\n"; |
|
|
(* let t = Types.descr (Typer.typ !glb_env t) in |
|
|
let pl = List.map (fun p -> |
|
|
let p = Typer.pat !glb_env p in |
|
|
let a = Types.descr (Patterns.accept p) in |
|
|
(Some p, Types.cap a t)) pl in |
|
|
let d = Patterns.Compiler.make_dispatcher t pl in |
|
|
Patterns.Compiler.print_disp ppf d *) |
|
|
() |
|
|
|
|
| 243 |
| `Accept p -> |
| `Accept p -> |
| 244 |
Format.fprintf ppf "[DEBUG:accept]@\n"; |
Format.fprintf ppf "[DEBUG:accept]@."; |
| 245 |
let p = Typer.pat !glb_env p in |
let p = Typer.pat !typing_env p in |
| 246 |
let t = Patterns.accept p in |
let t = Patterns.accept p in |
| 247 |
Format.fprintf ppf " %a@\n" Types.Print.print t |
Format.fprintf ppf " %a@." Types.Print.print (Types.descr t) |
| 248 |
| `Compile (t,pl) -> |
| `Compile (t,pl) -> |
| 249 |
Format.fprintf ppf "[DEBUG:compile]@\n"; |
Format.fprintf ppf "[DEBUG:compile]@."; |
| 250 |
let t = Typer.typ !glb_env t |
let t = Typer.typ !typing_env t |
| 251 |
and pl = List.map (Typer.pat !glb_env) pl in |
and pl = List.map (Typer.pat !typing_env) pl in |
| 252 |
Patterns.Compile.debug_compile ppf t pl |
Patterns.Compile.debug_compile ppf t pl |
| 253 |
| `Normal_record p -> assert false |
| `Explain (t,e) -> |
| 254 |
|
Format.fprintf ppf "[DEBUG:explain]@."; |
| 255 |
|
let t = Typer.typ !typing_env t in |
| 256 |
|
(match Explain.explain (Types.descr t) (eval ppf e) with |
| 257 |
|
| Some p -> |
| 258 |
|
Format.fprintf ppf "Explanation: @[%a@]@." |
| 259 |
|
Explain.print_path p |
| 260 |
|
| None -> |
| 261 |
|
Format.fprintf ppf "Explanation: value has given type@.") |
| 262 |
|
|
| 263 |
|
|
| 264 |
|
let rec collect_funs ppf accu = function |
| 265 |
|
| { descr = Ast.FunDecl e } :: rest -> collect_funs ppf (e::accu) rest |
| 266 |
|
| rest -> let_funs ppf accu; rest |
| 267 |
|
|
| 268 |
|
let rec collect_types ppf accu = function |
| 269 |
|
| { descr = Ast.TypeDecl (x,t) } :: rest -> |
| 270 |
|
collect_types ppf ((x,t) :: accu) rest |
| 271 |
|
| rest -> |
| 272 |
|
typing_env := |
| 273 |
|
Typer.enter_types (Typer.type_defs !typing_env accu) !typing_env; |
| 274 |
|
rest |
| 275 |
|
|
| 276 |
|
let flush_stdout () = Format.fprintf Format.std_formatter "@." |
| 277 |
|
|
| 278 |
|
let rec phrases ppf phs = match phs with |
| 279 |
|
| { descr = Ast.FunDecl _ } :: _ -> |
| 280 |
|
phrases ppf (collect_funs ppf [] phs) |
| 281 |
|
| { descr = Ast.TypeDecl (_,_) } :: _ -> |
| 282 |
|
phrases ppf (collect_types ppf [] phs) |
| 283 |
|
| { descr = Ast.SchemaDecl (name, schema) } :: rest -> |
| 284 |
|
Typer.register_schema name schema; |
| 285 |
|
phrases ppf rest |
| 286 |
|
| { descr = Ast.Namespace (pr,ns) } :: rest -> |
| 287 |
|
typing_env := Typer.enter_ns pr ns !typing_env; |
| 288 |
|
phrases ppf rest |
| 289 |
|
| { descr = Ast.Using (x,cu) } :: rest -> |
| 290 |
|
Librarian.import cu; |
| 291 |
|
Librarian.run Value.nil cu; |
| 292 |
|
typing_env := Typer.enter_cu x cu !typing_env; |
| 293 |
|
phrases ppf rest |
| 294 |
|
| { descr = Ast.EvalStatement e } :: rest -> |
| 295 |
|
ignore (eval ppf e); |
| 296 |
|
phrases ppf rest |
| 297 |
|
| { descr = Ast.LetDecl (p,e) } :: rest -> |
| 298 |
|
let_decl ppf p e; |
| 299 |
|
phrases ppf rest |
| 300 |
|
| { descr = Ast.Debug l } :: rest -> |
| 301 |
|
debug ppf l; |
| 302 |
|
phrases ppf rest |
| 303 |
|
| { descr = Ast.Directive `Quit } :: rest -> |
| 304 |
|
if !toplevel then raise End_of_file; |
| 305 |
|
phrases ppf rest |
| 306 |
|
| { descr = Ast.Directive `Env } :: rest -> |
| 307 |
|
dump_env ppf; |
| 308 |
|
phrases ppf rest |
| 309 |
|
| { descr = Ast.Directive (`Print_schema schema) } :: rest -> |
| 310 |
|
Schema_common.print_schema ppf (Typer.get_schema schema); |
| 311 |
|
flush_stdout (); |
| 312 |
|
phrases ppf rest |
| 313 |
|
| { descr = Ast.Directive (`Print_type name) } :: rest -> |
| 314 |
|
Typer.dump_type Format.std_formatter !typing_env name; |
| 315 |
|
flush_stdout (); |
| 316 |
|
phrases ppf rest |
| 317 |
|
| { descr = Ast.Directive (`Print_schema_type schema_ref) } :: rest -> |
| 318 |
|
Typer.dump_schema_type Format.std_formatter schema_ref; |
| 319 |
|
flush_stdout (); |
| 320 |
|
phrases ppf rest |
| 321 |
|
| { descr = Ast.Directive `Reinit_ns } :: rest -> |
| 322 |
|
Typer.set_ns_table_for_printer !typing_env; |
| 323 |
|
phrases ppf rest |
| 324 |
|
| { descr = Ast.Directive `Help } :: rest -> |
| 325 |
|
directive_help ppf; |
| 326 |
|
phrases ppf rest |
| 327 |
|
| { descr = Ast.Directive (`Dump pexpr) } :: rest -> |
| 328 |
|
Format.fprintf ppf "%a@." |
| 329 |
|
Value.dump_xml (Eval.eval !eval_env |
| 330 |
|
(fst (Typer.type_expr !typing_env pexpr))); |
| 331 |
|
phrases ppf rest |
| 332 |
|
| [] -> () |
| 333 |
|
|
| 334 |
|
let catch_exn ppf_err exn = |
| 335 |
|
if not catch_exceptions then raise exn; |
| 336 |
|
match exn with |
| 337 |
|
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break) |
| 338 |
|
as e -> |
| 339 |
|
raise e |
| 340 |
|
| exn -> |
| 341 |
|
print_exn ppf_err exn; |
| 342 |
|
Format.fprintf ppf_err "@." |
| 343 |
|
|
| 344 |
let mk_builtin () = |
let parse rule input = |
| 345 |
let bi = List.map (fun (n,t) -> [n, mk noloc (Ast.Internal t)]) |
try Parser.localize_exn (fun () -> rule input) |
| 346 |
Builtin.types in |
with e -> Parser.sync (); raise e |
|
glb_env := List.fold_left Typer.register_global_types !glb_env bi |
|
| 347 |
|
|
| 348 |
let () = mk_builtin () |
let run rule ppf ppf_err input = |
| 349 |
|
try phrases ppf (parse rule input); true |
| 350 |
|
with exn -> catch_exn ppf_err exn; false |
| 351 |
|
|
| 352 |
|
let script = run Parser.prog |
| 353 |
|
let topinput = run Parser.top_phrases |
| 354 |
|
|
| 355 |
let run ppf ppf_err input = |
let compile src out_dir = |
| 356 |
let insert_type_bindings = |
try |
| 357 |
List.iter (fun (x,t) -> |
if not (Filename.check_suffix src ".cd") |
| 358 |
typing_env := Typer.Env.add x t !typing_env; |
then raise (InvalidInputFilename src); |
| 359 |
if not !quiet then |
let cu = Filename.chop_suffix (Filename.basename src) ".cd" in |
| 360 |
Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t) |
let out_dir = |
| 361 |
in |
match out_dir with |
| 362 |
|
| None -> Filename.dirname src |
| 363 |
let type_decl decl = |
| Some x -> x in |
| 364 |
insert_type_bindings (Typer.type_let_decl !typing_env decl) |
let out = Filename.concat out_dir (cu ^ ".cdo") in |
| 365 |
in |
let id = Types.CompUnit.mk (U.mk_latin1 cu) in |
| 366 |
|
Librarian.compile id src; |
| 367 |
let eval_decl decl = |
Librarian.save id out; |
| 368 |
let bindings = Eval.eval_let_decl Eval.Env.empty decl in |
exit 0 |
| 369 |
List.iter |
with exn -> catch_exn Format.err_formatter exn; exit 1 |
|
(fun (x,v) -> |
|
|
Eval.enter_global x v; |
|
|
if not !quiet then |
|
|
Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v |
|
|
) bindings |
|
|
in |
|
|
|
|
|
let phrase ph = |
|
|
match ph.descr with |
|
|
| Ast.EvalStatement e -> |
|
|
let (fv,e) = Typer.expr !glb_env e in |
|
|
let t = Typer.type_check !typing_env e Types.any true in |
|
|
Location.dump_loc ppf e.Typed.exp_loc; |
|
|
if not !quiet then |
|
|
Format.fprintf ppf "|- %a@\n@." print_norm t; |
|
|
let v = Eval.eval Eval.Env.empty e in |
|
|
if not !quiet then |
|
|
Format.fprintf ppf "=> @[%a@]@\n@." print_value v |
|
|
| Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> () |
|
|
| Ast.LetDecl (p,e) -> |
|
|
let decl = Typer.let_decl !glb_env p e in |
|
|
type_decl decl; |
|
|
eval_decl decl |
|
|
| Ast.TypeDecl _ -> () |
|
|
| Ast.Debug l -> debug ppf l |
|
|
| _ -> assert false |
|
|
in |
|
| 370 |
|
|
| 371 |
let do_fun_decls decls = |
let compile_run src argv = |
|
let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in |
|
|
insert_type_bindings (Typer.type_rec_funs !typing_env decls); |
|
|
List.iter eval_decl decls |
|
|
in |
|
|
let rec phrases funs = function |
|
|
| { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs -> |
|
|
phrases ((p,e)::funs) phs |
|
|
| ph :: phs -> |
|
|
do_fun_decls funs; |
|
|
phrase ph; |
|
|
phrases [] phs |
|
|
| _ -> |
|
|
do_fun_decls funs |
|
|
in |
|
| 372 |
try |
try |
| 373 |
let p = |
if not (Filename.check_suffix src ".cd") |
| 374 |
try Parser.prog input |
then raise (InvalidInputFilename src); |
| 375 |
with |
let cu = Filename.chop_suffix (Filename.basename src) ".cd" in |
| 376 |
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e |
let id = Types.CompUnit.mk (U.mk_latin1 cu) in |
| 377 |
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e)) |
Librarian.compile id src; |
| 378 |
in |
Librarian.run argv id |
| 379 |
let (type_decls,fun_decls) = |
with exn -> catch_exn Format.err_formatter exn; exit 1 |
|
List.fold_left |
|
|
(fun ((typs,funs) as accu) ph -> match ph.descr with |
|
|
| Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs) |
|
|
| Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) -> |
|
|
(typs, (p,e)::funs) |
|
|
| _ -> accu |
|
|
) ([],[]) p in |
|
|
glb_env := Typer.register_global_types !glb_env type_decls; |
|
|
phrases [] p; |
|
|
true |
|
|
with |
|
|
| (Failure _ | Not_found | Invalid_argument _) as e -> |
|
|
raise e (* To get ocamlrun stack trace *) |
|
|
| exn -> print_exn ppf_err exn; false |
|
| 380 |
|
|
| 381 |
|
let run obj argv = |
| 382 |
|
try |
| 383 |
|
if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj) |
| 384 |
|
then raise (InvalidObjectFilename obj); |
| 385 |
|
let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in |
| 386 |
|
let id = Types.CompUnit.mk (U.mk_latin1 cu) in |
| 387 |
|
Librarian.import id; |
| 388 |
|
Librarian.run argv id |
| 389 |
|
with exn -> catch_exn Format.err_formatter exn; exit 1 |
| 390 |
|
|