|
@@ -2564,40 +2564,8 @@ and type_ident ctx i p mode =
|
|
end
|
|
end
|
|
end
|
|
end
|
|
|
|
|
|
-and type_access ctx e p mode =
|
|
|
|
- match e with
|
|
|
|
- | EConst (Ident s) ->
|
|
|
|
- type_ident ctx s p mode
|
|
|
|
- | EField (e1,"new") ->
|
|
|
|
- let e1 = type_expr ctx e1 Value in
|
|
|
|
- begin match e1.eexpr with
|
|
|
|
- | TTypeExpr (TClassDecl c) ->
|
|
|
|
- if mode = MSet then error "Cannot set constructor" p;
|
|
|
|
- if mode = MCall then error ("Cannot call constructor like this, use 'new " ^ (s_type_path c.cl_path) ^ "()' instead") p;
|
|
|
|
- let monos = List.map (fun _ -> mk_mono()) c.cl_params in
|
|
|
|
- let ct, cf = get_constructor ctx c monos p in
|
|
|
|
- let args = match follow ct with TFun(args,ret) -> args | _ -> assert false in
|
|
|
|
- let vl = List.map (fun (n,_,t) -> alloc_var n t) args in
|
|
|
|
- let vexpr v = mk (TLocal v) v.v_type p in
|
|
|
|
- let el = List.map vexpr vl in
|
|
|
|
- let ec,t = match c.cl_kind with
|
|
|
|
- | KAbstractImpl a ->
|
|
|
|
- let e = type_module_type ctx (TClassDecl c) None p in
|
|
|
|
- let e = mk (TField (e,(FStatic (c,cf)))) ct p in
|
|
|
|
- let t = TAbstract(a,monos) in
|
|
|
|
- make_call ctx e el t p,t
|
|
|
|
- | _ ->
|
|
|
|
- let t = TInst(c,monos) in
|
|
|
|
- mk (TNew(c,monos,el)) t p,t
|
|
|
|
- in
|
|
|
|
- AKExpr(mk (TFunction {
|
|
|
|
- tf_args = List.map (fun v -> v,None) vl;
|
|
|
|
- tf_type = t;
|
|
|
|
- tf_expr = mk (TReturn (Some ec)) t p;
|
|
|
|
- }) (tfun (List.map (fun v -> v.v_type) vl) t) p)
|
|
|
|
- | _ -> error "Binding new is only allowed on class types" p
|
|
|
|
- end;
|
|
|
|
- | EField _ ->
|
|
|
|
|
|
+(* MORDOR *)
|
|
|
|
+and handle_efield ctx e p mode =
|
|
let fields ?(resume=false) path e =
|
|
let fields ?(resume=false) path e =
|
|
let resume = ref resume in
|
|
let resume = ref resume in
|
|
let force = ref false in
|
|
let force = ref false in
|
|
@@ -2712,6 +2680,42 @@ and type_access ctx e p mode =
|
|
fields acc (type_access ctx (fst e) (snd e))
|
|
fields acc (type_access ctx (fst e) (snd e))
|
|
in
|
|
in
|
|
loop [] (e,p) mode
|
|
loop [] (e,p) mode
|
|
|
|
+
|
|
|
|
+and type_access ctx e p mode =
|
|
|
|
+ match e with
|
|
|
|
+ | EConst (Ident s) ->
|
|
|
|
+ type_ident ctx s p mode
|
|
|
|
+ | EField (e1,"new") ->
|
|
|
|
+ let e1 = type_expr ctx e1 Value in
|
|
|
|
+ begin match e1.eexpr with
|
|
|
|
+ | TTypeExpr (TClassDecl c) ->
|
|
|
|
+ if mode = MSet then error "Cannot set constructor" p;
|
|
|
|
+ if mode = MCall then error ("Cannot call constructor like this, use 'new " ^ (s_type_path c.cl_path) ^ "()' instead") p;
|
|
|
|
+ let monos = List.map (fun _ -> mk_mono()) c.cl_params in
|
|
|
|
+ let ct, cf = get_constructor ctx c monos p in
|
|
|
|
+ let args = match follow ct with TFun(args,ret) -> args | _ -> assert false in
|
|
|
|
+ let vl = List.map (fun (n,_,t) -> alloc_var n t) args in
|
|
|
|
+ let vexpr v = mk (TLocal v) v.v_type p in
|
|
|
|
+ let el = List.map vexpr vl in
|
|
|
|
+ let ec,t = match c.cl_kind with
|
|
|
|
+ | KAbstractImpl a ->
|
|
|
|
+ let e = type_module_type ctx (TClassDecl c) None p in
|
|
|
|
+ let e = mk (TField (e,(FStatic (c,cf)))) ct p in
|
|
|
|
+ let t = TAbstract(a,monos) in
|
|
|
|
+ make_call ctx e el t p,t
|
|
|
|
+ | _ ->
|
|
|
|
+ let t = TInst(c,monos) in
|
|
|
|
+ mk (TNew(c,monos,el)) t p,t
|
|
|
|
+ in
|
|
|
|
+ AKExpr(mk (TFunction {
|
|
|
|
+ tf_args = List.map (fun v -> v,None) vl;
|
|
|
|
+ tf_type = t;
|
|
|
|
+ tf_expr = mk (TReturn (Some ec)) t p;
|
|
|
|
+ }) (tfun (List.map (fun v -> v.v_type) vl) t) p)
|
|
|
|
+ | _ -> error "Binding new is only allowed on class types" p
|
|
|
|
+ end;
|
|
|
|
+ | EField _ ->
|
|
|
|
+ handle_efield ctx e p mode
|
|
| EArray (e1,e2) ->
|
|
| EArray (e1,e2) ->
|
|
let e1 = type_expr ctx e1 Value in
|
|
let e1 = type_expr ctx e1 Value in
|
|
let e2 = type_expr ctx e2 Value in
|
|
let e2 = type_expr ctx e2 Value in
|