st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-25 16:18:48 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Even better error reporting

Browse source
This commit is contained in:
Dmitry Boulytchev 2020-01-11 16:38:25 +03:00
parent b6180d8634
commit 92f60665df
3 changed files with 56 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

7
src/Driver.ml
View file

@ -109,7 +109,7 @@ class options args =
end
let main =
(* try*)
try
let cmd = new options Sys.argv in
match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
| `Ok prog ->
@ -136,6 +136,5 @@ let main =
List.iter (fun i -> Printf.printf "%d\n" i) output
)
| `Fail er -> Printf.eprintf "Error: %s\n" er
(* with Invalid_argument _ ->
Printf.printf "Usage: rc [-i | -s] <input file.expr>\n"
*)
with Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg

77
src/Language.ml
View file

@ -11,13 +11,21 @@ open Combinators
exception Semantic_error of string
let report_error ?(loc=None) str =
raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c))
module Loc =
struct
@type t = int * int with show, html
module H = Hashtbl.Make (struct type t = string let hash = Hashtbl.hash let equal = (==) end)
let tab = (H.create 1024 : t H.t)
let attach s loc = H.add tab s loc
let get = H.find_opt tab
end
let report_error ?(loc=None) str =
raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c))
(* Values *)
module Value =
@ -159,10 +167,10 @@ module State =
fst @@ inner n st
(* Undefined state *)
let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x)
let undefined x = report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
(* Create a state from bindings list *)
let from_list l = fun x -> try List.assoc x l with Not_found -> report_error (Printf.sprintf "undefined variable %s" x)
let from_list l = fun x -> try List.assoc x l with Not_found -> report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
(* Bind a variable to a value in a state *)
let bind x v s = fun y -> if x = y then v else s y
@ -179,18 +187,18 @@ module State =
(* Update: non-destructively "modifies" the state s by binding the variable x
to value v and returns the new state w.r.t. a scope
*)
let update ?(loc=None) x v s =
let update x v s =
let rec inner = function
| I -> report_error ~loc:loc "uninitialized state"
| I -> report_error "uninitialized state"
| G (scope, s) ->
if is_var x scope
then G (scope, bind x v s)
else report_error ~loc:loc (Printf.sprintf "name %s is undefined or does not designate a variable" x)
else report_error ~loc:(Loc.get x) (Printf.sprintf "name \"%s\" is undefined or does not designate a variable" x)
| L (scope, s, enclosing) ->
if in_scope x scope
then if is_var x scope
then L (scope, bind x v s, enclosing)
else report_error ~loc:loc (Printf.sprintf "name %s does not designate a variable" x)
else report_error ~loc:(Loc.get x) (Printf.sprintf "name \"%s\" does not designate a variable" x)
else L (scope, s, inner enclosing)
in
inner s
@ -278,7 +286,7 @@ module Pattern =
| [] -> UnBoxed
| _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) ps UnBoxed
}
| x:LIDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
| l:$ x:LIDENT y:(-"@" parse)? {Loc.attach x l#coord; match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
| s:("-")? c:DECIMAL {Const (match s with None -> c | _ -> ~-c)}
| s:STRING {String s}
| c:CHAR {Const (Char.code c)}
@ -359,7 +367,7 @@ module Expr =
match x with
| Value.Var (Value.Global x) -> State.update x v st
| Value.Elem (x, i) -> Value.update_elem x i v; st
| _ -> report_error (Printf.sprintf "invalid value %s in update" @@ show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") x)
| _ -> report_error (Printf.sprintf "invalid value \"%s\" in update" @@ show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") x)
(* Expression evaluator
@ -428,7 +436,7 @@ module Expr =
([], body, [])
(List.rev @@
List.map (function
| (name, (`Extern, _)) -> raise (Semantic_error (Printf.sprintf "external names ('%s') not supported in evaluation" name))
| (name, (`Extern, _)) -> report_error (Printf.sprintf "external names (\"%s\") not supported in evaluation" name)
| x -> x
)
defs)
@ -483,7 +491,7 @@ module Expr =
let st'', i', o', vs'' = eval (st', i, o, []) Skip body in
closure.(0) <- st'';
(State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs')
| _ -> report_error (Printf.sprintf "callee did not evaluate to a function: %s" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") f))
| _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") f))
))]))
| Leave -> eval (State.drop st, i, o, vs) Skip k
@ -656,13 +664,14 @@ module Expr =
| base[def][infix][atr];
base[def][infix][atr]:
l:$ n:DECIMAL => {notRef atr} :: (not_a_reference l) => {ignore atr (Const n)}
| l:$ s:STRING => {notRef atr} :: (not_a_reference l)=> {ignore atr (String s)}
| l:$ s:STRING => {notRef atr} :: (not_a_reference l) => {ignore atr (String s)}
| l:$ c:CHAR => {notRef atr} :: (not_a_reference l) => {ignore atr (Const (Char.code c))}
| l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c}
| l:$ %"infix" s:STRING => {notRef atr} :: (not_a_reference l) => {ignore atr (Var (infix_name s))}
| l:$ %"fun" "(" args:!(Util.list0)[ostap (LIDENT)] ")" "{" body:scope[def][infix][Weak][parse def] "}"=> {notRef atr} :: (not_a_reference l) => {ignore atr (Lambda (args, body))}
| l:$ %"fun" "(" args:!(Util.list0)[ostap (l:$ x:LIDENT {Loc.attach x l#coord; x})] ")"
"{" body:scope[def][infix][Weak][parse def] "}"=> {notRef atr} :: (not_a_reference l) => {ignore atr (Lambda (args, body))}
| l:$ "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} :: (not_a_reference l) => {ignore atr (Array es)}
| -"{" scope[def][infix][atr][parse def] -"}"
| l:$ "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} :: (not_a_reference l) => {ignore atr (match es with
@ -673,7 +682,7 @@ module Expr =
| None -> []
| Some args -> args))
}
| x:LIDENT {if notRef atr then ignore atr (Var x) else Ref x}
| l:$ x:LIDENT {Loc.attach x l#coord; if notRef atr then ignore atr (Var x) else Ref x}
| {isVoid atr} => %"skip" {materialize atr Skip}
@ -761,7 +770,7 @@ module Infix =
ce ()
with Break x -> x
let no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord))
let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op)
let kind_of = function true -> Public | _ -> Local
@ -815,38 +824,42 @@ module Definition =
let unopt_mod = function None -> `Local | Some m -> m
ostap (
arg : LIDENT;
arg : l:$ x:LIDENT {Loc.attach x l#coord; x};
position[pub][ass][coord][newp]:
%"at" s:STRING {match ass with `Nona -> Infix.at coord s newp pub | _ -> raise (Semantic_error (Printf.sprintf "associativity for infxi '%s' can not be specified (it is inherited from that for '%s')" newp s))}
%"at" s:STRING {match ass with
| `Nona -> Infix.at coord s newp pub
| _ -> report_error ~loc:(Some coord) (Printf.sprintf "associativity for infix \"%s\" can not be specified (it is inherited from that for \"%s\")" newp s)
}
| f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord s newp ass pub};
head[infix]:
m:(%"external" {`Extern} | %"public" e:(%"external")? {match e with None -> `Public | _ -> `PublicExtern})? %"fun" name:LIDENT {unopt_mod m, name, name, infix}
m:(%"external" {`Extern} | %"public" e:(%"external")? {match e with None -> `Public | _ -> `PublicExtern})? %"fun" l:$ name:LIDENT {Loc.attach name l#coord; unopt_mod m, name, name, infix}
| m:(%"public" {`Public})? ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
l:$ op:(s:STRING {s})
md:position[match m with Some _ -> true | _ -> false][ass][l#coord][op] {
let name = Expr.infix_name op in
match md (Expr.sem name) infix with
| `Ok infix' -> unopt_mod m, op, name, infix'
| `Fail msg -> raise (Semantic_error msg)
| `Fail msg -> report_error ~loc:(Some l#coord) msg
};
local_var[m][infix][expr][def]: name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? {
local_var[m][infix][expr][def]: l:$ name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? {
Loc.attach name l#coord;
match m, value with
| `Extern, Some _ -> raise (Semantic_error (Printf.sprintf "initial value for an external variable '%s' can not be specified" name))
| `Extern, Some _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "initial value for an external variable \"%s\" can not be specified" name)
| _ -> name, (m,`Variable value)
};
parse[infix][expr][def]:
parse[infix][expr][def]:
m:(%"local" {`Local} | %"public" e:(%"external")? {match e with None -> `Public | Some _ -> `PublicExtern} | %"external" {`Extern})
locs:!(Util.list (local_var m infix expr def)) ";" {locs, infix}
| - <(m, orig_name, name, infix')> : head[infix] -"(" -args:!(Util.list0 arg) -")"
("{" body:expr[def][infix'][Expr.Weak] "}" {
(l:$ "{" body:expr[def][infix'][Expr.Weak] "}" {
match m with
| `Extern -> raise (Semantic_error (Printf.sprintf "body for an external function '%s' can not be specified" orig_name))
| `Extern -> report_error ~loc:(Some l#coord) (Printf.sprintf "body for external function \"%s\" can not be specified" orig_name)
| _ -> [(name, (m, `Fun (args, body)))], infix'
} |
";" {
l:$ ";" {
match m with
| `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix'
| _ -> raise (Semantic_error (Printf.sprintf "missing body for the function/infix '%s'" orig_name))
| _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "missing body for the function/infix \"%s\"" orig_name)
})
)
@ -908,7 +921,7 @@ module Interface =
(ostap (interface -EOF))
with
| `Ok intfs -> Some intfs
| `Fail er -> report_error (Printf.sprintf "malformed interface file '%s': %s" fname er)
| `Fail er -> report_error (Printf.sprintf "malformed interface file \"%s\": %s" fname er)
)
with Sys_error _ -> None
@ -923,7 +936,7 @@ module Interface =
in
match inner paths with
| Some (path, intfs) -> path, intfs
| None -> report_error (Printf.sprintf "could not find an interface file for import '%s'" import)
| None -> report_error (Printf.sprintf "could not find an interface file for import \"%s\"" import)
end
@ -952,7 +965,7 @@ ostap (
let name = Expr.infix_name name in
match md (Expr.sem name) infix with
| `Ok infix' -> infix'
| `Fail msg -> raise (Semantic_error msg)
| `Fail msg -> report_error msg
in
match item with
| `Infix (_ , op, `At op') -> insert op infix (Infix.at l#coord op' op false)
@ -973,7 +986,7 @@ ostap (
(is, Infix.extract_exports infix'), Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e)
};
definitions[infix]:
<(def, infix')> : !(Definition.parse infix (*Expr.basic*) (fun def infix atr -> Expr.scope def infix atr (Expr.parse def)) definitions) <(defs, infix'')> : definitions[infix'] {
<(def, infix')> : !(Definition.parse infix (fun def infix atr -> Expr.scope def infix atr (Expr.parse def)) definitions) <(defs, infix'')> : definitions[infix'] {
def @ defs, infix''
}
| empty {[], infix}

16
src/SM.ml
View file

@ -247,7 +247,7 @@ let scope_label i s = label s ^ "_" ^ string_of_int i
let check_name_and_add names name mut =
if List.exists (fun (n, _) -> n = name) names
then invalid_arg (Printf.sprintf "name %s is already defined in the scope\n" name)
then report_error ~loc:(Loc.get name) (Printf.sprintf "name \"%s\" is already defined in the scope" name)
else (name, mut) :: names
;;
@ -545,7 +545,7 @@ object (self : 'self)
match m with
| `Local -> ()
| _ ->
report_error (Printf.sprintf "external/public definitions ('%s') not allowed in local scopes" name)
report_error (Printf.sprintf "external/public definitions (\"%s\") not allowed in local scopes" name)
method add_name (name : string) (m : [`Local | `Extern | `Public | `PublicExtern]) (mut : bool) = {<
decls = (name, m, false) :: decls;
@ -598,7 +598,7 @@ object (self : 'self)
fundefs = add_fun fundefs (to_fundef name' args body scope.st)
>} # register_fun name'
method lookup l name =
method lookup name =
match State.eval scope.st name with
| Value.Access n when n = ~-1 ->
let index = scope.acc_index in
@ -607,7 +607,7 @@ object (self : 'self)
fundefs = fundefs';
scope = {
scope with
st = State.update ~loc:l name (Value.Access index) scope.st;
st = State.update name (Value.Access index) scope.st;
acc_index = scope.acc_index + 1;
closure = loc :: scope.closure
}
@ -683,7 +683,7 @@ let compile cmd ((imports, infixes), p) =
List.fold_left
(fun (env, acc) (name, path) ->
let env = env#add_name name `Local true in
let env, dsg = env#lookup None name in
let env, dsg = env#lookup name in
env,
([DUP] @
List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2)]) path) @
@ -730,8 +730,8 @@ let compile cmd ((imports, infixes), p) =
add_code (compile_expr ls env s) ls false [DROP]
| Expr.ElemRef (x, i) -> compile_list l env [x; i]
| Expr.Var x -> let env, acc = env#lookup None x in (match acc with Value.Fun name -> env#register_call name, false, [PROTO (name, env#current_function)] | _ -> env, false, [LD acc])
| Expr.Ref x -> let env, acc = env#lookup None x in env, false, [LDA acc]
| Expr.Var x -> let env, acc = env#lookup x in (match acc with Value.Fun name -> env#register_call name, false, [PROTO (name, env#current_function)] | _ -> env, false, [LD acc])
| Expr.Ref x -> let env, acc = env#lookup x in env, false, [LDA acc]
| Expr.Const n -> env, false, [CONST n]
| Expr.String s -> env, false, [STRING s]
| Expr.Binop (op, x, y) -> let lop, env = env#get_label in
@ -740,7 +740,7 @@ let compile cmd ((imports, infixes), p) =
| Expr.Call (f, args) -> let lcall, env = env#get_label in
(match f with
| Expr.Var name ->
let env, acc = env#lookup None name in
let env, acc = env#lookup name in
(match acc with
| Value.Fun name ->
let env = env#register_call name in