st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-08 15:58:47 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Language.ml new memoization errors fixed

Browse source
This commit is contained in:
kverty 2020-01-27 03:39:55 +03:00
parent d93995c444
commit 8f00033fa9
1 changed files with 89 additions and 89 deletions
Download patch file Download diff file Expand all files Collapse all files

178
src/Language.ml
View file

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