mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-08 15:58:47 +00:00
Language.ml new memoization errors fixed
This commit is contained in:
kverty
parent
d93995c444
commit
8f00033fa9
1 changed files with 89 additions and 89 deletions
178
src/Language.ml
178
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 _ -> "<expr>") (fun _ -> "<state>") @@ 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 _ -> "<expr>") (fun _ -> "<state>") 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 _ -> "<expr>") (fun _ -> "<state>") 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'
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue