wip

ast.ml

@@ -5,17 +5,19 @@ type type_t =
   | Bool_t
   | Str_t
   | Func_t of type_t * type_t list
+  | Ptr_t of type_t
+
+type ident = string
 
 module Syntax = struct
-  type ident = string
-
   type value =
     | Void
     | Int of int
     | Bool of bool
     | Str of string
+    | Ptr of expr
 
-  type expr =
+  and expr =
     | Val of
         { value : value
         ; pos : Lexing.position
@@ -30,6 +32,10 @@ module Syntax = struct
         ; pos : Lexing.position
         }
 
+  type lval =
+    | Name of ident
+    | Addr of expr
+
   type instr =
     | Decl of
         { name : ident
@@ -37,7 +43,7 @@ module Syntax = struct
         ; pos : Lexing.position
         }
     | Assign of
-        { var : ident
+        { lval : lval
         ; expr : expr
         ; pos : Lexing.position
         }
@@ -93,6 +99,7 @@ module V1 = struct
     | Int of int
     | Bool of bool
     | Str of string
+    | Ptr of int
 end
 
 module V2 = struct
@@ -101,19 +108,22 @@ module V2 = struct
     | Int of int
     | Bool of bool
     | Data of string
+    | Ptr of int
 end
 
 module IR (P : Parameters) = struct
-  type ident = string
-
   type expr =
     | Val of P.value
     | Var of ident
     | Call of ident * expr list
 
+  type lval =
+    | Name of ident
+    | Addr of expr
+
   type instr =
     | Decl of ident
-    | Assign of ident * expr
+    | Assign of lval * expr
     | Do of expr
     | Cond of expr * block * block
     | Loop of expr * block

baselib.ml

@@ -16,6 +16,8 @@ let _types_ =
        ; "puti", Func_t (Void_t, [ Int_t ])
        ; "puts", Func_t (Void_t, [ Str_t ])
        ; "geti", Func_t (Int_t, [])
+       ; "alloc", Func_t (Ptr_t Magic_t, [ Int_t ])
+       ; "%deref", Func_t (Magic_t, [ Ptr_t Magic_t ])
        ])
 ;;
 
@@ -54,5 +56,7 @@ let builtins uniq =
     ; "puti", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.print_int); Syscall ]
     ; "puts", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.print_str); Syscall ]
     ; "geti", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.read_int); Syscall ]
+    ; "alloc", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.sbrk); Syscall ]
+    ; "%deref", [ Lw (T0, Mem (SP, 0)); Lw (A0, Mem (T0, 0)); Syscall ]
     ]
 ;;

compiler.ml

@@ -19,6 +19,7 @@ let compile_value = function
   | Int n -> [ Li (V0, n) ]
   | Bool b -> [ Li (V0, if b then 1 else 0) ]
   | Data l -> [ La (V0, Lbl l) ]
+  | Ptr p -> [ Li (V0, p) ]
 ;;
 
 let rec compile_expr env = function
@@ -47,9 +48,18 @@ let rec compile_expr env = function
 let rec compile_instr info = function
   | Decl v ->
     { info with env = Env.add v (Mem (FP, -info.fpo)) info.env; fpo = info.fpo + 4 }
-  | Assign (v, e) ->
+  | Assign (lv, e) ->
     { info with
-      asm = info.asm @ compile_expr info.env e @ [ Sw (V0, Env.find v info.env) ]
+      asm =
+        (info.asm
+        @ compile_expr info.env e
+        @
+        match lv with
+        | Name v -> [ Sw (V0, Env.find v info.env) ]
+        | Addr e ->
+          [ Addi (SP, SP, -4); Sw (V0, Mem (SP, 0)) ]
+          @ compile_expr info.env e
+          @ [ Lw (T0, Mem (SP, 0)); Addi (SP, SP, 4); Sw (T0, Mem (V0, 0)) ])
     }
   | Cond (e, ib, eb) ->
     let uniq = string_of_int info.cnt in

errors.ml

@@ -26,6 +26,7 @@ let rec string_of_type_t = function
     ^ (if List.length a > 1 then ")" else "")
     ^ " -> "
     ^ string_of_type_t r
+  | Ptr_t t -> "*" ^ string_of_type_t t
 ;;
 
 let errt expected given pos =

lexer.mll

@@ -32,7 +32,7 @@ rule token = parse
   | ';'           { Lsc }
   | '+'           { Ladd }
   | '-'           { Lsub }
-  | '*'           { Lmul }
+  | '*'           { Lstar }
   | '/'           { Ldiv }
   | '<'           { Lsmaller }
   | '>'           { Lbigger }

main.ml

@@ -10,7 +10,7 @@ let () =
   try
     let parsed = Parser.prog Lexer.token buf in
     close_in f;
-    (* Test.debug_parser Stdlib.stderr parsed; *)
+    Test.debug_parser Stdlib.stderr parsed;
     let ast = Semantics.analyze parsed in
     (* Test.debug_semantics Stdlib.stderr ast; *)
     let asm = Compiler.compile (Simplifier.simplify ast) in

parser.mly

@@ -11,10 +11,10 @@
 %token Lend Lassign Lsc Lreturn
 %token Lbracedeb Lbracefin
 %token Lpardeb Lparfin Lcomma
-%token Ladd Lsub Lmul Ldiv Lbigger Lsmaller Leq Lneq
+%token Ladd Lsub Lstar Ldiv Lbigger Lsmaller Leq Lneq
 %token Lif Lelse Lwhile
 
-%left Ladd Lsub Lmul Ldiv Lbigger Lsmaller Leq Lneq
+%left Ladd Lsub Lstar Ldiv Lbigger Lsmaller Leq Lneq
 
 %left Lbracedeb Lparfin Lbracefin Lreturn
 %left Ltype Lbool Lint Lvar Lstr
@@ -94,20 +94,37 @@ instr:
              ; pos = $startpos } ]
     }
 
+  /* type *v; */
+  | t = Ltype ; Lstar ; v = Lvar ; Lsc {
+    [ Decl { name = v ; type_t = Ptr_t t ; pos = $startpos(t) } ]
+  }
+
   /* type v; */
   | t = Ltype ; v = Lvar ; Lsc {
     [ Decl { name = v ; type_t = t ; pos = $startpos(t) } ]
   }
+  /* type *v = e; */
+  | t = Ltype ; Lstar ; v = Lvar ; Lassign ; e = expr ; Lsc
+    { [ Decl { name = v ; type_t = Ptr_t t ; pos = $startpos(t) }
+    ; Assign { lval = Name v ; expr = e ; pos = $startpos(v) } ]
+    }
 
   /* type v = e; */
   | t = Ltype ; v = Lvar ; Lassign ; e = expr ; Lsc
     { [ Decl { name = v ; type_t = t ; pos = $startpos(t) }
-    ; Assign { var = v ; expr = e ; pos = $startpos(v) } ]
+    ; Assign { lval = Name v ; expr = e ; pos = $startpos(v) } ]
     }
 
+  /* *v = e; */
+  | Lstar; v = Lvar ; Lassign ; e = expr ; Lsc {
+    [ Assign { lval = Addr (Var { name = v ; pos = $startpos(v) })
+             ; expr = e
+             ; pos = $startpos(e) } ]
+  }
+
   /* v = e; */
   | v = Lvar ; Lassign ; e = expr ; Lsc {
-    [ Assign { var = v ; expr = e ; pos = $startpos($2) } ]
+    [ Assign { lval = Name v ; expr = e ; pos = $startpos($2) } ]
   }
 
   /* e; */
@@ -162,7 +179,7 @@ expr:
   }
 
   /* e * e */
-  | a = expr ; Lmul ; b = expr {
+  | a = expr ; Lstar ; b = expr {
     Call { func = "%mul" ; args = [ a ; b ] ; pos = $startpos($2) }
   }
 
@@ -191,6 +208,11 @@ expr:
     Call { func = "%neq" ; args = [ a ; b ] ; pos = $startpos($2) }
   }
 
+  /* *e */
+  | Lstar; a = expr {
+    Call { func = "%deref" ; args = [ a ] ; pos = $startpos }
+  }
+
   /* function(a */
   | f = Lvar ; Lpardeb ; a = args_expr {
     Call { func = f ; args = a ; pos = $startpos(a) }

semantics.ml

@@ -4,31 +4,38 @@ open Ast.V1
 open Baselib
 open Errors
 
-let analyze_value = function
+let rec analyze_value = function
   | Syntax.Void -> Void, Void_t
   | Syntax.Int n -> Int n, Int_t
   | Syntax.Bool b -> Bool b, Bool_t
   | Syntax.Str s -> Str s, Str_t
+  | Syntax.Ptr v ->
+    let v2, t = analyze_value v in
+    Ptr 0, Ptr_t t
 ;;
 
 let rec analyze_expr env ua t = function
   | Syntax.Val v ->
     let v2, new_t = analyze_value v.value in
-    if new_t != t && t != Magic_t then errt t new_t v.pos;
+    (match t with
+    | Ptr_t t2 -> if new_t != t && t2 != Magic_t then errt t new_t v.pos
+    | _ -> if new_t != t && t != Magic_t then errt t new_t v.pos);
     Val v2, new_t
   | Syntax.Var v ->
     if not (Env.mem v.name env)
     then raise (SemanticsError ("Unbound variable \"" ^ v.name ^ "\"", v.pos));
     if List.mem v.name ua then warn ("Unassigned variable \"" ^ v.name ^ "\"") v.pos;
     let new_t = Env.find v.name env in
-    if new_t != t then errt t new_t v.pos;
+    if new_t != t && t != Magic_t then errt t new_t v.pos;
     Var v.name, new_t
   | Syntax.Call c ->
     if not (Env.mem c.func env)
     then raise (SemanticsError ("Unbound function \"" ^ c.func ^ "\"", c.pos));
     (match Env.find c.func env with
     | Func_t (ret_t, tl) ->
-      if ret_t != t && t != Magic_t then errt ret_t t c.pos;
+      (match ret_t with
+      | Ptr_t t2 -> if ret_t != t && t2 != Magic_t then errt ret_t t c.pos
+      | _ -> if ret_t != t && t != Magic_t then errt ret_t t c.pos);
       if List.length tl != List.length c.args
       then
         raise
@@ -63,10 +70,23 @@ let rec analyze_expr env ua t = function
 let rec analyze_instr env ua ret_t = function
   | Syntax.Decl d -> Decl d.name, Env.add d.name d.type_t env, [ d.name ] @ ua
   | Syntax.Assign a ->
-    if not (Env.mem a.var env)
+    let var, t =
-    then raise (SemanticsError ("Unbound variable \"" ^ a.var ^ "\"", a.pos));
+      match a.lval with
-    let ae, et = analyze_expr env ua (Env.find a.var env) a.expr in
+      | Name i -> i, Env.find i env
-    Assign (a.var, ae), env, List.filter (fun x -> x <> a.var) ua
+      | Addr e ->
+        let ae, t = analyze_expr env ua Magic_t e in
+        (match ae with
+        | Var v ->
+          ( v
+          , (match t with
+            | Ptr_t t -> t
+            | _ -> raise (SemanticsError ("Something went wrong", a.pos))) )
+        | _ -> raise (SemanticsError ("Can't assign to this address", a.pos)))
+    in
+    if not (Env.mem var env)
+    then raise (SemanticsError ("Unbound variable \"" ^ var ^ "\"", a.pos));
+    let ae, et = analyze_expr env ua t a.expr in
+    Assign (Name var, ae), env, List.filter (fun x -> x <> var) ua
   | Syntax.Do d ->
     let ae, _ = analyze_expr env ua Magic_t d.expr in
     Do ae, env, []

simplifier.ml

@@ -4,7 +4,7 @@ open Baselib
 let collect_constant_strings code =
   let counter = ref (-1) in
   let env = ref Env.empty in
-  let ccs_value = function
+  let rec ccs_value = function
     | V1.Void -> V2.Void, []
     | V1.Bool b -> V2.Bool b, []
     | V1.Int n -> V2.Int n, []
@@ -16,6 +16,9 @@ let collect_constant_strings code =
         let lbl = "str" ^ string_of_int !counter in
         env := Env.add s lbl !env;
         V2.Data lbl, [ lbl, Mips.Asciiz s ])
+    | V1.Ptr p ->
+      let v2, ccs = ccs_value p in
+      V2.Ptr v2, [] @ ccs
   in
   let rec ccs_expr = function
     | IR1.Val v ->
@@ -26,11 +29,18 @@ let collect_constant_strings code =
       let args2 = List.map ccs_expr args in
       IR2.Call (fn, List.map fst args2), List.flatten (List.map snd args2)
   in
+  let ccs_lval = function
+    | IR1.Name v -> IR2.Name v, []
+    | IR1.Addr e ->
+      let e2, ccs = ccs_expr e in
+      IR2.Addr e2, ccs
+  in
   let rec ccs_instr = function
     | IR1.Decl v -> IR2.Decl v, []
     | IR1.Assign (lv, e) ->
+      let lv2, ccs2 = ccs_lval lv in
       let e2, ccs = ccs_expr e in
-      IR2.Assign (lv, e2), ccs
+      IR2.Assign (lv2, e2), ccs @ ccs2
     | IR1.Do e ->
       let e2, ccs = ccs_expr e in
       IR2.Do e2, ccs

test.ml

@@ -9,14 +9,18 @@ let debug_parser oc parsed =
     | Syntax.Int d -> "Int " ^ string_of_int d
     | Syntax.Bool d -> "Bool " ^ string_of_bool d
     | Syntax.Str s -> "Str \"" ^ s ^ "\""
+    | Syntax.Ptr t -> "*" ^ fmt_v t
   and fmt_e = function
     | Syntax.Val d -> "Val (" ^ fmt_v d.value ^ ")"
     | Syntax.Var d -> "Var \"" ^ d.name ^ "\""
     | Syntax.Call d ->
       "Call (\"" ^ d.func ^ "\", [ " ^ String.concat " ; " (List.map fmt_e d.args) ^ " ])"
+  and fmt_lv = function
+    | Syntax.Name n -> "Name(\"" ^ n ^ "\")"
+    | Syntax.Addr e -> "Addr(" ^ fmt_e e ^ ")"
   and fmt_i = function
     | Syntax.Decl d -> "Decl(" ^ string_of_type_t d.type_t ^ ") \"" ^ d.name ^ "\""
-    | Syntax.Assign d -> "Assign (\"" ^ d.var ^ "\", " ^ fmt_e d.expr ^ ")"
+    | Syntax.Assign d -> "Assign (" ^ fmt_lv d.lval ^ ", " ^ fmt_e d.expr ^ ")"
     | Syntax.Do d -> "Do (" ^ fmt_e d.expr ^ ")"
     | Syntax.Cond c ->
       "Cond (" ^ fmt_e c.expr ^ ", " ^ fmt_b c.if_b ^ ", " ^ fmt_b c.else_b ^ ")"
@@ -50,6 +54,7 @@ let debug_semantics oc ast =
     | Int n -> "Int " ^ string_of_int n
     | Bool b -> "Bool " ^ string_of_bool b
     | Str s -> "Str \"" ^ s ^ "\""
+    | Ptr p -> "Ptr of " ^ fmt_v p
   and fmt_e = function
     | Val v -> "Val (" ^ fmt_v v ^ ")"
     | Var v -> "Var \"" ^ v ^ "\""
@@ -57,7 +62,14 @@ let debug_semantics oc ast =
       "Call (\"" ^ f ^ "\", [ " ^ String.concat " ; " (List.map fmt_e a) ^ " ])"
   and fmt_i = function
     | Decl v -> "Decl \"" ^ v ^ "\""
-    | Assign (v, e) -> "Assign (\"" ^ v ^ "\", " ^ fmt_e e ^ ")"
+    | Assign (lv, e) ->
+      "Assign (\""
+      ^ (match lv with
+        | Name v -> v
+        | Addr e -> fmt_e e)
+      ^ "\", "
+      ^ fmt_e e
+      ^ ")"
     | Do e -> "Do (" ^ fmt_e e ^ ")"
     | Cond (c, i, e) -> "Cond (" ^ fmt_e c ^ ", " ^ fmt_b i ^ ", " ^ fmt_b e ^ ")"
     | Loop (c, b) -> "Loop (" ^ fmt_e c ^ ", " ^ fmt_b b ^ ")"

tests/34_alloc.test

@@ -0,0 +1,7 @@
+void main () {
+    int *a = alloc(8);
+    *a = 4;
+    puti(a);
+    puts(" - ");
+    puti(*a);
+}