diff --git a/regression/test001.expr b/regression/test001.expr index 0f6e3568c..c5327d48e 100644 --- a/regression/test001.expr +++ b/regression/test001.expr @@ -76,4 +76,41 @@ fun f2 (p1, p2, p3) local p4, p5 { return p4 } +fun f3 (p1, p2, p3) local p4, p5 { + p4 := {}; + while (1) do + case p2[p3[0]] of + A (a, b) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + foo(p3, b, p5) + |B (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a + b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |C (a, b) -> + case P(foo(p3, p2, a), foo(p3, p2, b)) of + P (L (a), L (b)) -> p5 := L (a - b) + |P (a, b) -> p5 := foo(p3, a, b) + esac; + p4 := p5 : p4; + foo(p3, b, p5) + |D (a) -> + p5 := foo(p3, p2, a); + p4 := p5 : p4; + case p3[1][7] of + L (m) -> p3[1][7] := L (m + 1); + p3[2][m + 1] := p5 + esac + |E -> + return p4 + |a -> skip + esac + od; + return p4 +} + write(7) diff --git a/src/Driver.ml b/src/Driver.ml index 08d86316f..e72b155a7 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -30,7 +30,7 @@ let parse infile = ] s end ) - (ostap (!(Language.parse (Language.Expr.defaultInfix ())) -EOF)) + (ostap (!(Language.parse Language.Infix.default) -EOF)) let main = try diff --git a/src/Language.ml b/src/Language.ml index c67b73f5a..21adca9a6 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -260,13 +260,13 @@ module Expr = (* intrinsic (for evaluation) *) | Intrinsic of (config -> config) (* control (for control flow) *) | Control of (config -> t * config) - (* Reff : parsed expression should return value Reff (look for ":="); - Val : -//- returns simple value; - Void : parsed expression should not return any value; *) - type atr = Reff | Void | Val - let notRef x = match x with Reff -> false | _ -> true - let isVoid x = match x with Void -> true | _ -> false - let isValue x = match x with Void -> false | _ -> true (* functions for handling atribute *) + (* Available binary operators: + !! --- disjunction + && --- conjunction + ==, !=, <=, <, >=, > --- comparisons + +, - --- addition, subtraction + *, /, % --- multiplication, division, reminder + *) (* Update state *) let update st x v = @@ -400,21 +400,6 @@ module Expr = in eval env conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)]) - (* places ignore if expression should be void *) - let ignore atr expr = if isVoid atr then Ignore expr else expr - - (* semantics for default set of infixes *) - (* Available binary operators: - !! --- disjunction - && --- conjunction - ==, !=, <=, <, >=, > --- comparisons - +, - --- addition, subtraction - *, /, % --- multiplication, division, reminder - *) - - (* semantics for infixes creaed in runtime *) - let sem s = (fun x atr y -> ignore atr (Call (Var s, [x; y]))), (fun _ -> Val, Val) - (* Expression parser. You can use the following terminals: LIDENT --- a non-empty identifier a-z[a-zA-Z0-9_]* as a string @@ -422,190 +407,227 @@ module Expr = DECIMAL --- a decimal constant [0-9]+ as a string *) - let default = + (* Propagates *) + let rec propagate_ref = function + | Var x -> Ref x + | Elem (e, i) -> ElemRef (e, i) + | Seq (s1, s2) -> Seq (s1, propagate_ref s2) + | If (e, t1, t2) -> If (e, propagate_ref t1, propagate_ref t2) + | Case (e, bs) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs) + | _ -> raise (Semantic_error "not a destination") + + (* Balance values *) + let rec balance_value = function + | Array es -> Array (List.map balance_value es) + | Sexp (s, es) -> Sexp (s, List.map balance_value es) + | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) + | Elem (b, i) -> Elem (balance_value b, balance_value i) + | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) + | Length x -> Length (balance_value x) + | StringVal x -> StringVal (balance_value x) + | Call (f, es) -> Call (balance_value f, List.map balance_value es) + | Assign (d, s) -> Assign (balance_value d, balance_value s) + | Seq (l, r) -> Seq (balance_void l, balance_value r) + | If (c, t, e) -> If (balance_value c, balance_value t, balance_value e) + | Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps) + + | Return _ + | While _ + | Repeat _ + | Skip -> raise (Semantic_error "missing value") + + | e -> e + and balance_void = function + | If (c, t, e) -> If (balance_value c, balance_void t, balance_void e) + | Seq (l, r) -> Seq (balance_void l, balance_void r) + | Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps) + | While (e, s) -> While (balance_value e, balance_void s) + | Repeat (s, e) -> Repeat (balance_void s, balance_value e) + | Return (Some e) -> Return (Some (balance_value e)) + | Return None -> Return None + | Skip -> Skip + | e -> Ignore (balance_value e) + + (* ======= *) + + 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) -> 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 ostap ( + 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]) + + (* ======= *) + + ostap ( + parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)}; + basic[infix]: + !(expr + (fun x -> x) + (Array.map (fun (a, l) -> a, List.map (fun (s, f) -> ostap (- $(s)), f) l) infix) + (primary infix)); + primary[infix]: + b:base[infix] is:(-"[" i:parse[infix] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f})) * { + List.fold_left + (fun b -> + function + | `Elem i -> Elem (b, i) + | `Len -> Length b + | `Str -> StringVal b + | `Post f -> Call (Var f, [b]) + ) + b + is + }; + base[infix]: + n:DECIMAL {Const n} + | s:STRING {String (unquote s)} + | c:CHAR {Const (Char.code c)} + | "[" es:!(Util.list0)[parse infix] "]" {Array es} + | "{" es:!(Util.list0)[parse infix] "}" {match es with + | [] -> Const 0 + | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0) + } + | t:UIDENT args:(-"(" !(Util.list)[parse infix] -")")? {Sexp (t, match args with None -> [] | Some args -> args)} + | x:LIDENT s:("(" args:!(Util.list0)[parse infix] ")" {Call (Var x, args)} | empty {Var x}) {s} + + | %"skip" {Skip} + + | %"if" e:!(parse infix) + %"then" the:parse[infix] + elif:(%"elif" parse[infix] %"then" parse[infix])* + els:(%"else" parse[infix])? + %"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:parse[infix] %"do" s:parse[infix] %"od" {While (e, s)} + + | %"for" i:parse[infix] "," c:parse[infix] "," s:parse[infix] %"do" b:parse[infix] %"od" { + Seq (i, While (c, Seq (b, s))) + } + + | %"repeat" s:parse[infix] %"until" e:basic[infix] {Repeat (s, e)} + | %"return" e:basic[infix]? {Return e} + + | %"case" e:parse[infix] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)} + + | -"(" parse[infix] -")" + ) + + end + +(* Infix helpers *) +module Infix = + struct + + type t = ([`Lefta | `Righta | `Nona] * (string * (Expr.t -> Expr.t -> Expr.t)) list) array + + let name infix = + let b = Buffer.create 64 in + Buffer.add_string b "__Infix_"; + Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix; + Buffer.contents b + + let default : t = Array.map (fun (a, s) -> a, List.map (fun s -> s, - (fun x atr y -> ignore atr ( + (fun x y -> match s with - | ":" -> Sexp ("cons", [x; y]) - | "++" -> Call (Var "strcat", [x; y]) - | ":=" -> Assign (x, y) - | _ -> Binop (s, x, y)) + | ":" -> Expr.Sexp ("cons", [x; y]) + | "++" -> Expr.Call (Var "strcat", [x; y]) + | ":=" -> Expr.Assign (Expr.propagate_ref x, y) + | _ -> Expr.Binop (s, x, y) ) ) s ) [| `Righta, [":="]; `Righta, [":"]; - `Lefta , ["!!"]; - `Lefta , ["&&"]; - `Nona , ["=="; "!="; "<="; "<"; ">="; ">"]; - `Lefta , ["++"; "+" ; "-"]; - `Lefta , ["*" ; "/"; "%"]; + `Lefta , ["!!"]; + `Lefta , ["&&"]; + `Nona , ["=="; "!="; "<="; "<"; ">="; ">"]; + `Lefta , ["++"; "+" ; "-"]; + `Lefta , ["*" ; "/"; "%"]; |] - let sem_init s = (fun x atr y -> - ignore atr ( - match s with - | ":" -> Sexp ("cons", [x; y]) - | "++" -> Call (Var "strcat", [x; y]) - | ":=" -> Assign (x, y) - | _ -> Binop (s, x, y) - )), (fun _ -> (if s = ":=" then Reff else Val), Val) + exception Break of [`Ok of t | `Fail of string] - let defaultInfix : unit -> (t, atr, 'm, 'stream, 'b, 'c) Util.Infix.t = fun () -> - let infix = fst (Array.fold_left - (fun (infix, prev) (a, s) -> - let fstOp = List.hd s in - let newInfix = match Util.Infix.after (0, 0) prev fstOp a (sem_init fstOp) infix with `Ok t -> t in - (List.fold_right (fun s infix -> match Util.Infix.at (0, 0) fstOp s (sem_init s) infix with `Ok t -> t) s newInfix, fstOp) - ) - ((Util.Infix.singleton `Righta ":=" (sem_init ":=")), ":=") - [| - `Righta, [":"]; - `Lefta , ["!!"]; - `Lefta , ["&&"]; - `Lefta , ["=="; "!="; "<="; "<"; ">="; ">"]; - `Lefta , ["++"; "+" ; "-"]; - `Lefta , ["*" ; "/"; "%"]; - |] - ) in Util.Infix.setArr infix default + let find_op infix op cb ce = + try + Array.iteri (fun i (_, l) -> if List.exists (fun (s, _) -> s = op) l then raise (Break (cb i))) infix; + ce () + with Break x -> x - let left f c x a y = f (c x) a y - let right f c x a y = c (f x a y) + let no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord)) - let expr f infix opnd atr = + let sem name x y = Expr.Call (Var name, [x; y]) - let default = - Array.map (fun (a, s) -> - let g = match a with `Lefta | `Nona -> left | `Righta -> right in - let l = List.map (fun s -> s, - ((fun x atr y -> ignore atr ( - match s with - | ":" -> Sexp ("cons", [x; y]) - | "++" -> Call (Var "strcat", [x; y]) - | ":=" -> Assign (x, y) - | _ -> Binop (s, x, y)) - ), (fun _ -> (if s = ":=" then Reff else Val), Val)) - ) s in - a, - (snd (snd (List.hd l)), - (altl (List.map (fun (oper, (sema, _)) -> ostap (- $(oper) {g sema})) l), - l)) + let at coord op newp name infix = + find_op infix op + (fun i -> + `Ok (Array.init (Array.length infix) + (fun j -> + if j = i + then let (a, l) = infix.(i) in (a, (newp, sem name) :: l) + else infix.(j) + )) ) - [| - `Righta, [":="]; - `Righta, [":"]; - `Lefta , ["!!"]; - `Lefta , ["&&"]; - `Nona , ["=="; "!="; "<="; "<"; ">="; ">"]; - `Lefta , ["++"; "+" ; "-"]; - `Lefta , ["*" ; "/"; "%"]; - |] - in - let ops = Util.Infix.createArray infix in - if Array.length ops != Array.length default then failwith (Printf.sprintf "I said so: %d %s" (Array.length ops) (Array.fold_left (fun s (_, (_, (_, l))) -> s ^ (fst (List.hd l))) "" ops)); - let atrr i atr = snd (fst (snd ops.(i)) atr) in - let atrl i atr = fst (fst (snd ops.(i)) atr) in - let n = Array.length ops in - let op i = fst (snd (snd ops.(i))) in - let nona i = fst ops.(i) = `Nona in - let id x = x in - let ostap ( - inner[l][c][atr]: f[ostap ( - {n = l } => x:opnd[atr] {c x} - | {n > l && not (nona l)} => (-x:inner[l+1][id][atrl l atr] -o:op[l] y:inner[l][o c x atr][atrr l atr] | - x:inner[l+1][id][atr] {c x}) - | {n > l && nona l} => (x:inner[l+1][id][atrl l atr] o:op[l] y:inner[l+1][id][atrr l atr] {c (o id x atr y)} | - x:inner[l+1][id][atr] {c x}) - )] - ) - in - ostap (inner[0][id][atr]) + (fun _ -> no_op op coord) + let before coord op newp ass name infix = + find_op infix op + (fun i -> + `Ok (Array.init (1 + Array.length infix) + (fun j -> + if j < i + then infix.(j) + else if j = i then (ass, [newp, sem name]) + else infix.(j-1) + )) + ) + (fun _ -> no_op op coord) - ostap ( - parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} - | basic[infix][atr]; - - basic[infix][atr]: !(expr (fun x -> x) (infix) (primary infix) atr); - - primary[infix][atr]: - b:base[infix][Val] is:(-"[" i:parse[infix][Val] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f}))+ - => {match (List.hd (List.rev is)), atr with - | `Elem i, Reff -> true - | _, Reff -> false - | _, _ -> true} => - { - let lastElem = List.hd (List.rev is) in - let is = List.rev (List.tl (List.rev is)) in - let b = - List.fold_left - (fun b -> - function - | `Elem i -> Elem (b, i) - | `Len -> Length b - | `Str -> StringVal b - | `Post f -> Call (Var f, [b]) - ) - b - is - in - let res = match lastElem, atr with - | `Elem i, Reff -> ElemRef (b, i) - | `Elem i, _ -> Elem (b, i) - | `Len, _ -> Length b - | `Str, _ -> StringVal b - | `Post f, _ -> Call (Var f, [b]) - in - ignore atr res - } - | base[infix][atr]; - base[infix][atr]: - n:DECIMAL => {notRef atr} => {ignore atr (Const n)} - | s:STRING => {notRef atr} => {ignore atr (String (unquote s))} - | c:CHAR => {notRef atr} => {ignore atr (Const (Char.code c))} - | "[" es:!(Util.list0)[parse infix Val] "]" => {notRef atr} => {ignore atr (Array es)} - | "{" es:!(Util.list0)[parse infix Val] "}" => {notRef atr} => {ignore atr (match es with - | [] -> Const 0 - | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)) - } - | t:UIDENT args:(-"(" !(Util.list)[parse infix Val] -")")? => {notRef atr} => {ignore atr (Sexp (t, match args with - | None -> [] - | Some args -> args)) - } - | x:LIDENT s:( "(" args:!(Util.list0)[parse infix Val] ")" => {notRef atr} => {Call (Var x, args)} - | empty {if notRef atr then Var x else Ref x}) {ignore atr s} - - | {isVoid atr} => %"skip" {Skip} - - | %"if" e:!(parse infix Val) %"then" the:parse[infix][atr] - elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])* - %"else" els:parse[infix][atr] %"fi" - {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif els)} - | %"if" e:!(parse infix Val) %"then" the:parse[infix][Void] - elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])* - => {isVoid atr} => %"fi" - {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif Skip)} - - | %"while" e:parse[infix][Val] %"do" s:parse[infix][Void] - => {isVoid atr} => %"od" {While (e, s)} - - | %"for" i:parse[infix][Void] "," c:parse[infix][Val] "," s:parse[infix][Void] %"do" b:parse[infix][Void] => {isVoid atr} => %"od" - {Seq (i, While (c, Seq (b, s)))} - - | %"repeat" s:parse[infix][Void] %"until" e:basic[infix][Val] - => {isVoid atr} => {Repeat (s, e)} - | %"return" e:basic[infix][Val]? => {isVoid atr} => {Return e} - - | %"case" e:parse[infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix][atr])] %"esac" - {Case (e, bs)} - | %"case" e:parse[infix][Val] %"of" bs:(!(Pattern.parse) -"->" parse[infix][Void]) => {isVoid atr} => %"esac" - {Case (e, [bs])} - - | -"(" parse[infix][atr] -")" - ) + let after coord op newp ass name infix = + find_op infix op + (fun i -> + `Ok (Array.init (1 + Array.length infix) + (fun j -> + if j <= i + then infix.(j) + else if j = i+1 then (ass, [newp, sem name]) + else infix.(j-1) + )) + ) + (fun _ -> no_op op coord) end @@ -619,23 +641,23 @@ module Definition = ostap ( arg : LIDENT; position[ass][coord][newp]: - %"at" s:STRING {Util.Infix.at coord (unquote s) newp} - | f:(%"before" {Util.Infix.before} | %"after" {Util.Infix.after}) s:STRING {f coord (unquote s) newp ass}; + %"at" s:STRING {Infix.at coord (unquote s) newp} + | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass}; head[infix]: %"fun" name:LIDENT {name, infix} | ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta}) l:$ op:(s:STRING {unquote s}) md:position[ass][l#coord][op] { - let name = Util.Infix.name op in - match md (Expr.sem name) infix with + let name = Infix.name op in + match md name infix with | `Ok infix' -> name, infix' | `Fail msg -> raise (Semantic_error msg) }; parse[infix]: <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")" locs:(%"local" !(Util.list arg))? - "{" body:!(Expr.parse infix' Void) "}" { - (name, (args, (match locs with None -> [] | Some l -> l), body)), infix' + "{" body:!(Expr.parse infix') "}" { + (name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix' } ) @@ -674,7 +696,7 @@ let eval (defs, body) i = (* Top-level parser *) ostap ( - parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse (infix') Void) {defs, body}; + parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body}; definitions[infix]: <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''} | empty {[], infix}