diff --git a/.gitignore b/.gitignore index 6a2ef53b1..5955142ad 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ *~ *.cmi *.cmx +*.cmo *.o +.merlin diff --git a/Makefile b/Makefile index e9ea331aa..e7e2e6eea 100644 --- a/Makefile +++ b/Makefile @@ -31,5 +31,5 @@ clean: make clean -C runtime make clean -C stdlib make clean -C regression - + $(MAKE) clean -C bench diff --git a/bench/.gitignore b/bench/.gitignore new file mode 100644 index 000000000..015d7e2bc --- /dev/null +++ b/bench/.gitignore @@ -0,0 +1,3 @@ +/*.exe +/Pprint_gt.ml +/Pprint_default.ml diff --git a/bench/Makefile b/bench/Makefile new file mode 100644 index 000000000..06d18e1ed --- /dev/null +++ b/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 > $@ diff --git a/bench/README.md b/bench/README.md new file mode 100644 index 000000000..16044fb48 --- /dev/null +++ b/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 diff --git a/bench/bench_main.ml b/bench/bench_main.ml new file mode 100644 index 000000000..127ec81f9 --- /dev/null +++ b/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 diff --git a/bench/demo.lama b/bench/demo.lama new file mode 100644 index 000000000..c618269bf --- /dev/null +++ b/bench/demo.lama @@ -0,0 +1,6 @@ +public infix +++ at + (x, y) { + case x of + {} -> y + | x : xs -> x : xs +++ y + esac +} diff --git a/bench/demo_infix.ml b/bench/demo_infix.ml new file mode 100644 index 000000000..2431bef49 --- /dev/null +++ b/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 "@[%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); + () diff --git a/bench/p.ml b/bench/p.ml new file mode 100644 index 000000000..c0f0b26df --- /dev/null +++ b/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 "@[%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 @[{@,%a@]@ @[} else {@,%a@]@ } fi@]" + fself c fself th fself el]]) + +METH(While, ppf, cond body, While(cond,body), [[ +Format.fprintf ppf "@["; +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 "@["; +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 "@["; +Format.fprintf ppf "@[case %a of@ @]@," fself scru; +Format.fprintf ppf "@["; +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 "@["; +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 "@["; + Format.fprintf ppf "@[%afun %s (%a) @]@," pp_qualifier qual name args ss; + Format.fprintf ppf "@[{@,@[%a@]@]@ " pp_expr e; + Format.fprintf ppf "}"; + Format.fprintf ppf "@]"]] +) +FOOTER_DECL + +FIX diff --git a/bench/pp_default.m4 b/bench/pp_default.m4 new file mode 100644 index 000000000..2d5320823 --- /dev/null +++ b/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 +]]) diff --git a/bench/pp_gt.m4 b/bench/pp_gt.m4 new file mode 100644 index 000000000..40a01c542 --- /dev/null +++ b/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 +]]) diff --git a/runtime/.gitignore b/runtime/.gitignore new file mode 100644 index 000000000..ede012c6b --- /dev/null +++ b/runtime/.gitignore @@ -0,0 +1,2 @@ +*.a + diff --git a/src/.gitignore b/src/.gitignore new file mode 100644 index 000000000..af3dc85cf --- /dev/null +++ b/src/.gitignore @@ -0,0 +1,4 @@ +.depend +lamac +lamac.byte + diff --git a/src/Driver.ml b/src/Driver.ml index 8b1322555..6213d941e 100644 --- a/src/Driver.ml +++ b/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_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 \n\n" ^ "When no options specified, builds the source file into executable.\n" ^ "Options:\n" ^ " -c --- compile into object file\n" ^ - " -o --- write executable into file \n" ^ + " -o --- write executable into file \n" ^ " -I --- add 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 ""; 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 diff --git a/src/Language.ml b/src/Language.ml index 7d0348d32..136d01142 100644 --- a/src/Language.ml +++ b/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 _ -> "") (fun _ -> "") @@ 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 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. *) @@ -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] - 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 - + (* 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 _ -> "") (fun _ -> "") 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 _ -> "") (fun _ -> "") 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} - | "(" args:!(Util.list0)[parse infix Val] ")" {`Call args} + | "[" i:parse[infix][Val] "]" {`Elem i} + | "(" 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) - | _ -> again (loc', acc) + | Public -> again (loc', (ass, s, 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)) diff --git a/src/Makefile b/src/Makefile index b29eb0647..ed77617e0 100644 --- a/src/Makefile +++ b/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 diff --git a/src/Pprinter.ml b/src/Pprinter.ml new file mode 100644 index 000000000..dd9ca841a --- /dev/null +++ b/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 "@[%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 @[{@,%a@]@ @[} else {@,%a@]@ } fi@]" + fself c fself th fself el + method c_While ppf _ cond body = + Format.fprintf ppf "@["; + 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 "@["; + Format.fprintf ppf "repeat@,%a" fself body; + Format.fprintf ppf "until %a@]" fself cond + + + method c_Case ppf _ scru cases _ _ = + Format.fprintf ppf "@["; + Format.fprintf ppf "@[case %a of@ @]@," fself scru; + Format.fprintf ppf "@["; + 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 "@["; + 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 "@["; + Format.fprintf ppf "@[%afun %s (%a) @]@," self#qualifier qual name self#args ss; + Format.fprintf ppf "@[{@,@[%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" diff --git a/src/version.ml b/src/version.ml index cfc8d681e..c926137b6 100644 --- a/src/version.ml +++ b/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" diff --git a/stdlib/.gitignore b/stdlib/.gitignore new file mode 100644 index 000000000..48382914d --- /dev/null +++ b/stdlib/.gitignore @@ -0,0 +1,3 @@ +*.i +*.s + diff --git a/tools/.gitignore b/tools/.gitignore new file mode 100644 index 000000000..ceb88a5cc --- /dev/null +++ b/tools/.gitignore @@ -0,0 +1,2 @@ +/*.exe + diff --git a/tools/Makefile b/tools/Makefile new file mode 100644 index 000000000..6e6535403 --- /dev/null +++ b/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) $< diff --git a/tools/README.md b/tools/README.md new file mode 100644 index 000000000..bcb702129 --- /dev/null +++ b/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) +``` + +###### Поддерживаемые синтаксические конструкции + +Утилита работает для определний функций, их аргументов и локальных определений переменных. + diff --git a/tools/demo1.lama b/tools/demo1.lama new file mode 100644 index 000000000..a3385aa43 --- /dev/null +++ b/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 +} diff --git a/tools/tool.ml b/tools/tool.ml new file mode 100644 index 000000000..dd93d15a7 --- /dev/null +++ b/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%!"