let rec check_template_nesting template_spec =
let labels = Hashtbl.create 10
in let (_, errors) = List.fold_left(fun acc spec ->
let (line, errors) = acc
in let (name_opt, _) = spec
in match name_opt with
| None -> (line + 1, errors)
| Some label ->
try
let (start, end_start, ending, end_ending) = Hashtbl.find labels label
in let (new_pos, errors) =
if line = end_start + 1 then ((start, line, line, line), errors)
else if line = end_ending + 1 then ((start, end_start, ending, line), errors)
else if ending = end_start then ((start, end_start, line, line), errors)
else ((start, end_start, ending, end_ending), (label, line):: errors)
in Hashtbl.replace labels label new_pos;
(line + 1, errors)
with Not_found ->
Hashtbl.add labels label (line, line, line, line);
(line + 1, errors))
(0,[]) template_spec
in let errors = Hashtbl.fold ( fun label pos list ->
let (start1, _, _, ending1) = pos
in Hashtbl.fold(fun label pos list ->
let (start2, _, _, ending2) = pos
in if start2 > start1 && start2 < ending1 && ending2 > ending1 then (label, ending2):: list
else list
) labels list
) labels errors
in (labels, errors)
and generate_template_instr_function instruction env =
let generate_instructions template_specs labels replacement_list cloc args =
let find_replacement name =
let rec loop = function
| [] -> raise Not_found
| (n, condexpr, repl):: tl when n = name -> (condexpr, repl)
| hd:: tl -> loop tl
in loop replacement_list
in let make_repl_vars replacements =
let rec loop substrings expressions = function
| [] -> (ArrayExpr(List.rev substrings), ArrayExpr(List.rev expressions))
| hd:: tl ->
let (string, expr) = hd
in loop (Value(StringValue(string)):: substrings) (expr:: expressions) tl
in loop [] [] replacements
in let array = Array.of_list template_specs
in let rec loop name result index endindex args target_label substrings_var repl_var =
if index = endindex then
let result = (Return(Id("result"), cloc)):: result
in ExpressionStatement(Declaration(Id(name), Value(FunctionValue(args, List.rev result))), cloc)
else
let (label_opt, line) = array.(index)
in match label_opt with
| None ->
loop name (ExpressionStatement(Assignment(Id("result"), BinaryOp(Id("result"), Plus, Value(StringValue(line)))), cloc):: result) (index + 1) endindex args target_label substrings_var repl_var
| Some label ->
if label = target_label then
let call = FunctionCall(MemberExpr(Value(StringValue(line)), Value(StringValue("mreplace"))),[substrings_var; repl_var])
in loop name (ExpressionStatement(Assignment(Id("result"), BinaryOp(Id("result"), Plus, call)), cloc):: result) (index + 1) endindex args target_label substrings_var repl_var
else
try
let (condexpr, replacements) = find_replacement label
in let (substrings, replexprs) = make_repl_vars replacements
in let (start, _, _, ending) = Hashtbl.find labels label
in let arg_array = match condexpr with
| Once | When(_) -> []
| Loop(iname, _) | CondLoop(_, iname, _) -> [iname]
in let earg_array = match condexpr with
| Once | When(_) -> []
| Loop(iname, _) | CondLoop(_, iname, _) -> [Id(iname)]
in let stmt1 = loop label [ExpressionStatement(Declaration(Id("result"), Value(StringValue(""))), cloc)]
start (ending + 1) arg_array label substrings replexprs
in let call = ExpressionStatement(Assignment(Id("result"), BinaryOp(Id("result"), Plus, FunctionCall(Id(label), earg_array))), cloc)
in let stmt2 = match condexpr with
| Once -> call
| When(cexpr) -> If(cexpr, call, Noop, cloc)
| Loop(iname, iexpr) -> ForEach(iname, iexpr, call, cloc)
| CondLoop(cexpr, iname, iexpr) -> If(cexpr, ForEach(iname, iexpr, call, cloc), Noop, cloc)
in loop name (stmt2:: stmt1:: result) (ending + 1) endindex args target_label substrings_var repl_var
with Not_found ->
raise(TemplateError ("could not find instruction for label '"^label^"'"))
in let (name, args, specs, cloc) = instruction
in loop name [ExpressionStatement(Declaration(Id("result"), Value(StringValue(""))), cloc)]
0 (List.length template_specs) args "" (ArrayExpr([])) (ArrayExpr([]))
in let (name, args, replacements, cloc) = instruction
in try
let (template_specs, labels, _) = Hashtbl.find env.templates name
in let (rstmt, env) =
try
let stmt = generate_instructions template_specs labels replacements cloc args
in analyze_variables env stmt
with TemplateError message ->
(RNoop, Environment.add_error env cloc message)
in Hashtbl.remove env.templates name; (rstmt, env)
with
| Not_found -> (RNoop, env)
| Variable_not_found(name) -> (RNoop, env)
and filter_imported_ast stmts =
let rec loop result = function
| [] -> List.rev result
| stmt:: tl ->
(match stmt with
| ExpressionStatement(Declaration(_, _), _) | Import (_, _) ->
loop (stmt:: result) tl
| _ -> loop result tl
) in
loop [] stmts
and analyze_variables env ast =
let rec find_decl_in_expr env expr cloc =
match expr with
| Declaration(expr1, expr2) ->
let env = (match expr1 with
| Id(name) -> let (env, uid) = Environment.declare_variable env name in env
| MemberExpr(_, _) -> env
| _ -> Environment.add_error env cloc "Left side cannot be assigned to")
in find_decl_in_expr (find_decl_in_expr env expr1 cloc) expr2 cloc
| Not(expr) | PostFixSum (expr, _) ->
find_decl_in_expr env expr cloc
| Assignment(expr1, expr2) | BinaryOp(expr1, _, expr2) | CompOp(expr1, _, expr2)
| MemberExpr(expr1, expr2) ->
find_decl_in_expr (find_decl_in_expr env expr1 cloc) expr2 cloc
| TernaryCond(expr1, expr2, expr3) ->
find_decl_in_expr(find_decl_in_expr (find_decl_in_expr env expr1 cloc) expr2 cloc) expr3 cloc
| FunctionCall(expr, expr_list) ->
List.fold_left (fun env expr ->
find_decl_in_expr env expr cloc) (find_decl_in_expr env expr cloc) expr_list
| MapExpr(proplist) ->
List.fold_left (fun env prop -> let (_, expr) = prop in find_decl_in_expr env expr cloc) env proplist
| ArrayExpr(expr_list) ->
List.fold_left (fun env expr -> find_decl_in_expr env expr cloc) env expr_list
| Value(_) | UnboundVar(_) | Id(_) | VarArg(_) -> env
and find_declarations_in_stmt env stmt =
match stmt with
| ExpressionStatement(expr, cloc) | Throw(expr, cloc) | Switch(expr, _, cloc) | Case(Some expr, cloc)
| If(expr, _, _, cloc) | Return(expr, cloc) | ForEach(_, expr, _, cloc) ->
find_decl_in_expr env expr cloc
| TryFinally(_, _, _) | TryCatch(_, _, _, _) | StatementBlock(_) | Case(None, _) | Continue(_)
| Break(_) | Noop | Program(_) | Import(_) | For(_, _, _, _, _) -> env
| Instructions(name, _, _, _) -> let (env, _) = Environment.declare_variable env name in env
| TemplateDef(name, spec_list , cloc) ->
let (labels, errors) = check_template_nesting spec_list
in match errors with
| [] -> Environment.add_template env name spec_list labels cloc
| error_list ->
List.fold_left (fun env label_offset ->
let (label, offset) = label_offset
in let (file, line) = cloc
in Environment.add_error env (file, line + offset + 1) ("Invalid nesting of labels for label '"^label^"'")
) env error_list
and get_closure_vars stmt_list stack_depth =
let add loc = function
| None -> let t = Hashtbl.create 2 in Hashtbl.replace t loc RUndefined; Some t
| Some t -> Hashtbl.replace t loc RUndefined; Some t
in
let rec find_in_expr result = function
| RVariable(LocalVar(_, sdepth, ind)) | RVarArg(LocalVar(_, sdepth, ind)) ->
if sdepth = stack_depth then result else add (sdepth, ind) result
| RValue(_) | RVariable(GlobalVar(_, _)) | RVarArg(GlobalVar(_, _)) -> result
| RPostFixSum(e, _) | RNot(e) -> find_in_expr result e
| RBinaryOp(e1, _, e2) | RCompOp(e1, _, e2) | RAssignment(e1, e2) | RDeclaration(e1, e2)
| RMemberExpr(e1, e2) ->
find_in_expr (find_in_expr result e1) e2
| RTernaryCond(e1, e2, e3) ->
find_in_expr(find_in_expr (find_in_expr result e1) e2) e3
| RArrayExpr(elist) -> List.fold_left (fun r e -> find_in_expr r e) result elist
| RMapExpr(proplist) ->
List.fold_left (fun r prop -> let (_, e) = prop
in find_in_expr r e) result proplist
| RFunctionCall(e, elist) ->
List.fold_left (fun r e -> find_in_expr r e)
(find_in_expr result e) elist
and process result = function
| RNoop | RContinue(_) | RCase(None, _) | RBreak(_) | RFastIterator _ -> result
| RStatementBlock(slist) -> loop result slist
| RTryCatch(s1, _, s2, _) | RTryFinally(s1, s2, _) ->
process (process result s1) s2
| RReturn (e, _) | RThrow(e, _) | RCase(Some e, _) | RExpressionStatement(e, _) ->
find_in_expr result e
| RFor(e1, e2, e3, stmt, _) ->
process (find_in_expr(find_in_expr (find_in_expr result e1) e2) e3) stmt
| RIf(e, stmt1, stmt2, _) -> process(process(find_in_expr result e) stmt1)stmt2
| RSwitch(e, stmts, _) -> loop (find_in_expr result e) stmts
| RForEach(_, e, stmt, _) -> process (find_in_expr result e) stmt
| RProgram(_) -> raise (RuntimeError.InternalError "unexpected statement in closure processing")
and loop result = function
| [] -> result
| stmt:: list -> loop (process result stmt) list
in loop None stmt_list
and convert_value env cloc = function
| StringValue(v) -> (RStringValue(v), env)
| IntegerValue(v) -> (RIntegerValue(v), env)
| FloatValue(v) -> (RFloatValue(v), env)
| BooleanValue(v) -> (RBooleanValue(v), env)
| Void -> (RVoid, env)
| MapValue(h, s) ->
(RMapValue(Hashtbl.fold (fun k v h ->
let (repl, env) = convert_value env cloc v
in Hashtbl.replace h k repl ; h ) h (Hashtbl.create 10), s), env)
| FunctionValue(arg_list, stmt_list) ->
let rec analyze_vararg has_vararg namelist env = function
| [] -> (has_vararg, List.rev namelist, env)
| name::[] when is_vararg name -> analyze_vararg true ((vararg_formalname name):: namelist) env []
| name:: tl ->
let env =
(if is_vararg name then
Environment.add_error env cloc "vararg must be last argument"
else
env)
in analyze_vararg has_vararg (name:: namelist) env tl
in let (has_vararg, arg_list, env) = analyze_vararg false [] env arg_list
in let env = Environment.new_analysis_stackframe env
in let (env, _) = Environment.declare_variable env "this"
in let _ = Environment.record_usage env (LocalVar(env.unique_id - 1, 0, 0)) (DeclareOp cloc)
in let _ = Environment.record_usage env (LocalVar(env.unique_id - 1, 0, 0)) WriteOp
in let _ = Environment.record_usage env (LocalVar(env.unique_id - 1, 0, 0)) ReadOp
in let env = List.fold_left
(fun env name ->
let (env, _) = Environment.declare_variable env name
in let _ = Environment.record_usage env (LocalVar(env.unique_id - 1 , 0, 0)) (DeclareOp cloc)
in let _ = Environment.record_usage env (LocalVar(env.unique_id - 1, 0, 0)) WriteOp
in env) env arg_list
in let (stmt_list, env) = analyze_variables_in_block env stmt_list
in let closure_vars = get_closure_vars stmt_list (Environment.get_depth env)
in let inline_expr = match (stmt_list, closure_vars) with
| (RReturn(RValue(RFunctionValue(_,_,_,_,_,Some h,_)),_)::[],_) -> None
| (RReturn(expr, _)::[], None) | (RExpressionStatement(expr, _)::[], None) -> Some expr
| ([], None) -> Some (RValue(RVoid))
| _ -> None
in (RFunctionValue(List.hd env.num_locals, Environment.get_depth env, List.length arg_list, has_vararg,
stmt_list, closure_vars, inline_expr), Environment.pop_scope env)
and resolve_expr env expr cloc =
let rec resolve_expr_sub env expr op_type =
match expr with
| Id(name) ->
let loc = Environment.resolve_variable name env
in let _ = record_usage env loc op_type
in (RVariable(loc), env)
| VarArg(name) ->
let loc = Environment.resolve_variable name env
in (RVarArg(loc), env)
| BinaryOp(e1, op, e2) ->
let (expr1, env) = resolve_expr_sub env e1 ReadOp
in let (expr2, env) = resolve_expr_sub env e2 ReadOp
in (match (expr1, expr2) with
| (RValue(v1), RValue(v2)) ->
(try
(RValue(Expression.evaluate_op v1 v2 op), env)
with
| Division_by_zero -> (RBinaryOp(expr1, op, expr2), Environment.add_error env cloc "division by zero")
| EInvalidOperation(_, t) ->
(RBinaryOp(expr1, op, expr2), Environment.add_error env cloc ("invalid operation for "^t^" types"))
| EIncompatibleTypes(t1, t2) ->
(RBinaryOp(expr1, op, expr2), Environment.add_error env cloc ("incompatible types "^t1^" and "^t2))
)
| _ -> (RBinaryOp(expr1, op, expr2), env))
| CompOp(e1, op, e2) ->
let (expr1, env) = resolve_expr_sub env e1 ReadOp
in let (expr2, env) = resolve_expr_sub env e2 ReadOp
in (match (expr1, expr2) with
| (RValue(v1), RValue(v2)) ->
(try
(RValue(Expression.compare v1 op v2), env)
with
| EInvalidComparaison(_, _, _) ->
(RCompOp(expr1, op, expr2), Environment.add_error env cloc ("invalid comparaison"))
)
| _ -> (RCompOp(expr1, op, expr2), env))
| Not(e) ->
let (expr, env) = resolve_expr_sub env e ReadOp
in (match expr with
| RValue(RBooleanValue(b)) -> (RValue(RBooleanValue(not b)), env)
| _ -> (RNot(expr), env))
| FunctionCall(e, el) ->
let rec has_unbound_var = function
| [] -> false
| UnboundVar(_):: tl -> true
| _:: tl -> has_unbound_var tl
in if has_unbound_var el then
let rec unbound_list result = function
| [] -> List.rev result
| UnboundVar(name):: tl -> unbound_list (name:: result) tl
| _:: tl -> unbound_list result tl
in let rec bound_list result = function
| [] -> List.rev result
| UnboundVar(name):: tl ->
let variable =
if is_vararg name then
VarArg(vararg_formalname name)
else
Id(name)
in bound_list (variable:: result) tl
| expr:: tl -> bound_list (expr:: result) tl
in resolve_expr_sub env (Value(FunctionValue(unbound_list [] el,[Return(FunctionCall(e, bound_list [] el), cloc)]))) ReadOp
else
let (expr, env) = resolve_expr_sub env e ReadOp
in let (expr_list, env) = List.fold_left(fun acc expr -> let (lst, env) = acc
in let (expr, env) = resolve_expr_sub env expr ReadOp in (expr:: lst, env)) ([], env) el
in (RFunctionCall(expr, List.rev expr_list), env)
| MapExpr(prop_list) ->
let (prop_list, env) = List.fold_left(fun acc prop -> let (lst, env) = acc
in let (name, expr) = prop
in let (expr, env) = resolve_expr_sub env expr ReadOp
in ((name, expr):: lst, env)) ([], env) prop_list
in (RMapExpr(List.rev prop_list), env)
| ArrayExpr(el) ->
let (expr_list, env) = List.fold_left(fun acc expr -> let (lst, env) = acc
in let (expr, env) = resolve_expr_sub env expr ReadOp
in (expr:: lst, env)) ([], env) el
in (RArrayExpr(List.rev expr_list), env)
| Value(v) -> let (repl, env) = convert_value env cloc v in (RValue(repl), env)
| Assignment(e1, e2) ->
let (expr1, env) = resolve_expr_sub env e1 WriteOp
in let (expr2, env) = resolve_expr_sub env e2 ReadOp
in (RAssignment(expr1, expr2), env)
| Declaration(e1, e2) ->
let (expr1, env) = resolve_expr_sub env e1 (DeclareOp cloc)
in let (expr2, env) = resolve_expr_sub env e2 ReadOp
in let _ = match (expr1, expr2) with
| (RVariable(loc), RValue(value)) ->
let uid = uid_from_loc loc
in Environment.set_constant_value env uid value
| (RVariable(loc), _) -> record_usage env loc WriteOp
| _ -> ()
in (RDeclaration(expr1, expr2), env)
| TernaryCond(e1, e2, e3) ->
let (e1, env) = resolve_expr_sub env e1 ReadOp
in let (e2, env) = resolve_expr_sub env e2 ReadOp
in let (e3, env) = resolve_expr_sub env e3 ReadOp
in (RTernaryCond(e1, e2, e3), env)
| MemberExpr(e1, e2) ->
let (expr1, env) = match op_type with
| DeclareOp(loc) -> resolve_expr_sub env e1 (DeclareWriteOp(loc))
| _ -> resolve_expr_sub env e1 op_type
in let (expr2, env) = resolve_expr_sub env e2 ReadOp
in (RMemberExpr(expr1, expr2), env)
| PostFixSum(e, inc) ->
let (expr, env) = resolve_expr_sub env e WriteOp
in (RPostFixSum(expr, inc), env)
| UnboundVar(_) ->
(RValue(RVoid), Environment.add_error env cloc "Unexpected unbound var")
in
try
resolve_expr_sub env expr ReadOp
with
| Variable_not_found(name) -> (RValue(RVoid), Environment.add_error env cloc ("Undefined variable '"^name^"'"))
and replace_variables_in_block env stmt =
let rec loop env stmt_list new_list =
match stmt_list with
| [] -> (List.rev new_list, env)
| stmt:: tl ->
let (stmt, env) = analyze_variables env stmt
in loop env tl (stmt:: new_list)
in loop env stmt []
and process_imports env stmt_list =
let rec loop result env = function
| [] -> (List.rev result, env)
| Import(filename, cloc):: tl ->
(if Environment.has_import env filename then
loop (Noop:: result) env tl
else (
let env = Environment.add_import env filename
in let stmt = Parser_util.parse_filename filename
in (match stmt with
| Program(stmts) ->
let (stmts, env) = process_imports env (filter_imported_ast stmts)
in let result = List.fold_left (fun lst stmt -> stmt:: lst) result stmts
in loop result env tl
| _ -> raise (RuntimeError.InternalError "Unexpected node from import"))))
| stmt:: tl -> loop (stmt:: result) env tl
in loop [] env stmt_list
and analyze_variables_in_block env stmt_list =
let (stmt_list, env) = process_imports env stmt_list
in let env = List.fold_left(fun env stmt -> find_declarations_in_stmt env stmt) env stmt_list
in replace_variables_in_block env stmt_list
and analyze_variables_in_stmt env stmt =
let env = find_declarations_in_stmt env stmt
in analyze_variables env stmt
in
match ast with
| Program(stmt_list) ->
let (ast, env) = analyze_variables_in_block env stmt_list
in (RProgram(ast), env)
| StatementBlock(stmt_list) ->
let newenv = Environment.new_analysis_scope env
in let (ast, newenv) = analyze_variables_in_block newenv stmt_list
in (RStatementBlock(ast), Environment.pop_scope newenv)
| Switch(expr, stmt_list, cloc) ->
let newenv = Environment.new_analysis_scope env
in let (expr, newenv) = resolve_expr newenv expr cloc
in let (ast, newenv) = analyze_variables_in_block newenv stmt_list
in (RSwitch(expr, ast, cloc), Environment.pop_scope newenv)
| TryCatch(stmt1, name, stmt2, cloc) ->
let newenv = Environment.new_analysis_scope env
in let (stmt1, newenv) = analyze_variables_in_stmt newenv stmt1
in let newenv = Environment.new_analysis_scope (Environment.pop_scope newenv)
in let (newenv, _) = Environment.declare_variable newenv name
in let (stmt2, newenv) = analyze_variables_in_stmt newenv stmt2
in let loc = Environment.resolve_variable name newenv
in (RTryCatch(stmt1, loc, stmt2, cloc), Environment.pop_scope newenv)
| If(expr, stmt1, stmt2, cloc) ->
let (expr, env) = resolve_expr env expr cloc
in let newenv = Environment.new_analysis_scope env
in let (stmt1, newenv) = analyze_variables_in_stmt newenv stmt1
in let newenv = Environment.new_analysis_scope (Environment.pop_scope newenv)
in let (stmt2, newenv) = analyze_variables_in_stmt newenv stmt2
in (RIf(expr, stmt1, stmt2, cloc), Environment.pop_scope newenv)
| TryFinally(stmt1, stmt2, cloc) ->
let newenv = Environment.new_analysis_scope env
in let (stmt1, newenv) = analyze_variables_in_stmt newenv stmt1
in let newenv = Environment.new_analysis_scope (Environment.pop_scope newenv)
in let (stmt2, newenv) = analyze_variables_in_stmt newenv stmt2
in (RTryFinally(stmt1, stmt2, cloc), Environment.pop_scope newenv)
| ForEach(name, expr, stmt, cloc) ->
let (newenv, _) = Environment.declare_variable (Environment.new_analysis_scope env) name
in let (expr, newenv) = resolve_expr newenv expr cloc
in let (stmt, newenv) = analyze_variables_in_stmt newenv stmt
in let loc = Environment.resolve_variable name newenv
in (RForEach(loc, expr, stmt, cloc), Environment.pop_scope newenv)
| For(expr1, expr2, expr3, stmt, cloc) ->
let newenv = Environment.new_analysis_scope env
in let newenv = find_decl_in_expr (find_decl_in_expr (find_decl_in_expr newenv expr1 cloc) expr2 cloc) expr3 cloc
in let (expr1, newenv) = resolve_expr newenv expr1 cloc
in let (expr2, newenv) = resolve_expr newenv expr2 cloc
in let (expr3, newenv) = resolve_expr newenv expr3 cloc
in let (stmt, newenv) = analyze_variables_in_stmt newenv stmt
in (RFor(expr1, expr2, expr3, stmt, cloc), Environment.pop_scope newenv)
| Noop -> (RNoop, env)
| ExpressionStatement(e, cloc) ->
let (expr, env) = resolve_expr env e cloc
in (RExpressionStatement(expr, cloc), env)
| Return(e, cloc) ->
let (e, env) = resolve_expr env e cloc
in (RReturn(e, cloc), env)
| Case(Some e, cloc) ->
let (e, env) = resolve_expr env e cloc
in (RCase(Some e, cloc), env)
| Case(None, cloc) -> (RCase(None, cloc), env)
| Throw(e, cloc) ->
let (e, env) = resolve_expr env e cloc
in (RThrow(e, cloc), env)
| Break(cloc) -> (RBreak(cloc), env)
| Continue(cloc) -> (RContinue(cloc), env)
| Import(_, _) | TemplateDef(_, _, _) -> (RNoop, env)
| Instructions(name, args, specs, cloc) ->
generate_template_instr_function (name, args, specs, cloc) env