mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Stmt -> Expr in interpretation only
This commit is contained in:
Dmitry Boulytchev
parent
eae2367371
commit
d0c72844e8
9 changed files with 310 additions and 310 deletions
|
|
@ -7,9 +7,9 @@ RC=../src/rc.opt
|
||||||
check: $(TESTS)
|
check: $(TESTS)
|
||||||
|
|
||||||
$(TESTS): %: %.expr
|
$(TESTS): %: %.expr
|
||||||
@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
#@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||||
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
||||||
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
#@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
$(RM) test*.log *.s *~ $(TESTS)
|
$(RM) test*.log *.s *~ $(TESTS)
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ RC = ../../src/rc.opt
|
||||||
check: $(TESTS)
|
check: $(TESTS)
|
||||||
|
|
||||||
$(TESTS): %: %.expr
|
$(TESTS): %: %.expr
|
||||||
@RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
#@RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||||
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
||||||
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
#@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f *.log *.s *~
|
rm -f *.log *.s *~
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ RC = ../../src/rc.opt
|
||||||
check: $(TESTS)
|
check: $(TESTS)
|
||||||
|
|
||||||
$(TESTS): %: %.expr
|
$(TESTS): %: %.expr
|
||||||
@RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
#@RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||||
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
||||||
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
#@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f *.log *.s *~
|
rm -f *.log *.s *~
|
||||||
|
|
|
||||||
654
src/Language.ml
654
src/Language.ml
|
|
@ -1,6 +1,7 @@
|
||||||
(* Opening a library for generic programming (https://github.com/dboulytchev/GT).
|
(* Opening a library for generic programming (https://github.com/dboulytchev/GT).
|
||||||
The library provides "@type ..." syntax extension and plugins like show, etc.
|
The library provides "@type ..." syntax extension and plugins like show, etc.
|
||||||
*)
|
*)
|
||||||
|
module OrigList = List
|
||||||
open GT
|
open GT
|
||||||
|
|
||||||
(* Opening a library for combinator-based syntax analysis *)
|
(* Opening a library for combinator-based syntax analysis *)
|
||||||
|
|
@ -15,7 +16,15 @@ let unquote s = String.sub s 1 (String.length s - 2)
|
||||||
module Value =
|
module Value =
|
||||||
struct
|
struct
|
||||||
|
|
||||||
@type t = Int of int | String of bytes | Array of t array | Sexp of string * t list with show
|
@type t =
|
||||||
|
| Empty
|
||||||
|
| Var of string
|
||||||
|
| 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
|
let to_int = function
|
||||||
| Int n -> n
|
| Int n -> n
|
||||||
|
|
@ -29,7 +38,7 @@ module Value =
|
||||||
| Array a -> a
|
| Array a -> a
|
||||||
| _ -> failwith "array value expected"
|
| _ -> failwith "array value expected"
|
||||||
|
|
||||||
let sexp s vs = Sexp (s, vs)
|
let sexp s vs = Sexp (s, Array.of_list vs)
|
||||||
let of_int n = Int n
|
let of_int n = Int n
|
||||||
let of_string s = String s
|
let of_string s = String s
|
||||||
let of_array a = Array a
|
let of_array a = Array a
|
||||||
|
|
@ -49,20 +58,20 @@ module Value =
|
||||||
| String s -> append "\""; append @@ Bytes.to_string s; append "\""
|
| String s -> append "\""; append @@ Bytes.to_string s; append "\""
|
||||||
| Array a -> let n = Array.length a in
|
| Array a -> let n = Array.length a in
|
||||||
append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]"
|
append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]"
|
||||||
| Sexp (t, a) -> let n = List.length a in
|
| Sexp (t, a) -> let n = Array.length a in
|
||||||
if t = "cons"
|
if t = "cons"
|
||||||
then (
|
then (
|
||||||
append "{";
|
append "{";
|
||||||
let rec inner_list = function
|
let rec inner_list = function
|
||||||
| [] -> ()
|
| [||] -> ()
|
||||||
| [x; Int 0] -> inner x
|
| [|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;
|
in inner_list a;
|
||||||
append "}"
|
append "}"
|
||||||
)
|
)
|
||||||
else (
|
else (
|
||||||
append t;
|
append t;
|
||||||
(if n > 0 then (append " ("; List.iteri (fun i a -> (if i > 0 then append ", "); inner a) a;
|
(if n > 0 then (append " ("; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a;
|
||||||
append ")"))
|
append ")"))
|
||||||
)
|
)
|
||||||
in
|
in
|
||||||
|
|
@ -137,256 +146,25 @@ module State =
|
||||||
module Builtin =
|
module Builtin =
|
||||||
struct
|
struct
|
||||||
|
|
||||||
let eval (st, i, o, _) args = function
|
let eval (st, i, o, vs) args = function
|
||||||
| "read" -> (match i with z::i' -> (st, i', o, Some (Value.of_int z)) | _ -> 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], None)
|
| "write" -> (st, i, o @ [Value.to_int @@ List.hd args], vs)
|
||||||
| ".elem" -> let [b; j] = args in
|
| ".elem" -> let [b; j] = args in
|
||||||
(st, i, o, let i = Value.to_int j in
|
(st, i, o, let i = Value.to_int j in
|
||||||
Some (match b with
|
(match b with
|
||||||
| Value.String s -> Value.of_int @@ Char.code (Bytes.get s i)
|
| Value.String s -> Value.of_int @@ Char.code (Bytes.get s i)
|
||||||
| Value.Array a -> a.(i)
|
| Value.Array a -> a.(i)
|
||||||
| Value.Sexp (_, a) -> List.nth 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)
|
||||||
| ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Sexp (_, a) -> List.length a | Value.Array a -> Array.length a | Value.String s -> Bytes.length s)))
|
| ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs)
|
||||||
| ".array" -> (st, i, o, Some (Value.of_array @@ Array.of_list args))
|
| ".stringval" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs)
|
||||||
| ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a))
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
(* Simple expressions: syntax and semantics *)
|
(* Patterns *)
|
||||||
module Expr =
|
module Pattern =
|
||||||
struct
|
|
||||||
|
|
||||||
(* The type for expressions. Note, in regular OCaml there is no "@type..."
|
|
||||||
notation, it came from GT.
|
|
||||||
*)
|
|
||||||
@type t =
|
|
||||||
(* integer constant *) | Const of int
|
|
||||||
(* array *) | Array of t list
|
|
||||||
(* string *) | String of string
|
|
||||||
(* S-expressions *) | Sexp of string * t list
|
|
||||||
(* variable *) | Var of string
|
|
||||||
(* binary operator *) | Binop of string * t * t
|
|
||||||
(* element extraction *) | Elem of t * t
|
|
||||||
(* length *) | Length of t
|
|
||||||
(* string conversion *) | StringVal of t
|
|
||||||
(* function call *) | Call of string * t list with show
|
|
||||||
|
|
||||||
(* Available binary operators:
|
|
||||||
!! --- disjunction
|
|
||||||
&& --- conjunction
|
|
||||||
==, !=, <=, <, >=, > --- comparisons
|
|
||||||
+, - --- addition, subtraction
|
|
||||||
*, /, % --- multiplication, division, reminder
|
|
||||||
*)
|
|
||||||
|
|
||||||
(* The type of configuration: a state, an input stream, an output stream, an optional value *)
|
|
||||||
type config = State.t * int list * int list * Value.t option
|
|
||||||
|
|
||||||
(* Expression evaluator
|
|
||||||
|
|
||||||
val eval : env -> config -> t -> int * config
|
|
||||||
|
|
||||||
|
|
||||||
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,
|
|
||||||
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
|
|
||||||
let (|>) f g = fun x y -> f (g x y) in
|
|
||||||
match op with
|
|
||||||
| "+" -> (+)
|
|
||||||
| "-" -> (-)
|
|
||||||
| "*" -> ( * )
|
|
||||||
| "/" -> (/)
|
|
||||||
| "%" -> (mod)
|
|
||||||
| "<" -> bti |> (< )
|
|
||||||
| "<=" -> bti |> (<=)
|
|
||||||
| ">" -> bti |> (> )
|
|
||||||
| ">=" -> bti |> (>=)
|
|
||||||
| "==" -> bti |> (= )
|
|
||||||
| "!=" -> 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)
|
|
||||||
|
|
||||||
let rec eval env ((st, i, o, r) as conf) expr =
|
|
||||||
match expr with
|
|
||||||
| Const n -> (st, i, o, Some (Value.of_int n))
|
|
||||||
| String s -> (st, i, o, Some (Value.of_string @@ Bytes.of_string s))
|
|
||||||
| StringVal s ->
|
|
||||||
let (st, i, o, Some s) = eval env conf s in
|
|
||||||
(st, i, o, Some (Value.of_string @@ Value.string_val s))
|
|
||||||
| Var x -> (st, i, o, Some (State.eval st x))
|
|
||||||
| Array xs ->
|
|
||||||
let (st, i, o, vs) = eval_list env conf xs in
|
|
||||||
env#definition env ".array" vs (st, i, o, None)
|
|
||||||
| Sexp (t, xs) ->
|
|
||||||
let (st, i, o, vs) = eval_list env conf xs in
|
|
||||||
(st, i, o, Some (Value.Sexp (t, vs)))
|
|
||||||
| Binop (op, x, y) ->
|
|
||||||
let (_, _, _, Some x) as conf = eval env conf x in
|
|
||||||
let (st, i, o, Some y) as conf = eval env conf y in
|
|
||||||
(st, i, o, Some (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)))
|
|
||||||
| Elem (b, i) ->
|
|
||||||
let (st, i, o, args) = eval_list env conf [b; i] in
|
|
||||||
env#definition env ".elem" args (st, i, o, None)
|
|
||||||
| Length e ->
|
|
||||||
let (st, i, o, Some v) = eval env conf e in
|
|
||||||
env#definition env ".length" [v] (st, i, o, None)
|
|
||||||
| Call (f, args) ->
|
|
||||||
let (st, i, o, args) = eval_list env conf args in
|
|
||||||
env#definition env f args (st, i, o, None)
|
|
||||||
and eval_list env conf xs =
|
|
||||||
let vs, (st, i, o, _) =
|
|
||||||
List.fold_left
|
|
||||||
(fun (acc, conf) x ->
|
|
||||||
let (_, _, _, Some v) as conf = eval env conf x in
|
|
||||||
v::acc, conf
|
|
||||||
)
|
|
||||||
([], conf)
|
|
||||||
xs
|
|
||||||
in
|
|
||||||
(st, i, o, List.rev vs)
|
|
||||||
|
|
||||||
(* 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
|
|
||||||
*)
|
|
||||||
ostap (
|
|
||||||
parse[infix]:
|
|
||||||
!(Ostap.Util.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 (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 (x, args)} | empty {Var x}) {s}
|
|
||||||
| -"(" 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 ("strcat", [x; y])
|
|
||||||
| _ -> Expr.Binop (s, x, y)
|
|
||||||
)
|
|
||||||
) s
|
|
||||||
)
|
|
||||||
[|
|
|
||||||
`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 (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
|
|
||||||
|
|
||||||
(* Simple statements: syntax and sematics *)
|
|
||||||
module Stmt =
|
|
||||||
struct
|
|
||||||
|
|
||||||
(* Patterns in statements *)
|
|
||||||
module Pattern =
|
|
||||||
struct
|
struct
|
||||||
|
|
||||||
(* The type for patterns *)
|
(* The type for patterns *)
|
||||||
|
|
@ -439,60 +217,152 @@ module Stmt =
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
(* The type for statements *)
|
(* Simple expressions: syntax and semantics *)
|
||||||
@type t =
|
module Expr =
|
||||||
(* assignment *) | Assign of string * Expr.t list * Expr.t
|
struct
|
||||||
|
(* 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.
|
||||||
|
*)
|
||||||
|
type t =
|
||||||
|
(* integer constant *) | Const of int
|
||||||
|
(* array *) | Array of t list
|
||||||
|
(* string *) | String of string
|
||||||
|
(* S-expressions *) | Sexp of string * t list
|
||||||
|
(* variable *) | Var of string
|
||||||
|
(* reference (aka "lvalue") *) | Ref of string
|
||||||
|
(* binary operator *) | Binop of string * t * t
|
||||||
|
(* element extraction *) | Elem of t * t
|
||||||
|
(* reference to an element *) | ElemRef of t * t
|
||||||
|
(* length *) | Length of t
|
||||||
|
(* 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
|
(* empty statement *) | Skip
|
||||||
(* conditional *) | If of Expr.t * t * t
|
(* conditional *) | If of t * t * t
|
||||||
(* loop with a pre-condition *) | While of Expr.t * t
|
(* loop with a pre-condition *) | While of t * t
|
||||||
(* loop with a post-condition *) | Repeat of t * Expr.t
|
(* loop with a post-condition *) | Repeat of t * t
|
||||||
(* pattern-matching *) | Case of Expr.t * (Pattern.t * t) list
|
(* pattern-matching *) | Case of t * (Pattern.t * t) list
|
||||||
(* return statement *) | Return of Expr.t option
|
(* return statement *) | Return of t option
|
||||||
(* call a procedure *) | Expr of Expr.t
|
(* leave a scope *) | Leave
|
||||||
(* leave a scope *) | Leave with show
|
(* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
|
||||||
|
(* control (for control flow) *) | Control of (config -> t * config)
|
||||||
|
|
||||||
(* Statement evaluator
|
(* Available binary operators:
|
||||||
|
!! --- disjunction
|
||||||
val eval : env -> config -> t -> config
|
&& --- conjunction
|
||||||
|
==, !=, <=, <, >=, > --- comparisons
|
||||||
Takes an environment, a configuration and a statement, and returns another configuration. The
|
+, - --- addition, subtraction
|
||||||
environment is the same as for expressions
|
*, /, % --- multiplication, division, reminder
|
||||||
*)
|
*)
|
||||||
let update st x v is =
|
|
||||||
let rec update a v = function
|
|
||||||
| [] -> v
|
|
||||||
| i::tl ->
|
|
||||||
let i = Value.to_int i in
|
|
||||||
(match a with
|
|
||||||
| Value.String s when tl = [] -> Value.String (Value.update_string s i (Char.chr @@ Value.to_int v))
|
|
||||||
| Value.Array a -> Value.Array (Value.update_array a i (update a.(i) v tl))
|
|
||||||
)
|
|
||||||
in
|
|
||||||
State.update x (match is with [] -> v | _ -> update (State.eval st x) v is) st
|
|
||||||
|
|
||||||
let rec eval env ((st, i, o, r) as conf) k stmt =
|
(* Update state *)
|
||||||
let seq x = function Skip -> x | y -> Seq (x, y) in
|
let update st x v =
|
||||||
match stmt with
|
match x with
|
||||||
| Leave -> eval env (State.drop st, i, o, r) Skip k
|
| Value.Var x -> State.update x v st
|
||||||
| Assign (x, is, e) ->
|
| Value.Elem (x, i) ->
|
||||||
let (st, i, o, is) = Expr.eval_list env conf is in
|
(match x with
|
||||||
let (st, i, o, Some v) = Expr.eval env (st, i, o, None) e in
|
| Value.Sexp (_, a) | Value.Array a -> ignore (Value.update_array a i v)
|
||||||
eval env (update st x v is, i, o, None) Skip k
|
| Value.String a -> ignore (Value.update_string a i (Char.chr @@ Value.to_int v))
|
||||||
|
);
|
||||||
|
st
|
||||||
|
|
||||||
| Seq (s1, s2) -> eval env conf (seq s2 k) s1
|
(* Expression evaluator
|
||||||
| Skip -> (match k with Skip -> conf | _ -> eval env conf Skip k)
|
|
||||||
| If (e, s1, s2) -> let (_, _, _, Some v) as conf = Expr.eval env conf e in eval env conf k (if Value.to_int v <> 0 then s1 else s2)
|
val eval : env -> config -> k -> t -> config
|
||||||
| While (e, s) -> let (_, _, _, Some v) as conf = Expr.eval env conf e in
|
|
||||||
if Value.to_int v = 0
|
|
||||||
then eval env conf Skip k
|
Takes an environment, a configuration and an expresion, and returns another configuration. The
|
||||||
else eval env conf (seq stmt k) s
|
environment supplies the following method
|
||||||
| Repeat (s, e) -> eval env conf (seq (While (Expr.Binop ("==", e, Expr.Const 0), s)) k) s
|
|
||||||
| Return e -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e)
|
method definition : env -> string -> int list -> config -> config
|
||||||
| Expr e -> eval env (Expr.eval env conf e) k Skip
|
|
||||||
| Case (e, bs) ->
|
which takes an environment (of the same type), a name of the function, a list of actual parameters and a configuration,
|
||||||
let (_, _, _, Some v) as conf' = Expr.eval env conf e in
|
an returns a pair: the return value for the call and the resulting configuration
|
||||||
let rec branch ((st, i, o, _) as conf) = function
|
*)
|
||||||
|
let to_func op =
|
||||||
|
let bti = function true -> 1 | _ -> 0 in
|
||||||
|
let itb b = b <> 0 in
|
||||||
|
let (|>) f g = fun x y -> f (g x y) in
|
||||||
|
match op with
|
||||||
|
| "+" -> (+)
|
||||||
|
| "-" -> (-)
|
||||||
|
| "*" -> ( * )
|
||||||
|
| "/" -> (/)
|
||||||
|
| "%" -> (mod)
|
||||||
|
| "<" -> bti |> (< )
|
||||||
|
| "<=" -> bti |> (<=)
|
||||||
|
| ">" -> bti |> (> )
|
||||||
|
| ">=" -> bti |> (>=)
|
||||||
|
| "==" -> bti |> (= )
|
||||||
|
| "!=" -> 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)
|
||||||
|
|
||||||
|
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
|
||||||
|
| 0 -> fun rest -> [], rest
|
||||||
|
| n -> fun h::tl -> let tl', rest = take (n-1) tl in h :: tl', rest
|
||||||
|
|
||||||
|
let rec eval env ((st, i, o, vs) as conf) k expr =
|
||||||
|
(*Printf.printf "eval: %s\n" (show(list) (show(Value.t)) vs); flush stdout; *)
|
||||||
|
match expr with
|
||||||
|
| Control f ->
|
||||||
|
let s, conf' = f conf in
|
||||||
|
eval env conf' k s
|
||||||
|
| Intrinsic f ->
|
||||||
|
eval env (f conf) Skip k
|
||||||
|
| Const n ->
|
||||||
|
eval env (st, i, o, (Value.of_int n) :: vs) Skip k
|
||||||
|
| String s ->
|
||||||
|
eval env (st, i, o, (Value.of_string @@ Bytes.of_string s) :: vs) Skip k
|
||||||
|
| StringVal s ->
|
||||||
|
eval env conf k (schedule_list [s; Intrinsic (fun (st, i, o, s::vs) -> (st, i, o, (Value.of_string @@ Value.string_val s)::vs))])
|
||||||
|
| Var x ->
|
||||||
|
eval env (st, i, o, (State.eval st x) :: vs) Skip k
|
||||||
|
| Ref x ->
|
||||||
|
eval env (st, i, o, (Value.Var x) :: vs) Skip k
|
||||||
|
| Array xs ->
|
||||||
|
eval env conf k (schedule_list (xs @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length xs) vs in env#definition env ".array" (List.rev es) (st, i, o, vs'))]))
|
||||||
|
| Sexp (t, xs) ->
|
||||||
|
eval env conf k (schedule_list (xs @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length xs) vs in (st, i, o, Value.Sexp (t, Array.of_list (List.rev es)) :: vs'))]))
|
||||||
|
| Binop (op, x, y) ->
|
||||||
|
eval env conf k (schedule_list [x; y; Intrinsic (fun (st, i, o, y::x::vs) -> (st, i, o, (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)) :: vs))])
|
||||||
|
| Elem (b, i) ->
|
||||||
|
eval env conf k (schedule_list [b; i; Intrinsic (fun (st, i, o, j::b::vs) -> env#definition env ".elem" [b; j] (st, i, o, vs))])
|
||||||
|
| ElemRef (b, i) ->
|
||||||
|
eval env conf k (schedule_list [b; i; Intrinsic (fun (st, i, o, j::b::vs) -> (st, i, o, (Value.Elem (b, Value.to_int j))::vs))])
|
||||||
|
| Length e ->
|
||||||
|
eval env conf k (schedule_list [e; Intrinsic (fun (st, i, o, v::vs) -> env#definition env ".length" [v] (st, i, o, vs))])
|
||||||
|
| 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
|
||||||
|
| 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, vs))])
|
||||||
|
| Seq (s1, s2) ->
|
||||||
|
eval env conf (seq s2 k) s1
|
||||||
|
| Skip ->
|
||||||
|
(match k with Skip -> conf | _ -> eval env conf Skip k)
|
||||||
|
| If (e, s1, s2) ->
|
||||||
|
eval env conf k (schedule_list [e; Control (fun (st, i, o, e::vs) -> (if Value.to_int e <> 0 then s1 else s2), (st, i, o, vs))])
|
||||||
|
| While (e, s) ->
|
||||||
|
eval env conf k (schedule_list [e; Control (fun (st, i, o, e::vs) -> (if Value.to_int e <> 0 then seq s expr else Skip), (st, i, o, vs))])
|
||||||
|
| Repeat (s, e) ->
|
||||||
|
eval env conf (seq (While (Binop ("==", e, Const 0), s)) k) s
|
||||||
|
| Return e -> (match e with None -> (st, i, o, []) | Some e -> eval env (st, i, o, []) Skip e)
|
||||||
|
| Case (e, bs)->
|
||||||
|
let rec branch ((st, i, o, v::vs) as conf) = function
|
||||||
| [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v))
|
| [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v))
|
||||||
| (patt, body)::tl ->
|
| (patt, body)::tl ->
|
||||||
let rec match_patt patt v st =
|
let rec match_patt patt v st =
|
||||||
|
|
@ -503,7 +373,7 @@ module Stmt =
|
||||||
match patt, v with
|
match patt, v with
|
||||||
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
|
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
|
||||||
| Pattern.Wildcard , _ -> st
|
| Pattern.Wildcard , _ -> st
|
||||||
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st
|
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st
|
||||||
| Pattern.Array ps , Value.Array vs when List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st
|
| 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.Const n , Value.Int n' when n = n' -> st
|
||||||
| Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st
|
| Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st
|
||||||
|
|
@ -523,20 +393,63 @@ module Stmt =
|
||||||
in
|
in
|
||||||
match match_patt patt v (Some State.undefined) with
|
match match_patt patt v (Some State.undefined) with
|
||||||
| None -> branch conf tl
|
| None -> branch conf tl
|
||||||
| Some st' -> eval env (State.push st st' (Pattern.vars patt), i, o, None) k (Seq (body, Leave))
|
| Some st' -> eval env (State.push st st' (Pattern.vars patt), i, o, vs) k (Seq (body, Leave))
|
||||||
in
|
in
|
||||||
branch conf' bs
|
eval env conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)])
|
||||||
|
|
||||||
|
(* 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
|
||||||
|
*)
|
||||||
|
|
||||||
|
(* 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")
|
||||||
|
|
||||||
(* Statement parser *)
|
|
||||||
ostap (
|
ostap (
|
||||||
parse[infix]:
|
parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)};
|
||||||
s:stmt[infix] ";" ss:parse[infix] {Seq (s, ss)}
|
basic[infix]:
|
||||||
| stmt[infix];
|
!(Ostap.Util.expr
|
||||||
stmt[infix]:
|
(fun x -> x)
|
||||||
%"skip" {Skip}
|
(Array.map (fun (a, l) -> a, List.map (fun (s, f) -> ostap (- $(s)), f) l) infix)
|
||||||
| %"if" e:!(Expr.parse 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}
|
||||||
|
|
||||||
|
| %"skip" {Skip}
|
||||||
|
|
||||||
|
| %"if" e:!(parse infix)
|
||||||
%"then" the:parse[infix]
|
%"then" the:parse[infix]
|
||||||
elif:(%"elif" !(Expr.parse infix) %"then" parse[infix])*
|
elif:(%"elif" parse[infix] %"then" parse[infix])*
|
||||||
els:(%"else" parse[infix])?
|
els:(%"else" parse[infix])?
|
||||||
%"fi" {
|
%"fi" {
|
||||||
If (e, the,
|
If (e, the,
|
||||||
|
|
@ -546,27 +459,116 @@ module Stmt =
|
||||||
(match els with None -> Skip | Some s -> s)
|
(match els with None -> Skip | Some s -> s)
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
| %"while" e:!(Expr.parse infix) %"do" s:parse[infix] %"od"{While (e, s)}
|
|
||||||
| %"for" i:parse[infix] "," c:!(Expr.parse infix) "," s:parse[infix] %"do" b:parse[infix] %"od" {
|
| %"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)))
|
Seq (i, While (c, Seq (b, s)))
|
||||||
}
|
}
|
||||||
| %"repeat" s:parse[infix] %"until" e:!(Expr.parse infix) {Repeat (s, e)}
|
|
||||||
| %"return" e:!(Expr.parse infix)? {Return e}
|
| %"repeat" s:parse[infix] %"until" e:basic[infix] {Repeat (s, e)}
|
||||||
| %"case" e:!(Expr.parse infix) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)}
|
| %"return" e:basic[infix]? {Return e}
|
||||||
| x:LIDENT
|
|
||||||
s:(is:(-"[" !(Expr.parse infix) -"]")* ":=" e :!(Expr.parse infix) {Assign (x, is, e)}
|
| %"case" e:parse[infix] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)}
|
||||||
) {s}
|
|
||||||
| e:!(Expr.parse infix) {Expr e}
|
| -"(" parse[infix] -")"
|
||||||
)
|
)
|
||||||
|
|
||||||
end
|
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 *)
|
(* Function and procedure definitions *)
|
||||||
module Definition =
|
module Definition =
|
||||||
struct
|
struct
|
||||||
|
|
||||||
(* The type for a definition: name, argument list, local variables, body *)
|
(* The type for a definition: name, argument list, local variables, body *)
|
||||||
type t = string * (string list * string list * Stmt.t)
|
type t = string * (string list * string list * Expr.t)
|
||||||
|
|
||||||
ostap (
|
ostap (
|
||||||
arg : LIDENT;
|
arg : LIDENT;
|
||||||
|
|
@ -586,7 +588,7 @@ module Definition =
|
||||||
parse[infix]:
|
parse[infix]:
|
||||||
<(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
|
<(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
|
||||||
locs:(%"local" !(Util.list arg))?
|
locs:(%"local" !(Util.list arg))?
|
||||||
"{" body:!(Stmt.parse infix') "}" {
|
"{" body:!(Expr.parse infix') "}" {
|
||||||
(name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
|
(name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
@ -596,7 +598,7 @@ module Definition =
|
||||||
(* The top-level definitions *)
|
(* The top-level definitions *)
|
||||||
|
|
||||||
(* The top-level syntax category is a pair of definition list and statement (program body) *)
|
(* The top-level syntax category is a pair of definition list and statement (program body) *)
|
||||||
type t = Definition.t list * Stmt.t
|
type t = Definition.t list * Expr.t
|
||||||
|
|
||||||
(* Top-level evaluator
|
(* Top-level evaluator
|
||||||
|
|
||||||
|
|
@ -608,17 +610,17 @@ let eval (defs, body) i =
|
||||||
let module M = Map.Make (String) in
|
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, _ =
|
let _, _, o, _ =
|
||||||
Stmt.eval
|
Expr.eval
|
||||||
(object
|
(object
|
||||||
method definition env f args ((st, i, o, r) as conf) =
|
method definition env f args ((st, i, o, vs) as conf) =
|
||||||
try
|
try
|
||||||
let xs, locs, s = snd @@ M.find f m in
|
let xs, locs, s = snd @@ M.find f m in
|
||||||
let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in
|
let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in
|
||||||
let st'', i', o', r' = Stmt.eval env (st', i, o, r) Skip s in
|
let st'', i', o', vs' = Expr.eval env (st', i, o, []) Skip s in
|
||||||
(State.leave st'' st, i', o', r')
|
(State.leave st'' st, i', o', match vs' with [v] -> v::vs | _ -> vs)
|
||||||
with Not_found -> Builtin.eval conf args f
|
with Not_found -> Builtin.eval conf args f
|
||||||
end)
|
end)
|
||||||
(State.empty, i, [], None)
|
(State.empty, i, [], [])
|
||||||
Skip
|
Skip
|
||||||
body
|
body
|
||||||
in
|
in
|
||||||
|
|
@ -626,7 +628,7 @@ let eval (defs, body) i =
|
||||||
|
|
||||||
(* Top-level parser *)
|
(* Top-level parser *)
|
||||||
ostap (
|
ostap (
|
||||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Stmt.parse infix') {defs, body};
|
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, body};
|
||||||
definitions[infix]:
|
definitions[infix]:
|
||||||
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
|
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
|
||||||
| empty {[], infix}
|
| empty {[], infix}
|
||||||
|
|
|
||||||
40
src/SM.ml
40
src/SM.ml
|
|
@ -38,7 +38,7 @@ let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p
|
||||||
(* The type for the stack machine configuration: control stack, stack and configuration from statement
|
(* The type for the stack machine configuration: control stack, stack and configuration from statement
|
||||||
interpreter
|
interpreter
|
||||||
*)
|
*)
|
||||||
type config = (prg * State.t) list * Value.t list * Expr.config
|
type config = (prg * State.t) list * Value.t list * ( State.t * int list * int list) (*Expr.config*)
|
||||||
|
|
||||||
(* Stack machine interpreter
|
(* Stack machine interpreter
|
||||||
|
|
||||||
|
|
@ -66,7 +66,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
||||||
| LD x -> eval env (cstack, State.eval st x :: stack, c) prg'
|
| LD x -> eval env (cstack, State.eval st x :: stack, c) prg'
|
||||||
| ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg'
|
| ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg'
|
||||||
| STA (x, n) -> let v::is, stack' = split (n+1) stack in
|
| STA (x, n) -> let v::is, stack' = split (n+1) stack in
|
||||||
eval env (cstack, stack', (Language.Stmt.update st x v (List.rev is), i, o)) prg'
|
eval env (cstack, stack', c (* (Language.Stmt.update st x v (List.rev is), i, o) *)) prg'
|
||||||
| LABEL _ -> eval env conf prg'
|
| LABEL _ -> eval env conf prg'
|
||||||
| JMP l -> eval env conf (env#labeled l)
|
| JMP l -> eval env conf (env#labeled l)
|
||||||
| CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg')
|
| CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg')
|
||||||
|
|
@ -85,7 +85,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
||||||
| SWAP -> let x::y::stack' = stack in
|
| SWAP -> let x::y::stack' = stack in
|
||||||
eval env (cstack, y::x::stack', c) prg'
|
eval env (cstack, y::x::stack', c) prg'
|
||||||
| TAG (t, n) -> let x::stack' = stack in
|
| TAG (t, n) -> let x::stack' = stack in
|
||||||
eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg'
|
eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && Array.length a = n -> 1 | _ -> 0) :: stack', c) prg'
|
||||||
| ARRAY n -> let x::stack' = stack in
|
| ARRAY n -> let x::stack' = stack in
|
||||||
eval env (cstack, (Value.of_int @@ match x with Value.Array a when Array.length a = n -> 1 | _ -> 0) :: stack', c) prg'
|
eval env (cstack, (Value.of_int @@ match x with Value.Array a when Array.length a = n -> 1 | _ -> 0) :: stack', c) prg'
|
||||||
| PATT StrCmp -> let x::y::stack' = stack in
|
| PATT StrCmp -> let x::y::stack' = stack in
|
||||||
|
|
@ -128,8 +128,8 @@ let run p i =
|
||||||
method builtin (cstack, stack, (st, i, o)) f n p =
|
method builtin (cstack, stack, (st, i, o)) f n p =
|
||||||
let f = match f.[0] with 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in
|
let f = match f.[0] with 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in
|
||||||
let args, stack' = split n stack in
|
let args, stack' = split n stack in
|
||||||
let (st, i, o, r) = Language.Builtin.eval (st, i, o, None) (List.rev args) f in
|
let (st, i, o, r) = Language.Builtin.eval (st, i, o, []) (List.rev args) f in
|
||||||
let stack'' = if p then stack' else let Some r = r in r::stack' in
|
let stack'' = if p then stack' else let [r] = r in r::stack' in
|
||||||
(*Printf.printf "Builtin:\n";*)
|
(*Printf.printf "Builtin:\n";*)
|
||||||
(cstack, stack'', (st, i, o))
|
(cstack, stack'', (st, i, o))
|
||||||
end
|
end
|
||||||
|
|
@ -146,28 +146,29 @@ let run p i =
|
||||||
Takes a program in the source language and returns an equivalent program for the
|
Takes a program in the source language and returns an equivalent program for the
|
||||||
stack machine
|
stack machine
|
||||||
*)
|
*)
|
||||||
let compile (defs, p) =
|
let compile (defs, p) = invalid_arg ""
|
||||||
|
(*
|
||||||
let label s = "L" ^ s in
|
let label s = "L" ^ s in
|
||||||
let rec call f args p =
|
let rec call f args p =
|
||||||
let args_code = List.concat @@ List.map expr args in
|
let args_code = List.concat @@ List.map expr args in
|
||||||
args_code @ [CALL (label f, List.length args, p)]
|
args_code @ [CALL (label f, List.length args, p)]
|
||||||
and pattern env lfalse = function
|
and pattern env lfalse = function
|
||||||
| Stmt.Pattern.Wildcard -> env, false, [DROP]
|
| Pattern.Wildcard -> env, false, [DROP]
|
||||||
| Stmt.Pattern.Named (_, p) -> pattern env lfalse p
|
| Pattern.Named (_, p) -> pattern env lfalse p
|
||||||
| Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)]
|
| Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)]
|
| Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)]
|
| Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)]
|
| Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)]
|
| Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)]
|
| Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)]
|
| Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)]
|
||||||
| Stmt.Pattern.Array ps ->
|
| Pattern.Array ps ->
|
||||||
let lhead, env = env#get_label in
|
let lhead, env = env#get_label in
|
||||||
let ldrop, env = env#get_label in
|
let ldrop, env = env#get_label in
|
||||||
let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||||
let code, env = pattern_list lhead ldrop env ps in
|
let code, env = pattern_list lhead ldrop env ps in
|
||||||
env, true, tag @ code @ [DROP]
|
env, true, tag @ code @ [DROP]
|
||||||
| Stmt.Pattern.Sexp (t, ps) ->
|
| Pattern.Sexp (t, ps) ->
|
||||||
let lhead, env = env#get_label in
|
let lhead, env = env#get_label in
|
||||||
let ldrop, env = env#get_label in
|
let ldrop, env = env#get_label in
|
||||||
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||||
|
|
@ -186,9 +187,9 @@ let compile (defs, p) =
|
||||||
List.flatten (List.rev code), env
|
List.flatten (List.rev code), env
|
||||||
and bindings p =
|
and bindings p =
|
||||||
let bindings =
|
let bindings =
|
||||||
transform(Stmt.Pattern.t)
|
transform(Pattern.t)
|
||||||
(fun fself ->
|
(fun fself ->
|
||||||
object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t
|
object inherit [int list, (string * int list) list, _] @Pattern.t
|
||||||
method c_Wildcard path _ = []
|
method c_Wildcard path _ = []
|
||||||
method c_Named path _ s p = [s, path] @ fself path p
|
method c_Named path _ s p = [s, path] @ fself path p
|
||||||
method c_Sexp path _ x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
method c_Sexp path _ x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||||
|
|
@ -315,3 +316,4 @@ let compile (defs, p) =
|
||||||
let _, flag, code = compile_stmt lend env p in
|
let _, flag, code = compile_stmt lend env p in
|
||||||
(if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code)
|
(if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code)
|
||||||
|
|
||||||
|
*)
|
||||||
|
|
|
||||||
10
src/X86.ml
10
src/X86.ml
|
|
@ -539,13 +539,9 @@ class env =
|
||||||
*)
|
*)
|
||||||
let genasm (ds, stmt) =
|
let genasm (ds, stmt) =
|
||||||
let stmt =
|
let stmt =
|
||||||
Language.Stmt.Seq (
|
Language.Expr.Seq (
|
||||||
Language.Stmt.Expr (Language.Expr.Call ("__gc_init", [])),
|
Language.Expr.Call (Language.Expr.Var "__gc_init", []),
|
||||||
Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0]))))
|
Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0]))))
|
||||||
(*
|
|
||||||
Language.Stmt.Call ("__gc_init", []),
|
|
||||||
Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0]))))
|
|
||||||
*)
|
|
||||||
)
|
)
|
||||||
in
|
in
|
||||||
let env, code =
|
let env, code =
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue