mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-09 16:28:47 +00:00
Merge pull request #2 from kverty/post-historic
Infix moved to Ostap; atribute added in module Expr
This commit is contained in:
Dmitry Boulytchev
GitHub
commit
a24866cc6f
2 changed files with 202 additions and 298 deletions
|
|
@ -30,32 +30,32 @@ let parse infile =
|
|||
] s
|
||||
end
|
||||
)
|
||||
(ostap (!(Language.parse Language.Infix.default) -EOF))
|
||||
(ostap (!(Language.parse Language.Expr.defaultInfix) -EOF))
|
||||
|
||||
let main =
|
||||
try
|
||||
let interpret = Sys.argv.(1) = "-i" in
|
||||
let stack = Sys.argv.(1) = "-s" in
|
||||
let to_compile = not (interpret || stack) in
|
||||
let infile = Sys.argv.(if not to_compile then 2 else 1) in
|
||||
let infile = Sys.argv.(if not to_compile then 2 else 1) in
|
||||
match (try parse infile with Language.Semantic_error msg -> `Fail msg) with
|
||||
| `Ok prog ->
|
||||
if to_compile
|
||||
then
|
||||
then
|
||||
let basename = Filename.chop_suffix infile ".expr" in
|
||||
ignore @@ X86.build prog basename
|
||||
else
|
||||
ignore @@ X86.build prog basename
|
||||
else
|
||||
let rec read acc =
|
||||
try
|
||||
let r = read_int () in
|
||||
Printf.printf "> ";
|
||||
read (acc @ [r])
|
||||
read (acc @ [r])
|
||||
with End_of_file -> acc
|
||||
in
|
||||
let input = read [] in
|
||||
let output =
|
||||
if interpret
|
||||
then Language.eval prog input
|
||||
let input = read [] in
|
||||
let output =
|
||||
if interpret
|
||||
then Language.eval prog input
|
||||
else SM.run (SM.compile prog) input
|
||||
in
|
||||
List.iter (fun i -> Printf.printf "%d\n" i) output
|
||||
|
|
|
|||
480
src/Language.ml
480
src/Language.ml
|
|
@ -9,9 +9,9 @@ open Ostap
|
|||
open Combinators
|
||||
|
||||
exception Semantic_error of string
|
||||
|
||||
|
||||
let unquote s = String.sub s 1 (String.length s - 2)
|
||||
|
||||
|
||||
(* Values *)
|
||||
module Value =
|
||||
struct
|
||||
|
|
@ -19,19 +19,19 @@ module Value =
|
|||
@type t =
|
||||
| Empty
|
||||
| Var of string
|
||||
| Elem of t * int
|
||||
| Elem of t * int
|
||||
| Int of int
|
||||
| String of bytes
|
||||
| Array of t array
|
||||
| Sexp of string * t array
|
||||
with show
|
||||
|
||||
let to_int = function
|
||||
| Int n -> n
|
||||
let to_int = function
|
||||
| Int n -> n
|
||||
| _ -> failwith "int value expected"
|
||||
|
||||
let to_string = function
|
||||
| String s -> s
|
||||
let to_string = function
|
||||
| String s -> s
|
||||
| _ -> failwith "string value expected"
|
||||
|
||||
let to_array = function
|
||||
|
|
@ -47,14 +47,14 @@ module Value =
|
|||
| Sexp (t, _) -> t
|
||||
| _ -> failwith "symbolic expression expected"
|
||||
|
||||
let update_string s i x = Bytes.set s i x; s
|
||||
let update_string s i x = Bytes.set s i x; s
|
||||
let update_array a i x = a.(i) <- x; a
|
||||
|
||||
let update_elem x i v =
|
||||
match x with
|
||||
| Sexp (_, a) | Array a -> ignore (update_array a i v)
|
||||
| String a -> ignore (update_string a i (Char.chr @@ to_int v))
|
||||
|
||||
|
||||
let string_val v =
|
||||
let buf = Buffer.create 128 in
|
||||
let append s = Buffer.add_string buf s in
|
||||
|
|
@ -70,7 +70,7 @@ module Value =
|
|||
let rec inner_list = function
|
||||
| [||] -> ()
|
||||
| [|x; Int 0|] -> inner x
|
||||
| [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a
|
||||
| [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a
|
||||
in inner_list a;
|
||||
append "}"
|
||||
)
|
||||
|
|
@ -82,13 +82,13 @@ module Value =
|
|||
in
|
||||
inner v;
|
||||
Bytes.of_string @@ Buffer.contents buf
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
||||
(* States *)
|
||||
module State =
|
||||
struct
|
||||
|
||||
|
||||
(* State: global state, local state, scope variables *)
|
||||
type t =
|
||||
| G of (string -> Value.t)
|
||||
|
|
@ -98,12 +98,12 @@ module State =
|
|||
let undefined x = failwith (Printf.sprintf "Undefined variable: %s" 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
|
||||
let bind x v s = fun y -> if x = y then v else s y
|
||||
|
||||
(* Empty state *)
|
||||
let empty = G undefined
|
||||
|
||||
(* 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
|
||||
*)
|
||||
let update x v s =
|
||||
|
|
@ -144,13 +144,13 @@ module State =
|
|||
|
||||
(* Drop a local scope *)
|
||||
let drop (L (_, _, e)) = e
|
||||
|
||||
|
||||
end
|
||||
|
||||
(* Builtins *)
|
||||
module Builtin =
|
||||
struct
|
||||
|
||||
|
||||
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)
|
||||
|
|
@ -161,7 +161,7 @@ module Builtin =
|
|||
| Value.Array a -> a.(i)
|
||||
| Value.Sexp (_, a) -> a.(i)
|
||||
) :: vs
|
||||
)
|
||||
)
|
||||
| ".length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs)
|
||||
| ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs)
|
||||
| ".stringval" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs)
|
||||
|
|
@ -180,24 +180,24 @@ module Pattern =
|
|||
(* identifier *) | Named of string * t
|
||||
(* ground integer *) | Const of int
|
||||
(* ground string *) | String of string
|
||||
(* boxed value *) | Boxed
|
||||
(* unboxed value *) | UnBoxed
|
||||
(* boxed value *) | Boxed
|
||||
(* unboxed value *) | UnBoxed
|
||||
(* any string value *) | StringTag
|
||||
(* any sexp value *) | SexpTag
|
||||
(* any array value *) | ArrayTag
|
||||
with show, foldl
|
||||
|
||||
(* Pattern parser *)
|
||||
(* Pattern parser *)
|
||||
ostap (
|
||||
parse:
|
||||
!(Ostap.Util.expr
|
||||
parse:
|
||||
!(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, [":"]|]
|
||||
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)}
|
||||
|
|
@ -218,20 +218,20 @@ module Pattern =
|
|||
| -"(" parse -")"
|
||||
)
|
||||
|
||||
let vars p = transform(t) (fun f -> object inherit [string list, _] @t[foldl] f method c_Named s _ name p = name :: f s p end) [] p
|
||||
|
||||
let vars p = transform(t) (fun f -> object inherit [string list, _] @t[foldl] f method c_Named s _ name p = name :: f s p end) [] p
|
||||
|
||||
end
|
||||
|
||||
(* Simple expressions: syntax and semantics *)
|
||||
module Expr =
|
||||
struct
|
||||
(* The type of configuration: a state, an input stream, an output stream,
|
||||
and a stack of values
|
||||
(* The type of configuration: a state, an input stream, an output stream,
|
||||
and a stack of values
|
||||
*)
|
||||
type config = State.t * int list * int list * Value.t list
|
||||
|
||||
(* The type for expressions. Note, in regular OCaml there is no "@type..."
|
||||
notation, it came from GT.
|
||||
|
||||
(* The type for expressions. Note, in regular OCaml there is no "@type..."
|
||||
notation, it came from GT.
|
||||
*)
|
||||
type t =
|
||||
(* integer constant *) | Const of int
|
||||
|
|
@ -247,7 +247,7 @@ module Expr =
|
|||
(* string conversion *) | StringVal of t
|
||||
(* function call *) | Call of t * t list
|
||||
(* assignment *) | Assign of t * t
|
||||
(* composition *) | Seq of t * t
|
||||
(* composition *) | Seq of t * t
|
||||
(* empty statement *) | Skip
|
||||
(* conditional *) | If of t * t * t
|
||||
(* loop with a pre-condition *) | While of t * t
|
||||
|
|
@ -256,37 +256,37 @@ module Expr =
|
|||
(* return statement *) | Return of t option
|
||||
(* ignore a value *) | Ignore of t
|
||||
(* unit value *) | Unit
|
||||
(* leave a scope *) | Leave
|
||||
(* leave a scope *) | Leave
|
||||
(* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
|
||||
(* control (for control flow) *) | Control of (config -> t * config)
|
||||
|
||||
(* Available binary operators:
|
||||
!! --- disjunction
|
||||
&& --- conjunction
|
||||
==, !=, <=, <, >=, > --- comparisons
|
||||
+, - --- addition, subtraction
|
||||
*, /, % --- multiplication, division, reminder
|
||||
*)
|
||||
(* 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 *)
|
||||
|
||||
(* Update state *)
|
||||
let update st x v =
|
||||
match x with
|
||||
| Value.Var x -> State.update x v st
|
||||
| Value.Elem (x, i) -> Value.update_elem x i v; st
|
||||
|
||||
|
||||
(* Expression evaluator
|
||||
|
||||
val eval : env -> config -> k -> t -> config
|
||||
|
||||
|
||||
Takes an environment, a configuration and an expresion, and returns another configuration. The
|
||||
Takes an environment, a configuration and an expresion, and returns another configuration. The
|
||||
environment supplies the following method
|
||||
|
||||
method definition : env -> string -> int list -> config -> config
|
||||
|
||||
which takes an environment (of the same type), a name of the function, a list of actual parameters and a configuration,
|
||||
which takes an environment (of the same type), a name of the function, a list of actual parameters and a configuration,
|
||||
an returns a pair: the return value for the call and the resulting configuration
|
||||
*)
|
||||
*)
|
||||
let to_func op =
|
||||
let bti = function true -> 1 | _ -> 0 in
|
||||
let itb b = b <> 0 in
|
||||
|
|
@ -305,14 +305,14 @@ module Expr =
|
|||
| "!=" -> bti |> (<>)
|
||||
| "&&" -> fun x y -> bti (itb x && itb y)
|
||||
| "!!" -> fun x y -> bti (itb x || itb y)
|
||||
| _ -> failwith (Printf.sprintf "Unknown binary operator %s" op)
|
||||
| _ -> failwith (Printf.sprintf "Unknown binary operator %s" op)
|
||||
|
||||
let seq x = function Skip -> x | y -> Seq (x, y)
|
||||
let seq x = function Skip -> x | y -> Seq (x, y)
|
||||
|
||||
let schedule_list h::tl =
|
||||
List.fold_left seq h tl
|
||||
|
||||
let rec take = function
|
||||
|
||||
let rec take = function
|
||||
| 0 -> fun rest -> [], rest
|
||||
| n -> fun h::tl -> let tl', rest = take (n-1) tl in h :: tl', rest
|
||||
|
||||
|
|
@ -350,7 +350,7 @@ module Expr =
|
|||
| Call (Var f, args) ->
|
||||
eval env conf k (schedule_list (args @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length args) vs in
|
||||
env#definition env f (List.rev es) (st, i, o, vs'))]))
|
||||
| Leave -> eval env (State.drop st, i, o, vs) Skip k
|
||||
| Leave -> eval env (State.drop st, i, o, vs) Skip k
|
||||
| Assign (x, e) ->
|
||||
eval env conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))])
|
||||
| Seq (s1, s2) ->
|
||||
|
|
@ -380,14 +380,14 @@ module Expr =
|
|||
| Pattern.Array ps , Value.Array vs when List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st
|
||||
| Pattern.Const n , Value.Int n' when n = n' -> st
|
||||
| Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st
|
||||
| Pattern.Boxed , Value.String _
|
||||
| Pattern.Boxed , Value.String _
|
||||
| Pattern.Boxed , Value.Array _
|
||||
| Pattern.UnBoxed , Value.Int _
|
||||
| Pattern.Boxed , Value.Sexp (_, _)
|
||||
| Pattern.Boxed , Value.Sexp (_, _)
|
||||
| Pattern.StringTag , Value.String _
|
||||
| Pattern.ArrayTag , Value.Array _
|
||||
| Pattern.ArrayTag , Value.Array _
|
||||
| Pattern.SexpTag , Value.Sexp (_, _) -> st
|
||||
| _ -> None
|
||||
| _ -> None
|
||||
and match_list ps vs s =
|
||||
match ps, vs with
|
||||
| [], [] -> s
|
||||
|
|
@ -397,239 +397,143 @@ module Expr =
|
|||
match match_patt patt v (Some State.undefined) with
|
||||
| None -> branch conf tl
|
||||
| Some st' -> eval env (State.push st st' (Pattern.vars patt), i, o, vs) k (Seq (body, Leave))
|
||||
in
|
||||
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
|
||||
*)
|
||||
|
||||
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)
|
||||
|
||||
let defaultInfix : (t, atr) Util.Infix.t =
|
||||
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 , ["*" ; "/"; "%"];
|
||||
|]
|
||||
)
|
||||
|
||||
(* 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
|
||||
UIDENT --- a non-empty identifier A-Z[a-zA-Z0-9_]* as a string
|
||||
DECIMAL --- a decimal constant [0-9]+ as a string
|
||||
DECIMAL --- a decimal constant [0-9]+ as a string
|
||||
*)
|
||||
|
||||
(* 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}
|
||||
parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)}
|
||||
| basic[infix][atr];
|
||||
|
||||
| %"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)
|
||||
)
|
||||
basic[infix][atr]: !(Ostap.Util.newexpr (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
|
||||
}
|
||||
|
||||
| %"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] -")"
|
||||
| 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] -")"
|
||||
)
|
||||
|
||||
|
||||
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 y ->
|
||||
match s with
|
||||
| ":" -> 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 , ["*" ; "/"; "%"];
|
||||
|]
|
||||
|
||||
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 no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord))
|
||||
|
||||
let sem name x y = Expr.Call (Var name, [x; y])
|
||||
|
||||
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)
|
||||
))
|
||||
)
|
||||
(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)
|
||||
|
||||
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
|
||||
|
||||
(* Function and procedure definitions *)
|
||||
module Definition =
|
||||
|
|
@ -641,32 +545,32 @@ module Definition =
|
|||
ostap (
|
||||
arg : LIDENT;
|
||||
position[ass][coord][newp]:
|
||||
%"at" s:STRING {Infix.at coord (unquote s) newp}
|
||||
| f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass};
|
||||
%"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};
|
||||
head[infix]:
|
||||
%"fun" name:LIDENT {name, infix}
|
||||
| ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
|
||||
l:$ op:(s:STRING {unquote s})
|
||||
| ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
|
||||
l:$ op:(s:STRING {unquote s})
|
||||
md:position[ass][l#coord][op] {
|
||||
let name = Infix.name op in
|
||||
match md name infix with
|
||||
let name = Util.Infix.name op in
|
||||
match md (Expr.sem name) infix with
|
||||
| `Ok infix' -> name, infix'
|
||||
| `Fail msg -> raise (Semantic_error msg)
|
||||
| `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') "}" {
|
||||
(name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix'
|
||||
"{" body:!(Expr.parse infix' Void) "}" {
|
||||
(name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
|
||||
}
|
||||
)
|
||||
|
||||
end
|
||||
|
||||
|
||||
(* The top-level definitions *)
|
||||
|
||||
(* The top-level syntax category is a pair of definition list and statement (program body) *)
|
||||
type t = Definition.t list * Expr.t
|
||||
type t = Definition.t list * Expr.t
|
||||
|
||||
(* Top-level evaluator
|
||||
|
||||
|
|
@ -676,7 +580,7 @@ type t = Definition.t list * Expr.t
|
|||
*)
|
||||
let eval (defs, body) i =
|
||||
let module M = Map.Make (String) in
|
||||
let m = List.fold_left (fun m ((name, _) as def) -> M.add name def m) M.empty defs in
|
||||
let m = List.fold_left (fun m ((name, _) as def) -> M.add name def m) M.empty defs in
|
||||
let _, _, o, _ =
|
||||
Expr.eval
|
||||
(object
|
||||
|
|
@ -696,7 +600,7 @@ let eval (defs, body) i =
|
|||
|
||||
(* Top-level parser *)
|
||||
ostap (
|
||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body};
|
||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix' Void) {defs, body};
|
||||
definitions[infix]:
|
||||
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
|
||||
| empty {[], infix}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue