Initial import of l4c

[snipe.git] / parse / astutils.sml

diff --git a/parse/astutils.sml b/parse/astutils.sml
new file mode 100644 (file)
index 0000000..72bdaeb
--- /dev/null
+++ b/parse/astutils.sml
@@ -0,0 +1,107 @@
+signature ASTUTILS =
+sig    
+  structure Program :
+  sig
+    val append_typedef : Ast.program -> (Ast.ident * Ast.typedef) -> Ast.program
+    val append_function : Ast.program -> (Ast.ident * Ast.function) -> Ast.program
+  end
+  
+  structure Typedef :
+  sig
+    val data : Ast.typedef -> Ast.typedef
+    val mark : Ast.typedef -> Mark.ext option
+  end
+  
+  structure Function :
+  sig
+    val data : Ast.function -> Ast.function
+    val mark : Ast.function -> Mark.ext option
+    val returntype : Ast.function -> Ast.vtype
+    val params : Ast.function -> Ast.variable list
+  end
+  
+  structure Type :
+  sig
+    val size : Ast.vtype -> int
+    val issmall : Ast.vtype -> bool
+  end
+end
+
+structure AstUtils :> ASTUTILS =
+struct
+  structure A = Ast
+
+  structure Program =
+  struct
+    fun append_typedef (tds, fns) (i, td) =
+      let
+        val mark = case td
+                   of A.MarkedTypedef m => Mark.ext m
+                    | _ => NONE
+        val _ = case (Symbol.look tds i)
+                of SOME (A.MarkedTypedef m) => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
+                                                ErrorMsg.error (Mark.ext m) "(was originally defined here)" ;
+                                                raise ErrorMsg.Error)
+                 | SOME _ => (ErrorMsg.error mark ("Redefining typedef " ^ Symbol.name i) ;
+                              raise ErrorMsg.Error)
+                 | _ => ()
+     in
+       (Symbol.bind tds (i, td), fns)
+     end
+    fun append_function (tds, fns) (i, func) =
+      let
+        val mark = case func
+                   of A.MarkedFunction m => Mark.ext m
+                    | _ => NONE
+        val _ = case (Symbol.look fns i)
+                of SOME (A.MarkedFunction m) => (ErrorMsg.error mark ("Redefining function " ^ Symbol.name i) ;
+                                                 ErrorMsg.error (Mark.ext m) "(was originally defined here)" ;
+                                                 raise ErrorMsg.Error)
+                 | SOME _ => (ErrorMsg.error mark ("Redefining function " ^ Symbol.name i) ;
+                              raise ErrorMsg.Error)
+                 | _ => ()
+     in
+       (tds, Symbol.bind fns (i, func))
+     end
+  end
+  
+  structure Typedef =
+  struct
+    fun data (A.MarkedTypedef m) = data (Mark.data m)
+      | data m = m
+    
+    fun mark (A.MarkedTypedef m) = Mark.ext m
+      | mark _ = NONE
+  end
+  
+  structure Function =
+  struct
+    fun data (A.MarkedFunction m) = data (Mark.data m)
+      | data m = m
+    
+    fun mark (A.MarkedFunction m) = Mark.ext m
+      | mark _ = NONE
+    
+    fun returntype (A.MarkedFunction m) = returntype (Mark.data m)
+      | returntype (A.Function (r, _, _, _)) = r
+      | returntype (A.Extern (r, _)) = r
+    
+    fun params (A.MarkedFunction m) = params (Mark.data m)
+      | params (A.Function (_, pl, _, _)) = pl
+      | params (A.Extern (_, pl)) = pl
+  end
+  
+  structure Type =
+  struct
+    fun size A.Int = 4
+      | size (A.Typedef _) = raise ErrorMsg.InternalError "AU.Type.size on non-small type?"
+      | size (A.Pointer _) = 8
+      | size (A.Array _) = 8
+      | size A.TNull = 8
+    
+    fun issmall A.Int = true
+      | issmall (A.Pointer _) = true
+      | issmall (A.Array _) = true
+      | issmall _ = false
+  end
+end