diff --git a/compiler/global/signature.ml b/compiler/global/signature.ml index be57d6f..3cc3563 100644 --- a/compiler/global/signature.ml +++ b/compiler/global/signature.ml @@ -18,6 +18,7 @@ let interface_format_version = "8" (** Node argument *) type arg = { a_name : name option; a_type : ty } +(** Node static parameters *) type param = { p_name : name; p_type : ty } (** Node signature *) @@ -45,8 +46,8 @@ let mk_param name ty = { p_name = name; p_type = ty } let mk_field n ty = { f_name = n; f_type = ty } -let print_param ff p = Names.print_name ff p.p_name - +let print_param ff p = + fprintf ff "%a:%a" Names.print_name p.p_name print_type p.p_type let rec field_assoc f = function | [] -> raise Not_found diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 534b999..96434f2 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -55,24 +55,32 @@ let apply_int_op op n1 n2 = let rec simplify env se = match se with | Sint _ | Sfloat _ | Sbool _ | Sconstructor -> se - | Svar id -> (try simplify env (NamesEnv.find id env) with | _ -> Svar id) + | Svar id -> (try simplify env (NamesEnv.find id env) with | _ -> se) | Sop (op, [e1; e2]) -> - (match simplify env e1, simplify env e2 with - | Sint n1, Sint n2 -> apply_int_op op n1 n2 - | e1, e2 -> Sop (op, [e1; e2]) + let e1 = simplify env e1 in + let e2 = simplify env e2 in + (match e1.e_desc, e2.e_desc with + | Sint n1, Sint n2 -> { se with se_desc = apply_int_op op n1 n2 } + | _, _ -> { se with se_desc = Sop (op, [e1; e2]) } ) - | Sop (op, se_list) -> Sop (op, List.map (simplify env) se_list) - | Sarray se_list -> Sarray (List.map (simplify env) se_list) - | Sarray_power (se, n) -> Sarray_power (simplify env se, simplify env n) - | Stuple se_list -> Stuple (List.map (simplify env) se_list) + | Sop (op, se_list) -> + { se with se_desc = Sop (op, List.map (simplify env) se_list) } + | Sarray se_list -> + { se with se_desc = Sarray (List.map (simplify env) se_list) } + | Sarray_power (se, n) -> + { se with se_desc = Sarray_power (simplify env se, simplify env n) } + | Stuple se_list -> + { se with se_desc = Stuple (List.map (simplify env) se_list) } | Srecord f_se_list -> - Srecord (List.map (fun (f,se) -> f, simplify env se) f_se_list) + { se with se_desc = Srecord + (List.map (fun (f,se) -> f, simplify env se) f_se_list) } (** [int_of_static_exp env e] returns the value of the expression [e] in the environment [env], mapping vars to integers. Raises Instanciation_failed if it cannot be computed (if a var has no value).*) let int_of_static_exp env e = - match simplify env e with | Sint n -> n | _ -> raise Instanciation_failed + let e = simplify env e in + match e.e_desc with | Sint n -> n | _ -> raise Instanciation_failed (** [is_true env constr] returns whether the constraint is satisfied in the environment (or None if this can be decided) @@ -85,15 +93,15 @@ let is_true env = let e1 = simplify env e1 in let e2 = simplify env e2 in - (match e1, e2 with - | SConst n1, SConst n2 -> Some (n1 = n2), Cequal (e1, e2) + (match e1.e_desc, e2.e_desc with + | Sint n1, Sint n2 -> Some (n1 = n2), Cequal (e1, e2) | (_, _) -> None, Cequal (e1, e2)) | Clequal (e1, e2) -> let e1 = simplify env e1 in let e2 = simplify env e2 in - (match e1, e2 with - | SConst n1, SConst n2 -> Some (n1 <= n2), Clequal (e1, e2) + (match e1.e_desc, e2.e_desc with + | Sint n1, Sint n2 -> Some (n1 <= n2), Clequal (e1, e2) | _, _ -> None, Clequal (e1, e2)) | Cfalse -> None, Cfalse @@ -115,16 +123,19 @@ let rec solve const_env = (** Substitutes variables in the size exp with their value in the map (mapping vars to size exps). *) -let rec static_exp_subst m = function - | Svar n -> (try List.assoc n m with | Not_found -> Svar n) - | Sop (op, se_list) -> Sop (op, List.map (static_exp_subst m) se_list) - | Sarray_power (se, n) -> Sarray_power (static_exp_subst m se, - static_exp_subst m n) - | Sarray se_list -> Sarray (List.map (static_exp_subst env) se_list) - | Stuple se_list -> Stuple (List.map (static_exp_subst env) se_list) - | Srecord f_se_list -> - Srecord (List.map (fun (f,se) -> f, static_exp_subst env se) f_se_list) - | s -> s +let rec static_exp_subst m se = + let desc = match se.e_desc with + | Svar n -> (try List.assoc n m with | Not_found -> Svar n) + | Sop (op, se_list) -> Sop (op, List.map (static_exp_subst m) se_list) + | Sarray_power (se, n) -> Sarray_power (static_exp_subst m se, + static_exp_subst m n) + | Sarray se_list -> Sarray (List.map (static_exp_subst env) se_list) + | Stuple se_list -> Stuple (List.map (static_exp_subst env) se_list) + | Srecord f_se_list -> + Srecord (List.map (fun (f,se) -> f, static_exp_subst env se) f_se_list) + | s -> s + in + { se with se_desc = desc } (** Substitutes variables in the constraint list with their value in the map (mapping vars to size exps). *) @@ -135,7 +146,7 @@ let instanciate_constr m constr = | Cfalse -> Cfalse in List.map (replace_one m) constr -let rec print_static_exp ff = function +let rec print_static_exp ff se = match se.e_desc with | Sint i -> fprintf ff "%d" i | Sbool b -> fprintf ff "%b" b | Sfloat f -> fprintf ff "%f" f diff --git a/compiler/global/types.ml b/compiler/global/types.ml index 9f1237f..2442292 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -10,8 +10,6 @@ open Names open Location -type ty = | Tprod of ty list | Tid of longname | Tarray of ty * static_exp - type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location } and static_exp_desc = @@ -26,6 +24,8 @@ and static_exp_desc = | Srecord of (longname * static_exp) list (** { f1 = e1; f2 = e2; ... } *) | Sop of longname * static_exp list (** defined ops for now in pervasives *) +type ty = | Tprod of ty list | Tid of longname | Tarray of ty * static_exp + let invalid_type = Tprod [] let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) =