CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 16:28:12 +03:00
Code Issues Projects Releases Wiki Activity

Add ambiguous StructAccess for desugared

Browse Source 
to be resolved in scopelang
This commit is contained in:
Louis Gesbert 2022-11-22 20:57:59 +01:00
parent c92fe5e72d
commit 3f2aa19e97
21 changed files with 284 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
compiler/catala_utils/string.ml
View File

@ -47,3 +47,8 @@ let to_camel_case (s : string) : string =
else c_string;
last_was_underscore := is_underscore);
!out
let format_t = Format.pp_print_string
module Set = Set.Make (Stdlib.String)
module Map = Map.Make (Stdlib.String)

4
compiler/catala_utils/string.mli
View File

@ -15,6 +15,8 @@
the License. *)
include module type of Stdlib.String
module Set : Set.S with type elt = string
module Map : Map.S with type key = string
(** Helper functions used for string manipulation. *)
@ -36,3 +38,5 @@ val to_snake_case : string -> string
val to_camel_case : string -> string
(** Converts snake_case into CamlCase after removing Remove all diacritics on
Latin letters. *)
val format_t : Format.formatter -> string -> unit

2
compiler/dcalc/from_scopelang.ml
View File

@ -363,7 +363,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
m
| EOp op -> Expr.eop op m
| EOp op -> Expr.eop (Expr.translate_op op) m
| EErrorOnEmpty e' -> Expr.eerroronempty (translate_expr ctx e') m
| EArray es -> Expr.earray (List.map (translate_expr ctx) es) m

2
compiler/dcalc/interpreter.ml
View File

@ -31,7 +31,7 @@ let log_indent = ref 0
let rec evaluate_operator
(ctx : decl_ctx)
(op : operator)
(op : dcalc operator)
(pos : Pos.t)
(args : 'm Ast.expr list) : 'm Ast.naked_expr =
(* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use

104
compiler/desugared/from_surface.ml
View File

@ -27,15 +27,15 @@ module Runtime = Runtime_ocaml.Runtime
(** {1 Translating expressions} *)
let translate_op_kind (k : Surface.Ast.op_kind) : op_kind =
let translate_op_kind (k : Surface.Ast.op_kind) : desugared op_kind =
match k with
| KInt -> KInt
| KDec -> KRat
| KMoney -> KMoney
| KDate -> KDate
| KDuration -> KDuration
| Surface.Ast.KInt -> KInt
| Surface.Ast.KDec -> KRat
| Surface.Ast.KMoney -> KMoney
| Surface.Ast.KDate -> KDate
| Surface.Ast.KDuration -> KDuration
let translate_binop (op : Surface.Ast.binop) : binop =
let translate_binop (op : Surface.Ast.binop) : desugared binop =
match op with
| And -> And
| Or -> Or
@ -52,7 +52,7 @@ let translate_binop (op : Surface.Ast.binop) : binop =
| Neq -> Neq
| Concat -> Concat
let translate_unop (op : Surface.Ast.unop) : unop =
let translate_unop (op : Surface.Ast.unop) : desugared unop =
match op with Not -> Not | Minus l -> Minus (translate_op_kind l)
let disambiguate_constructor
@ -67,10 +67,7 @@ let disambiguate_constructor
"The deep pattern matching syntactic sugar is not yet supported"
in
let possible_c_uids =
try
Name_resolution.IdentMap.find
(Marked.unmark constructor)
ctxt.constructor_idmap
try IdentName.Map.find (Marked.unmark constructor) ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
(Marked.get_mark constructor)
@ -204,9 +201,9 @@ let rec translate_expr
| Ident x -> (
(* first we check whether this is a local var, then we resort to scope-wide
variables *)
match Name_resolution.IdentMap.find_opt x ctxt.local_var_idmap with
match IdentName.Map.find_opt x ctxt.local_var_idmap with
| None -> (
match Name_resolution.IdentMap.find_opt x scope_ctxt.var_idmap with
match IdentName.Map.find_opt x scope_ctxt.var_idmap with
| Some (ScopeVar uid) ->
(* If the referenced variable has states, then here are the rules to
desambiguate. In general, only the last state can be referenced.
@ -258,7 +255,7 @@ let rec translate_expr
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
(* In this case, y.x is a subscope variable *)
let subscope_uid, subscope_real_uid =
match Name_resolution.IdentMap.find y scope_ctxt.var_idmap with
match IdentName.Map.find y scope_ctxt.var_idmap with
| SubScope (sub, sc) -> sub, sc
| ScopeVar _ -> assert false
in
@ -269,42 +266,19 @@ let rec translate_expr
(SubScopeVar
(subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos)))
emark
| _ -> (
| _ ->
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope inside_definition_of ctxt e in
let x_possible_structs =
try Name_resolution.IdentMap.find (Marked.unmark x) ctxt.field_idmap
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark x)
"Unknown subscope or struct field name"
let str =
Option.map
(fun c ->
try Name_resolution.get_struct ctxt c
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c)
"Struct %s has not been defined before" (Marked.unmark c))
c
in
match c with
| None ->
(* No constructor name was specified *)
if StructName.Map.cardinal x_possible_structs > 1 then
Errors.raise_spanned_error (Marked.get_mark x)
"This struct field name is ambiguous, it can belong to %a. \
Disambiguate it by prefixing it with the struct name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" StructName.format_t s_name))
(StructName.Map.bindings x_possible_structs)
else
let s_uid, f_uid = StructName.Map.choose x_possible_structs in
Expr.estructaccess e f_uid s_uid emark
| Some c_name -> (
try
let c_uid = Name_resolution.get_struct ctxt c_name in
try
let f_uid = StructName.Map.find c_uid x_possible_structs in
Expr.estructaccess e f_uid c_uid emark
with Not_found ->
Errors.raise_spanned_error pos "Struct %s does not contain field %s"
(Marked.unmark c_name) (Marked.unmark x)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c_name)
"Struct %s has not been defined before" (Marked.unmark c_name))))
Expr.edstructaccess e (Marked.unmark x) str emark)
| FunCall (f, arg) -> Expr.eapp (rec_helper f) [rec_helper arg] emark
| ScopeCall (sc_name, fields) ->
let called_scope = Name_resolution.get_scope ctxt sc_name in
@ -314,8 +288,7 @@ let rec translate_expr
(fun acc (fld_id, e) ->
let var =
match
Name_resolution.IdentMap.find_opt (Marked.unmark fld_id)
scope_def.var_idmap
IdentName.Map.find_opt (Marked.unmark fld_id) scope_def.var_idmap
with
| Some (ScopeVar v) -> v
| Some (SubScope _) | None ->
@ -352,9 +325,7 @@ let rec translate_expr
Expr.eapp fn [rec_helper e1] emark
| StructLit (s_name, fields) ->
let s_uid =
match
Name_resolution.IdentMap.find_opt (Marked.unmark s_name) ctxt.typedefs
with
match IdentName.Map.find_opt (Marked.unmark s_name) ctxt.typedefs with
| Some (Name_resolution.TStruct s_uid) -> s_uid
| _ ->
Errors.raise_spanned_error (Marked.get_mark s_name)
@ -367,8 +338,7 @@ let rec translate_expr
let f_uid =
try
StructName.Map.find s_uid
(Name_resolution.IdentMap.find (Marked.unmark f_name)
ctxt.field_idmap)
(IdentName.Map.find (Marked.unmark f_name) ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark f_name)
"This identifier should refer to a field of struct %s"
@ -396,7 +366,7 @@ let rec translate_expr
Expr.estruct s_uid s_fields emark
| EnumInject (enum, (constructor, pos_constructor), payload) -> (
let possible_c_uids =
try Name_resolution.IdentMap.find constructor ctxt.constructor_idmap
try IdentName.Map.find constructor ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error pos_constructor
"The name of this constructor has not been defined before, maybe it \
@ -597,12 +567,12 @@ let rec translate_expr
Expr.make_var acc_var (Untyped { pos = Marked.get_mark param' })
in
let f_body =
let make_body (op : binop) =
let make_body (op : desugared binop) =
Expr.eapp (Expr.eop (Binop op) mark)
[acc; translate_expr scope inside_definition_of ctxt predicate]
emark
in
let make_extr_body (cmp_op : binop) (t : typ) =
let make_extr_body (cmp_op : desugared binop) (t : typ) =
let tmp_var = Var.make "tmp" in
let tmp =
Expr.make_var tmp_var (Untyped { pos = Marked.get_mark param' })
@ -963,8 +933,7 @@ let process_def
match def.definition_label with
| Some (label_str, label_pos) ->
Ast.ExplicitlyLabeled
( Name_resolution.IdentMap.find label_str scope_def_ctxt.label_idmap,
label_pos )
(IdentName.Map.find label_str scope_def_ctxt.label_idmap, label_pos)
| None -> Ast.Unlabeled
in
let exception_situation =
@ -981,7 +950,7 @@ let process_def
| ExceptionToLabel label_str -> (
try
let label_id =
Name_resolution.IdentMap.find (Marked.unmark label_str)
IdentName.Map.find (Marked.unmark label_str)
scope_def_ctxt.label_idmap
in
ExceptionToLabel (label_id, Marked.get_mark label_str)
@ -1157,8 +1126,7 @@ let attribute_to_io (attr : Surface.Ast.scope_decl_context_io) : Ast.io =
let init_scope_defs
(ctxt : Name_resolution.context)
(scope_idmap :
Name_resolution.scope_var_or_subscope Name_resolution.IdentMap.t) :
(scope_idmap : Name_resolution.scope_var_or_subscope IdentName.Map.t) :
Ast.scope_def Ast.ScopeDefMap.t =
(* Initializing the definitions of all scopes and subscope vars, with no rules
yet inside *)
@ -1213,7 +1181,7 @@ let init_scope_defs
let sub_scope_def =
ScopeName.Map.find subscope_uid ctxt.Name_resolution.scopes
in
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ v scope_def_map ->
match v with
| Name_resolution.SubScope _ -> scope_def_map
@ -1235,7 +1203,7 @@ let init_scope_defs
scope_def_map)
sub_scope_def.Name_resolution.var_idmap scope_def_map
in
Name_resolution.IdentMap.fold add_def scope_idmap Ast.ScopeDefMap.empty
IdentName.Map.fold add_def scope_idmap Ast.ScopeDefMap.empty
(** Main function of this module *)
let translate_program
@ -1246,7 +1214,7 @@ let translate_program
ScopeName.Map.mapi
(fun s_uid s_context ->
let scope_vars =
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ v acc ->
match v with
| Name_resolution.SubScope _ -> acc
@ -1258,7 +1226,7 @@ let translate_program
s_context.Name_resolution.var_idmap ScopeVar.Map.empty
in
let scope_sub_scopes =
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ v acc ->
match v with
| Name_resolution.ScopeVar _ -> acc
@ -1282,7 +1250,7 @@ let translate_program
ctx_structs = ctxt.Name_resolution.structs;
ctx_enums = ctxt.Name_resolution.enums;
ctx_scopes =
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ def acc ->
match def with
| Name_resolution.TScope (scope, scope_out_struct) ->

108
compiler/desugared/name_resolution.ml
View File

@ -23,17 +23,13 @@ open Shared_ast
(** {1 Name resolution context} *)
type ident = string
module IdentMap : Map.S with type key = String.t = Map.Make (String)
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of RuleName.t Marked.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
label_idmap : LabelName.t IdentMap.t;
label_idmap : LabelName.t IdentName.Map.t;
}
type scope_var_or_subscope =
@ -41,7 +37,7 @@ type scope_var_or_subscope =
| SubScope of SubScopeName.t * ScopeName.t
type scope_context = {
var_idmap : scope_var_or_subscope IdentMap.t;
var_idmap : scope_var_or_subscope IdentName.Map.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
@ -60,7 +56,7 @@ type var_sig = {
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_io : Surface.Ast.scope_decl_context_io;
var_sig_states_idmap : StateName.t IdentMap.t;
var_sig_states_idmap : StateName.t IdentName.Map.t;
var_sig_states_list : StateName.t list;
}
@ -73,15 +69,15 @@ type typedef =
(** Implicitly defined output struct *)
type context = {
local_var_idmap : Ast.expr Var.t IdentMap.t;
local_var_idmap : Ast.expr Var.t IdentName.Map.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
typedefs : typedef IdentMap.t;
typedefs : typedef IdentName.Map.t;
(** Gathers the names of the scopes, structs and enums *)
field_idmap : StructField.t StructName.Map.t IdentMap.t;
field_idmap : StructField.t StructName.Map.t IdentName.Map.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
constructor_idmap : EnumConstructor.t EnumName.Map.t IdentMap.t;
constructor_idmap : EnumConstructor.t EnumName.Map.t IdentName.Map.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
@ -102,7 +98,7 @@ let raise_unsupported_feature (msg : string) (pos : Pos.t) =
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
let raise_unknown_identifier (msg : string) (ident : ident Marked.pos) =
let raise_unknown_identifier (msg : string) (ident : IdentName.t Marked.pos) =
Errors.raise_spanned_error (Marked.get_mark ident)
"\"%s\": unknown identifier %s"
(Cli.with_style [ANSITerminal.yellow] "%s" (Marked.unmark ident))
@ -123,9 +119,9 @@ let get_var_io (ctxt : context) (uid : ScopeVar.t) :
let get_var_uid
(scope_uid : ScopeName.t)
(ctxt : context)
((x, pos) : ident Marked.pos) : ScopeVar.t =
((x, pos) : IdentName.t Marked.pos) : ScopeVar.t =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentMap.find_opt x scope.var_idmap with
match IdentName.Map.find_opt x scope.var_idmap with
| Some (ScopeVar uid) -> uid
| _ ->
raise_unknown_identifier
@ -136,18 +132,18 @@ let get_var_uid
let get_subscope_uid
(scope_uid : ScopeName.t)
(ctxt : context)
((y, pos) : ident Marked.pos) : SubScopeName.t =
((y, pos) : IdentName.t Marked.pos) : SubScopeName.t =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentMap.find_opt y scope.var_idmap with
match IdentName.Map.find_opt y scope.var_idmap with
| Some (SubScope (sub_uid, _sub_id)) -> sub_uid
| _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : ident) :
bool =
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : IdentName.t)
: bool =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentMap.find_opt y scope.var_idmap with
match IdentName.Map.find_opt y scope.var_idmap with
| Some (SubScope _) -> true
| _ -> false
@ -155,7 +151,7 @@ let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : ident) :
let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) :
bool =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
IdentMap.exists
IdentName.Map.exists
(fun _ -> function
| ScopeVar var_uid -> ScopeVar.equal uid var_uid
| _ -> false)
@ -179,7 +175,7 @@ let is_def_cond (ctxt : context) (def : Ast.ScopeDef.t) : bool =
is_var_cond ctxt x
let get_enum ctxt id =
match IdentMap.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
| TEnum id -> id
| TStruct sid ->
Errors.raise_multispanned_error
@ -200,7 +196,7 @@ let get_enum ctxt id =
(Marked.unmark id)
let get_struct ctxt id =
match IdentMap.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Errors.raise_multispanned_error
@ -214,7 +210,7 @@ let get_struct ctxt id =
(Marked.unmark id)
let get_scope ctxt id =
match IdentMap.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Errors.raise_multispanned_error
@ -244,7 +240,7 @@ let process_subscope_decl
let name, name_pos = decl.scope_decl_context_scope_name in
let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match IdentMap.find_opt subscope scope_ctxt.var_idmap with
match IdentName.Map.find_opt subscope scope_ctxt.var_idmap with
| Some use ->
let info =
match use with
@ -265,7 +261,7 @@ let process_subscope_decl
{
scope_ctxt with
var_idmap =
IdentMap.add name
IdentName.Map.add name
(SubScope (sub_scope_uid, original_subscope_uid))
scope_ctxt.var_idmap;
sub_scopes =
@ -302,7 +298,7 @@ let rec process_base_typ
| Surface.Ast.Boolean -> TLit TBool, typ_pos
| Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Surface.Ast.Named ident -> (
match IdentMap.find_opt ident ctxt.typedefs with
match IdentName.Map.find_opt ident ctxt.typedefs with
| Some (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum e_uid, typ_pos
| Some (TScope (_, scope_str)) ->
@ -332,7 +328,7 @@ let process_data_decl
let is_cond = is_type_cond decl.scope_decl_context_item_typ in
let name, pos = decl.scope_decl_context_item_name in
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match IdentMap.find_opt name scope_ctxt.var_idmap with
match IdentName.Map.find_opt name scope_ctxt.var_idmap with
| Some use ->
let info =
match use with
@ -349,16 +345,16 @@ let process_data_decl
let scope_ctxt =
{
scope_ctxt with
var_idmap = IdentMap.add name (ScopeVar uid) scope_ctxt.var_idmap;
var_idmap = IdentName.Map.add name (ScopeVar uid) scope_ctxt.var_idmap;
}
in
let states_idmap, states_list =
List.fold_right
(fun state_id (states_idmap, states_list) ->
let state_uid = StateName.fresh state_id in
( IdentMap.add (Marked.unmark state_id) state_uid states_idmap,
( IdentName.Map.add (Marked.unmark state_id) state_uid states_idmap,
state_uid :: states_list ))
decl.scope_decl_context_item_states (IdentMap.empty, [])
decl.scope_decl_context_item_states (IdentName.Map.empty, [])
in
{
ctxt with
@ -376,13 +372,14 @@ let process_data_decl
}
(** Adds a binding to the context *)
let add_def_local_var (ctxt : context) (name : ident) : context * Ast.expr Var.t
=
let add_def_local_var (ctxt : context) (name : IdentName.t) :
context * Ast.expr Var.t =
let local_var_uid = Var.make name in
let ctxt =
{
ctxt with
local_var_idmap = IdentMap.add name local_var_uid ctxt.local_var_idmap;
local_var_idmap =
IdentName.Map.add name local_var_uid ctxt.local_var_idmap;
}
in
ctxt, local_var_uid
@ -404,7 +401,7 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
{
ctxt with
field_idmap =
IdentMap.update
IdentName.Map.update
(Marked.unmark fdecl.Surface.Ast.struct_decl_field_name)
(fun uids ->
match uids with
@ -449,7 +446,7 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
{
ctxt with
constructor_idmap =
IdentMap.update
IdentName.Map.update
(Marked.unmark cdecl.Surface.Ast.enum_decl_case_name)
(fun uids ->
match uids with
@ -537,21 +534,21 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
let out_struct_fields =
let sco = ScopeName.Map.find scope_uid ctxt.scopes in
let str = get_struct ctxt decl.scope_decl_name in
IdentMap.fold
IdentName.Map.fold
(fun id var svmap ->
match var with
| SubScope _ -> svmap
| ScopeVar v -> (
try
let field =
StructName.Map.find str (IdentMap.find id ctxt.field_idmap)
StructName.Map.find str (IdentName.Map.find id ctxt.field_idmap)
in
ScopeVar.Map.add v field svmap
with Not_found -> svmap))
sco.var_idmap ScopeVar.Map.empty
in
let typedefs =
IdentMap.update
IdentName.Map.update
(Marked.unmark decl.scope_decl_name)
(function
| Some (TScope (scope, { out_struct_name; _ })) ->
@ -586,13 +583,13 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "scope")
(IdentMap.find_opt name ctxt.typedefs);
(IdentName.Map.find_opt name ctxt.typedefs);
let scope_uid = ScopeName.fresh (name, pos) in
let out_struct_uid = StructName.fresh (name, pos) in
{
ctxt with
typedefs =
IdentMap.add name
IdentName.Map.add name
(TScope
( scope_uid,
{
@ -603,7 +600,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
scopes =
ScopeName.Map.add scope_uid
{
var_idmap = IdentMap.empty;
var_idmap = IdentName.Map.empty;
scope_defs_contexts = Ast.ScopeDefMap.empty;
sub_scopes = ScopeName.Set.empty;
}
@ -614,12 +611,12 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "struct")
(IdentMap.find_opt name ctxt.typedefs);
(IdentName.Map.find_opt name ctxt.typedefs);
let s_uid = StructName.fresh sdecl.struct_decl_name in
{
ctxt with
typedefs =
IdentMap.add
IdentName.Map.add
(Marked.unmark sdecl.struct_decl_name)
(TStruct s_uid) ctxt.typedefs;
}
@ -628,12 +625,12 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "enum")
(IdentMap.find_opt name ctxt.typedefs);
(IdentName.Map.find_opt name ctxt.typedefs);
let e_uid = EnumName.fresh edecl.enum_decl_name in
{
ctxt with
typedefs =
IdentMap.add
IdentName.Map.add
(Marked.unmark edecl.enum_decl_name)
(TEnum e_uid) ctxt.typedefs;
}
@ -690,7 +687,8 @@ let get_def_key
| Some state -> (
try
Some
(IdentMap.find (Marked.unmark state) var_sig.var_sig_states_idmap)
(IdentName.Map.find (Marked.unmark state)
var_sig.var_sig_states_idmap)
with Not_found ->
Errors.raise_multispanned_error
[
@ -701,7 +699,7 @@ let get_def_key
"This identifier is not a state declared for variable %a."
ScopeVar.format_t x_uid)
| None ->
if not (IdentMap.is_empty var_sig.var_sig_states_idmap) then
if not (IdentName.Map.is_empty var_sig.var_sig_states_idmap) then
Errors.raise_multispanned_error
[
None, Marked.get_mark x;
@ -714,7 +712,7 @@ let get_def_key
else None )
| [y; x] ->
let (subscope_uid, subscope_real_uid) : SubScopeName.t * ScopeName.t =
match IdentMap.find_opt (Marked.unmark y) scope_ctxt.var_idmap with
match IdentName.Map.find_opt (Marked.unmark y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u
| Some _ ->
Errors.raise_spanned_error pos
@ -742,7 +740,7 @@ let update_def_key_ctx
| None -> def_key_ctx
| Some label ->
let new_label_idmap =
IdentMap.update (Marked.unmark label)
IdentName.Map.update (Marked.unmark label)
(fun existing_label ->
match existing_label with
| Some existing_label -> Some existing_label
@ -796,7 +794,7 @@ let empty_def_key_ctx =
(* Here, this is the first time we encounter a definition for this
definition key *)
default_exception_rulename = None;
label_idmap = IdentMap.empty;
label_idmap = IdentName.Map.empty;
}
let process_definition
@ -845,7 +843,7 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
=
let s_name =
match
IdentMap.find_opt
IdentName.Map.find_opt
(Marked.unmark suse.Surface.Ast.scope_use_name)
ctxt.typedefs
with
@ -873,14 +871,14 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
let form_context (prgm : Surface.Ast.program) : context =
let empty_ctxt =
{
local_var_idmap = IdentMap.empty;
typedefs = IdentMap.empty;
local_var_idmap = IdentName.Map.empty;
typedefs = IdentName.Map.empty;
scopes = ScopeName.Map.empty;
var_typs = ScopeVar.Map.empty;
structs = StructName.Map.empty;
field_idmap = IdentMap.empty;
field_idmap = IdentName.Map.empty;
enums = EnumName.Map.empty;
constructor_idmap = IdentMap.empty;
constructor_idmap = IdentName.Map.empty;
}
in
let ctxt =

34
compiler/desugared/name_resolution.mli
View File

@ -23,17 +23,13 @@ open Shared_ast
(** {1 Name resolution context} *)
type ident = string
module IdentMap : Map.S with type key = String.t
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of RuleName.t Marked.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
label_idmap : LabelName.t IdentMap.t;
label_idmap : LabelName.t IdentName.Map.t;
}
type scope_var_or_subscope =
@ -41,7 +37,7 @@ type scope_var_or_subscope =
| SubScope of SubScopeName.t * ScopeName.t
type scope_context = {
var_idmap : scope_var_or_subscope IdentMap.t;
var_idmap : scope_var_or_subscope IdentName.Map.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
@ -60,7 +56,7 @@ type var_sig = {
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_io : Surface.Ast.scope_decl_context_io;
var_sig_states_idmap : StateName.t IdentMap.t;
var_sig_states_idmap : StateName.t IdentName.Map.t;
var_sig_states_list : StateName.t list;
}
@ -73,15 +69,15 @@ type typedef =
(** Implicitly defined output struct *)
type context = {
local_var_idmap : Ast.expr Var.t IdentMap.t;
local_var_idmap : Ast.expr Var.t IdentName.Map.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
typedefs : typedef IdentMap.t;
typedefs : typedef IdentName.Map.t;
(** Gathers the names of the scopes, structs and enums *)
field_idmap : StructField.t StructName.Map.t IdentMap.t;
field_idmap : StructField.t StructName.Map.t IdentName.Map.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
constructor_idmap : EnumConstructor.t EnumName.Map.t IdentMap.t;
constructor_idmap : EnumConstructor.t EnumName.Map.t IdentName.Map.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
@ -99,7 +95,7 @@ val raise_unsupported_feature : string -> Pos.t -> 'a
(** Temporary function raising an error message saying that a feature is not
supported yet *)
val raise_unknown_identifier : string -> ident Marked.pos -> 'a
val raise_unknown_identifier : string -> IdentName.t Marked.pos -> 'a
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
@ -109,14 +105,14 @@ val get_var_typ : context -> ScopeVar.t -> typ
val is_var_cond : context -> ScopeVar.t -> bool
val get_var_io : context -> ScopeVar.t -> Surface.Ast.scope_decl_context_io
val get_var_uid : ScopeName.t -> context -> ident Marked.pos -> ScopeVar.t
val get_var_uid : ScopeName.t -> context -> IdentName.t Marked.pos -> ScopeVar.t
(** Get the variable uid inside the scope given in argument *)
val get_subscope_uid :
ScopeName.t -> context -> ident Marked.pos -> SubScopeName.t
ScopeName.t -> context -> IdentName.t Marked.pos -> SubScopeName.t
(** Get the subscope uid inside the scope given in argument *)
val is_subscope_uid : ScopeName.t -> context -> ident -> bool
val is_subscope_uid : ScopeName.t -> context -> IdentName.t -> bool
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
@ -129,7 +125,7 @@ val get_def_typ : context -> Ast.ScopeDef.t -> typ
val is_def_cond : context -> Ast.ScopeDef.t -> bool
val is_type_cond : Surface.Ast.typ -> bool
val add_def_local_var : context -> ident -> context * Ast.expr Var.t
val add_def_local_var : context -> IdentName.t -> context * Ast.expr Var.t
(** Adds a binding to the context *)
val get_def_key :
@ -141,15 +137,15 @@ val get_def_key :
Ast.ScopeDef.t
(** Usage: [get_def_key var_name var_state scope_uid ctxt pos]*)
val get_enum : context -> ident Marked.pos -> EnumName.t
val get_enum : context -> IdentName.t Marked.pos -> EnumName.t
(** Find an enum definition from the typedefs, failing if there is none or it
has a different kind *)
val get_struct : context -> ident Marked.pos -> StructName.t
val get_struct : context -> IdentName.t Marked.pos -> StructName.t
(** Find a struct definition from the typedefs (possibly an implicit output
struct from a scope), failing if there is none or it has a different kind *)
val get_scope : context -> ident Marked.pos -> ScopeName.t
val get_scope : context -> IdentName.t Marked.pos -> ScopeName.t
(** Find a scope definition from the typedefs, failing if there is none or it
has a different kind *)

8
compiler/driver.ml
View File

@ -148,20 +148,18 @@ let driver source_file (options : Cli.options) : int =
| None, _ ->
let _, scope =
try
Desugared.Name_resolution.IdentMap.filter_map
Shared_ast.IdentName.Map.filter_map
(fun _ -> function
| Desugared.Name_resolution.TScope (uid, _) -> Some uid
| _ -> None)
ctxt.typedefs
|> Desugared.Name_resolution.IdentMap.choose
|> Shared_ast.IdentName.Map.choose
with Not_found ->
Errors.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match
Desugared.Name_resolution.IdentMap.find_opt name ctxt.typedefs
with
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope \"%s\" inside the program."

2
compiler/lcalc/compile_with_exceptions.ml
View File

@ -72,7 +72,7 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
l) ->
Expr.elit l m
| ELit LEmptyError -> Expr.eraise EmptyError m
| EOp op -> Expr.eop op m
| EOp op -> Expr.eop (Expr.translate_op op) m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)

2
compiler/lcalc/compile_without_exceptions.ml
View File

@ -289,7 +289,7 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
let es', hoists = es |> List.map (translate_and_hoist ctx) |> List.split in
Expr.earray es' mark, disjoint_union_maps (Expr.pos e) hoists
| EOp op -> Expr.eop op mark, Var.Map.empty
| EOp op -> Expr.eop (Expr.translate_op op) mark, Var.Map.empty
and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.expr) :
'm A.expr boxed =

6
compiler/lcalc/to_ocaml.ml
View File

@ -54,7 +54,7 @@ let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
let format_op_kind (fmt : Format.formatter) (k : 'a op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> "!"
@ -63,7 +63,7 @@ let format_op_kind (fmt : Format.formatter) (k : op_kind) =
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
let format_binop (fmt : Format.formatter) (op : 'a binop Marked.pos) : unit =
match Marked.unmark op with
| Add k -> Format.fprintf fmt "+%a" format_op_kind k
| Sub k -> Format.fprintf fmt "-%a" format_op_kind k
@ -103,7 +103,7 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
let format_unop (fmt : Format.formatter) (op : lcalc unop Marked.pos) : unit =
match Marked.unmark op with
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
| Not -> Format.fprintf fmt "%s" "not"

2
compiler/scalc/ast.ml
View File

@ -36,7 +36,7 @@ and naked_expr =
| EArray of expr list
| ELit of L.lit
| EApp of expr * expr list
| EOp of operator
| EOp of lcalc operator
type stmt =
| SInnerFuncDef of LocalName.t Marked.pos * func

4
compiler/scalc/to_python.ml
View File

@ -49,7 +49,7 @@ let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
| EndCall -> Format.fprintf fmt "%s" "← "
| PosRecordIfTrueBool -> Format.fprintf fmt "☛ "
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
let format_binop (fmt : Format.formatter) (op : lcalc binop Marked.pos) : unit =
match Marked.unmark op with
| Add _ | Concat -> Format.fprintf fmt "+"
| Sub _ -> Format.fprintf fmt "-"
@ -89,7 +89,7 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
let format_unop (fmt : Format.formatter) (op : lcalc unop Marked.pos) : unit =
match Marked.unmark op with
| Minus _ -> Format.fprintf fmt "-"
| Not -> Format.fprintf fmt "not"

8
compiler/scopelang/from_desugared.ml
View File

@ -73,8 +73,10 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
| EStruct { name; fields } ->
Expr.estruct name (StructField.Map.map (translate_expr ctx) fields) m
| EStructAccess { e; field; name } ->
Expr.estructaccess (translate_expr ctx e) field name m
| EDStructAccess { e; field; name_opt } ->
assert false
(* TODO: resolve!! *)
(* Expr.estructaccess (translate_expr ctx e) field name_opt m *)
| EInj { e; cons; name } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { e; name; cases } ->
Expr.ematch (translate_expr ctx e) name
@ -112,7 +114,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
Expr.eabs (Expr.bind new_vars (translate_expr ctx body)) tys m
| EApp { f; args } ->
Expr.eapp (translate_expr ctx f) (List.map (translate_expr ctx) args) m
| EOp op -> Expr.eop op m
| EOp op -> Expr.eop (Expr.translate_op op) m
| EDefault { excepts; just; cons } ->
Expr.edefault
(List.map (translate_expr ctx) excepts)

85
compiler/shared_ast/definitions.ml
View File

@ -33,6 +33,10 @@ module EnumConstructor = Uid.Gen ()
module RuleName = Uid.Gen ()
module LabelName = Uid.Gen ()
(** Used for unresolved structs/maps in desugared *)
module IdentName = String
(** Only used by desugared/scopelang *)
module ScopeVar = Uid.Gen ()
@ -41,6 +45,22 @@ module StateName = Uid.Gen ()
(** {1 Abstract syntax tree} *)
(** Define a common base type for the expressions in most passes of the compiler *)
type desugared = [ `Desugared ]
(** {2 Phantom types used to select relevant cases on the generic AST}
we instantiate them with a polymorphic variant to take advantage of
sub-typing. The values aren't actually used. *)
type scopelang = [ `Scopelang ]
type dcalc = [ `Dcalc ]
type lcalc = [ `Lcalc ]
type 'a any = [< desugared | scopelang | dcalc | lcalc ] as 'a
(** ['a any] is 'a, but adds the constraint that it should be restricted to
valid AST kinds *)
(** {2 Types} *)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
@ -62,27 +82,28 @@ and naked_typ =
type date = Runtime.date
type duration = Runtime.duration
type op_kind =
| KInt
| KRat
| KMoney
| KDate
| KDuration (** All ops don't have a KDate and KDuration. *)
type 'a op_kind =
(* | Kpoly: desugared op_kind -- Coming soon ! *)
| KInt : 'a any op_kind
| KRat : 'a any op_kind
| KMoney : 'a any op_kind
| KDate : 'a any op_kind
| KDuration : 'a any op_kind (** All ops don't have a KDate and KDuration. *)
type ternop = Fold
type binop =
type 'a binop =
| And
| Or
| Xor
| Add of op_kind
| Sub of op_kind
| Mult of op_kind
| Div of op_kind
| Lt of op_kind
| Lte of op_kind
| Gt of op_kind
| Gte of op_kind
| Add of 'a op_kind
| Sub of 'a op_kind
| Mult of 'a op_kind
| Div of 'a op_kind
| Lt of 'a op_kind
| Lte of 'a op_kind
| Gt of 'a op_kind
| Gte of 'a op_kind
| Eq
| Neq
| Map
@ -97,9 +118,9 @@ type log_entry =
| EndCall
| PosRecordIfTrueBool
type unop =
type 'a unop =
| Not
| Minus of op_kind
| Minus of 'a op_kind
| Log of log_entry * Uid.MarkedString.info list
| Length
| IntToRat
@ -113,19 +134,13 @@ type unop =
| RoundMoney
| RoundDecimal
type operator = Ternop of ternop | Binop of binop | Unop of unop
type 'a operator = Ternop of ternop | Binop of 'a binop | Unop of 'a unop
type except = ConflictError | EmptyError | NoValueProvided | Crash
(** {2 Generic expressions} *)
(** Define a common base type for the expressions in most passes of the compiler *)
type desugared = [ `Desugared ]
type scopelang = [ `Scopelang ]
type dcalc = [ `Dcalc ]
type lcalc = [ `Lcalc ]
type 'a any = [< desugared | scopelang | dcalc | lcalc ] as 'a
(** Literals are the same throughout compilation except for the [LEmptyError]
case which is eliminated midway through. *)
type 'a glit =
@ -170,7 +185,7 @@ and ('a, 't) naked_gexpr =
args : ('a, 't) gexpr list;
}
-> ('a any, 't) naked_gexpr
| EOp : operator -> ('a any, 't) naked_gexpr
| EOp : 'a operator -> ('a any, 't) naked_gexpr
| EArray : ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| EVar : ('a, 't) naked_gexpr Bindlib.var -> ('a any, 't) naked_gexpr
| EAbs : {
@ -189,12 +204,6 @@ and ('a, 't) naked_gexpr =
fields : ('a, 't) gexpr StructField.Map.t;
}
-> ('a any, 't) naked_gexpr
| EStructAccess : {
name : StructName.t;
e : ('a, 't) gexpr;
field : StructField.t;
}
-> ('a any, 't) naked_gexpr
| EInj : {
name : EnumName.t;
e : ('a, 't) gexpr;
@ -216,6 +225,20 @@ and ('a, 't) naked_gexpr =
args : ('a, 't) gexpr ScopeVar.Map.t;
}
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
(* [desugared] has ambiguous struct fields *)
| EDStructAccess : {
name_opt : StructName.t option;
e : ('a, 't) gexpr;
field : IdentName.t;
}
-> ((desugared as 'a), 't) naked_gexpr
(* Resolved struct/enums, after [desugared] *)
| EStructAccess : {
name : StructName.t;
e : ('a, 't) gexpr;
field : StructField.t;
}
-> (([< scopelang | dcalc | lcalc ] as 'a), 't) naked_gexpr
(* Lambda-like *)
| EAssert : ('a, 't) gexpr -> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
(* Default terms *)

86
compiler/shared_ast/expr.ml
View File

@ -114,6 +114,9 @@ let estruct name (fields : ('a, 't) boxed_gexpr StructField.Map.t) mark =
(fun fields -> EStruct { name; fields })
(Box.lift_struct (StructField.Map.map Box.lift fields))
let edstructaccess e field name_opt =
Box.app1 e @@ fun e -> EDStructAccess { name_opt; e; field }
let estructaccess e field name =
Box.app1 e @@ fun e -> EStructAccess { name; e; field }
@ -232,6 +235,8 @@ let map
| EStruct { name; fields } ->
let fields = StructField.Map.map f fields in
estruct name fields m
| EDStructAccess { e; field; name_opt } ->
edstructaccess (f e) field name_opt m
| EStructAccess { e; field; name } -> estructaccess (f e) field name m
| EMatch { e; name; cases } ->
let cases = EnumConstructor.Map.map f cases in
@ -267,6 +272,7 @@ let shallow_fold
| EErrorOnEmpty e -> acc |> f e
| ECatch { body; handler; _ } -> acc |> f body |> f handler
| EStruct { fields; _ } -> acc |> StructField.Map.fold (fun _ -> f) fields
| EDStructAccess { e; _ } -> acc |> f e
| EStructAccess { e; _ } -> acc |> f e
| EMatch { e; cases; _ } ->
acc |> f e |> EnumConstructor.Map.fold (fun _ -> f) cases
@ -347,6 +353,9 @@ let map_gather
(acc, StructField.Map.empty)
in
acc, estruct name fields m
| EDStructAccess { e; field; name_opt } ->
let acc, e = f e in
acc, edstructaccess e field name_opt m
| EStructAccess { e; field; name } ->
let acc, e = f e in
acc, estructaccess e field name m
@ -689,6 +698,9 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
| ( EStruct { name = s1; fields = fields1 },
EStruct { name = s2; fields = fields2 } ) ->
StructName.equal s1 s2 && StructField.Map.equal equal fields1 fields2
| ( EDStructAccess { e = e1; field = f1; name_opt = s1 },
EDStructAccess { e = e2; field = f2; name_opt = s2 } ) ->
Option.equal StructName.equal s1 s2 && IdentName.equal f1 f2 && equal e1 e2
| ( EStructAccess { e = e1; field = f1; name = s1 },
EStructAccess { e = e2; field = f2; name = s2 } ) ->
StructName.equal s1 s2 && StructField.equal f1 f2 && equal e1 e2
@ -705,8 +717,8 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
ScopeName.equal s1 s2 && ScopeVar.Map.equal equal fields1 fields2
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _ | EAbs _ | EApp _
| EAssert _ | EOp _ | EDefault _ | EIfThenElse _ | EErrorOnEmpty _
| ERaise _ | ECatch _ | ELocation _ | EStruct _ | EStructAccess _ | EInj _
| EMatch _ | EScopeCall _ ),
| ERaise _ | ECatch _ | ELocation _ | EStruct _ | EDStructAccess _
| EStructAccess _ | EInj _ | EMatch _ | EScopeCall _ ),
_ ) ->
false
@ -719,7 +731,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
match[@ocamlformat "disable"] Marked.unmark e1, Marked.unmark e2 with
| ELit l1, ELit l2 ->
compare_lit l1 l2
| EApp {f=f1; args= args1}, EApp {f=f2; args= args2} ->
| EApp {f=f1; args=args1}, EApp {f=f2; args=args2} ->
compare f1 f2 @@< fun () ->
List.compare compare args1 args2
| EOp op1, EOp op2 ->
@ -728,44 +740,57 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
List.compare compare a1 a2
| EVar v1, EVar v2 ->
Bindlib.compare_vars v1 v2
| EAbs {binder=binder1; tys= typs1}, EAbs {binder=binder2; tys= typs2} ->
| EAbs {binder=binder1; tys=typs1},
EAbs {binder=binder2; tys=typs2} ->
List.compare compare_typ typs1 typs2 @@< fun () ->
let _, e1, e2 = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
| EIfThenElse {cond=i1; etrue= t1; efalse= e1}, EIfThenElse {cond=i2; etrue= t2; efalse= e2} ->
| EIfThenElse {cond=i1; etrue=t1; efalse=e1},
EIfThenElse {cond=i2; etrue=t2; efalse=e2} ->
compare i1 i2 @@< fun () ->
compare t1 t2 @@< fun () ->
compare e1 e2
| ELocation l1, ELocation l2 ->
compare_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| EStruct {name=name1; fields= field_map1}, EStruct {name=name2; fields= field_map2} ->
| EStruct {name=name1; fields=field_map1},
EStruct {name=name2; fields=field_map2} ->
StructName.compare name1 name2 @@< fun () ->
StructField.Map.compare compare field_map1 field_map2
| EStructAccess {e=e1; field= field_name1; name= struct_name1},
EStructAccess {e=e2; field= field_name2; name= struct_name2} ->
| EDStructAccess {e=e1; field=field_name1; name_opt=struct_name1},
EDStructAccess {e=e2; field=field_name2; name_opt=struct_name2} ->
compare e1 e2 @@< fun () ->
IdentName.compare field_name1 field_name2 @@< fun () ->
Option.compare StructName.compare struct_name1 struct_name2
| EStructAccess {e=e1; field=field_name1; name=struct_name1},
EStructAccess {e=e2; field=field_name2; name=struct_name2} ->
compare e1 e2 @@< fun () ->
StructField.compare field_name1 field_name2 @@< fun () ->
StructName.compare struct_name1 struct_name2
| EMatch {e=e1; name= name1;cases= emap1}, EMatch {e=e2; name= name2;cases= emap2} ->
| EMatch {e=e1; name=name1; cases=emap1},
EMatch {e=e2; name=name2; cases=emap2} ->
EnumName.compare name1 name2 @@< fun () ->
compare e1 e2 @@< fun () ->
EnumConstructor.Map.compare compare emap1 emap2
| EScopeCall {scope=name1; args= field_map1}, EScopeCall {scope=name2; args= field_map2} ->
| EScopeCall {scope=name1; args=field_map1},
EScopeCall {scope=name2; args=field_map2} ->
ScopeName.compare name1 name2 @@< fun () ->
ScopeVar.Map.compare compare field_map1 field_map2
| ETuple es1, ETuple es2 ->
List.compare compare es1 es2
| ETupleAccess {e=e1; index= n1; size=s1}, ETupleAccess {e=e2; index= n2; size=s2} ->
| ETupleAccess {e=e1; index=n1; size=s1},
ETupleAccess {e=e2; index=n2; size=s2} ->
Int.compare s1 s2 @@< fun () ->
Int.compare n1 n2 @@< fun () ->
compare e1 e2
| EInj {e=e1; name= name1; cons= cons1}, EInj {e=e2; name= name2; cons= cons2} ->
| EInj {e=e1; name=name1; cons=cons1},
EInj {e=e2; name=name2; cons=cons2} ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructor.compare cons1 cons2 @@< fun () ->
compare e1 e2
| EAssert e1, EAssert e2 ->
compare e1 e2
| EDefault {excepts=exs1; just= just1; cons=cons1}, EDefault {excepts=exs2; just= just2; cons=cons2} ->
| EDefault {excepts=exs1; just=just1; cons=cons1},
EDefault {excepts=exs2; just=just2; cons=cons2} ->
compare just1 just2 @@< fun () ->
compare cons1 cons2 @@< fun () ->
List.compare compare exs1 exs2
@ -773,7 +798,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
compare e1 e2
| ERaise ex1, ERaise ex2 ->
compare_except ex1 ex2
| ECatch {body=etry1; exn= ex1; handler=ewith1}, ECatch {body=etry2; exn= ex2; handler=ewith2} ->
| ECatch {body=etry1; exn=ex1; handler=ewith1},
ECatch {body=etry2; exn=ex2; handler=ewith2} ->
compare_except ex1 ex2 @@< fun () ->
compare etry1 etry2 @@< fun () ->
compare ewith1 ewith2
@ -786,6 +812,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EIfThenElse _, _ -> -1 | _, EIfThenElse _ -> 1
| ELocation _, _ -> -1 | _, ELocation _ -> 1
| EStruct _, _ -> -1 | _, EStruct _ -> 1
| EDStructAccess _, _ -> -1 | _, EDStructAccess _ -> 1
| EStructAccess _, _ -> -1 | _, EStructAccess _ -> 1
| EMatch _, _ -> -1 | _, EMatch _ -> 1
| EScopeCall _, _ -> -1 | _, EScopeCall _ -> 1
@ -842,6 +869,7 @@ let rec size : type a. (a, 't) gexpr -> int =
| ELocation _ -> 1
| EStruct { fields; _ } ->
StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0
| EDStructAccess { e; _ } -> 1 + size e
| EStructAccess { e; _ } -> 1 + size e
| EMatch { e; cases; _ } ->
EnumConstructor.Map.fold (fun _ e acc -> acc + 1 + size e) cases (size e)
@ -931,3 +959,33 @@ let make_tuple el m0 =
(List.map (fun e -> Marked.get_mark e) el)
in
etuple el m
let translate_op_kind : type a. a op_kind -> 'b op_kind = function
| KInt -> KInt
| KRat -> KRat
| KMoney -> KMoney
| KDate -> KDate
| KDuration -> KDuration
let translate_op : type a. a operator -> 'b operator = function
| Ternop o -> Ternop o
| Binop o ->
Binop
(match o with
| Add k -> Add (translate_op_kind k)
| Sub k -> Sub (translate_op_kind k)
| Mult k -> Mult (translate_op_kind k)
| Div k -> Div (translate_op_kind k)
| Lt k -> Lt (translate_op_kind k)
| Lte k -> Lte (translate_op_kind k)
| Gt k -> Gt (translate_op_kind k)
| Gte k -> Gte (translate_op_kind k)
| (And | Or | Xor | Eq | Neq | Map | Concat | Filter) as o -> o)
| Unop o ->
Unop
(match o with
| Minus k -> Minus (translate_op_kind k)
| ( Not | Log _ | Length | IntToRat | MoneyToRat | RatToMoney | GetDay
| GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | RoundMoney
| RoundDecimal ) as o ->
o)

16
compiler/shared_ast/expr.mli
View File

@ -66,7 +66,7 @@ val eapp :
val eassert :
(([< dcalc | lcalc ] as 'a), 't) boxed_gexpr -> 't -> ('a, 't) boxed_gexpr
val eop : operator -> 't -> (_ any, 't) boxed_gexpr
val eop : 'a any operator -> 't -> ('a, 't) boxed_gexpr
val edefault :
(([< desugared | scopelang | dcalc ] as 'a), 't) boxed_gexpr list ->
@ -105,8 +105,15 @@ val estruct :
't ->
('a, 't) boxed_gexpr
val edstructaccess :
(desugared, 't) boxed_gexpr ->
IdentName.t ->
StructName.t option ->
't ->
(desugared, 't) boxed_gexpr
val estructaccess :
('a any, 't) boxed_gexpr ->
(([< scopelang | dcalc | lcalc ] as 'a), 't) boxed_gexpr ->
StructField.t ->
StructName.t ->
't ->
@ -303,6 +310,11 @@ val make_tuple :
(** {2 Transformations} *)
val translate_op :
[< desugared | scopelang | dcalc | lcalc ] operator -> 'b any operator
(** Operators are actually all the same after initial desambiguation, so this
function allows converting their types ; otherwise, this is the identity *)
val remove_logging_calls : ('a any, 't) gexpr -> ('a, 't) boxed_gexpr
(** Removes all calls to [Log] unary operators in the AST, replacing them by
their argument. *)

9
compiler/shared_ast/print.ml
View File

@ -137,7 +137,7 @@ let lit (type a) (fmt : Format.formatter) (l : a glit) : unit =
| LDate d -> lit_style fmt (Runtime.date_to_string d)
| LDuration d -> lit_style fmt (Runtime.duration_to_string d)
let op_kind (fmt : Format.formatter) (k : op_kind) =
let op_kind (fmt : Format.formatter) (k : 'a op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> ""
@ -146,7 +146,7 @@ let op_kind (fmt : Format.formatter) (k : op_kind) =
| KDate -> "@"
| KDuration -> "^")
let binop (fmt : Format.formatter) (op : binop) : unit =
let binop (fmt : Format.formatter) (op : 'a binop) : unit =
operator fmt
(match op with
| Add k -> Format.asprintf "+%a" op_kind k
@ -179,7 +179,7 @@ let log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Cli.format_with_style [ANSITerminal.green] fmt "☛ ")
entry
let unop (fmt : Format.formatter) (op : unop) : unit =
let unop (fmt : Format.formatter) (op : 'a unop) : unit =
match op with
| Minus _ -> Format.pp_print_string fmt "-"
| Not -> Format.pp_print_string fmt "~"
@ -323,6 +323,9 @@ let rec expr_aux :
| ERaise exn ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
| ELocation loc -> location fmt loc
| EDStructAccess { e; field; _ } ->
Format.fprintf fmt "%a%a%a%a%a" expr e punctuation "." punctuation "\""
IdentName.format_t field punctuation "\""
| EStruct { name; fields } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]" StructName.format_t name
punctuation "{"

6
compiler/shared_ast/print.mli
View File

@ -35,11 +35,11 @@ val tlit : Format.formatter -> typ_lit -> unit
val location : Format.formatter -> 'a glocation -> unit
val typ : decl_ctx -> Format.formatter -> typ -> unit
val lit : Format.formatter -> 'a glit -> unit
val op_kind : Format.formatter -> op_kind -> unit
val binop : Format.formatter -> binop -> unit
val op_kind : Format.formatter -> 'a any op_kind -> unit
val binop : Format.formatter -> 'a any binop -> unit
val ternop : Format.formatter -> ternop -> unit
val log_entry : Format.formatter -> log_entry -> unit
val unop : Format.formatter -> unop -> unit
val unop : Format.formatter -> 'a any unop -> unit
val except : Format.formatter -> except -> unit
val var : Format.formatter -> 'e Var.t -> unit
val var_debug : Format.formatter -> 'e Var.t -> unit

3
compiler/shared_ast/typing.ml
View File

@ -215,7 +215,7 @@ let lit_type (type a) (lit : a A.glit) : naked_typ =
This allows us to have a simpler type system, while we argue the syntactic
burden of operator annotations helps the programmer visualize the type flow
in the code. *)
let op_type (op : A.operator Marked.pos) : unionfind_typ =
let op_type (op : 'a A.operator Marked.pos) : unionfind_typ =
let pos = Marked.get_mark op in
let bt = UnionFind.make (TLit TBool, pos) in
let it = UnionFind.make (TLit TInt, pos) in
@ -413,6 +413,7 @@ and typecheck_expr_top_down :
fields
in
Expr.estruct name fields' mark
| A.EDStructAccess { e = e_struct; name_opt; field } -> assert false
| A.EStructAccess { e = e_struct; name; field } ->
let fld_ty =
let str =

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

@ -426,8 +426,8 @@ let is_leap_year = Runtime.is_leap_year
(** [translate_op] returns the Z3 expression corresponding to the application of
[op] to the arguments [args] **)
let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
context * Expr.expr =
let rec translate_op (ctx : context) (op : dcalc operator) (args : 'm expr list)
: context * Expr.expr =
match op with
| Ternop _top ->
let _e1, _e2, _e3 =