From e66732ae64a5fb1a62c91bc1776ff78bf20a15c4 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Fri, 27 Apr 2018 01:34:25 +0300 Subject: [PATCH 01/15] Prepared branch --- src/Language.ml | 150 ++++++------------------------------------------ src/SM.ml | 103 ++------------------------------- src/X86.ml | 128 +---------------------------------------- 3 files changed, 23 insertions(+), 358 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index d58acef54..20b827377 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -11,7 +11,7 @@ open Combinators module Value = struct - @type t = Int of int | String of string | Array of t list | Sexp of string * t list with show + @type t = Int of int | String of string | Array of t list with show let to_int = function | Int n -> n @@ -29,10 +29,6 @@ module Value = let of_string s = String s let of_array a = Array a - let tag_of = function - | Sexp (t, _) -> t - | _ -> failwith "symbolic expression expected" - let update_string s i x = String.init (String.length s) (fun j -> if j = i then x else s.[j]) let update_array a i x = List.init (List.length a) (fun j -> if j = i then x else List.nth a j) @@ -131,61 +127,18 @@ module Expr = 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 - let (|>) f g = fun x y -> f (g x y) in - match op with - | "+" -> (+) - | "-" -> (-) - | "*" -> ( * ) - | "/" -> (/) - | "%" -> (mod) - | "<" -> bti |> (< ) - | "<=" -> bti |> (<=) - | ">" -> bti |> (> ) - | ">=" -> bti |> (>=) - | "==" -> bti |> (= ) - | "!=" -> 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) - - let rec eval env ((st, i, o, r) as conf) expr = - match expr with - | Const n -> (st, i, o, Some (Value.of_int n)) - | String s -> (st, i, o, Some (Value.of_string s)) - | 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) - | Sexp (t, xs) -> - let (st, i, o, vs) = eval_list env conf xs in - (st, i, o, Some (Value.Sexp (t, vs))) - | Binop (op, x, y) -> - 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) -> - let (st, i, o, args) = eval_list env conf [b; i] in - 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) - | Call (f, args) -> - let (st, i, o, args) = eval_list env conf args in - env#definition env f args (st, i, o, None) - and eval_list env conf xs = - let vs, (st, i, o, _) = - List.fold_left - (fun (acc, conf) x -> - let (_, _, _, Some v) as conf = eval env conf x in - v::acc, conf - ) - ([], conf) - xs - in - (st, i, o, List.rev vs) + let rec eval env ((st, i, o, r) as conf) expr = failwith "Not implemented" + and eval_list env conf xs = + let vs, (st, i, o, _) = + List.fold_left + (fun (acc, conf) x -> + let (_, _, _, Some v) as conf = eval env conf x in + v::acc, conf + ) + ([], conf) + xs + in + (st, i, o, List.rev vs) (* Expression parser. You can use the following terminals: @@ -193,31 +146,7 @@ module Expr = 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 -")" + parse: empty {failwith "Not implemented"} ) end @@ -257,54 +186,11 @@ module Stmt = 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 - | Assign (x, is, e) -> - 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) - | 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 - else eval env conf (seq stmt k) s - | 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 + let rec eval env ((st, i, o, r) as conf) k stmt = failwith "Not implemented" (* 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} + parse: empty {failwith "Not implemented"} ) end @@ -348,12 +234,12 @@ let eval (defs, body) i = try let xs, locs, s = snd @@ M.find f m in let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in - let st'', i', o', r' = Stmt.eval env (st', i, o, r) Skip s in + let st'', i', o', r' = Stmt.eval env (st', i, o, r) Stmt.Skip s in (State.leave st'' st, i', o', r') with Not_found -> Builtin.eval conf args f end) (State.empty, i, [], None) - Skip + Stmt.Skip body in o diff --git a/src/SM.ml b/src/SM.ml index 5ff3c519d..667a65926 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -19,8 +19,6 @@ open Language (* The type for the stack machine program *) type prg = insn list - -let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p (* The type for the stack machine configuration: control stack, stack and configuration from statement interpreter @@ -33,39 +31,15 @@ type config = (prg * State.t) list * Value.t list * Expr.config Takes an environment, a configuration and a program, and returns a configuration as a result. The environment is used to locate a label to jump to (via method env#labeled ) -*) +*) let split n l = let rec unzip (taken, rest) = function | 0 -> (List.rev taken, rest) | n -> let h::tl = rest in unzip (h::taken, tl) (n-1) in unzip ([], l) n - -let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function -| [] -> conf -| insn :: prg' -> - (match insn with - | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', c) prg' - | CONST i -> eval env (cstack, (Value.of_int i)::stack, c) prg' - | STRING s -> eval env (cstack, (Value.of_string s)::stack, c) prg' - | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' - | ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg' - | STA (x, n) -> let v::is, stack' = split (n+1) stack in - eval env (cstack, stack', (Language.Stmt.update st x v (List.rev is), i, o)) prg' - | LABEL _ -> eval env conf prg' - | JMP l -> eval env conf (env#labeled l) - | CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg') - | CALL (f, n, p) -> if env#is_label f - then eval env ((prg', st)::cstack, stack, c) (env#labeled f) - else eval env (env#builtin conf f n p) prg' - | BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in - let state = List.combine args @@ List.rev vs in - eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.enter st (args @ locals)) state, i, o)) prg' - | END | RET _ -> (match cstack with - | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' - | [] -> conf - ) - ) + +let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) prg = failwith "Not implemented" (* Top-level evaluation @@ -74,7 +48,6 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function Takes a program, an input stream, and returns an output stream this program calculates *) let run p i = - (* print_prg p; *) let module M = Map.Make (String) in let rec make_map m = function | [] -> m @@ -108,72 +81,4 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine *) -let compile (defs, p) = - let label s = "L" ^ s in - let rec call f args p = - let args_code = List.concat @@ List.map expr args in - args_code @ [CALL (label f, List.length args, p)] - and expr = function - | Expr.Var x -> [LD x] - | Expr.Const n -> [CONST n] - | Expr.String s -> [STRING s] - | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] - | Expr.Call (f, args) -> call f args false - | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL ("$array", List.length xs, false)] - | Expr.Elem (a, i) -> expr a @ expr i @ [CALL ("$elem", 2, false)] - | Expr.Length e -> expr e @ [CALL ("$length", 1, false)] - in - let rec compile_stmt l env = function - | Stmt.Assign (x, [], e) -> env, false, expr e @ [ST x] - | Stmt.Assign (x, is, e) -> env, false, List.flatten (List.map expr (is @ [e])) @ [STA (x, List.length is)] - | Stmt.Skip -> env, false, [] - - | Stmt.Seq (s1, s2) -> let l2, env = env#get_label in - let env, flag1, s1 = compile_stmt l2 env s1 in - let env, flag2, s2 = compile_stmt l env s2 in - env, flag2, s1 @ (if flag1 then [LABEL l2] else []) @ s2 - - | Stmt.If (c, s1, s2) -> let l2, env = env#get_label in - let env, flag1, s1 = compile_stmt l env s1 in - let env, flag2, s2 = compile_stmt l env s2 in - env, true, expr c @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l]) - - | Stmt.While (c, s) -> let loop, env = env#get_label in - let cond, env = env#get_label in - let env, _, s = compile_stmt cond env s in - env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ expr c @ [CJMP ("nz", loop)] - - | Stmt.Repeat (s, c) -> let loop , env = env#get_label in - let check, env = env#get_label in - let env , flag, body = compile_stmt check env s in - env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ (expr c) @ [CJMP ("z", loop)] - - | Stmt.Call (f, args) -> env, false, call f args true - - | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)] - in - let compile_def env (name, (args, locals, stmt)) = - let lend, env = env#get_label in - let env, flag, code = compile_stmt lend env stmt in - env, - [LABEL name; BEGIN (name, args, locals)] @ - code @ - (if flag then [LABEL lend] else []) @ - [END] - in - let env = - object - val ls = 0 - method get_label = (label @@ string_of_int ls), {< ls = ls + 1 >} - end - in - let env, def_code = - List.fold_left - (fun (env, code) (name, others) -> let env, code' = compile_def env (label name, others) in env, code'::code) - (env, []) - defs - in - let lend, env = env#get_label in - let _, flag, code = compile_stmt lend env p in - (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) - +let compile (defs, p) = failwith "Not implemented" diff --git a/src/X86.ml b/src/X86.ml index 3932e31db..542065801 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -100,133 +100,7 @@ let compile env code = | ">" -> "g" | _ -> failwith "unknown operator" in - let rec compile' env scode = - let on_stack = function S _ -> true | _ -> false in - match scode with - | [] -> env, [] - | instr :: scode' -> - let env', code' = - match instr with - | CONST n -> - let s, env' = env#allocate in - (env', [Mov (L n, s)]) - | LD x -> - let s, env' = (env#global x)#allocate in - env', - (match s with - | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] - | _ -> [Mov (env'#loc x, s)] - ) - | STA (x, n) -> failwith "" - | ST x -> - let s, env' = (env#global x)#pop in - env', - (match s with - | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] - | _ -> [Mov (s, env'#loc x)] - ) - | BINOP op -> - let x, y, env' = env#pop2 in - env'#push y, - (match op with - | "/" | "%" -> - [Mov (y, eax); - Cltd; - IDiv x; - Mov ((match op with "/" -> eax | _ -> edx), y) - ] - | "<" | "<=" | "==" | "!=" | ">=" | ">" -> - (match x with - | M _ | S _ -> - [Binop ("^", eax, eax); - Mov (x, edx); - Binop ("cmp", edx, y); - Set (suffix op, "%al"); - Mov (eax, y) - ] - | _ -> - [Binop ("^" , eax, eax); - Binop ("cmp", x, y); - Set (suffix op, "%al"); - Mov (eax, y) - ] - ) - | "*" -> - if on_stack x && on_stack y - then [Mov (y, eax); Binop (op, x, eax); Mov (eax, y)] - else [Binop (op, x, y)] - | "&&" -> - [Mov (x, eax); - Binop (op, x, eax); - Mov (L 0, eax); - Set ("ne", "%al"); - - Mov (y, edx); - Binop (op, y, edx); - Mov (L 0, edx); - Set ("ne", "%dl"); - - Binop (op, edx, eax); - Set ("ne", "%al"); - - Mov (eax, y) - ] - | "!!" -> - [Mov (y, eax); - Binop (op, x, eax); - Mov (L 0, eax); - Set ("ne", "%al"); - Mov (eax, y) - ] - | _ -> - if on_stack x && on_stack y - then [Mov (x, eax); Binop (op, eax, y)] - else [Binop (op, x, y)] - ) - | LABEL s -> env, [Label s] - | JMP l -> env, [Jmp l] - | CJMP (s, l) -> - let x, env = env#pop in - env, [Binop ("cmp", L 0, x); CJmp (s, l)] - - | BEGIN (f, a, l) -> - let env = env#enter f a l in - env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp)] - - | END -> - env, [Label env#epilogue; - Mov (ebp, esp); - Pop ebp; - Ret; - Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)) - ] - - | RET b -> - if b - then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] - else env, [Jmp env#epilogue] - - | CALL (f, n, p) -> - let pushr, popr = - List.split @@ List.map (fun r -> (Push r, Pop r)) env#live_registers - in - let env, code = - if n = 0 - then env, pushr @ [Call f] @ (List.rev popr) - else - let rec push_args env acc = function - | 0 -> env, acc - | n -> let x, env = env#pop in - push_args env ((Push x)::acc) (n-1) - in - let env, pushs = push_args env [] n in - env, pushr @ (List.rev pushs) @ [Call f; Binop ("+", L (n*4), esp)] @ (List.rev popr) - in - (if p then env, code else let y, env = env#allocate in env, code @ [Mov (eax, y)]) - in - let env'', code'' = compile' env' scode' in - env'', code' @ code'' - in + let rec compile' env scode = failwith "Not implemented" in compile' env code (* A set of strings *) From 797344017ebaaef11cb04a782c7f6ca6c2eebff3 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Fri, 27 Apr 2018 01:34:25 +0300 Subject: [PATCH 02/15] Prepared branch --- src/Language.ml | 150 ++++++------------------------------------------ src/SM.ml | 103 ++------------------------------- src/X86.ml | 128 +---------------------------------------- 3 files changed, 23 insertions(+), 358 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index d58acef54..20b827377 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -11,7 +11,7 @@ open Combinators module Value = struct - @type t = Int of int | String of string | Array of t list | Sexp of string * t list with show + @type t = Int of int | String of string | Array of t list with show let to_int = function | Int n -> n @@ -29,10 +29,6 @@ module Value = let of_string s = String s let of_array a = Array a - let tag_of = function - | Sexp (t, _) -> t - | _ -> failwith "symbolic expression expected" - let update_string s i x = String.init (String.length s) (fun j -> if j = i then x else s.[j]) let update_array a i x = List.init (List.length a) (fun j -> if j = i then x else List.nth a j) @@ -131,61 +127,18 @@ module Expr = 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 - let (|>) f g = fun x y -> f (g x y) in - match op with - | "+" -> (+) - | "-" -> (-) - | "*" -> ( * ) - | "/" -> (/) - | "%" -> (mod) - | "<" -> bti |> (< ) - | "<=" -> bti |> (<=) - | ">" -> bti |> (> ) - | ">=" -> bti |> (>=) - | "==" -> bti |> (= ) - | "!=" -> 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) - - let rec eval env ((st, i, o, r) as conf) expr = - match expr with - | Const n -> (st, i, o, Some (Value.of_int n)) - | String s -> (st, i, o, Some (Value.of_string s)) - | 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) - | Sexp (t, xs) -> - let (st, i, o, vs) = eval_list env conf xs in - (st, i, o, Some (Value.Sexp (t, vs))) - | Binop (op, x, y) -> - 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) -> - let (st, i, o, args) = eval_list env conf [b; i] in - 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) - | Call (f, args) -> - let (st, i, o, args) = eval_list env conf args in - env#definition env f args (st, i, o, None) - and eval_list env conf xs = - let vs, (st, i, o, _) = - List.fold_left - (fun (acc, conf) x -> - let (_, _, _, Some v) as conf = eval env conf x in - v::acc, conf - ) - ([], conf) - xs - in - (st, i, o, List.rev vs) + let rec eval env ((st, i, o, r) as conf) expr = failwith "Not implemented" + and eval_list env conf xs = + let vs, (st, i, o, _) = + List.fold_left + (fun (acc, conf) x -> + let (_, _, _, Some v) as conf = eval env conf x in + v::acc, conf + ) + ([], conf) + xs + in + (st, i, o, List.rev vs) (* Expression parser. You can use the following terminals: @@ -193,31 +146,7 @@ module Expr = 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 -")" + parse: empty {failwith "Not implemented"} ) end @@ -257,54 +186,11 @@ module Stmt = 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 - | Assign (x, is, e) -> - 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) - | 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 - else eval env conf (seq stmt k) s - | 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 + let rec eval env ((st, i, o, r) as conf) k stmt = failwith "Not implemented" (* 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} + parse: empty {failwith "Not implemented"} ) end @@ -348,12 +234,12 @@ let eval (defs, body) i = try let xs, locs, s = snd @@ M.find f m in let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in - let st'', i', o', r' = Stmt.eval env (st', i, o, r) Skip s in + let st'', i', o', r' = Stmt.eval env (st', i, o, r) Stmt.Skip s in (State.leave st'' st, i', o', r') with Not_found -> Builtin.eval conf args f end) (State.empty, i, [], None) - Skip + Stmt.Skip body in o diff --git a/src/SM.ml b/src/SM.ml index 5ff3c519d..667a65926 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -19,8 +19,6 @@ open Language (* The type for the stack machine program *) type prg = insn list - -let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p (* The type for the stack machine configuration: control stack, stack and configuration from statement interpreter @@ -33,39 +31,15 @@ type config = (prg * State.t) list * Value.t list * Expr.config Takes an environment, a configuration and a program, and returns a configuration as a result. The environment is used to locate a label to jump to (via method env#labeled ) -*) +*) let split n l = let rec unzip (taken, rest) = function | 0 -> (List.rev taken, rest) | n -> let h::tl = rest in unzip (h::taken, tl) (n-1) in unzip ([], l) n - -let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function -| [] -> conf -| insn :: prg' -> - (match insn with - | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', c) prg' - | CONST i -> eval env (cstack, (Value.of_int i)::stack, c) prg' - | STRING s -> eval env (cstack, (Value.of_string s)::stack, c) prg' - | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' - | ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg' - | STA (x, n) -> let v::is, stack' = split (n+1) stack in - eval env (cstack, stack', (Language.Stmt.update st x v (List.rev is), i, o)) prg' - | LABEL _ -> eval env conf prg' - | JMP l -> eval env conf (env#labeled l) - | CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg') - | CALL (f, n, p) -> if env#is_label f - then eval env ((prg', st)::cstack, stack, c) (env#labeled f) - else eval env (env#builtin conf f n p) prg' - | BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in - let state = List.combine args @@ List.rev vs in - eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.enter st (args @ locals)) state, i, o)) prg' - | END | RET _ -> (match cstack with - | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' - | [] -> conf - ) - ) + +let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) prg = failwith "Not implemented" (* Top-level evaluation @@ -74,7 +48,6 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function Takes a program, an input stream, and returns an output stream this program calculates *) let run p i = - (* print_prg p; *) let module M = Map.Make (String) in let rec make_map m = function | [] -> m @@ -108,72 +81,4 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine *) -let compile (defs, p) = - let label s = "L" ^ s in - let rec call f args p = - let args_code = List.concat @@ List.map expr args in - args_code @ [CALL (label f, List.length args, p)] - and expr = function - | Expr.Var x -> [LD x] - | Expr.Const n -> [CONST n] - | Expr.String s -> [STRING s] - | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] - | Expr.Call (f, args) -> call f args false - | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL ("$array", List.length xs, false)] - | Expr.Elem (a, i) -> expr a @ expr i @ [CALL ("$elem", 2, false)] - | Expr.Length e -> expr e @ [CALL ("$length", 1, false)] - in - let rec compile_stmt l env = function - | Stmt.Assign (x, [], e) -> env, false, expr e @ [ST x] - | Stmt.Assign (x, is, e) -> env, false, List.flatten (List.map expr (is @ [e])) @ [STA (x, List.length is)] - | Stmt.Skip -> env, false, [] - - | Stmt.Seq (s1, s2) -> let l2, env = env#get_label in - let env, flag1, s1 = compile_stmt l2 env s1 in - let env, flag2, s2 = compile_stmt l env s2 in - env, flag2, s1 @ (if flag1 then [LABEL l2] else []) @ s2 - - | Stmt.If (c, s1, s2) -> let l2, env = env#get_label in - let env, flag1, s1 = compile_stmt l env s1 in - let env, flag2, s2 = compile_stmt l env s2 in - env, true, expr c @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l]) - - | Stmt.While (c, s) -> let loop, env = env#get_label in - let cond, env = env#get_label in - let env, _, s = compile_stmt cond env s in - env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ expr c @ [CJMP ("nz", loop)] - - | Stmt.Repeat (s, c) -> let loop , env = env#get_label in - let check, env = env#get_label in - let env , flag, body = compile_stmt check env s in - env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ (expr c) @ [CJMP ("z", loop)] - - | Stmt.Call (f, args) -> env, false, call f args true - - | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)] - in - let compile_def env (name, (args, locals, stmt)) = - let lend, env = env#get_label in - let env, flag, code = compile_stmt lend env stmt in - env, - [LABEL name; BEGIN (name, args, locals)] @ - code @ - (if flag then [LABEL lend] else []) @ - [END] - in - let env = - object - val ls = 0 - method get_label = (label @@ string_of_int ls), {< ls = ls + 1 >} - end - in - let env, def_code = - List.fold_left - (fun (env, code) (name, others) -> let env, code' = compile_def env (label name, others) in env, code'::code) - (env, []) - defs - in - let lend, env = env#get_label in - let _, flag, code = compile_stmt lend env p in - (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) - +let compile (defs, p) = failwith "Not implemented" diff --git a/src/X86.ml b/src/X86.ml index c6b270ab6..bd8b34559 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -100,133 +100,7 @@ let compile env code = | ">" -> "g" | _ -> failwith "unknown operator" in - let rec compile' env scode = - let on_stack = function S _ -> true | _ -> false in - match scode with - | [] -> env, [] - | instr :: scode' -> - let env', code' = - match instr with - | CONST n -> - let s, env' = env#allocate in - (env', [Mov (L n, s)]) - | LD x -> - let s, env' = (env#global x)#allocate in - env', - (match s with - | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] - | _ -> [Mov (env'#loc x, s)] - ) - | STA (x, n) -> failwith "" - | ST x -> - let s, env' = (env#global x)#pop in - env', - (match s with - | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] - | _ -> [Mov (s, env'#loc x)] - ) - | BINOP op -> - let x, y, env' = env#pop2 in - env'#push y, - (match op with - | "/" | "%" -> - [Mov (y, eax); - Cltd; - IDiv x; - Mov ((match op with "/" -> eax | _ -> edx), y) - ] - | "<" | "<=" | "==" | "!=" | ">=" | ">" -> - (match x with - | M _ | S _ -> - [Binop ("^", eax, eax); - Mov (x, edx); - Binop ("cmp", edx, y); - Set (suffix op, "%al"); - Mov (eax, y) - ] - | _ -> - [Binop ("^" , eax, eax); - Binop ("cmp", x, y); - Set (suffix op, "%al"); - Mov (eax, y) - ] - ) - | "*" -> - if on_stack x && on_stack y - then [Mov (y, eax); Binop (op, x, eax); Mov (eax, y)] - else [Binop (op, x, y)] - | "&&" -> - [Mov (x, eax); - Binop (op, x, eax); - Mov (L 0, eax); - Set ("ne", "%al"); - - Mov (y, edx); - Binop (op, y, edx); - Mov (L 0, edx); - Set ("ne", "%dl"); - - Binop (op, edx, eax); - Set ("ne", "%al"); - - Mov (eax, y) - ] - | "!!" -> - [Mov (y, eax); - Binop (op, x, eax); - Mov (L 0, eax); - Set ("ne", "%al"); - Mov (eax, y) - ] - | _ -> - if on_stack x && on_stack y - then [Mov (x, eax); Binop (op, eax, y)] - else [Binop (op, x, y)] - ) - | LABEL s -> env, [Label s] - | JMP l -> env, [Jmp l] - | CJMP (s, l) -> - let x, env = env#pop in - env, [Binop ("cmp", L 0, x); CJmp (s, l)] - - | BEGIN (f, a, l) -> - let env = env#enter f a l in - env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp)] - - | END -> - env, [Label env#epilogue; - Mov (ebp, esp); - Pop ebp; - Ret; - Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)) - ] - - | RET b -> - if b - then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] - else env, [Jmp env#epilogue] - - | CALL (f, n, p) -> - let pushr, popr = - List.split @@ List.map (fun r -> (Push r, Pop r)) env#live_registers - in - let env, code = - if n = 0 - then env, pushr @ [Call f] @ (List.rev popr) - else - let rec push_args env acc = function - | 0 -> env, acc - | n -> let x, env = env#pop in - push_args env ((Push x)::acc) (n-1) - in - let env, pushs = push_args env [] n in - env, pushr @ (List.rev pushs) @ [Call f; Binop ("+", L (n*4), esp)] @ (List.rev popr) - in - (if p then env, code else let y, env = env#allocate in env, code @ [Mov (eax, y)]) - in - let env'', code'' = compile' env' scode' in - env'', code' @ code'' - in + let rec compile' env scode = failwith "Not implemented" in compile' env code (* A set of strings *) From 514d956c1f0f252337d075d082500fe091bcf080 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Thu, 22 Oct 2020 23:02:03 +0300 Subject: [PATCH 03/15] Repair compilation Signed-off-by: Kakadu --- src/Makefile | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Makefile b/src/Makefile index 8eb66bcfd..8e8cc98bc 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,12 +1,12 @@ TOPFILE = rc -OCAMLC = ocamlc -OCAMLOPT = ocamlopt -OCAMLDEP = ocamldep +OCAMLC = ocamlfind c +OCAMLOPT = ocamlfind opt +OCAMLDEP = ocamlfind dep 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`" +LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma +CAMLP5 = -syntax camlp5o -package GT.syntax.all,ostap.syntax PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap` +BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap` OFLAGS = $(BFLAGS) all: .depend $(TOPFILE).opt @@ -18,7 +18,7 @@ $(TOPFILE).opt: $(SOURCES:.ml=.cmx) $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx) $(TOPFILE).byte: $(SOURCES:.ml=.cmo) - $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo) + $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo) clean: rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend @@ -42,4 +42,3 @@ clean: %.cmx: %.ml $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< - From f241a4060b96e96c7af4d2c2f05b8829cade23e6 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Thu, 22 Oct 2020 23:24:10 +0300 Subject: [PATCH 04/15] repair compilation with old ostap Signed-off-by: Kakadu --- src/Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Makefile b/src/Makefile index 8e8cc98bc..ebf1285b0 100644 --- a/src/Makefile +++ b/src/Makefile @@ -3,10 +3,10 @@ OCAMLC = ocamlfind c OCAMLOPT = ocamlfind opt OCAMLDEP = ocamlfind dep SOURCES = Language.ml SM.ml X86.ml Driver.ml -LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma +LIBS = #GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma CAMLP5 = -syntax camlp5o -package GT.syntax.all,ostap.syntax PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap` +BFLAGS = -rectypes -package GT,re,ostap -linkpkg OFLAGS = $(BFLAGS) all: .depend $(TOPFILE).opt @@ -15,10 +15,10 @@ all: .depend $(TOPFILE).opt $(OCAMLDEP) $(PXFLAGS) *.ml > .depend $(TOPFILE).opt: $(SOURCES:.ml=.cmx) - $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx) + $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) $(TOPFILE).byte: $(SOURCES:.ml=.cmo) - $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo) + $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) $(SOURCES:.ml=.cmo) clean: rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend From bd60df94aa3e92079b4d8979822998bba5643e10 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Thu, 22 Oct 2020 23:30:23 +0300 Subject: [PATCH 05/15] Revert "Prepared branch" This reverts commit e66732ae64a5fb1a62c91bc1776ff78bf20a15c4. --- src/Language.ml | 150 ++++++++++++++++++++++++++++++++++++++++++------ src/SM.ml | 103 +++++++++++++++++++++++++++++++-- src/X86.ml | 128 ++++++++++++++++++++++++++++++++++++++++- 3 files changed, 358 insertions(+), 23 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index 20b827377..d58acef54 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -11,7 +11,7 @@ open Combinators module Value = struct - @type t = Int of int | String of string | Array of t list with show + @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 @@ -29,6 +29,10 @@ module Value = let of_string s = String s let of_array a = Array a + let tag_of = function + | Sexp (t, _) -> t + | _ -> failwith "symbolic expression expected" + let update_string s i x = String.init (String.length s) (fun j -> if j = i then x else s.[j]) let update_array a i x = List.init (List.length a) (fun j -> if j = i then x else List.nth a j) @@ -127,18 +131,61 @@ module Expr = 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 rec eval env ((st, i, o, r) as conf) expr = failwith "Not implemented" - and eval_list env conf xs = - let vs, (st, i, o, _) = - List.fold_left - (fun (acc, conf) x -> - let (_, _, _, Some v) as conf = eval env conf x in - v::acc, conf - ) - ([], conf) - xs - in - (st, i, o, List.rev vs) + let to_func op = + let bti = function true -> 1 | _ -> 0 in + let itb b = b <> 0 in + let (|>) f g = fun x y -> f (g x y) in + match op with + | "+" -> (+) + | "-" -> (-) + | "*" -> ( * ) + | "/" -> (/) + | "%" -> (mod) + | "<" -> bti |> (< ) + | "<=" -> bti |> (<=) + | ">" -> bti |> (> ) + | ">=" -> bti |> (>=) + | "==" -> bti |> (= ) + | "!=" -> 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) + + let rec eval env ((st, i, o, r) as conf) expr = + match expr with + | Const n -> (st, i, o, Some (Value.of_int n)) + | String s -> (st, i, o, Some (Value.of_string s)) + | 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) + | Sexp (t, xs) -> + let (st, i, o, vs) = eval_list env conf xs in + (st, i, o, Some (Value.Sexp (t, vs))) + | Binop (op, x, y) -> + 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) -> + let (st, i, o, args) = eval_list env conf [b; i] in + 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) + | Call (f, args) -> + let (st, i, o, args) = eval_list env conf args in + env#definition env f args (st, i, o, None) + and eval_list env conf xs = + let vs, (st, i, o, _) = + List.fold_left + (fun (acc, conf) x -> + let (_, _, _, Some v) as conf = eval env conf x in + v::acc, conf + ) + ([], conf) + xs + in + (st, i, o, List.rev vs) (* Expression parser. You can use the following terminals: @@ -146,7 +193,31 @@ module Expr = DECIMAL --- a decimal constant [0-9]+ as a string *) ostap ( - parse: empty {failwith "Not implemented"} + 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 @@ -186,11 +257,54 @@ module Stmt = 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 = failwith "Not implemented" + 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 + | Assign (x, is, e) -> + 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) + | 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 + else eval env conf (seq stmt k) s + | 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: empty {failwith "Not implemented"} + 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 @@ -234,12 +348,12 @@ let eval (defs, body) i = try let xs, locs, s = snd @@ M.find f m in let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in - let st'', i', o', r' = Stmt.eval env (st', i, o, r) Stmt.Skip s in + let st'', i', o', r' = Stmt.eval env (st', i, o, r) Skip s in (State.leave st'' st, i', o', r') with Not_found -> Builtin.eval conf args f end) (State.empty, i, [], None) - Stmt.Skip + Skip body in o diff --git a/src/SM.ml b/src/SM.ml index 667a65926..5ff3c519d 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -19,6 +19,8 @@ open Language (* The type for the stack machine program *) type prg = insn list + +let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p (* The type for the stack machine configuration: control stack, stack and configuration from statement interpreter @@ -31,15 +33,39 @@ type config = (prg * State.t) list * Value.t list * Expr.config Takes an environment, a configuration and a program, and returns a configuration as a result. The environment is used to locate a label to jump to (via method env#labeled ) -*) +*) let split n l = let rec unzip (taken, rest) = function | 0 -> (List.rev taken, rest) | n -> let h::tl = rest in unzip (h::taken, tl) (n-1) in unzip ([], l) n - -let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) prg = failwith "Not implemented" + +let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function +| [] -> conf +| insn :: prg' -> + (match insn with + | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', c) prg' + | CONST i -> eval env (cstack, (Value.of_int i)::stack, c) prg' + | STRING s -> eval env (cstack, (Value.of_string s)::stack, c) prg' + | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' + | ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg' + | STA (x, n) -> let v::is, stack' = split (n+1) stack in + eval env (cstack, stack', (Language.Stmt.update st x v (List.rev is), i, o)) prg' + | LABEL _ -> eval env conf prg' + | JMP l -> eval env conf (env#labeled l) + | CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg') + | CALL (f, n, p) -> if env#is_label f + then eval env ((prg', st)::cstack, stack, c) (env#labeled f) + else eval env (env#builtin conf f n p) prg' + | BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in + let state = List.combine args @@ List.rev vs in + eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.enter st (args @ locals)) state, i, o)) prg' + | END | RET _ -> (match cstack with + | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' + | [] -> conf + ) + ) (* Top-level evaluation @@ -48,6 +74,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) prg = failwith "No Takes a program, an input stream, and returns an output stream this program calculates *) let run p i = + (* print_prg p; *) let module M = Map.Make (String) in let rec make_map m = function | [] -> m @@ -81,4 +108,72 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine *) -let compile (defs, p) = failwith "Not implemented" +let compile (defs, p) = + let label s = "L" ^ s in + let rec call f args p = + let args_code = List.concat @@ List.map expr args in + args_code @ [CALL (label f, List.length args, p)] + and expr = function + | Expr.Var x -> [LD x] + | Expr.Const n -> [CONST n] + | Expr.String s -> [STRING s] + | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] + | Expr.Call (f, args) -> call f args false + | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL ("$array", List.length xs, false)] + | Expr.Elem (a, i) -> expr a @ expr i @ [CALL ("$elem", 2, false)] + | Expr.Length e -> expr e @ [CALL ("$length", 1, false)] + in + let rec compile_stmt l env = function + | Stmt.Assign (x, [], e) -> env, false, expr e @ [ST x] + | Stmt.Assign (x, is, e) -> env, false, List.flatten (List.map expr (is @ [e])) @ [STA (x, List.length is)] + | Stmt.Skip -> env, false, [] + + | Stmt.Seq (s1, s2) -> let l2, env = env#get_label in + let env, flag1, s1 = compile_stmt l2 env s1 in + let env, flag2, s2 = compile_stmt l env s2 in + env, flag2, s1 @ (if flag1 then [LABEL l2] else []) @ s2 + + | Stmt.If (c, s1, s2) -> let l2, env = env#get_label in + let env, flag1, s1 = compile_stmt l env s1 in + let env, flag2, s2 = compile_stmt l env s2 in + env, true, expr c @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l]) + + | Stmt.While (c, s) -> let loop, env = env#get_label in + let cond, env = env#get_label in + let env, _, s = compile_stmt cond env s in + env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ expr c @ [CJMP ("nz", loop)] + + | Stmt.Repeat (s, c) -> let loop , env = env#get_label in + let check, env = env#get_label in + let env , flag, body = compile_stmt check env s in + env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ (expr c) @ [CJMP ("z", loop)] + + | Stmt.Call (f, args) -> env, false, call f args true + + | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)] + in + let compile_def env (name, (args, locals, stmt)) = + let lend, env = env#get_label in + let env, flag, code = compile_stmt lend env stmt in + env, + [LABEL name; BEGIN (name, args, locals)] @ + code @ + (if flag then [LABEL lend] else []) @ + [END] + in + let env = + object + val ls = 0 + method get_label = (label @@ string_of_int ls), {< ls = ls + 1 >} + end + in + let env, def_code = + List.fold_left + (fun (env, code) (name, others) -> let env, code' = compile_def env (label name, others) in env, code'::code) + (env, []) + defs + in + let lend, env = env#get_label in + let _, flag, code = compile_stmt lend env p in + (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) + diff --git a/src/X86.ml b/src/X86.ml index bd8b34559..c6b270ab6 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -100,7 +100,133 @@ let compile env code = | ">" -> "g" | _ -> failwith "unknown operator" in - let rec compile' env scode = failwith "Not implemented" in + let rec compile' env scode = + let on_stack = function S _ -> true | _ -> false in + match scode with + | [] -> env, [] + | instr :: scode' -> + let env', code' = + match instr with + | CONST n -> + let s, env' = env#allocate in + (env', [Mov (L n, s)]) + | LD x -> + let s, env' = (env#global x)#allocate in + env', + (match s with + | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] + | _ -> [Mov (env'#loc x, s)] + ) + | STA (x, n) -> failwith "" + | ST x -> + let s, env' = (env#global x)#pop in + env', + (match s with + | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] + | _ -> [Mov (s, env'#loc x)] + ) + | BINOP op -> + let x, y, env' = env#pop2 in + env'#push y, + (match op with + | "/" | "%" -> + [Mov (y, eax); + Cltd; + IDiv x; + Mov ((match op with "/" -> eax | _ -> edx), y) + ] + | "<" | "<=" | "==" | "!=" | ">=" | ">" -> + (match x with + | M _ | S _ -> + [Binop ("^", eax, eax); + Mov (x, edx); + Binop ("cmp", edx, y); + Set (suffix op, "%al"); + Mov (eax, y) + ] + | _ -> + [Binop ("^" , eax, eax); + Binop ("cmp", x, y); + Set (suffix op, "%al"); + Mov (eax, y) + ] + ) + | "*" -> + if on_stack x && on_stack y + then [Mov (y, eax); Binop (op, x, eax); Mov (eax, y)] + else [Binop (op, x, y)] + | "&&" -> + [Mov (x, eax); + Binop (op, x, eax); + Mov (L 0, eax); + Set ("ne", "%al"); + + Mov (y, edx); + Binop (op, y, edx); + Mov (L 0, edx); + Set ("ne", "%dl"); + + Binop (op, edx, eax); + Set ("ne", "%al"); + + Mov (eax, y) + ] + | "!!" -> + [Mov (y, eax); + Binop (op, x, eax); + Mov (L 0, eax); + Set ("ne", "%al"); + Mov (eax, y) + ] + | _ -> + if on_stack x && on_stack y + then [Mov (x, eax); Binop (op, eax, y)] + else [Binop (op, x, y)] + ) + | LABEL s -> env, [Label s] + | JMP l -> env, [Jmp l] + | CJMP (s, l) -> + let x, env = env#pop in + env, [Binop ("cmp", L 0, x); CJmp (s, l)] + + | BEGIN (f, a, l) -> + let env = env#enter f a l in + env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp)] + + | END -> + env, [Label env#epilogue; + Mov (ebp, esp); + Pop ebp; + Ret; + Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)) + ] + + | RET b -> + if b + then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] + else env, [Jmp env#epilogue] + + | CALL (f, n, p) -> + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) env#live_registers + in + let env, code = + if n = 0 + then env, pushr @ [Call f] @ (List.rev popr) + else + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + push_args env ((Push x)::acc) (n-1) + in + let env, pushs = push_args env [] n in + env, pushr @ (List.rev pushs) @ [Call f; Binop ("+", L (n*4), esp)] @ (List.rev popr) + in + (if p then env, code else let y, env = env#allocate in env, code @ [Mov (eax, y)]) + in + let env'', code'' = compile' env' scode' in + env'', code' @ code'' + in compile' env code (* A set of strings *) From 7aca3e3f110e1c00421ce701234ee9ed17fbad9b Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sun, 25 Oct 2020 12:30:56 +0300 Subject: [PATCH 06/15] First menhir implementation Signed-off-by: Kakadu --- .gitignore | 4 +- doc/.gitignore | 4 + regression/.gitignore | 2 + src/.depend | 13 +++ src/.gitignore | 6 ++ src/Driver.ml | 112 +++++++++++++++++------ src/LamaLexer.mll | 112 +++++++++++++++++++++++ src/LamaMenhir.mly | 133 ++++++++++++++++++++++++++++ src/Language.ml | 200 ++++++++++++++++++++++++++---------------- src/Makefile | 41 +++++++-- 10 files changed, 514 insertions(+), 113 deletions(-) create mode 100644 doc/.gitignore create mode 100644 regression/.gitignore create mode 100644 src/.depend create mode 100644 src/.gitignore create mode 100644 src/LamaLexer.mll create mode 100644 src/LamaMenhir.mly 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/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/.depend b/src/.depend new file mode 100644 index 000000000..55c7cb4de --- /dev/null +++ b/src/.depend @@ -0,0 +1,13 @@ +Driver.cmo : X86.cmo SM.cmo Language.cmo LamaMenhir.cmi LamaLexer.cmo +Driver.cmx : X86.cmx SM.cmx Language.cmx LamaMenhir.cmx LamaLexer.cmx +LamaLexer.cmo : Language.cmo LamaMenhir.cmi +LamaLexer.cmx : Language.cmx LamaMenhir.cmx +LamaMenhir.cmo : Language.cmo LamaMenhir.cmi +LamaMenhir.cmx : Language.cmx LamaMenhir.cmi +LamaMenhir.cmi : Language.cmo +Language.cmo : +Language.cmx : +SM.cmo : Language.cmo +SM.cmx : Language.cmx +X86.cmo : SM.cmo Language.cmo +X86.cmx : SM.cmx Language.cmx diff --git a/src/.gitignore b/src/.gitignore new file mode 100644 index 000000000..22fc462aa --- /dev/null +++ b/src/.gitignore @@ -0,0 +1,6 @@ +.merlin +/LamaLexer.ml +/LamaMenhir.ml +/LamaMenhir.mli +/LamaMenhir.conflicts +/rc.opt diff --git a/src/Driver.ml b/src/Driver.ml index 04818b39e..3fe638ed5 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -18,33 +18,91 @@ let parse infile = ) (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 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 parse { menhir; file } = + if not menhir + then parse file + else + let lexbuf = Lexing.from_string (Util.read file) in + let () = lexbuf.Lexing.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = file } 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) + + + +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/LamaLexer.mll b/src/LamaLexer.mll new file mode 100644 index 000000000..0006f935b --- /dev/null +++ b/src/LamaLexer.mll @@ -0,0 +1,112 @@ +{ +open Lexing +open LamaMenhir +open Language.Json + +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 } + | "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..5bba2479d --- /dev/null +++ b/src/LamaMenhir.mly @@ -0,0 +1,133 @@ +%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_log: + | GT { ">" } + | GE { ">=" } + | LT { "<" } + | LE { "<=" } + | NEQ { "!=" } + | EQEQ { "==" } + | LAND { "&&" } + | LOR { "!!" } + ; + +expr_log: + | l = expr_log; op = op_log; 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 } + | f = IDENT; LPAREN; args = separated_list(COMMA, expr); RPAREN { Language.Expr.Call (f, args) } + | f = IDENT { Language.Expr.Var f } + // | f = IDENT; args = plist(expr) { + // match args with + // | [] -> Language.Expr.Var f + // | args -> Language.Expr.Call (f, args) + // } + | 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 = elifs; els = else1?; 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 = indexes; ASSGN; e=expr { Language.Stmt.Assign (x, is, e) } + ; + +index: + | LBRACK; e = expr; RBRACK { e } + ; +indexes: xs = list(index) { xs } + ; + +elif1: ELIF; e = expr; THEN; th = stmts { (e,th) (* ???? *) }; +elifs: e = elif1* { e }; +else1: ELSE; br = stmts { br }; + +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/Language.ml b/src/Language.ml index d58acef54..b7090f39d 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,81 @@ 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 + DECIMAL --- a decimal constant [0-9]+ as a string *) - ostap ( + ostap ( parse: - !(Ostap.Util.expr - (fun x -> x) - (Array.map (fun (a, s) -> a, + !(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, ["*" ; "/"; "%"]; - |] - ) + ) + [| + `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}; + 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} + | 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 +268,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,38 +279,39 @@ 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)? + %"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) + 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))) + 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} + | %"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 *) @@ -314,7 +319,7 @@ module Definition = struct (* The type for a definition: name, argument list, local variables, body *) - type t = string * (string list * string list * Stmt.t) + @type t = string * (string list * string list * Stmt.t) with show ostap ( arg : IDENT; @@ -326,11 +331,11 @@ module Definition = ) 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 +344,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 @@ -360,3 +366,47 @@ let eval (defs, body) i = (* Top-level parser *) let parse = ostap (!(Definition.parse)* !(Stmt.parse)) + +module Json = struct + type token = + (* | NULL + | TRUE + | FALSE *) + | 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 + + type value = [ + | `Assoc of (string * value) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of value list + | `Null + | `String of string + ] +end diff --git a/src/Makefile b/src/Makefile index ebf1285b0..ecbcbb31f 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,29 +1,50 @@ +.PHONY: celan + TOPFILE = rc OCAMLC = ocamlfind c OCAMLOPT = ocamlfind opt OCAMLDEP = ocamlfind dep -SOURCES = Language.ml SM.ml X86.ml Driver.ml -LIBS = #GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma +SOURCES_HEAD = Language.ml +SOURCES_GENERATED = LamaMenhir.ml LamaLexer.ml +SOURCES_TAIL = SM.ml X86.ml Driver.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) +#COMPILE_OBJS_CMO := $(COMPILE_OBJS_CMO:.mli=.cmi) +#COMPILE_OBJS_CMX := $(COMPILE_OBJS_CMX:.mli=.cmi) +LIBS = CAMLP5 = -syntax camlp5o -package GT.syntax.all,ostap.syntax PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -package GT,re,ostap -linkpkg +BFLAGS = -rectypes -package GT,re,ostap -linkpkg -w -13 OFLAGS = $(BFLAGS) -all: .depend $(TOPFILE).opt +all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt -.depend: $(SOURCES) - $(OCAMLDEP) $(PXFLAGS) *.ml > .depend +depend: $(SOURCES) + $(OCAMLDEP) $(PXFLAGS) *.ml *.mli > .depend -$(TOPFILE).opt: $(SOURCES:.ml=.cmx) +$(TOPFILE).opt: $(COMPILE_OBJS_CMX) $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) -$(TOPFILE).byte: $(SOURCES:.ml=.cmo) +$(TOPFILE).byte: $(COMPILE_OBJS_CMO) $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) $(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 $< + +LamaMenhir.cmo: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmo +LamaMenhir.cmx: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmx +Driver.cmx: LamaMenhir.cmx LamaLexer.cmx + +LamaMenhir.ml: LamaMenhir.mly #LamaMenhir.cmi + menhir --external-tokens Language.Json --explain $< + # generic rules ############### @@ -42,3 +63,5 @@ clean: %.cmx: %.ml $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< + +-include `ocamlc -where`/Makefile.config From 358101b0de21f4aba75cb47ac59b174145e6a09d Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sun, 25 Oct 2020 22:46:07 +0300 Subject: [PATCH 07/15] Added benchmark about menhir Signed-off-by: Kakadu --- src/.depend | 13 --------- src/.gitignore | 1 + src/Driver.ml | 41 +++------------------------- src/LamaLexer.mll | 3 +- src/LamaMenhir.mly | 12 ++++++-- src/Language.ml | 25 ++++++++++++++--- src/Makefile | 29 ++++++++++++-------- src/RunMenhir.ml | 21 ++++++++++++++ src/bench.ml | 68 ++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 143 insertions(+), 70 deletions(-) delete mode 100644 src/.depend create mode 100644 src/RunMenhir.ml create mode 100644 src/bench.ml diff --git a/src/.depend b/src/.depend deleted file mode 100644 index 55c7cb4de..000000000 --- a/src/.depend +++ /dev/null @@ -1,13 +0,0 @@ -Driver.cmo : X86.cmo SM.cmo Language.cmo LamaMenhir.cmi LamaLexer.cmo -Driver.cmx : X86.cmx SM.cmx Language.cmx LamaMenhir.cmx LamaLexer.cmx -LamaLexer.cmo : Language.cmo LamaMenhir.cmi -LamaLexer.cmx : Language.cmx LamaMenhir.cmx -LamaMenhir.cmo : Language.cmo LamaMenhir.cmi -LamaMenhir.cmx : Language.cmx LamaMenhir.cmi -LamaMenhir.cmi : Language.cmo -Language.cmo : -Language.cmx : -SM.cmo : Language.cmo -SM.cmx : Language.cmx -X86.cmo : SM.cmo Language.cmo -X86.cmx : SM.cmx Language.cmx diff --git a/src/.gitignore b/src/.gitignore index 22fc462aa..4ff7dc064 100644 --- a/src/.gitignore +++ b/src/.gitignore @@ -4,3 +4,4 @@ /LamaMenhir.mli /LamaMenhir.conflicts /rc.opt +/*.exe diff --git a/src/Driver.ml b/src/Driver.ml index 3fe638ed5..73bb42008 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -1,22 +1,4 @@ -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 = @@ -43,27 +25,12 @@ module ArgInfo = struct let is_interpret { interpret } = interpret let dparsetree { dparsetree } = dparsetree - 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 parse { menhir; file } = + print_endline file; + let s = Ostap.Util.read file in if not menhir - then parse file - else - let lexbuf = Lexing.from_string (Util.read file) in - let () = lexbuf.Lexing.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = file } 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) - - + then Language.run_parser s + else RunMenhir.run_parser ~filename:file s end diff --git a/src/LamaLexer.mll b/src/LamaLexer.mll index 0006f935b..4d17be93f 100644 --- a/src/LamaLexer.mll +++ b/src/LamaLexer.mll @@ -13,7 +13,7 @@ let next_line lexbuf = } } -let int = '-'? ['0'-'9'] ['0'-'9']* +let int = ['0'-'9'] ['0'-'9']* let digit = ['0'-'9'] let frac = '.' digit* let exp = ['e' 'E'] ['-' '+']? digit+ @@ -30,6 +30,7 @@ rule read = | 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 } diff --git a/src/LamaMenhir.mly b/src/LamaMenhir.mly index 5bba2479d..b7a90c0b4 100644 --- a/src/LamaMenhir.mly +++ b/src/LamaMenhir.mly @@ -30,19 +30,25 @@ | MINUS { "-" } | PERCENT { "%" } ; -%inline op_log: +%inline op_pred: | GT { ">" } | GE { ">=" } | LT { "<" } | LE { "<=" } | NEQ { "!=" } | EQEQ { "==" } + ; +%inline op_log: | LAND { "&&" } | LOR { "!!" } ; expr_log: - | l = expr_log; op = op_log; r = expr_add { Language.Expr.Binop (op,l,r) } + | 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: @@ -68,7 +74,7 @@ expr_base: | 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 } + | 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 } // | f = IDENT; args = plist(expr) { diff --git a/src/Language.ml b/src/Language.ml index b7090f39d..51b1479a4 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -214,7 +214,8 @@ module Expr = {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))} + (* | s:STRING {String (String.sub s 1 (String.length s - 2))} *) + | s:STRING {String s } | 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)} @@ -369,9 +370,6 @@ let parse = ostap (!(Definition.parse)* !(Stmt.parse)) module Json = struct type token = - (* | NULL - | TRUE - | FALSE *) | STRING of string | IDENT of string | DECIMAL of int @@ -410,3 +408,22 @@ module Json = struct | `String of string ] end + + +open Ostap + +let run_parser s = + 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/Makefile b/src/Makefile index ecbcbb31f..3c7fb32bc 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,33 +1,36 @@ .PHONY: celan TOPFILE = rc +BENCH_FILE = bench.exe OCAMLC = ocamlfind c OCAMLOPT = ocamlfind opt OCAMLDEP = ocamlfind dep SOURCES_HEAD = Language.ml SOURCES_GENERATED = LamaMenhir.ml LamaLexer.ml -SOURCES_TAIL = SM.ml X86.ml Driver.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) -#COMPILE_OBJS_CMO := $(COMPILE_OBJS_CMO:.mli=.cmi) -#COMPILE_OBJS_CMX := $(COMPILE_OBJS_CMX:.mli=.cmi) LIBS = -CAMLP5 = -syntax camlp5o -package GT.syntax.all,ostap.syntax +OCAMLFIND_PACKAGES=-package GT.syntax.all,ostap.syntax +CAMLP5 = -syntax camlp5o $(OCAMLFIND_PACKAGES) PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -package GT,re,ostap -linkpkg -w -13 +BFLAGS = -rectypes -package GT,re,ostap,benchmark -linkpkg -w -13 OFLAGS = $(BFLAGS) +MENHIR_FLAGS = --external-tokens Language.Json --explain +#MENHIR_FLAGS += --trace -all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt +all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt $(BENCH_FILE) depend: $(SOURCES) $(OCAMLDEP) $(PXFLAGS) *.ml *.mli > .depend -$(TOPFILE).opt: $(COMPILE_OBJS_CMX) - $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) +$(TOPFILE).opt: $(COMPILE_OBJS_CMX) Driver.cmx + $(OCAMLOPT) -o $@ $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) Driver.cmx + +$(BENCH_FILE): $(COMPILE_OBJS_CMX) bench.cmx + $(OCAMLOPT) -o $@ $(BFLAGS) $(OCAMLFIND_PACKAGES) -package str $(OFLAGS) $^ -$(TOPFILE).byte: $(COMPILE_OBJS_CMO) - $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) $(SOURCES:.ml=.cmo) celan: clean clean: @@ -40,10 +43,12 @@ clean: LamaMenhir.cmo: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmo LamaMenhir.cmx: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmx +RunMenhir.cmx LamaLexer.cmx: LamaMenhir.cmx Driver.cmx: LamaMenhir.cmx LamaLexer.cmx -LamaMenhir.ml: LamaMenhir.mly #LamaMenhir.cmi - menhir --external-tokens Language.Json --explain $< +LamaMenhir.ml: LamaMenhir.mly + menhir $(MENHIR_FLAGS) $< + $(RM) LamaMenhir.mli # generic rules 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..0ea80a6bd --- /dev/null +++ b/src/bench.ml @@ -0,0 +1,68 @@ +(* How many repetitions should be performed *) +let repeat = 2 +(* How much time we should spent on benchmark *) +let timeout = 2 + +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; + exit 1 + in + + let () = + let ast1 = wrap Language.run_parser in + let ast2 = wrap (RunMenhir.run_parser ~filename:file) in + + if ast1<>ast2 + then + let () = Format.printf "Ostap AST:\n%s\n\nMenhir AST:\n%s\n\n%!" + (GT.show Language.Stmt.t ast1) + (GT.show Language.Stmt.t ast2) + in + failwith "Two ASTs are not equal" + in + Gc.full_major (); + let run_ostap () = + let _: Language.Stmt.t = wrap Language.run_parser in + () + in + let run_menhir () = + let _: Language.Stmt.t = wrap (RunMenhir.run_parser ~filename:file) in + () + in + + let open Benchmark in + let res = throughputN ~style:Nil ~repeat timeout + [ ("Ostap", run_ostap, ()) + ; ("menhir", run_menhir, ()) + ] + in + tabulate res + +let () = List.iter bench_file filenames From 584149ec4505cb09af6a4ae420226ec2f9a22d51 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Thu, 29 Oct 2020 22:56:33 +0300 Subject: [PATCH 08/15] Squash Signed-off-by: Kakadu --- src/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makefile b/src/Makefile index 3c7fb32bc..2a342f994 100644 --- a/src/Makefile +++ b/src/Makefile @@ -15,7 +15,7 @@ LIBS = OCAMLFIND_PACKAGES=-package GT.syntax.all,ostap.syntax CAMLP5 = -syntax camlp5o $(OCAMLFIND_PACKAGES) PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -package GT,re,ostap,benchmark -linkpkg -w -13 +BFLAGS = -rectypes -package GT,re,ostap,benchmark -linkpkg -w -13 -g OFLAGS = $(BFLAGS) MENHIR_FLAGS = --external-tokens Language.Json --explain #MENHIR_FLAGS += --trace From d897920842ecdc071a14c6621131a91489dc16cf Mon Sep 17 00:00:00 2001 From: Kakadu Date: Mon, 9 Nov 2020 22:22:53 +0300 Subject: [PATCH 09/15] Move menhir lexemes to separate file Signed-off-by: Kakadu --- src/LamaLexer.mll | 2 +- src/Language.ml | 45 +------------------------------------------- src/Makefile | 6 +++--- src/MenhirLexemes.ml | 28 +++++++++++++++++++++++++++ src/bench.ml | 4 ++-- 5 files changed, 35 insertions(+), 50 deletions(-) create mode 100644 src/MenhirLexemes.ml diff --git a/src/LamaLexer.mll b/src/LamaLexer.mll index 4d17be93f..24e344c44 100644 --- a/src/LamaLexer.mll +++ b/src/LamaLexer.mll @@ -1,7 +1,7 @@ { open Lexing open LamaMenhir -open Language.Json +open MenhirLexemes exception SyntaxError of string diff --git a/src/Language.ml b/src/Language.ml index 51b1479a4..bf16d1bae 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -214,8 +214,7 @@ module Expr = {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))} *) - | s:STRING {String s } + | 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)} @@ -368,48 +367,6 @@ let eval (defs, body) i = (* Top-level parser *) let parse = ostap (!(Definition.parse)* !(Stmt.parse)) -module Json = struct - 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 - - type value = [ - | `Assoc of (string * value) list - | `Bool of bool - | `Float of float - | `Int of int - | `List of value list - | `Null - | `String of string - ] -end - - open Ostap let run_parser s = diff --git a/src/Makefile b/src/Makefile index 2a342f994..a40ee0fa6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -5,7 +5,7 @@ BENCH_FILE = bench.exe OCAMLC = ocamlfind c OCAMLOPT = ocamlfind opt OCAMLDEP = ocamlfind dep -SOURCES_HEAD = Language.ml +SOURCES_HEAD = MenhirLexemes.ml Language.ml SOURCES_GENERATED = LamaMenhir.ml LamaLexer.ml SOURCES_TAIL = RunMenhir.ml SM.ml X86.ml SOURCES = $(SOURCES_HEAD) $(SOURCES_GENERATED) $(SOURCES_TAIL) @@ -17,7 +17,7 @@ CAMLP5 = -syntax camlp5o $(OCAMLFIND_PACKAGES) PXFLAGS = $(CAMLP5) BFLAGS = -rectypes -package GT,re,ostap,benchmark -linkpkg -w -13 -g OFLAGS = $(BFLAGS) -MENHIR_FLAGS = --external-tokens Language.Json --explain +MENHIR_FLAGS = --external-tokens MenhirLexemes --explain #MENHIR_FLAGS += --trace all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt $(BENCH_FILE) @@ -42,7 +42,7 @@ clean: ocamllex $< LamaMenhir.cmo: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmo -LamaMenhir.cmx: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmx +LamaMenhir.cmx: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmx MenhirLexemes.cmi MenhirLexemes.cmo RunMenhir.cmx LamaLexer.cmx: LamaMenhir.cmx Driver.cmx: LamaMenhir.cmx LamaLexer.cmx 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/bench.ml b/src/bench.ml index 0ea80a6bd..d1e70bcf5 100644 --- a/src/bench.ml +++ b/src/bench.ml @@ -31,13 +31,13 @@ let bench_file file = match parse contents with | `Ok r -> snd r | `Fail s -> - Printf.eprintf "Error: %s\n" s; + Printf.eprintf "Error: %s\n%s\n\n" s (Printexc.get_backtrace ()); exit 1 in let () = - let ast1 = wrap Language.run_parser in let ast2 = wrap (RunMenhir.run_parser ~filename:file) in + let ast1 = wrap Language.run_parser in if ast1<>ast2 then From 5b24ef0a9a3aff25d44b91e909c840103a7ecf8c Mon Sep 17 00:00:00 2001 From: Kakadu Date: Wed, 11 Nov 2020 14:39:46 +0300 Subject: [PATCH 10/15] Added Opal parser combinator library to benchmarks Signed-off-by: Kakadu --- .ocamlformat | 0 src/GenParser.ml | 141 +++++++++++++++++ src/LamaAngstrom.ml | 37 +++++ src/LamaOpal.ml | 360 ++++++++++++++++++++++++++++++++++++++++++++ src/Language.ml | 20 ++- src/Makefile | 18 ++- src/bench.ml | 89 +++++++---- 7 files changed, 623 insertions(+), 42 deletions(-) create mode 100644 .ocamlformat create mode 100644 src/GenParser.ml create mode 100644 src/LamaAngstrom.ml create mode 100644 src/LamaOpal.ml diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 000000000..e69de29bb 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..933057a5b --- /dev/null +++ b/src/LamaAngstrom.ml @@ -0,0 +1,37 @@ +open Angstrom + + + +(* module Expr = struct + + let util_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) -> ostap (!(oper) {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 = f[ostap ( + {n = l } => x:opnd {c x} + | {n > l && not (nona l)} => x:inner[l+1][id] b:(-o:op[l] inner[l][o c x])? { + match b with None -> c x | Some x -> x + } + | {n > l && nona l} => x:inner[l+1][id] b:(op[l] inner[l+1][id])? { + c (match b with None -> x | Some (o, y) -> o id x y) + })] + ) + in + ostap (inner[0][id]) + + + let parse +end *) + + +let run_parser ~filename _str = `Ok ([], Language.Stmt.Skip) diff --git a/src/LamaOpal.ml b/src/LamaOpal.ml new file mode 100644 index 000000000..c2611177b --- /dev/null +++ b/src/LamaOpal.ml @@ -0,0 +1,360 @@ +open Language +open GenParser + +module OpalImpl = struct + open Opal + + module I = struct + type ('a, 'b) t = ('a, 'b) Opal.parser + + let opt p = + (* print_endline "opt asked"; + ( (p => fun x -> Some x) <|> fun s -> + print_endline "returnig none"; + return None s ) + s *) + 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 stream = + (* Printf.printf "spaces 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 -> "[]" ); *) + skip_many (one_of [ '\t'; '\r'; '\n'; ' ' ]) stream + + let eof : (char, unit) t = + fun stream -> + (* Printf.printf "eof 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 -> "[]" ); *) + (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/Language.ml b/src/Language.ml index bf16d1bae..949192933 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -192,11 +192,9 @@ module Expr = 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, + + let hack : (_*(_*(_)) list) array = + Array.map (fun (a, s) -> a, List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s ) [| @@ -206,7 +204,13 @@ module Expr = `Lefta, ["+" ; "-"]; `Lefta, ["*" ; "/"; "%"]; |] - ) + + + ostap ( + parse: + !(Ostap.Util.expr + (fun x -> x) + hack primary); primary: b:base is:(-"[" i:parse -"]" {`Elem i} @@ -305,7 +309,9 @@ module Stmt = Seq (i, While (c, Seq (b, s))) } | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} - | %"return" e:!(Expr.parse)? {Return 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)} diff --git a/src/Makefile b/src/Makefile index a40ee0fa6..d2056938e 100644 --- a/src/Makefile +++ b/src/Makefile @@ -14,21 +14,21 @@ COMPILE_OBJS_CMX := $(SOURCES:.ml=.cmx) LamaMenhir.cmx LamaLexer.cmx $(SOURCES_ LIBS = OCAMLFIND_PACKAGES=-package GT.syntax.all,ostap.syntax CAMLP5 = -syntax camlp5o $(OCAMLFIND_PACKAGES) -PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -package GT,re,ostap,benchmark -linkpkg -w -13 -g +#PXFLAGS = $(CAMLP5) +BFLAGS = -rectypes -package GT,re,ostap,benchmark,angstrom,opal -linkpkg -w -13 -g OFLAGS = $(BFLAGS) MENHIR_FLAGS = --external-tokens MenhirLexemes --explain #MENHIR_FLAGS += --trace all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt $(BENCH_FILE) -depend: $(SOURCES) - $(OCAMLDEP) $(PXFLAGS) *.ml *.mli > .depend +#depend: $(SOURCES) +# $(OCAMLDEP) $(PXFLAGS) *.ml *.mli > .depend $(TOPFILE).opt: $(COMPILE_OBJS_CMX) Driver.cmx $(OCAMLOPT) -o $@ $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) Driver.cmx -$(BENCH_FILE): $(COMPILE_OBJS_CMX) bench.cmx +$(BENCH_FILE): $(COMPILE_OBJS_CMX) GenParser.cmx LamaAngstrom.cmx LamaOpal.cmx bench.cmx $(OCAMLOPT) -o $@ $(BFLAGS) $(OCAMLFIND_PACKAGES) -package str $(OFLAGS) $^ @@ -41,10 +41,14 @@ clean: %.ml: %.mll ocamllex $< -LamaMenhir.cmo: LamaMenhir.ml LamaMenhir.cmi Language.cmi Language.cmo +SM.cmx Language.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 +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 LamaMenhir.ml: LamaMenhir.mly menhir $(MENHIR_FLAGS) $< diff --git a/src/bench.ml b/src/bench.ml index d1e70bcf5..d38bbfad4 100644 --- a/src/bench.ml +++ b/src/bench.ml @@ -1,67 +1,100 @@ (* How many repetitions should be performed *) -let repeat = 2 +let repeat = 1 + (* How much time we should spent on benchmark *) -let timeout = 2 +let timeout = 1 -let dirname,filenames = +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) + 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) + 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); + 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) + (dirname, files) -(* let filenames = ["regression/test036.expr"] *) +(* 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) = + 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 + | `Ok r -> snd r + | `Fail s -> + Printf.eprintf "Error: %s\n%s\n\n" s (Printexc.get_backtrace ()); + exit 1 in let () = - let ast2 = wrap (RunMenhir.run_parser ~filename:file) in + 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 Language.run_parser in - if ast1<>ast2 - then - let () = Format.printf "Ostap AST:\n%s\n\nMenhir AST:\n%s\n\n%!" - (GT.show Language.Stmt.t ast1) - (GT.show Language.Stmt.t ast2) - in - failwith "Two ASTs are not equal" + (* 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 Language.run_parser in + let (_ : Language.Stmt.t) = wrap Language.run_parser in () in let run_menhir () = - let _: Language.Stmt.t = wrap (RunMenhir.run_parser ~filename:file) in + 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, ()) - ] + let res = + throughputN ~style:Nil ~repeat timeout + [ + ("Ostap", run_ostap, ()); + ("menhir", run_menhir, ()); + (* ; ("angstrom", run_angstrom, ()) *) + ("opal", run_opal, ()); + ] in tabulate res From 8854c194f7ccce5f7889c3800ce4def165398a47 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Fri, 13 Nov 2020 17:01:39 +0300 Subject: [PATCH 11/15] Some preparations for other parsing libraries Signed-off-by: Kakadu --- src/LamaAngstrom.ml | 361 +++++++++++++++++++++++++++++++++++---- src/LamaOstapNoErrors.ml | 347 +++++++++++++++++++++++++++++++++++++ src/Makefile | 2 +- src/bench.ml | 8 +- 4 files changed, 684 insertions(+), 34 deletions(-) create mode 100644 src/LamaOstapNoErrors.ml diff --git a/src/LamaAngstrom.ml b/src/LamaAngstrom.ml index 933057a5b..987656681 100644 --- a/src/LamaAngstrom.ml +++ b/src/LamaAngstrom.ml @@ -1,37 +1,340 @@ -open Angstrom +(* open Language +open GenParser +module AngImpl = struct + open Angstrom + module I = struct + type nonrec ('a, 'b) t = 'b t -(* module Expr = struct + let ( => ) = ( >>| ) - let util_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) -> ostap (!(oper) {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 = f[ostap ( - {n = l } => x:opnd {c x} - | {n > l && not (nona l)} => x:inner[l+1][id] b:(-o:op[l] inner[l][o c x])? { - match b with None -> c x | Some x -> x - } - | {n > l && nona l} => x:inner[l+1][id] b:(op[l] inner[l+1][id])? { - c (match b with None -> x | Some (o, y) -> o id x y) - })] - ) - in - ostap (inner[0][id]) + 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 parse -end *) +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 run_parser ~filename _str = `Ok ([], Language.Stmt.Skip) + 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/Makefile b/src/Makefile index d2056938e..32b6cc871 100644 --- a/src/Makefile +++ b/src/Makefile @@ -28,7 +28,7 @@ all: LamaMenhir.ml LamaLexer.ml depend $(TOPFILE).opt $(BENCH_FILE) $(TOPFILE).opt: $(COMPILE_OBJS_CMX) Driver.cmx $(OCAMLOPT) -o $@ $(OFLAGS) $(LIBS:.cma=.cmxa) $(SOURCES:.ml=.cmx) Driver.cmx -$(BENCH_FILE): $(COMPILE_OBJS_CMX) GenParser.cmx LamaAngstrom.cmx LamaOpal.cmx bench.cmx +$(BENCH_FILE): $(COMPILE_OBJS_CMX) GenParser.cmx LamaOpal.cmx bench.cmx $(OCAMLOPT) -o $@ $(BFLAGS) $(OCAMLFIND_PACKAGES) -package str $(OFLAGS) $^ diff --git a/src/bench.ml b/src/bench.ml index d38bbfad4..a307b3df2 100644 --- a/src/bench.ml +++ b/src/bench.ml @@ -78,10 +78,10 @@ let bench_file file = 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_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 () From c8b38254fab7b8cee641e98335bd58eabef7c732 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sat, 14 Nov 2020 18:45:15 +0300 Subject: [PATCH 12/15] polish impleemtation Signed-off-by: Kakadu --- .ocamlformat | 0 src/LamaMenhir.mly | 20 ++----- src/LamaOpal.ml | 131 +++++++++++++++------------------------------ src/LamaOstapP5.ml | 105 ++++++++++++++++++++++++++++++++++++ src/Language.ml | 104 ----------------------------------- src/Makefile | 10 ++-- src/bench.ml | 4 +- 7 files changed, 157 insertions(+), 217 deletions(-) delete mode 100644 .ocamlformat create mode 100644 src/LamaOstapP5.ml diff --git a/.ocamlformat b/.ocamlformat deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/LamaMenhir.mly b/src/LamaMenhir.mly index b7a90c0b4..4fa3b409a 100644 --- a/src/LamaMenhir.mly +++ b/src/LamaMenhir.mly @@ -77,11 +77,6 @@ expr_base: | 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 } - // | f = IDENT; args = plist(expr) { - // match args with - // | [] -> Language.Expr.Var f - // | args -> Language.Expr.Call (f, args) - // } | LBRACK; elems = separated_list(COMMA, expr); RBRACK { Language.Expr.Array elems } ; @@ -98,7 +93,8 @@ stmts: ss = separated_nonempty_list(SEMICOLON,stmt) stmt: | SKIP { Language.Stmt.Skip } | IF; e=expr; THEN; the = stmts; - elif = elifs; els = else1?; FI + 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, @@ -114,19 +110,9 @@ stmt: | 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 = indexes; ASSGN; e=expr { Language.Stmt.Assign (x, is, e) } + | x = IDENT; is = list(LBRACK; e = expr; RBRACK { e }); ASSGN; e=expr { Language.Stmt.Assign (x, is, e) } ; -index: - | LBRACK; e = expr; RBRACK { e } - ; -indexes: xs = list(index) { xs } - ; - -elif1: ELIF; e = expr; THEN; th = stmts { (e,th) (* ???? *) }; -elifs: e = elif1* { e }; -else1: ELSE; br = stmts { br }; - arg: a = IDENT { a }; locals: LOCAL; locs = separated_list(COMMA, arg) { locs }; definition: diff --git a/src/LamaOpal.ml b/src/LamaOpal.ml index c2611177b..ff4a0dec7 100644 --- a/src/LamaOpal.ml +++ b/src/LamaOpal.ml @@ -8,11 +8,6 @@ module OpalImpl = struct type ('a, 'b) t = ('a, 'b) Opal.parser let opt p = - (* print_endline "opt asked"; - ( (p => fun x -> Some x) <|> fun s -> - print_endline "returnig none"; - return None s ) - s *) option None (p => fun x -> Some x) let guard p cond _ = p >>= fun r -> if cond r then return r else mzero @@ -35,24 +30,11 @@ module OpalImpl = struct let ( => ) = ( => ) - let spaces stream = - (* Printf.printf "spaces 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 -> "[]" ); *) - skip_many (one_of [ '\t'; '\r'; '\n'; ' ' ]) stream + let spaces = + skip_many (one_of [ '\t'; '\r'; '\n'; ' ' ]) let eof : (char, unit) t = - fun stream -> - (* Printf.printf "eof 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 -> "[]" ); *) - (spaces >>= fun _ -> eof ()) stream + (spaces >>= fun _ -> eof ()) let token s stream = (* Printf.printf "token '%s' asked\n" s; *) @@ -67,42 +49,19 @@ module OpalImpl = struct 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 string = + token "\"" *> many alpha_num <* token "\"" => fun xs -> + Printf.sprintf "%S" (implode xs) + 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 + 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 = - 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'; @@ -115,10 +74,7 @@ module OpalImpl = struct 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 lexeme l = spaces *> token l let debug msg stream = print_endline msg; @@ -201,30 +157,19 @@ module Expr (P : PExt) = struct 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 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 + match xs with [] -> failwith "bad argument" | xs -> helper xs *) let parse d = fix @@ fun self -> @@ -236,7 +181,6 @@ module Stmt (P : PExt) = struct | _ -> 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) @@ -289,20 +233,6 @@ module Stmt (P : PExt) = struct 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) @@ -317,8 +247,6 @@ module Definition (P : PExt) = struct 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 @@ -332,6 +260,31 @@ let run_parser ~filename contents = | 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 @@ -342,14 +295,14 @@ let () = failwith (Printf.sprintf "%s %d It had to succeed" __FILE__ __LINE__) | Some _ -> () -let () = +let __ () = let module S = Stmt (Helpers (OpalImpl)) in - let s = "while do skip od" 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 = "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 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 949192933..12df14653 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -187,46 +187,6 @@ module Expr = 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 - *) - - let hack : (_*(_*(_)) list) array = - 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, ["*" ; "/"; "%"]; - |] - - - ostap ( - parse: - !(Ostap.Util.expr - (fun x -> x) - hack - 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 @@ -284,58 +244,15 @@ module Stmt = | 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) with show - 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 (* The top-level definitions *) @@ -369,24 +286,3 @@ let eval (defs, body) i = body in o - -(* Top-level parser *) -let parse = ostap (!(Definition.parse)* !(Stmt.parse)) - -open Ostap - -let run_parser s = - 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/Makefile b/src/Makefile index 32b6cc871..8b64b5db5 100644 --- a/src/Makefile +++ b/src/Makefile @@ -5,9 +5,9 @@ BENCH_FILE = bench.exe OCAMLC = ocamlfind c OCAMLOPT = ocamlfind opt OCAMLDEP = ocamlfind dep -SOURCES_HEAD = MenhirLexemes.ml Language.ml +SOURCES_HEAD = MenhirLexemes.ml Language.ml LamaOstapP5.ml SOURCES_GENERATED = LamaMenhir.ml LamaLexer.ml -SOURCES_TAIL = RunMenhir.ml SM.ml X86.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) @@ -15,7 +15,7 @@ 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 -g +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 @@ -41,14 +41,14 @@ clean: %.ml: %.mll ocamllex $< -SM.cmx Language.cmx: PXFLAGS += $(CAMLP5) +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 +bench.cmx: LamaOpal.cmx LamaOstapP5.cmx LamaMenhir.cmx LamaMenhir.ml: LamaMenhir.mly menhir $(MENHIR_FLAGS) $< diff --git a/src/bench.ml b/src/bench.ml index a307b3df2..b0570200f 100644 --- a/src/bench.ml +++ b/src/bench.ml @@ -56,7 +56,7 @@ let bench_file file = () in (* Printf.printf "Calling ostap parser"; *) - let ast1 = wrap Language.run_parser in + let ast1 = wrap LamaOstapP5.run_parser in (* Printf.printf "Calling menhir parser\n"; *) let ast2 = wrap (RunMenhir.run_parser ~filename:file) in @@ -71,7 +71,7 @@ let bench_file file = in Gc.full_major (); let run_ostap () = - let (_ : Language.Stmt.t) = wrap Language.run_parser in + let (_ : Language.Stmt.t) = wrap LamaOstapP5.run_parser in () in let run_menhir () = From 9e08b3e40f98424ec1cb0d512072f42a2d314fcc Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sat, 14 Nov 2020 18:45:21 +0300 Subject: [PATCH 13/15] text added Signed-off-by: Kakadu --- README.md | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/README.md b/README.md index 552617ec3..01e511e31 100644 --- a/README.md +++ b/README.md @@ -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 +* LamaOstapP5.ml +* LamaMenhir.mly и LamaLexer.mll + +Ostap использует специальное синтаксическое расширение для написание парсера, поэтому естесственно, что размер реализации на Ostap меньше, чем на Opal. Но и там, и там, можно описывать специализированные парсеры (например, парсер арифметических выражений), использование которых может сделать код более похожим по размеру. + +Menhir позволяет параметризовывать правила другими, в том числе "анонимными" правилами, поддерживает специальный синтаксии для операций EBNF. Поэтому размер непосредственно пасрера можно сопоставить по размеру с реализацией на Ostap, за несколькими исключениями. + +* Ostap использует специальный парсер для парсинга арифметических выражений, поэтому эта часть на нём компактнее. +* Menhir использует lexer на основе OCamlLex, в Ostap это реализовано по-другому. Поэтому реализация лексической части на menhir выглядит сущетсвенно длиннее, чем на Ostap. + +#### Разбираемый язык + +Разновиность Ламы, где мы не используем определение кастомных инфиксных операторов. По идее, если их завести, то menhir будет больно. ДЮ, вы тут лучше знаете, какие там инфиксы в Ламе и почему именно будет больно. From 3fa9339e9aa9cc3d735c4796b3c4faacfe2e465e Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sat, 14 Nov 2020 18:53:36 +0300 Subject: [PATCH 14/15] Update README.md --- README.md | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 01e511e31..6c7d129ae 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: @@ -27,18 +27,18 @@ Building: Сравнивались три реализации: -* Старый[https://github.com/Kakadu/ostap/tree/master-very-old] Ostap с отключенной обработкой ошибок -* Opal[https://github.com/pyrocat101/opal] -* Menhir[http://gitlab.inria.fr/fpottier/menhir] +* [Старый](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%. В зеркальных элементах таблицы при таком подсчете будут всегда значения противоположного знака. +* Первый столбец --- название парсера +* Второй столбей --- абсолютная скорость, чем больше, тем лучше +* Третий --- таблица ускорения одного вида парсинга относительно другого. Для строки L и стобца R в ячейке `[L][R]` будет храниться ускроение, которое дает парсер L относительно R, которое вычисляется как (L-R)/R*100%. В зеркальных элементах таблицы при таком подсчете будут всегда значения противоположного знака. В итоге получилось, что LR анализатор (Menhir) работает существенно производительнее нисходящего анализа, по причинам... @@ -46,9 +46,9 @@ Opal не поддерживает человеческие сообщения Реализации находятся в файлах -* LamaOpal.ml -* LamaOstapP5.ml -* LamaMenhir.mly и LamaLexer.mll +* [LamaOpal.ml](src/LamaOpal.ml) +* [LamaOstapP5.ml](src/LamaOstapP5.ml) +* [LamaMenhir.mly](src/LamaMenhir.mly) и [LamaLexer.mll](src/LamaLexer.mll) Ostap использует специальное синтаксическое расширение для написание парсера, поэтому естесственно, что размер реализации на Ostap меньше, чем на Opal. Но и там, и там, можно описывать специализированные парсеры (например, парсер арифметических выражений), использование которых может сделать код более похожим по размеру. From 51f268fc3a01f4c2b6cc66fdf9b4568741d473df Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sat, 14 Nov 2020 19:00:21 +0300 Subject: [PATCH 15/15] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 6c7d129ae..21a59e4c0 100644 --- a/README.md +++ b/README.md @@ -59,4 +59,4 @@ Menhir позволяет параметризовывать правила др #### Разбираемый язык -Разновиность Ламы, где мы не используем определение кастомных инфиксных операторов. По идее, если их завести, то menhir будет больно. ДЮ, вы тут лучше знаете, какие там инфиксы в Ламе и почему именно будет больно. +Разновиность Ламы, где мы не используем определение кастомных инфиксных операторов. По идее, если их завести, то menhir будет больно. ДЮ, Вы тут лучше знаете, какие там инфиксы в Ламе и почему именно будет больно.