diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index b3e1b79139b..e62d8949123 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -71,6 +71,15 @@ let find id env = with Not_found -> trap no_region "unbound identifier %s" id +let lookup_actor env at aid id = + match V.Env.find_opt aid !(env.actor_env) with + | None -> trap at "Unknown actor \"%s\"" aid + | Some actor_value -> + let fs = V.as_obj actor_value in + match V.Env.find_opt id fs with + | None -> trap at "Actor \"%s\" has no method \"%s\"" aid id + | Some field_value -> field_value + (* Tracing *) let trace_depth = ref 0 @@ -307,10 +316,16 @@ and interpret_exp_mut env exp (k : V.value V.cont) = ) | LitE lit -> k (interpret_lit env lit) + | PrimE (ActorDotPrim n, [{ it = VarE (_, actor); _ }]) when not(Lib.Promise.is_fulfilled (find actor env.vals)) -> + (* actor not defined yet, just pair them up *) + k V.(Tup [Blob (env.self); Text n]) | PrimE (p, es) -> interpret_exps env es [] (fun vs -> match p, vs with | CallPrim typs, [v1; v2] -> + let v1 = match v1 with + | V.(Tup [Blob aid; Text id]) -> lookup_actor env exp.at aid id + | _ -> v1 in let call_conv, f = V.as_func v1 in check_call_conv (List.hd es) call_conv; check_call_conv_arg env exp v2 call_conv; @@ -320,7 +335,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = k (try Operator.unop op ot v1 with Invalid_argument s -> trap exp.at "%s" s) | BinPrim (ot, op), [v1; v2] -> k (try Operator.binop op ot v1 v2 with _ -> - trap exp.at "arithmetic overflow") + trap exp.at "arithmetic overflow") | RelPrim (ot, op), [v1; v2] -> k (Operator.relop op ot v1 v2) | TupPrim, exps -> @@ -335,16 +350,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) = let fs = V.as_obj v1 in k (try find n fs with _ -> assert false) | ActorDotPrim n, [v1] -> - let id = V.as_blob v1 in - begin match V.Env.find_opt id !(env.actor_env) with - (* not quite correct: On the platform, you can invoke and get a reject *) - | None -> trap exp.at "Unknown actor \"%s\"" id - | Some actor_value -> - let fs = V.as_obj actor_value in - match V.Env.find_opt n fs with - | None -> trap exp.at "Actor \"%s\" has no method \"%s\"" id n - | Some field_value -> k field_value - end + (* delay error handling to the point when the method gets applied *) + k V.(Tup [v1; Text n]) | ArrayPrim (mut, _), vs -> let vs' = match mut with @@ -447,6 +454,9 @@ and interpret_exp_mut env exp (k : V.value V.cont) = let e = V.Tup [V.Variant ("canister_reject", V.unit); v1] in Scheduler.queue (fun () -> reject e) | ICCallPrim, [v1; v2; kv; rv; cv] -> + let v1 = match v1 with + | V.(Tup [Blob aid; Text id]) -> lookup_actor env exp.at aid id + | _ -> v1 in let call_conv, f = V.as_func v1 in check_call_conv (List.hd es) call_conv; check_call_conv_arg env exp v2 call_conv; @@ -463,7 +473,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = in k (V.Obj ve) | SelfRef _, [] -> - k (V.Blob env.self) + k (context env) | SystemTimePrim, [] -> k (V.Nat64 (Numerics.Nat64.of_int 42)) | SystemCyclesRefundedPrim, [] -> (* faking it *) @@ -572,7 +582,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = and interpret_actor env ds fs k = let self = V.fresh_id () in - let env0 = {env with self = self} in + let env0 = {env with self} in let ve = declare_decs ds V.Env.empty in let env' = adjoin_vals env0 ve in interpret_decs env' ds (fun _ -> diff --git a/src/lib/lib.mli b/src/lib/lib.mli index cd748881a39..47b2563498d 100644 --- a/src/lib/lib.mli +++ b/src/lib/lib.mli @@ -84,7 +84,7 @@ end module Seq : sig - val for_all : ('a -> bool) -> 'a Seq.t -> bool + val for_all : ('a -> bool) -> 'a Seq.t -> bool (* 4.14 *) end module Option : diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index bcbb995e46d..b4e943bde7d 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -1145,7 +1145,7 @@ let transform_unit_body (u : S.comp_unit_body) : Ir.comp_unit = let actor_expression = build_actor u.at [] self_id fields u.note.S.note_typ in begin match actor_expression with | I.ActorE (ds, fs, u, t) -> - I.ActorU (None, ds, fs, u, t) + I.ActorU (None, ds, fs, u, t) | _ -> assert false end diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index b5a1500d74f..12cb3fecb10 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -69,7 +69,13 @@ module Make (Cfg : Config) = struct | FromCandidE e -> "FromCandidE" $$ [exp e] | TupE es -> "TupE" $$ exps es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] - | ObjBlockE (s, t, dfs) -> "ObjBlockE" $$ [obj_sort s; match t with None -> Atom "_" | Some t -> typ t] @ List.map dec_field dfs + | ObjBlockE (s, nt, dfs) -> "ObjBlockE" $$ [obj_sort s; + match nt with + | None, None -> Atom "_" + | None, Some t -> typ t + | Some id, Some t -> id.it $$ [Atom ":"; typ t] + | Some id, None -> Atom id.it + ] @ List.map dec_field dfs | ObjE ([], efs) -> "ObjE" $$ List.map exp_field efs | ObjE (bases, efs) -> "ObjE" $$ exps bases @ [Atom "with"] @ List.map exp_field efs | DotE (e, x) -> "DotE" $$ [exp e; id x] diff --git a/src/mo_def/compUnit.ml b/src/mo_def/compUnit.ml index f61a1cecd9c..a71aafa29de 100644 --- a/src/mo_def/compUnit.ml +++ b/src/mo_def/compUnit.ml @@ -80,14 +80,14 @@ let obj_decs obj_sort at note id_opt fields = match id_opt with | None -> [ { it = ExpD { - it = ObjBlockE ( { it = obj_sort; at; note = () }, None, fields); + it = ObjBlockE ( { it = obj_sort; at; note = () }, (None, None), fields); at; note }; at; note }] | Some id -> [ { it = LetD ( { it = VarP id; at; note = note.note_typ }, - { it = ObjBlockE ({ it = obj_sort; at; note = () }, None, fields); + { it = ObjBlockE ({ it = obj_sort; at; note = () }, (None, None), fields); at; note; }, None); at; note diff --git a/src/mo_def/syntax.ml b/src/mo_def/syntax.ml index 5fa55b9053c..5917938b628 100644 --- a/src/mo_def/syntax.ml +++ b/src/mo_def/syntax.ml @@ -165,7 +165,7 @@ and exp' = | OptE of exp (* option injection *) | DoOptE of exp (* option monad *) | BangE of exp (* scoped option projection *) - | ObjBlockE of obj_sort * typ option * dec_field list (* object block *) + | ObjBlockE of obj_sort * (id option * typ option) * dec_field list (* object block *) | ObjE of exp list * exp_field list (* record literal/extension *) | TagE of id * exp (* variant *) | DotE of exp * id (* object projection *) diff --git a/src/mo_frontend/definedness.ml b/src/mo_frontend/definedness.ml index 9255bff48c3..fffe2221df5 100644 --- a/src/mo_frontend/definedness.ml +++ b/src/mo_frontend/definedness.ml @@ -84,55 +84,55 @@ let rec exp msgs e : f = match e.it with (* Or anything that is occurring in a call (as this may call a closure): *) | CallE (e1, ts, e2) -> eagerify (exps msgs [e1; e2]) (* And break, return, throw can be thought of as calling a continuation: *) - | BreakE (i, e) -> eagerify (exp msgs e) - | RetE e -> eagerify (exp msgs e) + | BreakE (_, e) + | RetE e | ThrowE e -> eagerify (exp msgs e) (* Uses are delayed by function expressions *) | FuncE (_, sp, tp, p, t, _, e) -> - delayify ((exp msgs e /// pat msgs p) /// shared_pat msgs sp) + delayify ((exp msgs e /// pat msgs p) /// shared_pat msgs sp) + | ObjBlockE (s, (self_id_opt, _), dfs) -> + group msgs ~extern:self_id_opt (dec_fields msgs dfs) (* The rest remaining cases just collect the uses of subexpressions: *) - | LitE _ | ActorUrlE _ + | LitE _ | PrimE _ | ImportE _ -> M.empty - | UnE (_, uo, e) -> exp msgs e - | BinE (_, e1, bo, e2)-> exps msgs [e1; e2] - | RelE (_, e1, ro, e2)-> exps msgs [e1; e2] - | ShowE (_, e) -> exp msgs e - | ToCandidE es -> exps msgs es - | FromCandidE e -> exp msgs e - | TupE es -> exps msgs es - | ProjE (e, i) -> exp msgs e - | ObjBlockE (s, _, dfs) -> - (* For actors, this may be too permissive; to be revised when we work on actors again *) - group msgs (dec_fields msgs dfs) | ObjE (bases, efs) -> exps msgs bases ++ exp_fields msgs efs - | DotE (e, i) -> exp msgs e - | AssignE (e1, e2) -> exps msgs [e1; e2] - | ArrayE (m, es) -> exps msgs es - | IdxE (e1, e2) -> exps msgs [e1; e2] + | TupE es + | ArrayE (_, es) + | ToCandidE es -> exps msgs es | BlockE ds -> group msgs (decs msgs ds) - | NotE e -> exp msgs e - | AndE (e1, e2) -> exps msgs [e1; e2] - | OrE (e1, e2) -> exps msgs [e1; e2] - | ImpliesE (e1, e2) -> exps msgs [e1; e2] - | OldE e -> exp msgs e | IfE (e1, e2, e3) -> exps msgs [e1; e2; e3] - | SwitchE (e, cs) -> exp msgs e ++ cases msgs cs + | SwitchE (e, cs) | TryE (e, cs, None) -> exp msgs e ++ cases msgs cs | TryE (e, cs, Some f)-> exps msgs [e; f] ++ cases msgs cs - | WhileE (e1, e2) -> exps msgs [e1; e2] | LoopE (e1, None) -> exp msgs e1 - | LoopE (e1, Some e2) -> exps msgs [e1; e2] + | LoopE (e1, Some e2) + | WhileE (e1, e2) + | AssignE (e1, e2) + | IdxE (e1, e2) + | BinE (_, e1, _, e2) + | RelE (_, e1, _, e2) + | AndE (e1, e2) + | OrE (e1, e2) + | ImpliesE (e1, e2) -> exps msgs [e1; e2] | ForE (p, e1, e2) -> exp msgs e1 ++ (exp msgs e2 /// pat msgs p) - | LabelE (i, t, e) -> exp msgs e - | DebugE e -> exp msgs e - | AsyncE (_, _, e) -> exp msgs e - | AwaitE (_, e) -> exp msgs e - | AssertE (_, e) -> exp msgs e - | AnnotE (e, t) -> exp msgs e - | OptE e -> exp msgs e - | DoOptE e -> exp msgs e - | BangE e -> exp msgs e - | TagE (_, e) -> exp msgs e + | UnE (_, _, e) + | ShowE (_, e) + | FromCandidE e + | DotE (e, _) + | ProjE (e, _) + | NotE e + | OldE e + | LabelE (_, _, e) + | DebugE e + | AsyncE (_, _, e) + | AwaitE (_, e) + | AssertE (_, e) + | AnnotE (e, _) + | OptE e + | DoOptE e + | BangE e + | TagE (_, e) + | ActorUrlE e | IgnoreE e -> exp msgs e and exps msgs es : f = unions (exp msgs) es @@ -178,12 +178,15 @@ and dec msgs d = match d.it with | VarD (i, e) -> (M.empty, S.singleton i.it) +++ exp msgs e | TypD (i, tp, t) -> (M.empty, S.empty) | ClassD (csp, i, tp, p, t, s, i', dfs) -> + let extern = if s.it = Type.Actor then Some i' else None in (M.empty, S.singleton i.it) +++ delayify ( - group msgs (dec_fields msgs dfs @ class_self d.at i') /// pat msgs p /// shared_pat msgs csp + group msgs ~extern (dec_fields msgs dfs @ class_self d.at i' s.it) /// pat msgs p /// shared_pat msgs csp ) (* The class self binding is treated as defined at the very end of the group *) -and class_self at i : group = [(at, S.singleton i.it, S.empty, S.empty)] +and class_self at i : Type.obj_sort -> group = function + | Type.Actor -> [] + | _ -> [(at, S.singleton i.it, S.empty, S.empty)] and decs msgs decs : group = (* Annotate the declarations with the analysis results *) @@ -192,9 +195,13 @@ and decs msgs decs : group = (d.at, defs, eager_vars f, delayed_vars f) ) decs -and group msgs (grp : group) : f = +and group msgs ?(extern=None) (grp : group) : f = (* Create a map from declared variable to their definition point *) let defWhen = M.disjoint_unions (List.mapi (fun i (_, defs, _, _) -> map_of_set i defs) grp) in + (* Insert the externally defined binding in front if present, non-shadowing *) + let defWhen = match extern with + | Some b when M.find_opt b.it defWhen |> Option.is_none -> M.add b.it (-1) defWhen + | _ -> defWhen in (* Calculate the relation R *) let r = NameRel.unions (List.map (fun (_, defs, _, delayed) -> NameRel.cross defs delayed) grp) in (* Check for errors *) @@ -242,4 +249,3 @@ let check_lib lib = ignore (group msgs (decs msgs (imp_ds @ ds))); Some () ) - diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index 73353a1720f..85de84694bd 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -195,13 +195,13 @@ let share_dec_field (df : dec_field) = } | _ -> df -and objblock s ty dec_fields = +and objblock s id ty dec_fields = List.iter (fun df -> match df.it.vis.it, df.it.dec.it with | Public _, ClassD (_, id, _, _, _, _, _, _) when is_anon_id id -> syntax_error df.it.dec.at "M0158" "a public class cannot be anonymous, please provide a name" | _ -> ()) dec_fields; - ObjBlockE(s, ty, dec_fields) + ObjBlockE(s, (id, ty), dec_fields) %} @@ -872,12 +872,13 @@ dec_nonvar : let named, x = xf sort $sloc in let e = if s.it = Type.Actor then + let id = if named then Some x else None in AwaitE (Type.Fut, AsyncE(Type.Fut, scope_bind (anon_id "async" (at $sloc)) (at $sloc), - objblock s t (List.map share_dec_field efs) @? at $sloc) + objblock s id t (List.map share_dec_field efs) @? at $sloc) @? at $sloc) @? at $sloc - else objblock s t efs @? at $sloc + else objblock s None t efs @? at $sloc in let_or_exp named x e.it e.at } | sp=shared_pat_opt FUNC xf=id_opt diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index f3aedaa4943..9001eb6bf47 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1382,7 +1382,7 @@ and infer_exp'' env exp : T.typ = in let t = infer_obj env' obj_sort.it dec_fields exp.at in begin match env.pre, typ_opt with - | false, Some typ -> + | false, (_, Some typ) -> let t' = check_typ env' typ in if not (T.sub t t') then local_error env exp.at "M0192" diff --git a/src/mo_interpreter/interpret.ml b/src/mo_interpreter/interpret.ml index 91afb0740a0..0164d0b641e 100644 --- a/src/mo_interpreter/interpret.ml +++ b/src/mo_interpreter/interpret.ml @@ -83,6 +83,15 @@ let find id env = let dom = V.Env.keys env in trap no_region "unbound identifier %s in domain %s" id (String.concat " " dom) +let lookup_actor env at aid id = + match V.Env.find_opt aid !(env.actor_env) with + | None -> trap at "Unknown actor \"%s\"" aid + | Some actor_value -> + let fs = V.as_obj actor_value in + match V.Env.find_opt id fs with + | None -> trap at "Actor \"%s\" has no method \"%s\"" aid id + | Some field_value -> field_value + (* Tracing *) let trace_depth = ref 0 @@ -482,8 +491,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) = | _ -> assert false) | ProjE (exp1, n) -> interpret_exp env exp1 (fun v1 -> k (List.nth (V.as_tup v1) n)) - | ObjBlockE (obj_sort, _, dec_fields) -> - interpret_obj env obj_sort.it dec_fields k + | ObjBlockE (obj_sort, (self_id_opt, _), dec_fields) -> + interpret_obj env obj_sort.it self_id_opt dec_fields k | ObjE (exp_bases, exp_fields) -> let fields fld_env = interpret_exp_fields env exp_fields fld_env (fun env -> k (V.Obj env)) in let open V.Env in @@ -503,21 +512,13 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exps env exp_bases [] (fun objs -> fields (merges (strip objs))) | TagE (i, exp1) -> interpret_exp env exp1 (fun v1 -> k (V.Variant (i.it, v1))) + | DotE (exp1, id) when T.(sub exp1.note.note_typ (Obj (Actor, []))) -> + interpret_exp env exp1 (fun v1 -> k V.(Tup [v1; Text id.it])) | DotE (exp1, id) -> interpret_exp env exp1 (fun v1 -> match v1 with | V.Obj fs -> k (find id.it fs) - | V.Blob aid when T.sub exp1.note.note_typ (T.Obj (T.Actor, [])) -> - begin match V.Env.find_opt aid !(env.actor_env) with - (* not quite correct: On the platform, you can invoke and get a reject *) - | None -> trap exp.at "Unknown actor \"%s\"" aid - | Some actor_value -> - let fs = V.as_obj actor_value in - match V.Env.find_opt id.it fs with - | None -> trap exp.at "Actor \"%s\" has no method \"%s\"" aid id.it - | Some field_value -> k field_value - end | V.Array vs -> let f = match id.it with | "size" -> array_size @@ -572,6 +573,10 @@ and interpret_exp_mut env exp (k : V.value V.cont) = in k v' | CallE (exp1, typs, exp2) -> interpret_exp env exp1 (fun v1 -> + let v1 = begin match v1 with + | V.(Tup [Blob aid; Text id]) -> lookup_actor env exp1.at aid id + | _ -> v1 + end in interpret_exp env exp2 (fun v2 -> let call_conv, f = V.as_func v1 in check_call_conv exp1 call_conv; @@ -797,19 +802,20 @@ and define_pat env pat v = false and match_lit lit v : bool = + let open Numerics in match !lit, v with | NullLit, V.Null -> true | BoolLit b, V.Bool b' -> b = b' - | NatLit n, V.Int n' -> Numerics.Int.eq n n' - | Nat8Lit n, V.Nat8 n' -> Numerics.Nat8.eq n n' - | Nat16Lit n, V.Nat16 n' -> Numerics.Nat16.eq n n' - | Nat32Lit n, V.Nat32 n' -> Numerics.Nat32.eq n n' - | Nat64Lit n, V.Nat64 n' -> Numerics.Nat64.eq n n' - | IntLit i, V.Int i' -> Numerics.Int.eq i i' - | Int8Lit i, V.Int8 i' -> Numerics.Int_8.eq i i' - | Int16Lit i, V.Int16 i' -> Numerics.Int_16.eq i i' - | Int32Lit i, V.Int32 i' -> Numerics.Int_32.eq i i' - | Int64Lit i, V.Int64 i' -> Numerics.Int_64.eq i i' + | NatLit n, V.Int n' -> Int.eq n n' + | Nat8Lit n, V.Nat8 n' -> Nat8.eq n n' + | Nat16Lit n, V.Nat16 n' -> Nat16.eq n n' + | Nat32Lit n, V.Nat32 n' -> Nat32.eq n n' + | Nat64Lit n, V.Nat64 n' -> Nat64.eq n n' + | IntLit i, V.Int i' -> Int.eq i i' + | Int8Lit i, V.Int8 i' -> Int_8.eq i i' + | Int16Lit i, V.Int16 i' -> Int_16.eq i i' + | Int32Lit i, V.Int32 i' -> Int_32.eq i i' + | Int64Lit i, V.Int64 i' -> Int_64.eq i i' | FloatLit z, V.Float z' -> z = z' | CharLit c, V.Char c' -> c = c' | TextLit u, V.Text u' -> u = u' @@ -885,16 +891,22 @@ and match_shared_pat env shared_pat c = (* Objects *) -and interpret_obj env obj_sort dec_fields (k : V.value V.cont) = +and interpret_obj env obj_sort self_id dec_fields (k : V.value V.cont) = match obj_sort with | T.Actor -> let self = V.fresh_id() in + let self' = V.Blob self in + (* Define self_id eagerly *) + let env' = match self_id with + | Some id -> adjoin_vals env (declare_id id) + | None -> env in + Option.iter (fun id -> define_id env' id self') self_id; let ve_ex, ve_in = declare_dec_fields dec_fields V.Env.empty V.Env.empty in - let env' = adjoin_vals { env with self = self } ve_in in - interpret_dec_fields env' dec_fields ve_ex + let env'' = adjoin_vals { env' with self } ve_in in + interpret_dec_fields env'' dec_fields ve_ex (fun obj -> (env.actor_env := V.Env.add self obj !(env.actor_env); - k (V.Blob self))) + k self')) | _ -> let ve_ex, ve_in = declare_dec_fields dec_fields V.Env.empty V.Env.empty in let env' = adjoin_vals env ve_in in @@ -966,7 +978,7 @@ and interpret_dec env dec (k : V.value V.cont) = let f = interpret_func env id.it shared_pat pat (fun env' k' -> if obj_sort.it <> T.Actor then let env'' = adjoin_vals env' (declare_id id') in - interpret_obj env'' obj_sort.it dec_fields (fun v' -> + interpret_obj env'' obj_sort.it None dec_fields (fun v' -> define_id env'' id' v'; k' v') else @@ -978,9 +990,7 @@ and interpret_dec env dec (k : V.value V.cont) = rets = Some k''; throws = Some r } in - interpret_obj env''' obj_sort.it dec_fields (fun v' -> - define_id env''' id' v'; - k'' v')) + interpret_obj env''' obj_sort.it (Some id') dec_fields k'') k') in let v = V.Func (CC.call_conv_of_typ dec.note.note_typ, f) in diff --git a/src/mo_values/operator.ml b/src/mo_values/operator.ml index 414989d9e53..bf22cbb7abd 100644 --- a/src/mo_values/operator.ml +++ b/src/mo_values/operator.ml @@ -185,7 +185,7 @@ let structural_equality t = let v1 = as_array v1 in let v2 = as_array v2 in Bool ( - Array.length v1 == Array.length v2 && + Array.length v1 = Array.length v2 && Lib.Array.for_all2 (fun x y -> as_bool (eq_elem x y)) v1 v2 ) | T.Opt t -> ( @@ -235,8 +235,13 @@ let structural_equality t = else go (List.find (fun f -> f.T.lab = l1) fs).T.typ v1 v2 | T.Func (s, c, tbs, ts1, ts2) -> - assert (T.is_shared_sort s); - fun v1 v2 -> Bool (v1 == v2) (* HACK *) + assert (T.is_shared_sort s); + fun v1 v2 -> match v1, v2 with + | Tup [Blob _; Text _], Tup [Blob _; Text _] -> Bool (v1 = v2) (* public methods *) + | Func _, Tup [Blob _; Text _] + | Tup [Blob _; Text _], Func _ -> assert false; (* mixed, cannot determine equality *) + | Func _, Func _ -> Bool (v1 == v2) (* both internal, HACK *) + | _ -> failwith "illegal shared function" in go t diff --git a/src/mo_values/prim.ml b/src/mo_values/prim.ml index 28a21b2f7a6..0248598a95a 100644 --- a/src/mo_values/prim.ml +++ b/src/mo_values/prim.ml @@ -295,8 +295,9 @@ let prim trap = ) - | "blobOfPrincipal" -> fun _ v k -> k v - | "principalOfBlob" -> fun _ v k -> k v + | "cast" + | "blobOfPrincipal" + | "principalOfBlob" | "principalOfActor" -> fun _ v k -> k v | "blobToArray" -> fun _ v k -> @@ -316,8 +317,6 @@ let prim trap = Char.chr (Nat8.to_int (Value.as_nat8 !(Value.as_mut v))) ) (Array.to_seq (Value.as_array v))))) - | "cast" -> fun _ v k -> k v - (* calls never fail in the interpreter *) | "call_perform_status" -> fun _ v k -> k (Nat32 Nat32.zero) | "call_perform_message" -> fun _ v k -> k (Value.Text "") diff --git a/src/viper/traversals.ml b/src/viper/traversals.ml index c5cf7933ea4..bdf02154c6e 100644 --- a/src/viper/traversals.ml +++ b/src/viper/traversals.ml @@ -48,7 +48,7 @@ let rec over_exp (v : visitor) (exp : exp) : exp = | TupE exps -> { exp with it = TupE (List.map (over_exp v) exps) } | ArrayE (x, exps) -> { exp with it = ArrayE (x, List.map (over_exp v) exps) } | BlockE ds -> { exp with it = BlockE (List.map (over_dec v) ds) } - | ObjBlockE (x, t, dfs) -> { exp with it = ObjBlockE (x, Option.map (over_typ v) t, List.map (over_dec_field v) dfs) } + | ObjBlockE (x, (n, t), dfs) -> { exp with it = ObjBlockE (x, (n, Option.map (over_typ v) t), List.map (over_dec_field v) dfs) } | ObjE (bases, efs) -> { exp with it = ObjE (List.map (over_exp v) bases, List.map (over_exp_field v) efs) } | IfE (exp1, exp2, exp3) -> { exp with it = IfE(over_exp v exp1, over_exp v exp2, over_exp v exp3) } | TryE (exp1, cases, exp2) -> { exp with it = TryE (over_exp v exp1, List.map (over_case v) cases, Option.map (over_exp v) exp2) } diff --git a/test/run-drun/incomplete-self-reference.mo b/test/run-drun/incomplete-self-reference.mo new file mode 100644 index 00000000000..138d3c07e5d --- /dev/null +++ b/test/run-drun/incomplete-self-reference.mo @@ -0,0 +1,17 @@ +import { debugPrint } = "mo:⛔"; + +actor Self { + var stored : shared () -> async () = Self.method; + public func method() : async () { debugPrint "Hey!" }; + public func go() : async () { + assert stored == stored; + //assert go != stored; + assert Self.method == Self.method; + assert Self.go != Self.method; + //assert stored == method; + assert stored == Self.method; + await stored() + }; +}; + +Self.go(); //OR-CALL ingress go "DIDL\x00\x00" diff --git a/test/run-drun/ok/incomplete-self-reference.drun-run.ok b/test/run-drun/ok/incomplete-self-reference.drun-run.ok new file mode 100644 index 00000000000..bef445760af --- /dev/null +++ b/test/run-drun/ok/incomplete-self-reference.drun-run.ok @@ -0,0 +1,4 @@ +ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 +ingress Completed: Reply: 0x4449444c0000 +debug.print: Hey! +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/ok/incomplete-self-reference.run-ir.ok b/test/run-drun/ok/incomplete-self-reference.run-ir.ok new file mode 100644 index 00000000000..4c5477a837a --- /dev/null +++ b/test/run-drun/ok/incomplete-self-reference.run-ir.ok @@ -0,0 +1 @@ +Hey! diff --git a/test/run-drun/ok/incomplete-self-reference.run-low.ok b/test/run-drun/ok/incomplete-self-reference.run-low.ok new file mode 100644 index 00000000000..4c5477a837a --- /dev/null +++ b/test/run-drun/ok/incomplete-self-reference.run-low.ok @@ -0,0 +1 @@ +Hey! diff --git a/test/run-drun/ok/incomplete-self-reference.run.ok b/test/run-drun/ok/incomplete-self-reference.run.ok new file mode 100644 index 00000000000..4c5477a837a --- /dev/null +++ b/test/run-drun/ok/incomplete-self-reference.run.ok @@ -0,0 +1 @@ +Hey! diff --git a/test/run-drun/ok/pass-class-self.diff-ir.ok b/test/run-drun/ok/pass-class-self.diff-ir.ok new file mode 100644 index 00000000000..28c1f98e185 --- /dev/null +++ b/test/run-drun/ok/pass-class-self.diff-ir.ok @@ -0,0 +1,4 @@ +--- pass-class-self.run ++++ pass-class-self.run-ir +@@ -0,0 +1 @@ ++Before! diff --git a/test/run-drun/ok/pass-class-self.diff-low.ok b/test/run-drun/ok/pass-class-self.diff-low.ok new file mode 100644 index 00000000000..b3d286b58c7 --- /dev/null +++ b/test/run-drun/ok/pass-class-self.diff-low.ok @@ -0,0 +1,4 @@ +--- pass-class-self.run ++++ pass-class-self.run-low +@@ -0,0 +1 @@ ++Before! diff --git a/test/run-drun/ok/pass-class-self.drun-run.ok b/test/run-drun/ok/pass-class-self.drun-run.ok new file mode 100644 index 00000000000..2995727c5e0 --- /dev/null +++ b/test/run-drun/ok/pass-class-self.drun-run.ok @@ -0,0 +1,3 @@ +ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 +debug.print: Before! +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/ok/pass-class-self.run-ir.ok b/test/run-drun/ok/pass-class-self.run-ir.ok new file mode 100644 index 00000000000..fda743ffda9 --- /dev/null +++ b/test/run-drun/ok/pass-class-self.run-ir.ok @@ -0,0 +1 @@ +Before! diff --git a/test/run-drun/ok/pass-class-self.run-low.ok b/test/run-drun/ok/pass-class-self.run-low.ok new file mode 100644 index 00000000000..fda743ffda9 --- /dev/null +++ b/test/run-drun/ok/pass-class-self.run-low.ok @@ -0,0 +1 @@ +Before! diff --git a/test/run-drun/ok/pass-self.drun-run.ok b/test/run-drun/ok/pass-self.drun-run.ok new file mode 100644 index 00000000000..79f28bef6a0 --- /dev/null +++ b/test/run-drun/ok/pass-self.drun-run.ok @@ -0,0 +1,5 @@ +ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 +debug.print: Before! +debug.print: rwlgt-iiaaa-aaaaa-aaaaa-cai +debug.print: So far so good! +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/ok/pass-self.run-ir.ok b/test/run-drun/ok/pass-self.run-ir.ok new file mode 100644 index 00000000000..9deafdd2f39 --- /dev/null +++ b/test/run-drun/ok/pass-self.run-ir.ok @@ -0,0 +1,3 @@ +Before! +ys6dh-5cjiq-5dc +So far so good! diff --git a/test/run-drun/ok/pass-self.run-low.ok b/test/run-drun/ok/pass-self.run-low.ok new file mode 100644 index 00000000000..9deafdd2f39 --- /dev/null +++ b/test/run-drun/ok/pass-self.run-low.ok @@ -0,0 +1,3 @@ +Before! +ys6dh-5cjiq-5dc +So far so good! diff --git a/test/run-drun/ok/pass-self.run.ok b/test/run-drun/ok/pass-self.run.ok new file mode 100644 index 00000000000..9deafdd2f39 --- /dev/null +++ b/test/run-drun/ok/pass-self.run.ok @@ -0,0 +1,3 @@ +Before! +ys6dh-5cjiq-5dc +So far so good! diff --git a/test/run-drun/pass-class-self.mo b/test/run-drun/pass-class-self.mo new file mode 100644 index 00000000000..4777aabb58b --- /dev/null +++ b/test/run-drun/pass-class-self.mo @@ -0,0 +1,13 @@ +import { debugPrint; principalOfActor } = "mo:⛔"; + +actor class C() = Self { + public func method() : async () { debugPrint "YESS!"; ignore principalOfActor Self }; + func caller(_callee : shared () -> async ()) { }; + + debugPrint "Before!"; + ignore principalOfActor Self; + caller(Self.method); + caller(method); + //debugPrint (debug_show(principalOfActor Self)); // See #4733 + //debugPrint "So far so good!"; +} diff --git a/test/run-drun/pass-self.mo b/test/run-drun/pass-self.mo new file mode 100644 index 00000000000..3387d021215 --- /dev/null +++ b/test/run-drun/pass-self.mo @@ -0,0 +1,13 @@ +import { debugPrint; principalOfActor } = "mo:⛔"; + +actor Self { + public func method() : async () { debugPrint "YESS!"; ignore principalOfActor Self }; + func caller(_callee : shared () -> async ()) { }; + + debugPrint "Before!"; + ignore principalOfActor Self; + caller(Self.method); + caller(method); + debugPrint (debug_show(principalOfActor Self)); + debugPrint "So far so good!"; +}