Merging with origin

.gitignore

@@ -1,5 +1,7 @@
 *~
 *.cmi
 *.cmx
+*.cmo
 *.o
+.merlin
 

Makefile

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

bench/.gitignore

@@ -0,0 +1,3 @@
+/*.exe
+/Pprint_gt.ml
+/Pprint_default.ml

bench/Makefile

@@ -0,0 +1,37 @@
+.PHONY: clean
+
+OUT = bench.exe
+OUT2 = demo_infix.exe
+LAMA_CMXES = ../src/Language.cmx
+OCAMLC = ocamlfind c
+OCAMLOPT = ocamlfind opt
+BFLAGS += -package GT,ostap,re,benchmark,str -I ../src -rectypes -g
+GENERATED = Pprint_gt.ml Pprint_default.ml
+
+all: $(OUT) $(OUT2)
+
+demo_infix.cmx bench_main.cmx: Pprint_gt.cmx Pprint_default.cmx
+
+$(OUT): Pprint_gt.cmx Pprint_default.cmx bench_main.cmx
+	$(OCAMLOPT) $(BFLAGS) $(LAMA_CMXES) -linkpkg $^ -o $@
+
+$(OUT2): Pprint_gt.cmx Pprint_default.cmx demo_infix.cmx
+	$(OCAMLOPT) $(BFLAGS) $(LAMA_CMXES) -linkpkg $^ -o $@
+
+clean:
+	$(RM) *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend $(OUT) $(GENERATED)
+
+%.cmi: %.ml
+	$(OCAMLC) -c $(BFLAGS)  $<
+
+%.cmx: %.ml
+	$(OCAMLOPT) -c $(BFLAGS) $<
+
+
+###############
+Pprint_gt.ml: pp_gt.m4 p.ml
+	m4 $< p.ml > $@
+
+###############
+Pprint_default.ml: pp_default.m4 p.ml
+	m4 $< p.ml > $@

bench/README.md

@@ -0,0 +1,26 @@
+#### Benchmark suite for pretty printing
+
+Files:
+
+- `p.ml` -- an implementation of pretty-printer in meta-language
+- `pp_default.m4` -- macro that converts `p.ml` into strightforward pretty printer
+- `pp_gt.m4` -- a macro that converts `p.ml` into GT-based pretty printer
+- `bench_main.ml` -- runner of benhcmark1
+- `demo_infix.ml` -- demo about infix operator pretty printing
+
+Compilation: hit `make`.
+
+###### Benchmark `bench.exe`
+
+Searches for input files in `../stdlib` or `./stdlib` and measures two pretty-printers:
+
+- straightforward one from `Pprint_default.ml` (generated by `pp_default.m4` from `p.ml`)
+- the one using our approach: `Pprint_gt.ml`  (generated by `pp_gt.m4` from `p.ml`)
+
+
+###### demo `demo_infix.exe`
+
+Pretty prints a small piece of code by two approaches:
+
+- generated using our approach: `Pprint_gt.ml`
+- modified `Pprint_gt.ml`: we are printing infix names in a prettier way. It is not possible to modify straightforward approach without pain

bench/bench_main.ml

@@ -0,0 +1,76 @@
+open Benchmark
+
+(* How many repetitions should be performed *)
+let repeat = 2
+(* How nuch time we should spent on benchmark *)
+let timeout = 2
+
+let dirname,filenames =
+  let dirname =
+    let path1 = "./stdlib" in
+    let path2 = "../stdlib" in
+    if Sys.(file_exists path1 && is_directory path1) then path1
+    else if Sys.(file_exists path2 && is_directory path2) then path2
+    else failwith (Printf.sprintf "Can't find a directory '%s' or '%s'" path1 path2)
+  in
+  Format.printf "Looking for samples from: '%s'\n%!" dirname;
+  let files =
+    let fs = Sys.readdir dirname in
+    let r = Str.regexp ".*\\.lama$" in
+    List.filter (fun s -> (Str.string_match r s 0) && s <> "Ostap.lama") (Array.to_list fs)
+  in
+  Format.printf "Tests found: %s\n%!" (GT.show GT.list (GT.show GT.string) files);
+  (dirname,files)
+
+
+let bench_file file =
+  Format.printf "Benchmarking file `%s`\n%!" file;
+  let options = object
+    method is_workaround = false
+    method get_infile = Printf.sprintf "%s/%s" dirname file
+    method get_include_paths = [dirname; Printf.sprintf "%s/../runtime" dirname]
+  end in
+  let ast =
+    try match Language.run_parser options with
+      | `Ok  r -> r
+      | `Fail s ->
+          Printf.eprintf "Error: %s\n" s;
+          exit 1
+    with Language.Semantic_error s ->
+      Printf.eprintf "Error: %s\n" s;
+      exit 1
+  in
+
+  let () =
+    let s1 = Format.asprintf "%a" Pprint_gt.pp (snd ast) in
+    let s2 = Format.asprintf "%a" Pprint_default.pp (snd ast) in
+    if s1<>s2
+    then begin
+      let wrap name cnt =
+        let ch = open_out name in
+        output_string ch cnt;
+        close_out ch
+      in
+      wrap "/tmp/gt.ml" s1;
+      wrap "/tmp/default.ml" s2;
+      failwith "Two printers doesn't behave the same"
+    end
+  in
+  Gc.full_major ();
+  let run_gt () =
+    let _:string = Format.asprintf "%a" Pprint_gt.pp (snd ast) in
+    ()
+  in
+  let run_default () =
+    let _:string = Format.asprintf "%a" Pprint_default.pp (snd ast) in
+    ()
+  in
+
+  let res = throughputN ~style:Nil ~repeat timeout
+    [ ("GT", run_gt, ())
+    ; ("Default", run_default, ())
+    ]
+  in
+  tabulate res
+
+let () = List.iter bench_file filenames

bench/demo.lama

@@ -0,0 +1,6 @@
+public infix +++ at + (x, y) {
+  case x of
+    {}     -> y
+  | x : xs -> x : xs +++ y
+  esac
+}

bench/demo_infix.ml

@@ -0,0 +1,89 @@
+open Benchmark
+
+let dirname,filename =
+  let dirname =
+    let path1 = "./stdlib" in
+    let path2 = "../stdlib" in
+    if Sys.(file_exists path1 && is_directory path1) then path1
+    else if Sys.(file_exists path2 && is_directory path2) then path2
+    else failwith (Printf.sprintf "Can't find a directory '%s' or '%s'" path1 path2)
+  in
+  let filename =
+    let path1 = "./demo.lama" in
+    let path2 = "./bench/demo.lama" in
+    if Sys.file_exists path1 then path1
+    else if Sys.file_exists path2 then path2
+    else failwith (Printf.sprintf "Can't find an input file both in '%s' and '%s'" path1 path2)
+  in
+  (dirname,filename)
+
+let infix_prefix = "i__Infix_"
+let looks_like_infix s =
+  Str.first_chars s (String.length infix_prefix) = infix_prefix
+
+let rewrite_infix s =
+  if not (looks_like_infix s)
+  then s
+  else
+    let b = Buffer.create 3 in
+    let s = String.sub s (String.length infix_prefix) String.(length s - length infix_prefix) in
+    let rec loop i =
+      if i >= String.length s then ()
+      else
+        let num c = Char.code c - Char.code '0' in
+        let c = Char.chr (num s.[i] * 10 + num s.[i+1]) in
+        Buffer.add_char b c;
+        loop (i+2)
+    in
+    let () = loop 0 in
+    Buffer.contents b
+
+class my_pp_e pp_decl fself = object
+  inherit Pprint_gt.pp_e pp_decl fself as super
+  method! c_Call ppf e f args =
+    match f,args with
+    | (Var s, [l; r]) when looks_like_infix s ->
+        Format.fprintf ppf "@[<h>%a@ %s@ %a@]"
+          fself l
+          (rewrite_infix s)
+          fself r                                                     (* CHANGE 1 *)
+
+    | _ -> super#c_Call ppf e f args
+end
+
+let fix decl0 t0 =
+  let open Language in
+  let rec decl (name,ppf) subj =
+    let inh = (rewrite_infix name, ppf) in                             (* CHANGE 2 *)
+    Expr.gcata_decl (decl0 decl expr) inh subj
+  and expr inh subj =
+    Expr.gcata_t (t0 decl expr) inh subj
+  in
+  (decl, expr)
+
+let pp fmt s =
+  let open Pprint_gt in
+  snd (fix (new pp_d) (new my_pp_e)) fmt s
+
+let options = object
+  method is_workaround = false
+  method get_infile = filename
+  method get_include_paths = [dirname; Printf.sprintf "%s/../runtime" dirname]
+end
+
+let () =
+  let ast =
+    Format.printf "Parsing input file `%s'\n%!" options#get_infile;
+    try match Language.run_parser options with
+      | `Ok  r -> r
+      | `Fail s ->
+          Printf.eprintf "Error: %s\n" s;
+          exit 1
+    with Language.Semantic_error s ->
+      Printf.eprintf "Error: %s\n" s;
+      exit 1
+  in
+
+  Format.printf "Default printer:\n%a\n\n%!" Pprint_gt.pp (snd ast);
+  Format.printf "Modified printer:\n%a\n\n%!" pp (snd ast);
+  ()

bench/p.ml

@@ -0,0 +1,159 @@
+open Language
+
+class pp_pattern fself = object
+  inherit [Pattern.t] Pattern.fmt_t_t fself
+
+  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"
+end
+
+let pp_pattern fmt p =
+  GT.transform Pattern.t (new pp_pattern) fmt p
+
+HEADER_EXPR
+METH(Const, ppf, n, Const n, Format.fprintf ppf "%d" n)
+METH(Var, ppf, s, Var s, Format.fprintf ppf "%s" s)
+METH(Ref, ppf, s, Ref s, Format.fprintf ppf "%s" s)
+METH(String, ppf, s, String s, Format.fprintf ppf "\"%s\"" s)
+METH(Array, ppf, xs, Array xs, [[Format.fprintf ppf "@[{@ ";
+xs |> List.iteri (fun i ->
+  if i<>0 then Format.fprintf ppf ",@ ";
+  fself ppf);
+Format.fprintf ppf " }@]"]]
+)
+METH(Sexp, ppf, name xs, [[Sexp (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 ")@]")
+]])
+METH(Binop, ppf, op l r, Binop (op, l, r), [[Format.fprintf ppf "@[%a@ %s@ %a@]" fself l op fself r]])
+METH(Elem, ppf, l idx, Elem (l,idx), [[Format.fprintf ppf "%a[%a]" fself l fself idx]])
+METH(ElemRef, ppf, l idx, ElemRef (l,idx), [[Format.fprintf ppf "%a[%a]" fself l fself idx]])
+METH(Length, ppf, e, Length e, [[Format.fprintf ppf "@[(%a).length@]" fself e]])
+
+METH(StringVal, ppf, _x__519_, StringVal _x__519_, [[Format.fprintf ppf "StringVal @[(@,%a@,)@]" fself _x__519_]])
+
+
+
+METH(Call, ppf, f args, Call (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 ")@]@]"]])
+
+METH(Assign, ppf, l r, Assign (l,r), [[Format.fprintf ppf "@[%a@ :=@ %a@]" fself l fself r]])
+METH(Seq, ppf, l r, Seq (l,r), [[Format.fprintf ppf "@[<v>%a;@ %a@]" fself l fself r]])
+
+
+METH(Skip, ppf, , Skip, [[ Format.fprintf ppf "skip" ]])
+
+METH(If, ppf, c th el, If (c,th,el), [[
+Format.fprintf ppf "@[if %a then @[<v 2>{@,%a@]@ @[<v 2>} else {@,%a@]@ } fi@]"
+  fself c fself th fself el]])
+
+METH(While, ppf, cond body, While(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"]])
+
+METH(Repeat, ppf, cond body, Repeat(cond,body), [[
+Format.fprintf ppf "@[<v 2>";
+Format.fprintf ppf "repeat@,%a" fself body;
+Format.fprintf ppf "until %a@]" fself cond]])
+
+METH(Case, ppf, scru cases _ _, Case(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 "@]"]])
+
+METH(Return, ppf, e, Return e, [[(match e with
+| None -> Format.fprintf ppf "return"
+| Some e -> Format.fprintf ppf "@[return@ %a@]" fself e)]])
+
+METH(Ignore, ppf, e, Ignore e, Format.fprintf ppf "@[%a@]" fself e)
+METH(Unit, ppf, , Unit, Format.fprintf ppf "Unit ")
+METH(Scope, ppf, xs body, Scope(xs,body), [[Format.fprintf ppf "@[<v>";
+Format.pp_print_list ~pp_sep:(fun fmt () -> ())
+  (fun ppf (name, d) ->
+    Format.fprintf ppf "@[%a@]@," (fun ppf -> pp_decl (name,ppf)) d)
+  ppf xs;
+fself ppf body;
+Format.fprintf ppf "@]"]])
+
+METH(Lambda, ppf, args body, Lambda(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
+]])
+
+METH(Leave, ppf, , Leave, Format.fprintf ppf "Leave ")
+
+METH(Intrinsic, ppf, _x__584_, Intrinsic _, Format.fprintf ppf "Intrinsic ")
+METH(Control, ppf, _x__584_, Control _, Format.fprintf ppf "Control ")
+
+FOOTER_EXPR
+
+let args ppf =
+  Format.fprintf ppf "%a" @@
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",")
+    (Format.pp_print_text)
+
+let pp_qualifier ppf : Expr.qualifier -> _ = function
+  | `Local -> ()
+  | `Extern -> Format.fprintf ppf "extern@ "
+  | `Public -> Format.fprintf ppf "public@ "
+  | `PublicExtern -> Format.fprintf ppf "not implemented %d" __LINE__
+
+HEADER_DECL
+METH0(DECL, (name,ppf), (qual,item), [[
+  let _: [`Fun of string list * Expr.t | `Variable of Expr.t GT.option] = item in
+  match item with
+  | `Variable(None) -> Format.fprintf ppf "local %s;" name
+  | `Variable(Some e) ->
+      Format.fprintf ppf "local %s = %a;" name pp_expr e
+  | `Fun (ss,e) ->
+      Format.fprintf ppf "@[<v>";
+      Format.fprintf ppf "@[%afun %s (%a) @]@," pp_qualifier qual name args ss;
+      Format.fprintf ppf "@[<v 2>{@,@[%a@]@]@ " pp_expr e;
+      Format.fprintf ppf "}";
+      Format.fprintf ppf "@]"]]
+)
+FOOTER_DECL
+
+FIX

bench/pp_default.m4

@@ -0,0 +1,25 @@
+changequote([[,]])
+define(HEADER_EXPR, [[
+let rec pp_e pp_decl fself ppf root =
+  let open Expr in
+  match root with]])
+
+define(METH, [[
+  | $4 ->
+      $5]])
+define(METH0, [[
+  | $3 ->
+      $4]])
+define(FOOTER_EXPR, [[]])
+define(HEADER_DECL, [[
+let rec pp_d fself pp_expr (name,ppf) root =
+  let open Expr in
+  match root with]])
+
+
+define(FOOTER_DECL, [[]])
+
+define(FIX, [[
+let rec pp_decl ppf = pp_d pp_decl pp ppf
+and pp ppf = pp_e pp_decl pp ppf
+]])

bench/pp_gt.m4

@@ -0,0 +1,40 @@
+changequote([[,]])
+define(HEADER_EXPR, [[
+class pp_e pp_decl fself  = object
+  inherit [Format.formatter, Expr.t, unit] Expr.t_t
+  ]])
+
+define(METH, [[
+  method c_$1 $2 _ $3 =
+    $5
+]])
+define(METH0, [[
+  method c_$1 $2 $3 =
+    $4]])
+define(FOOTER_EXPR, [[
+end (* class *)
+]])
+define(HEADER_DECL, [[
+class pp_d fself pp_expr  =
+let (_: (string*Format.formatter) -> Expr.decl -> unit) = fself in
+let (_: Format.formatter -> Expr.t -> unit) = pp_expr  in
+object
+  inherit [(string*Format.formatter), _, unit] Expr.decl_t]])
+
+
+define(FOOTER_DECL, [[
+end (* class *)
+]])
+define(FIX, [[
+
+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_d) (new pp_e)) fmt s
+]])

runtime/.gitignore

@@ -0,0 +1,2 @@
+*.a
+

src/.gitignore

@@ -0,0 +1,4 @@
+.depend
+lamac
+lamac.byte
+

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_sm   = 2 in
+  let dump_ast  = 0b1 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

@@ -41,7 +41,7 @@ exception Semantic_error of string
 
 module Loc =
   struct
-    @type t = int * int with show, html
+    @type t = int * int with show, html, foldl
 
     module H = Hashtbl.Make (struct type t = string let hash = Hashtbl.hash let equal = (==) end)
 
@@ -49,13 +49,14 @@ module Loc =
 
     let attach s loc = H.add tab s loc
     let get          = H.find_opt tab
+    let get_exn      = H.find tab
 
   end
 
 let report_error ?(loc=None) str =
   raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c));;
   
-@type k = Unmut | Mut | FVal with show, html
+@type k = Unmut | Mut | FVal with show, html, foldl
 
 (* Values *)
 module Value =
@@ -68,7 +69,7 @@ module Value =
     | Arg    of int
     | Access of int
     | Fun    of string
-    with show, html   
+    with show, html, foldl
 
     @type ('a, 'b) t =
     | Empty
@@ -81,7 +82,7 @@ module Value =
     | Closure of string list * 'a * 'b
     | FunRef  of string * string list * 'a * int
     | Builtin of string
-    with show, html
+    with show, html, foldl
 
     let is_int = function Int _ -> true | _ -> false
                                              
@@ -178,7 +179,7 @@ module State =
     | I
     | G of (string * k) list * (string, 'a) arrow
     | L of (string * k) list * (string, 'a) arrow * 'a t
-    with show, html
+    with show, html, foldl
 
     (* Get the depth level of a state *)
     let rec level = function
@@ -298,7 +299,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 (
@@ -344,12 +345,17 @@ module Expr =
     (* The type of configuration: a state, an input stream, an output stream,
        and a stack of values
     *)
-    @type 'a value  = ('a, 'a value State.t array) Value.t with show, html
-    @type 'a config = 'a value State.t * int list * int list * 'a value list with show, html
+    @type 'a value  = ('a, 'a value State.t array) Value.t with show, html, foldl
+    @type 'a config = 'a value State.t * int list * int list * 'a value list with show, html, foldl
     (* Reff : parsed expression should return value Reff (look for ":=");
        Val : -//- returns simple value;
        Void : parsed expression should not return any value;  *)
-    @type atr = Reff | Void | Val | Weak with show, html
+
+    @type atr = Reff | Void | Val | Weak with show, html, foldl
+
+    @type qualifier = [ `Local | `Public | `Extern | `PublicExtern ]
+        with show, html, foldl
+
     (* The type for expressions. Note, in regular OCaml there is no "@type..."
        notation, it came from GT.
     *)
@@ -381,8 +387,8 @@ 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]
-    with show, html
+    and decl = qualifier * [`Fun of string list * t | `Variable of t option]
+    with show, html, foldl
 
     let notRef = function Reff -> false | _ -> true
     let isVoid = function Void | Weak -> true  | _ -> false
@@ -1254,3 +1260,38 @@ 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,27 +2,26 @@ 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: metagen .depend $(TOPFILE)
+all: depend metagen  $(TOPFILE)
 
 metagen:
 	echo "let version = \"Version `git rev-parse --abbrev-ref HEAD`, `git rev-parse --short HEAD`, `git rev-parse --verify HEAD |git show --no-patch --no-notes --pretty='%cd'`\"" > version.ml
 	echo "let path = \"`opam var share`/Lama\"" > stdpath.ml
 
-.depend: $(SOURCES)
+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,198 @@
+(*
+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 _ l r =
+    Format.fprintf ppf "@[%a@ :=@ %a@]" fself l fself r
+  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 _ c th el =
+    Format.fprintf ppf "@[if %a then @[<v 2>{@,%a@]@ @[<v 2>} else {@,%a@]@ } fi@]"
+      fself c fself th fself el
+  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"
+
+  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
+*)
+
+let pp: Format.formatter -> _ -> unit = fun _ _ -> failwith "Pretty printer is not implemented"

src/version.ml

@@ -1 +1 @@
-let version = "Version 1.00, eeddb0b25, Tue Jan 12 01:14:18 2021 +0300"
+let version = "Version 1.00, 2b9adec08, Mon Jan 25 01:22:56 2021 +0300"

stdlib/.gitignore

@@ -0,0 +1,3 @@
+*.i
+*.s
+

tools/.gitignore

@@ -0,0 +1,2 @@
+/*.exe
+

tools/Makefile

@@ -0,0 +1,25 @@
+.PHONY: clean
+
+GTD = tool.exe
+
+LAMA_CMXES = ../src/Language.cmx
+OCAMLC = ocamlfind c
+OCAMLOPT = ocamlfind opt
+BFLAGS += -package GT,ostap,re,str -I ../src -rectypes -g
+
+all: $(GTD) $(OUT2)
+
+
+
+$(GTD): tool.cmx
+	$(OCAMLOPT) $(BFLAGS) $(LAMA_CMXES) -linkpkg $^ -o $@
+
+
+clean:
+	$(RM) *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend $(OUT) $(GENERATED)
+
+%.cmi: %.ml
+	$(OCAMLC) -c $(BFLAGS)  $<
+
+%.cmx: %.ml
+	$(OCAMLOPT) -c $(BFLAGS) $<

tools/README.md

@@ -0,0 +1,41 @@
+##### Утилиты работы  с программами на LaMa
+
+Утилита `tools/tool.exe` принимает следующие параметры командной строки
+
+* `-pos L,C` для указания позиции в исходном тексте, по которой необходимо найди идентификатор и его место определения (resolve)
+* `-use` опциональный параметр, который кроме resolve производит поиск использований этого идентификатора
+
+Пример входного файла:
+
+```
+ 1  public fun foldl (f, acc, l) {
+ 2                --  ^-- (1,19)
+ 3    case l of
+ 4      {}     -> acc
+ 5    | x : xs -> foldl (f, f (acc, x), xs)
+ 6            -- (5,22)--^  ^-- (5,25)
+ 7    esac
+ 8  }
+ 9
+10  public fun filter (f, l) {
+11    case l of
+12      {}    -> {}
+13    | h : t -> if f (h) then h : filter (f, t) else filter (f, t) fi
+14    esac
+15  }
+```
+
+Пример запуска: `LAMA=./runtime tools/tool.exe tools/demo1.lama -pos 5,22 -use`
+
+В выводе утилита находит определение символа `f` на позиции (1,19) и два его использования на позициях (5,25) и (5,22)
+
+```
+found definition for `f` at (1,19)
+Total 2 usages found
+(5,25) (5,22)
+```
+
+###### Поддерживаемые синтаксические конструкции
+
+Утилита работает для определний функций, их аргументов и локальных определений переменных.
+

tools/demo1.lama

@@ -0,0 +1,15 @@
+public fun foldl (f, acc, l) {
+              --  ^-- (1,19)
+  case l of
+    {}     -> acc
+  | x : xs -> foldl (f, f (acc, x), xs)
+          -- (5,22)--^  ^-- (5,25)
+  esac
+}
+
+public fun filter (f, l) {
+  case l of
+    {}    -> {}
+  | h : t -> if f (h) then h : filter (f, t) else filter (f, t) fi
+  esac
+}

tools/tool.ml

@@ -0,0 +1,136 @@
+open Language
+
+(* Test using:
+    mkae -C tools && LAMA=./runtime tools/gtd.exe tools/demo1.lama -pos 20,22 -use
+  should give:
+    found definition for `f` at (17,19)
+    Total 2 usages found
+    (5,25) (5,22)
+*)
+type mode = GoToDef | Usages
+type config =
+  { mutable filename : string
+  ; mutable pos : string
+  ; mutable line : int
+  ; mutable col: int
+  ; mutable mode: mode
+  }
+
+let config = { filename= "file.ml"; pos="0,0"; line=0; col=0; mode = GoToDef }
+let parse_loc loc =
+  Scanf.sscanf loc "%d,%d" (fun l c -> config.line <- l; config.col <- c)
+
+let () =
+  Arg.parse
+    [ "-pos", String parse_loc, "L,C when L is line and C is column"
+    ; "-def", Unit (fun () -> config.mode <- GoToDef), "go to definition"
+    ; "-use", Unit (fun () -> config.mode <- Usages), "find usages"
+    ]
+    (fun name -> config.filename <- name)
+    "Help"
+
+
+module Introduced = struct
+  include Map.Make(String)
+  let extend k v map =
+    (* Format.printf "extending '%s' -> (%d,%d)\n%!" k (fst v) (snd v); *)
+    add k (k,v) map
+end
+exception DefinitionFound of (string * Loc.t)
+
+let do_find e =
+  let on_name name map =
+    match Loc.get name with
+    | Some (l,c) when l=config.line && c = config.col ->
+        (* we found what we want *)
+        let (key,(l,c)) = Introduced.find name map in
+        raise (DefinitionFound (key,(l,c)))
+    | _ -> map
+  in
+
+  (* looks for line,col in the tree *)
+  let ooo (foldl_decl, fself) = object
+    inherit [_,_] Language.Expr.foldl_t_t_stub (foldl_decl, fself) as super
+    method! c_Var _inh _ name = on_name name _inh
+    method! c_Ref _inh _ name = on_name name _inh
+    method c_Scope init e names r =
+      let map = ListLabels.fold_left ~init names ~f:(fun acc (fname,(_,info)) ->
+        let acc = Introduced.extend fname (Loc.get_exn fname) acc in
+        match info with
+        | `Variable _ ->  acc
+        | `Fun (args, body) ->
+            let acc2 = List.fold_left (fun acc arg_name -> Introduced.extend arg_name (Loc.get_exn arg_name) acc) acc args in
+            let _ = fself acc2 body in
+            acc
+        )
+      in
+      super#c_Scope map e names r
+  end in
+
+  (* Format.printf "STUB. Ht size = %d\n%!" (Loc.H.length Loc.tab);
+  Loc.H.iter (fun k (l,c) -> Format.printf "%s -> (%d,%d)\n%!" k l c) Loc.tab; *)
+
+  let (_,fold_t) = Expr.fix_decl Expr.foldl_decl_0 ooo in
+  match fold_t Introduced.empty e with
+  | exception (DefinitionFound arg) -> Some arg
+  | _ -> None
+
+
+let find_usages root (def_name,(_,_)) =
+  let on_name name acc =
+    if String.equal def_name name
+    then (Loc.get_exn name) :: acc
+    else acc
+  in
+
+  let ooo (foldl_decl, fself) = object(self)
+    inherit [_,_] Language.Expr.foldl_t_t_stub (foldl_decl, fself) as super
+    method! c_Var (acc,in_scope) _ name =
+      if in_scope then (on_name name acc, in_scope) else (acc, in_scope)
+    method! c_Ref (acc,in_scope) _ name =
+      self#c_Var (acc,in_scope) (Var name) name
+    method c_Scope init e names r =
+      ListLabels.fold_left ~init names ~f:(fun ((acc, in_scope) as inh) (name,info) ->
+        match (in_scope, String.equal def_name name) with
+        | (true, true) -> (acc, false)
+        | (true, _) -> begin
+            match snd info with
+            | `Fun (args, body) when List.mem def_name args ->  inh
+            | `Fun (args, body) -> fself inh body
+            | `Variable (Some rhs) -> fself inh rhs
+            | `Variable None -> inh
+        end
+        | (false, true) -> super#c_Scope (acc,true) e names r
+        | false,false -> begin
+            match snd info with
+            | `Fun (args, body) when List.memq def_name args -> fself (acc,true) body
+            | `Fun (args, body) -> fself inh body
+            | `Variable (Some rhs) -> fself inh rhs
+            | `Variable None -> inh
+        end
+      ) |> (fun acc -> fself acc r)
+  end in
+
+  let (_,fold_t) = Expr.fix_decl Expr.foldl_decl_0 ooo in
+  fold_t ([],false) root
+
+
+let () =
+  let cfg = object
+    method get_include_paths = ["."; "./runtime"] method get_infile = config.filename method is_workaround=false end
+  in
+  match Language.run_parser cfg with
+  | `Fail s -> failwith s
+  | `Ok ((_,_), e) ->
+      (* Format.printf "%s\n%!" (GT.show Expr.t e); *)
+      match do_find e with
+      | None -> Format.printf "Definition not found\n%!"
+      | Some (name,(l,c)) ->
+          match config.mode with
+          | GoToDef -> Format.printf "found definition for `%s` at (%d,%d)\n%!" name l c;
+          | Usages ->
+              Format.printf "found definition for `%s` at (%d,%d)\n%!" name l c;
+              let (locs,_) = find_usages e (name,(l,c)) in
+              Format.printf "Total %d usages found\n%!" (List.length locs);
+              List.iter (fun (l,c) -> Format.printf "(%d,%d) %!" l c) locs;
+              Format.printf "\n%!"