st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 06:48:48 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merging with origin

Browse source
This commit is contained in:
Dmitry Boulytchev 2021-01-25 01:38:59 +03:00
commit 7eb3e223b8
24 changed files with 1059 additions and 157 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

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

2
Makefile
View file

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

3
bench/.gitignore vendored Normal file
View file

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

37
bench/Makefile Normal file
View file

@ -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 > $@

26
bench/README.md Normal file
View file

@ -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

76
bench/bench_main.ml Normal file
View file

@ -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

6
bench/demo.lama Normal file
View file

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

89
bench/demo_infix.ml Normal file
View file

@ -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);
()

159
bench/p.ml Normal file
View file

@ -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

25
bench/pp_default.m4 Normal file
View file

@ -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
]])

40
bench/pp_gt.m4 Normal file
View file

@ -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
]])

2
runtime/.gitignore vendored Normal file
View file

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

4
src/.gitignore vendored Normal file
View file

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

79
src/Driver.ml
View file

@ -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 <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

231
src/Language.ml
View file

@ -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 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 _ -> "<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}
| "(" 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))

13
src/Makefile
View file

@ -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

198
src/Pprinter.ml Normal file
View file

@ -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"

2
src/version.ml
View file

@ -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"

3
stdlib/.gitignore vendored Normal file
View file

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

2
tools/.gitignore vendored Normal file
View file

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

25
tools/Makefile Normal file
View file

@ -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) $<

41
tools/README.md Normal file
View file

@ -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)
```
###### Поддерживаемые синтаксические конструкции
Утилита работает для определний функций, их аргументов и локальных определений переменных.

15
tools/demo1.lama Normal file
View file

@ -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
}

136
tools/tool.ml Normal file
View file

@ -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%!"