CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-20 00:41:05 +03:00
Code Issues Projects Releases Wiki Activity

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2023-08-16 00:04:45 +02:00
parent c58e76f4e5
commit 72882f82df
43 changed files with 974 additions and 880 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build_system/clerk_driver.ml
View File

@ -173,7 +173,6 @@ let readdir_sort (dirname : string) : string array =
dirs dirs
with Sys_error _ -> [||] with Sys_error _ -> [||]
(** Given a file, looks in the relative [output] directory if there are files (** Given a file, looks in the relative [output] directory if there are files
with the same base name that contain expected outputs for different *) with the same base name that contain expected outputs for different *)
let search_for_expected_outputs (file : string) : expected_output_descr list = let search_for_expected_outputs (file : string) : expected_output_descr list =

12
build_system/clerk_runtest.ml
View File

@ -40,7 +40,7 @@ let checkfile parents file =
~pp_sep:(fun ppf () -> Format.fprintf ppf " %a@ " String.format "→") ~pp_sep:(fun ppf () -> Format.fprintf ppf " %a@ " String.format "→")
Format.pp_print_string) Format.pp_print_string)
(List.rev (file :: parents)); (List.rev (file :: parents));
(file :: parents), file file :: parents, file
let with_in_channel_safe parents file f = let with_in_channel_safe parents file f =
try File.with_in_channel file f try File.with_in_channel file f
@ -186,9 +186,9 @@ let run_inline_tests
| [] -> Message.emit_warning "No inline tests found in %s" file | [] -> Message.emit_warning "No inline tests found in %s" file
| file_tests -> | file_tests ->
Message.emit_debug "@[<v 2>Running tests:@ %a@]" Message.emit_debug "@[<v 2>Running tests:@ %a@]"
(Format.pp_print_list (Format.pp_print_list (fun ppf t ->
(fun ppf t -> Format.fprintf ppf "- @[<hov>%s:@ %d tests@]" Format.fprintf ppf "- @[<hov>%s:@ %d tests@]" t.filename
t.filename (List.length t.tests))) (List.length t.tests)))
file_tests; file_tests;
let run test oc = let run test oc =
List.iter List.iter
@ -214,7 +214,8 @@ let run_inline_tests
let pid = let pid =
let cwd = Unix.getcwd () in let cwd = Unix.getcwd () in
Unix.chdir file_dir; Unix.chdir file_dir;
Fun.protect ~finally:(fun () -> Unix.chdir cwd) @@ fun () -> Fun.protect ~finally:(fun () -> Unix.chdir cwd)
@@ fun () ->
Unix.create_process_env catala_exe cmd env Unix.stdin cmd_out_wr Unix.create_process_env catala_exe cmd env Unix.stdin cmd_out_wr
cmd_out_wr cmd_out_wr
in in
@ -256,4 +257,3 @@ let run_inline_tests
Sys.rename out test.filename) Sys.rename out test.filename)
else run test stdout) else run test stdout)
file_tests file_tests

14
build_system/clerk_runtest.mli
View File

@ -14,10 +14,18 @@
License for the specific language governing permissions and limitations under License for the specific language governing permissions and limitations under
the License. *) the License. *)
(** This module contains specific commands used to detect and run inline tests in Catala files. The functionality is built into the `clerk runtest` subcommand, but is separate from the normal Clerk behaviour: Clerk drives Ninja, which in turn might need to evaluate tests as part of some rules and can run `clerk runtest` in a reentrant way. *) (** This module contains specific commands used to detect and run inline tests
in Catala files. The functionality is built into the `clerk runtest`
subcommand, but is separate from the normal Clerk behaviour: Clerk drives
Ninja, which in turn might need to evaluate tests as part of some rules and
can run `clerk runtest` in a reentrant way. *)
val has_inline_tests : string -> bool val has_inline_tests : string -> bool
(** Checks if the given named file contains inline tests (either directly or through includes) *) (** Checks if the given named file contains inline tests (either directly or
through includes) *)
val run_inline_tests : reset:bool -> string -> string -> string list -> unit val run_inline_tests : reset:bool -> string -> string -> string list -> unit
(** [run_inline_tests ~reset file catala_exe catala_opts] runs the tests in Catala [file] using the given path to the Catala executable and the provided options. Output is printed to [stdout] if [reset] is false, otherwise [file] is replaced with the updated test results. *) (** [run_inline_tests ~reset file catala_exe catala_opts] runs the tests in
Catala [file] using the given path to the Catala executable and the provided
options. Output is printed to [stdout] if [reset] is false, otherwise [file]
is replaced with the updated test results. *)

9
compiler/catala_utils/map.ml
View File

@ -33,7 +33,6 @@ module type S = sig
(* Slightly more informative [Not_found] exception *) (* Slightly more informative [Not_found] exception *)
val find : key -> 'a t -> 'a val find : key -> 'a t -> 'a
val keys : 'a t -> key list val keys : 'a t -> key list
val values : 'a t -> 'a list val values : 'a t -> 'a list
val of_list : (key * 'a) list -> 'a t val of_list : (key * 'a) list -> 'a t
@ -70,7 +69,6 @@ module type S = sig
unit unit
(** Formats all bindings of the map in order using the given separator (** Formats all bindings of the map in order using the given separator
(default ["; "]) and binding indicator (default [" = "]). *) (default ["; "]) and binding indicator (default [" = "]). *)
end end
module Make (Ord : OrderedType) : S with type key = Ord.t = struct module Make (Ord : OrderedType) : S with type key = Ord.t = struct
@ -79,14 +77,13 @@ module Make (Ord : OrderedType) : S with type key = Ord.t = struct
exception Not_found of key exception Not_found of key
let () = let () =
Printexc.register_printer @@ function Printexc.register_printer
@@ function
| Not_found k -> | Not_found k ->
Some (Format.asprintf "key '%a' not found in map" Ord.format k) Some (Format.asprintf "key '%a' not found in map" Ord.format k)
| _ -> None | _ -> None
let find k t = let find k t = try find k t with Stdlib.Not_found -> raise (Not_found k)
try find k t with Stdlib.Not_found -> raise (Not_found k)
let keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev let keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev
let values t = fold (fun _ v acc -> v :: acc) t [] |> List.rev let values t = fold (fun _ v acc -> v :: acc) t [] |> List.rev
let of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l let of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l

193
compiler/dcalc/from_scopelang.ml
View File

@ -35,7 +35,8 @@ type 'm scope_ref =
type 'm scope_sig_ctx = { type 'm scope_sig_ctx = {
scope_sig_local_vars : scope_var_ctx list; (** List of scope variables *) scope_sig_local_vars : scope_var_ctx list; (** List of scope variables *)
scope_sig_scope_ref : 'm scope_ref; (** Var or external representing the scope *) scope_sig_scope_ref : 'm scope_ref;
(** Var or external representing the scope *)
scope_sig_input_struct : StructName.t; (** Scope input *) scope_sig_input_struct : StructName.t; (** Scope input *)
scope_sig_output_struct : StructName.t; (** Scope output *) scope_sig_output_struct : StructName.t; (** Scope output *)
scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t; scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t;
@ -75,11 +76,12 @@ let pos_mark_mk (type a m) (e : (a, m) gexpr) :
let rec module_scope_sig scope_sig_ctx path scope = let rec module_scope_sig scope_sig_ctx path scope =
match path with match path with
| [] -> ScopeName.Map.find scope scope_sig_ctx.scope_sigs | [] -> ScopeName.Map.find scope scope_sig_ctx.scope_sigs
| (modname, mpos) :: path -> | (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname scope_sig_ctx.scope_sigs_modules with match ModuleName.Map.find_opt modname scope_sig_ctx.scope_sigs_modules with
| None -> | None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
| Some sig_ctx -> module_scope_sig sig_ctx path scope modname
| Some sig_ctx -> module_scope_sig sig_ctx path scope)
let merge_defaults let merge_defaults
~(is_func : bool) ~(is_func : bool)
@ -223,7 +225,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Message.raise_spanned_error (Expr.pos e) Message.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a%a is missing from this pattern \ "The constructor %a of enum %a%a is missing from this pattern \
matching" matching"
EnumConstructor.format constructor Print.path path EnumName.format name EnumConstructor.format constructor Print.path path
EnumName.format name
in in
let case_d = translate_expr ctx case_e in let case_d = translate_expr ctx case_e in
( EnumConstructor.Map.add constructor case_d d_cases, ( EnumConstructor.Map.add constructor case_d d_cases,
@ -234,8 +237,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
if not (EnumConstructor.Map.is_empty remaining_e_cases) then if not (EnumConstructor.Map.is_empty remaining_e_cases) then
Message.raise_spanned_error (Expr.pos e) Message.raise_spanned_error (Expr.pos e)
"Pattern matching is incomplete for enum %a%a: missing cases %a" "Pattern matching is incomplete for enum %a%a: missing cases %a"
Print.path path Print.path path EnumName.format name
EnumName.format name
(EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () -> (EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () ->
Format.fprintf fmt ", ")) Format.fprintf fmt ", "))
remaining_e_cases; remaining_e_cases;
@ -243,9 +245,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Expr.ematch ~e:e1 ~name ~cases:d_cases m Expr.ematch ~e:e1 ~name ~cases:d_cases m
| EScopeCall { path; scope; args } -> | EScopeCall { path; scope; args } ->
let pos = Expr.mark_pos m in let pos = Expr.mark_pos m in
let sc_sig = let sc_sig = module_scope_sig ctx.scopes_parameters path scope in
module_scope_sig ctx.scopes_parameters path scope
in
let in_var_map = let in_var_map =
ScopeVar.Map.merge ScopeVar.Map.merge
(fun var_name (str_field : scope_input_var_ctx option) expr -> (fun var_name (str_field : scope_input_var_ctx option) expr ->
@ -292,18 +292,20 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
in_var_map StructField.Map.empty in_var_map StructField.Map.empty
in in
let arg_struct = let arg_struct =
Expr.estruct ~name:sc_sig.scope_sig_input_struct ~fields:field_map (mark_tany m pos) Expr.estruct ~name:sc_sig.scope_sig_input_struct ~fields:field_map
(mark_tany m pos)
in in
let called_func = let called_func =
let m = mark_tany m pos in let m = mark_tany m pos in
let e = match sc_sig.scope_sig_scope_ref with let e =
match sc_sig.scope_sig_scope_ref with
| Local_scope_ref v -> Expr.evar v m | Local_scope_ref v -> Expr.evar v m
| External_scope_ref (path, name) -> | External_scope_ref (path, name) ->
Expr.eexternal ~path ~name:(Mark.map (fun s -> External_scope s) name) m Expr.eexternal ~path
~name:(Mark.map (fun s -> External_scope s) name)
m
in in
tag_with_log_entry tag_with_log_entry e BeginCall
e
BeginCall
[ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"] [ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"]
in in
let single_arg = let single_arg =
@ -351,14 +353,17 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(struct_output.struct_output_function_field x) ... } *) (struct_output.struct_output_function_field x) ... } *)
let result_eta_expanded = let result_eta_expanded =
Expr.estruct ~name:sc_sig.scope_sig_output_struct Expr.estruct ~name:sc_sig.scope_sig_output_struct
~fields:(StructField.Map.mapi ~fields:
(StructField.Map.mapi
(fun field typ -> (fun field typ ->
let original_field_expr = let original_field_expr =
Expr.estructaccess Expr.estructaccess
~e:(Expr.make_var result_var ~e:
(Expr.make_var result_var
(Expr.with_ty m (Expr.with_ty m
(TStruct sc_sig.scope_sig_output_struct, Expr.pos e))) (TStruct sc_sig.scope_sig_output_struct, Expr.pos e)))
~field ~name:sc_sig.scope_sig_output_struct (Expr.with_ty m typ) ~field ~name:sc_sig.scope_sig_output_struct
(Expr.with_ty m typ)
in in
match Mark.remove typ with match Mark.remove typ with
| TArrow (ts_in, t_out) -> | TArrow (ts_in, t_out) ->
@ -382,7 +387,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(ListLabels.mapi (List.combine params_vars ts_in) (ListLabels.mapi (List.combine params_vars ts_in)
~f:(fun i (param_var, t_in) -> ~f:(fun i (param_var, t_in) ->
tag_with_log_entry tag_with_log_entry
(Expr.make_var param_var (Expr.with_ty m t_in)) (Expr.make_var param_var
(Expr.with_ty m t_in))
(VarDef (VarDef
{ {
log_typ = Mark.remove t_in; log_typ = Mark.remove t_in;
@ -405,7 +411,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
EndCall f_markings) EndCall f_markings)
ts_in (Expr.pos e) ts_in (Expr.pos e)
| _ -> original_field_expr) | _ -> original_field_expr)
(snd (StructName.Map.find sc_sig.scope_sig_output_struct ctx.decl_ctx.ctx_structs))) (snd
(StructName.Map.find sc_sig.scope_sig_output_struct
ctx.decl_ctx.ctx_structs)))
(Expr.with_ty m (TStruct sc_sig.scope_sig_output_struct, Expr.pos e)) (Expr.with_ty m (TStruct sc_sig.scope_sig_output_struct, Expr.pos e))
in in
(* Here we have to go through an if statement that records a decision being (* Here we have to go through an if statement that records a decision being
@ -457,9 +465,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
match ctx.scope_name, Mark.remove f with match ctx.scope_name, Mark.remove f with
| Some sname, ELocation loc -> ( | Some sname, ELocation loc -> (
match loc with match loc with
| ScopelangScopeVar { name = (v, _); _ } -> | ScopelangScopeVar { name = v, _; _ } ->
[ScopeName.get_info sname; ScopeVar.get_info v] [ScopeName.get_info sname; ScopeVar.get_info v]
| SubScopeVar {scope; var = (v, _); _} -> | SubScopeVar { scope; var = v, _; _ } ->
[ScopeName.get_info scope; ScopeVar.get_info v] [ScopeName.get_info scope; ScopeVar.get_info v]
| ToplevelVar _ -> []) | ToplevelVar _ -> [])
| _ -> [] | _ -> []
@ -572,9 +580,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
| EOp { op = Add_dat_dur _; tys } -> | EOp { op = Add_dat_dur _; tys } ->
Expr.eop (Add_dat_dur ctx.date_rounding) tys m Expr.eop (Add_dat_dur ctx.date_rounding) tys m
| EOp { op; tys } -> Expr.eop (Operator.translate op) tys m | EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
| ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
| ETuple _ | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _
| EArray _ | EIfThenElse _ ) as e -> | EIfThenElse _ ) as e ->
Expr.map ~f:(translate_expr ctx) (e, m) Expr.map ~f:(translate_expr ctx) (e, m)
(** The result of a rule translation is a list of assignment, with variables and (** The result of a rule translation is a list of assignment, with variables and
@ -781,9 +789,7 @@ let translate_rule
all_subscope_output_vars all_subscope_output_vars
in in
let subscope_func = let subscope_func =
tag_with_log_entry tag_with_log_entry scope_dcalc_ref BeginCall
scope_dcalc_ref
BeginCall
[ [
sigma_name, pos_sigma; sigma_name, pos_sigma;
SubScopeName.get_info subindex; SubScopeName.get_info subindex;
@ -896,15 +902,16 @@ let translate_rules
((fun next -> next), ctx) ((fun next -> next), ctx)
rules rules
in in
let scope_sig_decl = let scope_sig_decl = ScopeName.Map.find scope_name ctx.decl_ctx.ctx_scopes in
ScopeName.Map.find scope_name ctx.decl_ctx.ctx_scopes
in
let return_exp = let return_exp =
Expr.estruct ~name:scope_sig.scope_sig_output_struct Expr.estruct ~name:scope_sig.scope_sig_output_struct
~fields:(ScopeVar.Map.fold ~fields:
(ScopeVar.Map.fold
(fun var (dcalc_var, _, io) acc -> (fun var (dcalc_var, _, io) acc ->
if Mark.remove io.Desugared.Ast.io_output then if Mark.remove io.Desugared.Ast.io_output then
let field = ScopeVar.Map.find var scope_sig_decl.out_struct_fields in let field =
ScopeVar.Map.find var scope_sig_decl.out_struct_fields
in
StructField.Map.add field StructField.Map.add field
(Expr.make_var dcalc_var (mark_tany mark pos_sigma)) (Expr.make_var dcalc_var (mark_tany mark pos_sigma))
acc acc
@ -918,7 +925,8 @@ let translate_rules
(Expr.Box.lift return_exp)), (Expr.Box.lift return_exp)),
new_ctx ) new_ctx )
(* From a scope declaration and definitions, create the corresponding scope body wrapped in the appropriate call convention. *) (* From a scope declaration and definitions, create the corresponding scope body
wrapped in the appropriate call convention. *)
let translate_scope_decl let translate_scope_decl
(ctx : 'm ctx) (ctx : 'm ctx)
(scope_name : ScopeName.t) (scope_name : ScopeName.t)
@ -972,14 +980,16 @@ let translate_scope_decl
(* Find a witness of a mark in the definitions *) (* Find a witness of a mark in the definitions *)
match sigma.scope_decl_rules with match sigma.scope_decl_rules with
| [] -> | [] ->
(* Todo: are we sure this can't happen in normal code ? E.g. is calling a scope which only defines input variables already an error at this stage or not ? *) (* Todo: are we sure this can't happen in normal code ? E.g. is calling a
Message.raise_spanned_error pos_sigma "Scope %a has no content" ScopeName.format scope_name scope which only defines input variables already an error at this stage
or not ? *)
Message.raise_spanned_error pos_sigma "Scope %a has no content"
ScopeName.format scope_name
| (Definition (_, _, _, (_, m)) | Assertion (_, m) | Call (_, _, m)) :: _ -> | (Definition (_, _, _, (_, m)) | Assertion (_, m) | Call (_, _, m)) :: _ ->
m m
in in
let rules_with_return_expr, ctx = let rules_with_return_expr, ctx =
translate_rules ctx scope_name sigma.scope_decl_rules sigma_info translate_rules ctx scope_name sigma.scope_decl_rules sigma_info scope_mark
scope_mark
scope_sig scope_sig
in in
let scope_variables = let scope_variables =
@ -1034,8 +1044,7 @@ let translate_scope_decl
}) })
(Bindlib.bind_var v next) (Bindlib.bind_var v next)
(Expr.Box.lift (Expr.Box.lift
(Expr.make_var scope_input_var (Expr.make_var scope_input_var (mark_tany scope_mark pos_sigma))))
(mark_tany scope_mark pos_sigma))))
scope_input_variables next scope_input_variables next
in in
let scope_body = let scope_body =
@ -1062,8 +1071,7 @@ let translate_scope_decl
let new_struct_ctx = let new_struct_ctx =
StructName.Map.singleton scope_input_struct_name ([], field_map) StructName.Map.singleton scope_input_struct_name ([], field_map)
in in
( scope_body, scope_body, new_struct_ctx
new_struct_ctx )
let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
let defs_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in let defs_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in
@ -1073,28 +1081,42 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
in in
let decl_ctx = prgm.program_ctx in let decl_ctx = prgm.program_ctx in
Message.emit_debug "prog scopes: %a@ modules: %a" Message.emit_debug "prog scopes: %a@ modules: %a"
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space) prgm.program_scopes (ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space)
(ModuleName.Map.format prgm.program_scopes
(fun fmt prg -> ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt prg.Scopelang.Ast.program_scopes)) prgm.program_modules; (ModuleName.Map.format (fun fmt prg ->
ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt
prg.Scopelang.Ast.program_scopes))
prgm.program_modules;
let sctx : 'm scope_sigs_ctx = let sctx : 'm scope_sigs_ctx =
let process_scope_sig (scope_path, scope_name) scope = let process_scope_sig (scope_path, scope_name) scope =
Message.emit_debug "process_scope_sig %a%a (%a)" Message.emit_debug "process_scope_sig %a%a (%a)" Print.path scope_path
Print.path scope_path ScopeName.format scope_name ScopeName.format scope.Scopelang.Ast.scope_decl_name; ScopeName.format scope_name ScopeName.format
scope.Scopelang.Ast.scope_decl_name;
let scope_ref = let scope_ref =
match scope_path with match scope_path with
| [] -> | [] ->
let v = Var.make (Mark.remove (ScopeName.get_info scope_name)) in let v = Var.make (Mark.remove (ScopeName.get_info scope_name)) in
Local_scope_ref v Local_scope_ref v
| path -> | path ->
External_scope_ref (path, Mark.copy (ScopeName.get_info scope_name) scope_name) External_scope_ref
(path, Mark.copy (ScopeName.get_info scope_name) scope_name)
in in
let scope_info = let scope_info =
try try
ScopeName.Map.find scope_name (Program.module_ctx decl_ctx scope_path).ctx_scopes ScopeName.Map.find scope_name
with ScopeName.Map.Not_found _ -> Message.raise_spanned_error (Mark.get (ScopeName.get_info scope_name)) "Could not find scope %a%a" Print.path scope_path ScopeName.format scope_name (Program.module_ctx decl_ctx scope_path).ctx_scopes
with ScopeName.Map.Not_found _ ->
Message.raise_spanned_error
(Mark.get (ScopeName.get_info scope_name))
"Could not find scope %a%a" Print.path scope_path ScopeName.format
scope_name
in in
let scope_sig_in_fields = let scope_sig_in_fields =
(* Output fields have already been generated and added to the program ctx at this point, because they are visible to the user (manipulated as the return type of ScopeCalls) ; but input fields are used purely internally and need to be created here to implement the call convention for scopes. *) (* Output fields have already been generated and added to the program
ctx at this point, because they are visible to the user (manipulated
as the return type of ScopeCalls) ; but input fields are used purely
internally and need to be created here to implement the call
convention for scopes. *)
ScopeVar.Map.filter_map ScopeVar.Map.filter_map
(fun dvar (typ, vis) -> (fun dvar (typ, vis) ->
match Mark.remove vis.Desugared.Ast.io_input with match Mark.remove vis.Desugared.Ast.io_input with
@ -1127,48 +1149,64 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
} }
in in
let rec process_modules path prg = let rec process_modules path prg =
{ scope_sigs = {
scope_sigs =
ScopeName.Map.mapi ScopeName.Map.mapi
(fun scope_name (scope_decl, _) -> (fun scope_name (scope_decl, _) ->
process_scope_sig (path, scope_name) scope_decl) process_scope_sig (path, scope_name) scope_decl)
prg.Scopelang.Ast.program_scopes; prg.Scopelang.Ast.program_scopes;
scope_sigs_modules = scope_sigs_modules =
ModuleName.Map.mapi (fun modname prg -> ModuleName.Map.mapi
(fun modname prg ->
process_modules (path @ [modname, Pos.no_pos]) prg) process_modules (path @ [modname, Pos.no_pos]) prg)
prg.Scopelang.Ast.program_modules; prg.Scopelang.Ast.program_modules;
} }
in in
{ scope_sigs = {
scope_sigs =
ScopeName.Map.mapi ScopeName.Map.mapi
(fun scope_name (scope_decl, _) -> (fun scope_name (scope_decl, _) ->
process_scope_sig ([], scope_name) scope_decl) process_scope_sig ([], scope_name) scope_decl)
prgm.Scopelang.Ast.program_scopes; prgm.Scopelang.Ast.program_scopes;
scope_sigs_modules = scope_sigs_modules =
ModuleName.Map.mapi (fun modname prg -> ModuleName.Map.mapi
process_modules [modname, Pos.no_pos] prg) (fun modname prg -> process_modules [modname, Pos.no_pos] prg)
prgm.Scopelang.Ast.program_modules; prgm.Scopelang.Ast.program_modules;
} }
in in
let rec gather_module_in_structs acc path sctx = let rec gather_module_in_structs acc path sctx =
(* Expose all added in_structs from submodules at toplevel *) (* Expose all added in_structs from submodules at toplevel *)
ModuleName.Map.fold (fun modname scope_sigs acc -> ModuleName.Map.fold
(fun modname scope_sigs acc ->
let path = path @ [modname, Pos.no_pos] in let path = path @ [modname, Pos.no_pos] in
let acc = gather_module_in_structs acc path scope_sigs.scope_sigs_modules in let acc =
ScopeName.Map.fold (fun _ scope_sig_ctx acc -> gather_module_in_structs acc path scope_sigs.scope_sigs_modules
in
ScopeName.Map.fold
(fun _ scope_sig_ctx acc ->
let fields = let fields =
ScopeVar.Map.fold (fun _ sivc acc -> ScopeVar.Map.fold
let pos = Mark.get (StructField.get_info sivc.scope_input_name) in (fun _ sivc acc ->
StructField.Map.add sivc.scope_input_name (sivc.scope_input_typ, pos) acc) let pos =
Mark.get (StructField.get_info sivc.scope_input_name)
in
StructField.Map.add sivc.scope_input_name
(sivc.scope_input_typ, pos)
acc)
scope_sig_ctx.scope_sig_in_fields StructField.Map.empty scope_sig_ctx.scope_sig_in_fields StructField.Map.empty
in in
StructName.Map.add scope_sig_ctx.scope_sig_input_struct StructName.Map.add scope_sig_ctx.scope_sig_input_struct
(path, fields) acc) (path, fields) acc)
scope_sigs.scope_sigs acc scope_sigs.scope_sigs acc)
) sctx acc
sctx in
acc let decl_ctx =
{
decl_ctx with
ctx_structs =
gather_module_in_structs decl_ctx.ctx_structs [] sctx.scope_sigs_modules;
}
in in
let decl_ctx = { decl_ctx with ctx_structs = gather_module_in_structs decl_ctx.ctx_structs [] sctx.scope_sigs_modules } in
let top_ctx = let top_ctx =
let toplevel_vars = let toplevel_vars =
TopdefName.Map.mapi TopdefName.Map.mapi
@ -1208,19 +1246,23 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
translate_scope_decl ctx scope_name (Mark.remove scope) translate_scope_decl ctx scope_name (Mark.remove scope)
in in
let scope_var = let scope_var =
match (ScopeName.Map.find scope_name sctx.scope_sigs).scope_sig_scope_ref with match
(ScopeName.Map.find scope_name sctx.scope_sigs)
.scope_sig_scope_ref
with
| Local_scope_ref v -> v | Local_scope_ref v -> v
| External_scope_ref _ -> assert false | External_scope_ref _ -> assert false
in in
( { ( {
ctx with ctx with
decl_ctx = decl_ctx =
{ ctx.decl_ctx with {
ctx.decl_ctx with
ctx_structs = ctx_structs =
StructName.Map.union StructName.Map.union
(fun _ _ -> assert false) (fun _ _ -> assert false)
ctx.decl_ctx.ctx_structs scope_in_struct; ctx.decl_ctx.ctx_structs scope_in_struct;
} };
}, },
scope_var, scope_var,
Bindlib.box_apply Bindlib.box_apply
@ -1235,8 +1277,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
ctx ) ctx )
in in
let items, ctx = translate_defs top_ctx defs_ordering in let items, ctx = translate_defs top_ctx defs_ordering in
(* WIP TODO FIXME HERE: the scopes in submodules are not translated here it seems, and their input structs not added to decl_ctx (see From_surface:1476 for decl_ctx flattening info) *) (* WIP TODO FIXME HERE: the scopes in submodules are not translated here it
{ seems, and their input structs not added to decl_ctx (see From_surface:1476
code_items = Bindlib.unbox items; for decl_ctx flattening info) *)
decl_ctx = ctx.decl_ctx; { code_items = Bindlib.unbox items; decl_ctx = ctx.decl_ctx }
}

3
compiler/desugared/ast.ml
View File

@ -248,7 +248,8 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDef.Map.t =
(fun (loc, loc_pos) acc -> (fun (loc, loc_pos) acc ->
let usage = let usage =
match loc with match loc with
| DesugaredScopeVar { name; state } -> Some (ScopeDef.Var (Mark.remove name, state)) | DesugaredScopeVar { name; state } ->
Some (ScopeDef.Var (Mark.remove name, state))
| SubScopeVar { alias; var; _ } -> | SubScopeVar { alias; var; _ } ->
Some Some
(ScopeDef.SubScopeVar (ScopeDef.SubScopeVar

3
compiler/desugared/dependency.ml
View File

@ -261,7 +261,8 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
(fun used_var g -> (fun used_var g ->
let edge_from = let edge_from =
match Mark.remove used_var with match Mark.remove used_var with
| DesugaredScopeVar { name; state } -> Some (Vertex.Var (Mark.remove name, state)) | DesugaredScopeVar { name; state } ->
Some (Vertex.Var (Mark.remove name, state))
| SubScopeVar { alias; _ } -> | SubScopeVar { alias; _ } ->
Some (Vertex.SubScope (Mark.remove alias)) Some (Vertex.SubScope (Mark.remove alias))
| ToplevelVar _ -> None | ToplevelVar _ -> None

12
compiler/desugared/disambiguate.ml
View File

@ -86,16 +86,16 @@ let program prg =
env env
in in
let rec build_typing_env prg = let rec build_typing_env prg =
ModuleName.Map.fold (fun modname prg -> ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg)) Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules prg.program_modules (base_typing_env prg)
(base_typing_env prg)
in in
let env = let env =
ModuleName.Map.fold (fun modname prg -> ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg)) Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules prg.program_modules (base_typing_env prg)
(base_typing_env prg)
in in
let program_topdefs = let program_topdefs =
TopdefName.Map.map TopdefName.Map.map

200
compiler/desugared/from_surface.ml
View File

@ -168,13 +168,16 @@ let rec disambiguate_constructor
with EnumName.Map.Not_found _ -> with EnumName.Map.Not_found _ ->
Message.raise_spanned_error pos "Enum %s does not contain case %s" Message.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) (Mark.remove constructor)) (Mark.remove enum) (Mark.remove constructor))
| (modname, mpos)::path -> | (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctxt.modules with match ModuleName.Map.find_opt modname ctxt.modules with
| None -> | None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some ctxt -> | Some ctxt ->
let constructor = List.map (Mark.map (fun (_, c) -> path, c)) constructor0 in let constructor =
disambiguate_constructor ctxt constructor pos List.map (Mark.map (fun (_, c) -> path, c)) constructor0
in
disambiguate_constructor ctxt constructor pos)
let int100 = Runtime.integer_of_int 100 let int100 = Runtime.integer_of_int 100
let rat100 = Runtime.decimal_of_integer int100 let rat100 = Runtime.decimal_of_integer int100
@ -240,14 +243,14 @@ let rec translate_expr
[tau] pos [tau] pos
else else
let binding_var = Var.make (Mark.remove binding) in let binding_var = Var.make (Mark.remove binding) in
let local_vars = Ident.Map.add (Mark.remove binding) binding_var local_vars in let local_vars =
Ident.Map.add (Mark.remove binding) binding_var local_vars
in
let e2 = rec_helper ~local_vars e2 in let e2 = rec_helper ~local_vars e2 in
Expr.make_abs [| binding_var |] e2 [tau] pos) Expr.make_abs [| binding_var |] e2 [tau] pos)
(EnumName.Map.find enum_uid ctxt.enums) (EnumName.Map.find enum_uid ctxt.enums)
in in
Expr.ematch Expr.ematch ~e:(rec_helper e1_sub) ~name:enum_uid ~cases emark
~e:(rec_helper e1_sub)
~name:enum_uid ~cases emark
| Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) -> | Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) ->
check_formula op e1; check_formula op e1;
check_formula op e2; check_formula op e2;
@ -349,7 +352,8 @@ let rec translate_expr
with respect to the state that we are defining. *) with respect to the state that we are defining. *)
let rec find_prev_state = function let rec find_prev_state = function
| [] -> None | [] -> None
| st0 :: st1 :: _ when StateName.equal inside_def_state st1 -> | st0 :: st1 :: _ when StateName.equal inside_def_state st1
->
Some st0 Some st0
| _ :: states -> find_prev_state states | _ :: states -> find_prev_state states
in in
@ -358,7 +362,9 @@ let rec translate_expr
(* we take the last state in the chain *) (* we take the last state in the chain *)
Some (List.hd (List.rev states))) Some (List.hd (List.rev states)))
in in
Expr.elocation (DesugaredScopeVar { name = uid, pos; state = x_state }) emark Expr.elocation
(DesugaredScopeVar { name = uid, pos; state = x_state })
emark
| Some (SubScope _) | Some (SubScope _)
(* Note: allowing access to a global variable with the same name as a (* Note: allowing access to a global variable with the same name as a
subscope is disputable, but I see no good reason to forbid it either *) subscope is disputable, but I see no good reason to forbid it either *)
@ -366,21 +372,21 @@ let rec translate_expr
match Ident.Map.find_opt x ctxt.topdefs with match Ident.Map.find_opt x ctxt.topdefs with
| Some v -> | Some v ->
Expr.elocation Expr.elocation
(ToplevelVar { path = []; name = v, Mark.get (TopdefName.get_info v) }) (ToplevelVar
{ path = []; name = v, Mark.get (TopdefName.get_info v) })
emark emark
| None -> | None ->
Name_resolution.raise_unknown_identifier Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos)))) "for a local, scope-wide or global variable" (x, pos))))
| Ident (path, name) -> | Ident (path, name) -> (
let ctxt = Name_resolution.module_ctx ctxt path in let ctxt = Name_resolution.module_ctx ctxt path in
(match Ident.Map.find_opt (Mark.remove name) ctxt.topdefs with match Ident.Map.find_opt (Mark.remove name) ctxt.topdefs with
| Some v -> | Some v ->
Expr.elocation Expr.elocation
(ToplevelVar { path; name = v, Mark.get (TopdefName.get_info v) }) (ToplevelVar { path; name = v, Mark.get (TopdefName.get_info v) })
emark emark
| None -> | None ->
Name_resolution.raise_unknown_identifier Name_resolution.raise_unknown_identifier "for an external variable" name)
"for an external variable" name)
| Dotted (e, ((path, x), _ppos)) -> ( | Dotted (e, ((path, x), _ppos)) -> (
match path, Mark.remove e with match path, Mark.remove e with
| [], Ident ([], (y, _)) | [], Ident ([], (y, _))
@ -397,11 +403,12 @@ let rec translate_expr
Name_resolution.get_var_uid subscope_real_uid ctxt x Name_resolution.get_var_uid subscope_real_uid ctxt x
in in
Expr.elocation Expr.elocation
(SubScopeVar { (SubScopeVar
{
path = subscope_path; path = subscope_path;
scope = subscope_real_uid; scope = subscope_real_uid;
alias = (subscope_uid, pos); alias = subscope_uid, pos;
var = (subscope_var_uid, pos) var = subscope_var_uid, pos;
}) })
emark emark
| _ -> | _ ->
@ -409,17 +416,16 @@ let rec translate_expr
let e = rec_helper e in let e = rec_helper e in
let rec get_str ctxt = function let rec get_str ctxt = function
| [] -> None | [] -> None
| [c] -> | [c] -> Some (Name_resolution.get_struct ctxt c)
Some (Name_resolution.get_struct ctxt c) | (modname, mpos) :: path -> (
| (modname, mpos) :: path ->
match ModuleName.Map.find_opt modname ctxt.modules with match ModuleName.Map.find_opt modname ctxt.modules with
| None -> | None ->
Message.raise_spanned_error mpos Message.raise_spanned_error mpos "Module %a not found"
"Module %a not found" ModuleName.format modname ModuleName.format modname
| Some ctxt -> | Some ctxt -> get_str ctxt path)
get_str ctxt path
in in
Expr.edstructaccess ~e ~field:(Mark.remove x) ~name_opt:(get_str ctxt path) ~path emark) Expr.edstructaccess ~e ~field:(Mark.remove x)
~name_opt:(get_str ctxt path) ~path emark)
| FunCall (f, args) -> | FunCall (f, args) ->
Expr.eapp (rec_helper f) (List.map rec_helper args) emark Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall (((path, id), _), fields) -> | ScopeCall (((path, id), _), fields) ->
@ -467,11 +473,7 @@ let rec translate_expr
let local_vars = Ident.Map.add (Mark.remove x) v local_vars in let local_vars = Ident.Map.add (Mark.remove x) v local_vars in
let tau = TAny, Mark.get x in let tau = TAny, Mark.get x in
(* This type will be resolved in Scopelang.Desambiguation *) (* This type will be resolved in Scopelang.Desambiguation *)
let fn = let fn = Expr.make_abs [| v |] (rec_helper ~local_vars e2) [tau] pos in
Expr.make_abs [| v |]
(rec_helper ~local_vars e2)
[tau] pos
in
Expr.eapp fn [rec_helper e1] emark Expr.eapp fn [rec_helper e1] emark
| StructLit ((([], s_name), _), fields) -> | StructLit ((([], s_name), _), fields) ->
let s_uid = let s_uid =
@ -540,12 +542,14 @@ let rec translate_expr
let e_uid, c_uid = EnumName.Map.choose possible_c_uids in let e_uid, c_uid = EnumName.Map.choose possible_c_uids in
let payload = Option.map rec_helper payload in let payload = Option.map rec_helper payload in
Expr.einj Expr.einj
~e:(match payload with ~e:
(match payload with
| Some e' -> e' | Some e' -> e'
| None -> Expr.elit LUnit mark_constructor) | None -> Expr.elit LUnit mark_constructor)
~cons:c_uid ~name:e_uid emark ~cons:c_uid ~name:e_uid emark
| path_enum -> ( | path_enum -> (
let path, enum = match List.rev path_enum with let path, enum =
match List.rev path_enum with
| enum :: rpath -> List.rev rpath, enum | enum :: rpath -> List.rev rpath, enum
| _ -> assert false | _ -> assert false
in in
@ -555,11 +559,10 @@ let rec translate_expr
let e_uid = Name_resolution.get_enum ctxt enum in let e_uid = Name_resolution.get_enum ctxt enum in
try try
let c_uid = EnumName.Map.find e_uid possible_c_uids in let c_uid = EnumName.Map.find e_uid possible_c_uids in
let payload = let payload = Option.map rec_helper payload in
Option.map rec_helper payload
in
Expr.einj Expr.einj
~e:(match payload with ~e:
(match payload with
| Some e' -> e' | Some e' -> e'
| None -> Expr.elit LUnit mark_constructor) | None -> Expr.elit LUnit mark_constructor)
~cons:c_uid ~name:e_uid emark ~cons:c_uid ~name:e_uid emark
@ -570,8 +573,7 @@ let rec translate_expr
let e1 = rec_helper e1 in let e1 = rec_helper e1 in
let cases_d, e_uid = let cases_d, e_uid =
disambiguate_match_and_build_expression scope inside_definition_of ctxt disambiguate_match_and_build_expression scope inside_definition_of ctxt
local_vars local_vars cases
cases
in in
Expr.ematch ~e:e1 ~name:e_uid ~cases:cases_d emark Expr.ematch ~e:e1 ~name:e_uid ~cases:cases_d emark
| TestMatchCase (e1, pattern) -> | TestMatchCase (e1, pattern) ->
@ -594,9 +596,7 @@ let rec translate_expr
[tau] pos) [tau] pos)
(EnumName.Map.find enum_uid ctxt.enums) (EnumName.Map.find enum_uid ctxt.enums)
in in
Expr.ematch Expr.ematch ~e:(rec_helper e1) ~name:enum_uid ~cases emark
~e:(rec_helper e1)
~name:enum_uid ~cases:cases emark
| ArrayLit es -> Expr.earray (List.map rec_helper es) emark | ArrayLit es -> Expr.earray (List.map rec_helper es) emark
| CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) -> | CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) ->
let collection = rec_helper collection in let collection = rec_helper collection in
@ -619,8 +619,8 @@ let rec translate_expr
emark) emark)
[f_pred; collection] emark [f_pred; collection] emark
| CollectionOp | CollectionOp
(S.AggregateArgExtremum { max; default; f = param_name, predicate }, collection) ( S.AggregateArgExtremum { max; default; f = param_name, predicate },
-> collection ) ->
let default = rec_helper default in let default = rec_helper default in
let pos_dft = Expr.pos default in let pos_dft = Expr.pos default in
let collection = rec_helper collection in let collection = rec_helper collection in
@ -800,9 +800,7 @@ and disambiguate_match_and_build_expression
let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) = let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) =
match case with match case with
| S.MatchCase case -> | S.MatchCase case ->
let constructor, binding = let constructor, binding = Mark.remove case.S.match_case_pattern in
Mark.remove case.S.match_case_pattern
in
let e_uid', c_uid = let e_uid', c_uid =
disambiguate_constructor ctxt constructor disambiguate_constructor ctxt constructor
(Mark.get case.S.match_case_pattern) (Mark.get case.S.match_case_pattern)
@ -826,7 +824,9 @@ and disambiguate_match_and_build_expression
[None, Mark.get case.match_case_expr; None, Expr.pos e_case] [None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format "The constructor %a has been matched twice:" EnumConstructor.format
c_uid); c_uid);
let local_vars, param_var = create_var local_vars (Option.map Mark.remove binding) in let local_vars, param_var =
create_var local_vars (Option.map Mark.remove binding)
in
let case_body = let case_body =
translate_expr scope inside_definition_of ctxt local_vars translate_expr scope inside_definition_of ctxt local_vars
case.S.match_case_expr case.S.match_case_expr
@ -882,7 +882,8 @@ and disambiguate_match_and_build_expression
(* Creates the wildcard payload *) (* Creates the wildcard payload *)
let local_vars, payload_var = create_var local_vars None in let local_vars, payload_var = create_var local_vars None in
let case_body = let case_body =
translate_expr scope inside_definition_of ctxt local_vars match_case_expr translate_expr scope inside_definition_of ctxt local_vars
match_case_expr
in in
let e_binder = Expr.bind [| payload_var |] case_body in let e_binder = Expr.bind [| payload_var |] case_body in
@ -972,8 +973,7 @@ let process_rule_parameters
Message.raise_multispanned_error Message.raise_multispanned_error
[ [
Some "Arguments declared here", pos; Some "Arguments declared here", pos;
( Some "Definition missing the arguments", Some "Definition missing the arguments", Mark.get def.S.definition_name;
Mark.get def.S.definition_name );
] ]
"This definition for %a is missing the arguments" Ast.ScopeDef.format "This definition for %a is missing the arguments" Ast.ScopeDef.format
decl_name decl_name
@ -1005,7 +1005,8 @@ let process_default
(cons : S.expression) : Ast.rule = (cons : S.expression) : Ast.rule =
let just = let just =
match just with match just with
| Some just -> Some (translate_expr (Some scope) (Some def_key) ctxt local_vars just) | Some just ->
Some (translate_expr (Some scope) (Some def_key) ctxt local_vars just)
| None -> None | None -> None
in in
let just = merge_conditions precond just (Mark.get def_key) in let just = merge_conditions precond just (Mark.get def_key) in
@ -1159,7 +1160,9 @@ let process_scope_use_item
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (prgm : Ast.program)
(item : S.scope_use_item Mark.pos) : Ast.program = (item : S.scope_use_item Mark.pos) : Ast.program =
let precond = Option.map (translate_expr (Some scope) None ctxt Ident.Map.empty) precond in let precond =
Option.map (translate_expr (Some scope) None ctxt Ident.Map.empty) precond
in
match Mark.remove item with match Mark.remove item with
| S.Rule rule -> process_rule precond scope ctxt prgm rule | S.Rule rule -> process_rule precond scope ctxt prgm rule
| S.Definition def -> process_def precond scope ctxt prgm def | S.Definition def -> process_def precond scope ctxt prgm def
@ -1277,7 +1280,8 @@ let process_topdef
let expr_opt = let expr_opt =
match def.S.topdef_expr, def.S.topdef_args with match def.S.topdef_expr, def.S.topdef_args with
| None, _ -> None | None, _ -> None
| Some e, None -> Some (Expr.unbox_closed (translate_expr None None ctxt Ident.Map.empty e)) | Some e, None ->
Some (Expr.unbox_closed (translate_expr None None ctxt Ident.Map.empty e))
| Some e, Some (args, _) -> | Some e, Some (args, _) ->
let local_vars, args_tys = let local_vars, args_tys =
List.fold_left_map List.fold_left_map
@ -1417,9 +1421,8 @@ let init_scope_defs
Ident.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty Ident.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty
(** Main function of this module *) (** Main function of this module *)
let translate_program let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
(ctxt : Name_resolution.context) Ast.program =
(surface : S.program) : Ast.program =
let desugared = let desugared =
let get_program_scopes ctxt = let get_program_scopes ctxt =
ScopeName.Map.mapi ScopeName.Map.mapi
@ -1430,7 +1433,9 @@ let translate_program
match v with match v with
| Name_resolution.SubScope _ -> acc | Name_resolution.SubScope _ -> acc
| Name_resolution.ScopeVar v -> ( | Name_resolution.ScopeVar v -> (
let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in let v_sig =
ScopeVar.Map.find v ctxt.Name_resolution.var_typs
in
match v_sig.Name_resolution.var_sig_states_list with match v_sig.Name_resolution.var_sig_states_list with
| [] -> ScopeVar.Map.add v Ast.WholeVar acc | [] -> ScopeVar.Map.add v Ast.WholeVar acc
| states -> ScopeVar.Map.add v (Ast.States states) acc)) | states -> ScopeVar.Map.add v (Ast.States states) acc))
@ -1458,28 +1463,40 @@ let translate_program
in in
let rec make_ctx ctxt = let rec make_ctx ctxt =
let submodules = let submodules =
ModuleName.Map.map make_ctx ctxt.Name_resolution.modules; ModuleName.Map.map make_ctx ctxt.Name_resolution.modules
in in
{ {
Ast.program_ctx = Ast.program_ctx =
{ {
(* After name resolution, type definitions (structs and enums) are exposed at toplevel for easier lookup, but their paths need to remain available for printing and later passes *) (* After name resolution, type definitions (structs and enums) are
exposed at toplevel for easier lookup, but their paths need to
remain available for printing and later passes *)
ctx_structs = ctx_structs =
ModuleName.Map.fold (fun modname prg acc -> ModuleName.Map.fold
StructName.Map.union (fun _ _ _ -> assert false) acc (fun modname prg acc ->
StructName.Map.union
(fun _ _ _ -> assert false)
acc
(StructName.Map.map (StructName.Map.map
(fun (path, def) -> (modname, Pos.no_pos) :: path, def) (fun (path, def) -> (modname, Pos.no_pos) :: path, def)
prg.Ast.program_ctx.ctx_structs)) prg.Ast.program_ctx.ctx_structs))
submodules submodules
(StructName.Map.map (fun def -> [], def) ctxt.Name_resolution.structs); (StructName.Map.map
(fun def -> [], def)
ctxt.Name_resolution.structs);
ctx_enums = ctx_enums =
ModuleName.Map.fold (fun modname prg acc -> ModuleName.Map.fold
EnumName.Map.union (fun _ _ _ -> assert false) acc (fun modname prg acc ->
EnumName.Map.union
(fun _ _ _ -> assert false)
acc
(EnumName.Map.map (EnumName.Map.map
(fun (path, def) -> (modname, Pos.no_pos) :: path, def) (fun (path, def) -> (modname, Pos.no_pos) :: path, def)
prg.Ast.program_ctx.ctx_enums)) prg.Ast.program_ctx.ctx_enums))
submodules submodules
(EnumName.Map.map (fun def -> [], def) ctxt.Name_resolution.enums); (EnumName.Map.map
(fun def -> [], def)
ctxt.Name_resolution.enums);
ctx_scopes = ctx_scopes =
Ident.Map.fold Ident.Map.fold
(fun _ def acc -> (fun _ def acc ->
@ -1490,7 +1507,8 @@ let translate_program
ctxt.Name_resolution.typedefs ScopeName.Map.empty; ctxt.Name_resolution.typedefs ScopeName.Map.empty;
ctx_struct_fields = ctxt.Name_resolution.field_idmap; ctx_struct_fields = ctxt.Name_resolution.field_idmap;
ctx_topdefs = ctxt.Name_resolution.topdef_types; ctx_topdefs = ctxt.Name_resolution.topdef_types;
ctx_modules = ModuleName.Map.map (fun s -> s.Ast.program_ctx) submodules; ctx_modules =
ModuleName.Map.map (fun s -> s.Ast.program_ctx) submodules;
}; };
Ast.program_topdefs = TopdefName.Map.empty; Ast.program_topdefs = TopdefName.Map.empty;
Ast.program_scopes = get_program_scopes ctxt; Ast.program_scopes = get_program_scopes ctxt;
@ -1505,41 +1523,49 @@ let translate_program
match Mark.remove item with match Mark.remove item with
| S.ScopeUse use -> process_scope_use ctxt prgm use | S.ScopeUse use -> process_scope_use ctxt prgm use
| S.Topdef def -> process_topdef ctxt prgm def | S.Topdef def -> process_topdef ctxt prgm def
| S.ScopeDecl _ | S.StructDecl _ | S.ScopeDecl _ | S.StructDecl _ | S.EnumDecl _ -> prgm)
| S.EnumDecl _ ->
prgm)
prgm block prgm block
in in
let rec process_structure let rec process_structure (prgm : Ast.program) (item : S.law_structure) :
(prgm : Ast.program) Ast.program =
(item : S.law_structure) : Ast.program =
match item with match item with
| S.LawHeading (_, children) -> | S.LawHeading (_, children) ->
List.fold_left List.fold_left
(fun prgm child -> process_structure prgm child) (fun prgm child -> process_structure prgm child)
prgm children prgm children
| S.CodeBlock (block, _, _) -> | S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block
process_code_block ctxt prgm block
| S.LawInclude _ | S.LawText _ -> prgm | S.LawInclude _ | S.LawText _ -> prgm
in in
Message.emit_debug "DESUGARED → prog scopes: %a@ modules: %a" Message.emit_debug "DESUGARED → prog scopes: %a@ modules: %a"
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space) desugared.Ast.program_scopes (ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space)
(ModuleName.Map.format desugared.Ast.program_scopes
(fun fmt prg -> ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt prg.Ast.program_scopes)) desugared.Ast.program_modules; (ModuleName.Map.format (fun fmt prg ->
ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt
prg.Ast.program_scopes))
desugared.Ast.program_modules;
let desugared = let desugared =
List.fold_left (fun acc (id, intf) -> List.fold_left
(fun acc (id, intf) ->
let modul = ModuleName.Map.find id acc.Ast.program_modules in let modul = ModuleName.Map.find id acc.Ast.program_modules in
let modul = process_code_block (Name_resolution.module_ctx ctxt [id, Pos.no_pos]) modul intf in let modul =
{ acc with program_modules = process_code_block
ModuleName.Map.add id modul acc.program_modules }) (Name_resolution.module_ctx ctxt [id, Pos.no_pos])
desugared modul intf
surface.S.program_modules in
{
acc with
program_modules = ModuleName.Map.add id modul acc.program_modules;
})
desugared surface.S.program_modules
in in
let desugared = let desugared =
List.fold_left process_structure desugared surface.S.program_items List.fold_left process_structure desugared surface.S.program_items
in in
Message.emit_debug "DESUGARED2 → prog scopes: %a@ modules: %a" Message.emit_debug "DESUGARED2 → prog scopes: %a@ modules: %a"
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space) desugared.Ast.program_scopes (ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space)
(ModuleName.Map.format desugared.Ast.program_scopes
(fun fmt prg -> ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt prg.Ast.program_scopes)) desugared.Ast.program_modules; (ModuleName.Map.format (fun fmt prg ->
ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt
prg.Ast.program_scopes))
desugared.Ast.program_modules;
desugared desugared

3
compiler/desugared/linting.ml
View File

@ -108,7 +108,8 @@ let detect_unused_struct_fields (p : program) : unit =
~f:(fun struct_fields_used e -> ~f:(fun struct_fields_used e ->
let rec structs_fields_used_expr e struct_fields_used = let rec structs_fields_used_expr e struct_fields_used =
match Mark.remove e with match Mark.remove e with
| EDStructAccess { name_opt = Some name; e = e_struct; field; path = _ } -> | EDStructAccess
{ name_opt = Some name; e = e_struct; field; path = _ } ->
let field = let field =
StructName.Map.find name StructName.Map.find name
(Ident.Map.find field p.program_ctx.ctx_struct_fields) (Ident.Map.find field p.program_ctx.ctx_struct_fields)

74
compiler/desugared/name_resolution.ml
View File

@ -65,8 +65,7 @@ type var_sig = {
type typedef = type typedef =
| TStruct of StructName.t | TStruct of StructName.t
| TEnum of EnumName.t | TEnum of EnumName.t
| TScope of ScopeName.t * scope_info | TScope of ScopeName.t * scope_info (** Implicitly defined output struct *)
(** Implicitly defined output struct *)
type context = { type context = {
typedefs : typedef Ident.Map.t; typedefs : typedef Ident.Map.t;
@ -238,15 +237,15 @@ let get_scope ctxt id =
Message.raise_spanned_error (Mark.get id) "No scope named %s found" Message.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id) (Mark.remove id)
let rec module_ctx ctxt path = match path with let rec module_ctx ctxt path =
match path with
| [] -> ctxt | [] -> ctxt
| (modname, mpos) :: path -> | (modname, mpos) :: path -> (
(match ModuleName.Map.find_opt modname ctxt.modules with match ModuleName.Map.find_opt modname ctxt.modules with
| None -> | None ->
Message.raise_spanned_error mpos Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
"Module %a not found" ModuleName.format modname modname
| Some ctxt -> | Some ctxt -> module_ctx ctxt path)
module_ctx ctxt path)
(** {1 Declarations pass} *) (** {1 Declarations pass} *)
@ -267,8 +266,7 @@ let process_subscope_decl
in in
Message.raise_multispanned_error Message.raise_multispanned_error
[Some "first use", Mark.get info; Some "second use", s_pos] [Some "first use", Mark.get info; Some "second use", s_pos]
"Subscope name @{<yellow>\"%s\"@} already used" "Subscope name @{<yellow>\"%s\"@} already used" (Mark.remove subscope)
(Mark.remove subscope)
| None -> | None ->
let sub_scope_uid = SubScopeName.fresh (name, name_pos) in let sub_scope_uid = SubScopeName.fresh (name, name_pos) in
let original_subscope_uid = let original_subscope_uid =
@ -316,23 +314,24 @@ let rec process_base_typ
| Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos | Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Surface.Ast.Named ([], (ident, _pos)) -> ( | Surface.Ast.Named ([], (ident, _pos)) -> (
match Ident.Map.find_opt ident ctxt.typedefs with match Ident.Map.find_opt ident ctxt.typedefs with
| Some (TStruct s_uid) -> TStruct ( s_uid), typ_pos | Some (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum ( e_uid), typ_pos | Some (TEnum e_uid) -> TEnum e_uid, typ_pos
| Some (TScope (_, scope_str)) -> | Some (TScope (_, scope_str)) ->
TStruct ( scope_str.out_struct_name), typ_pos TStruct scope_str.out_struct_name, typ_pos
| None -> | None ->
Message.raise_spanned_error typ_pos Message.raise_spanned_error typ_pos
"Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \ "Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
declared" declared"
ident) ident)
| Surface.Ast.Named ((modul, mpos)::path, id) -> | Surface.Ast.Named ((modul, mpos) :: path, id) -> (
match ModuleName.Map.find_opt modul ctxt.modules with match ModuleName.Map.find_opt modul ctxt.modules with
| None -> | None ->
Message.raise_spanned_error mpos Message.raise_spanned_error mpos
"This refers to module %a, which was not found" "This refers to module %a, which was not found" ModuleName.format
ModuleName.format modul modul
| Some mod_ctxt -> | Some mod_ctxt ->
process_base_typ mod_ctxt Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos)) process_base_typ mod_ctxt
Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos)))
(** Process a type (function or not) *) (** Process a type (function or not) *)
let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ
@ -589,7 +588,9 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
(Mark.remove decl.scope_decl_name) (Mark.remove decl.scope_decl_name)
(function (function
| Some (TScope (scope, { in_struct_name; out_struct_name; _ })) -> | Some (TScope (scope, { in_struct_name; out_struct_name; _ })) ->
Some (TScope (scope, { in_struct_name; out_struct_name; out_struct_fields; })) Some
(TScope
(scope, { in_struct_name; out_struct_name; out_struct_fields }))
| _ -> assert false) | _ -> assert false)
ctxt.typedefs ctxt.typedefs
in in
@ -681,9 +682,14 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
"toplevel definition") "toplevel definition")
(Ident.Map.find_opt name ctxt.topdefs); (Ident.Map.find_opt name ctxt.topdefs);
let uid = TopdefName.fresh def.topdef_name in let uid = TopdefName.fresh def.topdef_name in
{ ctxt with {
ctxt with
topdefs = Ident.Map.add name uid ctxt.topdefs; topdefs = Ident.Map.add name uid ctxt.topdefs;
topdef_types = TopdefName.Map.add uid (process_type ctxt def.topdef_type) ctxt.topdef_types } topdef_types =
TopdefName.Map.add uid
(process_type ctxt def.topdef_type)
ctxt.topdef_types;
}
(** Process a code item that is a declaration *) (** Process a code item that is a declaration *)
let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
@ -699,16 +705,14 @@ let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
let process_code_block let process_code_block
(process_item : context -> Surface.Ast.code_item Mark.pos -> context) (process_item : context -> Surface.Ast.code_item Mark.pos -> context)
(ctxt : context) (ctxt : context)
(block : Surface.Ast.code_block) : (block : Surface.Ast.code_block) : context =
context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
(** Process a law structure, only considering the code blocks *) (** Process a law structure, only considering the code blocks *)
let rec process_law_structure let rec process_law_structure
(process_item : context -> Surface.Ast.code_item Mark.pos -> context) (process_item : context -> Surface.Ast.code_item Mark.pos -> context)
(ctxt : context) (ctxt : context)
(s : Surface.Ast.law_structure) : (s : Surface.Ast.law_structure) : context =
context =
match s with match s with
| Surface.Ast.LawHeading (_, children) -> | Surface.Ast.LawHeading (_, children) ->
List.fold_left List.fold_left
@ -758,7 +762,8 @@ let get_def_key
ScopeVar.format x_uid ScopeVar.format x_uid
else None ) else None )
| [y; x] -> | [y; x] ->
let (subscope_uid, (path, subscope_real_uid)) : SubScopeName.t * (path * ScopeName.t) = let (subscope_uid, (path, subscope_real_uid))
: SubScopeName.t * (path * ScopeName.t) =
match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u | Some (SubScope (v, u)) -> v, u
| Some _ -> | Some _ ->
@ -933,14 +938,11 @@ let empty_ctxt =
let import_module modules (name, intf) = let import_module modules (name, intf) =
let ctxt = { empty_ctxt with modules } in let ctxt = { empty_ctxt with modules } in
let ctxt = let ctxt = List.fold_left process_name_item ctxt intf in
List.fold_left process_name_item ctxt intf let ctxt = List.fold_left process_decl_item ctxt intf in
in
let ctxt =
List.fold_left process_decl_item ctxt intf
in
let ctxt = { ctxt with modules = empty_ctxt.modules } in let ctxt = { ctxt with modules = empty_ctxt.modules } in
(* No submodules at the moment, a module may use the ones loaded before it, but doesn't reexport them *) (* No submodules at the moment, a module may use the ones loaded before it,
but doesn't reexport them *)
ModuleName.Map.add name ctxt modules ModuleName.Map.add name ctxt modules
(** Derive the context from metadata, in one pass over the declarations *) (** Derive the context from metadata, in one pass over the declarations *)
@ -950,8 +952,10 @@ let form_context (prgm : Surface.Ast.program) : context =
in in
let ctxt = { empty_ctxt with modules } in let ctxt = { empty_ctxt with modules } in
let rec gather_var_sigs acc modules = let rec gather_var_sigs acc modules =
(* Scope vars from imported modules need to be accessible directly for definitions through submodules *) (* Scope vars from imported modules need to be accessible directly for
ModuleName.Map.fold (fun _modname mctx acc -> definitions through submodules *)
ModuleName.Map.fold
(fun _modname mctx acc ->
let acc = gather_var_sigs acc mctx.modules in let acc = gather_var_sigs acc mctx.modules in
ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.var_typs) ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.var_typs)
modules acc modules acc

6
compiler/desugared/name_resolution.mli
View File

@ -65,8 +65,7 @@ type var_sig = {
type typedef = type typedef =
| TStruct of StructName.t | TStruct of StructName.t
| TEnum of EnumName.t | TEnum of EnumName.t
| TScope of ScopeName.t * scope_info | TScope of ScopeName.t * scope_info (** Implicitly defined output struct *)
(** Implicitly defined output struct *)
type context = { type context = {
typedefs : typedef Ident.Map.t; typedefs : typedef Ident.Map.t;
@ -152,7 +151,8 @@ val get_scope : context -> Ident.t Mark.pos -> ScopeName.t
has a different kind *) has a different kind *)
val module_ctx : context -> path -> context val module_ctx : context -> path -> context
(** Returns the context corresponding to the given module path; raises a user error if the module is not found *) (** Returns the context corresponding to the given module path; raises a user
error if the module is not found *)
val process_type : context -> Surface.Ast.typ -> typ val process_type : context -> Surface.Ast.typ -> typ
(** Convert a surface base type to an AST type *) (** Convert a surface base type to an AST type *)

8
compiler/driver.ml
View File

@ -61,9 +61,7 @@ module Passes = struct
let prg = let prg =
Surface.Parser_driver.parse_top_level_file options.input_file language Surface.Parser_driver.parse_top_level_file options.input_file language
in in
let prg = let prg = Surface.Fill_positions.fill_pos_with_legislative_info prg in
Surface.Fill_positions.fill_pos_with_legislative_info prg
in
let prg = let prg =
{ prg with program_modules = load_module_interfaces options link_modules } { prg with program_modules = load_module_interfaces options link_modules }
in in
@ -256,8 +254,8 @@ module Commands = struct
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}" "Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
variable ScopeName.format scope_uid variable ScopeName.format scope_uid
| Some | Some
(Desugared.Name_resolution.SubScope (subscope_var_name, (subscope_path, subscope_name))) (Desugared.Name_resolution.SubScope
-> ( (subscope_var_name, (subscope_path, subscope_name))) -> (
match second_part with match second_part with
| None -> | None ->
Message.raise_error Message.raise_error

7
compiler/lcalc/ast.ml
View File

@ -26,7 +26,8 @@ module OptionMonad = struct
Expr.einj ~e ~cons:Expr.some_constr ~name:Expr.option_enum mark Expr.einj ~e ~cons:Expr.some_constr ~name:Expr.option_enum mark
let empty ~(mark : 'a mark) = let empty ~(mark : 'a mark) =
Expr.einj ~e:(Expr.elit LUnit mark) ~cons:Expr.none_constr ~name:Expr.option_enum mark Expr.einj ~e:(Expr.elit LUnit mark) ~cons:Expr.none_constr
~name:Expr.option_enum mark
let bind_var ~(mark : 'a mark) f x arg = let bind_var ~(mark : 'a mark) f x arg =
let cases = let cases =
@ -36,8 +37,8 @@ module OptionMonad = struct
let x = Var.make "_" in let x = Var.make "_" in
Expr.eabs Expr.eabs
(Expr.bind [| x |] (Expr.bind [| x |]
(Expr.einj ~e:(Expr.evar x mark) ~cons:Expr.none_constr ~name:Expr.option_enum (Expr.einj ~e:(Expr.evar x mark) ~cons:Expr.none_constr
mark)) ~name:Expr.option_enum mark))
[TLit TUnit, Expr.mark_pos mark] [TLit TUnit, Expr.mark_pos mark]
mark ); mark );
(* | None x -> None x *) (* | None x -> None x *)

9
compiler/lcalc/compile_without_exceptions.ml
View File

@ -169,7 +169,11 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
Ast.OptionMonad.return ~mark Ast.OptionMonad.return ~mark
(Expr.eapp (Expr.eapp
(Expr.evar (trans_var ctx scope) mark) (Expr.evar (trans_var ctx scope) mark)
[Expr.estruct ~name ~fields:(StructField.Map.map (trans ctx) fields) mark] [
Expr.estruct ~name
~fields:(StructField.Map.map (trans ctx) fields)
mark;
]
mark) mark)
| EApp { f = (EVar ff, _) as f; args } | EApp { f = (EVar ff, _) as f; args }
when not (Var.Map.find ff ctx.ctx_vars).is_scope -> when not (Var.Map.find ff ctx.ctx_vars).is_scope ->
@ -750,8 +754,7 @@ let translate_program (prgm : typed D.program) : untyped A.program =
ctx_structs = ctx_structs =
prgm.decl_ctx.ctx_structs prgm.decl_ctx.ctx_structs
|> StructName.Map.mapi (fun _n (path, str) -> |> StructName.Map.mapi (fun _n (path, str) ->
path, path, StructField.Map.map trans_typ_keep str);
StructField.Map.map trans_typ_keep str);
} }
in in

30
compiler/lcalc/to_ocaml.ml
View File

@ -218,9 +218,7 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
| TClosureEnv -> failwith "unimplemented!" | TClosureEnv -> failwith "unimplemented!"
let format_var_str (fmt : Format.formatter) (v : string) : unit = let format_var_str (fmt : Format.formatter) (v : string) : unit =
let lowercase_name = let lowercase_name = String.to_snake_case (String.to_ascii v) in
String.to_snake_case (String.to_ascii v)
in
let lowercase_name = let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
~subst:(fun _ -> "_dot_") ~subst:(fun _ -> "_dot_")
@ -276,13 +274,21 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
in in
match Mark.remove e with match Mark.remove e with
| EVar v -> Format.fprintf fmt "%a" format_var v | EVar v -> Format.fprintf fmt "%a" format_var v
| EExternal { path; name } -> | EExternal { path; name } -> (
Print.path fmt path; Print.path fmt path;
(* FIXME: this is wrong in general !! (* FIXME: this is wrong in general !! We assume the idents exposed by the
We assume the idents exposed by the module depend only on the original name, while they actually get through Bindlib and may have been renamed. A correct implem could use the runtime registration used by the interpreter, but that would be distasteful and incur a penalty ; or we would need to reproduce the same structure as in the original module to ensure that bindlib performs the exact same renamings ; or finally we could normalise the names at generation time (either at toplevel or in a dedicated submodule ?) *) module depend only on the original name, while they actually get through
(match Mark.remove name with Bindlib and may have been renamed. A correct implem could use the runtime
| External_value name -> format_var_str fmt (Mark.remove (TopdefName.get_info name)) registration used by the interpreter, but that would be distasteful and
| External_scope name -> format_var_str fmt (Mark.remove (ScopeName.get_info name))) incur a penalty ; or we would need to reproduce the same structure as in
the original module to ensure that bindlib performs the exact same
renamings ; or finally we could normalise the names at generation time
(either at toplevel or in a dedicated submodule ?) *)
match Mark.remove name with
| External_value name ->
format_var_str fmt (Mark.remove (TopdefName.get_info name))
| External_scope name ->
format_var_str fmt (Mark.remove (ScopeName.get_info name)))
| ETuple es -> | ETuple es ->
Format.fprintf fmt "@[<hov 2>(%a)@]" Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list (Format.pp_print_list
@ -550,12 +556,10 @@ let format_ctx
match struct_or_enum with match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s -> | Scopelang.Dependency.TVertex.Struct s ->
let path, def = StructName.Map.find s ctx.ctx_structs in let path, def = StructName.Map.find s ctx.ctx_structs in
if path = [] then if path = [] then Format.fprintf fmt "%a@\n" format_struct_decl (s, def)
Format.fprintf fmt "%a@\n" format_struct_decl (s, def)
| Scopelang.Dependency.TVertex.Enum e -> | Scopelang.Dependency.TVertex.Enum e ->
let path, def = EnumName.Map.find e ctx.ctx_enums in let path, def = EnumName.Map.find e ctx.ctx_enums in
if path = [] then if path = [] then Format.fprintf fmt "%a@\n" format_enum_decl (e, def))
Format.fprintf fmt "%a@\n" format_enum_decl (e, def))
(type_ordering @ scope_structs) (type_ordering @ scope_structs)
let rename_vars e = let rename_vars e =

13
compiler/plugins/api_web.ml
View File

@ -165,8 +165,8 @@ module To_jsoo = struct
format_typ_to_jsoo t2 fmt_struct_name () format_typ_to_jsoo t2 fmt_struct_name ()
format_struct_field_name (None, struct_field) format_struct_field_name (None, struct_field)
(Format.pp_print_list (fun fmt (i, ti) -> (Format.pp_print_list (fun fmt (i, ti) ->
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" format_typ_of_jsoo
format_typ_of_jsoo ti Format.pp_print_string i)) ti Format.pp_print_string i))
(List.combine args_names t1) (List.combine args_names t1)
| _ -> | _ ->
Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]" Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]"
@ -190,8 +190,8 @@ module To_jsoo = struct
| _ -> | _ ->
Format.fprintf fmt Format.fprintf fmt
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]" "@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]"
format_struct_field_name (None, struct_field) format_struct_field_name (None, struct_field) format_typ_of_jsoo
format_typ_of_jsoo struct_field_type fmt_struct_name () struct_field_type fmt_struct_name ()
format_struct_field_name_camel_case struct_field) format_struct_field_name_camel_case struct_field)
fmt fmt
(StructField.Map.bindings struct_fields) (StructField.Map.bindings struct_fields)
@ -231,8 +231,9 @@ module To_jsoo = struct
(StructField.Map.bindings struct_fields) (StructField.Map.bindings struct_fields)
fmt_conv_funs () fmt_conv_funs ()
in in
let format_enum_decl fmt (enum_name, (path, (enum_cons : typ EnumConstructor.Map.t))) let format_enum_decl
= fmt
(enum_name, (path, (enum_cons : typ EnumConstructor.Map.t))) =
let fmt_enum_name fmt _ = format_enum_name fmt enum_name in let fmt_enum_name fmt _ = format_enum_name fmt enum_name in
let fmt_module_enum_name fmt () = let fmt_module_enum_name fmt () =
Print.path fmt path; Print.path fmt path;

6
compiler/plugins/json_schema.ml
View File

@ -80,8 +80,7 @@ module To_json = struct
Format.pp_print_list Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (field_name, field_type) -> (fun fmt (field_name, field_type) ->
Format.fprintf fmt "@[<hov 2>\"%a%a\": {@\n%a@]@\n}" Format.fprintf fmt "@[<hov 2>\"%a%a\": {@\n%a@]@\n}" Print.path path
Print.path path
format_struct_field_name_camel_case field_name fmt_type field_type) format_struct_field_name_camel_case field_name fmt_type field_type)
fmt fmt
(StructField.Map.bindings fields) (StructField.Map.bindings fields)
@ -105,7 +104,8 @@ module To_json = struct
(t :: acc) @ collect_required_type_defs_from_scope_input s (t :: acc) @ collect_required_type_defs_from_scope_input s
| TEnum e -> | TEnum e ->
List.fold_left collect (t :: acc) List.fold_left collect (t :: acc)
(EnumConstructor.Map.values (snd (EnumName.Map.find e ctx.ctx_enums))) (EnumConstructor.Map.values
(snd (EnumName.Map.find e ctx.ctx_enums)))
| TArray t -> collect acc t | TArray t -> collect acc t
| _ -> acc | _ -> acc
in in

3
compiler/plugins/lazy_interp.ml
View File

@ -234,7 +234,8 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) :
let m = Mark.get e in let m = Mark.get e in
let application_arg = let application_arg =
Expr.estruct ~name:scope_arg_struct Expr.estruct ~name:scope_arg_struct
~fields:(StructField.Map.map ~fields:
(StructField.Map.map
(function (function
| TArrow (ty_in, ty_out), _ -> | TArrow (ty_in, ty_out), _ ->
Expr.make_abs Expr.make_abs

2
compiler/plugins/modules.ml
View File

@ -115,7 +115,7 @@ let compile options link_modules optimize check_invariants =
gen_ocaml options link_modules optimize check_invariants (Some modname) None gen_ocaml options link_modules optimize check_invariants (Some modname) None
in in
let flags = ["-I"; Lazy.force runtime_dir] in let flags = ["-I"; Lazy.force runtime_dir] in
let shared_out = File.(Filename.dirname ml_file / basename ^ ".cmxs") in let shared_out = File.((Filename.dirname ml_file / basename) ^ ".cmxs") in
Message.emit_debug "Compiling OCaml shared object file @{<bold>%s@}..." Message.emit_debug "Compiling OCaml shared object file @{<bold>%s@}..."
shared_out; shared_out;
run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags); run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags);

12
compiler/scalc/print.ml
View File

@ -43,8 +43,8 @@ let rec format_expr
| EFunc v -> Format.fprintf fmt "%a" format_func_name v | EFunc v -> Format.fprintf fmt "%a" format_func_name v
| EStruct (es, s) -> | EStruct (es, s) ->
let path, fields = StructName.Map.find s decl_ctx.ctx_structs in let path, fields = StructName.Map.find s decl_ctx.ctx_structs in
Format.fprintf fmt "@[<hov 2>%a%a@ %a%a%a@]" Print.path path StructName.format s Format.fprintf fmt "@[<hov 2>%a%a@ %a%a%a@]" Print.path path
Print.punctuation "{" StructName.format s Print.punctuation "{"
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, (struct_field, _)) -> (fun fmt (e, (struct_field, _)) ->
@ -150,13 +150,11 @@ let rec format_statement
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt ((case, _), (arm_block, payload_name)) -> (fun fmt ((case, _), (arm_block, payload_name)) ->
Format.fprintf fmt "%a %a%a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation Format.fprintf fmt "%a %a%a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation
"|" Print.path path Print.enum_constructor case Print.punctuation ":" "|" Print.path path Print.enum_constructor case Print.punctuation
format_var_name payload_name Print.punctuation "→" ":" format_var_name payload_name Print.punctuation "→"
(format_block decl_ctx ~debug) (format_block decl_ctx ~debug)
arm_block)) arm_block))
(List.combine (List.combine (EnumConstructor.Map.bindings cons) arms)
(EnumConstructor.Map.bindings cons)
arms)
and format_block and format_block
(decl_ctx : decl_ctx) (decl_ctx : decl_ctx)

10
compiler/scalc/to_python.ml
View File

@ -274,9 +274,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
| EVar v -> format_var fmt v | EVar v -> format_var fmt v
| EFunc f -> format_func_name fmt f | EFunc f -> format_func_name fmt f
| EStruct (es, s) -> | EStruct (es, s) ->
let path, fields = let path, fields = StructName.Map.find s ctx.ctx_structs in
StructName.Map.find s ctx.ctx_structs
in
Format.fprintf fmt "%a%a(%a)" Print.path path format_struct_name s Format.fprintf fmt "%a%a(%a)" Print.path path format_struct_name s
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
@ -442,9 +440,9 @@ let rec format_statement
~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 4>elif ") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 4>elif ")
(fun fmt (case_block, payload_var, cons_name) -> (fun fmt (case_block, payload_var, cons_name) ->
Format.fprintf fmt "%a.code == %a%a_Code.%a:@\n%a = %a.value@\n%a" Format.fprintf fmt "%a.code == %a%a_Code.%a:@\n%a = %a.value@\n%a"
format_var tmp_var Print.path path format_enum_name e_name format_enum_cons_name format_var tmp_var Print.path path format_enum_name e_name
cons_name format_var payload_var format_var tmp_var format_enum_cons_name cons_name format_var payload_var format_var
(format_block ctx) case_block)) tmp_var (format_block ctx) case_block))
cases cases
| SReturn e1 -> | SReturn e1 ->
Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx) Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx)

15
compiler/scopelang/ast.ml
View File

@ -75,8 +75,7 @@ let type_program (prg : 'm program) : typed program =
let typing_env = let typing_env =
TopdefName.Map.fold TopdefName.Map.fold
(fun name (_, ty) -> Typing.Env.add_toplevel_var name ty) (fun name (_, ty) -> Typing.Env.add_toplevel_var name ty)
prg.program_topdefs prg.program_topdefs typing_env
typing_env
in in
let typing_env = let typing_env =
ScopeName.Map.fold ScopeName.Map.fold
@ -88,16 +87,16 @@ let type_program (prg : 'm program) : typed program =
typing_env typing_env
in in
let rec build_typing_env prg = let rec build_typing_env prg =
ModuleName.Map.fold (fun modname prg -> ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg)) Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules prg.program_modules (base_typing_env prg)
(base_typing_env prg)
in in
let typing_env = let typing_env =
ModuleName.Map.fold (fun modname prg -> ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg)) Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules prg.program_modules (base_typing_env prg)
(base_typing_env prg)
in in
let program_topdefs = let program_topdefs =
TopdefName.Map.map TopdefName.Map.map

4
compiler/scopelang/ast.mli
View File

@ -47,7 +47,9 @@ type 'm program = {
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t; program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t; program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_modules : nil program ModuleName.Map.t; program_modules : nil program ModuleName.Map.t;
(* Using [nil] here ensure that program interfaces don't contain any expressions. They won't contain any rules or topdefs, but will still have the scope signatures needed to respect the call convention *) (* Using [nil] here ensure that program interfaces don't contain any
expressions. They won't contain any rules or topdefs, but will still have
the scope signatures needed to respect the call convention *)
program_ctx : decl_ctx; program_ctx : decl_ctx;
} }

12
compiler/scopelang/dependency.ml
View File

@ -82,7 +82,8 @@ let rec expr_used_defs e =
e VMap.empty e VMap.empty
in in
match e with match e with
| ELocation (ToplevelVar { path = []; name = v, pos }), _ -> VMap.singleton (Topdef v) pos | ELocation (ToplevelVar { path = []; name = v, pos }), _ ->
VMap.singleton (Topdef v) pos
| (EScopeCall { path = []; scope; _ }, m) as e -> | (EScopeCall { path = []; scope; _ }, m) as e ->
VMap.add (Scope scope) (Expr.mark_pos m) (recurse_subterms e) VMap.add (Scope scope) (Expr.mark_pos m) (recurse_subterms e)
| EAbs { binder; _ }, _ -> | EAbs { binder; _ }, _ ->
@ -148,7 +149,8 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
used_defs g) used_defs g)
g scope.Ast.scope_decl_rules) g scope.Ast.scope_decl_rules)
prgm.program_scopes g prgm.program_scopes g
(* TODO FIXME: Add submodules here, they may still need dependency resolution type-wise (?) *) (* TODO FIXME: Add submodules here, they may still need dependency resolution
type-wise (?) *)
let check_for_cycle_in_defs (g : SDependencies.t) : unit = let check_for_cycle_in_defs (g : SDependencies.t) : unit =
(* if there is a cycle, there will be an strongly connected component of (* if there is a cycle, there will be an strongly connected component of
@ -284,8 +286,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
Message.raise_spanned_error (Mark.get typ) Message.raise_spanned_error (Mark.get typ)
"The type %a%a is defined using itself, which is forbidden \ "The type %a%a is defined using itself, which is forbidden \
since Catala does not provide recursive types" since Catala does not provide recursive types"
Print.path path Print.path path TVertex.format used
TVertex.format used
else else
let edge = TDependencies.E.create used (Mark.get typ) def in let edge = TDependencies.E.create used (Mark.get typ) def in
TDependencies.add_edge_e g edge) TDependencies.add_edge_e g edge)
@ -307,8 +308,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
Message.raise_spanned_error (Mark.get typ) Message.raise_spanned_error (Mark.get typ)
"The type %a%a is defined using itself, which is forbidden \ "The type %a%a is defined using itself, which is forbidden \
since Catala does not provide recursive types" since Catala does not provide recursive types"
Print.path path Print.path path TVertex.format used
TVertex.format used
else else
let edge = TDependencies.E.create used (Mark.get typ) def in let edge = TDependencies.E.create used (Mark.get typ) def in
TDependencies.add_edge_e g edge) TDependencies.add_edge_e g edge)

159
compiler/scopelang/from_desugared.ml
View File

@ -35,11 +35,12 @@ type ctx = {
let rec module_ctx ctx = function let rec module_ctx ctx = function
| [] -> ctx | [] -> ctx
| (modname, mpos) :: path -> | (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctx.modules with match ModuleName.Map.find_opt modname ctx.modules with
| None -> | None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
| Some ctx -> module_ctx ctx path modname
| Some ctx -> module_ctx ctx path)
let tag_with_log_entry let tag_with_log_entry
(e : untyped Ast.expr boxed) (e : untyped Ast.expr boxed)
@ -51,8 +52,7 @@ let tag_with_log_entry
[e] (Mark.get e) [e] (Mark.get e)
else e else e
let rec translate_expr (ctx : ctx) (e : D.expr) : let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
untyped Ast.expr boxed =
let m = Mark.get e in let m = Mark.get e in
match Mark.remove e with match Mark.remove e with
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m | EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
@ -79,20 +79,26 @@ let rec translate_expr (ctx : ctx) (e : D.expr) :
| ELocation (DesugaredScopeVar { name; state = None }) -> | ELocation (DesugaredScopeVar { name; state = None }) ->
Expr.elocation Expr.elocation
(ScopelangScopeVar (ScopelangScopeVar
{ name = {
match ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping name =
(match
ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping
with with
| WholeVar new_s_var -> Mark.copy name new_s_var | WholeVar new_s_var -> Mark.copy name new_s_var
| States _ -> failwith "should not happen" } ) | States _ -> failwith "should not happen");
})
m m
| ELocation (DesugaredScopeVar { name; state = Some state }) -> | ELocation (DesugaredScopeVar { name; state = Some state }) ->
Expr.elocation Expr.elocation
(ScopelangScopeVar (ScopelangScopeVar
{ name = {
match ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping name =
(match
ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping
with with
| WholeVar _ -> failwith "should not happen" | WholeVar _ -> failwith "should not happen"
| States states -> Mark.copy name (List.assoc state states) }) | States states -> Mark.copy name (List.assoc state states));
})
m m
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m | ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
| EDStructAccess { name_opt = None; _ } -> | EDStructAccess { name_opt = None; _ } ->
@ -117,14 +123,15 @@ let rec translate_expr (ctx : ctx) (e : D.expr) :
Expr.estructaccess ~e:e' ~field ~name m Expr.estructaccess ~e:e' ~field ~name m
| EScopeCall { path; scope; args } -> | EScopeCall { path; scope; args } ->
Expr.escopecall ~path ~scope Expr.escopecall ~path ~scope
~args:(ScopeVar.Map.fold ~args:
(ScopeVar.Map.fold
(fun v e args' -> (fun v e args' ->
let v' = let v' =
match ScopeVar.Map.find v ctx.scope_var_mapping with match ScopeVar.Map.find v ctx.scope_var_mapping with
| WholeVar v' -> v' | WholeVar v' -> v'
| States ((_, v') :: _) -> | States ((_, v') :: _) ->
(* When there are multiple states, the input is always the first (* When there are multiple states, the input is always the
one *) first one *)
v' v'
| States [] -> assert false | States [] -> assert false
in in
@ -173,9 +180,7 @@ let def_to_exception_graph
let rule_to_exception_graph (scope : D.scope) = function let rule_to_exception_graph (scope : D.scope) = function
| Desugared.Dependency.Vertex.Var (var, state) -> ( | Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def = let scope_def =
D.ScopeDef.Map.find D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs
(D.ScopeDef.Var (var, state))
scope.scope_defs
in in
let var_def = scope_def.D.scope_def_rules in let var_def = scope_def.D.scope_def_rules in
match Mark.remove scope_def.D.scope_def_io.io_input with match Mark.remove scope_def.D.scope_def_io.io_input with
@ -195,9 +200,7 @@ let rule_to_exception_graph (scope : D.scope) = function
| _ -> | _ ->
D.ScopeDef.Map.singleton D.ScopeDef.Map.singleton
(D.ScopeDef.Var (var, state)) (D.ScopeDef.Var (var, state))
(def_to_exception_graph (def_to_exception_graph (D.ScopeDef.Var (var, state)) var_def))
(D.ScopeDef.Var (var, state))
var_def))
| Desugared.Dependency.Vertex.SubScope sub_scope_index -> | Desugared.Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the re-definitions (* Before calling the sub_scope, we need to include all the re-definitions
of subscope parameters*) of subscope parameters*)
@ -211,9 +214,7 @@ let rule_to_exception_graph (scope : D.scope) = function
(* We exclude subscope variables that have 0 re-definitions and are (* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *) not visible in the input of the subscope *)
&& not && not
((match ((match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.D.scope_def_io.io_input
with
| NoInput -> true | NoInput -> true
| _ -> false) | _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules)) && RuleName.Map.is_empty scope_def.scope_def_rules))
@ -230,9 +231,7 @@ let rule_to_exception_graph (scope : D.scope) = function
(* This definition redefines a variable of the correct subscope. But (* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *) to the io parameters of that subscope variable. *)
(match (match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.D.scope_def_io.io_input
with
| NoInput -> | NoInput ->
Message.raise_multispanned_error Message.raise_multispanned_error
(( Some "Incriminated subscope:", (( Some "Incriminated subscope:",
@ -266,13 +265,11 @@ let rule_to_exception_graph (scope : D.scope) = function
List.fold_left List.fold_left
(fun exc_graphs (new_exc_graph, subscope_var, var_pos) -> (fun exc_graphs (new_exc_graph, subscope_var, var_pos) ->
D.ScopeDef.Map.add D.ScopeDef.Map.add
(D.ScopeDef.SubScopeVar (D.ScopeDef.SubScopeVar (sub_scope_index, subscope_var, var_pos))
(sub_scope_index, subscope_var, var_pos))
new_exc_graph exc_graphs) new_exc_graph exc_graphs)
D.ScopeDef.Map.empty D.ScopeDef.Map.empty
(D.ScopeDef.Map.values sub_scope_vars_redefs) (D.ScopeDef.Map.values sub_scope_vars_redefs)
| Assertion _ -> | Assertion _ -> D.ScopeDef.Map.empty (* no exceptions for assertions *)
D.ScopeDef.Map.empty (* no exceptions for assertions *)
let scope_to_exception_graphs (scope : D.scope) : let scope_to_exception_graphs (scope : D.scope) :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t = Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t =
@ -351,9 +348,7 @@ let rec rule_tree_to_expr
(* because each rule has its own variables parameters and we want to convert (* because each rule has its own variables parameters and we want to convert
the whole rule tree into a function, we need to perform some alpha-renaming the whole rule tree into a function, we need to perform some alpha-renaming
of all the expressions *) of all the expressions *)
let substitute_parameter let substitute_parameter (e : D.expr boxed) (rule : D.rule) : D.expr boxed =
(e : D.expr boxed)
(rule : D.rule) : D.expr boxed =
match params, rule.D.rule_parameter with match params, rule.D.rule_parameter with
| Some new_params, Some (old_params_with_types, _) -> | Some new_params, Some (old_params_with_types, _) ->
let old_params, _ = List.split old_params_with_types in let old_params, _ = List.split old_params_with_types in
@ -390,14 +385,10 @@ let rec rule_tree_to_expr
ctx) ctx)
in in
let base_just_list = let base_just_list =
List.map List.map (fun rule -> substitute_parameter rule.D.rule_just rule) base_rules
(fun rule -> substitute_parameter rule.D.rule_just rule)
base_rules
in in
let base_cons_list = let base_cons_list =
List.map List.map (fun rule -> substitute_parameter rule.D.rule_cons rule) base_rules
(fun rule -> substitute_parameter rule.D.rule_cons rule)
base_rules
in in
let translate_and_unbox_list (list : D.expr boxed list) : let translate_and_unbox_list (list : D.expr boxed list) :
untyped Ast.expr boxed list = untyped Ast.expr boxed list =
@ -473,24 +464,17 @@ let translate_def
(* Here, we have to transform this list of rules into a default tree. *) (* Here, we have to transform this list of rules into a default tree. *)
let top_list = def_map_to_tree def exc_graph in let top_list = def_map_to_tree def exc_graph in
let is_input = let is_input =
match Mark.remove io.D.io_input with match Mark.remove io.D.io_input with OnlyInput -> true | _ -> false
| OnlyInput -> true
| _ -> false
in in
let is_reentrant = let is_reentrant =
match Mark.remove io.D.io_input with match Mark.remove io.D.io_input with Reentrant -> true | _ -> false
| Reentrant -> true
| _ -> false
in in
let top_value : D.rule option = let top_value : D.rule option =
if is_cond && ((not is_subscope_var) || (is_subscope_var && is_input)) then if is_cond && ((not is_subscope_var) || (is_subscope_var && is_input)) then
(* We add the bottom [false] value for conditions, only for the scope (* We add the bottom [false] value for conditions, only for the scope
where the condition is declared. Except when the variable is an input, where the condition is declared. Except when the variable is an input,
where we want the [false] to be added at each caller parent scope. *) where we want the [false] to be added at each caller parent scope. *)
Some Some (D.always_false_rule (D.ScopeDef.get_position def_info) params)
(D.always_false_rule
(D.ScopeDef.get_position def_info)
params)
else None else None
in in
if if
@ -550,20 +534,16 @@ let translate_def
exceptions to the default value *) exceptions to the default value *)
Node (top_list, [top_value]) Node (top_list, [top_value])
| [top_tree], None -> top_tree | [top_tree], None -> top_tree
| _, None -> | _, None -> Node (top_list, [D.empty_rule (Mark.get typ) params]))
Node (top_list, [D.empty_rule (Mark.get typ) params]))
let translate_rule let translate_rule
ctx ctx
(scope : D.scope) (scope : D.scope)
(exc_graphs : (exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) = function
= function
| Desugared.Dependency.Vertex.Var (var, state) -> ( | Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def = let scope_def =
D.ScopeDef.Map.find D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs
(D.ScopeDef.Var (var, state))
scope.scope_defs
in in
let var_def = scope_def.D.scope_def_rules in let var_def = scope_def.D.scope_def_rules in
let var_params = scope_def.D.scope_def_parameters in let var_params = scope_def.D.scope_def_parameters in
@ -613,9 +593,7 @@ let translate_rule
(* We exclude subscope variables that have 0 re-definitions and are (* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *) not visible in the input of the subscope *)
&& not && not
((match ((match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.D.scope_def_io.io_input
with
| NoInput -> true | NoInput -> true
| _ -> false) | _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules)) && RuleName.Map.is_empty scope_def.scope_def_rules))
@ -633,9 +611,7 @@ let translate_rule
(* This definition redefines a variable of the correct subscope. But (* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *) to the io parameters of that subscope variable. *)
(match (match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.D.scope_def_io.io_input
with
| NoInput -> assert false (* error already raised *) | NoInput -> assert false (* error already raised *)
| OnlyInput when RuleName.Map.is_empty def && not is_cond -> | OnlyInput when RuleName.Map.is_empty def && not is_cond ->
assert false (* error already raised *) assert false (* error already raised *)
@ -652,28 +628,28 @@ let translate_rule
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in in
Ast.Definition Ast.Definition
( ( SubScopeVar { ( ( SubScopeVar
{
path = subscop_path; path = subscop_path;
scope = subscop_real_name; scope = subscop_real_name;
alias = sub_scope_index, var_pos; alias = sub_scope_index, var_pos;
var = var =
match (match
ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping
with with
| WholeVar v -> v, var_pos | WholeVar v -> v, var_pos
| States states -> | States states ->
(* When defining a sub-scope variable, we always define (* When defining a sub-scope variable, we always
its first state in the sub-scope. *) define its first state in the sub-scope. *)
snd (List.hd states), var_pos }, snd (List.hd states), var_pos);
},
var_pos ), var_pos ),
def_typ, def_typ,
scope_def.D.scope_def_io, scope_def.D.scope_def_io,
Expr.unbox expr_def )) Expr.unbox expr_def ))
sub_scope_vars_redefs_candidates sub_scope_vars_redefs_candidates
in in
let sub_scope_vars_redefs = let sub_scope_vars_redefs = D.ScopeDef.Map.values sub_scope_vars_redefs in
D.ScopeDef.Map.values sub_scope_vars_redefs
in
sub_scope_vars_redefs sub_scope_vars_redefs
@ [ @ [
Ast.Call Ast.Call
@ -698,9 +674,7 @@ let translate_scope_interface ctx scope =
match states with match states with
| WholeVar -> | WholeVar ->
let scope_def = let scope_def =
D.ScopeDef.Map.find D.ScopeDef.Map.find (D.ScopeDef.Var (var, None)) scope.D.scope_defs
(D.ScopeDef.Var (var, None))
scope.D.scope_defs
in in
let typ = scope_def.scope_def_typ in let typ = scope_def.scope_def_typ in
ScopeVar.Map.add ScopeVar.Map.add
@ -742,8 +716,7 @@ let translate_scope
(ctx : ctx) (ctx : ctx)
(exc_graphs : (exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t)
(scope : D.scope) (scope : D.scope) : untyped Ast.scope_decl Mark.pos =
: untyped Ast.scope_decl Mark.pos =
let scope_dependencies = let scope_dependencies =
Desugared.Dependency.build_scope_dependencies scope Desugared.Dependency.build_scope_dependencies scope
in in
@ -758,7 +731,8 @@ let translate_scope
scope_decl_rules @ new_rules) scope_decl_rules @ new_rules)
[] scope_ordering [] scope_ordering
in in
Mark.map (fun s -> { s with Ast.scope_decl_rules }) Mark.map
(fun s -> { s with Ast.scope_decl_rules })
(translate_scope_interface ctx scope) (translate_scope_interface ctx scope)
(** {1 API} *) (** {1 API} *)
@ -766,8 +740,8 @@ let translate_scope
let translate_program let translate_program
(desugared : D.program) (desugared : D.program)
(exc_graphs : (exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) :
: untyped Ast.program = untyped Ast.program =
(* First we give mappings to all the locations between Desugared and This (* First we give mappings to all the locations between Desugared and This
involves creating a new Scopelang scope variable for every state of a involves creating a new Scopelang scope variable for every state of a
Desugared variable. *) Desugared variable. *)
@ -782,8 +756,7 @@ let translate_program
let var_name, var_pos = ScopeVar.get_info scope_var in let var_name, var_pos = ScopeVar.get_info scope_var in
let new_var = let new_var =
match states with match states with
| D.WholeVar -> | D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos))
WholeVar (ScopeVar.fresh (var_name, var_pos))
| States states -> | States states ->
let var_prefix = var_name ^ "_" in let var_prefix = var_name ^ "_" in
let state_var state = let state_var state =
@ -808,12 +781,18 @@ let translate_program
in in
let ctx = make_ctx desugared in let ctx = make_ctx desugared in
let rec gather_scope_vars acc modules = let rec gather_scope_vars acc modules =
ModuleName.Map.fold (fun _modname mctx acc -> ModuleName.Map.fold
(fun _modname mctx acc ->
let acc = gather_scope_vars acc mctx.modules in let acc = gather_scope_vars acc mctx.modules in
ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.scope_var_mapping) ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.scope_var_mapping)
modules acc modules acc
in in
let ctx = { ctx with scope_var_mapping = gather_scope_vars ctx.scope_var_mapping ctx.modules } in let ctx =
{
ctx with
scope_var_mapping = gather_scope_vars ctx.scope_var_mapping ctx.modules;
}
in
let rec process_decl_ctx ctx decl_ctx = let rec process_decl_ctx ctx decl_ctx =
let ctx_scopes = let ctx_scopes =
ScopeName.Map.map ScopeName.Map.map
@ -832,16 +811,20 @@ let translate_program
{ out_str with out_struct_fields }) { out_str with out_struct_fields })
decl_ctx.ctx_scopes decl_ctx.ctx_scopes
in in
{ decl_ctx with {
decl_ctx with
ctx_modules = ctx_modules =
ModuleName.Map.mapi (fun modname decl_ctx -> ModuleName.Map.mapi
(fun modname decl_ctx ->
let ctx = ModuleName.Map.find modname ctx.modules in let ctx = ModuleName.Map.find modname ctx.modules in
process_decl_ctx ctx decl_ctx) process_decl_ctx ctx decl_ctx)
decl_ctx.ctx_modules; decl_ctx.ctx_modules;
ctx_scopes; } ctx_scopes;
}
in in
let rec process_modules program_ctx desugared = let rec process_modules program_ctx desugared =
ModuleName.Map.mapi (fun modname m_desugared -> ModuleName.Map.mapi
(fun modname m_desugared ->
let ctx = ModuleName.Map.find modname ctx.modules in let ctx = ModuleName.Map.find modname ctx.modules in
{ {
Ast.program_topdefs = TopdefName.Map.empty; Ast.program_topdefs = TopdefName.Map.empty;
@ -869,7 +852,9 @@ let translate_program
desugared.program_topdefs desugared.program_topdefs
in in
let program_scopes = let program_scopes =
ScopeName.Map.map (translate_scope ctx exc_graphs) desugared.D.program_scopes ScopeName.Map.map
(translate_scope ctx exc_graphs)
desugared.D.program_scopes
in in
{ {
Ast.program_topdefs; Ast.program_topdefs;

18
compiler/scopelang/print.ml
View File

@ -22,10 +22,10 @@ let struc
ctx ctx
(fmt : Format.formatter) (fmt : Format.formatter)
(name : StructName.t) (name : StructName.t)
(path, fields : path * typ StructField.Map.t) : unit = ((path, fields) : path * typ StructField.Map.t) : unit =
Format.fprintf fmt "%a %a%a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword "struct" Format.fprintf fmt "%a %a%a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword
Print.path path "struct" Print.path path StructName.format name Print.punctuation "="
StructName.format name Print.punctuation "=" Print.punctuation "{" Print.punctuation "{"
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) -> (fun fmt (field_name, typ) ->
@ -38,10 +38,9 @@ let enum
ctx ctx
(fmt : Format.formatter) (fmt : Format.formatter)
(name : EnumName.t) (name : EnumName.t)
(path, cases : path * typ EnumConstructor.Map.t) : unit = ((path, cases) : path * typ EnumConstructor.Map.t) : unit =
Format.fprintf fmt "%a %a%a %a @\n@[<hov 2> %a@]" Print.keyword "enum" Format.fprintf fmt "%a %a%a %a @\n@[<hov 2> %a@]" Print.keyword "enum"
Print.path path Print.path path EnumName.format name Print.punctuation "="
EnumName.format name Print.punctuation "="
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) -> (fun fmt (field_name, typ) ->
@ -95,9 +94,8 @@ let scope ?debug ctx fmt (name, (decl, _pos)) =
Format.fprintf fmt "%a %a" Print.keyword "assert" Format.fprintf fmt "%a %a" Print.keyword "assert"
(Print.expr ?debug ()) e (Print.expr ?debug ()) e
| Call ((scope_path, scope_name), subscope_name, _) -> | Call ((scope_path, scope_name), subscope_name, _) ->
Format.fprintf fmt "%a %a%a%a%a%a" Print.keyword "call" Format.fprintf fmt "%a %a%a%a%a%a" Print.keyword "call" Print.path
Print.path scope_path scope_path ScopeName.format scope_name Print.punctuation "["
ScopeName.format scope_name Print.punctuation "["
SubScopeName.format subscope_name Print.punctuation "]")) SubScopeName.format subscope_name Print.punctuation "]"))
decl.scope_decl_rules decl.scope_decl_rules

47
compiler/shared_ast/definitions.ml
View File

@ -23,7 +23,9 @@
open Catala_utils open Catala_utils
module Runtime = Runtime_ocaml.Runtime module Runtime = Runtime_ocaml.Runtime
module ModuleName = String module ModuleName = String
(* TODO: should probably be turned into an Uid once we implement module import directives; that will incur an additional resolution work on all paths though *) (* TODO: should probably be turned into an Uid once we implement module import
directives; that will incur an additional resolution work on all paths
though *)
module ScopeName = Uid.Gen () module ScopeName = Uid.Gen ()
module TopdefName = Uid.Gen () module TopdefName = Uid.Gen ()
@ -314,8 +316,10 @@ type except = ConflictError | EmptyError | NoValueProvided | Crash
type untyped = { pos : Pos.t } [@@caml.unboxed] type untyped = { pos : Pos.t } [@@caml.unboxed]
type typed = { pos : Pos.t; ty : typ } type typed = { pos : Pos.t; ty : typ }
type 'a custom = { pos : Pos.t; custom : 'a } type 'a custom = { pos : Pos.t; custom : 'a }
(** Using empty markings will ensure terms can't be constructed: used for
example in interfaces to ensure that they don't contain any expressions *)
type nil = | type nil = |
(** Using empty markings will ensure terms can't be constructed: used for example in interfaces to ensure that they don't contain any expressions *)
(** The generic type of AST markings. Using a GADT allows functions to be (** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when polymorphic in the marking, but still do transformations on types when
@ -346,24 +350,34 @@ type lit =
type path = ModuleName.t Mark.pos list type path = ModuleName.t Mark.pos list
(** External references are resolved to strings that point to functions or constants in the end, but we need to keep different references for typing *) (** External references are resolved to strings that point to functions or
constants in the end, but we need to keep different references for typing *)
type external_ref = type external_ref =
| External_value of TopdefName.t | External_value of TopdefName.t
| External_scope of ScopeName.t | External_scope of ScopeName.t
(** Locations are handled differently in [desugared] and [scopelang] *) (** Locations are handled differently in [desugared] and [scopelang] *)
type 'a glocation = type 'a glocation =
| DesugaredScopeVar : | DesugaredScopeVar : {
{ name: ScopeVar.t Mark.pos; state: StateName.t option } name : ScopeVar.t Mark.pos;
state : StateName.t option;
}
-> < scopeVarStates : yes ; .. > glocation -> < scopeVarStates : yes ; .. > glocation
| ScopelangScopeVar : | ScopelangScopeVar : {
{ name: ScopeVar.t Mark.pos } name : ScopeVar.t Mark.pos;
}
-> < scopeVarSimpl : yes ; .. > glocation -> < scopeVarSimpl : yes ; .. > glocation
| SubScopeVar : | SubScopeVar : {
{ path: path; scope: ScopeName.t; alias: SubScopeName.t Mark.pos; var: ScopeVar.t Mark.pos } path : path;
scope : ScopeName.t;
alias : SubScopeName.t Mark.pos;
var : ScopeVar.t Mark.pos;
}
-> < explicitScopes : yes ; .. > glocation -> < explicitScopes : yes ; .. > glocation
| ToplevelVar : | ToplevelVar : {
{ path: path; name: TopdefName.t Mark.pos } path : path;
name : TopdefName.t Mark.pos;
}
-> < explicitScopes : yes ; .. > glocation -> < explicitScopes : yes ; .. > glocation
type ('a, 'm) gexpr = (('a, 'm) naked_gexpr, 'm) marked type ('a, 'm) gexpr = (('a, 'm) naked_gexpr, 'm) marked
@ -463,7 +477,11 @@ and ('a, 'b, 'm) base_gexpr =
-> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr -> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr
(** Resolved struct/enums, after [desugared] *) (** Resolved struct/enums, after [desugared] *)
(* Lambda-like *) (* Lambda-like *)
| EExternal : { path: path; name: external_ref Mark.pos} -> ('a, < explicitScopes: no ; .. >, 't) base_gexpr | EExternal : {
path : path;
name : external_ref Mark.pos;
}
-> ('a, < explicitScopes : no ; .. >, 't) base_gexpr
| EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr | EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr
(* Default terms *) (* Default terms *)
| EDefault : { | EDefault : {
@ -595,7 +613,4 @@ type decl_ctx = {
ctx_modules : decl_ctx ModuleName.Map.t; ctx_modules : decl_ctx ModuleName.Map.t;
} }
type 'e program = { type 'e program = { decl_ctx : decl_ctx; code_items : 'e code_item_list }
decl_ctx : decl_ctx;
code_items : 'e code_item_list;
}

59
compiler/shared_ast/expr.ml
View File

@ -109,7 +109,10 @@ let subst binder vars =
Bindlib.msubst binder (Array.of_list (List.map Mark.remove vars)) Bindlib.msubst binder (Array.of_list (List.map Mark.remove vars))
let evar v mark = Mark.add mark (Bindlib.box_var v) let evar v mark = Mark.add mark (Bindlib.box_var v)
let eexternal ~path ~name mark = Mark.add mark (Bindlib.box (EExternal {path; name}))
let eexternal ~path ~name mark =
Mark.add mark (Bindlib.box (EExternal { path; name }))
let etuple args = Box.appn args @@ fun args -> ETuple args let etuple args = Box.appn args @@ fun args -> ETuple args
let etupleaccess e index size = let etupleaccess e index size =
@ -296,8 +299,7 @@ let map
estruct ~name ~fields m estruct ~name ~fields m
| EDStructAccess { path; name_opt; field; e } -> | EDStructAccess { path; name_opt; field; e } ->
edstructaccess ~path ~name_opt ~field ~e:(f e) m edstructaccess ~path ~name_opt ~field ~e:(f e) m
| EStructAccess { name; field; e } -> | EStructAccess { name; field; e } -> estructaccess ~name ~field ~e:(f e) m
estructaccess ~name ~field ~e:(f e) m
| EMatch { name; e; cases } -> | EMatch { name; e; cases } ->
let cases = EnumConstructor.Map.map f cases in let cases = EnumConstructor.Map.map f cases in
ematch ~name ~e:(f e) ~cases m ematch ~name ~e:(f e) ~cases m
@ -516,31 +518,33 @@ let compare_lit (l1 : lit) (l2 : lit) =
| LDuration _, _ -> . | LDuration _, _ -> .
| _, LDuration _ -> . | _, LDuration _ -> .
let compare_path = let compare_path = List.compare (Mark.compare ModuleName.compare)
List.compare (Mark.compare ModuleName.compare)
let compare_location let compare_location
(type a) (type a)
(x : a glocation Mark.pos) (x : a glocation Mark.pos)
(y : a glocation Mark.pos) = (y : a glocation Mark.pos) =
match Mark.remove x, Mark.remove y with match Mark.remove x, Mark.remove y with
| DesugaredScopeVar { name = vx; state = None}, DesugaredScopeVar { name = vy; state = None} | ( DesugaredScopeVar { name = vx; state = None },
| DesugaredScopeVar { name = vx; state = Some _}, DesugaredScopeVar { name = vy; state = None} DesugaredScopeVar { name = vy; state = None } )
| DesugaredScopeVar { name = vx; state = None}, DesugaredScopeVar { name = vy; state = Some _} -> | ( DesugaredScopeVar { name = vx; state = Some _ },
DesugaredScopeVar { name = vy; state = None } )
| ( DesugaredScopeVar { name = vx; state = None },
DesugaredScopeVar { name = vy; state = Some _ } ) ->
ScopeVar.compare (Mark.remove vx) (Mark.remove vy) ScopeVar.compare (Mark.remove vx) (Mark.remove vy)
| DesugaredScopeVar {name = (x, _); state = Some sx}, DesugaredScopeVar {name = (y, _); state = Some sy} -> | ( DesugaredScopeVar { name = x, _; state = Some sx },
DesugaredScopeVar { name = y, _; state = Some sy } ) ->
let cmp = ScopeVar.compare x y in let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp if cmp = 0 then StateName.compare sx sy else cmp
| ScopelangScopeVar { name = (vx, _) }, ScopelangScopeVar { name = (vy, _) } -> | ScopelangScopeVar { name = vx, _ }, ScopelangScopeVar { name = vy, _ } ->
ScopeVar.compare vx vy ScopeVar.compare vx vy
| ( SubScopeVar { alias = (xsubindex, _); var = (xsubvar, _); _}, | ( SubScopeVar { alias = xsubindex, _; var = xsubvar, _; _ },
SubScopeVar { alias = (ysubindex, _); var = (ysubvar, _); _} ) -> SubScopeVar { alias = ysubindex, _; var = ysubvar, _; _ } ) ->
let c = SubScopeName.compare xsubindex ysubindex in let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| ToplevelVar { path = px; name = (vx, _) }, ToplevelVar { path = py; name = (vy, _) } -> | ( ToplevelVar { path = px; name = vx, _ },
(match compare_path px py with ToplevelVar { path = py; name = vy, _ } ) -> (
| 0 -> TopdefName.compare vx vy match compare_path px py with 0 -> TopdefName.compare vx vy | n -> n)
| n -> n)
| DesugaredScopeVar _, _ -> -1 | DesugaredScopeVar _, _ -> -1
| _, DesugaredScopeVar _ -> 1 | _, DesugaredScopeVar _ -> 1
| ScopelangScopeVar _, _ -> -1 | ScopelangScopeVar _, _ -> -1
@ -554,11 +558,15 @@ let equal_path = List.equal (Mark.equal ModuleName.equal)
let equal_location a b = compare_location a b = 0 let equal_location a b = compare_location a b = 0
let equal_except ex1 ex2 = ex1 = ex2 let equal_except ex1 ex2 = ex1 = ex2
let compare_except ex1 ex2 = Stdlib.compare ex1 ex2 let compare_except ex1 ex2 = Stdlib.compare ex1 ex2
let equal_external_ref ref1 ref2 = match ref1, ref2 with
let equal_external_ref ref1 ref2 =
match ref1, ref2 with
| External_value v1, External_value v2 -> TopdefName.equal v1 v2 | External_value v1, External_value v2 -> TopdefName.equal v1 v2
| External_scope s1, External_scope s2 -> ScopeName.equal s1 s2 | External_scope s1, External_scope s2 -> ScopeName.equal s1 s2
| (External_value _ | External_scope _), _ -> false | (External_value _ | External_scope _), _ -> false
let compare_external_ref ref1 ref2 = match ref1, ref2 with
let compare_external_ref ref1 ref2 =
match ref1, ref2 with
| External_value v1, External_value v2 -> TopdefName.compare v1 v2 | External_value v1, External_value v2 -> TopdefName.compare v1 v2
| External_scope s1, External_scope s2 -> ScopeName.compare s1 s2 | External_scope s1, External_scope s2 -> ScopeName.compare s1 s2
| External_value _, _ -> -1 | External_value _, _ -> -1
@ -609,12 +617,15 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
StructName.equal s1 s2 && StructField.Map.equal equal fields1 fields2 StructName.equal s1 s2 && StructField.Map.equal equal fields1 fields2
| ( EDStructAccess { e = e1; field = f1; name_opt = s1; path = p1 }, | ( EDStructAccess { e = e1; field = f1; name_opt = s1; path = p1 },
EDStructAccess { e = e2; field = f2; name_opt = s2; path = p2 } ) -> EDStructAccess { e = e2; field = f2; name_opt = s2; path = p2 } ) ->
Option.equal StructName.equal s1 s2 && equal_path p1 p2 && Ident.equal f1 f2 && equal e1 e2 Option.equal StructName.equal s1 s2
&& equal_path p1 p2
&& Ident.equal f1 f2
&& equal e1 e2
| ( EStructAccess { e = e1; field = f1; name = s1 }, | ( EStructAccess { e = e1; field = f1; name = s1 },
EStructAccess { e = e2; field = f2; name = s2 } ) -> EStructAccess { e = e2; field = f2; name = s2 } ) ->
StructName.equal s1 s2 && StructField.equal f1 f2 && equal e1 e2 StructName.equal s1 s2 && StructField.equal f1 f2 && equal e1 e2
| EInj { e = e1; cons = c1; name = n1 }, | EInj { e = e1; cons = c1; name = n1 }, EInj { e = e2; cons = c2; name = n2 }
EInj { e = e2; cons = c2; name = n2 } -> ->
EnumName.equal n1 n2 && EnumConstructor.equal c1 c2 && equal e1 e2 EnumName.equal n1 n2 && EnumConstructor.equal c1 c2 && equal e1 e2
| ( EMatch { e = e1; name = n1; cases = cases1 }, | ( EMatch { e = e1; name = n1; cases = cases1 },
EMatch { e = e2; name = n2; cases = cases2 } ) -> EMatch { e = e2; name = n2; cases = cases2 } ) ->
@ -623,9 +634,9 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
&& EnumConstructor.Map.equal equal cases1 cases2 && EnumConstructor.Map.equal equal cases1 cases2
| ( EScopeCall { path = p1; scope = s1; args = fields1 }, | ( EScopeCall { path = p1; scope = s1; args = fields1 },
EScopeCall { path = p2; scope = s2; args = fields2 } ) -> EScopeCall { path = p2; scope = s2; args = fields2 } ) ->
ScopeName.equal s1 s2 && ScopeName.equal s1 s2
equal_path p1 p2 && && equal_path p1 p2
ScopeVar.Map.equal equal fields1 fields2 && ScopeVar.Map.equal equal fields1 fields2
| ( ECustom { obj = obj1; targs = targs1; tret = tret1 }, | ( ECustom { obj = obj1; targs = targs1; tret = tret1 },
ECustom { obj = obj2; targs = targs2; tret = tret2 } ) -> ECustom { obj = obj2; targs = targs2; tret = tret2 } ) ->
Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2 Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2

7
compiler/shared_ast/expr.mli
View File

@ -36,7 +36,12 @@ val rebox : ('a any, 'm) gexpr -> ('a, 'm) boxed_gexpr
(** Rebuild the whole term, re-binding all variables and exposing free variables *) (** Rebuild the whole term, re-binding all variables and exposing free variables *)
val evar : ('a, 'm) gexpr Var.t -> 'm mark -> ('a, 'm) boxed_gexpr val evar : ('a, 'm) gexpr Var.t -> 'm mark -> ('a, 'm) boxed_gexpr
val eexternal : path:path -> name:external_ref Mark.pos -> 'm mark -> (< explicitScopes: no; .. >, 'm) boxed_gexpr
val eexternal :
path:path ->
name:external_ref Mark.pos ->
'm mark ->
(< explicitScopes : no ; .. >, 'm) boxed_gexpr
val bind : val bind :
('a, 'm) gexpr Var.t array -> ('a, 'm) gexpr Var.t array ->

24
compiler/shared_ast/interpreter.ml
View File

@ -549,31 +549,33 @@ let rec evaluate_expr :
Message.raise_spanned_error pos Message.raise_spanned_error pos
"free variable found at evaluation (should not happen if term was \ "free variable found at evaluation (should not happen if term was \
well-typed)" well-typed)"
| EExternal { path; name } -> ( | EExternal { path; name } ->
let ty = let ty =
try try
let ctx = Program.module_ctx ctx path in let ctx = Program.module_ctx ctx path in
match Mark.remove name with match Mark.remove name with
| External_value name -> | External_value name -> TopdefName.Map.find name ctx.ctx_topdefs
TopdefName.Map.find name ctx.ctx_topdefs
| External_scope name -> | External_scope name ->
let scope_info = ScopeName.Map.find name ctx.ctx_scopes in let scope_info = ScopeName.Map.find name ctx.ctx_scopes in
TArrow ([TStruct scope_info.in_struct_name, pos], ( TArrow
( [TStruct scope_info.in_struct_name, pos],
(TStruct scope_info.out_struct_name, pos) ), (TStruct scope_info.out_struct_name, pos) ),
pos pos )
with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ -> with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ ->
Message.raise_spanned_error pos "Reference to %a%a could not be resolved" Message.raise_spanned_error pos
Print.path path Print.external_ref name "Reference to %a%a could not be resolved" Print.path path
Print.external_ref name
in in
let runtime_path = let runtime_path =
List.map Mark.remove path, ( List.map Mark.remove path,
match Mark.remove name with match Mark.remove name with
| External_value name -> Mark.remove (TopdefName.get_info name) | External_value name -> Mark.remove (TopdefName.get_info name)
| External_scope name -> Mark.remove (ScopeName.get_info name) | External_scope name -> Mark.remove (ScopeName.get_info name) )
(* we have the guarantee that the two cases won't collide because they have different capitalisation rules inherited from the input *) (* we have the guarantee that the two cases won't collide because they
have different capitalisation rules inherited from the input *)
in in
let o = Runtime.lookup_value runtime_path in let o = Runtime.lookup_value runtime_path in
runtime_to_val evaluate_expr ctx m ty o) runtime_to_val evaluate_expr ctx m ty o
| EApp { f = e1; args } -> ( | EApp { f = e1; args } -> (
let e1 = evaluate_expr ctx e1 in let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args in let args = List.map (evaluate_expr ctx) args in

9
compiler/shared_ast/optimizations.ml
View File

@ -409,10 +409,13 @@ let test_iota_reduction_2 () =
let matchA = let matchA =
Expr.ematch Expr.ematch
~e:(Expr.ematch ~e:(num 1) ~name:enumT ~e:
~cases:(cases_of_list (Expr.ematch ~e:(num 1) ~name:enumT
~cases:
(cases_of_list
[ [
(consB, fun x -> injBe (injB x)); (consA, fun _x -> injAe (num 20)); (consB, fun x -> injBe (injB x));
(consA, fun _x -> injAe (num 20));
]) ])
nomark) nomark)
~name:enumT ~name:enumT

38
compiler/shared_ast/print.ml
View File

@ -73,10 +73,10 @@ let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
let module_name ppf m = Format.fprintf ppf "@{<blue>%a@}" ModuleName.format m let module_name ppf m = Format.fprintf ppf "@{<blue>%a@}" ModuleName.format m
let path ppf p = let path ppf p =
Format.pp_print_list ~pp_sep:(fun _ () -> ()) Format.pp_print_list
~pp_sep:(fun _ () -> ())
(fun ppf m -> (fun ppf m ->
Format.fprintf ppf "%a@{<cyan>.@}" Format.fprintf ppf "%a@{<cyan>.@}" module_name (Mark.remove m))
module_name (Mark.remove m))
ppf p ppf p
let location (type a) (fmt : Format.formatter) (l : a glocation) : unit = let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
@ -103,11 +103,12 @@ let external_ref fmt er =
let rec module_ctx ctx = function let rec module_ctx ctx = function
| [] -> ctx | [] -> ctx
| (modname, mpos) :: path -> | (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctx.ctx_modules with match ModuleName.Map.find_opt modname ctx.ctx_modules with
| None -> | None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
| Some ctx -> module_ctx ctx path modname
| Some ctx -> module_ctx ctx path)
let rec typ_gen let rec typ_gen
(ctx : decl_ctx option) (ctx : decl_ctx option)
@ -137,15 +138,14 @@ let rec typ_gen
pp_color_string (List.hd colors) fmt ")" pp_color_string (List.hd colors) fmt ")"
| TStruct s -> ( | TStruct s -> (
match ctx with match ctx with
| None -> | None -> StructName.format fmt s
StructName.format fmt s
| Some ctx -> | Some ctx ->
let p, fields = StructName.Map.find s ctx.ctx_structs in let p, fields = StructName.Map.find s ctx.ctx_structs in
if StructField.Map.is_empty fields then if StructField.Map.is_empty fields then (
(path fmt p; StructName.format fmt s) path fmt p;
StructName.format fmt s)
else else
Format.fprintf fmt "@[<hv 2>%a%a %a@,%a@;<0 -2>%a@]" Format.fprintf fmt "@[<hv 2>%a%a %a@,%a@;<0 -2>%a@]" path p
path p
StructName.format s StructName.format s
(pp_color_string (List.hd colors)) (pp_color_string (List.hd colors))
"{" "{"
@ -166,14 +166,14 @@ let rec typ_gen
| None -> Format.fprintf fmt "@[<hov 2>%a@]" EnumName.format e | None -> Format.fprintf fmt "@[<hov 2>%a@]" EnumName.format e
| Some ctx -> | Some ctx ->
let p, def = EnumName.Map.find e ctx.ctx_enums in let p, def = EnumName.Map.find e ctx.ctx_enums in
Format.fprintf fmt "@[<hov 2>%a%a%a%a%a@]" path p EnumName.format e punctuation "[" Format.fprintf fmt "@[<hov 2>%a%a%a%a%a@]" path p EnumName.format e
punctuation "["
(EnumConstructor.Map.format_bindings (EnumConstructor.Map.format_bindings
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|")
(fun fmt pp_case mty -> (fun fmt pp_case mty ->
Format.fprintf fmt "%t%a@ %a" pp_case punctuation ":" (typ ~colors) Format.fprintf fmt "%t%a@ %a" pp_case punctuation ":" (typ ~colors)
mty)) mty))
def def punctuation "]")
punctuation "]")
| TOption t -> | TOption t ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "eoption" (typ ~colors) t Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "eoption" (typ ~colors) t
| TArrow ([t1], t2) -> | TArrow ([t1], t2) ->
@ -871,9 +871,9 @@ let enum
decl_ctx decl_ctx
fmt fmt
(pp_name : Format.formatter -> unit) (pp_name : Format.formatter -> unit)
(p, c : path * typ EnumConstructor.Map.t) = ((p, c) : path * typ EnumConstructor.Map.t) =
Format.fprintf fmt "@[<h 0>%a %a%t %a@ %a@]" keyword "type" path p pp_name punctuation Format.fprintf fmt "@[<h 0>%a %a%t %a@ %a@]" keyword "type" path p pp_name
"=" punctuation "="
(EnumConstructor.Map.format_bindings (EnumConstructor.Map.format_bindings
~pp_sep:(fun _ _ -> ()) ~pp_sep:(fun _ _ -> ())
(fun fmt pp_n ty -> (fun fmt pp_n ty ->
@ -888,7 +888,7 @@ let struct_
decl_ctx decl_ctx
fmt fmt
(pp_name : Format.formatter -> unit) (pp_name : Format.formatter -> unit)
(p, c : path * typ StructField.Map.t) = ((p, c) : path * typ StructField.Map.t) =
Format.fprintf fmt "@[<hv 0>@[<hv 2>@[<h>%a %a%t %a@;%a@]@;%a@]%a@]@;" keyword Format.fprintf fmt "@[<hv 0>@[<hv 2>@[<h>%a %a%t %a@;%a@]@;%a@]%a@]@;" keyword
"type" path p pp_name punctuation "=" punctuation "{" "type" path p pp_name punctuation "=" punctuation "{"
(StructField.Map.format_bindings (StructField.Map.format_bindings

7
compiler/shared_ast/program.ml
View File

@ -41,11 +41,12 @@ let empty_ctx =
let rec module_ctx ctx = function let rec module_ctx ctx = function
| [] -> ctx | [] -> ctx
| (modname, mpos) :: path -> | (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctx.ctx_modules with match ModuleName.Map.find_opt modname ctx.ctx_modules with
| None -> | None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
| Some ctx -> module_ctx ctx path modname
| Some ctx -> module_ctx ctx path)
let get_scope_body { code_items; _ } scope = let get_scope_body { code_items; _ } scope =
match match

3
compiler/shared_ast/program.mli
View File

@ -23,7 +23,8 @@ open Definitions
val empty_ctx : decl_ctx val empty_ctx : decl_ctx
val module_ctx : decl_ctx -> ModuleName.t Mark.pos list -> decl_ctx val module_ctx : decl_ctx -> ModuleName.t Mark.pos list -> decl_ctx
(** Follows a path to get the corresponding context for type and value declarations. Errors out if the module is not found *) (** Follows a path to get the corresponding context for type and value
declarations. Errors out if the module is not found *)
(** {2 Transformations} *) (** {2 Transformations} *)

4
compiler/shared_ast/scope.mli
View File

@ -1,5 +1,5 @@
(* This file is part of the Catala compiler, a specification language for tax (* This file is part of the Catala compiler, a specification language for tax <
< and social benefits computation rules. Copyright (C) 2020-2022 Inria, and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr> <alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>

65
compiler/shared_ast/typing.ml
View File

@ -125,13 +125,16 @@ let rec format_typ
"(" "("
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> (fun fmt t -> format_typ fmt ~colors:(List.tl colors) t))
format_typ fmt ~colors:(List.tl colors) t))
ts ts
(pp_color_string (List.hd colors)) (pp_color_string (List.hd colors))
")" ")"
| TStruct s -> Print.path fmt (fst (A.StructName.Map.find s ctx.A.ctx_structs)); A.StructName.format fmt s | TStruct s ->
| TEnum e -> Print.path fmt (fst (A.EnumName.Map.find e ctx.A.ctx_enums)); A.EnumName.format fmt e Print.path fmt (fst (A.StructName.Map.find s ctx.A.ctx_structs));
A.StructName.format fmt s
| TEnum e ->
Print.path fmt (fst (A.EnumName.Map.find e ctx.A.ctx_enums));
A.EnumName.format fmt e
| TOption t -> | TOption t ->
Format.fprintf fmt "@[<hov 2>option %a@]" Format.fprintf fmt "@[<hov 2>option %a@]"
(format_typ_with_parens ~colors:(List.tl colors)) (format_typ_with_parens ~colors:(List.tl colors))
@ -346,10 +349,12 @@ module Env = struct
let rec module_env path env = let rec module_env path env =
match path with match path with
| [] -> env | [] -> env
| (modname, mpos) :: path -> | (modname, mpos) :: path -> (
match A.ModuleName.Map.find_opt modname env.modules with match A.ModuleName.Map.find_opt modname env.modules with
| None -> Message.raise_spanned_error mpos "Module %a not found" A.ModuleName.format modname | None ->
| Some env -> module_env path env Message.raise_spanned_error mpos "Module %a not found"
A.ModuleName.format modname
| Some env -> module_env path env)
let add v tau t = { t with vars = Var.Map.add v tau t.vars } let add v tau t = { t with vars = Var.Map.add v tau t.vars }
let add_var v typ t = add v (ast_to_typ typ) t let add_var v typ t = add v (ast_to_typ typ) t
@ -447,12 +452,8 @@ and typecheck_expr_top_down :
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty)) Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
| A.EStruct { name; fields } -> | A.EStruct { name; fields } ->
let mark = ty_mark (TStruct name) in let mark = ty_mark (TStruct name) in
let _path, str_ast = let _path, str_ast = A.StructName.Map.find name ctx.A.ctx_structs in
A.StructName.Map.find name ctx.A.ctx_structs let str = A.StructName.Map.find name env.structs in
in
let str =
A.StructName.Map.find name env.structs
in
let _check_fields : unit = let _check_fields : unit =
let missing_fields, extra_fields = let missing_fields, extra_fields =
A.StructField.Map.fold A.StructField.Map.fold
@ -627,14 +628,11 @@ and typecheck_expr_top_down :
in in
Expr.ematch ~e:e1' ~name ~cases mark Expr.ematch ~e:e1' ~name ~cases mark
| A.EMatch { e = e1; name; cases } -> | A.EMatch { e = e1; name; cases } ->
let _path, cases_ty = let _path, cases_ty = A.EnumName.Map.find name ctx.A.ctx_enums in
A.EnumName.Map.find name ctx.A.ctx_enums
in
let t_ret = unionfind ~pos:e1 (TAny (Any.fresh ())) in let t_ret = unionfind ~pos:e1 (TAny (Any.fresh ())) in
let mark = mark_with_tau_and_unify t_ret in let mark = mark_with_tau_and_unify t_ret in
let e1' = let e1' =
typecheck_expr_top_down ~leave_unresolved ctx env typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TEnum name))
(unionfind (TEnum name))
e1 e1
in in
let cases = let cases =
@ -688,20 +686,21 @@ and typecheck_expr_top_down :
let ty = let ty =
let not_found pr x = let not_found pr x =
Message.raise_spanned_error pos_e Message.raise_spanned_error pos_e
"Could not resolve the reference to %a%a.@ Make sure the corresponding \ "Could not resolve the reference to %a%a.@ Make sure the \
module was properly loaded?" corresponding module was properly loaded?"
Print.path path Print.path path pr x
pr x
in in
match Mark.remove name with match Mark.remove name with
| A.External_value name -> | A.External_value name -> (
(try try ast_to_typ (A.TopdefName.Map.find name ctx.ctx_topdefs)
ast_to_typ (A.TopdefName.Map.find name ctx.ctx_topdefs) with A.TopdefName.Map.Not_found _ ->
with A.TopdefName.Map.Not_found _ -> not_found A.TopdefName.format name) not_found A.TopdefName.format name)
| A.External_scope name -> | A.External_scope name -> (
(try try
let scope_info = A.ScopeName.Map.find name ctx.ctx_scopes in let scope_info = A.ScopeName.Map.find name ctx.ctx_scopes in
ast_to_typ (TArrow ([TStruct scope_info.in_struct_name, pos_e], ast_to_typ
( TArrow
( [TStruct scope_info.in_struct_name, pos_e],
(TStruct scope_info.out_struct_name, pos_e) ), (TStruct scope_info.out_struct_name, pos_e) ),
pos_e ) pos_e )
with A.ScopeName.Map.Not_found _ -> not_found A.ScopeName.format name) with A.ScopeName.Map.Not_found _ -> not_found A.ScopeName.format name)
@ -1033,7 +1032,7 @@ let program ~leave_unresolved prg =
ctx_structs = ctx_structs =
A.StructName.Map.mapi A.StructName.Map.mapi
(fun s_name (path, fields) -> (fun s_name (path, fields) ->
path, ( path,
A.StructField.Map.mapi A.StructField.Map.mapi
(fun f_name (t : A.typ) -> (fun f_name (t : A.typ) ->
match Mark.remove t with match Mark.remove t with
@ -1042,12 +1041,12 @@ let program ~leave_unresolved prg =
(A.StructField.Map.find f_name (A.StructField.Map.find f_name
(A.StructName.Map.find s_name new_env.structs)) (A.StructName.Map.find s_name new_env.structs))
| _ -> t) | _ -> t)
fields) fields ))
prg.decl_ctx.ctx_structs; prg.decl_ctx.ctx_structs;
ctx_enums = ctx_enums =
A.EnumName.Map.mapi A.EnumName.Map.mapi
(fun e_name (path, cons) -> (fun e_name (path, cons) ->
path, ( path,
A.EnumConstructor.Map.mapi A.EnumConstructor.Map.mapi
(fun cons_name (t : A.typ) -> (fun cons_name (t : A.typ) ->
match Mark.remove t with match Mark.remove t with
@ -1056,7 +1055,7 @@ let program ~leave_unresolved prg =
(A.EnumConstructor.Map.find cons_name (A.EnumConstructor.Map.find cons_name
(A.EnumName.Map.find e_name new_env.enums)) (A.EnumName.Map.find e_name new_env.enums))
| _ -> t) | _ -> t)
cons) cons ))
prg.decl_ctx.ctx_enums; prg.decl_ctx.ctx_enums;
}; };
} }

1
compiler/shared_ast/var.ml
View File

@ -92,6 +92,7 @@ module Map = struct
open M open M
type k0 = M.key type k0 = M.key
exception Not_found = M.Not_found exception Not_found = M.Not_found
type nonrec ('e, 'x) t = 'x t type nonrec ('e, 'x) t = 'x t

2
compiler/shared_ast/var.mli
View File

@ -57,8 +57,8 @@ end
Extend as needed *) Extend as needed *)
module Map : sig module Map : sig
type ('e, 'x) t type ('e, 'x) t
type k0 type k0
exception Not_found of k0 exception Not_found of k0
val empty : ('e, 'x) t val empty : ('e, 'x) t

3
compiler/surface/ast.ml
View File

@ -310,7 +310,8 @@ and law_structure =
| CodeBlock of code_block * source_repr * bool (* Metadata if true *) | CodeBlock of code_block * source_repr * bool (* Metadata if true *)
and interface = code_block and interface = code_block
(** Invariant: an interface shall only contain [*Decl] elements, or [Topdef] elements with [topdef_expr = None] *) (** Invariant: an interface shall only contain [*Decl] elements, or [Topdef]
elements with [topdef_expr = None] *)
and program = { and program = {
program_items : law_structure list; program_items : law_structure list;

8
compiler/surface/parser_driver.ml
View File

@ -231,7 +231,7 @@ let rec parse_source_file
{ {
program_items = program.Ast.program_items; program_items = program.Ast.program_items;
program_source_files = source_file_name :: program.Ast.program_source_files; program_source_files = source_file_name :: program.Ast.program_source_files;
program_modules = [] program_modules = [];
} }
(** Expands the include directives in a parsing result, thus parsing new source (** Expands the include directives in a parsing result, thus parsing new source
@ -267,8 +267,7 @@ and expand_includes
Ast.program_source_files = acc.Ast.program_source_files @ new_sources; Ast.program_source_files = acc.Ast.program_source_files @ new_sources;
Ast.program_items = Ast.program_items =
acc.Ast.program_items @ [Ast.LawHeading (heading, commands')]; acc.Ast.program_items @ [Ast.LawHeading (heading, commands')];
Ast.program_modules = Ast.program_modules = acc.Ast.program_modules @ new_modules;
acc.Ast.program_modules @ new_modules;
} }
| i -> { acc with Ast.program_items = acc.Ast.program_items @ [i] }) | i -> { acc with Ast.program_items = acc.Ast.program_items @ [i] })
{ {
@ -302,8 +301,7 @@ let get_interface program =
(** {1 API} *) (** {1 API} *)
let load_interface source_file language = let load_interface source_file language =
parse_source_file source_file language parse_source_file source_file language |> get_interface
|> get_interface
let parse_top_level_file let parse_top_level_file
(source_file : Cli.input_file) (source_file : Cli.input_file)

11
compiler/surface/parser_driver.mli
View File

@ -19,11 +19,10 @@
open Catala_utils open Catala_utils
val load_interface : val load_interface : Cli.input_file -> Cli.backend_lang -> Ast.interface
Cli.input_file -> (** Reads only declarations in metadata in the supplied input file, and only
Cli.backend_lang -> keeps type information *)
Ast.interface
(** Reads only declarations in metadata in the supplied input file, and only keeps type information *)
val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program
(** Parses a catala file (handling file includes) and returns a program. Modules in the program are returned empty, use [load_interface] to fill them. *) (** Parses a catala file (handling file includes) and returns a program. Modules
in the program are returned empty, use [load_interface] to fill them. *)

12
compiler/verification/z3backend.real.ml
View File

@ -667,11 +667,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
accesses *) accesses *)
let accessors = List.hd (Datatype.get_accessors z3_struct) in let accessors = List.hd (Datatype.get_accessors z3_struct) in
let _path, fields = StructName.Map.find name ctx.ctx_decl.ctx_structs in let _path, fields = StructName.Map.find name ctx.ctx_decl.ctx_structs in
let idx_mappings = let idx_mappings = List.combine (StructField.Map.keys fields) accessors in
List.combine
(StructField.Map.keys fields)
accessors
in
let _, accessor = let _, accessor =
List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings
in in
@ -687,11 +683,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
let ctrs = Datatype.get_constructors z3_enum in let ctrs = Datatype.get_constructors z3_enum in
let _path, cons_map = EnumName.Map.find name ctx.ctx_decl.ctx_enums in let _path, cons_map = EnumName.Map.find name ctx.ctx_decl.ctx_enums in
(* This should always succeed if the expression is well-typed in dcalc *) (* This should always succeed if the expression is well-typed in dcalc *)
let idx_mappings = let idx_mappings = List.combine (EnumConstructor.Map.keys cons_map) ctrs in
List.combine
(EnumConstructor.Map.keys cons_map)
ctrs
in
let _, ctr = let _, ctr =
List.find List.find
(fun (cons1, _) -> EnumConstructor.equal cons cons1) (fun (cons1, _) -> EnumConstructor.equal cons cons1)