diff --git a/.gitignore b/.gitignore
index 847efcc68..db0fec99e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,4 @@
*~
-*.cmi
-*.cmx
+*.cm[iox]
*.o
+
diff --git a/README.md b/README.md
index 552617ec3..21a59e4c0 100644
--- a/README.md
+++ b/README.md
@@ -2,7 +2,7 @@
Supplementary repository for compiler course.
-Prerequisites: ocaml [http://ocaml.org], opam [http://opam.ocaml.org].
+Prerequisites: [ocaml](http://ocaml.org), opam [http://opam.ocaml.org].
Building:
@@ -12,3 +12,51 @@ Building:
* `opam install GT`
* To build the sources: `make` from the top project directory
* To test: `test.sh` from `regression` subfolder
+
+
+
+### Про бенчмарки
+
+Было рассмотрено три подхода к созданию синтаксического анализатора:
+
+* LR анализ на основе Menhir
+* Нисходящий с помощью библиотеки Opal
+* Нисходящий с помощью Ostap
+
+#### Сравнение производительности
+
+Сравнивались три реализации:
+
+* [Старый](https://github.com/Kakadu/ostap/tree/master-very-old) Ostap с отключенной обработкой ошибок
+* [Opal](https://github.com/pyrocat101/opal)
+* [Menhir](http://gitlab.inria.fr/fpottier/menhir)
+
+Opal не поддерживает человеческие сообщения об ошибках, поэтому в Ostap те были отключены. В Menhir сообщения об
+ошибках так просто отключить нельзя.
+
+Производительность показана в таблице. Парсеры запускали в течение 1 секунды и вычислялось сколько раз они успешно отработали. В таблице хранится следующая информация:
+
+* Первый столбец --- название парсера
+* Второй столбей --- абсолютная скорость, чем больше, тем лучше
+* Третий --- таблица ускорения одного вида парсинга относительно другого. Для строки L и стобца R в ячейке `[L][R]` будет храниться ускроение, которое дает парсер L относительно R, которое вычисляется как (L-R)/R*100%. В зеркальных элементах таблицы при таком подсчете будут всегда значения противоположного знака.
+
+В итоге получилось, что LR анализатор (Menhir) работает существенно производительнее нисходящего анализа, по причинам...
+
+#### Сравнение размера кода
+
+Реализации находятся в файлах
+
+* [LamaOpal.ml](src/LamaOpal.ml)
+* [LamaOstapP5.ml](src/LamaOstapP5.ml)
+* [LamaMenhir.mly](src/LamaMenhir.mly) и [LamaLexer.mll](src/LamaLexer.mll)
+
+Ostap использует специальное синтаксическое расширение для написание парсера, поэтому естесственно, что размер реализации на Ostap меньше, чем на Opal. Но и там, и там, можно описывать специализированные парсеры (например, парсер арифметических выражений), использование которых может сделать код более похожим по размеру.
+
+Menhir позволяет параметризовывать правила другими, в том числе "анонимными" правилами, поддерживает специальный синтаксии для операций EBNF. Поэтому размер непосредственно пасрера можно сопоставить по размеру с реализацией на Ostap, за несколькими исключениями.
+
+* Ostap использует специальный парсер для парсинга арифметических выражений, поэтому эта часть на нём компактнее.
+* Menhir использует lexer на основе OCamlLex, в Ostap это реализовано по-другому. Поэтому реализация лексической части на menhir выглядит сущетсвенно длиннее, чем на Ostap.
+
+#### Разбираемый язык
+
+Разновиность Ламы, где мы не используем определение кастомных инфиксных операторов. По идее, если их завести, то menhir будет больно. ДЮ, Вы тут лучше знаете, какие там инфиксы в Ламе и почему именно будет больно.
diff --git a/doc/.gitignore b/doc/.gitignore
new file mode 100644
index 000000000..c8fe64d68
--- /dev/null
+++ b/doc/.gitignore
@@ -0,0 +1,4 @@
+*.log
+*.out
+*.pdf
+
diff --git a/regression/.gitignore b/regression/.gitignore
new file mode 100644
index 000000000..6d34078da
--- /dev/null
+++ b/regression/.gitignore
@@ -0,0 +1,2 @@
+*.s
+
diff --git a/src/.gitignore b/src/.gitignore
new file mode 100644
index 000000000..4ff7dc064
--- /dev/null
+++ b/src/.gitignore
@@ -0,0 +1,7 @@
+.merlin
+/LamaLexer.ml
+/LamaMenhir.ml
+/LamaMenhir.mli
+/LamaMenhir.conflicts
+/rc.opt
+/*.exe
diff --git a/src/Driver.ml b/src/Driver.ml
index 04818b39e..73bb42008 100644
--- a/src/Driver.ml
+++ b/src/Driver.ml
@@ -1,50 +1,75 @@
-open Ostap
-let parse infile =
- let s = Util.read infile 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.ident ["skip"; "if"; "then"; "else"; "elif"; "fi"; "while"; "do"; "od"; "repeat"; "until"; "for"; "fun"; "local"; "return"; "length"] s
- inherit Util.Lexers.skip [
- Matcher.Skip.whitespaces " \t\n";
- Matcher.Skip.lineComment "--";
- Matcher.Skip.nestedComment "(*" "*)"
- ] s
- end
- )
- (ostap (!(Language.parse) -EOF))
+
+module ArgInfo = struct
+ type t =
+ { mutable interpret: bool
+ ; mutable stack: bool
+ ; mutable file: string
+ ; mutable menhir: bool
+ ; mutable dparsetree: bool
+ }
+ let empty () = { interpret = false; stack=false; file=""; menhir=false; dparsetree = false }
+ let to_compile { stack; interpret } = not (interpret || stack)
+ let parse_args nfo =
+ Arg.parse
+ [ ("-i", Arg.Unit (fun () -> nfo.interpret <- true), "interpret")
+ ; ("-s", Arg.Unit (fun () -> nfo.stack <- true), "stack")
+ ; ("-m", Arg.Unit (fun () -> nfo.menhir <- true), "use menhir")
+ ; ("-pc", Arg.Unit (fun () -> nfo.menhir <- false), "use ostap (default) ")
+ ; ("-dparsetree", Arg.Unit (fun () -> nfo.dparsetree <- true), "dump parsetree")
+ ]
+ (fun s -> nfo.file <- s )
+ "Usage: rc [-i | -s] \n"
+
+ let infile { file } = file
+ let is_interpret { interpret } = interpret
+ let dparsetree { dparsetree } = dparsetree
+
+ let parse { menhir; file } =
+ print_endline file;
+ let s = Ostap.Util.read file in
+ if not menhir
+ then Language.run_parser s
+ else RunMenhir.run_parser ~filename:file s
+
+end
let main =
- try
- let interpret = Sys.argv.(1) = "-i" in
- let stack = Sys.argv.(1) = "-s" in
- let to_compile = not (interpret || stack) in
- let infile = Sys.argv.(if not to_compile then 2 else 1) in
- match parse infile with
+ (* try *)
+ let args = ArgInfo.empty () in
+ let () = ArgInfo.parse_args args in
+ (* let interpret = Sys.argv.(1) = "-i" in *)
+ (* let stack = Sys.argv.(1) = "-s" in *)
+ (* let to_compile = not (interpret || stack) in *)
+ (* let infile = Sys.argv.(if not to_compile then 2 else 1) in *)
+ match ArgInfo.parse args with
| `Ok prog ->
- if to_compile
- then
- let basename = Filename.chop_suffix infile ".expr" in
- ignore @@ X86.build prog basename
- else
- let rec read acc =
- try
- let r = read_int () in
- Printf.printf "> ";
- read (acc @ [r])
- with End_of_file -> acc
- in
- let input = read [] in
- let output =
- if interpret
- then Language.eval prog input
- else SM.run (SM.compile prog) input
- in
- List.iter (fun i -> Printf.printf "%d\n" i) output
+ let () =
+ if ArgInfo.dparsetree args
+ then (
+ Format.printf "%s\n%!" (GT.show GT.list (GT.show Language.Definition.t) @@ fst prog);
+ Format.printf "%s\n%!" (GT.show Language.Stmt.t @@ snd prog);
+ )
+ in
+ if ArgInfo.to_compile args
+ then
+ let basename = Filename.chop_suffix (ArgInfo.infile args) ".expr" in
+ ignore @@ X86.build prog basename
+ else
+ let rec read acc =
+ try
+ let r = read_int () in
+ Printf.printf "> ";
+ read (acc @ [r])
+ with End_of_file -> acc
+ in
+ let input = read [] in
+ let output =
+ if ArgInfo.is_interpret args
+ then Language.eval prog input
+ else SM.run (SM.compile prog) input
+ in
+ List.iter (fun i -> Printf.printf "%d\n" i) output
| `Fail er -> Printf.eprintf "Syntax error: %s\n" er
- with Invalid_argument _ ->
- Printf.printf "Usage: rc [-i | -s] \n"
+ (* with Invalid_argument _ ->
+ Printf.printf "Usage: rc [-i | -s] \n" *)
diff --git a/src/GenParser.ml b/src/GenParser.ml
new file mode 100644
index 000000000..e1790547d
--- /dev/null
+++ b/src/GenParser.ml
@@ -0,0 +1,141 @@
+module type P = sig
+ type ('t, 'a) t
+
+ val ( => ) : ('t, 'a) t -> ('a -> 'b) -> ('t, 'b) t
+
+ val map : ('a -> 'b) -> ('t, 'a) t -> ('t, 'b) t
+
+ val altl : ('t, 'a) t list -> ('t, 'a) t
+
+ val alt : ('t, 'a) t -> ('t, 'a) t -> ('t, 'a) t
+
+ val many : ('t, 'a) t -> ('t, 'a list) t
+
+ val empty : ('t, unit) t
+
+ val return : 'a -> ('t, 'a) t
+
+ val ( >>= ) : ('t, 'a) t -> ('a -> ('t, 'b) t) -> ('t, 'b) t
+
+ val ( *> ) : ('t, 'a) t -> ('t, 'b) t -> ('t, 'b) t
+
+ val ( <* ) : ('t, 'a) t -> ('t, 'b) t -> ('t, 'a) t
+
+ val seq : ('t, 'a) t -> ('a -> ('t, 'b) t) -> ('t, 'b) t
+
+ (* val guard : ('a, 'b, 'c) t -> ('b -> bool) -> ('b -> 'c) option -> ('a, 'b, 'c) t *)
+
+ val guard : ('a, 'b) t -> ('b -> bool) -> ('b -> unit) option -> ('a, 'b) t
+
+ val opt : ('a, 'b) t -> ('a, 'b option) t
+
+ val fix : (('a, 'b) t -> ('a, 'b) t) -> ('a, 'b) t
+
+ val token : string -> (char, string) t
+
+ (* almost token but modulo whitespace *)
+ val lexeme : string -> (char, string) t
+
+ val decimal : (char, int) t
+
+ val ident : (char, string) t
+
+ val eof : (char, unit) t
+
+ (* should return a string with leading and ending quotes *)
+ val string : (char, string) t
+
+ val char : (char, char) t
+
+ val debug : string -> ('tok, unit) t
+
+ val spaces : (char, unit) t
+end
+
+module type PExt = sig
+ include P
+
+ (* comma-separated list of >=0 values *)
+ val list0 : (char, 'r) t -> (char, 'r list) t
+
+ (* comma-separated list of >=1 values *)
+ val list : (char, 'r) t -> (char, 'r list) t
+
+ val parens : (char, 'b) t -> (char, 'b) t
+end
+
+module OUtil (P : P) = struct
+ open P
+
+ let left f c x y = f (c x) y
+
+ let right f c x y = c (f x y)
+
+ let expr f ops opnd =
+ let ops =
+ Array.map
+ (fun (assoc, list) ->
+ let g =
+ match assoc with `Lefta | `Nona -> left | `Righta -> right
+ in
+ ( assoc = `Nona,
+ altl (List.map (fun (oper, sema) -> oper => fun _ -> g sema) list)
+ ))
+ ops
+ in
+ let n = Array.length ops in
+ let op i = snd ops.(i) in
+ let nona i = fst ops.(i) in
+ let id x = x in
+ let rec inner l c =
+ (* Printf.printf "inner %d \n%!" l; *)
+ f
+ (alt
+ (seq
+ (guard empty (fun _ -> n = l) None)
+ (fun _ -> map (fun (x as _0) -> c x) opnd))
+ (alt
+ (seq
+ (guard empty (fun _ -> n > l && not (nona l)) None)
+ (fun _ ->
+ seq
+ (inner (l + 1) id)
+ (fun (x as _1) ->
+ map
+ (fun (b as _0) ->
+ match b with None -> c x | Some x -> x)
+ (opt (seq (op l) (fun o -> inner l (o c x)))))))
+ (seq
+ (guard empty (fun _ -> n > l && nona l) None)
+ (fun _ ->
+ seq
+ (inner (l + 1) id)
+ (fun (x as _1) ->
+ map
+ (fun (b as _0) ->
+ c (match b with None -> x | Some (o, y) -> o id x y))
+ (opt
+ (seq (op l) (fun (_ as _1) ->
+ map
+ (fun (_ as _0) -> (_1, _0))
+ (inner (l + 1) id)))))))))
+ in
+
+ inner 0 id
+end
+
+module Helpers (P : P) : PExt with type ('a, 'b) t = ('a, 'b) P.t = struct
+ include P
+
+ let list0 p =
+ alt
+ ( p >>= fun h ->
+ many (lexeme "," *> p) >>= fun tl -> return (h :: tl) )
+ (empty => fun _ -> [])
+
+ let list p =
+ p >>= fun h ->
+ many (lexeme "," *> p) >>= fun tl -> return (h :: tl)
+
+ let parens p = lexeme "(" *> p <* lexeme ")"
+end
diff --git a/src/LamaAngstrom.ml b/src/LamaAngstrom.ml
new file mode 100644
index 000000000..987656681
--- /dev/null
+++ b/src/LamaAngstrom.ml
@@ -0,0 +1,340 @@
+(* open Language
+open GenParser
+
+module AngImpl = struct
+ open Angstrom
+
+ module I = struct
+ type nonrec ('a, 'b) t = 'b t
+
+ let ( => ) = ( >>| )
+
+ let map f x = x >>| f
+
+ let ( >>= ) = ( >>= )
+
+ let seq = ( >>= )
+
+ let return = return
+
+ let opt = option
+
+ let guard p cond _ = p >>= fun r -> if cond r then return r else fail ""
+
+ (* let guard = guard *)
+
+ let empty : ('t, unit) t = return ()
+
+ let many = many
+
+ let alt = ( <|> )
+
+ let altl = choice
+
+ let spaces = skip_while (fun c -> List.mem c [ '\t'; '\r'; '\n'; ' ' ])
+
+ let eof : (char, unit) t = fun stream -> (spaces >>= fun _ -> eof ()) stream
+
+ let token s stream =
+ (* Printf.printf "token '%s' asked\n" s; *)
+ token s stream
+
+ let ( *> ) f g = f >>= fun _ -> g
+
+ let ( <* ) f g =
+ f >>= fun r ->
+ g >>= fun _ -> return r
+
+ let fix = fix
+
+ let string s =
+ (* let () = print_endline "string called" in *)
+ ( token "\"" *> many alpha_num <* token "\"" => fun xs ->
+ Printf.sprintf "%S" (implode xs) )
+ s
+
+ let decimal : (char, int) t =
+ fun stream ->
+ (* let () =
+ print_endline "decimal called";
+ Printf.printf "decimal asked when stream %s empty: %s \n"
+ (if stream = LazyStream.Nil then "IS" else "IS NOT")
+ ( match stream with
+ | LazyStream.Cons (c, t) ->
+ Printf.sprintf "('%c'=%d) :: ???" c (Char.code c)
+ | Nil -> "[]" )
+ in *)
+ ( many1 digit => fun xs ->
+ List.fold_left
+ (fun acc x -> (acc * 10) + Char.code x - Char.code '0')
+ 0 xs )
+ stream
+
+ (* parses 'c' *)
+ let char s =
+ let () =
+ (* print_endline "char called";
+ Printf.printf "decimal asked when stream %s empty: %s \n"
+ (if s = LazyStream.Nil then "IS" else "IS NOT")
+ ( match s with
+ | LazyStream.Cons (c, t) ->
+ Printf.sprintf "('%c'=%d) :: ???" c (Char.code c)
+ | Nil -> "[]" ); *)
+ ()
+ in
+
+ choice
+ [
+ Opal.token "'\n'" *> return '\n';
+ Opal.token "'\t'" *> return '\t';
+ Opal.exactly '\'' *> alpha_num <* Opal.exactly '\'';
+ ]
+ s
+
+ let ident =
+ spaces *> letter >>= fun h ->
+ many (alpha_num <|> exactly '_') >>= fun tl -> return (implode (h :: tl))
+
+ let lexeme l =
+ spaces *> token l => fun x ->
+ (* Printf.printf "lexeme %s eaten\n" x; *)
+ x
+
+ let debug msg stream =
+ print_endline msg;
+ return () stream
+ end
+
+ include I
+end
+
+let is_keyword s = List.mem s [ "return"; "if"; "fi"; "else"; "do"; "od" ]
+
+module Expr (P : PExt) = struct
+ open P
+ module Util = OUtil (P)
+
+ type 'a d = {
+ parse : 'a d -> (char, 'a) t;
+ primary : 'a d -> (char, 'a) t;
+ base : 'a d -> (char, 'a) t;
+ }
+
+ let parse d =
+ fix @@ fun _ ->
+ Util.expr
+ (fun x -> x)
+ (Array.map
+ (fun (a, s) ->
+ ( a,
+ List.map
+ (fun s_ ->
+ ( (lexeme s_ >>= fun _ -> return ()),
+ fun x y -> Expr.Binop (s_, x, y) ))
+ s ))
+ [|
+ (`Lefta, [ "!!" ]);
+ (`Lefta, [ "&&" ]);
+ (`Nona, [ "=="; "!="; "<="; "<"; ">="; ">" ]);
+ (`Lefta, [ "+"; "-" ]);
+ (`Lefta, [ "*"; "/"; "%" ]);
+ |])
+ (d.primary d)
+
+ let primary d =
+ fix @@ fun _ ->
+ let suffix =
+ alt
+ (lexeme "[" *> d.parse d <* lexeme "]" => fun x -> `Elem x)
+ (lexeme "." *> lexeme "length" => fun _ -> `Len)
+ in
+ d.base d >>= fun b ->
+ many suffix >>= fun is ->
+ return
+ (List.fold_left
+ (fun b -> function `Elem i -> Expr.Elem (b, i) | `Len -> Length b)
+ b is)
+
+ let ident = guard ident (fun k -> not (is_keyword k)) None
+
+ let base d =
+ fix @@ fun _ ->
+ altl
+ [
+ (spaces *> decimal => fun x -> Expr.Const x);
+ ( spaces *> string => fun s ->
+ Expr.String (String.sub s 1 (String.length s - 2)) );
+ (spaces *> char => fun c -> Expr.Const (Char.code c));
+ (lexeme "[" *> list0 (d.parse d) <* lexeme "]" => fun a -> Expr.Array a);
+ ( lexeme "`" *> ident >>= fun t ->
+ opt (lexeme "(" *> list (d.parse d) <* lexeme ")") >>= fun args ->
+ return
+ (Expr.Sexp (t, match args with None -> [] | Some args -> args)) );
+ ( ident >>= fun x ->
+ alt
+ ( lexeme "(" *> list0 (d.parse d) <* lexeme ")" => fun args ->
+ Expr.Call (x, args) )
+ (empty *> return (Expr.Var x)) );
+ parens (d.parse d);
+ ]
+
+ let d = { parse; base; primary }
+end
+
+let __ () =
+ let module E = Expr (Helpers (OpalImpl)) in
+ match Opal.parse E.(d.parse d) (Opal.LazyStream.of_string "1+2") with
+ | None -> failwith "It had to succeed"
+ | Some x ->
+ Printf.printf "%s\n" (GT.show Language.Expr.t x);
+ ()
+
+(* let () = Printf.printf "%s %d\n" __FILE__ __LINE__ *)
+
+module Stmt (P : PExt) = struct
+ open P
+ module E = Expr (P)
+
+ type 'a d = { parse : 'a d -> (char, 'a) t; stmt : 'a d -> (char, 'a) t }
+
+ let foldr1_exn f xs =
+ let rec helper = function
+ | [] -> failwith "bad argument"
+ | [ x ] -> x
+ | x :: xs -> f x (helper xs)
+ in
+
+ match xs with [] -> failwith "bad argument" | xs -> helper xs
+
+ let parse d =
+ fix @@ fun self ->
+ (* d.stmt d >>= fun h ->
+ many (lexeme ";" *> self) >>= fun ss ->
+ return
+ ( match ss with
+ | [] -> h
+ | _ -> foldr1_exn (fun s ss -> Stmt.Seq (s, ss)) (h :: ss) ) *)
+ alt
+ ( d.stmt d >>= fun s ->
+ (* debug "ask;" *> *)
+ lexeme ";" *> d.parse d >>= fun ss -> return (Stmt.Seq (s, ss)) )
+ (d.stmt d)
+
+ let ident = guard ident (fun k -> not (is_keyword k)) None
+
+ let stmt d =
+ fix @@ fun _ ->
+ altl
+ [
+ lexeme "skip" *> return Stmt.Skip;
+ ( (lexeme "if" *> E.(d.parse d)) >>= fun e ->
+ lexeme "then" *> d.parse d >>= fun the ->
+ many
+ ( (lexeme "elif" *> E.(d.parse d)) >>= fun l ->
+ lexeme "then" *> d.parse d >>= fun r -> return (l, r) )
+ >>= fun elif ->
+ opt (lexeme "else" *> d.parse d) >>= fun els ->
+ lexeme "fi" => fun _ ->
+ Stmt.If
+ ( e,
+ the,
+ List.fold_right
+ (fun (e, t) elif -> Stmt.If (e, t, elif))
+ elif
+ (match els with None -> Stmt.Skip | Some s -> s) ) );
+ ( (lexeme "while" *> E.(d.parse d)) >>= fun e ->
+ lexeme "do" *> d.parse d >>= fun s ->
+ lexeme "od" *> return (Stmt.While (e, s)) );
+ ( lexeme "for" *> d.parse d >>= fun i ->
+ (lexeme "," *> E.(d.parse d)) >>= fun c ->
+ lexeme "," *> d.parse d >>= fun s ->
+ lexeme "do" *> d.parse d >>= fun b ->
+ lexeme "od" *> return (Stmt.Seq (i, While (c, Seq (b, s)))) );
+ ( lexeme "repeat" *> d.parse d >>= fun s ->
+ (lexeme "until" *> E.(d.parse d)) >>= fun e ->
+ return (Stmt.Repeat (s, e)) );
+ ( lexeme "return" *> spaces *> opt E.(d.parse d) => fun e ->
+ Stmt.Return e );
+ ( ident >>= fun x ->
+ alt
+ ( many ((lexeme "[" *> E.(d.parse d)) <* lexeme "]") >>= fun is ->
+ (lexeme ":=" *> E.(d.parse d)) >>= fun e ->
+ return (Stmt.Assign (x, is, e)) )
+ ( parens (list0 E.(d.parse d)) >>= fun args ->
+ return (Stmt.Call (x, args)) ) );
+ ]
+
+ let d = { parse; stmt }
+
+ let parse = d.parse d
+end
+
+let __ () =
+ let module S = Stmt (Helpers (OpalImpl)) in
+ let func = S.(d.parse d) in
+
+ match
+ Opal.parse func
+ (Opal.LazyStream.of_string
+ "n := read ();\nwhile do\n\n\n skip od\n")
+ with
+ | None -> failwith "It had to succeed"
+ | Some x ->
+ Printf.printf "%s\n" (GT.show Language.Stmt.t x);
+ ()
+
+module Definition (P : PExt) = struct
+ open P
+ module S = Stmt (P)
+
+ let arg = ident
+
+ let parse =
+ lexeme "fun" *> ident >>= fun name ->
+ parens (list0 arg) >>= fun args ->
+ opt (lexeme "local" *> list arg) >>= fun locs ->
+ (lexeme "{" *> S.(d.parse d)) <* lexeme "}" >>= fun body ->
+ return (name, (args, (match locs with None -> [] | Some l -> l), body))
+end
+
+(* let () = Printf.printf "%s %d\n" __FILE__ __LINE__ *)
+
+let run_parser ~filename contents =
+ let parse =
+ let module I = Helpers (OpalImpl) in
+ let module D = Definition (I) in
+ let module S = Stmt (I) in
+ let open I in
+ many D.parse >>= fun defs ->
+ S.parse >>= fun s -> eof *> return (defs, s)
+ in
+ match Opal.parse parse (Opal.LazyStream.of_string contents) with
+ | None -> `Fail ""
+ | Some x -> `Ok x
+
+let () =
+ let module I = Helpers (OpalImpl) in
+ let open I in
+ let p = spaces *> opt decimal in
+ let s = " 1" in
+ match Opal.parse p (Opal.LazyStream.of_string s) with
+ | None ->
+ failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__)
+ | Some _ -> ()
+
+let () =
+ let module S = Stmt (Helpers (OpalImpl)) in
+ let s = "while do skip od" in
+ let s = "repeat skip until 1" in
+
+ let s = "while 1 do skip od" in
+ let s = "fun f () { if 1 then return fi; } skip" in
+ let s = "if 1 then return fi" in
+ let s = "x := 'a'; skip" in
+ (* let s = "if 'a' then skip fi" in *)
+ match run_parser ~filename:"" s with
+ | `Fail _ ->
+ failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__)
+ | `Ok (_, x) ->
+ Printf.printf "%s\n" (GT.show Language.Stmt.t x);
+ () *)
diff --git a/src/LamaLexer.mll b/src/LamaLexer.mll
new file mode 100644
index 000000000..24e344c44
--- /dev/null
+++ b/src/LamaLexer.mll
@@ -0,0 +1,113 @@
+{
+open Lexing
+open LamaMenhir
+open MenhirLexemes
+
+exception SyntaxError of string
+
+let next_line lexbuf =
+ let pos = lexbuf.lex_curr_p in
+ lexbuf.lex_curr_p <-
+ { pos with pos_bol = lexbuf.lex_curr_pos;
+ pos_lnum = pos.pos_lnum + 1
+ }
+}
+
+let int = ['0'-'9'] ['0'-'9']*
+let digit = ['0'-'9']
+let frac = '.' digit*
+let exp = ['e' 'E'] ['-' '+']? digit+
+let float = digit* frac? exp?
+
+let white = [' ' '\t']+
+let newline = '\r' | '\n' | "\r\n"
+let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']*
+
+rule read =
+ parse
+ | white { read lexbuf }
+ | newline { next_line lexbuf; read lexbuf }
+ | int { DECIMAL (int_of_string (Lexing.lexeme lexbuf) : int ) }
+ (* | float { FLOAT (float_of_string (Lexing.lexeme lexbuf)) } *)
+ | "skip" { SKIP }
+ | "return" { RETURN }
+ | "if" { IF }
+ | "then" { THEN }
+ | "else" { ELSE }
+ | "elif" { ELIF }
+ | "fi" { FI }
+ | "do" { DO }
+ | "od" { OD }
+ | "repeat" { REPEAT }
+ | "until" { UNTIL }
+ | "for" { FOR }
+ | "while" { WHILE }
+ | "fun" { FUN }
+ | "local" { LOCAL }
+ | "length" { LENGTH }
+ (* It's important that identifier goes below keywords *)
+ | id { IDENT (Lexing.lexeme lexbuf) }
+ | ":=" { ASSGN }
+ | '"' { read_string (Buffer.create 17) lexbuf }
+ | '\'' { read_char (Buffer.create 3) lexbuf }
+ | '(' { LPAREN }
+ | ')' { RPAREN }
+ | '{' { LEFT_BRACE }
+ | '}' { RIGHT_BRACE }
+ | '[' { LBRACK }
+ | ']' { RBRACK }
+ | '`' { BACKTICK }
+ | '<' { LT }
+ | '>' { GT }
+ | "<=" { LE }
+ | ">=" { GE }
+ | "!=" { NEQ }
+ | "==" { EQEQ }
+ | ';' { SEMICOLON }
+ | ',' { COMMA }
+ | '+' { PLUS }
+ | '-' { MINUS }
+ | '*' { TIMES }
+ | '/' { DIV }
+ | '%' { PERCENT }
+ | '.' { DOT }
+ | "&&" { LAND }
+ | "!!" { LOR }
+ | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf)) }
+ | eof { EOF }
+
+and read_string buf =
+ parse
+ | '"' { STRING (Buffer.contents buf) }
+ | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf }
+ | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf }
+ | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf }
+ | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf }
+ | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf }
+ | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf }
+ | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf }
+ | [^ '"' '\\']+
+ { Buffer.add_string buf (Lexing.lexeme lexbuf);
+ read_string buf lexbuf
+ }
+ | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) }
+ | eof { raise (SyntaxError ("String literal is not terminated")) }
+
+and read_char buf =
+ parse
+ | '\'' { let s = Buffer.contents buf in
+ assert(String.length s > 0);
+ CHAR s.[0]
+ }
+ | '\\' '\\' '\'' { CHAR '\\' }
+ | '\\' 'b' '\'' { CHAR '\b' }
+ (* | '\\' 'f' '\'' { CHAR '\f' } *)
+ | '\\' 'n' '\'' { CHAR '\n' }
+ | '\\' 'r' '\'' { CHAR '\r' }
+ | '\\' 't' '\'' { CHAR '\t' }
+ | [^ '\'' '\\']
+ { Buffer.add_string buf (Lexing.lexeme lexbuf);
+ read_char buf lexbuf
+ }
+ | _ { raise (SyntaxError ("Illegal char character: " ^ Lexing.lexeme lexbuf)) }
+ | eof { raise (SyntaxError ("Char literal is not terminated")) }
diff --git a/src/LamaMenhir.mly b/src/LamaMenhir.mly
new file mode 100644
index 000000000..4fa3b409a
--- /dev/null
+++ b/src/LamaMenhir.mly
@@ -0,0 +1,125 @@
+%token DECIMAL
+%token IDENT
+%token CHAR
+%token STRING
+%token PLUS MINUS TIMES DIV
+%token FUN
+%token SKIP
+%token LOCAL
+%token RETURN
+%token ASSGN LENGTH
+%token IF FI THEN ELIF ELSE
+%token DO OD FOR WHILE REPEAT UNTIL
+%token LPAREN RPAREN LEFT_BRACE RIGHT_BRACE LBRACK RBRACK
+%token GT GE LT LE EQEQ NEQ
+%token PERCENT LAND LOR
+%token SEMICOLON COMMA DOT
+%token EOF
+%start toplevel
+%%
+
+%inline plist(X):
+| xs = loption(delimited(LPAREN, separated_list(COMMA, X), RPAREN)) { xs }
+
+%inline op_mul:
+ | TIMES { "*" }
+ | DIV { "/" }
+ ;
+%inline op_add:
+ | PLUS { "+" }
+ | MINUS { "-" }
+ | PERCENT { "%" }
+ ;
+%inline op_pred:
+ | GT { ">" }
+ | GE { ">=" }
+ | LT { "<" }
+ | LE { "<=" }
+ | NEQ { "!=" }
+ | EQEQ { "==" }
+ ;
+%inline op_log:
+ | LAND { "&&" }
+ | LOR { "!!" }
+ ;
+
+expr_log:
+ | l = expr_log; op = op_log; r = expr_pred { Language.Expr.Binop (op,l,r) }
+ | e = expr_pred { e }
+ ;
+expr_pred:
+ | l = expr_pred; op = op_pred; r = expr_add { Language.Expr.Binop (op,l,r) }
+ | e = expr_add { e }
+ ;
+expr_add:
+ | l = expr_add; op = op_add; r = expr_mul { Language.Expr.Binop (op,l,r) }
+ | e = expr_mul { e }
+ ;
+expr_mul:
+ | l = expr_mul; op = op_mul; r = expr_primary { Language.Expr.Binop (op,l,r) }
+ | e = expr_primary { e }
+ ;
+expr_primary:
+ | b = expr_base; is = myindex* {
+ let open Language.Expr in
+ List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b) b is
+ }
+ ;
+%inline myindex:
+ | LBRACK; idx = expr; RBRACK { `Elem idx }
+ | DOT; LENGTH { `Len }
+ ;
+expr_base:
+ | n = DECIMAL { Language.Expr.Const n }
+ | s = STRING { Language.Expr.String s }
+ | c = CHAR { Language.Expr.Const (Char.code c) }
+ | LPAREN; e = expr_log; RPAREN { e }
+ | MINUS; e = expr_base { e (* BUG?*) }
+ | f = IDENT; LPAREN; args = separated_list(COMMA, expr); RPAREN { Language.Expr.Call (f, args) }
+ | f = IDENT { Language.Expr.Var f }
+ | LBRACK; elems = separated_list(COMMA, expr); RBRACK { Language.Expr.Array elems }
+ ;
+
+expr: e = expr_log { e };
+
+stmts: ss = separated_nonempty_list(SEMICOLON,stmt)
+ {
+ match List.rev ss with
+ | [] -> failwith "should not happen"
+ | h::tl -> List.fold_left (fun acc x -> Language.Stmt.Seq (x, acc) ) h tl
+ }
+ ;
+
+stmt:
+ | SKIP { Language.Stmt.Skip }
+ | IF; e=expr; THEN; the = stmts;
+ elif=list(ELIF; e = expr; THEN; th = stmts { (e,th) });
+ els=option(ELSE; br = stmts { br }); FI
+ {
+ let open Language.Stmt in
+ If (e, the,
+ List.fold_right
+ (fun (e, t) elif -> If (e, t, elif))
+ elif
+ (match els with None -> Skip | Some s -> s)
+ )
+ }
+ | WHILE; e=expr; DO; s = stmts; OD { Language.Stmt.While (e, s) }
+ | FOR; i=stmt; COMMA; c = expr; COMMA; s=stmt; DO; b=stmts; OD
+ { let open Language.Stmt in Seq (i, While (c, Seq (b, s))) }
+ | REPEAT; s=stmts; UNTIL; e=expr { Language.Stmt.Repeat (s, e) }
+ | RETURN; e=expr? { Return e }
+ | x = IDENT; LPAREN; args = separated_list(COMMA, expr); RPAREN { Language.Stmt.Call (x, args) }
+ | x = IDENT; is = list(LBRACK; e = expr; RBRACK { e }); ASSGN; e=expr { Language.Stmt.Assign (x, is, e) }
+ ;
+
+arg: a = IDENT { a };
+locals: LOCAL; locs = separated_list(COMMA, arg) { locs };
+definition:
+ | FUN; name = IDENT; LPAREN; args = separated_list(COMMA, arg); RPAREN;
+ locs=locals?;
+ LEFT_BRACE; body=stmts; RIGHT_BRACE;
+ { (name, (args, (match locs with None -> [] | Some l -> l), body))
+ };
+
+toplevel: defs = list(definition); last=stmts; EOF { (defs, last) };
diff --git a/src/LamaOpal.ml b/src/LamaOpal.ml
new file mode 100644
index 000000000..ff4a0dec7
--- /dev/null
+++ b/src/LamaOpal.ml
@@ -0,0 +1,313 @@
+open Language
+open GenParser
+
+module OpalImpl = struct
+ open Opal
+
+ module I = struct
+ type ('a, 'b) t = ('a, 'b) Opal.parser
+
+ let opt p =
+ option None (p => fun x -> Some x)
+
+ let guard p cond _ = p >>= fun r -> if cond r then return r else mzero
+
+ let seq = ( >>= )
+
+ let ( >>= ) = seq
+
+ let return = return
+
+ let empty : ('t, unit) t = fun s -> return () s
+
+ let many = many
+
+ let alt a b = choice [ a; b ]
+
+ let altl l = List.fold_left ( <|> ) mzero l
+
+ let map f x = x => f
+
+ let ( => ) = ( => )
+
+ let spaces =
+ skip_many (one_of [ '\t'; '\r'; '\n'; ' ' ])
+
+ let eof : (char, unit) t =
+ (spaces >>= fun _ -> eof ())
+
+ let token s stream =
+ (* Printf.printf "token '%s' asked\n" s; *)
+ token s stream
+
+ let ( *> ) f g = f >>= fun _ -> g
+
+ let ( <* ) f g =
+ f >>= fun r ->
+ g >>= fun _ -> return r
+
+ let rec fix : (('a, 'b) t -> ('a, 'b) t) -> ('a, 'b) t =
+ fun p stream -> p (fun s -> fix p s) stream
+
+ let string =
+ token "\"" *> many alpha_num <* token "\"" => fun xs ->
+ Printf.sprintf "%S" (implode xs)
+
+
+ let decimal : (char, int) t =
+ many1 digit => fun xs ->
+ List.fold_left
+ (fun acc x -> (acc * 10) + Char.code x - Char.code '0')
+ 0 xs
+
+ (* parses 'c' *)
+ let char s =
+ choice
+ [
+ Opal.token "'\n'" *> return '\n';
+ Opal.token "'\t'" *> return '\t';
+ Opal.exactly '\'' *> alpha_num <* Opal.exactly '\'';
+ ]
+ s
+
+ let ident =
+ spaces *> letter >>= fun h ->
+ many (alpha_num <|> exactly '_') >>= fun tl -> return (implode (h :: tl))
+
+ let lexeme l = spaces *> token l
+
+ let debug msg stream =
+ print_endline msg;
+ return () stream
+ end
+
+ include I
+end
+
+let is_keyword s = List.mem s [ "return"; "if"; "fi"; "else"; "do"; "od" ]
+
+module Expr (P : PExt) = struct
+ open P
+ module Util = OUtil (P)
+
+ type 'a d = {
+ parse : 'a d -> (char, 'a) t;
+ primary : 'a d -> (char, 'a) t;
+ base : 'a d -> (char, 'a) t;
+ }
+
+ let parse d =
+ fix @@ fun _ ->
+ Util.expr
+ (fun x -> x)
+ (Array.map
+ (fun (a, s) ->
+ ( a,
+ List.map
+ (fun s_ ->
+ ( (lexeme s_ >>= fun _ -> return ()),
+ fun x y -> Expr.Binop (s_, x, y) ))
+ s ))
+ [|
+ (`Lefta, [ "!!" ]);
+ (`Lefta, [ "&&" ]);
+ (`Nona, [ "=="; "!="; "<="; "<"; ">="; ">" ]);
+ (`Lefta, [ "+"; "-" ]);
+ (`Lefta, [ "*"; "/"; "%" ]);
+ |])
+ (d.primary d)
+
+ let primary d =
+ fix @@ fun _ ->
+ let suffix =
+ alt
+ (lexeme "[" *> d.parse d <* lexeme "]" => fun x -> `Elem x)
+ (lexeme "." *> lexeme "length" => fun _ -> `Len)
+ in
+ d.base d >>= fun b ->
+ many suffix >>= fun is ->
+ return
+ (List.fold_left
+ (fun b -> function `Elem i -> Expr.Elem (b, i) | `Len -> Length b)
+ b is)
+
+ let ident = guard ident (fun k -> not (is_keyword k)) None
+
+ let base d =
+ fix @@ fun _ ->
+ altl
+ [
+ (spaces *> decimal => fun x -> Expr.Const x);
+ ( spaces *> string => fun s ->
+ Expr.String (String.sub s 1 (String.length s - 2)) );
+ (spaces *> char => fun c -> Expr.Const (Char.code c));
+ (lexeme "[" *> list0 (d.parse d) <* lexeme "]" => fun a -> Expr.Array a);
+ ( lexeme "`" *> ident >>= fun t ->
+ opt (lexeme "(" *> list (d.parse d) <* lexeme ")") >>= fun args ->
+ return
+ (Expr.Sexp (t, match args with None -> [] | Some args -> args)) );
+ ( ident >>= fun x ->
+ alt
+ ( lexeme "(" *> list0 (d.parse d) <* lexeme ")" => fun args ->
+ Expr.Call (x, args) )
+ (empty *> return (Expr.Var x)) );
+ parens (d.parse d);
+ ]
+
+ let d = { parse; base; primary }
+end
+
+module Stmt (P : PExt) = struct
+ open P
+ module E = Expr (P)
+
+ type 'a d = { parse : 'a d -> (char, 'a) t; stmt : 'a d -> (char, 'a) t }
+
+ (* let foldr1_exn f xs =
+ let rec helper = function
+ | [] -> failwith "bad argument"
+ | [ x ] -> x
+ | x :: xs -> f x (helper xs)
+ in
+ match xs with [] -> failwith "bad argument" | xs -> helper xs *)
+
+ let parse d =
+ fix @@ fun self ->
+ (* d.stmt d >>= fun h ->
+ many (lexeme ";" *> self) >>= fun ss ->
+ return
+ ( match ss with
+ | [] -> h
+ | _ -> foldr1_exn (fun s ss -> Stmt.Seq (s, ss)) (h :: ss) ) *)
+ alt
+ ( d.stmt d >>= fun s ->
+ lexeme ";" *> d.parse d >>= fun ss -> return (Stmt.Seq (s, ss)) )
+ (d.stmt d)
+
+ let ident = guard ident (fun k -> not (is_keyword k)) None
+
+ let stmt d =
+ fix @@ fun _ ->
+ altl
+ [
+ lexeme "skip" *> return Stmt.Skip;
+ ( (lexeme "if" *> E.(d.parse d)) >>= fun e ->
+ lexeme "then" *> d.parse d >>= fun the ->
+ many
+ ( (lexeme "elif" *> E.(d.parse d)) >>= fun l ->
+ lexeme "then" *> d.parse d >>= fun r -> return (l, r) )
+ >>= fun elif ->
+ opt (lexeme "else" *> d.parse d) >>= fun els ->
+ lexeme "fi" => fun _ ->
+ Stmt.If
+ ( e,
+ the,
+ List.fold_right
+ (fun (e, t) elif -> Stmt.If (e, t, elif))
+ elif
+ (match els with None -> Stmt.Skip | Some s -> s) ) );
+ ( (lexeme "while" *> E.(d.parse d)) >>= fun e ->
+ lexeme "do" *> d.parse d >>= fun s ->
+ lexeme "od" *> return (Stmt.While (e, s)) );
+ ( lexeme "for" *> d.parse d >>= fun i ->
+ (lexeme "," *> E.(d.parse d)) >>= fun c ->
+ lexeme "," *> d.parse d >>= fun s ->
+ lexeme "do" *> d.parse d >>= fun b ->
+ lexeme "od" *> return (Stmt.Seq (i, While (c, Seq (b, s)))) );
+ ( lexeme "repeat" *> d.parse d >>= fun s ->
+ (lexeme "until" *> E.(d.parse d)) >>= fun e ->
+ return (Stmt.Repeat (s, e)) );
+ ( lexeme "return" *> spaces *> opt E.(d.parse d) => fun e ->
+ Stmt.Return e );
+ ( ident >>= fun x ->
+ alt
+ ( many ((lexeme "[" *> E.(d.parse d)) <* lexeme "]") >>= fun is ->
+ (lexeme ":=" *> E.(d.parse d)) >>= fun e ->
+ return (Stmt.Assign (x, is, e)) )
+ ( parens (list0 E.(d.parse d)) >>= fun args ->
+ return (Stmt.Call (x, args)) ) );
+ ]
+
+ let d = { parse; stmt }
+
+ let parse = d.parse d
+end
+
+module Definition (P : PExt) = struct
+ open P
+ module S = Stmt (P)
+
+ let arg = ident
+
+ let parse =
+ lexeme "fun" *> ident >>= fun name ->
+ parens (list0 arg) >>= fun args ->
+ opt (lexeme "local" *> list arg) >>= fun locs ->
+ (lexeme "{" *> S.(d.parse d)) <* lexeme "}" >>= fun body ->
+ return (name, (args, (match locs with None -> [] | Some l -> l), body))
+end
+
+let run_parser ~filename contents =
+ let parse =
+ let module I = Helpers (OpalImpl) in
+ let module D = Definition (I) in
+ let module S = Stmt (I) in
+ let open I in
+ many D.parse >>= fun defs ->
+ S.parse >>= fun s -> eof *> return (defs, s)
+ in
+ match Opal.parse parse (Opal.LazyStream.of_string contents) with
+ | None -> `Fail ""
+ | Some x -> `Ok x
+
+
+(* **************** Tests ********************************* *)
+let __ () =
+ let module S = Stmt (Helpers (OpalImpl)) in
+ let func = S.(d.parse d) in
+
+ match
+ Opal.parse func
+ (Opal.LazyStream.of_string
+ "n := read ();\nwhile do\n\n\n skip od\n")
+ with
+ | None -> failwith "It had to succeed"
+ | Some x ->
+ Printf.printf "%s\n" (GT.show Language.Stmt.t x);
+ ()
+
+
+let __ () =
+ let module E = Expr (Helpers (OpalImpl)) in
+ match Opal.parse E.(d.parse d) (Opal.LazyStream.of_string "1+2") with
+ | None -> failwith "It had to succeed"
+ | Some x ->
+ Printf.printf "%s\n" (GT.show Language.Expr.t x);
+ ()
+
+let () =
+ let module I = Helpers (OpalImpl) in
+ let open I in
+ let p = spaces *> opt decimal in
+ let s = " 1" in
+ match Opal.parse p (Opal.LazyStream.of_string s) with
+ | None ->
+ failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__)
+ | Some _ -> ()
+
+let __ () =
+ let module S = Stmt (Helpers (OpalImpl)) in
+ (* let s = "while do skip od" in
+ let s = "repeat skip until 1" in
+
+ let s = "while 1 do skip od" in
+ let s = "fun f () { if 1 then return fi; } skip" in
+ let s = "if 1 then return fi" in *)
+ let s = "x := 'a'; skip" in
+ (* let s = "if 'a' then skip fi" in *)
+ match run_parser ~filename:"" s with
+ | `Fail _ ->
+ failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__)
+ | `Ok (_, x) ->
+ Printf.printf "%s\n" (GT.show Language.Stmt.t x);
+ ()
diff --git a/src/LamaOstapNoErrors.ml b/src/LamaOstapNoErrors.ml
new file mode 100644
index 000000000..0c08487c2
--- /dev/null
+++ b/src/LamaOstapNoErrors.ml
@@ -0,0 +1,347 @@
+open Language
+open GenParser
+
+module OstapImpl = struct
+ open Ostap
+ open Ostap.Combinators
+
+ module I = struct
+ type ('a, 'b) t = ('a, unit, 'b) Ostap.Types.parse
+
+ let map = map
+
+ let ( => ) x f = map f x
+
+ let ( >>= ) = seq
+
+ let seq = ( >>= )
+
+ let return x = empty => fun () -> x
+
+ let opt p =
+ (* print_endline "opt asked";
+ ( (p => fun x -> Some x) <|> fun s ->
+ print_endline "returnig none";
+ return None s )
+ s *)
+ opt p
+
+ (* let guard p cond _ = p >>= fun r -> if cond r then return r else mzero *)
+ let guard = guard
+
+ let empty : ('t, unit) t = fun s -> return () s
+
+ let many = many
+
+ let alt a b = alt a b
+
+ let altl l = List.fold_left ( <|> ) (fail None) l
+
+ let spaces stream = skip_many (one_of [ '\t'; '\r'; '\n'; ' ' ]) stream
+
+ let eof : (char, unit) t = fun stream -> (spaces >>= fun _ -> eof ()) stream
+
+ let token s stream =
+ (* Printf.printf "token '%s' asked\n" s; *)
+ token s stream
+
+ let ( *> ) f g = f >>= fun _ -> g
+
+ let ( <* ) f g =
+ f >>= fun r ->
+ g >>= fun _ -> return r
+
+ let rec fix : (('a, 'b) t -> ('a, 'b) t) -> ('a, 'b) t =
+ fun p stream -> p (fun s -> fix p s) stream
+
+ let string s =
+ (* let () = print_endline "string called" in *)
+ ( token "\"" *> many alpha_num <* token "\"" => fun xs ->
+ Printf.sprintf "%S" (implode xs) )
+ s
+
+ let decimal : (char, int) t =
+ fun stream ->
+ (* let () =
+ print_endline "decimal called";
+ Printf.printf "decimal asked when stream %s empty: %s \n"
+ (if stream = LazyStream.Nil then "IS" else "IS NOT")
+ ( match stream with
+ | LazyStream.Cons (c, t) ->
+ Printf.sprintf "('%c'=%d) :: ???" c (Char.code c)
+ | Nil -> "[]" )
+ in *)
+ ( many1 digit => fun xs ->
+ List.fold_left
+ (fun acc x -> (acc * 10) + Char.code x - Char.code '0')
+ 0 xs )
+ stream
+
+ (* parses 'c' *)
+ let char s =
+ let () =
+ (* print_endline "char called";
+ Printf.printf "decimal asked when stream %s empty: %s \n"
+ (if s = LazyStream.Nil then "IS" else "IS NOT")
+ ( match s with
+ | LazyStream.Cons (c, t) ->
+ Printf.sprintf "('%c'=%d) :: ???" c (Char.code c)
+ | Nil -> "[]" ); *)
+ ()
+ in
+
+ choice
+ [
+ Opal.token "'\n'" *> return '\n';
+ Opal.token "'\t'" *> return '\t';
+ Opal.exactly '\'' *> alpha_num <* Opal.exactly '\'';
+ ]
+ s
+
+ let ident =
+ spaces *> letter >>= fun h ->
+ many (alpha_num <|> exactly '_') >>= fun tl -> return (implode (h :: tl))
+
+ let lexeme l =
+ spaces *> token l => fun x ->
+ (* Printf.printf "lexeme %s eaten\n" x; *)
+ x
+
+ let debug msg stream =
+ print_endline msg;
+ return () stream
+ end
+
+ include I
+end
+
+let is_keyword s = List.mem s [ "return"; "if"; "fi"; "else"; "do"; "od" ]
+
+module Expr (P : PExt) = struct
+ open P
+ module Util = OUtil (P)
+
+ type 'a d = {
+ parse : 'a d -> (char, 'a) t;
+ primary : 'a d -> (char, 'a) t;
+ base : 'a d -> (char, 'a) t;
+ }
+
+ let parse d =
+ fix @@ fun _ ->
+ Util.expr
+ (fun x -> x)
+ (Array.map
+ (fun (a, s) ->
+ ( a,
+ List.map
+ (fun s_ ->
+ ( (lexeme s_ >>= fun _ -> return ()),
+ fun x y -> Expr.Binop (s_, x, y) ))
+ s ))
+ [|
+ (`Lefta, [ "!!" ]);
+ (`Lefta, [ "&&" ]);
+ (`Nona, [ "=="; "!="; "<="; "<"; ">="; ">" ]);
+ (`Lefta, [ "+"; "-" ]);
+ (`Lefta, [ "*"; "/"; "%" ]);
+ |])
+ (d.primary d)
+
+ let primary d =
+ fix @@ fun _ ->
+ let suffix =
+ alt
+ (lexeme "[" *> d.parse d <* lexeme "]" => fun x -> `Elem x)
+ (lexeme "." *> lexeme "length" => fun _ -> `Len)
+ in
+ d.base d >>= fun b ->
+ many suffix >>= fun is ->
+ return
+ (List.fold_left
+ (fun b -> function `Elem i -> Expr.Elem (b, i) | `Len -> Length b)
+ b is)
+
+ let ident = guard ident (fun k -> not (is_keyword k)) None
+
+ let base d =
+ fix @@ fun _ ->
+ altl
+ [
+ (spaces *> decimal => fun x -> Expr.Const x);
+ ( spaces *> string => fun s ->
+ Expr.String (String.sub s 1 (String.length s - 2)) );
+ (spaces *> char => fun c -> Expr.Const (Char.code c));
+ (lexeme "[" *> list0 (d.parse d) <* lexeme "]" => fun a -> Expr.Array a);
+ ( lexeme "`" *> ident >>= fun t ->
+ opt (lexeme "(" *> list (d.parse d) <* lexeme ")") >>= fun args ->
+ return
+ (Expr.Sexp (t, match args with None -> [] | Some args -> args)) );
+ ( ident >>= fun x ->
+ alt
+ ( lexeme "(" *> list0 (d.parse d) <* lexeme ")" => fun args ->
+ Expr.Call (x, args) )
+ (empty *> return (Expr.Var x)) );
+ parens (d.parse d);
+ ]
+
+ let d = { parse; base; primary }
+end
+
+let __ () =
+ let module E = Expr (Helpers (OpalImpl)) in
+ match Opal.parse E.(d.parse d) (Opal.LazyStream.of_string "1+2") with
+ | None -> failwith "It had to succeed"
+ | Some x ->
+ Printf.printf "%s\n" (GT.show Language.Expr.t x);
+ ()
+
+(* let () = Printf.printf "%s %d\n" __FILE__ __LINE__ *)
+
+module Stmt (P : PExt) = struct
+ open P
+ module E = Expr (P)
+
+ type 'a d = { parse : 'a d -> (char, 'a) t; stmt : 'a d -> (char, 'a) t }
+
+ let foldr1_exn f xs =
+ let rec helper = function
+ | [] -> failwith "bad argument"
+ | [ x ] -> x
+ | x :: xs -> f x (helper xs)
+ in
+
+ match xs with [] -> failwith "bad argument" | xs -> helper xs
+
+ let parse d =
+ fix @@ fun self ->
+ (* d.stmt d >>= fun h ->
+ many (lexeme ";" *> self) >>= fun ss ->
+ return
+ ( match ss with
+ | [] -> h
+ | _ -> foldr1_exn (fun s ss -> Stmt.Seq (s, ss)) (h :: ss) ) *)
+ alt
+ ( d.stmt d >>= fun s ->
+ (* debug "ask;" *> *)
+ lexeme ";" *> d.parse d >>= fun ss -> return (Stmt.Seq (s, ss)) )
+ (d.stmt d)
+
+ let ident = guard ident (fun k -> not (is_keyword k)) None
+
+ let stmt d =
+ fix @@ fun _ ->
+ altl
+ [
+ lexeme "skip" *> return Stmt.Skip;
+ ( (lexeme "if" *> E.(d.parse d)) >>= fun e ->
+ lexeme "then" *> d.parse d >>= fun the ->
+ many
+ ( (lexeme "elif" *> E.(d.parse d)) >>= fun l ->
+ lexeme "then" *> d.parse d >>= fun r -> return (l, r) )
+ >>= fun elif ->
+ opt (lexeme "else" *> d.parse d) >>= fun els ->
+ lexeme "fi" => fun _ ->
+ Stmt.If
+ ( e,
+ the,
+ List.fold_right
+ (fun (e, t) elif -> Stmt.If (e, t, elif))
+ elif
+ (match els with None -> Stmt.Skip | Some s -> s) ) );
+ ( (lexeme "while" *> E.(d.parse d)) >>= fun e ->
+ lexeme "do" *> d.parse d >>= fun s ->
+ lexeme "od" *> return (Stmt.While (e, s)) );
+ ( lexeme "for" *> d.parse d >>= fun i ->
+ (lexeme "," *> E.(d.parse d)) >>= fun c ->
+ lexeme "," *> d.parse d >>= fun s ->
+ lexeme "do" *> d.parse d >>= fun b ->
+ lexeme "od" *> return (Stmt.Seq (i, While (c, Seq (b, s)))) );
+ ( lexeme "repeat" *> d.parse d >>= fun s ->
+ (lexeme "until" *> E.(d.parse d)) >>= fun e ->
+ return (Stmt.Repeat (s, e)) );
+ ( lexeme "return" *> spaces *> opt E.(d.parse d) => fun e ->
+ Stmt.Return e );
+ ( ident >>= fun x ->
+ alt
+ ( many ((lexeme "[" *> E.(d.parse d)) <* lexeme "]") >>= fun is ->
+ (lexeme ":=" *> E.(d.parse d)) >>= fun e ->
+ return (Stmt.Assign (x, is, e)) )
+ ( parens (list0 E.(d.parse d)) >>= fun args ->
+ return (Stmt.Call (x, args)) ) );
+ ]
+
+ let d = { parse; stmt }
+
+ let parse = d.parse d
+end
+
+let __ () =
+ let module S = Stmt (Helpers (OpalImpl)) in
+ let func = S.(d.parse d) in
+
+ match
+ Opal.parse func
+ (Opal.LazyStream.of_string
+ "n := read ();\nwhile do\n\n\n skip od\n")
+ with
+ | None -> failwith "It had to succeed"
+ | Some x ->
+ Printf.printf "%s\n" (GT.show Language.Stmt.t x);
+ ()
+
+module Definition (P : PExt) = struct
+ open P
+ module S = Stmt (P)
+
+ let arg = ident
+
+ let parse =
+ lexeme "fun" *> ident >>= fun name ->
+ parens (list0 arg) >>= fun args ->
+ opt (lexeme "local" *> list arg) >>= fun locs ->
+ (lexeme "{" *> S.(d.parse d)) <* lexeme "}" >>= fun body ->
+ return (name, (args, (match locs with None -> [] | Some l -> l), body))
+end
+
+(* let () = Printf.printf "%s %d\n" __FILE__ __LINE__ *)
+
+let run_parser ~filename contents =
+ let parse =
+ let module I = Helpers (OpalImpl) in
+ let module D = Definition (I) in
+ let module S = Stmt (I) in
+ let open I in
+ many D.parse >>= fun defs ->
+ S.parse >>= fun s -> eof *> return (defs, s)
+ in
+ match Opal.parse parse (Opal.LazyStream.of_string contents) with
+ | None -> `Fail ""
+ | Some x -> `Ok x
+
+let () =
+ let module I = Helpers (OpalImpl) in
+ let open I in
+ let p = spaces *> opt decimal in
+ let s = " 1" in
+ match Opal.parse p (Opal.LazyStream.of_string s) with
+ | None ->
+ failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__)
+ | Some _ -> ()
+
+let () =
+ let module S = Stmt (Helpers (OpalImpl)) in
+ let s = "while do skip od" in
+ let s = "repeat skip until 1" in
+
+ let s = "while 1 do skip od" in
+ let s = "fun f () { if 1 then return fi; } skip" in
+ let s = "if 1 then return fi" in
+ let s = "x := 'a'; skip" in
+ (* let s = "if 'a' then skip fi" in *)
+ match run_parser ~filename:"" s with
+ | `Fail _ ->
+ failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__)
+ | `Ok (_, x) ->
+ Printf.printf "%s\n" (GT.show Language.Stmt.t x);
+ ()
diff --git a/src/LamaOstapP5.ml b/src/LamaOstapP5.ml
new file mode 100644
index 000000000..c3bad0c8e
--- /dev/null
+++ b/src/LamaOstapP5.ml
@@ -0,0 +1,105 @@
+open Ostap
+open Ostap.Combinators
+
+module Expr = struct
+ open Language.Expr
+
+ ostap (
+ parse:
+ !(Ostap.Util.expr
+ (fun x -> x)
+ (Array.map (fun (a, s) -> a,
+ List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s
+ )
+ [|
+ `Lefta, ["!!"];
+ `Lefta, ["&&"];
+ `Nona , ["=="; "!="; "<="; "<"; ">="; ">"];
+ `Lefta, ["+" ; "-"];
+ `Lefta, ["*" ; "/"; "%"];
+ |])
+ primary);
+ primary:
+ b:base is:(-"[" i:parse -"]" {`Elem i}
+ | "." %"length" {`Len}) *
+ {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b) b is };
+ base:
+ n:DECIMAL {Const n}
+ | s:STRING {String (String.sub s 1 (String.length s - 2))}
+ | c:CHAR {Const (Char.code c)}
+ | "[" es:!(Util.list0)[parse] "]" {Array es}
+ | "`" t:IDENT args:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match args with None -> [] | Some args -> args)}
+ | x:IDENT s:("(" args:!(Util.list0)[parse] ")" {Call (x, args)}
+ | empty {Var x})
+ {s}
+ | -"(" parse -")"
+ )
+end
+
+module Stmt = struct
+ open Language.Stmt
+
+ ostap (
+ parse:
+ s:stmt ";" ss:parse {Seq (s, ss)}
+ | stmt;
+
+ stmt:
+ %"skip" {Skip}
+ | %"if" e:!(Expr.parse)
+ %"then" the:parse
+ elif:(%"elif" !(Expr.parse) %"then" parse)*
+ els:(%"else" parse)?
+ %"fi" {
+ If (e, the,
+ List.fold_right
+ (fun (e, t) elif -> If (e, t, elif))
+ elif
+ (match els with None -> Skip | Some s -> s)
+ )
+ }
+ | %"while" e:!(Expr.parse) %"do" s:parse %"od"{While (e, s)}
+ | %"for" i:parse "," c:!(Expr.parse) "," s:parse %"do" b:parse %"od" {
+ Seq (i, While (c, Seq (b, s)))
+ }
+ | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)}
+ | %"return" e:!(Expr.parse)?
+ {Return e}
+
+ | x:IDENT
+ s: (is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)}
+ | "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)}
+ ) {s}
+ )
+
+end
+
+module Definition = struct
+ ostap (
+ arg : IDENT;
+ parse: %"fun" name:IDENT "(" args:!(Util.list0 arg) ")"
+ locs:(%"local" !(Util.list arg))?
+ "{" body:!(Stmt.parse) "}" {
+ (name, (args, (match locs with None -> [] | Some l -> l), body))
+ }
+ )
+end
+
+(* Top-level parser *)
+let parse = ostap (!(Definition.parse)* !(Stmt.parse))
+
+let run_parser s =
+ Ostap.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.ident ["skip"; "if"; "then"; "else"; "elif"; "fi"; "while"; "do"; "od"; "repeat"; "until"; "for"; "fun"; "local"; "return"; "length"] s
+ inherit Util.Lexers.skip [
+ Matcher.Skip.whitespaces " \t\n";
+ Matcher.Skip.lineComment "--";
+ Matcher.Skip.nestedComment "(*" "*)"
+ ] s
+ end)
+ (ostap (!(parse) -EOF))
diff --git a/src/Language.ml b/src/Language.ml
index d58acef54..12df14653 100644
--- a/src/Language.ml
+++ b/src/Language.ml
@@ -13,12 +13,12 @@ module Value =
@type t = Int of int | String of string | Array of t list | Sexp of string * t list with show
- let to_int = function
- | Int n -> n
+ let to_int = function
+ | Int n -> n
| _ -> failwith "int value expected"
- let to_string = function
- | String s -> s
+ let to_string = function
+ | String s -> s
| _ -> failwith "string value expected"
let to_array = function
@@ -37,11 +37,11 @@ module Value =
let update_array a i x = List.init (List.length a) (fun j -> if j = i then x else List.nth a j)
end
-
+
(* States *)
module State =
struct
-
+
(* State: global state, local state, scope variables *)
type t = {g : string -> Value.t; l : string -> Value.t; scope : string list}
@@ -50,7 +50,7 @@ module State =
let e x = failwith (Printf.sprintf "Undefined variable: %s" x) in
{g = e; l = e; scope = []}
- (* Update: non-destructively "modifies" the state s by binding the variable x
+ (* 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 =
@@ -81,20 +81,20 @@ module Builtin =
| Value.String s -> Value.of_int @@ Char.code s.[i]
| Value.Array a -> List.nth a i
)
- )
+ )
| "$length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s)))
| "$array" -> (st, i, o, Some (Value.of_array args))
| "isArray" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array _ -> 1 | _ -> 0))
- | "isString" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.String _ -> 1 | _ -> 0))
-
+ | "isString" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.String _ -> 1 | _ -> 0))
+
end
-
+
(* Simple expressions: syntax and semantics *)
module Expr =
struct
-
- (* The type for expressions. Note, in regular OCaml there is no "@type..."
- notation, it came from GT.
+
+ (* The type for expressions. Note, in regular OCaml there is no "@type..."
+ notation, it came from GT.
*)
@type t =
(* integer constant *) | Const of int
@@ -104,7 +104,7 @@ module Expr =
(* variable *) | Var of string
(* binary operator *) | Binop of string * t * t
(* element extraction *) | Elem of t * t
- (* length *) | Length of t
+ (* length *) | Length of t
(* function call *) | Call of string * t list with show
(* Available binary operators:
@@ -117,20 +117,20 @@ module Expr =
(* The type of configuration: a state, an input stream, an output stream, an optional value *)
type config = State.t * int list * int list * Value.t option
-
+
(* Expression evaluator
val eval : env -> config -> t -> int * config
- Takes an environment, a configuration and an expresion, and returns another configuration. The
+ Takes an environment, a configuration and an expresion, and returns another configuration. The
environment supplies the following method
method definition : env -> string -> int list -> config -> config
- which takes an environment (of the same type), a name of the function, a list of actual parameters and a configuration,
+ which takes an environment (of the same type), a name of the function, a list of actual parameters and a configuration,
an returns a pair: the return value for the call and the resulting configuration
- *)
+ *)
let to_func op =
let bti = function true -> 1 | _ -> 0 in
let itb b = b <> 0 in
@@ -149,8 +149,8 @@ module Expr =
| "!=" -> bti |> (<>)
| "&&" -> fun x y -> bti (itb x && itb y)
| "!!" -> fun x y -> bti (itb x || itb y)
- | _ -> failwith (Printf.sprintf "Unknown binary operator %s" op)
-
+ | _ -> failwith (Printf.sprintf "Unknown binary operator %s" op)
+
let rec eval env ((st, i, o, r) as conf) expr =
match expr with
| Const n -> (st, i, o, Some (Value.of_int n))
@@ -158,7 +158,7 @@ module Expr =
| Var x -> (st, i, o, Some (State.eval st x))
| Array xs ->
let (st, i, o, vs) = eval_list env conf xs in
- env#definition env "$array" vs (st, i, o, None)
+ env#definition env "$array" vs (st, i, o, None)
| Sexp (t, xs) ->
let (st, i, o, vs) = eval_list env conf xs in
(st, i, o, Some (Value.Sexp (t, vs)))
@@ -166,12 +166,12 @@ module Expr =
let (_, _, _, Some x) as conf = eval env conf x in
let (st, i, o, Some y) as conf = eval env conf y in
(st, i, o, Some (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)))
- | Elem (b, i) ->
+ | Elem (b, i) ->
let (st, i, o, args) = eval_list env conf [b; i] in
- env#definition env "$elem" args (st, i, o, None)
+ env#definition env "$elem" args (st, i, o, None)
| Length e ->
let (st, i, o, Some v) = eval env conf e in
- env#definition env "$length" [v] (st, i, o, None)
+ env#definition env "$length" [v] (st, i, o, None)
| Call (f, args) ->
let (st, i, o, args) = eval_list env conf args in
env#definition env f args (st, i, o, None)
@@ -186,77 +186,45 @@ module Expr =
xs
in
(st, i, o, List.rev vs)
-
- (* Expression parser. You can use the following terminals:
- IDENT --- a non-empty identifier a-zA-Z[a-zA-Z0-9_]* as a string
- DECIMAL --- a decimal constant [0-9]+ as a string
- *)
- ostap (
- parse:
- !(Ostap.Util.expr
- (fun x -> x)
- (Array.map (fun (a, s) -> a,
- List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s
- )
- [|
- `Lefta, ["!!"];
- `Lefta, ["&&"];
- `Nona , ["=="; "!="; "<="; "<"; ">="; ">"];
- `Lefta, ["+" ; "-"];
- `Lefta, ["*" ; "/"; "%"];
- |]
- )
- primary);
- primary: b:base is:(-"[" i:parse -"]" {`Elem i} | "." %"length" {`Len}) *
- {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b) b is};
- base:
- n:DECIMAL {Const n}
- | s:STRING {String (String.sub s 1 (String.length s - 2))}
- | c:CHAR {Const (Char.code c)}
- | "[" es:!(Util.list0)[parse] "]" {Array es}
- | "`" t:IDENT args:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match args with None -> [] | Some args -> args)}
- | x:IDENT s:("(" args:!(Util.list0)[parse] ")" {Call (x, args)} | empty {Var x}) {s}
- | -"(" parse -")"
- )
-
+
end
-
+
(* Simple statements: syntax and sematics *)
module Stmt =
struct
(* The type for statements *)
- type t =
+ @type t =
(* assignment *) | Assign of string * Expr.t list * Expr.t
- (* composition *) | Seq of t * t
+ (* composition *) | Seq of t * t
(* empty statement *) | Skip
(* conditional *) | If of Expr.t * t * t
(* loop with a pre-condition *) | While of Expr.t * t
(* loop with a post-condition *) | Repeat of t * Expr.t
(* return statement *) | Return of Expr.t option
- (* call a procedure *) | Call of string * Expr.t list
-
+ (* call a procedure *) | Call of string * Expr.t list with show
+
(* Statement evaluator
val eval : env -> config -> t -> config
- Takes an environment, a configuration and a statement, and returns another configuration. The
+ Takes an environment, a configuration and a statement, and returns another configuration. The
environment is the same as for expressions
*)
let update st x v is =
let rec update a v = function
- | [] -> v
+ | [] -> v
| i::tl ->
let i = Value.to_int i in
(match a with
| Value.String s when tl = [] -> Value.String (Value.update_string s i (Char.chr @@ Value.to_int v))
| Value.Array a -> Value.Array (Value.update_array a i (update (List.nth a i) v tl))
- )
+ )
in
State.update x (match is with [] -> v | _ -> update (State.eval st x) v is) st
-
+
let rec eval env ((st, i, o, r) as conf) k stmt =
let seq x = function Skip -> x | y -> Seq (x, y) in
match stmt with
@@ -264,10 +232,10 @@ module Stmt =
let (st, i, o, is) = Expr.eval_list env conf is in
let (st, i, o, Some v) = Expr.eval env (st, i, o, None) e in
eval env (update st x v is, i, o, None) Skip k
-
+
| Seq (s1, s2) -> eval env conf (seq s2 k) s1
| Skip -> (match k with Skip -> conf | _ -> eval env conf Skip k)
- | If (e, s1, s2) -> let (_, _, _, Some v) as conf = Expr.eval env conf e in eval env conf k (if Value.to_int v <> 0 then s1 else s2)
+ | If (e, s1, s2) -> let (_, _, _, Some v) as conf = Expr.eval env conf e in eval env conf k (if Value.to_int v <> 0 then s1 else s2)
| While (e, s) -> let (_, _, _, Some v) as conf = Expr.eval env conf e in
if Value.to_int v = 0
then eval env conf Skip k
@@ -275,62 +243,22 @@ module Stmt =
| Repeat (s, e) -> eval env conf (seq (While (Expr.Binop ("==", e, Expr.Const 0), s)) k) s
| Return e -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e)
| Call (f, args) -> eval env (Expr.eval env conf (Expr.Call (f, args))) k Skip
-
- (* Statement parser *)
- ostap (
- parse:
- s:stmt ";" ss:parse {Seq (s, ss)}
- | stmt;
- stmt:
- %"skip" {Skip}
- | %"if" e:!(Expr.parse)
- %"then" the:parse
- elif:(%"elif" !(Expr.parse) %"then" parse)*
- els:(%"else" parse)?
- %"fi" {
- If (e, the,
- List.fold_right
- (fun (e, t) elif -> If (e, t, elif))
- elif
- (match els with None -> Skip | Some s -> s)
- )
- }
- | %"while" e:!(Expr.parse) %"do" s:parse %"od"{While (e, s)}
- | %"for" i:parse "," c:!(Expr.parse) "," s:parse %"do" b:parse %"od" {
- Seq (i, While (c, Seq (b, s)))
- }
- | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)}
- | %"return" e:!(Expr.parse)? {Return e}
- | x:IDENT
- s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} |
- "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)}
- ) {s}
- )
-
+
+
end
(* Function and procedure definitions *)
module Definition =
struct
-
(* The type for a definition: name, argument list, local variables, body *)
- type t = string * (string list * string list * Stmt.t)
-
- ostap (
- arg : IDENT;
- parse: %"fun" name:IDENT "(" args:!(Util.list0 arg) ")"
- locs:(%"local" !(Util.list arg))?
- "{" body:!(Stmt.parse) "}" {
- (name, (args, (match locs with None -> [] | Some l -> l), body))
- }
- )
+ @type t = string * (string list * string list * Stmt.t) with show
end
-
+
(* The top-level definitions *)
(* The top-level syntax category is a pair of definition list and statement (program body) *)
-type t = Definition.t list * Stmt.t
+type t = Definition.t list * Stmt.t
(* Top-level evaluator
@@ -339,8 +267,9 @@ type t = Definition.t list * Stmt.t
Takes a program and its input stream, and returns the output stream
*)
let eval (defs, body) i =
+ (* Format.printf "Eval: %s %d\n%!" __FILE__ __LINE__; *)
let module M = Map.Make (String) in
- let m = List.fold_left (fun m ((name, _) as def) -> M.add name def m) M.empty defs in
+ let m = List.fold_left (fun m ((name, _) as def) -> M.add name def m) M.empty defs in
let _, _, o, _ =
Stmt.eval
(object
@@ -357,6 +286,3 @@ let eval (defs, body) i =
body
in
o
-
-(* Top-level parser *)
-let parse = ostap (!(Definition.parse)* !(Stmt.parse))
diff --git a/src/Makefile b/src/Makefile
index 8eb66bcfd..8b64b5db5 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,29 +1,59 @@
+.PHONY: celan
+
TOPFILE = rc
-OCAMLC = ocamlc
-OCAMLOPT = ocamlopt
-OCAMLDEP = ocamldep
-SOURCES = Language.ml SM.ml X86.ml Driver.ml
-LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma
-CAMLP5 = -pp "camlp5o -I `ocamlfind -query GT.syntax` -I `ocamlfind -query ostap.syntax` pa_ostap.cmo pa_gt.cmo -L `ocamlfind -query GT.syntax`"
-PXFLAGS = $(CAMLP5)
-BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap`
+BENCH_FILE = bench.exe
+OCAMLC = ocamlfind c
+OCAMLOPT = ocamlfind opt
+OCAMLDEP = ocamlfind dep
+SOURCES_HEAD = MenhirLexemes.ml Language.ml LamaOstapP5.ml
+SOURCES_GENERATED = LamaMenhir.ml LamaLexer.ml
+SOURCES_TAIL = RunMenhir.ml SM.ml X86.ml
+SOURCES = $(SOURCES_HEAD) $(SOURCES_GENERATED) $(SOURCES_TAIL)
+COMPILE_OBJS_CMO := $(SOURCES_HEAD:.ml=.cmo) LamaMenhir.cmo LamaLexer.cmo $(SOURCES_TAIL:.ml=.cmo)
+COMPILE_OBJS_CMX := $(SOURCES:.ml=.cmx) LamaMenhir.cmx LamaLexer.cmx $(SOURCES_TAIL:.ml=.cmx)
+LIBS =
+OCAMLFIND_PACKAGES=-package GT.syntax.all,ostap.syntax
+CAMLP5 = -syntax camlp5o $(OCAMLFIND_PACKAGES)
+#PXFLAGS = $(CAMLP5)
+BFLAGS = -rectypes -package GT,re,ostap,benchmark,angstrom,opal -linkpkg -w -13-58 -g
OFLAGS = $(BFLAGS)
+MENHIR_FLAGS = --external-tokens MenhirLexemes --explain
+#MENHIR_FLAGS += --trace
+
+all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt $(BENCH_FILE)
-all: .depend $(TOPFILE).opt
+#depend: $(SOURCES)
+# $(OCAMLDEP) $(PXFLAGS) *.ml *.mli > .depend
-.depend: $(SOURCES)
- $(OCAMLDEP) $(PXFLAGS) *.ml > .depend
+$(TOPFILE).opt: $(COMPILE_OBJS_CMX) Driver.cmx
+ $(OCAMLOPT) -o $@ $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) Driver.cmx
-$(TOPFILE).opt: $(SOURCES:.ml=.cmx)
- $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx)
+$(BENCH_FILE): $(COMPILE_OBJS_CMX) GenParser.cmx LamaOpal.cmx bench.cmx
+ $(OCAMLOPT) -o $@ $(BFLAGS) $(OCAMLFIND_PACKAGES) -package str $(OFLAGS) $^
-$(TOPFILE).byte: $(SOURCES:.ml=.cmo)
- $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo)
+celan: clean
clean:
- rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend
+ $(RM) -R *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend LamaMenhir.ml LamaMenhir.mli LamaLexer.ml
-include .depend
+
+%.ml: %.mll
+ ocamllex $<
+
+SM.cmx Language.cmx LamaOstapP5.cmx: PXFLAGS += $(CAMLP5)
+#LamaMenhir.cmo: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmo
+LamaMenhir.cmx: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmx MenhirLexemes.cmi MenhirLexemes.cmo
+RunMenhir.cmx LamaLexer.cmx: LamaMenhir.cmx Language.cmi
+LamaOpal.cmx LamaAngstrom.cmx: Language.cmi GenParser.cmi
+X86.cmx SM.cmx: Language.cmi
+Driver.cmx: LamaMenhir.cmx LamaLexer.cmx
+bench.cmx: LamaOpal.cmx LamaOstapP5.cmx LamaMenhir.cmx
+
+LamaMenhir.ml: LamaMenhir.mly
+ menhir $(MENHIR_FLAGS) $<
+ $(RM) LamaMenhir.mli
+
# generic rules
###############
@@ -43,3 +73,4 @@ clean:
%.cmx: %.ml
$(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $<
+-include `ocamlc -where`/Makefile.config
diff --git a/src/MenhirLexemes.ml b/src/MenhirLexemes.ml
new file mode 100644
index 000000000..fa05a5ba9
--- /dev/null
+++ b/src/MenhirLexemes.ml
@@ -0,0 +1,28 @@
+type token =
+| STRING of string
+| IDENT of string
+| DECIMAL of int
+| CHAR of char
+| INT of int
+| FLOAT of float
+| ID of string
+| LBRACK
+| RBRACK
+| LEFT_BRACE
+| RIGHT_BRACE
+| LPAREN | RPAREN
+| WHILE | DO | OD | FOR | REPEAT | UNTIL | RETURN
+| IF | THEN | ELIF | ELSE | FI
+| COMMA | MINUS | PLUS | TIMES | DIV
+| LT | LE | GT | GE | NEQ | EQEQ
+| PERCENT | LAND | LOR
+| ASSGN
+| LOCAL
+| LENGTH
+| DOT
+| FUN
+| SKIP
+| SEMICOLON
+| COLON
+| BACKTICK
+| EOF
diff --git a/src/RunMenhir.ml b/src/RunMenhir.ml
new file mode 100644
index 000000000..3aab987d2
--- /dev/null
+++ b/src/RunMenhir.ml
@@ -0,0 +1,21 @@
+type parse_result =
+ [ `Fail of string
+ | `Ok of
+ (string * (string list * string list * Language.Stmt.t)) list *
+ Language.Stmt.t ]
+
+let print_position outx lexbuf =
+ let open Lexing in
+ let pos = lexbuf.lex_curr_p in
+ Format.fprintf outx "%s:%d:%d" pos.pos_fname
+ pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1)
+
+let run_parser ~filename contents =
+ let lexbuf = Lexing.from_string contents in
+ let () = lexbuf.Lexing.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename } in
+ try `Ok (LamaMenhir.toplevel LamaLexer.read lexbuf)
+ with
+ | LamaLexer.SyntaxError msg ->
+ `Fail (Format.asprintf "%a: %s\n" print_position lexbuf msg)
+ | LamaMenhir.Error ->
+ `Fail (Format.asprintf "%a: syntax error\n" print_position lexbuf)
diff --git a/src/bench.ml b/src/bench.ml
new file mode 100644
index 000000000..b0570200f
--- /dev/null
+++ b/src/bench.ml
@@ -0,0 +1,101 @@
+(* How many repetitions should be performed *)
+let repeat = 1
+
+(* How much time we should spent on benchmark *)
+let timeout = 1
+
+let dirname, filenames =
+ let dirname =
+ let path1 = "./regression" in
+ let path2 = "../regression" 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 ".*\\.expr$" 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);
+ let files = List.map (Printf.sprintf "%s/%s" dirname) files in
+ (dirname, files)
+
+(* let filenames = [ "regression/test036.expr" ] *)
+
+let bench_file file =
+ Format.printf "Benchmarking file `%s`\n%!" file;
+
+ let contents = Ostap.Util.read file in
+ let wrap (parse : string -> RunMenhir.parse_result) =
+ match parse contents with
+ | `Ok r -> snd r
+ | `Fail s ->
+ Printf.eprintf "Error: %s\n%s\n\n" s (Printexc.get_backtrace ());
+ exit 1
+ in
+
+ let () =
+ let check msg1 ast1 msg2 ast2 =
+ if ast1 <> ast2 then
+ let () =
+ Format.printf "%s AST:\n%s\n\n%s AST:\n%s\n\n%!" msg1
+ (GT.show Language.Stmt.t ast1)
+ msg2
+ (GT.show Language.Stmt.t ast2)
+ in
+ failwith "Two ASTs are not equal"
+ else
+ (* let () = Format.printf "%s and %s ASTs are OK!\n%!" msg1 msg2 in *)
+ ()
+ in
+ (* Printf.printf "Calling ostap parser"; *)
+ let ast1 = wrap LamaOstapP5.run_parser in
+
+ (* Printf.printf "Calling menhir parser\n"; *)
+ let ast2 = wrap (RunMenhir.run_parser ~filename:file) in
+
+ (* Printf.printf "Calling Opal parser\n"; *)
+ let ast3 = wrap (LamaOpal.run_parser ~filename:file) in
+
+ check "Ostap" ast1 "Menhir" ast2;
+ check "Ostap" ast1 "Opal" ast3;
+ check "menhir" ast2 "opal" ast3;
+ ()
+ in
+ Gc.full_major ();
+ let run_ostap () =
+ let (_ : Language.Stmt.t) = wrap LamaOstapP5.run_parser in
+ ()
+ in
+ let run_menhir () =
+ let (_ : Language.Stmt.t) = wrap (RunMenhir.run_parser ~filename:file) in
+ ()
+ in
+ (* let _run_angstrom () =
+ let (_ : Language.Stmt.t) = wrap (LamaAngstrom.run_parser ~filename:file) in
+ ()
+ in *)
+ let run_opal () =
+ let (_ : Language.Stmt.t) = wrap (LamaOpal.run_parser ~filename:file) in
+ ()
+ in
+ let open Benchmark in
+ let res =
+ throughputN ~style:Nil ~repeat timeout
+ [
+ ("Ostap", run_ostap, ());
+ ("menhir", run_menhir, ());
+ (* ; ("angstrom", run_angstrom, ()) *)
+ ("opal", run_opal, ());
+ ]
+ in
+ tabulate res
+
+let () = List.iter bench_file filenames