semantics.ml (4151B)
1 open Ast 2 open Ast.IR 3 open Baselib 4 5 exception Error of string * Lexing.position 6 7 let print_env key v = 8 print_endline (key ^ " " ^ (string_of_type_t v)) 9 10 let expr_pos expr = 11 match expr with 12 | Syntax.Void v -> v.pos 13 | Syntax.Int n -> n.pos 14 | Syntax.Float n -> n.pos 15 | Syntax.Bool b -> b.pos 16 | Syntax.Char c -> c.pos 17 | Syntax.Str s -> s.pos 18 | Syntax.Var v -> v.pos 19 | Syntax.Call c -> c.pos 20 21 let errt expected given pos = 22 raise (Error (Printf.sprintf "expected %s but given %s" 23 (string_of_type_t expected) 24 (string_of_type_t given), 25 pos)) 26 27 let rec analyze_expr expr env = 28 match expr with 29 | Syntax.Void v -> Void, Void_t 30 | Syntax.Int n -> Int n.value, Int_t 31 | Syntax.Float n -> Float n.value, Float_t 32 | Syntax.Bool b -> Bool b.value, Bool_t 33 | Syntax.Char c -> Char c.value, Char_t 34 | Syntax.Str s -> Str s.value, Str_t 35 | Syntax.Var v -> 36 if Env.mem v.name env then 37 Var v.name, Env.find v.name env 38 else 39 raise (Error (Printf.sprintf "unbound variable '%s'" v.name, 40 v.pos)) 41 | Syntax.Call c -> 42 match Env.find_opt c.func env with 43 | Some (Func_t (rt, at)) -> 44 if List.length at != List.length c.args then 45 raise (Error (Printf.sprintf "expected %d arguments but given %d" 46 (List.length at) (List.length c.args), c.pos)) ; 47 let args = List.map2 (fun eat a -> let aa, at = analyze_expr a env 48 in if at = eat then aa 49 else errt eat at (expr_pos a)) 50 at c.args in 51 Call (c.func, args), rt 52 | Some _ -> raise (Error (Printf.sprintf "'%s' is not a function" c.func, 53 c.pos)) 54 | None -> raise (Error (Printf.sprintf "undefined function '%s'" c.func, 55 c.pos)) 56 57 let rec analyze_instr instr env = 58 match instr with 59 | Syntax.Assign a -> 60 let ae, et = analyze_expr a.expr env in 61 let t = match Env.find_opt a.var env with 62 | Some t -> t 63 | None -> raise (Error (Printf.sprintf "var %s does not exist" a.var, a.pos)) in 64 if (string_of_type_t t) = (string_of_type_t et) then 65 Assign (a.var, ae), Env.add a.var et env 66 else 67 raise (Error (Printf.sprintf "var %s is of type %s" a.var (string_of_type_t t), a.pos)) 68 | Syntax.Return r -> 69 let ae, _ = analyze_expr r.expr env in 70 Return ae, env 71 | Syntax.Decl d -> 72 if Env.mem d.var env then 73 raise (Error (Printf.sprintf "var %s already declared" d.var, d.pos)) 74 else 75 Decl d.var, Env.add d.var d.type_ env 76 | Syntax.Expr e -> 77 let ae, t = analyze_expr e.expr env in 78 Expr ae, env 79 | Syntax.Cond e -> 80 let ae, t = analyze_expr e.expr env in 81 let b1, nenv = analyze_block e.b1 env in 82 let b2, nenv' = analyze_block e.b2 nenv in 83 Cond (ae, b1, b2), nenv' 84 | Syntax.Loop l -> 85 let ae, t = analyze_expr l.expr env in 86 let b1, nenv = analyze_block l.b env in 87 Loop (ae, b1), nenv 88 89 and analyze_block block env = 90 match block with 91 | [] -> [], env 92 | instr :: rest -> 93 let ai, new_env = analyze_instr instr env in 94 let ab, nenv = analyze_block rest new_env in 95 ai :: ab, nenv 96 97 let rec push_arg_in_env arg env = 98 match arg with 99 | [] -> env 100 | (type_, ident) :: cdr -> 101 push_arg_in_env cdr (Env.add ident type_ env) 102 103 let analyze_def def env = 104 match def with 105 | Syntax.Func f -> 106 if Env.mem f.name env then 107 raise (Error (Printf.sprintf "func %s already declared" f.name, f.pos)) 108 else 109 let types, names = List.split f.args in 110 let l, nenv = analyze_block f.body (push_arg_in_env f.args env) in 111 Func (f.name, names, l), Env.add f.name (Func_t (f.ftype, types)) env (* env is the initial, nenv is the func scope *) 112 113 let rec analyze_prog prog env = 114 match prog with 115 | [] -> [], env 116 | d :: r -> 117 let f, nenv = analyze_def d env in 118 let l, nenv' = analyze_prog r nenv in 119 f :: l, nenv' 120 121 let analyze parsed = 122 let l, env = analyze_prog parsed Baselib._types_ in 123 (* Env.iter print_env env; *) 124 l