From 8f00033fa9e9871a7ab7fa74dbe7817fe85db41f Mon Sep 17 00:00:00 2001 From: kverty Date: Mon, 27 Jan 2020 03:39:55 +0300 Subject: [PATCH] Language.ml new memoization errors fixed --- src/Language.ml | 178 ++++++++++++++++++++++++------------------------ 1 file changed, 89 insertions(+), 89 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index 85989c4fa..1098b5096 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -15,12 +15,12 @@ module Subst = module H = Hashtbl.Make (struct type t = string let hash = Hashtbl.hash let equal = (=) end) let tab = (H.create 1024 : string H.t) - + let attach infix op = H.add tab infix op let subst id = match H.find_opt tab id with None -> id | Some op -> op - + end - + let infix_name infix = let b = Buffer.create 64 in Buffer.add_string b "i__Infix_"; @@ -28,7 +28,7 @@ let infix_name infix = let s = Buffer.contents b in Subst.attach s ("infix " ^ infix); s - + let sys_infix_name infix = let b = Buffer.create 64 in Buffer.add_string b "s__Infix_"; @@ -46,15 +46,15 @@ module Loc = module H = Hashtbl.Make (struct type t = string let hash = Hashtbl.hash let equal = (==) end) let tab = (H.create 1024 : t H.t) - + let attach s loc = H.add tab s loc - let get = H.find_opt tab - + let get = H.find_opt tab + end let report_error ?(loc=None) str = raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c)) - + (* Values *) module Value = struct @@ -66,7 +66,7 @@ module Value = | Arg of int | Access of int | Fun of string - with show, html + with show, html @type ('a, 'b) t = | Empty @@ -147,7 +147,7 @@ module Builtin = let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"] let bindings () = List.map (fun name -> name, Value.Builtin name) list let names = List.map (fun name -> name, false) list - + let eval (st, i, o, vs) args = function | "read" -> (match i with z::i' -> (st, i', o, (Value.of_int z)::vs) | _ -> failwith "Unexpected end of input") | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs) @@ -193,14 +193,14 @@ module State = (if l >= n then st'' else st), l+1 in fst @@ inner n st - + (* Undefined state *) let undefined x = report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" (Subst.subst x)) (* Create a state from bindings list *) let from_list l = fun x -> try List.assoc x l with Not_found -> report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" (Subst.subst x)) - + (* Bind a variable to a value in a state *) let bind x v s = fun y -> if x = y then v else s y @@ -212,11 +212,11 @@ module State = (* Scope operation: checks if a name designates variable *) let is_var x s = try List.assoc x s with Not_found -> false - + (* Update: non-destructively "modifies" the state s by binding the variable x to value v and returns the new state w.r.t. a scope *) - let update x v s = + let update x v s = let rec inner = function | I -> report_error "uninitialized state" | G (scope, s) -> @@ -230,12 +230,12 @@ module State = else report_error ~loc:(Loc.get x) (Printf.sprintf "name \"%s\" does not designate a variable" (Subst.subst x)) else L (scope, s, inner enclosing) in - inner s + inner s (* Evals a variable in a state w.r.t. a scope *) let rec eval s x = match s with - | I -> report_error "uninitialized state" + | I -> report_error "uninitialized state" | G (_, s) -> s x | L (scope, s, enclosing) -> if in_scope x scope then s x else eval enclosing x @@ -248,7 +248,7 @@ module State = in let g = get st in let rec recurse = function - | I -> g + | I -> g | L (scope, s, e) -> L (scope, s, recurse e) | G _ -> g in @@ -257,7 +257,7 @@ module State = (* Creates a new scope, based on a given state *) let rec enter st xs = match st with - | I -> report_error "uninitialized state" + | I -> report_error "uninitialized state" | G _ -> L (xs, undefined, st) | L (_, _, e) -> enter e xs @@ -273,7 +273,7 @@ module State = (* Observe a variable in a state and print it to stderr *) let observe st x = Printf.eprintf "%s=%s\n%!" x (try show (Value.t) (fun _ -> "") (fun _ -> "") @@ eval st x with _ -> "undefined") - + end (* Patterns *) @@ -299,14 +299,14 @@ module Pattern = (* Pattern parser *) ostap ( parse: - !(Ostap.Util.expr - (fun x -> x) - (Array.map (fun (a, s) -> + !(Ostap.Util.expr) + [fun x -> x] + [Array.map (fun (a, s) -> a, List.map (fun s -> ostap(- $(s)), (fun x y -> Sexp ("cons", [x; y]))) s) [|`Righta, [":"]|] - ) - primary); + ] + [primary]; primary: %"_" {Wildcard} | t:UIDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} @@ -354,7 +354,7 @@ module Expr = (* array *) | Array of t list (* string *) | String of string (* S-expressions *) | Sexp of string * t list - (* variable *) | Var of string + (* variable *) | Var of string (* reference (aka "lvalue") *) | Ref of string (* binary operator *) | Binop of string * t * t (* element extraction *) | Elem of t * t @@ -372,17 +372,17 @@ module Expr = (* return statement *) | Return of t option (* ignore a value *) | Ignore of t (* unit value *) | Unit - (* entering the scope *) | Scope of (string * decl) list * t + (* entering the scope *) | Scope of (string * decl) list * t (* lambda expression *) | Lambda of string list * t (* leave a scope *) | Leave (* intrinsic (for evaluation) *) | Intrinsic of (t config, t config) arrow (* control (for control flow) *) | Control of (t config, t * t config) arrow and decl = [`Local | `Public | `Extern | `PublicExtern ] * [`Fun of string list * t | `Variable of t option] with show, html - + let notRef = function Reff -> false | _ -> true let isVoid = function Void | Weak -> true | _ -> false - + (* Available binary operators: !! --- disjunction && --- conjunction @@ -392,7 +392,7 @@ module Expr = *) (* Update state *) - let update st x v = + let update st x v = match x with | Value.Var (Value.Global x) -> State.update x v st | Value.Elem (x, i) -> Value.update_elem x i v; st @@ -444,11 +444,11 @@ module Expr = let print_values vs = Printf.eprintf "Values:\n%!"; List.iter (fun v -> Printf.eprintf "%s\n%!" @@ show(Value.t) (fun _ -> "") (fun _ -> "") v) vs; - Printf.eprintf "End Values\n%!" + Printf.eprintf "End Values\n%!" in match expr with | Lambda (args, body) -> - eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k + eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k | Scope (defs, body) -> let vars, body, bnds = List.fold_left @@ -513,10 +513,10 @@ module Expr = let st' = State.push (State.leave st closure.(0)) (State.from_list @@ List.combine args es) (List.map (fun x -> x, true) args) in let st'', i', o', vs'' = eval (st', i, o, []) Skip body in closure.(0) <- st''; - (State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs') + (State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs') | _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "") (fun _ -> "") f)) ))])) - + | Leave -> eval (State.drop st, i, o, vs) Skip k | Assign (x, e) -> eval conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))]) @@ -553,7 +553,7 @@ module Expr = | Pattern.Boxed , Value.Sexp (_, _) | Pattern.StringTag , Value.String _ | Pattern.ArrayTag , Value.Array _ - | Pattern.ClosureTag , Value.Closure _ + | Pattern.ClosureTag , Value.Closure _ | Pattern.SexpTag , Value.Sexp (_, _) -> st | _ -> None and match_list ps vs s = @@ -582,7 +582,7 @@ module Expr = match atr with | Weak -> Seq (expr, Const 0) | _ -> expr - + (* semantics for infixes created in runtime *) let sem s = (fun x atr y -> ignore atr (Call (Var s, [x; y]))), (fun _ -> Val, Val) @@ -599,7 +599,7 @@ module Expr = 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 expr f ops opnd atr = + let expr = Mem.memoize (fun f -> Mem.memoize (fun ops -> Mem.memoize (fun opnd -> let ops = Array.map (fun (assoc, (atrs, list)) -> @@ -624,32 +624,32 @@ module Expr = )] ) in - ostap (inner[0][id][atr]) - + ostap (inner[0][id][atr])))) + let atr' = atr let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord)) - + (* UGLY! *) let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Pervasives.ref (fun _ _ -> invalid_arg "must not happen") - + (* ======= *) ostap ( parse[def][infix][atr]: h:basic[def][infix][Void] -";" t:parse[def][infix][atr] {Seq (h, t)} | basic[def][infix][atr]; scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)}; - basic[def][infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, _, f) -> ostap (- $(s)), f) l)) infix) (primary def infix) atr); + basic[def][infix][atr]: !(expr)[fun x -> x][Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, _, f) -> ostap (- $(s)), f) l)) infix][primary def infix][atr]; primary[def][infix][atr]: s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)}) b:base[def][infix][Val] is:( "." f:LIDENT args:(-"(" !(Util.list)[parse def infix Val] -")")? {`Post (f, args)} | "." %"length" {`Len} | "." %"string" {`Str} - | "[" i:parse[def][infix][Val] "]" {`Elem i} - | "(" args:!(Util.list0)[parse def infix Val] ")" {`Call args} + | "[" i:parse[def][infix][Val] "]" {`Elem i} + | "(" args:(!(Util.list0)[parse def infix Val]) ")" {`Call args} )+ => {match (List.hd (List.rev is)), atr with - | `Elem i, Reff -> true + | `Elem i, Reff -> true | _, Reff -> false | _, _ -> true} => { @@ -672,7 +672,7 @@ module Expr = | `Len -> Length b | `Str -> StringVal b | `Post (f, args) -> Call (Var f, b :: match args with None -> [] | Some args -> args) - | `Call args -> (match b with Sexp _ -> invalid_arg "retry!" | _ -> Call (b, args)) + | `Call args -> (match b with Sexp _ -> invalid_arg "retry!" | _ -> Call (b, args)) ) b is @@ -692,9 +692,9 @@ module Expr = l:$ n:DECIMAL => {notRef atr} :: (not_a_reference l) => {ignore atr (Const n)} | l:$ s:STRING => {notRef atr} :: (not_a_reference l) => {ignore atr (String s)} | l:$ c:CHAR => {notRef atr} :: (not_a_reference l) => {ignore atr (Const (Char.code c))} - - | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c} - + + | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c} + | l:$ %"infix" s:INFIX => {notRef atr} :: (not_a_reference l) => { if ((* UGLY! *) Obj.magic !predefined_op) infix s then ( @@ -702,16 +702,16 @@ module Expr = then report_error ~loc:(Some l#coord) (Printf.sprintf "can not capture predefined operator \":=\"") else let name = sys_infix_name s in Loc.attach name l#coord; ignore atr (Var name) - ) + ) else ( let name = infix_name s in Loc.attach name l#coord; ignore atr (Var name) ) } - | l:$ %"fun" "(" args:!(Util.list0)[ostap (l:$ x:LIDENT {Loc.attach x l#coord; x})] ")" + | 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)} - | -"{" scope[def][infix][atr][parse def] -"}" - | l:$ "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} :: (not_a_reference l) => {ignore atr (match es with + | l:$ "[" es:(!(Util.list0)[parse def infix Val]) "]" => {notRef atr} :: (not_a_reference l) => {ignore atr (Array es)} + | -"{" scope[def][infix][atr][parse def] -"}" + | l:$ "{" es:(!(Util.list0)[parse def infix Val]) "}" => {notRef atr} :: (not_a_reference l) => {ignore atr (match es with | [] -> Const 0 | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)) } @@ -719,7 +719,7 @@ module Expr = | None -> [] | Some args -> args)) } - | l:$ x:LIDENT {Loc.attach x l#coord; if notRef atr then ignore atr (Var x) else Ref x} + | l:$ x:LIDENT {Loc.attach x l#coord; if notRef atr then ignore atr (Var x) else Ref x} | {isVoid atr} => %"skip" {materialize atr Skip} @@ -736,8 +736,8 @@ module Expr = | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {materialize atr (Repeat (s, e))} | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e} - | %"case" l:$ e:parse[def][infix][Val] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])] %"esac" - {Case (e, bs, l#coord, atr)} + | %"case" l:$ e:parse[def][infix][Val] %"of" bs:(!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])]) %"esac" + {Case (e, bs, l#coord, atr)} | -"(" parse[def][infix][atr] -")" ) @@ -746,11 +746,11 @@ module Expr = constexpr: n:DECIMAL {Const n} | s:STRING {String s} - | c:CHAR {Const (Char.code c)} + | c:CHAR {Const (Char.code c)} | %"true" {Const 1} - | %"false" {Const 0} - | "[" es:!(Util.list0)[constexpr] "]" {Array es} - | "{" es:!(Util.list0)[constexpr] "}" {match es with [] -> Const 0 | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)} + | %"false" {Const 0} + | "[" es:(!(Util.list0)[constexpr]) "]" {Array es} + | "{" es:(!(Util.list0)[constexpr]) "}" {match es with [] -> Const 0 | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)} | t:UIDENT args:(-"(" !(Util.list)[constexpr] -")")? {Sexp (t, match args with None -> [] | Some args -> args)} | l:$ x:LIDENT {Loc.attach x l#coord; Var x} | -"(" constexpr -")" @@ -762,13 +762,13 @@ module Expr = (* Infix helpers *) module Infix = struct - + @type kind = Predefined | Public | Local with show @type ass = [`Lefta | `Righta | `Nona] with show @type loc = [`Before of string | `After of string | `At of string] with show @type export = (ass * string * loc) list with show @type showable = (ass * string * kind) list array with show - + type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * kind * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array let show_infix (infix : t) = @@ -776,7 +776,7 @@ module Infix = let extract_exports infix = let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in - let exported = + let exported = Array.map (fun (ass, (_, ops)) -> (ass, List.rev @@ List.map (fun (s, kind, _) -> s, kind) @@ List.filter (function (_, Public, _) | (_, Predefined, _) -> true | _ -> false) ops) @@ -792,8 +792,8 @@ module Infix = let loc' = match tl with [] -> `After s | _ -> `At s in (fun again -> match kind with - | Public -> again (loc', (ass, s, loc) :: acc) - | _ -> again (loc', acc) + | Public -> again (loc', (ass, s, loc) :: acc) + | _ -> again (loc', acc) ) (match tl with [] -> fun acc -> acc | _ -> fun acc -> inner acc tl) in @@ -803,9 +803,9 @@ module Infix = exported in List.rev exports - let is_predefined op = + let is_predefined op = List.exists (fun x -> op = x) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"; ":="] - + (* List.iter (fun op -> Printf.eprintf "F,%s\n" (sys_infix_name op); @@ -818,7 +818,7 @@ module Infix = Printf.eprintf "}\n\n" *) ) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"] *) - + let default : t = Array.map (fun (a, s) -> a, @@ -836,14 +836,14 @@ module Infix = |] exception Break of [`Ok of t | `Fail of string] - + let find_op infix op cb ce = try Array.iteri (fun i (_, (_, l)) -> if List.exists (fun (s, _, _) -> s = op) l then raise (Break (cb i))) infix; ce () with Break x -> x - let predefined_op infix op = + let predefined_op infix op = Array.exists (fun (_, (_, l)) -> List.exists (fun (s, p, _) -> s = op && p = Predefined) l @@ -852,11 +852,11 @@ module Infix = (* UGLY!!! *) Expr.predefined_op := (Obj.magic) predefined_op;; - - let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op) + + let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op) let kind_of = function true -> Public | _ -> Local - + let at coord op newp public (sem, _) (infix : t) = find_op infix op (fun i -> @@ -905,9 +905,9 @@ module Definition = type t = string * [`Fun of string list * Expr.t | `Variable of Expr.t option] let unopt_mod = function None -> `Local | Some m -> m - + ostap ( - arg : l:$ x:LIDENT {Loc.attach x l#coord; x}; + arg : l:$ x:LIDENT {Loc.attach x l#coord; x}; position[pub][ass][coord][newp]: %"at" s:INFIX {match ass with | `Nona -> Infix.at coord s newp pub @@ -931,18 +931,18 @@ module Definition = Loc.attach name l#coord; name, (`Public, `Variable (Some value)) }; - constdef: %"public" d:!(Util.list (const_var)) ";" {d}; + constdef: %"public" d:(!(Util.list)[const_var]) ";" {d}; (* end of the workaround *) local_var[m][infix][expr][def]: l:$ name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? { - Loc.attach name l#coord; + Loc.attach name l#coord; match m, value with | `Extern, Some _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "initial value for an external variable \"%s\" can not be specified" name) | _ -> name, (m,`Variable value) }; parse[infix][expr][expr'][def]: m:(%"local" {`Local} | %"public" e:(%"external")? {match e with None -> `Public | Some _ -> `PublicExtern} | %"external" {`Extern}) - locs:!(Util.list (local_var m infix expr' def)) ";" {locs, infix} - | - <(m, orig_name, name, infix', flag)> : head[infix] -"(" -args:!(Util.list0 arg) -")" + locs:(!(Util.list)[local_var m infix expr' def]) ";" {locs, infix} + | - <(m, orig_name, name, infix', flag)> : head[infix] -"(" -args:(!(Util.list0)[arg]) -")" (l:$ "{" body:expr[def][infix'][Expr.Weak] "}" { if flag && List.length args != 2 then report_error ~loc:(Some l#coord) "infix operator should accept two arguments"; match m with @@ -951,16 +951,16 @@ module Definition = } | l:$ ";" { match m with - | `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix' + | `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix' | _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "missing body for the function/infix \"%s\"" orig_name) - }) + }) ) end - + module Interface = struct - + (* Generates an interface file. *) let gen ((imps, ifxs), p) = let buf = Buffer.create 256 in @@ -978,7 +978,7 @@ module Interface = | _ -> () ) decls; - | _ -> ()); + | _ -> ()); List.iter (function (ass, op, loc) -> let append_op op = append "\""; append op; append "\"" in @@ -989,7 +989,7 @@ module Interface = append ";\n" ) ifxs; Buffer.contents buf - + (* Read an interface file *) let read fname = let ostap ( @@ -1010,13 +1010,13 @@ module Interface = inherit Util.Lexers.ident [] s inherit Util.Lexers.string s inherit Util.Lexers.skip [Matcher.Skip.whitespaces " \t\n"] s - end) + end) (ostap (interface -EOF)) with | `Ok intfs -> Some intfs | `Fail er -> report_error (Printf.sprintf "malformed interface file \"%s\": %s" fname er) ) - with Sys_error _ -> None + with Sys_error _ -> None let find import paths = let rec inner = function @@ -1047,14 +1047,14 @@ let eval (_, expr) i = (* Top-level parser *) ostap ( - imports[cmd]: l:$ is:(%"import" !(Util.list (ostap (UIDENT))) -";")* { + imports[cmd]: l:$ is:(%"import" !(Util.list)[ostap (UIDENT)]) -";")* { let is = "Std" :: List.flatten is in let infix = List.fold_left (fun infix import -> List.fold_left (fun infix item -> - let insert name infix md = + let insert name infix md = let name = infix_name name in match md (Expr.sem name) infix with | `Ok infix' -> infix'