From 25ec856fba70feeefca2b12edfd3262070203e4d Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 14 Jan 2020 03:30:17 +0300 Subject: [PATCH] Better infixes --- regression/test053.expr | 6 ++--- regression/test060.expr | 2 +- regression/test064.expr | 4 +-- regression/test067.expr | 2 +- regression/test087.expr | 6 ++--- regression/test092.expr | 2 +- regression/test095.expr | 4 +-- regression/test098.expr | 2 +- src/Driver.ml | 1 + src/Language.ml | 59 ++++++++++++++++++++++++++++------------- src/SM.ml | 2 +- 11 files changed, 56 insertions(+), 34 deletions(-) diff --git a/regression/test053.expr b/regression/test053.expr index fc36c038a..da09c0534 100644 --- a/regression/test053.expr +++ b/regression/test053.expr @@ -1,6 +1,6 @@ local n; -infix "===" at "==" (v1, v2) { +infix === at == (v1, v2) { local s1, s2, i; s1 := v1.string; @@ -17,14 +17,14 @@ infix "===" at "==" (v1, v2) { fi } -infix "?" before "+" (v, l) { +infix ? before + (v, l) { case l of {} -> return 0 | h : tl -> if h === v then return 1 else return (v ? tl) fi esac } -infix "+++" at "+" (l1, l2) { +infix +++ at + (l1, l2) { case l1 of {} -> return l2 | h : tl -> return (h : tl +++ l2) diff --git a/regression/test060.expr b/regression/test060.expr index 8d7f16d71..82b131056 100644 --- a/regression/test060.expr +++ b/regression/test060.expr @@ -1,5 +1,5 @@ fun f (l) { - infix "===" at "==" (a, b) { + infix === at == (a, b) { return a == b } diff --git a/regression/test064.expr b/regression/test064.expr index 9097b1ab1..114923597 100644 --- a/regression/test064.expr +++ b/regression/test064.expr @@ -1,5 +1,5 @@ -infix "++" at "+" (a, b) {return a+b} +infix ++ at + (a, b) {return a+b} local x = read (); -write (infix "++" (2, 3)) \ No newline at end of file +write (infix ++ (2, 3)) \ No newline at end of file diff --git a/regression/test067.expr b/regression/test067.expr index 78a03eb11..943bee593 100644 --- a/regression/test067.expr +++ b/regression/test067.expr @@ -1,4 +1,4 @@ -infixr "**" before "*" (f, g) { +infixr ** before * (f, g) { return fun (x) {return f (g (x))} } diff --git a/regression/test087.expr b/regression/test087.expr index 81c8ee53f..00f8c509d 100644 --- a/regression/test087.expr +++ b/regression/test087.expr @@ -1,6 +1,6 @@ local n; -infix "===" at "==" (v1, v2) { +infix === at == (v1, v2) { local s1, s2, i; s1 := v1.string; @@ -17,14 +17,14 @@ infix "===" at "==" (v1, v2) { fi } -infix "?" before "+" (v, l) { +infix ? before + (v, l) { case l of {} -> 0 | h : tl -> if h === v then 1 else (v ? tl) fi esac } -infix "+++" at "+" (l1, l2) { +infix +++ at + (l1, l2) { case l1 of {} -> l2 | h : tl -> (h : tl +++ l2) diff --git a/regression/test092.expr b/regression/test092.expr index 261881c89..2b85c8504 100644 --- a/regression/test092.expr +++ b/regression/test092.expr @@ -1,5 +1,5 @@ fun f (l) { - infix "===" at "==" (a, b) { + infix === at == (a, b) { a == b } diff --git a/regression/test095.expr b/regression/test095.expr index 4e9d3723e..7be485fc1 100644 --- a/regression/test095.expr +++ b/regression/test095.expr @@ -1,5 +1,5 @@ -infix "++" at "+" (a, b) { a+b} +infix ++ at + (a, b) { a+b} local x = read (); -write (infix "++" (2, 3)) \ No newline at end of file +write (infix ++ (2, 3)) \ No newline at end of file diff --git a/regression/test098.expr b/regression/test098.expr index bb682c860..e28fe3226 100644 --- a/regression/test098.expr +++ b/regression/test098.expr @@ -1,4 +1,4 @@ -infixr "**" before "*" (f, g) { +infixr ** before * (f, g) { fun (x) { f (g (x))} } diff --git a/src/Driver.ml b/src/Driver.ml index bf5b92df1..601dc49f1 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -22,6 +22,7 @@ let parse cmd = inherit Util.Lexers.decimal s inherit Util.Lexers.string s inherit Util.Lexers.char s + inherit Util.Lexers.infix s inherit Util.Lexers.lident kws s inherit Util.Lexers.uident kws s inherit Util.Lexers.skip [ diff --git a/src/Language.ml b/src/Language.ml index 156c1016e..474fc1831 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -8,6 +8,18 @@ open GT (* Opening a library for combinator-based syntax analysis *) open Ostap open Combinators + +let infix_name infix = + let b = Buffer.create 64 in + Buffer.add_string b "i__Infix_"; + Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix; + Buffer.contents b + +let sys_infix_name infix = + let b = Buffer.create 64 in + Buffer.add_string b "s__Infix_"; + Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix; + Buffer.contents b exception Semantic_error of string @@ -167,7 +179,13 @@ module State = fst @@ inner n st (* Undefined state *) - let undefined x = report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x) + let undefined x = +(* let ops = + List.map (fun op -> infix_name op, op) + + in + try Value.Var (Value.Fun (List.assoc x ops)) with + Not_found -> *) report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x) (* Create a state from bindings list *) let from_list l = fun x -> try List.assoc x l with Not_found -> report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x) @@ -187,7 +205,7 @@ module State = (* Update: non-destructively "modifies" the state s by binding the variable x to value v and returns the new state w.r.t. a scope *) - let update x v s = + let update x v s = let rec inner = function | I -> report_error "uninitialized state" | G (scope, s) -> @@ -404,12 +422,6 @@ module Expr = let seq x = function Skip -> x | y -> Seq (x, y) - let infix_name infix = - let b = Buffer.create 64 in - Buffer.add_string b "i__Infix_"; - Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix; - Buffer.contents b - let schedule_list h::tl = List.fold_left seq h tl @@ -568,7 +580,7 @@ module Expr = match s with | ":" -> Sexp ("cons", [x; y]) | ":=" -> Assign (x, y) - | _ -> Binop (s, x, y) + | _ -> Binop (s, x, y) ) (* ======= *) @@ -669,7 +681,7 @@ module Expr = | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c} - | l:$ %"infix" s:STRING => {notRef atr} :: (not_a_reference l) => {ignore atr (Var (infix_name s))} + | l:$ %"infix" s:INFIX => {notRef atr} :: (not_a_reference l) => {let name = infix_name s in Loc.attach name l#coord; ignore atr (Var name)} | l:$ %"fun" "(" args:!(Util.list0)[ostap (l:$ x:LIDENT {Loc.attach x l#coord; x})] ")" "{" body:scope[def][infix][Weak][parse def] "}"=> {notRef atr} :: (not_a_reference l) => {ignore atr (Lambda (args, body))} | l:$ "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} :: (not_a_reference l) => {ignore atr (Array es)} @@ -714,9 +726,13 @@ module Infix = @type ass = [`Lefta | `Righta | `Nona] with show @type loc = [`Before of string | `After of string | `At of string] with show @type export = (ass * string * loc) list with show - + @type showable = (ass * string * kind) list array with show + type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * kind * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array + let show_infix (infix : t) = + show(showable) @@ Array.map (fun (ass, (_, l)) -> List.map (fun (str, kind, _) -> ass, str, kind) l) infix + let extract_exports infix = let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in let exported = @@ -745,6 +761,9 @@ module Infix = (`Before ":=", []) exported in List.rev exports + + let is_predefined op = + List.exists (fun x -> op = x) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"; ":="] let default : t = Array.map (fun (a, s) -> @@ -780,7 +799,7 @@ module Infix = `Ok (Array.init (Array.length infix) (fun j -> if j = i - then let (a, (atr, l)) = infix.(i) in (a, (atr, ((newp, kind_of public, sem) :: l))) + then let (a, (atr, l)) = infix.(i) in (a, ( (*atr*) (fun _ -> Expr.Val, Expr.Val), ((newp, kind_of public, sem) :: (List.filter (fun (op', _, _) -> op' <> newp) l)))) else infix.(j) )) ) @@ -826,17 +845,19 @@ module Definition = ostap ( arg : l:$ x:LIDENT {Loc.attach x l#coord; x}; position[pub][ass][coord][newp]: - %"at" s:STRING {match ass with - | `Nona -> Infix.at coord s newp pub - | _ -> report_error ~loc:(Some coord) (Printf.sprintf "associativity for infix \"%s\" can not be specified (it is inherited from that for \"%s\")" newp s) + %"at" s:INFIX {match ass with + | `Nona -> Infix.at coord s newp pub + | _ -> report_error ~loc:(Some coord) (Printf.sprintf "associativity for infix \"%s\" can not be specified (it is inherited from that for \"%s\")" newp s) } - | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord s newp ass pub}; + | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:INFIX {f coord s newp ass pub}; head[infix]: m:(%"external" {`Extern} | %"public" e:(%"external")? {match e with None -> `Public | _ -> `PublicExtern})? %"fun" l:$ name:LIDENT {Loc.attach name l#coord; unopt_mod m, name, name, infix} | m:(%"public" {`Public})? ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta}) - l:$ op:(s:STRING {s}) + l:$ op:(s:INFIX {s}) md:position[match m with Some _ -> true | _ -> false][ass][l#coord][op] { - let name = Expr.infix_name op in + if m <> None && Infix.is_predefined op then report_error ~loc:(Some l#coord) (Printf.sprintf "redefinition of standard infix operator \"%s\" can not be exported" op); + let name = infix_name op in + Loc.attach name l#coord; match md (Expr.sem name) infix with | `Ok infix' -> unopt_mod m, op, name, infix' | `Fail msg -> report_error ~loc:(Some l#coord) msg @@ -962,7 +983,7 @@ ostap ( List.fold_left (fun infix item -> let insert name infix md = - let name = Expr.infix_name name in + let name = infix_name name in match md (Expr.sem name) infix with | `Ok infix' -> infix' | `Fail msg -> report_error msg diff --git a/src/SM.ml b/src/SM.ml index 29a625281..dbb157396 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -807,7 +807,7 @@ let compile cmd ((imports, infixes), p) = let n = List.length brs - 1 in let lfail, env = env#get_label in let lexp , env = env#get_label in - let env , fe , se = compile_expr lexp env e in + let env , fe , se = compile_expr lexp env e in let env , _, _, code, fail = List.fold_left (fun ((env, lab, i, code, continue) as acc) (p, s) ->