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,60 +1,27 @@
-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" ^
     "When no options specified, builds the source file into executable.\n" ^
     "Options:\n" ^
     "  -c        --- compile into object file\n" ^
-    "  -o <file> --- write executable into file <file>\n" ^    
+    "  -o <file> --- write executable into file <file>\n" ^
     "  -I <path> --- add <path> into unit search path list\n" ^
     "  -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" ^
-    "  -h        --- show this help\n"             
+    "  -h        --- show this help\n"
   in
   object (self)
     val version = ref false
@@ -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
@@ -97,12 +65,12 @@ class options args =
         | None -> ()
       in loop ()
     (* Workaround until Ostap starts to memoize properly *)
-    method is_workaround = !const   
+    method is_workaround = !const
     method private set_workaround =
       const := true
     (* end of the workaround *)
     method private set_help    = help := true
-    method private set_version = version := true                          
+    method private set_version = version := true
     method private set_dump mask =
       dump := !dump lor mask
     method private set_infile name =
@@ -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)
@@ -169,42 +141,43 @@ class options args =
       (match !outfile with
        | None   -> ()
        | Some _ -> (match !mode with `Default -> () | _ -> Printf.printf "Output file option ignored in this mode.\n")
-      );           
+      );
       if !version then Printf.printf "%s\n" Version.version;
       if !help    then Printf.printf "%s" help_string
     method get_debug =
       if !debug then "" else "-g"
     method set_debug =
-      debug := true     
+      debug := true
   end
-  
+
 let main =
-  try 
+  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
-        | _ -> 
+        | _ ->
   	   let rec read acc =
 	     try
 	       let r = read_int () in
 	       Printf.printf "> ";
 	       read (acc @ [r])
              with End_of_file -> acc
-	   in 
+	   in
 	   let input = read [] in
 	   let output =
 	     if cmd#get_mode = `Eval
 	     then Language.eval prog input
 	     else SM.run (SM.compile cmd prog) input
 	   in
-	   List.iter (fun i -> Printf.printf "%d\n" i) output 
+	   List.iter (fun i -> Printf.printf "%d\n" i) output
        )
     | `Fail er -> Printf.eprintf "Error: %s\n" er; exit 255
   with
-  | Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg; exit 255 
+  | Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg; exit 255
   | Commandline_error msg -> Printf.printf "%s\n" msg; exit 255

src/Language.ml

@@ -15,12 +15,12 @@ module Subst =
     module H = Hashtbl.Make (struct type t = string let hash = Hashtbl.hash let equal = (=) end)
 
     let tab = (H.create 1024 : string H.t)
-          
+
     let attach infix op = H.add tab infix op
     let subst  id       = match H.find_opt tab id with None -> id | Some op -> op
-    
+
   end
-   
+
 let infix_name infix =
   let b = Buffer.create 64 in
   Buffer.add_string b "i__Infix_";
@@ -28,7 +28,7 @@ let infix_name infix =
   let s = Buffer.contents b in
   Subst.attach s ("infix " ^ infix);
   s
-  
+
 let sys_infix_name infix =
   let b = Buffer.create 64 in
   Buffer.add_string b "s__Infix_";
@@ -41,21 +41,22 @@ 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)
 
     let tab = (H.create 1024 : t H.t)
-          
+
     let attach s loc = H.add tab s loc
-    let get          = H.find_opt tab 
+    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
                                              
@@ -151,8 +152,8 @@ module Builtin =
     let list        = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"]
     let bindings () = List.map (fun name -> name, Value.Builtin name) list
     let names       = List.map (fun name -> name, FVal) list
-                 
+
-    let eval (st, i, o, vs) args = function
+let eval (st, i, o, vs) args = function
     | "read"     -> (match i with z::i' -> (st, i', o, (Value.of_int z)::vs) | _ -> failwith "Unexpected end of input")
     | "write"    -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs)
     | ".elem"    -> let [b; j] = args in
@@ -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
@@ -197,14 +198,14 @@ module State =
            (if l >= n then st'' else st), l+1
       in
       fst @@ inner n st
-                    
+
     (* Undefined state *)
     let undefined x =
       report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" (Subst.subst x))
 
     (* Create a state from bindings list *)
     let from_list l = fun x -> try List.assoc x l with Not_found -> report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" (Subst.subst x))
-                             
+
     (* Bind a variable to a value in a state *)
     let bind x v s = fun y -> if x = y then v else s y
 
@@ -216,11 +217,11 @@ module State =
 
     (* Scope operation: checks if a name designates variable *)
     let is_var x s = try Mut = List.assoc x s with Not_found -> false
-                    
+
     (* Update: non-destructively "modifies" the state s by binding the variable x
        to value v and returns the new state w.r.t. a scope
     *)
-    let update x v s = 
+    let update x v s =
       let rec inner = function
       | I -> report_error "uninitialized state"
       | G (scope, s) ->
@@ -234,12 +235,12 @@ module State =
               else report_error ~loc:(Loc.get x) (Printf.sprintf "name \"%s\" does not designate a variable" (Subst.subst x))
          else L (scope, s, inner enclosing)
       in
-      inner s      
+      inner s
 
     (* Evals a variable in a state w.r.t. a scope *)
     let rec eval s x =
       match s with
-      | I                       -> report_error "uninitialized state"           
+      | I                       -> report_error "uninitialized state"
       | G (_, s)                -> s x
       | L (scope, s, enclosing) -> if in_scope x scope then s x else eval enclosing x
 
@@ -252,7 +253,7 @@ module State =
       in
       let g = get st in
       let rec recurse = function
-      | I               -> g 
+      | I               -> g
       | L (scope, s, e) -> L (scope, s, recurse e)
       | G _             -> g
       in
@@ -261,7 +262,7 @@ module State =
     (* Creates a new scope, based on a given state *)
     let rec enter st xs =
       match st with
-      | I           -> report_error "uninitialized state"                   
+      | I           -> report_error "uninitialized state"
       | G _         -> L (xs, undefined, st)
       | L (_, _, e) -> enter e xs
 
@@ -277,7 +278,7 @@ module State =
     (* Observe a variable in a state and print it to stderr *)
     let observe st x =
       Printf.eprintf "%s=%s\n%!" x (try show (Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") @@ eval st x with _ -> "undefined")
-      
+
   end
 
 (* Patterns *)
@@ -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 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
+    @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.
     *)
@@ -358,7 +364,7 @@ module Expr =
     (* array                      *) | Array     of t list
     (* string                     *) | String    of string
     (* S-expressions              *) | Sexp      of string * t list
-    (* variable                   *) | Var       of string 
+    (* variable                   *) | Var       of string
     (* reference (aka "lvalue")   *) | Ref       of string
     (* binary operator            *) | Binop     of string * t * t
     (* element extraction         *) | Elem      of t * t
@@ -376,17 +382,17 @@ module Expr =
     (* return statement           *) | Return    of t option
     (* ignore a value             *) | Ignore    of t
     (* unit value                 *) | Unit
-    (* entering the scope         *) | Scope     of (string * decl) list * t 
+    (* entering the scope         *) | Scope     of (string * decl) list * t
     (* lambda expression          *) | Lambda    of string list * t
     (* 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
+    with show, html, foldl
-                           
+
     let notRef = function Reff -> false | _ -> true
     let isVoid = function Void | Weak -> true  | _ -> false
-    
+
     (* Available binary operators:
         !!                   --- disjunction
         &&                   --- conjunction
@@ -396,7 +402,7 @@ module Expr =
     *)
 
     (* Update state *)
-    let update st x v =      
+    let update st x v =
       match x with
       | Value.Var (Value.Global x) -> State.update x v st
       | Value.Elem (x, i) -> Value.update_elem x i v; st
@@ -448,11 +454,11 @@ module Expr =
       let print_values vs =
         Printf.eprintf "Values:\n%!";
         List.iter (fun v -> Printf.eprintf "%s\n%!" @@ show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v) vs;
-        Printf.eprintf "End Values\n%!"        
+        Printf.eprintf "End Values\n%!"
       in
       match expr with
       | Lambda (args, body) ->
-         eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k        
+         eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k
       | Scope (defs, body) ->
          let vars, body, bnds =
            List.fold_left
@@ -517,10 +523,10 @@ module Expr =
                 let st' = State.push (State.leave st closure.(0)) (State.from_list @@ List.combine args es) (List.map (fun x -> x, Mut) args) in
                 let st'', i', o', vs'' = eval (st', i, o, []) Skip body in
                 closure.(0) <- st'';
-                (State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs')                      
+                (State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs')
              | _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") f))
             ))]))
-        
+
       | Leave  -> eval (State.drop st, i, o, vs) Skip k
       | Assign (x, e)  ->
          eval conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))])
@@ -557,7 +563,7 @@ module Expr =
                | Pattern.Boxed       , Value.Sexp  (_, _)
                | Pattern.StringTag   , Value.String _
                | Pattern.ArrayTag    , Value.Array  _
-               | Pattern.ClosureTag  , Value.Closure _                                           
+               | Pattern.ClosureTag  , Value.Closure _
                | Pattern.SexpTag     , Value.Sexp  (_, _)                                                  -> st
                | _                                                                                         -> None
              and match_list ps vs s =
@@ -586,7 +592,7 @@ module Expr =
     match atr with
     | Weak -> Seq (expr, Const 0)
     | _    -> expr
-    
+
   (* semantics for infixes created in runtime *)
   let sem s = (fun x atr y -> ignore atr (Call (Var s, [x; y]))), (fun _ -> Val, Val)
 
@@ -631,34 +637,34 @@ module Expr =
           )]
       )
       in
-      ostap (inner[0][id][atr]) 
+      ostap (inner[0][id][atr])
-      
+
     let atr' = atr
     let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord))
-                          
+
     (* UGLY! *)
     let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Pervasives.ref (fun _ _ -> invalid_arg "must not happen")
 
-    let defCell = Pervasives.ref 0 
+    let defCell = Pervasives.ref 0
-                                                      
+
     (* ======= *)
-    let makeParsers env = 
+    let makeParsers env =
     let makeParser, makeBasicParser, makeScopeParser =
       let def s   = let Some def = Obj.magic !defCell in def s in
       let ostap (
       parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} | basic[infix][atr];
-      scope[infix][atr]: <(d, infix')> : def[infix] expr:parse[infix'][atr] {Scope (d, expr)} | {isVoid atr} => <(d, infix')> : def[infix] => {d <> []} => {Scope (d, materialize atr Skip)}; 
+      scope[infix][atr]: <(d, infix')> : def[infix] expr:parse[infix'][atr] {Scope (d, expr)} | {isVoid atr} => <(d, infix')> : def[infix] => {d <> []} => {Scope (d, materialize atr Skip)};
       basic[infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, _, f) -> ostap (- $(s)), f) l)) infix) (primary infix) atr);
       primary[infix][atr]:
-          s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)})  
+          s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)})
           b:base[infix][Val] is:(  "." f:LIDENT args:(-"(" !(Util.list)[parse infix Val] -")")? {`Post (f, args)}
                                       | "." %"length"                                           {`Len}
                                       | "." %"string"                                           {`Str}
-                                      | "[" i:parse[infix][Val] "]"                             {`Elem i}                                    
+                                      | "[" i:parse[infix][Val] "]"                             {`Elem i}
-                                      | "(" args:!(Util.list0)[parse infix Val] ")"             {`Call args}  
+                                      | "(" args:!(Util.list0)[parse infix Val] ")"             {`Call args}
           )+
         => {match (List.hd (List.rev is)), atr with
-            | `Elem i, Reff -> true            
+            | `Elem i, Reff -> true
             |  _,      Reff -> false
             |  _,      _    -> true} =>
         {
@@ -681,7 +687,7 @@ module Expr =
                 | `Len            -> Length b
                 | `Str            -> StringVal b
                 | `Post (f, args) -> Call (Var f, b :: match args with None -> [] | Some args -> args)
-                | `Call args      -> (match b with Sexp _ -> invalid_arg "retry!" | _ -> Call (b, args)) 
+                | `Call args      -> (match b with Sexp _ -> invalid_arg "retry!" | _ -> Call (b, args))
               )
               b
               is
@@ -701,9 +707,9 @@ module Expr =
         l:$ n:DECIMAL                              => {notRef atr} :: (not_a_reference l) => {ignore atr (Const n)}
       | l:$ s:STRING                               => {notRef atr} :: (not_a_reference l) => {ignore atr (String s)}
       | l:$ c:CHAR                                 => {notRef atr} :: (not_a_reference l) => {ignore atr (Const  (Char.code c))}
-      
+
-      | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c} 
+      | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c}
-       
+
       | l:$ %"infix" s:INFIX => {notRef atr} :: (not_a_reference l) => {
           if ((* UGLY! *) Obj.magic !predefined_op) infix s
           then (
@@ -711,7 +717,7 @@ module Expr =
             then report_error ~loc:(Some l#coord) (Printf.sprintf "can not capture predefined operator \":=\"")
             else
               let name = sys_infix_name s in Loc.attach name l#coord; ignore atr (Var name)
-          )            
+          )
           else (
             let name = infix_name s in Loc.attach name l#coord; ignore atr (Var name)
           )
@@ -735,7 +741,7 @@ module Expr =
       }
 
       | l:$ "[" es:!(Util.list0)[parse infix Val] "]" => {notRef atr} :: (not_a_reference l) => {ignore atr (Array es)}
-      | -"{" scope[infix][atr] -"}" 
+      | -"{" scope[infix][atr] -"}"
       | l:$ "{" es:!(Util.list0)[parse infix Val] "}" => {notRef atr} :: (not_a_reference l) => {ignore atr (match es with
                                                                                       | [] -> Const 0
                                                                                       | _  -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0))
@@ -744,7 +750,7 @@ module Expr =
                                                                                                               | None -> []
                                                                                                               | Some args -> args))
                                                                                         }
-      | l:$ x:LIDENT {Loc.attach x l#coord; if notRef atr then ignore atr (Var x) else Ref x}                 
+      | l:$ x:LIDENT {Loc.attach x l#coord; if notRef atr then ignore atr (Var x) else Ref x}
 
       | {isVoid atr} => %"skip" {materialize atr Skip}
 
@@ -797,7 +803,7 @@ module Expr =
           match sema with
           | Some s -> s, ss
           | None   ->
-             let arr, ss = 
+             let arr, ss =
                List.fold_left (fun (arr, ss) ((loc, omit, p, s) as elem) ->
                                  match omit with
                                  | None   -> (match p with
@@ -840,21 +846,21 @@ module Expr =
         List.fold_left (fun acc args -> Call (acc, args)) (Var p) args
       }
       | -"(" syntax[infix] -")"
-      | -"$(" parse[infix][Val] -")" 
+      | -"$(" parse[infix][Val] -")"
     ) in (fun def -> defCell := Obj.magic !def; parse),
          (fun def -> defCell := Obj.magic !def; basic),
          (fun def -> defCell := Obj.magic !def; scope)
     in
     makeParser, makeBasicParser, makeScopeParser
-                                   
+
     (* Workaround until Ostap starts to memoize properly *)
     ostap (
       constexpr:
         n:DECIMAL                                          {Const n}
       | s:STRING                                           {String s}
-      | c:CHAR                                             {Const (Char.code c)}      
+      | c:CHAR                                             {Const (Char.code c)}
       | %"true"                                            {Const 1}
-      | %"false"                                           {Const 0}       
+      | %"false"                                           {Const 0}
       | "[" es:!(Util.list0)[constexpr] "]"                {Array es}
       | "{" es:!(Util.list0)[constexpr] "}"                {match es with [] -> Const 0 | _  -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)}
       | t:UIDENT args:(-"(" !(Util.list)[constexpr] -")")? {Sexp (t, match args with None -> [] | Some args -> args)}
@@ -868,13 +874,13 @@ module Expr =
 (* Infix helpers *)
 module Infix =
   struct
-    
+
     @type kind     = Predefined | Public | Local with show
     @type ass      = [`Lefta | `Righta | `Nona] with show
     @type loc      = [`Before of string | `After of string | `At of string] with show
     @type export   = (ass * string * loc) list with show
     @type showable = (ass * string * kind) list array with show
-                                                                                                     
+
     type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * kind * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array
 
     let show_infix (infix : t) =
@@ -882,7 +888,7 @@ module Infix =
 
     let extract_exports infix =
       let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in
-      let exported = 
+      let exported =
         Array.map
           (fun (ass, (_, ops)) ->
             (ass, List.rev @@ List.map (fun (s, kind, _) -> s, kind) @@ List.filter (function (_, Public, _) | (_, Predefined, _) -> true | _ -> false) ops)
@@ -898,8 +904,8 @@ module Infix =
                  let loc' = match tl with [] -> `After s | _ -> `At s in
                  (fun again ->
                     match kind with
-                    | Public -> again (loc', (ass, s, loc) :: acc) 
+                    | Public -> again (loc', (ass, s, loc) :: acc)
-                    | _      -> again (loc', acc) 
+                    | _      -> again (loc', acc)
                  )
                  (match tl with [] -> fun acc -> acc | _ -> fun acc -> inner acc tl)
             in
@@ -909,9 +915,9 @@ module Infix =
           exported
       in List.rev exports
 
-    let is_predefined op =      
+    let is_predefined op =
       List.exists (fun x -> op = x) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"; ":="]
-      
+
     (*
     List.iter (fun op ->
         Printf.eprintf "F,%s\n" (sys_infix_name op);
@@ -924,7 +930,7 @@ module Infix =
         Printf.eprintf "}\n\n"        *)
       ) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"]
      *)
-      
+
     let default : t =
       Array.map (fun (a, s) ->
         a,
@@ -942,14 +948,14 @@ module Infix =
       |]
 
     exception Break of [`Ok of t | `Fail of string]
-      
+
     let find_op infix op cb ce =
       try
         Array.iteri (fun i (_, (_, l)) -> if List.exists (fun (s, _, _) -> s = op) l then raise (Break (cb i))) infix;
         ce ()
       with Break x -> x
 
-    let predefined_op infix op =      
+    let predefined_op infix op =
       Array.exists
         (fun (_, (_, l)) ->
            List.exists (fun (s, p, _) -> s = op && p = Predefined) l
@@ -958,11 +964,11 @@ module Infix =
 
     (* UGLY!!! *)
     Expr.predefined_op := (Obj.magic) predefined_op;;
-                          
+
-    let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op) 
+    let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op)
 
     let kind_of = function true -> Public | _ -> Local
-                                               
+
     let at coord op newp public (sem, _) (infix : t) =
       find_op infix op
         (fun i ->
@@ -1021,10 +1027,10 @@ module Definition =
       constdef: %"public" d:!(Util.list (const_var)) ";" {d}
       (* end of the workaround *)
     )
-                                                      
+
     let makeParser env exprBasic exprScope =
     let ostap (
-      arg : l:$ x:LIDENT {Loc.attach x l#coord; x};       
+      arg : l:$ x:LIDENT {Loc.attach x l#coord; x};
       position[pub][ass][coord][newp]:
         %"at" s:INFIX {match ass with
                        | `Nona -> Infix.at coord s newp pub
@@ -1044,7 +1050,7 @@ module Definition =
           | `Fail msg  -> report_error ~loc:(Some l#coord) msg
       };
       local_var[m][infix]: l:$ name:LIDENT value:(-"=" exprBasic[infix][Expr.Val])? {
-        Loc.attach name l#coord;                                                                  
+        Loc.attach name l#coord;
         match m, value with
         | `Extern, Some _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "initial value for an external variable \"%s\" can not be specified" name)
         | _               -> name, (m,`Variable value)
@@ -1076,16 +1082,16 @@ module Definition =
          } |
          l:$ ";" {
             match m with
-            | `Extern -> [(name, (m, `Fun ((List.map (fun _ -> env#get_tmp) args), Expr.Skip)))], infix' 
+            | `Extern -> [(name, (m, `Fun ((List.map (fun _ -> env#get_tmp) args), Expr.Skip)))], infix'
             | _       -> report_error ~loc:(Some l#coord) (Printf.sprintf "missing body for the function/infix \"%s\"" orig_name)
-         })           
+         })
     ) in parse
 
   end
-  
+
 module Interface =
   struct
-    
+
     (* Generates an interface file. *)
     let gen ((imps, ifxs), p) =
       let buf = Buffer.create 256 in
@@ -1103,7 +1109,7 @@ module Interface =
              | _ -> ()
             )
             decls;
-       | _ -> ());      
+       | _ -> ());
       List.iter
         (function (ass, op, loc) ->
            let append_op op = append "\""; append op; append "\"" in
@@ -1114,7 +1120,7 @@ module Interface =
            append ";\n"
         ) ifxs;
       Buffer.contents buf
-      
+
     (* Read an interface file *)
     let read fname =
       let ostap (
@@ -1135,13 +1141,13 @@ module Interface =
                              inherit Util.Lexers.ident [] s
                              inherit Util.Lexers.string s
                              inherit Util.Lexers.skip  [Matcher.Skip.whitespaces " \t\n"] s
-                           end)             
+                           end)
                           (ostap (interface -EOF))
          with
          | `Ok intfs -> Some intfs
          | `Fail er  -> report_error (Printf.sprintf "malformed interface file \"%s\": %s" fname er)
         )
-      with Sys_error _ -> None                        
+      with Sys_error _ -> None
 
     let find import paths =
       (*Printf.printf "Paths to search import in: %s" (show(list) (show(string)) paths); *)
@@ -1181,7 +1187,7 @@ ostap (
       (fun infix import ->
         List.fold_left
           (fun infix item ->
-             let insert name infix md = 
+             let insert name infix md =
                let name = infix_name name in
                match md (Expr.sem name) infix with
                | `Ok infix' -> infix'
@@ -1212,8 +1218,8 @@ let parse cmd =
     object
       val imports   = Pervasives.ref ([] : string list)
       val tmp_index = Pervasives.ref 0
-                    
+
-      method add_import imp = imports := imp :: !imports 
+      method add_import imp = imports := imp :: !imports
       method get_tmp        = let index = !tmp_index in incr tmp_index; Printf.sprintf "__tmp%d" index
       method get_imports    = !imports
     end
@@ -1233,24 +1239,59 @@ let parse cmd =
   in
 
   let definitions = Pervasives.ref None in
-  
+
   let (makeParser, makeBasicParser, makeScopeParser) = Expr.makeParsers env in
-  
+
   let expr        s = makeParser      definitions s in
   let exprBasic   s = makeBasicParser definitions s in
   let exprScope   s = makeScopeParser definitions s in
-  
+
   definitions := Some (makeDefinitions env exprBasic exprScope);
 
   let Some definitions = !definitions in
-  
+
   let ostap (
       parse[cmd]:
         <(is, infix)> : imports[cmd]
-        <(d, infix')> : definitions[infix] 
+        <(d, infix')> : definitions[infix]
         expr:expr[infix'][Expr.Weak]? {
             (env#get_imports @ is, Infix.extract_exports infix'), Expr.Scope (d, match expr with None -> Expr.materialize Expr.Weak Expr.Skip | Some e -> e)
           }
         )
   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%!"