AST refactor

lib/ast.ml

@@ -1,3 +1,5 @@
+exception Syntax_error of string
+
 type numBinOp =
   | Eq | Neq
   | Lt | Le | Gt | Ge
@@ -10,13 +12,6 @@ type param = {
 }
 [@@deriving show]
 
-type ctorParam = {
-  isMember: bool;
-  name: string;
-  className: string;
-}
-[@@deriving show]
-
 type instr =
   | Block of param list * instr list
   | Assign of expr * expr
@@ -39,14 +34,6 @@ and expr =
   | StaticCast of string * expr
 [@@deriving show]
 
-type ctorDecl = {
-  name: string;
-  params: ctorParam list;
-  superCall: (string * expr list) option;
-  body: instr;
-}
-[@@deriving show]
-
 type methodDecl = {
   name: string;
   override: bool;
@@ -56,11 +43,16 @@ type methodDecl = {
 }
 [@@deriving show]
 
+type superCall = {
+  name: string;
+  args: expr list
+}
+[@@deriving show]
+
 type classDecl = {
   name: string;
-  ctorParams: ctorParam list;
-  superclass: string option;
-  ctor: ctorDecl;
+  super: superCall option;
+  ctor: methodDecl;
   staticMethods: methodDecl list;
   instMethods: methodDecl list;
   staticAttrs: param list;

lib/astmanip.ml

@@ -20,10 +20,10 @@ let get_class decls name =
 let rec recursively decls decl f =
   f decl
   |> Optmanip.or_else (fun () ->
-      match decl.superclass with
+      match decl.super with
       | None -> None
       | Some(super) ->
-        (get_class_opt decls super)
+        (get_class_opt decls super.name)
         |> Optmanip.and_then (fun superDecl ->
             recursively decls superDecl f
           )
@@ -33,10 +33,10 @@ let rec recursively decls decl f =
     @raise Not_found if an ancestor has no declaration. *)
 
 let rec ancestors decls decl =
-  match decl.superclass with
+  match decl.super with
   | None -> []
   | Some(super) ->
-    let superDecl = (get_class decls super) in
+    let superDecl = (get_class decls super.name) in
     superDecl :: (ancestors decls superDecl)
 
 (** Get the method declaration in a class with a given name. *)
@@ -81,12 +81,7 @@ let get_static_method name decl =
 let get_inst_attr_opt attrName decl =
   let pred (attr: param) =
     if attr.name = attrName then Some(attr.className) else None
-  in let pred2 (attr: ctorParam) =
-       if attr.name = attrName then Some(attr.className) else None
   in List.find_map pred decl.instAttrs
-     |> Optmanip.or_else (fun () ->
-         List.find_map pred2 decl.ctorParams
-       )
 
 (** Find (recursively through ancestors) the type of an attribute in a class declaration. *)
 
@@ -208,8 +203,8 @@ let is_base decls derived base =
 
 let make_class_env decl =
   let env = ("this", decl.name) :: []
-  in let env = match decl.superclass with
-      | Some(super) -> ("super", super) :: env
+  in let env = match decl.super with
+      | Some(super) -> ("super", super.name) :: env
       | None -> env
   in env
 

lib/compil.ml

@@ -50,10 +50,10 @@ let make_method_addrs params =
 let rec all_attrs decls decl = 
   let attrs = 
     List.map (fun ({ name; _ }: param) -> name) decl.instAttrs
-  in match decl.superclass with
+  in match decl.super with
   | None -> attrs
   | Some(super) ->
-    let super = get_class decls super
+    let super = get_class decls super.name
     in all_attrs decls super @ attrs
 
 (** Get the offset of an instance attribute in a class. *)
@@ -274,11 +274,10 @@ let compile chan ast =
       Expects 'this' on stack and leave 'this' after execution. *)
 
   in let code_super_call addrs env decl =
-    let args = snd (decl.ctor.superCall |> Option.get)
-    in let super = decl.superclass |> Option.get
+    let { args; name } = Option.get decl.super
     in List.iter (code_expr addrs env) args; (* push args *)
     _PUSHL (-1 - List.length args); (* push this *)
-    _PUSHA (ctor_lbl super);
+    _PUSHA (ctor_lbl name);
     _CALL ();
     _POPN ((List.length args) + 1) (* pop args & this *)
 
@@ -293,7 +292,7 @@ let compile chan ast =
     in let vti = Util.index_of decl decls
 
     in let rec call_super_ctor decl = 
-      match decl.superclass with 
+      match decl.super with 
       | Some(_) -> code_super_call addrs [] decl        
       | None -> ()
 

lib/contextual.ml

@@ -7,7 +7,7 @@ exception Contextual_error of string
 let err str = raise (Contextual_error str)
 (* let err str = print_endline @@ "[CONTEXTUAL ERROR]: " ^ str; () *)
 
-(** Check that methods, instance attributes and static attributes unique in a class declaration.
+(** Check that methods, instance attributes and static attributes are unique in a class declaration.
     @raise Contextual_error if a check fails. *)
 
 let check_no_dup decl =
@@ -33,11 +33,11 @@ let check_no_dup decl =
 
 let check_inheritance decls =
   let decls_with_super = decls |> List.filter_map (fun d ->
-      d.superclass |> Optmanip.map (fun super -> (d.name, super))
+      d.super |> Optmanip.map (fun super -> (d.name, super))
     )
-  in decls_with_super |> List.iter (fun (name, super) ->
-      match get_class_opt decls super with
-      | None -> err (Printf.sprintf "class '%s' extends unknown class '%s'" name super)
+  in decls_with_super |> List.iter (fun (name, (super: superCall)) ->
+      match get_class_opt decls super.name with
+      | None -> err (Printf.sprintf "class '%s' extends unknown class '%s'" name super.name)
       | _ -> ()
     )
 
@@ -47,11 +47,11 @@ let check_inheritance decls =
 let check_cycles decls =
   (* complexity unoptimized (add memoization?) *)
   let rec r_check ancestors decl =
-    match decl.superclass with
+    match decl.super with
     | Some(super) ->
-      let superDecl = get_class_opt decls super |> Option.get in
+      let superDecl = get_class_opt decls super.name |> Option.get in
       if List.exists ((=) super) ancestors
-      then err (Printf.sprintf "cycle in heritance: class '%s' extends ancestor class '%s'" decl.name super)
+      then err (Printf.sprintf "cycle in heritance: class '%s' extends ancestor class '%s'" decl.name super.name)
       else r_check (super::ancestors) superDecl
     | None -> ()
   in List.iter (r_check []) decls
@@ -88,9 +88,9 @@ let check_overrides decls decl =
        then err (Printf.sprintf "method '%s' of base class '%s' is marked override" meth.name decl.name)
        else ()
 
-  in match decl.superclass with
+  in match decl.super with
   | Some(super) ->
-    let superDecl = get_class decls super
+    let superDecl = get_class decls super.name
     in List.iter (check_super_method superDecl) decl.instMethods
   | None -> List.iter check_base_method decl.instMethods
 
@@ -140,11 +140,11 @@ let check_no_reserved_var vars =
     @raise Contextual_error if a check fails. *)
 
 let check_no_reserved_class decls =
-  let reserved = ["String"; "Integer"; "_Void"]
+  let reserved = ["String"; "Integer"]
 
   in let check decl =
-       if List.exists (fun r -> decl.name = r || decl.superclass = Some(r)) reserved
-       then err (Printf.sprintf "use of reserved class in class '%s'" decl.name)
+    if List.exists ((=) decl.name) reserved
+    then err (Printf.sprintf "use of reserved class in class '%s'" decl.name)
 
   in List.iter check decls
 
@@ -311,12 +311,12 @@ and check_expr_new decls env (className, args) =
          if not (is_base decls arg param)
          then err (Printf.sprintf "invalid call argument: type '%s' is incompatible with '%s'" arg param)
 
-    in if List.length args <> List.length decl.ctorParams
+    in if List.length args <> List.length decl.ctor.params
     then err (Printf.sprintf "invalid number of arguments in instantiation of '%s'" className);
 
-    List.iter2 (fun arg (param: ctorParam) ->
+    List.iter2 (fun arg (param: param) ->
         check_arg arg param.className
-      ) args decl.ctorParams
+      ) args decl.ctor.params
 
 and check_expr_cast decls env (className, e) = 
   check_expr decls env e;
@@ -362,7 +362,6 @@ and check_expr decls env expr =
 
 (** Check constructor declaration validity. Performs following checks:
     * Constructor name and class name are equal
-    * Constructor parameters and class parameters are equal
     * Constructor parameters have no reserved keywords
     * Constructor calls the right super constructor if class is derived
     * Constructor does not call any super constructor if class is base
@@ -383,25 +382,18 @@ let check_ctor decls decl =
     if decl.name <> ctor.name
     then err (Printf.sprintf "constructor name '%s' does dot correspond with class name '%s'" ctor.name decl.name)
     else ();
-
-    (match decl.superclass, ctor.superCall with
-     | Some(n1), Some(n2, _) when n1 <> n2 -> err (Printf.sprintf "class '%s' extends superclass '%s' but constructor calls super constructor of '%s'" decl.name n1 n2)
-     | Some(n1), None -> err (Printf.sprintf "class '%s' extends superclass '%s' but constructor does not call the super constructor" decl.name n1)
-     | None, Some(n2, _) -> err (Printf.sprintf "class '%s' is a base class but constructor calls super constructor of '%s'" decl.name n2)
-     | _ -> ());
 
-    (match ctor.superCall with
-     | Some(super, args) ->
-        let superDecl = get_class decls super
-        in let superParams = ctor_params_to_method_params superDecl.ctorParams
+    (match decl.super with
+     | Some{ name; args } ->
+        let superDecl = get_class decls name
         in let args = args |> List.map (fun e ->
           check_expr decls env e;
           get_expr_type decls env e
         )
-        in check_call_args decls args superParams
+        in check_call_args decls args superDecl.ctor.params
      | None -> ());
 
-    if ctor.params <> decl.ctorParams
+    if ctor.params <> decl.ctor.params
     then err (Printf.sprintf "constructor params of class '%s' do not correspond with the constructor definition" decl.name)
     else ();
 

lib/parser.mly

@@ -1,12 +1,13 @@
 %{
 open Ast
 
-exception Syntax_error of string
+type ctorParam = { param: Ast.param; isMember: bool }
+type ctorDecl = { meth: Ast.methodDecl; super: superCall option; cparams: ctorParam list }
 
 type classBodyElt =
   | StaticMethod of Ast.methodDecl
   | InstMethod of Ast.methodDecl
-  | Ctor of Ast.ctorDecl
+  | Ctor of ctorDecl
   | StaticAttrib of Ast.param list
   | InstAttrib of Ast.param list
 
@@ -71,11 +72,23 @@ prog:
 classDecl:
   CLASS name = CLASSNAME ctorParams = ctorParamList superclass = extends IS LCURLY l = list(classBodyElement) RCURLY {
     let (lsm, lim, lc, lsa, lia) = split_body_elts l
-    in if List.length lc <> 1
-    then raise (Syntax_error (Printf.sprintf "class '%s' defines %d constructor(s), expected 1" name (List.length lc)))
-    else
-      let ctor = List.hd lc
-      in { name; ctorParams; superclass; staticMethods=lsm; instMethods=lim; ctor; staticAttrs=lsa; instAttrs=lia }
+
+    in let ctor = 
+      if List.length lc <> 1
+      then raise (Syntax_error (Printf.sprintf "class '%s' defines %d constructor(s), expected 1" name (List.length lc)))
+      else List.hd lc
+
+    in let lia = lia @ (ctor.cparams |> List.filter_map (fun p -> if p.isMember then Some(p.param) else None))
+
+    in if ctorParams <> ctor.cparams
+      then raise (Syntax_error (Printf.sprintf "different parameters between class '%s' header and constructor definition" name));
+
+    (match ctor.super, superclass with
+    | None, None -> ()
+    | Some{ name=s1; args=_ }, Some(s2) when s1 = s2 -> ()
+    | _ -> raise (Syntax_error (Printf.sprintf "different super class between class '%s' header and constructor definition" name)));
+
+    { name; super=ctor.super; staticMethods=lsm; instMethods=lim; ctor=ctor.meth; staticAttrs=lsa; instAttrs=lia }
   }
 
 classBodyElement:
@@ -98,14 +111,25 @@ methodDecl:
   }
 
 ctorDecl:
-  | DEF name = CLASSNAME params = ctorParamList IS body = instrBlock {
-    Ctor({ name; params; superCall=None; body;  })
+  | DEF name = CLASSNAME cparams = ctorParamList IS b = instrBlock {
+    let instAttrs = cparams |> List.filter_map (fun p -> if p.isMember then Some(p.param) else None)
+    in let params = cparams |> List.map (fun p -> p.param)
+    in let prelude = instAttrs |> List.map (fun (p: param) -> Assign(Attr(Id("this"), p.name), Id(p.name))) 
+    in let body = match b with
+    | Block(lp, li) -> Block(lp, prelude @ li)
+    | _ -> failwith "unreachable"
+    in Ctor({ super=None; meth={ name; params; body; override=false; retType=None }; cparams })
   }
-  | DEF name = CLASSNAME params = ctorParamList COLON super = CLASSNAME lsuper = superList IS b = instrBlock {
-    Ctor({ name; params; superCall=Some(super, lsuper); body=b; })
+  | DEF name = CLASSNAME cparams = ctorParamList COLON super = CLASSNAME lsuper = superList IS b = instrBlock {
+    let instAttrs = cparams |> List.filter_map (fun p -> if p.isMember then Some(p.param) else None)
+    in let params = cparams |> List.map (fun p -> p.param)
+    in let prelude = instAttrs |> List.map (fun (p: param) -> Assign(Attr(Id("this"), p.name), Id(p.name))) 
+    in let body = match b with
+    | Block(lp, li) -> Block(lp, prelude @ li)
+    | _ -> failwith "unreachable"
+    in Ctor({ super=Some{name=super; args=lsuper}; meth={ name; params; body; override=false; retType=None }; cparams })
   }
 
-
 attrDecl:
   | VAR static = boption(STATIC) lname = separated_list(COMMA, ID) COLON className = CLASSNAME {
     let p = List.map (fun name -> { name; className }) lname in
@@ -123,7 +147,7 @@ ctorParamList:
 
 ctorParam:
   isMember = boption(VAR) names = separated_nonempty_list(COMMA, ID) COLON className = CLASSNAME
-  { List.map (fun name -> { isMember; name; className }) names }
+  { List.map (fun name -> { isMember; param={ name; className } }) names }
 
 extends:
   | EXTENDS id = CLASSNAME { Some(id) }

lib/vtable.ml

@@ -25,10 +25,10 @@ let insert vt methName decl =
 (** Build a VTable from a class declaration *)
 
 let rec make decls decl = 
-  match decl.superclass with
+  match decl.super with
   | Some(super) ->
-      let super = get_class decls super 
-      in let vt = make decls super
+      let superDecl = get_class decls super.name 
+      in let vt = make decls superDecl
       in decl.instMethods
       |> List.fold_left (fun vt (m: methodDecl) -> 
           insert vt m.name decl