Dumps implemented

src/Driver.ml

@@ -37,11 +37,14 @@ exception Commandline_error of string
 class options args =
   let n = Array.length args in
   let rec fix f = f (fix f) in
+  let dump_ast  = 1 in
+  let dump_sm   = 2 in
   object (self)
     val i      = ref 1
     val infile = ref (None : string option)
     val paths  = ref [try Sys.getenv "RC_RUNTIME" with _ -> "../runtime"]
     val mode   = ref (`Default : [`Default | `Eval | `SM | `Compile ])
+    val dump   = ref 0
     val help   = ref false
     initializer
       let rec loop () =
@@ -52,6 +55,8 @@ class options args =
             | "-I"  -> (match self#peek with None -> raise (Commandline_error "path expected after '-I' specifier") | Some path -> self#add_include_path path)
             | "-s"  -> self#set_mode `SM
             | "-i"  -> self#set_mode `Eval
+            | "-ds" -> self#set_dump dump_sm
+            | "-dp" -> self#set_dump dump_ast
             | "-h"  -> self#set_help
             | _ ->
                if opt.[0] = '-'
@@ -61,6 +66,8 @@ class options args =
            loop ()
         | None -> ()
       in loop ()
+    method private set_dump mask =
+      dump := !dump lor mask
     method private set_infile name =
       match !infile with
       | None       -> infile := Some name
@@ -84,6 +91,20 @@ class options args =
       | Some name -> name
     method get_help = !help
     method get_include_paths = !paths
+    method basename = Filename.chop_suffix self#get_infile ".expr"
+    method dump_file ext contents =
+      let name = self#basename in
+      let outf = open_out (Printf.sprintf "%s.%s" name ext) in
+      Printf.fprintf outf "%s" contents;
+      close_out outf
+    method dump_AST ast =
+      if (!dump land dump_ast) > 0
+      then self#dump_file "ast" (GT.show(Language.Expr.t) ast)
+      else ()
+    method dump_SM sm  =
+      if (!dump land dump_sm) > 0
+      then self#dump_file "sm" (SM.show_prg sm)
+      else ()
   end
   
 let main =
@@ -91,6 +112,7 @@ let main =
     let cmd = new options Sys.argv in
     match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
     | `Ok prog ->
+       cmd#dump_AST (snd prog);
        (match cmd#get_mode with
         | `Default | `Compile ->
             ignore @@ X86.build cmd prog

src/SM.ml

@@ -37,7 +37,10 @@ with show
 (* The type for the stack machine program *)
 @type prg = insn list with show
 
-let print_prg p = List.iter (fun i -> Printf.eprintf "%s\n%!" (show(insn) i)) p;;
+let show_prg p =
+  let b = Buffer.create 512 in
+  List.iter (fun i -> Buffer.add_string b (show(insn) i); Buffer.add_string b "\n") p;
+  Buffer.contents b;;
 
 (* Values *)
 @type value = (string, value array) Value.t with show
@@ -760,4 +763,5 @@ let compile cmd ((imports, infixes), p) =
   let has_main        = List.length code > 0 in
   let env, prg        = compile_fundefs [if has_main then [LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @ code @ [END] else []] env in
   let prg             = (if has_main then [PUBLIC "main"] else []) @ env#get_decls @ List.flatten prg in
+  cmd#dump_SM prg;
   prg

src/X86.ml

@@ -689,6 +689,9 @@ let build cmd prog =
     in
     iterate [] S.empty imports
   in
+  cmd#dump_file "s" (genasm cmd prog);
+  cmd#dump_file "i" (Interface.gen prog);
+  (*
   let name = Filename.chop_suffix cmd#get_infile ".expr" in
   let outf = open_out (Printf.sprintf "%s.s" name) in
   Printf.fprintf outf "%s" (genasm cmd prog);
@@ -696,13 +699,14 @@ let build cmd prog =
   let outf = open_out (Printf.sprintf "%s.i" name) in
   Printf.fprintf outf "%s" (Interface.gen prog);
   close_out outf; 
+   *)
   let inc  = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
   match cmd#get_mode with
   | `Default ->
      let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in
      let buf  = Buffer.create 255 in
      List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs;
-     Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s %s/runtime.a" name name (Buffer.contents buf) inc)
+     Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s %s/runtime.a" cmd#basename cmd#basename (Buffer.contents buf) inc)
   | `Compile ->
-     Sys.command (Printf.sprintf "gcc -g -m32 -c %s.s" name)
+     Sys.command (Printf.sprintf "gcc -g -m32 -c %s.s" cmd#basename)
   | _ -> invalid_arg "must not happen"