Permalink
Browse files

Changed how runtime errors such as division by zero are reported.

We used to allow operations to be triggered by resources and we used
this for reporting common errors through the builtin exception instance
err. This trick does not work anymore, so I changed things around.

First I added Error.exc so that err#raise can report an exception.
Then in pervasives I added a type of runtime errors, changed err so
that it accepts runtime errors (rather than strings), and wrote
convenience handlers for handling division by zero and others.

So now division by zero is handled as

  with divisionByZero x with ...

which will evaluate to x if err#raise DivisionByZero happens.
  • Loading branch information...
1 parent 3b3cf7c commit 13a4b107df18b06175104ed77f5dfaf9c9ec34c4 @andrejbauer andrejbauer committed with matijapretnar Mar 9, 2012
Showing with 68 additions and 72 deletions.
  1. +30 −31 pervasives.eff
  2. +32 −36 src/eff.ml
  3. +5 −4 src/error.ml
  4. +1 −1 src/print.ml
View
@@ -1,43 +1,46 @@
+(* This is the equivalent of Haskell prelude or Ocaml pervasives,
+ with some list handling functions thrown in. *)
+
+external ( = ) : 'a -> 'a -> bool = "="
+
+external ( < ) : 'a -> 'a -> bool = "<"
+
type channel = effect
operation write : string -> unit
operation read : unit -> string
end ;;
external std : channel = "std" ;;
-let absurd x = match x with ;;
-
type 'a exception = effect
operation raise : 'a -> empty
end ;;
-external err : string exception = "err" ;;
+let raise e p = match (e#raise p) with ;;
-let raise e p = absurd (e#raise p) ;;
+type runtime_error =
+ | DivisionByZero
+ | InvalidArgument of string
+ | AssertionFault
+ | FailWith of string ;;
-let divByZero =
- new exception @ () with
- operation raise _ @ _ -> absurd (err#raise "Division by zero")
- end ;;
+external err : runtime_error exception = "err" ;;
-let invalidArgument =
- new exception @ () with
- operation raise msg @ _ -> absurd (err#raise msg)
- end ;;
+let runtime_error e = raise err e ;;
-let assertionFault =
- new exception @ () with
- operation raise _ @ _ -> absurd (err#raise "assertion failure")
- end ;;
+let runtime_handle e v = handler
+ | err#raise e' _ ->
+ if e' = e then v else runtime_error e' ;;
-let assert b = if b then () else raise assertionFault () ;;
+let divisionByZero = runtime_handle DivisionByZero ;;
-let failWith =
- new exception @ () with
- operation raise msg @ _ -> absurd (err#raise msg)
- end ;;
+let invalidArgument msg = runtime_handle (InvalidArgument msg) ;;
-let failwith msg = raise failWith msg ;;
+let failWith msg = runtime_handle (FailWith msg) ;;
+
+let assert b = if b then () else runtime_error AssertionFault ;;
+
+let failwith msg = runtime_error (FailWith msg) ;;
external ( ~- ) : int -> int = "~-"
@@ -51,13 +54,9 @@ external ( - ) : int -> int -> int = "-"
external ( % ) : int -> int -> int = "%"
let (%) m n = match n with
- | 0 -> raise divByZero ()
+ | 0 -> runtime_error DivisionByZero
| n -> (%) m n
-external ( < ) : 'a -> 'a -> bool = "<"
-
-external ( = ) : 'a -> 'a -> bool = "="
-
external ( ~-. ) : float -> float = "~-."
external ( +. ) : float -> float -> float = "+."
@@ -69,7 +68,7 @@ external ( -. ) : float -> float -> float = "-."
external ( /. ) : float -> float -> float = "/."
external ( / ) : int -> int -> int = "/"
let ( / ) m n = match n with
- | 0 -> raise divByZero ()
+ | 0 -> runtime_error DivisionByZero
| n -> (/) m n
external float : int -> float = "float"
@@ -172,7 +171,7 @@ let rec zip xs ys =
match (xs, ys) with
| ([], []) -> []
| (x :: xs, y :: ys) -> (x, y) :: (zip xs ys)
- | (_, _) -> raise invalidArgument "zip: length mismatch"
+ | (_, _) -> runtime_error (InvalidArgument "zip: length mismatch")
let reverse =
let rec reverse_acc acc = function
@@ -191,11 +190,11 @@ let rec length = function
| x :: xs -> length xs + 1
let head = function
- | [] -> raise invalidArgument "head: empty list"
+ | [] -> runtime_error (InvalidArgument "head: empty list")
| x :: _ -> x
let rec tail = function
- | [] -> raise invalidArgument "head: empty list"
+ | [] -> runtime_error (InvalidArgument "tail: empty list")
| x :: xs -> xs
let abs x = if x < 0 then -x else x
View
@@ -2,13 +2,13 @@ module S = Syntax
module C = Common
let usage = "Usage: eff [option] ... [file] ..."
-let interactive = ref true
+let interactive_shell = ref true
let pervasives = ref true
let pervasives_file = ref (Filename.concat (Filename.dirname Sys.argv.(0)) "pervasives.eff")
(* We set up a list of files to be loaded and run. *)
let files = ref []
-let add_file f = (files := f :: !files)
+let add_file interactive filename = (files := (filename, interactive) :: !files)
(* Command-line options *)
let options = Arg.align [
@@ -29,10 +29,10 @@ let options = Arg.align [
("--warn-sequencing", Arg.Set Infer.warn_implicit_sequencing,
" Print warning about implicit sequencing");
("-n",
- Arg.Clear interactive,
+ Arg.Clear interactive_shell,
" Do not run the interactive toplevel");
("-l",
- Arg.String (fun str -> add_file str),
+ Arg.String (fun str -> add_file false str),
"<file> Load <file> into the initial environment");
("-V",
Arg.Set_int Print.verbosity,
@@ -41,8 +41,8 @@ let options = Arg.align [
(* Treat anonymous arguments as files to be run. *)
let anonymous str =
- add_file str;
- interactive := false
+ add_file true str;
+ interactive_shell := false
(* Parser wrapper *)
@@ -55,10 +55,10 @@ let parse parser lex =
| Failure "lexing: empty token" ->
Error.syntax ~pos:(Lexer.position_of_lex lex) "unrecognised symbol."
-let initial_environment =
+let initial_ctxenv =
(Ctx.initial, Eval.initial)
-let exec_topdef (ctx, env) (d,pos) =
+let exec_topdef interactive (ctx, env) (d,pos) =
match d with
| S.TopLet defs ->
let defs = C.assoc_map Desugar.computation defs in
@@ -68,7 +68,7 @@ let exec_topdef (ctx, env) (d,pos) =
(fun (p,c) env -> let v = Eval.run env c in Eval.extend p v env)
defs env
in
- if !interactive then begin
+ if interactive then begin
List.iter (fun (x, (ps,t)) ->
match Eval.lookup x env with
| None -> assert false
@@ -80,7 +80,7 @@ let exec_topdef (ctx, env) (d,pos) =
let defs = C.assoc_map Desugar.let_rec defs in
let vars, ctx = Infer.infer_top_let_rec ctx pos defs in
let env = Eval.extend_let_rec env defs in
- if !interactive then begin
+ if interactive then begin
List.iter (fun (x,(ps,t)) -> Format.printf "@[val %s : %t = <fun>@]@." x (Print.ty ps t)) vars
end ;
(ctx, env)
@@ -100,51 +100,50 @@ let exec_topdef (ctx, env) (d,pos) =
(* [exec_cmd env c] executes toplevel command [c] in global
environment [(ctx, env)]. It prints the result on standard output
and return the new environment. *)
-let rec exec_cmd (ctx, env) e =
+let rec exec_cmd interactive (ctx, env) e =
match e with
| S.Expr c ->
let c = Desugar.computation c in
let ctx, (ps, t) = Infer.infer_top_comp ctx c in
let v = Eval.run env c in
- if !interactive then Format.printf "@[- : %t = %t@]@." (Print.ty ps t) (Print.value v) ;
+ if interactive then Format.printf "@[- : %t = %t@]@." (Print.ty ps t) (Print.value v) ;
(ctx, env)
| S.TypeOf c ->
let c = Desugar.computation c in
let ctx, (ps, t) = Infer.infer_top_comp ctx c in
Format.printf "@[- : %t@]@." (Print.ty ps t) ;
(ctx, env)
-
| S.Reset ->
- print_endline ("Environment reset."); initial_environment
+ print_endline ("Environment reset."); initial_ctxenv
| S.Help ->
print_endline ("Read the source.") ; (ctx, env)
| S.Quit -> exit 0
- | S.Use fn -> use_file (ctx, env) fn
- | S.Topdef def -> exec_topdef (ctx, env) def
+ | S.Use fn -> use_file (ctx, env) (fn, interactive)
+ | S.Topdef def -> exec_topdef interactive (ctx, env) def
-and use_file env fn =
- let cmds = Lexer.read_file (parse Parser.file) fn in
- List.fold_left exec_cmd env cmds
-
-let rec loop env =
- try
- let cmd = Lexer.read_toplevel (parse Parser.commandline) () in
- let env = exec_cmd env cmd in
- loop env
- with
- | Error.Error err -> Print.error err; loop env
- | Sys.Break -> prerr_endline "Interrupted."; loop env
+and use_file env (filename, interactive) =
+ let cmds = Lexer.read_file (parse Parser.file) filename in
+ List.fold_left (exec_cmd interactive) env cmds
(* Interactive toplevel *)
-let toplevel env =
+let toplevel ctxenv =
let eof = match Sys.os_type with
| "Unix" | "Cygwin" -> "Ctrl-D"
| "Win32" -> "Ctrl-Z"
| _ -> "EOF"
in
print_endline ("eff " ^ Version.version);
print_endline ("Press " ^ eof ^ " to exit.");
- try loop env
+ try
+ let ctxenv = ref ctxenv in
+ while true do
+ try
+ let cmd = Lexer.read_toplevel (parse Parser.commandline) () in
+ ctxenv := exec_cmd true !ctxenv cmd
+ with
+ | Error.Error err -> Print.error err
+ | Sys.Break -> prerr_endline "Interrupted."
+ done
with End_of_file -> ()
(* Main program *)
@@ -155,13 +154,10 @@ let main =
(* Files were listed in the wrong order, so we reverse them *)
files := List.rev !files;
(* Load the pervasives. *)
- if !pervasives then add_file !pervasives_file ;
+ if !pervasives then add_file false !pervasives_file ;
try
(* Run and load all the specified files. *)
- let i = !interactive in
- interactive := false ;
- let env = List.fold_left use_file initial_environment !files in
- interactive := i ;
- if !interactive then toplevel env
+ let ctxenv = List.fold_left use_file initial_ctxenv !files in
+ if !interactive_shell then toplevel ctxenv
with
Error.Error err -> Print.error err; exit 1
View
@@ -7,7 +7,8 @@ let error ?(pos=Common.Nowhere) err_type =
in
Format.kfprintf k Format.str_formatter
-let fatal ?pos = error ?pos "Fatal"
-let typing ?pos = error ?pos "Typing"
-let runtime ?pos = error ?pos "Runtime"
-let syntax ?pos = error ?pos "Syntax"
+let fatal ?pos = error ?pos "Fatal error"
+let typing ?pos = error ?pos "Typing error"
+let runtime ?pos = error ?pos "Runtime error"
+let syntax ?pos = error ?pos "Syntax error"
+let exc ?pos = error ?pos "Exception"
View
@@ -196,7 +196,7 @@ let message ?(pos=Common.Nowhere) msg_type v =
else
Format.ifprintf Format.err_formatter
-let error (pos, err_type, msg) = message ~pos (err_type ^ " error") 1 "%s" msg
+let error (pos, err_type, msg) = message ~pos (err_type) 1 "%s" msg
let check ?pos = message ?pos "Check" 2
let warning ?pos = message ?pos "Warning" 3
let debug ?pos = message ?pos "Debug" 4

0 comments on commit 13a4b10

Please sign in to comment.