src: Adding new switch and moving code from Driver to Language

Signed-off-by: Kakadu <Kakadu@pm.me>

Makefile

@@ -31,5 +31,5 @@ clean:
 	make clean -C runtime
 	make clean -C stdlib
 	make clean -C regression
-
+	$(MAKE) clean -C bench
 

src/Driver.ml

@@ -1,45 +1,11 @@
-open Ostap
-
-let parse cmd =
-  let s   = Util.read cmd#get_infile in
-  let kws = [
-    "skip";      
-    "if"; "then"; "else"; "elif"; "fi";
-    "while"; "do"; "od";
-    "repeat"; "until";
-    "for";
-    "fun"; "local"; "public"; "external"; "return"; "import"; 
-    "length";
-    "string";
-    "case"; "of"; "esac"; "when";
-    "boxed"; "unboxed"; "string"; "sexp"; "array";
-    "infix"; "infixl"; "infixr"; "at"; "before"; "after";
-    "true"; "false"; "lazy"; "eta"; "syntax"]
-  in
-  Util.parse
-    (object
-       inherit Matcher.t s
-       inherit Util.Lexers.decimal s
-       inherit Util.Lexers.string s
-       inherit Util.Lexers.char   s
-       inherit Util.Lexers.infix  s
-       inherit Util.Lexers.lident kws s
-       inherit Util.Lexers.uident kws s
-       inherit Util.Lexers.skip [
-	 Matcher.Skip.whitespaces " \t\n\r";
-	 Matcher.Skip.lineComment "--";
-	 Matcher.Skip.nestedComment "(*" "*)"
-       ] s
-     end
-    )
-    (if cmd#is_workaround then ostap (p:!(Language.constparse cmd) -EOF) else ostap (p:!(Language.parse cmd) -EOF))
-
 exception Commandline_error of string
 
 class options args =
   let n = Array.length args in
-  let dump_ast  = 1 in
+  let dump_ast  = 0b1 in
-  let dump_sm   = 2 in
+  let dump_sm   = 0b010 in
+  let dump_source = 0b100 in
+  (* Kakadu: binary masks are cool for C code, but for OCaml I don't see any reason to save memory like this *)
   let help_string =
     "Lama compiler. (C) JetBrains Reserach, 2017-2020.\n" ^
     "Usage: lamac <options> <input file>\n\n" ^
@@ -51,6 +17,7 @@ class options args =
     "  -i        --- interpret on a source-level interpreter\n" ^
     "  -s        --- compile into stack machine code and interpret on the stack machine initerpreter\n" ^
     "  -dp       --- dump AST (the output will be written into .ast file)\n" ^
+    "  -dsrc     --- dump pretty-printed source code\n" ^
     "  -ds       --- dump stack machine code (the output will be written into .sm file; has no\n" ^
     "                effect if -i option is specfied)\n" ^
     "  -v        --- show version\n" ^
@@ -84,6 +51,7 @@ class options args =
             | "-s"  -> self#set_mode `SM
             | "-i"  -> self#set_mode `Eval
             | "-ds" -> self#set_dump dump_sm
+            | "-dsrc" -> self#set_dump dump_source
             | "-dp" -> self#set_dump dump_ast
             | "-h"  -> self#set_help
             | "-v"  -> self#set_version
@@ -160,7 +128,11 @@ class options args =
         Buffer.add_string buf "</html>";
         self#dump_file "html" (Buffer.contents buf)
       )
-      else ()
+    method dump_source (ast: Language.Expr.t) =
+      if (!dump land dump_source) > 0
+      then Pprinter.pp Format.std_formatter ast;
+
+
     method dump_SM sm  =
       if (!dump land dump_sm) > 0
       then self#dump_file "sm" (SM.show_prg sm)
@@ -182,9 +154,10 @@ let main =
   try
     let cmd = new options Sys.argv in
     cmd#greet;
-    match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
+    match (try Language.run_parser cmd with Language.Semantic_error msg -> `Fail msg) with
     | `Ok prog ->
        cmd#dump_AST (snd prog);
+       cmd#dump_source (snd prog);
        (match cmd#get_mode with
         | `Default | `Compile ->
             ignore @@ X86.build cmd prog

src/Language.ml

@@ -294,7 +294,7 @@ module Pattern =
     (* any sexp value   *) | SexpTag
     (* any array value  *) | ArrayTag
     (* any closure      *) | ClosureTag
-    with show, foldl, html
+    with show, foldl, html, fmt
 
     (* Pattern parser *)
     ostap (
@@ -349,6 +349,10 @@ module Expr =
     (* The type for expressions. Note, in regular OCaml there is no "@type..."
        notation, it came from GT.
     *)
+
+    @type qualifier = [ `Local | `Public | `Extern | `PublicExtern ]
+        with show, html
+
     @type t =
     (* integer constant           *) | Const     of int
     (* array                      *) | Array     of t list
@@ -377,7 +381,7 @@ module Expr =
     (* leave a scope              *) | Leave
     (* intrinsic (for evaluation) *) | Intrinsic of (t config, t config) arrow
     (* control (for control flow) *) | Control   of (t config, t * t config) arrow
-    and decl = [`Local | `Public | `Extern | `PublicExtern ] * [`Fun of string list * t | `Variable of t option]
+    and decl = qualifier * [`Fun of string list * t | `Variable of t option]
     with show, html
                            
     let notRef = function Reff -> false | _ -> true
@@ -1250,3 +1254,39 @@ let parse cmd =
         )
   in
   parse cmd
+
+
+let run_parser cmd =
+  let s   = Util.read cmd#get_infile in
+  let kws = [
+    "skip";
+    "if"; "then"; "else"; "elif"; "fi";
+    "while"; "do"; "od";
+    "repeat"; "until";
+    "for";
+    "fun"; "local"; "public"; "external"; "return"; "import";
+    "length";
+    "string";
+    "case"; "of"; "esac"; "when";
+    "boxed"; "unboxed"; "string"; "sexp"; "array";
+    "infix"; "infixl"; "infixr"; "at"; "before"; "after";
+    "true"; "false"; "lazy"; "eta"; "syntax"]
+  in
+  Util.parse
+    (object
+       inherit Matcher.t s
+       inherit Util.Lexers.decimal s
+       inherit Util.Lexers.string s
+       inherit Util.Lexers.char   s
+       inherit Util.Lexers.infix  s
+       inherit Util.Lexers.lident kws s
+       inherit Util.Lexers.uident kws s
+       inherit Util.Lexers.skip [
+        Matcher.Skip.whitespaces " \t\n\r";
+        Matcher.Skip.lineComment "--";
+        Matcher.Skip.nestedComment "(*" "*)"
+       ] s
+     end
+    )
+    (if cmd#is_workaround then ostap (p:!(constparse cmd) -EOF)  else ostap (p:!(parse cmd) -EOF))
+

src/Makefile

@@ -2,12 +2,11 @@ TOPFILE = lamac
 OCAMLC = ocamlfind c
 OCAMLOPT = ocamlfind opt
 OCAMLDEP = ocamlfind dep
-SOURCES = version.ml stdpath.ml Language.ml SM.ml X86.ml Driver.ml
+SOURCES = version.ml stdpath.ml Language.ml Pprinter.ml SM.ml X86.ml Driver.ml
 CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all
 PXFLAGS = $(CAMLP5)
-BFLAGS = -rectypes -g
+BFLAGS = -rectypes -g -w -13-58 -package ostap,unix
 OFLAGS = $(BFLAGS)
-LIBS = unix.cma
 
 all: depend metagen  $(TOPFILE)
 
@@ -19,10 +18,10 @@ depend: $(SOURCES)
 	$(OCAMLDEP) $(PXFLAGS) *.ml > .depend
 
 $(TOPFILE): $(SOURCES:.ml=.cmx)
-	$(OCAMLOPT) -o $(TOPFILE) $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx)
+	$(OCAMLOPT) -o $(TOPFILE) $(OFLAGS) -linkpkg $(SOURCES:.ml=.cmx)
 
 $(TOPFILE).byte: $(SOURCES:.ml=.cmo)
-	$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo) 
+	$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) -linkpkg $(SOURCES:.ml=.cmo)
 
 clean:
 	rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend

src/Pprinter.ml

@@ -0,0 +1,195 @@
+open Language
+
+class pp_pattern fself = object
+  inherit [Format.formatter, Pattern.t, unit] Pattern.t_t
+
+  method c_Wildcard ppf _ = Format.fprintf ppf "_"
+  method c_Const ppf _ = Format.fprintf ppf "%d"
+  method c_Named ppf _ name _ =
+    (* TODO: should I ignore another argument? *)
+    Format.fprintf ppf "%s" name
+  method c_Sexp ppf _ name xs =
+    match name,xs with
+    | "cons", [l; r] ->
+        Format.fprintf ppf "%a@ :@ %a" fself l fself r
+    | _ ->
+        Format.fprintf ppf "@[%s@ (" name;
+        xs |> List.iter (Format.fprintf ppf "%a@ " fself);
+        Format.fprintf ppf ")@] "
+
+  method c_Array ppf _ xs =
+    Format.fprintf ppf "@[{ ";
+    Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
+      fself ppf xs;
+    Format.fprintf ppf " }@]"
+
+  method c_ArrayTag ppf _ = Format.fprintf ppf "#array"
+  method c_SexpTag ppf _ = Format.fprintf ppf "#sexp"
+  method c_ClosureTag ppf _ = Format.fprintf ppf "#fun"
+  method c_UnBoxed ppf _ = failwith "not implemented"
+  method c_String ppf _ = failwith "not implemented"
+  method c_StringTag ppf _ = failwith "not implemented"
+  method c_Boxed ppf _ = failwith "not implemented"
+end
+
+let pp_pattern fmt p =
+  GT.transform Pattern.t (new pp_pattern) fmt p
+
+class pp_expr on_decl fself =
+object
+  inherit [Format.formatter, Expr.t, unit] Expr.t_t
+  method c_Const ppf _ = Format.fprintf ppf "%d"
+  method c_Var ppf _ = Format.fprintf ppf "%s"
+  method c_Ref ppf _ = Format.fprintf ppf "%s"
+  method c_Array ppf _ xs =
+    Format.fprintf ppf "@[{@ ";
+    xs |> List.iteri (fun i ->
+      if i<>0 then Format.fprintf ppf ",@ ";
+      fself ppf);
+    Format.fprintf ppf " }@]"
+  method c_String ppf _ s = Format.fprintf ppf "\"%s\"" s
+
+  method c_Sexp ppf _ name xs =
+    match name,xs with
+    | "cons", [l;r] -> Format.fprintf ppf "@[%a : %a@]" fself l fself r
+    | _ ->
+        Format.fprintf ppf "@[%s@ (" name;
+        xs |> List.iteri (fun i x ->
+          if i<>0 then Format.fprintf ppf ", ";
+          fself ppf x
+        );
+        Format.fprintf ppf ")@]"
+
+  method c_Binop ppf _ op l r =
+    Format.fprintf ppf "@[%a@ %s@ %a@]" fself l op fself r
+  method c_Elem ppf _ l idx =
+    Format.fprintf ppf "%a[%a]" fself l fself idx
+  method c_ElemRef ppf _ l idx =
+    (* TODO: should Elem and ElemRef be the same? *)
+    Format.fprintf ppf "%a[%a]" fself l fself idx
+  method c_Length ppf _ e =
+    Format.fprintf ppf "@[(%a).length@]" fself e
+  method c_StringVal ppf _ _x__519_ =
+    Format.fprintf ppf "StringVal @[(@,%a@,)@]" fself _x__519_
+  method c_Call ppf _ f args =
+    Format.fprintf ppf "@[%a @[(" fself f;
+    args |> List.iteri (fun i arg ->
+      Format.fprintf ppf "%s%a" (if i<>0 then ", " else "") fself arg
+    );
+    Format.fprintf ppf ")@]@]"
+
+
+  method c_Assign ppf _ _x__526_ _x__527_ =
+    Format.fprintf ppf "@[%a@ :=@ %a@]" fself _x__526_ fself _x__527_
+  method c_Seq ppf _ l r =
+    Format.fprintf ppf "@[<v>%a;@ %a@]" fself l fself r
+  method c_Skip ppf _ = Format.fprintf ppf "skip"
+  method c_If ppf _ _x__533_ _x__534_ _x__535_ =
+    Format.fprintf ppf "@[if %a then @[<v 2>{@,%a@]@ @[<v 2>} else {@,%a@]@ } fi@]"
+      fself _x__533_ fself _x__534_ fself _x__535_
+  method c_While ppf _ cond body =
+    Format.fprintf ppf "@[<v 2>";
+    Format.fprintf ppf "while %a do@," fself cond;
+    fself ppf body;
+    Format.fprintf ppf "@]@ ";
+    Format.fprintf ppf "od";
+    (*Format.fprintf inh___536_ "While @[(@,%a,@,@ %a@,)@]" fself
+      cond fself body*)
+  method c_Repeat ppf _ cond body =
+    Format.fprintf ppf "@[<v 2>";
+    Format.fprintf ppf "repeat@,%a" fself body;
+    Format.fprintf ppf "until %a@]" fself cond
+
+
+  method c_Case ppf _ scru cases _ _ =
+    Format.fprintf ppf "@[<v>";
+    Format.fprintf ppf "@[case %a of@ @]@," fself scru;
+    Format.fprintf ppf "@[<v 0>";
+    cases |> List.iteri (fun i (p,e) ->
+      Format.fprintf ppf "@[%s %a@ ->@ %a@]@ " (if i=0 then " " else "|") pp_pattern p fself e
+    );
+    Format.fprintf ppf "@]";
+    Format.fprintf ppf "@[esac@]";
+    Format.fprintf ppf "@]"
+
+
+  method c_Return ppf _ e =
+    match e with
+    | None -> Format.fprintf ppf "return"
+    | Some e -> Format.fprintf ppf "@[return@ %a@]" fself e
+
+  method c_Ignore ppf _ e =
+    Format.fprintf ppf "@[%a@]" fself e
+  method c_Unit ppf _ = Format.fprintf ppf "Unit "
+  method c_Scope ppf _ xs body =
+    Format.fprintf ppf "@[<v>";
+    Format.pp_print_list ~pp_sep:(fun fmt () -> ())
+      (fun ppf (name, d) ->
+        Format.fprintf ppf "@[%a@]@," (fun ppf -> on_decl (name,ppf)) d)
+      ppf xs;
+    fself ppf body;
+    Format.fprintf ppf "@]"
+
+  method c_Lambda ppf _ args body =
+    Format.fprintf ppf "@[fun (%a) { %a }@]"
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_text)
+      args
+      fself
+      body
+
+  method c_Leave ppf _ = Format.fprintf ppf "Leave "
+  method c_Intrinsic ppf _ _ =
+    Format.fprintf ppf "Intrinsic"
+
+  method c_Control ppf _ _ =
+    Format.fprintf ppf "Control"
+
+end
+
+class pp_decl fself on_expr  = object(self)
+  inherit [ (string*Format.formatter), _, unit] Expr.decl_t
+  method qualifier ppf : Expr.qualifier -> _ = function
+    | `Local -> ()
+    | `Extern -> Format.fprintf ppf "extern@ "
+    | `Public -> Format.fprintf ppf "public@ "
+    | `PublicExtern -> Format.fprintf ppf "not implemented %d" __LINE__
+
+  method args ppf =
+    Format.fprintf ppf "%a" @@
+    Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",")
+      (Format.pp_print_text)
+
+  method c_DECL (name,ppf) (qual, (item: [`Fun of string list * Expr.t | `Variable of Expr.t GT.option])) =
+    match item with
+    | `Variable(None) -> Format.fprintf ppf "local %s;" name
+    | `Variable(Some e) ->
+        Format.fprintf ppf "local %s = %a;" name on_expr e
+    | `Fun (ss,e) ->
+        Format.fprintf ppf "@[<v>";
+        Format.fprintf ppf "@[%afun %s (%a) @]@," self#qualifier qual name self#args ss;
+        Format.fprintf ppf "@[<v 2>{@,@[%a@]@]@ " on_expr e;
+        Format.fprintf ppf "}";
+        Format.fprintf ppf "@]"
+
+end
+
+
+let fix_decl decl0 t0 =
+  let rec traitdecl inh subj =
+    Expr.gcata_decl (decl0 traitdecl traitt) inh subj
+  and traitt inh subj =
+    Expr.gcata_t (t0 traitdecl traitt) inh subj
+  in
+  (traitdecl, traitt)
+
+let pp fmt s =
+  snd (fix_decl (new pp_decl) (new pp_expr)) fmt s
+
+let pp ppf ast =
+  let margin =
+    try int_of_string @@ Sys.getenv "LAMA_MARGIN"
+    with Failure _ | Not_found -> 35
+  in
+  Format.set_margin margin;
+  Format.set_max_indent 15;
+  Format.printf "%a\n%!" pp ast