mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-22 14:48:46 +00:00
Dmitry Boulytchev
GitHub
commit
a2d7448b57
5 changed files with 406 additions and 199 deletions
|
|
@ -1,8 +1,8 @@
|
|||
TESTS=$(basename $(wildcard test*.expr))
|
||||
TESTS=$(basename $(wildcard test001*.expr))
|
||||
|
||||
RC=../src/rc.opt
|
||||
|
||||
.PHONY: check $(TESTS)
|
||||
.PHONY: check $(TESTS)
|
||||
|
||||
check: $(TESTS)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,116 @@
|
|||
x := read ();
|
||||
y := read ();
|
||||
z := x*y*3;
|
||||
write (z)
|
||||
fun foo (p1, p2, p3) {
|
||||
return p1
|
||||
}
|
||||
|
||||
fun f1 (p1, p2, p3) local p4, p5 {
|
||||
p4 := {};
|
||||
while (1) do
|
||||
case p2[p3[0]] of
|
||||
A (a, b) ->
|
||||
p5 := foo(p3, p2, a);
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|B (a, b) ->
|
||||
case P(foo(p3, p2, a), foo(p3, p2, b)) of
|
||||
P (L (a), L (b)) -> p5 := L (a + b)
|
||||
|P (a, b) -> p5 := foo(p3, a, b)
|
||||
esac;
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|C (a, b) ->
|
||||
case P(foo(p3, p2, a), foo(p3, p2, b)) of
|
||||
P (L (a), L (b)) -> p5 := L (a - b)
|
||||
|P (a, b) -> p5 := foo(p3, a, b)
|
||||
esac;
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|D (a) ->
|
||||
p5 := foo(p3, p2, a);
|
||||
p4 := p5 : p4;
|
||||
case p3[1][7] of
|
||||
L (m) -> p3[1][7] := L (m + 1);
|
||||
p3[2][m + 1] := p5
|
||||
esac
|
||||
|E ->
|
||||
return p4
|
||||
|a -> skip
|
||||
esac
|
||||
od;
|
||||
return p4
|
||||
}
|
||||
|
||||
fun f2 (p1, p2, p3) local p4, p5 {
|
||||
p4 := {};
|
||||
while (1) do
|
||||
case p2[p3[0]] of
|
||||
A (a, b) ->
|
||||
p5 := foo(p3, p2, a);
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|B (a, b) ->
|
||||
case P(foo(p3, p2, a), foo(p3, p2, b)) of
|
||||
P (L (a), L (b)) -> p5 := L (a + b)
|
||||
|P (a, b) -> p5 := foo(p3, a, b)
|
||||
esac;
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|C (a, b) ->
|
||||
case P(foo(p3, p2, a), foo(p3, p2, b)) of
|
||||
P (L (a), L (b)) -> p5 := L (a - b)
|
||||
|P (a, b) -> p5 := foo(p3, a, b)
|
||||
esac;
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|D (a) ->
|
||||
p5 := foo(p3, p2, a);
|
||||
p4 := p5 : p4;
|
||||
case p3[1][7] of
|
||||
L (m) -> p3[1][7] := L (m + 1);
|
||||
p3[2][m + 1] := p5
|
||||
esac
|
||||
|E ->
|
||||
return p4
|
||||
|a -> skip
|
||||
esac
|
||||
od;
|
||||
return p4
|
||||
}
|
||||
|
||||
fun f3 (p1, p2, p3) local p4, p5 {
|
||||
p4 := {};
|
||||
while (1) do
|
||||
case p2[p3[0]] of
|
||||
A (a, b) ->
|
||||
p5 := foo(p3, p2, a);
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|B (a, b) ->
|
||||
case P(foo(p3, p2, a), foo(p3, p2, b)) of
|
||||
P (L (a), L (b)) -> p5 := L (a + b)
|
||||
|P (a, b) -> p5 := foo(p3, a, b)
|
||||
esac;
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|C (a, b) ->
|
||||
case P(foo(p3, p2, a), foo(p3, p2, b)) of
|
||||
P (L (a), L (b)) -> p5 := L (a - b)
|
||||
|P (a, b) -> p5 := foo(p3, a, b)
|
||||
esac;
|
||||
p4 := p5 : p4;
|
||||
foo(p3, b, p5)
|
||||
|D (a) ->
|
||||
p5 := foo(p3, p2, a);
|
||||
p4 := p5 : p4;
|
||||
case p3[1][7] of
|
||||
L (m) -> p3[1][7] := L (m + 1);
|
||||
p3[2][m + 1] := p5
|
||||
esac
|
||||
|E ->
|
||||
return p4
|
||||
|a -> skip
|
||||
esac
|
||||
od;
|
||||
return p4
|
||||
}
|
||||
|
||||
write(7)
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ let parse infile =
|
|||
] s
|
||||
end
|
||||
)
|
||||
(ostap (!(Language.parse Language.Expr.defaultInfix) -EOF))
|
||||
(ostap (!(Language.parse Language.Infix.default) -EOF))
|
||||
|
||||
let main =
|
||||
try
|
||||
|
|
|
|||
350
src/Language.ml
350
src/Language.ml
|
|
@ -260,13 +260,13 @@ module Expr =
|
|||
(* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
|
||||
(* control (for control flow) *) | Control of (config -> t * config)
|
||||
|
||||
(* 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 *)
|
||||
(* Available binary operators:
|
||||
!! --- disjunction
|
||||
&& --- conjunction
|
||||
==, !=, <=, <, >=, > --- comparisons
|
||||
+, - --- addition, subtraction
|
||||
*, /, % --- multiplication, division, reminder
|
||||
*)
|
||||
|
||||
(* Update state *)
|
||||
let update st x v =
|
||||
|
|
@ -400,48 +400,6 @@ module Expr =
|
|||
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
|
||||
|
|
@ -449,91 +407,229 @@ module Expr =
|
|||
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][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)}
|
||||
| basic[infix][atr];
|
||||
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}
|
||||
|
||||
basic[infix][atr]: !(Ostap.Util.newexpr (fun x -> x) (infix) (primary infix) atr);
|
||||
| %"skip" {Skip}
|
||||
|
||||
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
|
||||
| %"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)
|
||||
)
|
||||
}
|
||||
| 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}
|
||||
| %"while" e:parse[infix] %"do" s:parse[infix] %"od" {While (e, s)}
|
||||
|
||||
| %"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)}
|
||||
| %"for" i:parse[infix] "," c:parse[infix] "," s:parse[infix] %"do" b:parse[infix] %"od" {
|
||||
Seq (i, While (c, Seq (b, s)))
|
||||
}
|
||||
|
||||
| %"while" e:parse[infix][Val] %"do" s:parse[infix][Void]
|
||||
=> {isVoid atr} => %"od" {While (e, s)}
|
||||
| %"repeat" s:parse[infix] %"until" e:basic[infix] {Repeat (s, e)}
|
||||
| %"return" e:basic[infix]? {Return e}
|
||||
|
||||
| %"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)))}
|
||||
| %"case" e:parse[infix] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)}
|
||||
|
||||
| %"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] -")"
|
||||
| -"(" parse[infix] -")"
|
||||
)
|
||||
|
||||
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 =
|
||||
|
|
@ -545,23 +641,23 @@ module Definition =
|
|||
ostap (
|
||||
arg : LIDENT;
|
||||
position[ass][coord][newp]:
|
||||
%"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};
|
||||
%"at" s:STRING {Infix.at coord (unquote s) newp}
|
||||
| f:(%"before" {Infix.before} | %"after" {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})
|
||||
md:position[ass][l#coord][op] {
|
||||
let name = Util.Infix.name op in
|
||||
match md (Expr.sem name) infix with
|
||||
let name = Infix.name op in
|
||||
match md name infix with
|
||||
| `Ok infix' -> name, infix'
|
||||
| `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' Void) "}" {
|
||||
(name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
|
||||
"{" body:!(Expr.parse infix') "}" {
|
||||
(name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix'
|
||||
}
|
||||
)
|
||||
|
||||
|
|
@ -600,7 +696,7 @@ let eval (defs, body) i =
|
|||
|
||||
(* Top-level parser *)
|
||||
ostap (
|
||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix' Void) {defs, body};
|
||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body};
|
||||
definitions[infix]:
|
||||
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
|
||||
| empty {[], infix}
|
||||
|
|
|
|||
129
src/X86.ml
129
src/X86.ml
|
|
@ -1,28 +1,28 @@
|
|||
open GT
|
||||
|
||||
|
||||
(* X86 codegeneration interface *)
|
||||
|
||||
(* The registers: *)
|
||||
let regs = [|"%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp"|]
|
||||
|
||||
(* We can not freely operate with all register; only 3 by now *)
|
||||
(* We can not freely operate with all register; only 3 by now *)
|
||||
let num_of_regs = Array.length regs - 5
|
||||
|
||||
(* We need to know the word size to calculate offsets correctly *)
|
||||
let word_size = 4;;
|
||||
|
||||
(* We need to distinguish the following operand types: *)
|
||||
@type opnd =
|
||||
@type opnd =
|
||||
| R of int (* hard register *)
|
||||
| S of int (* a position on the hardware stack *)
|
||||
| M of string (* a named memory location *)
|
||||
| L of int (* an immediate operand *)
|
||||
| I of opnd (* an indirect operand *)
|
||||
| I of opnd (* an indirect operand *)
|
||||
with show
|
||||
|
||||
let show_opnd = show(opnd)
|
||||
|
||||
(* For convenience we define the following synonyms for the registers: *)
|
||||
|
||||
(* For convenience we define the following synonyms for the registers: *)
|
||||
let ebx = R 0
|
||||
let ecx = R 1
|
||||
let esi = R 2
|
||||
|
|
@ -41,7 +41,7 @@ type instr =
|
|||
(* x86 integer division, see instruction set reference *) | IDiv of opnd
|
||||
(* see instruction set reference *) | Cltd
|
||||
(* sets a value from flags; the first operand is the *) | Set of string * string
|
||||
(* suffix, which determines the value being set, the *)
|
||||
(* suffix, which determines the value being set, the *)
|
||||
(* the second --- (sub)register name *)
|
||||
(* pushes the operand on the hardware stack *) | Push of opnd
|
||||
(* pops from the hardware stack to the operand *) | Pop of opnd
|
||||
|
|
@ -56,7 +56,7 @@ type instr =
|
|||
(* arithmetic correction: or 0x0001 *) | Or1 of opnd
|
||||
(* arithmetic correction: shl 1 *) | Sal1 of opnd
|
||||
(* arithmetic correction: shr 1 *) | Sar1 of opnd
|
||||
| Repmovsl
|
||||
| Repmovsl
|
||||
(* Instruction printer *)
|
||||
let show instr =
|
||||
let binop = function
|
||||
|
|
@ -64,7 +64,7 @@ let show instr =
|
|||
| "-" -> "subl"
|
||||
| "*" -> "imull"
|
||||
| "&&" -> "andl"
|
||||
| "!!" -> "orl"
|
||||
| "!!" -> "orl"
|
||||
| "^" -> "xorl"
|
||||
| "cmp" -> "cmpl"
|
||||
| _ -> failwith "unknown binary operator"
|
||||
|
|
@ -98,7 +98,7 @@ let show instr =
|
|||
| Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s)
|
||||
| Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s)
|
||||
| Repmovsl -> Printf.sprintf "\trep movsl\t"
|
||||
|
||||
|
||||
(* Opening stack machine to use instructions without fully qualified names *)
|
||||
open SM
|
||||
|
||||
|
|
@ -119,9 +119,9 @@ let compile env code =
|
|||
| "!=" -> "ne"
|
||||
| ">=" -> "ge"
|
||||
| ">" -> "g"
|
||||
| _ -> failwith "unknown operator"
|
||||
| _ -> failwith "unknown operator"
|
||||
in
|
||||
let rec compile' env scode =
|
||||
let rec compile' env scode =
|
||||
let on_stack = function S _ -> true | _ -> false in
|
||||
let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in
|
||||
let call env f n =
|
||||
|
|
@ -143,7 +143,7 @@ let compile env code =
|
|||
| "Barray" -> List.rev @@ (Push (L n)) :: pushs
|
||||
| "Bsexp" -> List.rev @@ (Push (L n)) :: pushs
|
||||
| "Bsta" -> pushs
|
||||
| _ -> List.rev pushs
|
||||
| _ -> List.rev pushs
|
||||
in
|
||||
env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr)
|
||||
in
|
||||
|
|
@ -158,7 +158,7 @@ let compile env code =
|
|||
| CONST n ->
|
||||
let s, env' = env#allocate in
|
||||
(env', [Mov (L ((n lsl 1) lor 1), s)])
|
||||
|
||||
|
||||
| STRING s ->
|
||||
let s, env = env#string s in
|
||||
let l, env = env#allocate in
|
||||
|
|
@ -172,7 +172,7 @@ let compile env code =
|
|||
| S _ | M _ -> [Lea (env'#loc x, eax); Mov (eax, s)]
|
||||
| _ -> [Lea (env'#loc x, s)]
|
||||
)
|
||||
|
||||
|
||||
| LD x ->
|
||||
let s, env' = (env#variable x)#allocate in
|
||||
env',
|
||||
|
|
@ -181,7 +181,7 @@ let compile env code =
|
|||
| _ -> [Mov (env'#loc x, s)]
|
||||
)
|
||||
|
||||
| ST x ->
|
||||
| ST x ->
|
||||
let env' = env#variable x in
|
||||
let s = env'#peek in
|
||||
env',
|
||||
|
|
@ -189,18 +189,18 @@ let compile env code =
|
|||
| S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)]
|
||||
| _ -> [Mov (s, env'#loc x)]
|
||||
)
|
||||
|
||||
|
||||
| STA ->
|
||||
call env ".sta" 3
|
||||
|
||||
|
||||
| STI ->
|
||||
let v, x, env' = env#pop2 in
|
||||
env'#push x,
|
||||
(match x with
|
||||
| S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I eax); Mov (edx, x)]
|
||||
| _ -> [Mov (v, eax); Mov (eax, I x); Mov (eax, x)]
|
||||
)
|
||||
|
||||
)
|
||||
|
||||
| BINOP op ->
|
||||
let x, y, env' = env#pop2 in
|
||||
env'#push y,
|
||||
|
|
@ -243,7 +243,7 @@ let compile env code =
|
|||
Binop ("cmp", x, y);
|
||||
Set (suffix op, "%al");
|
||||
Sal1 eax;
|
||||
Or1 eax;
|
||||
Or1 eax;
|
||||
Mov (eax, y)
|
||||
]
|
||||
)
|
||||
|
|
@ -263,13 +263,13 @@ let compile env code =
|
|||
Binop (op, y, edx);
|
||||
Mov (L 0, edx);
|
||||
Set ("ne", "%dl");
|
||||
|
||||
|
||||
Binop (op, edx, eax);
|
||||
Set ("ne", "%al");
|
||||
Sal1 eax;
|
||||
Or1 eax;
|
||||
Mov (eax, y)
|
||||
]
|
||||
]
|
||||
| "!!" ->
|
||||
[Mov (y, eax);
|
||||
Sar1 eax;
|
||||
|
|
@ -280,24 +280,24 @@ let compile env code =
|
|||
Sal1 eax;
|
||||
Or1 eax;
|
||||
Mov (eax, y)
|
||||
]
|
||||
]
|
||||
| "+" ->
|
||||
if on_stack x && on_stack y
|
||||
if on_stack x && on_stack y
|
||||
then [Mov (x, eax); Dec eax; Binop ("+", eax, y)]
|
||||
else [Binop (op, x, y); Dec y]
|
||||
| "-" ->
|
||||
if on_stack x && on_stack y
|
||||
if on_stack x && on_stack y
|
||||
then [Mov (x, eax); Binop (op, eax, y); Or1 y]
|
||||
else [Binop (op, x, y); Or1 y]
|
||||
)
|
||||
| LABEL s -> (if env#is_barrier then (env#drop_barrier)#retrieve_stack s else env), [Label s]
|
||||
|
||||
|
||||
| JMP l -> (env#set_stack l)#set_barrier, [Jmp l]
|
||||
|
||||
|
||||
| CJMP (s, l) ->
|
||||
let x, env = env#pop in
|
||||
env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)]
|
||||
|
||||
|
||||
| BEGIN (f, a, l) ->
|
||||
env#assert_empty_stack;
|
||||
let env = env#enter f a l in
|
||||
|
|
@ -307,8 +307,8 @@ let compile env code =
|
|||
Mov (M ("$" ^ (env#allocated_size)), ecx);
|
||||
Repmovsl
|
||||
]
|
||||
|
||||
| END ->
|
||||
|
||||
| END ->
|
||||
env#endfunc, [Label env#epilogue;
|
||||
Mov (ebp, esp);
|
||||
Pop ebp;
|
||||
|
|
@ -316,11 +316,11 @@ let compile env code =
|
|||
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size));
|
||||
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
|
||||
]
|
||||
|
||||
| RET ->
|
||||
|
||||
| RET ->
|
||||
let x, env = env#pop in
|
||||
env, [Mov (x, eax); Jmp env#epilogue]
|
||||
|
||||
|
||||
| CALL (f, n) -> call env f n
|
||||
|
||||
| SEXP (t, n) ->
|
||||
|
|
@ -330,16 +330,16 @@ let compile env code =
|
|||
|
||||
| DROP ->
|
||||
snd env#pop, []
|
||||
|
||||
|
||||
| DUP ->
|
||||
let x = env#peek in
|
||||
let s, env = env#allocate in
|
||||
env, mov x s
|
||||
|
||||
|
||||
| SWAP ->
|
||||
let x, y = env#peek2 in
|
||||
env, [Push x; Push y; Pop x; Pop y]
|
||||
|
||||
|
||||
| TAG (t, n) ->
|
||||
let s1, env = env#allocate in
|
||||
let s2, env = env#allocate in
|
||||
|
|
@ -362,8 +362,8 @@ let compile env code =
|
|||
| String -> ".string_tag_patt"
|
||||
| Sexp -> ".sexp_tag_patt"
|
||||
) 1
|
||||
|
||||
| ENTER xs ->
|
||||
|
||||
| ENTER xs ->
|
||||
let env, code =
|
||||
List.fold_left
|
||||
(fun (env, code) v ->
|
||||
|
|
@ -373,7 +373,7 @@ let compile env code =
|
|||
(env#scope @@ List.rev xs, []) xs
|
||||
in
|
||||
env, List.flatten @@ List.rev code
|
||||
|
||||
|
||||
| LEAVE -> env#unscope, []
|
||||
in
|
||||
let env'', code'' = compile' env' scode' in
|
||||
|
|
@ -381,11 +381,11 @@ let compile env code =
|
|||
in
|
||||
compile' env code
|
||||
|
||||
(* A set of strings *)
|
||||
module S = Set.Make (String)
|
||||
(* A set of strings *)
|
||||
module S = Set.Make (String)
|
||||
|
||||
(* A map indexed by strings *)
|
||||
module M = Map.Make (String)
|
||||
module M = Map.Make (String)
|
||||
|
||||
(* Environment implementation *)
|
||||
class env =
|
||||
|
|
@ -407,15 +407,15 @@ class env =
|
|||
val max_locals_size = 0
|
||||
|
||||
method max_locals_size = max_locals_size
|
||||
|
||||
|
||||
method endfunc =
|
||||
if stack_slots > max_locals_size
|
||||
then {< max_locals_size = stack_slots >}
|
||||
else self
|
||||
|
||||
|
||||
method show_stack =
|
||||
GT.show(list) (GT.show(opnd)) stack
|
||||
|
||||
|
||||
method print_locals =
|
||||
Printf.printf "LOCALS: size = %d\n" static_size;
|
||||
List.iter
|
||||
|
|
@ -428,7 +428,7 @@ class env =
|
|||
|
||||
(* Assert empty stack *)
|
||||
method assert_empty_stack = assert (stack = [])
|
||||
|
||||
|
||||
(* check barrier condition *)
|
||||
method is_barrier = barrier
|
||||
|
||||
|
|
@ -437,22 +437,22 @@ class env =
|
|||
|
||||
(* drop barrier *)
|
||||
method drop_barrier = {< barrier = false >}
|
||||
|
||||
|
||||
(* associates a stack to a label *)
|
||||
method set_stack l = (*Printf.printf "Setting stack for %s\n" l;*) {< stackmap = M.add l stack stackmap >}
|
||||
|
||||
|
||||
(* retrieves a stack for a label *)
|
||||
method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*)
|
||||
try {< stack = M.find l stackmap >} with Not_found -> self
|
||||
|
||||
|
||||
(* gets a name for a global variable *)
|
||||
method loc x =
|
||||
try S (- (List.assoc x args) - 1)
|
||||
with Not_found ->
|
||||
with Not_found ->
|
||||
try S (assoc x locals) with Not_found -> M ("global_" ^ x)
|
||||
|
||||
|
||||
(* allocates a fresh position on a symbolic stack *)
|
||||
method allocate =
|
||||
method allocate =
|
||||
let x, n =
|
||||
let rec allocate' = function
|
||||
| [] -> ebx , 0
|
||||
|
|
@ -485,8 +485,8 @@ class env =
|
|||
for i = 0 to min (String.length tag - 1) 4 do
|
||||
h := (!h lsl 6) lor (String.index chars tag.[i])
|
||||
done;
|
||||
!h
|
||||
|
||||
!h
|
||||
|
||||
(* registers a variable in the environment *)
|
||||
method variable x =
|
||||
match self#loc x with
|
||||
|
|
@ -500,18 +500,18 @@ class env =
|
|||
let y = Printf.sprintf "string_%d" scount in
|
||||
let m = M.add x y stringm in
|
||||
y, {< scount = scount + 1; stringm = m>}
|
||||
|
||||
(* gets all global variables *)
|
||||
|
||||
(* gets all global variables *)
|
||||
method globals = S.elements globals
|
||||
|
||||
(* gets all string definitions *)
|
||||
(* gets all string definitions *)
|
||||
method strings = M.bindings stringm
|
||||
|
||||
(* gets a number of stack positions allocated *)
|
||||
method allocated = stack_slots
|
||||
|
||||
method allocated_size = Printf.sprintf "LS%s_SIZE" fname
|
||||
|
||||
|
||||
(* enters a function *)
|
||||
method enter f a l =
|
||||
let n = List.length l in
|
||||
|
|
@ -527,10 +527,10 @@ class env =
|
|||
method unscope =
|
||||
let n = List.length (List.hd locals) in
|
||||
{< static_size = static_size - n; locals = List.tl locals >}
|
||||
|
||||
|
||||
(* returns a label for the epilogue *)
|
||||
method epilogue = Printf.sprintf "L%s_epilogue" fname
|
||||
|
||||
|
||||
(* returns a name for local size meta-symbol *)
|
||||
method lsize = Printf.sprintf "L%s_SIZE" fname
|
||||
|
||||
|
|
@ -542,9 +542,9 @@ class env =
|
|||
| _::tl -> inner (d+1) acc tl
|
||||
in
|
||||
inner 0 [] stack
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
||||
(* Generates an assembler text for a program: first compiles the program into
|
||||
the stack code, then generates x86 assember code, then prints the assembler file
|
||||
*)
|
||||
|
|
@ -552,7 +552,7 @@ let genasm (ds, stmt) =
|
|||
let stmt =
|
||||
Language.Expr.Seq (
|
||||
Language.Expr.Ignore (Language.Expr.Call (Language.Expr.Var "__gc_init", [])),
|
||||
Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0]))))
|
||||
Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0]))))
|
||||
)
|
||||
in
|
||||
let env, code =
|
||||
|
|
@ -582,4 +582,3 @@ let build prog name =
|
|||
close_out outf;
|
||||
let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
|
||||
Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue