| 1 |
open Location
|
| 2 |
open Ident
|
| 3 |
|
| 4 |
exception InvalidInputFilename of string
|
| 5 |
exception InvalidObjectFilename of string
|
| 6 |
|
| 7 |
(* if set to false toplevel exception aren't cought.
|
| 8 |
* Useful for debugging with 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 toplevel = ref false
|
| 20 |
let verbose = ref false
|
| 21 |
|
| 22 |
let typing_env = State.ref "Cduce.typing_env" Builtin.env
|
| 23 |
let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
|
| 24 |
|
| 25 |
let get_global_value cenv v =
|
| 26 |
Eval.var (Compile.find v !compile_env)
|
| 27 |
|
| 28 |
let get_global_type v =
|
| 29 |
Typer.find_value v !typing_env
|
| 30 |
|
| 31 |
let rec is_abstraction = function
|
| 32 |
| Ast.Abstraction _ -> true
|
| 33 |
| Ast.LocatedExpr (_,e) -> is_abstraction e
|
| 34 |
| _ -> false
|
| 35 |
|
| 36 |
let print_norm ppf d =
|
| 37 |
Location.protect ppf
|
| 38 |
(fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
|
| 39 |
|
| 40 |
let print_sample ppf s =
|
| 41 |
Location.protect ppf
|
| 42 |
(fun ppf -> Sample.print ppf s)
|
| 43 |
|
| 44 |
let print_protect ppf s =
|
| 45 |
Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)
|
| 46 |
|
| 47 |
let print_value ppf v =
|
| 48 |
Location.protect ppf (fun ppf -> Value.print ppf v)
|
| 49 |
|
| 50 |
let dump_value ppf x t v =
|
| 51 |
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
|
| 52 |
U.print (Id.value x) print_norm t print_value v
|
| 53 |
|
| 54 |
let dump_env ppf tenv cenv =
|
| 55 |
Format.fprintf ppf "Types:%a@." Typer.dump_types tenv;
|
| 56 |
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns tenv;
|
| 57 |
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
|
| 58 |
Ns.InternalPrinter.dump;
|
| 59 |
Format.fprintf ppf "Schemas: %s@."
|
| 60 |
(String.concat " " (List.map U.get_str (Typer.get_schema_names tenv)));
|
| 61 |
Format.fprintf ppf "Values:@.";
|
| 62 |
Typer.iter_values tenv
|
| 63 |
(fun x t -> dump_value ppf x t (get_global_value cenv x))
|
| 64 |
|
| 65 |
let directive_help ppf =
|
| 66 |
Format.fprintf ppf
|
| 67 |
"Toplevel directives:
|
| 68 |
#quit;; quit the interpreter
|
| 69 |
#env;; dump current environment
|
| 70 |
#reinit_ns;; reinitialize namespace processing
|
| 71 |
#help;; shows this help message
|
| 72 |
#dump_value <expr>;; dump an XML-ish representation of the resulting
|
| 73 |
value of a given expression
|
| 74 |
#print_schema <name>;;
|
| 75 |
#print_type <name>;;
|
| 76 |
"
|
| 77 |
|
| 78 |
let rec print_exn ppf = function
|
| 79 |
| Location (loc, w, exn) ->
|
| 80 |
Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
|
| 81 |
Format.fprintf ppf "%a" Location.html_hilight (loc,w);
|
| 82 |
print_exn ppf exn
|
| 83 |
| Value.CDuceExn v ->
|
| 84 |
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
|
| 85 |
print_value v
|
| 86 |
| Typer.WrongLabel (t,l) ->
|
| 87 |
Format.fprintf ppf "Wrong record selection; field %a "
|
| 88 |
Label.print (LabelPool.value l);
|
| 89 |
Format.fprintf ppf "not present in an expression of type:@.%a@."
|
| 90 |
print_norm t
|
| 91 |
| Typer.ShouldHave (t,msg) ->
|
| 92 |
Format.fprintf ppf "This expression should have type:@.%a@.%a@."
|
| 93 |
print_norm t
|
| 94 |
print_protect msg
|
| 95 |
| Typer.ShouldHave2 (t1,msg,t2) ->
|
| 96 |
Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
|
| 97 |
print_norm t1
|
| 98 |
print_protect msg
|
| 99 |
print_norm t2
|
| 100 |
| Typer.Error s ->
|
| 101 |
Format.fprintf ppf "%a@." print_protect s
|
| 102 |
| Typer.Constraint (s,t) ->
|
| 103 |
Format.fprintf ppf "This expression should have type:@.%a@."
|
| 104 |
print_norm t;
|
| 105 |
Format.fprintf ppf "but its inferred type is:@.%a@."
|
| 106 |
print_norm s;
|
| 107 |
Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@."
|
| 108 |
print_sample (Sample.get (Types.diff s t))
|
| 109 |
| Typer.NonExhaustive t ->
|
| 110 |
Format.fprintf ppf "This pattern matching is not exhaustive@.";
|
| 111 |
Format.fprintf ppf "Residual type:@.%a@."
|
| 112 |
print_norm t;
|
| 113 |
Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
|
| 114 |
| Typer.UnboundId (x,tn) ->
|
| 115 |
Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
|
| 116 |
(if tn then " (it is a type name)" else "")
|
| 117 |
| Typer.UnboundExtId (cu,x) ->
|
| 118 |
Format.fprintf ppf "Unbound external identifier %a:%a@."
|
| 119 |
U.print (Types.CompUnit.value cu)
|
| 120 |
U.print (Id.value x)
|
| 121 |
| Ulexer.Error (i,j,s) ->
|
| 122 |
let loc = Location.loc_of_pos (i,j), `Full in
|
| 123 |
Format.fprintf ppf "Error %a:@." Location.print_loc loc;
|
| 124 |
Format.fprintf ppf "%a%s" Location.html_hilight loc s
|
| 125 |
| Parser.Error s | Stream.Error s ->
|
| 126 |
Format.fprintf ppf "Parsing error: %a@." print_protect s
|
| 127 |
| Librarian.InconsistentCrc id ->
|
| 128 |
Format.fprintf ppf "Link error:@.";
|
| 129 |
let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
|
| 130 |
Format.fprintf ppf "Inconsistent checksum (compilation unit: %s)@."
|
| 131 |
name
|
| 132 |
| Librarian.NoImplementation id ->
|
| 133 |
Format.fprintf ppf "Link error:@.";
|
| 134 |
let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
|
| 135 |
Format.fprintf ppf "No implementation found for compilation unit: %s@."
|
| 136 |
name
|
| 137 |
| Librarian.Loop id ->
|
| 138 |
Format.fprintf ppf "Compilation error:@.";
|
| 139 |
let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
|
| 140 |
Format.fprintf ppf "Loop between compilation unit (compilation unit: %s)@."
|
| 141 |
name
|
| 142 |
| InvalidInputFilename f ->
|
| 143 |
Format.fprintf ppf "Compilation error:@.";
|
| 144 |
Format.fprintf ppf "Source filename must have extension .cd@.";
|
| 145 |
| InvalidObjectFilename f ->
|
| 146 |
Format.fprintf ppf "Compilation error:@.";
|
| 147 |
Format.fprintf ppf "Object filename must have extension .cdo and no path@.";
|
| 148 |
| Librarian.InvalidObject f ->
|
| 149 |
Format.fprintf ppf "Invalid object file %s@." f
|
| 150 |
| Librarian.CannotOpen f ->
|
| 151 |
Format.fprintf ppf "Cannot open file %s@." f
|
| 152 |
| Location.Generic s ->
|
| 153 |
Format.fprintf ppf "%a@." print_protect s
|
| 154 |
| exn ->
|
| 155 |
(* raise exn *)
|
| 156 |
Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
|
| 157 |
|
| 158 |
|
| 159 |
let eval_quiet tenv cenv e =
|
| 160 |
let (e,_) = Typer.type_expr tenv e in
|
| 161 |
let e = Compile.compile_expr cenv e in
|
| 162 |
Eval.expr e
|
| 163 |
|
| 164 |
let debug ppf tenv cenv = function
|
| 165 |
| `Subtype (t1,t2) ->
|
| 166 |
Format.fprintf ppf "[DEBUG:subtype]@.";
|
| 167 |
let t1 = Types.descr (Typer.typ tenv t1)
|
| 168 |
and t2 = Types.descr (Typer.typ tenv t2) in
|
| 169 |
let s = Types.subtype t1 t2 in
|
| 170 |
Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
|
| 171 |
| `Sample t ->
|
| 172 |
Format.fprintf ppf "[DEBUG:sample]@.";
|
| 173 |
(try
|
| 174 |
let t = Types.descr (Typer.typ tenv t) in
|
| 175 |
Format.fprintf ppf "%a@." print_sample (Sample.get t)
|
| 176 |
with Not_found ->
|
| 177 |
Format.fprintf ppf "Empty type : no sample !@.")
|
| 178 |
| `Filter (t,p) ->
|
| 179 |
Format.fprintf ppf "[DEBUG:filter]@.";
|
| 180 |
let t = Typer.typ tenv t
|
| 181 |
and p = Typer.pat tenv p in
|
| 182 |
let f = Patterns.filter (Types.descr t) p in
|
| 183 |
List.iter (fun (x,t) ->
|
| 184 |
Format.fprintf ppf " %a:%a@." U.print (Id.value x)
|
| 185 |
print_norm (Types.descr t)) f
|
| 186 |
| `Accept p ->
|
| 187 |
Format.fprintf ppf "[DEBUG:accept]@.";
|
| 188 |
let p = Typer.pat tenv p in
|
| 189 |
let t = Patterns.accept p in
|
| 190 |
Format.fprintf ppf " %a@." Types.Print.print (Types.descr t)
|
| 191 |
| `Compile (t,pl) ->
|
| 192 |
Format.fprintf ppf "[DEBUG:compile]@.";
|
| 193 |
let t = Typer.typ tenv t
|
| 194 |
and pl = List.map (Typer.pat tenv) pl in
|
| 195 |
Patterns.Compile.debug_compile ppf t pl
|
| 196 |
| `Explain (t,e) ->
|
| 197 |
Format.fprintf ppf "[DEBUG:explain]@.";
|
| 198 |
let t = Typer.typ tenv t in
|
| 199 |
(match Explain.explain (Types.descr t) (eval_quiet tenv cenv e) with
|
| 200 |
| Some p ->
|
| 201 |
Format.fprintf ppf "Explanation: @[%a@]@."
|
| 202 |
Explain.print_path p
|
| 203 |
| None ->
|
| 204 |
Format.fprintf ppf "Explanation: value has given type@.")
|
| 205 |
|
| 206 |
|
| 207 |
let flush_ppf ppf = Format.fprintf ppf "@."
|
| 208 |
|
| 209 |
let directive ppf tenv cenv = function
|
| 210 |
| `Debug d ->
|
| 211 |
debug ppf tenv cenv d
|
| 212 |
| `Quit ->
|
| 213 |
(if !toplevel then raise End_of_file)
|
| 214 |
| `Env ->
|
| 215 |
dump_env ppf tenv cenv
|
| 216 |
| `Print_schema schema ->
|
| 217 |
let uri = Typer.find_schema schema tenv in
|
| 218 |
let sch = Typer.get_schema uri in
|
| 219 |
Schema_common.print_schema ppf sch;
|
| 220 |
flush_ppf ppf
|
| 221 |
| `Print_type name ->
|
| 222 |
Typer.dump_type ppf tenv name;
|
| 223 |
flush_ppf ppf
|
| 224 |
| `Print_schema_type schema_ref ->
|
| 225 |
Typer.dump_schema_type ppf tenv schema_ref;
|
| 226 |
flush_ppf ppf
|
| 227 |
| `Reinit_ns ->
|
| 228 |
Typer.set_ns_table_for_printer tenv
|
| 229 |
| `Help ->
|
| 230 |
directive_help ppf
|
| 231 |
| `Dump pexpr ->
|
| 232 |
Value.dump_xml ppf (eval_quiet tenv cenv pexpr);
|
| 233 |
flush_ppf ppf
|
| 234 |
|
| 235 |
let print_id_opt ppf = function
|
| 236 |
| None -> Format.fprintf ppf "-"
|
| 237 |
| Some id -> Format.fprintf ppf "val %a" U.print (Id.value id)
|
| 238 |
|
| 239 |
let print_value_opt ppf = function
|
| 240 |
| None -> ()
|
| 241 |
| Some v -> Format.fprintf ppf " = %a" print_value v
|
| 242 |
|
| 243 |
let show ppf id t v =
|
| 244 |
Format.fprintf ppf "@[%a : @[%a%a@]@]@."
|
| 245 |
print_id_opt id
|
| 246 |
print_norm t
|
| 247 |
print_value_opt v
|
| 248 |
|
| 249 |
let phrases ppf phs =
|
| 250 |
let (tenv,cenv,_) =
|
| 251 |
Compile.comp_unit
|
| 252 |
~run:true ~show:(show ppf)
|
| 253 |
~loading:Librarian.import_and_run
|
| 254 |
~directive:(directive ppf)
|
| 255 |
!typing_env !compile_env phs in
|
| 256 |
typing_env := tenv;
|
| 257 |
compile_env := cenv
|
| 258 |
|
| 259 |
let catch_exn ppf_err exn =
|
| 260 |
if not catch_exceptions then raise exn;
|
| 261 |
match exn with
|
| 262 |
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
|
| 263 |
as e ->
|
| 264 |
raise e
|
| 265 |
| exn ->
|
| 266 |
print_exn ppf_err exn;
|
| 267 |
Format.fprintf ppf_err "@."
|
| 268 |
|
| 269 |
let parse rule input =
|
| 270 |
try Parser.localize_exn (fun () -> rule input)
|
| 271 |
with e -> Parser.sync (); raise e
|
| 272 |
|
| 273 |
let run rule ppf ppf_err input =
|
| 274 |
try phrases ppf (parse rule input); true
|
| 275 |
with exn -> catch_exn ppf_err exn; false
|
| 276 |
|
| 277 |
let topinput = run Parser.top_phrases
|
| 278 |
let script = run Parser.prog
|
| 279 |
|
| 280 |
|
| 281 |
let compile src out_dir =
|
| 282 |
try
|
| 283 |
if not (Filename.check_suffix src ".cd")
|
| 284 |
then raise (InvalidInputFilename src);
|
| 285 |
let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
|
| 286 |
let out_dir =
|
| 287 |
match out_dir with
|
| 288 |
| None -> Filename.dirname src
|
| 289 |
| Some x -> x in
|
| 290 |
let out = Filename.concat out_dir (cu ^ ".cdo") in
|
| 291 |
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
|
| 292 |
Librarian.compile !verbose cu id src;
|
| 293 |
Librarian.save cu id out;
|
| 294 |
exit 0
|
| 295 |
with exn -> catch_exn Format.err_formatter exn; exit 1
|
| 296 |
|
| 297 |
let compile_run src =
|
| 298 |
try
|
| 299 |
if not (Filename.check_suffix src ".cd")
|
| 300 |
then raise (InvalidInputFilename src);
|
| 301 |
let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
|
| 302 |
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
|
| 303 |
Librarian.compile !verbose cu id src;
|
| 304 |
Librarian.run id
|
| 305 |
with exn -> catch_exn Format.err_formatter exn; exit 1
|
| 306 |
|
| 307 |
let run obj =
|
| 308 |
try
|
| 309 |
if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
|
| 310 |
then raise (InvalidObjectFilename obj);
|
| 311 |
let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
|
| 312 |
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
|
| 313 |
Librarian.import_and_run id
|
| 314 |
with exn -> catch_exn Format.err_formatter exn; exit 1
|
| 315 |
|
| 316 |
|
| 317 |
let dump_env ppf = dump_env ppf !typing_env !compile_env
|
| 318 |
|
| 319 |
let eval s =
|
| 320 |
let st = Stream.of_string s in
|
| 321 |
let phs = parse Parser.prog st in
|
| 322 |
let vals = ref [] in
|
| 323 |
let show id t v =
|
| 324 |
match id,v with
|
| 325 |
| Some id, Some v ->
|
| 326 |
let id = Id.value id in
|
| 327 |
vals := (Some id,v) :: !vals
|
| 328 |
| None, Some v ->
|
| 329 |
vals := (None,v) :: !vals
|
| 330 |
| _ -> assert false
|
| 331 |
in
|
| 332 |
let r () =
|
| 333 |
ignore (Compile.comp_unit
|
| 334 |
~run:true ~show Builtin.env Compile.empty_toplevel phs) in
|
| 335 |
Eval.new_stack r ();
|
| 336 |
List.rev !vals
|
| 337 |
|
| 338 |
let eval s =
|
| 339 |
try eval s
|
| 340 |
with exn ->
|
| 341 |
let b = Buffer.create 1024 in
|
| 342 |
let ppf = Format.formatter_of_buffer b in
|
| 343 |
print_exn ppf exn;
|
| 344 |
Format.fprintf ppf "@.";
|
| 345 |
raise (Value.CDuceExn (Value.ocaml2cduce_string (Buffer.contents b)))
|
| 346 |
|
| 347 |
|
Parent Directory
| 
Revision Log