diff --git a/src/desugar.ml b/src/desugar.ml index dfa8b538d11..b5183963dea 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -4,7 +4,7 @@ module I = Ir module T = Type (* TODO: clean me up when IrOps available, especially build_obj *) - + (* Combinators used in the desguaring *) let bool_lit b : Ir.exp = @@ -162,8 +162,8 @@ let | d::ds -> match d.it with | S.ClassD(_,con_id,_,_,_,_,_) -> - let (c,k) = match con_id.note with Some p -> p | _ -> assert false in - let typD = {it = I.TypD (c,k); + let (c, k) = match con_id.note with Some p -> p | _ -> assert false in + let typD = {it = I.TypD (c, k); at = d.at; note = {S.note_typ = T.unit; S.note_eff = T.Triv}} in @@ -177,8 +177,8 @@ let let cc = Value.call_conv_of_typ n.S.note_typ in I.FuncD (cc, i, typ_binds tbs, pat p, ty.note, exp e) | S.TypD (con_id, typ_bind, t) -> - let (c,k) = Lib.Option.value con_id.note in - I.TypD (c,k) + let (c, k) = Lib.Option.value con_id.note in + I.TypD (c, k) | S.ClassD (fun_id, typ_id, tbs, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in let inst = List.map @@ -191,7 +191,7 @@ let match n.S.note_typ with | T.Func(s,c,bds,dom,[rng]) -> assert(List.length inst = List.length bds); - T.open_ inst rng + T.open_ inst rng | _ -> assert false in I.FuncD (cc, fun_id, typ_binds tbs, pat p, obj_typ, (* TBR *) diff --git a/src/parser.mly b/src/parser.mly index 790010219b8..fcd0e5247e6 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -27,11 +27,14 @@ let (@=) it at = {it; at; note = None} let dummy_obj_sort() = ref (Type.Object Type.Local) let dup_var x = VarE (x.it @@ x.at) @? x.at + +let anon sort at = "anon-" ^ sort ^ "-" ^ string_of_pos at.left + let name_exp e = match e.it with | VarE x -> [], e, dup_var x | _ -> - let x = ("anon-val-" ^ string_of_pos (e.at.left)) @@ e.at in + let x = anon "val" e.at @@ e.at in [LetD (VarP x @! x.at, e) @? e.at], dup_var x, dup_var x let assign_op lhs rhs_f at = @@ -164,8 +167,7 @@ seplist1(X, SEP) : | id=ID { fun _ _ -> id @@ at $sloc } | (* empty *) - { fun sort sloc -> - ("anon-" ^ sort ^ "-" ^ string_of_pos (at sloc).left) @@ at sloc } + { fun sort sloc -> anon sort (at sloc) @@ at sloc } %inline var_opt : | (* empty *) { Const @@ no_region } @@ -456,9 +458,9 @@ exp : { e } | d=dec_var { DecE(d, ref Type.Pre) @? at $sloc } - - -case : + + +case : | CASE p=pat_nullary e=exp { {pat = p; exp = e} @@ at $sloc } @@ -558,15 +560,22 @@ dec : | e=exp_nondec { ExpD e @? at $sloc } (* TODO(andreas): move to dec_nonvar once other production is gone *) - | s=obj_sort xf=id_opt EQ? efs=obj_body - { let anon = if s.it = Type.Actor then "actor" else "object" in - let efs' = + | s=obj_sort id_opt=id? EQ? efs=obj_body + { let efs' = if s.it = Type.Object Type.Local then efs else List.map share_expfield efs in - let p = VarP(xf anon $sloc) @! at $sloc in - LetD(p, ObjE(s, xf anon $sloc, efs') @? at $sloc) @? at $sloc } + let r = at $sloc in + (* desugar anonymous objects to ExpD, named ones to LetD. *) + match id_opt with + | None -> + let sort = if s.it = Type.Actor then "actor" else "object" in + let x = anon sort r @@ r in + ExpD(ObjE(s, x, efs') @? r) @? r + | Some x -> + let p = VarP x @! r in + LetD(p, ObjE(s, x, efs') @? r) @? r } func_dec : | tps=typ_params_opt p=pat_nullary rt=return_typ? fb=func_body @@ -592,7 +601,7 @@ obj_body : class_body : | EQ xf=id_opt efs=obj_body { xf "object" $sloc, efs } - | efs=obj_body { ("anon-object-" ^ string_of_pos (at $sloc).left) @@ at $sloc, efs } + | efs=obj_body { anon "object" (at $sloc) @@ at $sloc, efs } (* Programs *) diff --git a/src/typing.ml b/src/typing.ml index eb2fe0ceca9..74f1eb0bc8f 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -1082,9 +1082,8 @@ and check_dec env t dec = (* TBR: special-case unit? *) if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then local_error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" - (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons t') - + (T.string_of_typ_expand env.cons t) (* and print_ce = Con.Env.iter (fun c k -> @@ -1167,8 +1166,7 @@ and infer_dec_typdecs env dec : con_env = let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in let k = T.Abs (tbs, T.close cs t) in id.note <- Some (c, k); - Con.Env.singleton c (T.Abs (tbs, T.close cs t)) - + Con.Env.singleton c k (* Pass 4: collect value identifiers *) and gather_block_valdecs env decs : val_env = @@ -1185,7 +1183,6 @@ and gather_dec_valdecs env ve dec : val_env = error env dec.at "duplicate definition for %s in block" id.it; T.Env.add id.it T.Pre ve - (* Pass 5: infer value types *) and infer_block_valdecs env decs : val_env = let _, ve = diff --git a/test/run/issue129.as b/test/run/issue129.as new file mode 100644 index 00000000000..8cdfde339f3 --- /dev/null +++ b/test/run/issue129.as @@ -0,0 +1,14 @@ +// status.as +type Status = { + failed_ : Nat; + passed_ : Nat; + pending_ : Nat; +}; + +let appendStatus = func (x : Status, y : Status) : Status { + new { + failed_ = x.failed_ + y.failed_; + passed_ = x.passed_ + y.passed_; + pending_ = x.pending_ + y.pending_; + }; +};