158 lines
4.5 KiB
OCaml
158 lines
4.5 KiB
OCaml
open Ast
|
|
open Ast.IR
|
|
open Baselib
|
|
|
|
exception Error of string * Lexing.position
|
|
|
|
(* fonctions d'aide à la gestion des erreurs *)
|
|
|
|
let expr_pos expr =
|
|
match expr with
|
|
| Syntax.Int n -> n.pos
|
|
| Syntax.Float n -> n.pos
|
|
| Syntax.Char c -> c.pos
|
|
| Syntax.Str s -> s.pos
|
|
| Syntax.Bool b -> b.pos
|
|
| Syntax.Var v -> v.pos
|
|
| Syntax.Call c -> c.pos
|
|
;;
|
|
|
|
let errt expected given pos =
|
|
raise
|
|
(Error
|
|
( Printf.sprintf
|
|
"expected %s but given %s"
|
|
(string_of_type_t expected)
|
|
(string_of_type_t given)
|
|
, pos ))
|
|
;;
|
|
|
|
(* analyse sémantique *)
|
|
|
|
let rec analyze_expr expr env =
|
|
match expr with
|
|
| Syntax.Int n -> Int n.value, Int_t
|
|
| Syntax.Float n -> Float n.value, Float_t (* TODO: Should be Float_t *)
|
|
| Syntax.Char c -> Char c.value.[0], Char_t
|
|
| Syntax.Str s -> Str s.value, Str_t
|
|
| Syntax.Bool b -> Bool b.value, Bool_t
|
|
| Syntax.Var va ->
|
|
(match Env.find_opt va.name env with
|
|
| Some v -> Var va.name, v
|
|
| _ -> raise (Error (Printf.sprintf "unbound variable '%s'" va.name, va.pos)))
|
|
| Syntax.Call c ->
|
|
(match Env.find_opt c.func env with
|
|
| Some (Func_t (rt, at)) ->
|
|
if List.length at != List.length c.args
|
|
then
|
|
raise
|
|
(Error
|
|
( Printf.sprintf
|
|
"expected %d arguments but given %d"
|
|
(List.length at)
|
|
(List.length c.args)
|
|
, c.pos ));
|
|
let args =
|
|
List.map2
|
|
(fun eat a ->
|
|
let aa, at = analyze_expr a env in
|
|
if at = eat then aa else errt eat at (expr_pos a))
|
|
at
|
|
c.args
|
|
in
|
|
Call (c.func, args), rt
|
|
| Some _ -> raise (Error (Printf.sprintf "'%s' is not a function" c.func, c.pos))
|
|
| None -> raise (Error (Printf.sprintf "undefined function '%s'" c.func, c.pos)))
|
|
;;
|
|
|
|
let rec analyze_instr instr env =
|
|
match instr with
|
|
| Syntax.Assign a ->
|
|
let t =
|
|
match Env.find_opt a.var env with
|
|
| Some ty -> ty
|
|
| _ -> raise (Error (Printf.sprintf "undeclared variable '%s'" a.var, a.pos))
|
|
in
|
|
let ae, et = analyze_expr a.expr env in
|
|
if t = et
|
|
then Assign (a.var, ae), Env.add a.var et env
|
|
else
|
|
raise
|
|
(Error
|
|
( Printf.sprintf
|
|
"changing type of variable '%s' %s -> %s"
|
|
a.var
|
|
(string_of_type_t t)
|
|
(string_of_type_t et)
|
|
, a.pos ))
|
|
| Syntax.Decl d ->
|
|
if Env.mem d.var env
|
|
then raise (Error (Printf.sprintf "redefinition of '%s'" d.var, d.pos))
|
|
else Decl d.var, Env.add d.var d.typ env
|
|
| Syntax.Expr e ->
|
|
let ae, t = analyze_expr e.expr env in
|
|
Expr ae, env
|
|
| Syntax.Return r ->
|
|
let ae, _ = analyze_expr r.expr env in
|
|
Return ae, env
|
|
| Syntax.Cond c ->
|
|
let ae, et = analyze_expr c.expr env in
|
|
if et <> Int_t && et <> Bool_t
|
|
then raise (Error (Printf.sprintf "not a boolean expression", c.pos))
|
|
else (
|
|
let abt, nenv = analyze_block c.blockt env in
|
|
let abf, new_env = analyze_block c.blockf nenv in
|
|
Cond (ae, abt, abf), new_env)
|
|
| Syntax.Loop l ->
|
|
let ae, et = analyze_expr l.expr env in
|
|
if et <> Int_t && et <> Bool_t
|
|
then raise (Error (Printf.sprintf "not a boolean expression", l.pos))
|
|
else (
|
|
let ab, nenv = analyze_block l.block env in
|
|
Loop (ae, ab), nenv)
|
|
|
|
and analyze_block block env =
|
|
match block with
|
|
| [] -> [], env
|
|
| instr :: rest ->
|
|
let ai, new_env = analyze_instr instr env in
|
|
let ab, nenv = analyze_block rest new_env in
|
|
ai :: ab, nenv
|
|
;;
|
|
|
|
let rec add_arg_env args env =
|
|
match args with
|
|
| [] -> env
|
|
| (ty, arg) :: rest -> add_arg_env rest (Env.add arg ty env)
|
|
;;
|
|
|
|
let rec analyze_def def env =
|
|
match def with
|
|
| Syntax.Func f ->
|
|
if Env.mem f.name env
|
|
then raise (Error (Printf.sprintf "redefinition of function '%s'" f.name, f.pos))
|
|
else (
|
|
let at, args = List.split f.args in
|
|
let nenv = add_arg_env f.args (Env.add f.name (Func_t (f.typ, at)) env) in
|
|
let b, new_env = analyze_block f.block nenv in
|
|
Func (f.name, args, b), Env.add f.name (Func_t (f.typ, at)) env)
|
|
;;
|
|
|
|
let print_env key v = print_endline (key ^ " " ^ string_of_type_t v)
|
|
|
|
let rec analyze_prog defs env =
|
|
match defs with
|
|
| [] -> [], env
|
|
| def :: rest ->
|
|
let ad, new_env = analyze_def def env in
|
|
let ap, nenv = analyze_prog rest new_env in
|
|
ad :: ap, nenv
|
|
;;
|
|
|
|
let analyze parsed =
|
|
let a, env = analyze_prog parsed Baselib._baselib_ in
|
|
(* Env.iter print_env env; *)
|
|
(* print_endline ("a" ^ " " ^ (string_of_type_t (Env.find "a" env))); *)
|
|
a
|
|
;;
|