open Code type 'a procedure = Frame.frame * 'a type 'a program = { number_of_globals : int; main : 'a procedure; procedures : 'a procedure list } exception Internal_error exception Relop of string type access = Local of Gen.temp | Global of int let trans_binop = function | Pp.Plus -> Plus | Pp.Minus -> Minus | Pp.Times -> Times | Pp.Div -> Div | Pp.Lt -> Lt | Pp.Le -> Le | Pp.Gt -> Gt | Pp.Ge -> Ge | Pp.Eq -> Eq | Pp.Ne -> Ne ;; let rec trans_expr env = function | Pp.Bin (op, e1, e2) -> Code.Bin (trans_binop op, trans_expr env e1, trans_expr env e2) | Pp.Int n -> Const n | Pp.Bool true -> Const 1 | Pp.Bool false -> Const 0 | Pp.Get x -> trans_get (Env.find_var env x) | Pp.Function_call (f, args) -> trans_call env f args | Pp.Geti (e1,e2) -> Mem (array_address env e1 e2) | Pp.Alloc (e, t) -> Call (Frame.alloc, [trans_expr env e]) and trans_stm env = function | Pp.Set (x,e) -> trans_set (trans_expr env e) (Env.find_var env x); | Pp.Sequence code -> Seq (List.map (trans_stm env) code) | Pp.Write_int e1 -> Exp (Call (Frame.write_int, [trans_expr env e1])) | Pp.Writeln_int e1 -> Exp (Call (Frame.writeln_int, [trans_expr env e1])) | Pp.Read_int s -> trans_set (Call (Frame.read_int, [])) (Env.find_var env s) | Pp.While (e, i) -> let loop = Gen.new_label() and continue = Gen.new_label() and endwhile = Gen.new_label() in let (cmp, c1, c2) = trans_test env e in Seq [ Label loop; Cjump (cmp, c1, c2, continue, endwhile); Label continue; trans_stm env i; Jump loop; Label endwhile; ] | Pp.If (e, i1, i2) -> let iftrue = Gen.new_label() and iffalse = Gen.new_label() and endif = Gen.new_label() in let (cmp, c1,c2) = trans_test env e in Seq [ Cjump (cmp, c1, c2, iftrue, iffalse); Label iftrue; trans_stm env i1; Jump endif; Label iffalse; trans_stm env i2; Label endif; ] | Pp.Procedure_call (f, args) -> Exp (trans_call env f args) | Pp.Seti (e1, e2, e3) -> Move_mem (array_address env e1 e2, trans_expr env e3) and trans_test env = function | Pp.Bin (c, e1, e2) -> let relop = match c with | Pp.Lt -> Rlt | Pp.Gt -> Rgt | Pp.Le -> Rle | Pp.Ge -> Rge | Pp.Eq -> Req | Pp.Ne -> Rne | Pp.Plus -> raise (Relop "+") | Pp.Minus -> raise (Relop "-") | Pp.Times -> raise (Relop "*") | Pp.Div -> raise (Relop "/") in (relop, trans_expr env e1, trans_expr env e2) | e -> (Rne, Const 0, trans_expr env e) and global i = Bin (Plus, Name Frame.global_space, Const (i * Frame.wordsize)) and trans_get = function | Local t -> Temp t | Global i -> Mem (global i) and trans_set c = function | Local t -> Move_temp (t, c) | Global i -> Move_mem (global i, c) and array_address env e1 e2 = let v = trans_expr env e1 in let k = trans_expr env e2 in match k with Const 0 -> v | Const k -> Bin (Plus, v, Const (k * Frame.wordsize)) | _ -> Bin (Plus, v, Bin (Times, k, Const Frame.wordsize)) and trans_call env f args = let g = Env.find_definition env f in let args_compilés = List.map (trans_expr env) args in Call (g, args_compilés) let trans_definition env (nom_de_g, source_de_g) (encore_le_nom_de_g, frame_de_g) = (* le nom de g apparaît deux fois, dans le source et dans l'environnment de compilation. Par construction, les deux sont identiques; on ignore le second. *) let env_args = try List.map2 (fun (variable, son_type) y -> variable, Local y) source_de_g.Pp.arguments (Frame.frame_args frame_de_g) with Invalid_argument s -> raise Internal_error (* par construction, les deux environnement sont de même domaine *) in let env_result = match Frame.frame_result frame_de_g with Some t -> [nom_de_g, Local t] | _ -> [] in let env_local = List.map (fun (variable, son_type) -> variable, Local (Gen.new_temp())) source_de_g.Pp.local_vars in let new_env = Env.add_local_vars env (List.concat [env_args; env_result; env_local]) in frame_de_g, [ Label (Frame.frame_name frame_de_g); trans_stm new_env source_de_g.Pp.body; Jump (Frame.frame_return frame_de_g) ] ;; let mapi f l = Array.to_list (Array.mapi f (Array.of_list l));; (* "mapi f [a1; a2; ... ak]" retourne "[f 1 a1; f 2 a2; ...; f k ak]" *) let trans_program p = let var_env = mapi (fun i (s, ty) -> s, Global i) p.Pp.global_vars in (* table des accès pour les variables globales *) let make_definition_frame (nom_de_g, g) = let frame_de_g = Frame.named_frame nom_de_g g.Pp.arguments g.Pp.result in nom_de_g, frame_de_g in let definition_env = List.map make_definition_frame p.Pp.definitions in (* on fabrique la table des fonctions et procédures *) let env = Env.create_global var_env definition_env in (* l'environnement global *) let main = (* on traite la procédure principale comme une fonction *) ("main", { Pp.arguments = []; Pp.result = None; Pp.local_vars = []; Pp.body = p.Pp.main; }) in { number_of_globals = List.length p.Pp.global_vars; main = trans_definition env main (make_definition_frame main); procedures = try List.map2 (trans_definition env) p.Pp.definitions definition_env with Invalid_argument s -> raise Internal_error (* Par construction, les deux environnements sont par construction de même domaine *) } ;; let program p = try trans_program p with | Env.Free s -> Printf.fprintf stderr "Program incorrect:\n\ la variable %s est libre" s; prerr_newline(); exit 1 | Relop s -> Printf.fprintf stderr "Program incorrect:\n\ opération entière %s utilisée comme une relation" s; prerr_newline(); exit 1 | Internal_error -> Printf.fprintf stderr "Internal error"; prerr_newline(); exit 2 ;;