From d0c72844e8c7b0f36eb43a3050b3cd21b3c7682f Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 2 Apr 2019 19:51:46 +0300 Subject: [PATCH] Stmt -> Expr in interpretation only --- regression/Makefile | 4 +- regression/deep-expressions/Makefile | 4 +- regression/expressions/Makefile | 4 +- regression/test034.expr | 2 +- regression/test039.expr | 6 +- regression/test047.expr | 2 +- src/Language.ml | 548 ++++++++++++++------------- src/SM.ml | 40 +- src/X86.ml | 10 +- 9 files changed, 310 insertions(+), 310 deletions(-) diff --git a/regression/Makefile b/regression/Makefile index 384fefd72..d061cf589 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,9 +7,9 @@ RC=../src/rc.opt check: $(TESTS) $(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) -s $< > $@.log && diff $@.log orig/$@.log + #@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: $(RM) test*.log *.s *~ $(TESTS) diff --git a/regression/deep-expressions/Makefile b/regression/deep-expressions/Makefile index e46f56420..c27224569 100644 --- a/regression/deep-expressions/Makefile +++ b/regression/deep-expressions/Makefile @@ -7,9 +7,9 @@ RC = ../../src/rc.opt check: $(TESTS) $(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) -s $< > $@.log && diff $@.log orig/$@.log + #@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: rm -f *.log *.s *~ diff --git a/regression/expressions/Makefile b/regression/expressions/Makefile index 3b2afb53a..244d76bbb 100644 --- a/regression/expressions/Makefile +++ b/regression/expressions/Makefile @@ -7,9 +7,9 @@ RC = ../../src/rc.opt check: $(TESTS) $(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) -s $< > $@.log && diff $@.log orig/$@.log + #@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: rm -f *.log *.s *~ diff --git a/regression/test034.expr b/regression/test034.expr index 0a624a069..90e74b95f 100644 --- a/regression/test034.expr +++ b/regression/test034.expr @@ -11,7 +11,7 @@ x := "abcdefgh"; printString (x); for i:=0, i return 0 | Node (y, l, r) -> if x == y then return 1 - elif x > y then return find (l, x) - else return find (r, x) - fi + elif x > y then return find (l, x) + else return find (r, x) + fi esac } diff --git a/regression/test047.expr b/regression/test047.expr index ef53c9593..5a1f15c23 100644 --- a/regression/test047.expr +++ b/regression/test047.expr @@ -38,7 +38,7 @@ case 1 of | a@3 -> write (a) | a@2 -> write (a) | a@1 -> write (a) -| a@0 -> write (a) +| a@0 -> write (a) esac; case A (1, 2, 3) of diff --git a/src/Language.ml b/src/Language.ml index 4778efbc0..9a01a614d 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -1,6 +1,7 @@ (* Opening a library for generic programming (https://github.com/dboulytchev/GT). The library provides "@type ..." syntax extension and plugins like show, etc. *) +module OrigList = List open GT (* 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 = 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 | Int n -> n @@ -29,7 +38,7 @@ module Value = | Array a -> a | _ -> 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_string s = String s let of_array a = Array a @@ -49,20 +58,20 @@ module Value = | String s -> append "\""; append @@ Bytes.to_string s; append "\"" | Array a -> let n = Array.length a in 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" then ( append "{"; let rec inner_list = function - | [] -> () - | [x; Int 0] -> inner x - | [x; Sexp ("cons", a)] -> inner x; append ", "; inner_list a + | [||] -> () + | [|x; Int 0|] -> inner x + | [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a in inner_list a; append "}" ) else ( 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 ")")) ) in @@ -137,41 +146,112 @@ module State = module Builtin = struct - let eval (st, i, o, _) args = function - | "read" -> (match i with z::i' -> (st, i', o, Some (Value.of_int z)) | _ -> failwith "Unexpected end of input") - | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], None) + 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], vs) | ".elem" -> let [b; j] = args in (st, i, o, let i = Value.to_int j in - Some (match b with - | Value.String s -> Value.of_int @@ Char.code (Bytes.get s i) - | Value.Array a -> a.(i) - | Value.Sexp (_, a) -> List.nth a i - ) + (match b with + | Value.String s -> Value.of_int @@ Char.code (Bytes.get s i) + | Value.Array a -> a.(i) + | Value.Sexp (_, a) -> a.(i) + ) :: 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, Some (Value.of_array @@ Array.of_list args)) - | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) + | ".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) end - + +(* Patterns *) +module Pattern = + struct + + (* The type for patterns *) + @type t = + (* wildcard "-" *) | Wildcard + (* S-expression *) | Sexp of string * t list + (* array *) | Array of t list + (* identifier *) | Named of string * t + (* ground integer *) | Const of int + (* ground string *) | String of string + (* boxed value *) | Boxed + (* unboxed value *) | UnBoxed + (* any string value *) | StringTag + (* any sexp value *) | SexpTag + (* any array value *) | ArrayTag + with show, foldl + + (* Pattern parser *) + ostap ( + 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, [":"]|] + ) + primary); + primary: + %"_" {Wildcard} + | t:UIDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} + | "[" ps:(!(Util.list0)[parse]) "]" {Array ps} + | "{" ps:(!(Util.list0)[parse]) "}" {match ps with + | [] -> UnBoxed + | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) ps UnBoxed + } + | x:LIDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)} + | c:DECIMAL {Const c} + | s:STRING {String (unquote s)} + | c:CHAR {Const (Char.code c)} + | "#" %"boxed" {Boxed} + | "#" %"unboxed" {UnBoxed} + | "#" %"string" {StringTag} + | "#" %"sexp" {SexpTag} + | "#" %"array" {ArrayTag} + | -"(" 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 + + 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 + *) + 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 - (* 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 + 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 + (* empty statement *) | Skip + (* conditional *) | If of t * t * t + (* loop with a pre-condition *) | While of t * t + (* loop with a post-condition *) | Repeat of t * t + (* pattern-matching *) | Case of t * (Pattern.t * t) list + (* return statement *) | Return of t option + (* leave a scope *) | Leave + (* intrinsic (for evaluation) *) | Intrinsic of (config -> config) + (* control (for control flow) *) | Control of (config -> t * config) (* Available binary operators: !! --- disjunction @@ -181,12 +261,20 @@ module Expr = *, /, % --- 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 - + (* Update state *) + let update st x v = + match x with + | Value.Var x -> State.update x v st + | Value.Elem (x, i) -> + (match x with + | Value.Sexp (_, a) | Value.Array a -> ignore (Value.update_array a i v) + | Value.String a -> ignore (Value.update_string a i (Char.chr @@ Value.to_int v)) + ); + st + (* Expression evaluator - val eval : env -> config -> t -> int * config + val eval : env -> config -> k -> t -> config Takes an environment, a configuration and an expresion, and returns another configuration. The @@ -216,66 +304,131 @@ module Expr = | "&&" -> 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 = + + 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 - | Const n -> (st, i, o, Some (Value.of_int n)) - | String s -> (st, i, o, Some (Value.of_string @@ Bytes.of_string s)) + | 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 -> - 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)) + 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 -> - let (st, i, o, vs) = eval_list env conf xs in - env#definition env ".array" vs (st, i, o, None) + 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) -> - let (st, i, o, vs) = eval_list env conf xs in - (st, i, o, Some (Value.Sexp (t, vs))) + 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) -> - 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) + 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 -> - 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) - + 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)) + | (patt, body)::tl -> + let rec match_patt patt v st = + let update x v = function + | None -> None + | Some s -> Some (State.bind x v s) + in + match patt, v with + | Pattern.Named (x, p), v -> update x v (match_patt p v st ) + | Pattern.Wildcard , _ -> 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.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.Array _ + | Pattern.UnBoxed , Value.Int _ + | Pattern.Boxed , Value.Sexp (_, _) + | Pattern.StringTag , Value.String _ + | Pattern.ArrayTag , Value.Array _ + | Pattern.SexpTag , Value.Sexp (_, _) -> st + | _ -> None + and match_list ps vs s = + match ps, vs with + | [], [] -> s + | p::ps, v::vs -> match_list ps vs (match_patt p v s) + | _ -> None + in + 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 + 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 *) - ostap ( - parse[infix]: + + (* 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") + + ostap ( + parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)}; + basic[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})) * { + 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]) + | `Post f -> Call (Var f, [b]) ) b is @@ -290,7 +443,34 @@ module Expr = | _ -> 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} + | 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] + 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) + ) + } + + | %"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] -")" ) @@ -314,13 +494,15 @@ module Infix = 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) + | ":" -> 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 , ["&&"]; @@ -339,7 +521,7 @@ module Infix = 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 sem name x y = Expr.Call (Var name, [x; y]) let at coord op newp name infix = find_op infix op @@ -381,212 +563,32 @@ module Infix = end -(* Simple statements: syntax and sematics *) -module Stmt = - struct - - (* Patterns in statements *) - module Pattern = - struct - - (* The type for patterns *) - @type t = - (* wildcard "-" *) | Wildcard - (* S-expression *) | Sexp of string * t list - (* array *) | Array of t list - (* identifier *) | Named of string * t - (* ground integer *) | Const of int - (* ground string *) | String of string - (* boxed value *) | Boxed - (* unboxed value *) | UnBoxed - (* any string value *) | StringTag - (* any sexp value *) | SexpTag - (* any array value *) | ArrayTag - with show, foldl - - (* Pattern parser *) - ostap ( - 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, [":"]|] - ) - primary); - primary: - %"_" {Wildcard} - | t:UIDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} - | "[" ps:(!(Util.list0)[parse]) "]" {Array ps} - | "{" ps:(!(Util.list0)[parse]) "}" {match ps with - | [] -> UnBoxed - | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) ps UnBoxed - } - | x:LIDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)} - | c:DECIMAL {Const c} - | s:STRING {String (unquote s)} - | c:CHAR {Const (Char.code c)} - | "#" %"boxed" {Boxed} - | "#" %"unboxed" {UnBoxed} - | "#" %"string" {StringTag} - | "#" %"sexp" {SexpTag} - | "#" %"array" {ArrayTag} - | -"(" 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 - - end - - (* The type for statements *) - @type t = - (* assignment *) | Assign of string * Expr.t list * Expr.t - (* composition *) | Seq of t * t - (* empty statement *) | Skip - (* conditional *) | If of Expr.t * t * t - (* loop with a pre-condition *) | While of Expr.t * t - (* loop with a post-condition *) | Repeat of t * Expr.t - (* pattern-matching *) | Case of Expr.t * (Pattern.t * t) list - (* return statement *) | Return of Expr.t option - (* call a procedure *) | Expr of Expr.t - (* leave a scope *) | Leave with show - - (* Statement evaluator - - val eval : env -> config -> t -> config - - Takes an environment, a configuration and a statement, and returns another configuration. The - environment is the same as for expressions - *) - 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 = - let seq x = function Skip -> x | y -> Seq (x, y) in - match stmt with - | Leave -> eval env (State.drop st, i, o, r) Skip k - | Assign (x, is, e) -> - let (st, i, o, is) = Expr.eval_list env conf is in - let (st, i, o, Some v) = Expr.eval env (st, i, o, None) e in - eval env (update st x v is, i, o, None) Skip k - - | 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) -> 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) - | 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 - else eval env conf (seq stmt k) s - | 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) - | Expr e -> eval env (Expr.eval env conf e) k Skip - | Case (e, bs) -> - let (_, _, _, Some v) as conf' = Expr.eval env conf e in - let rec branch ((st, i, o, _) as conf) = function - | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v)) - | (patt, body)::tl -> - let rec match_patt patt v st = - let update x v = function - | None -> None - | Some s -> Some (State.bind x v s) - in - match patt, v with - | Pattern.Named (x, p), v -> update x v (match_patt p v 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.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.Array _ - | Pattern.UnBoxed , Value.Int _ - | Pattern.Boxed , Value.Sexp (_, _) - | Pattern.StringTag , Value.String _ - | Pattern.ArrayTag , Value.Array _ - | Pattern.SexpTag , Value.Sexp (_, _) -> st - | _ -> None - and match_list ps vs s = - match ps, vs with - | [], [] -> s - | p::ps, v::vs -> match_list ps vs (match_patt p v s) - | _ -> None - in - 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, None) k (Seq (body, Leave)) - in - branch conf' bs - - (* Statement parser *) - ostap ( - parse[infix]: - s:stmt[infix] ";" ss:parse[infix] {Seq (s, ss)} - | stmt[infix]; - stmt[infix]: - %"skip" {Skip} - | %"if" e:!(Expr.parse infix) - %"then" the:parse[infix] - elif:(%"elif" !(Expr.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) - ) - } - | %"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" { - 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} - | %"case" e:!(Expr.parse infix) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)} - | x:LIDENT - s:(is:(-"[" !(Expr.parse infix) -"]")* ":=" e :!(Expr.parse infix) {Assign (x, is, e)} - ) {s} - | e:!(Expr.parse infix) {Expr e} - ) - - end - (* Function and procedure definitions *) module Definition = struct (* 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 ( 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}; + | 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}) + | 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 | `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:!(Stmt.parse infix') "}" { + "{" body:!(Expr.parse 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 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 @@ -608,17 +610,17 @@ 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 _, _, o, _ = - Stmt.eval + Expr.eval (object - method definition env f args ((st, i, o, r) as conf) = + method definition env f args ((st, i, o, vs) as conf) = try - 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'', i', o', r' = Stmt.eval env (st', i, o, r) Skip s in - (State.leave st'' st, i', o', r') + 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'', i', o', vs' = Expr.eval env (st', i, o, []) Skip s in + (State.leave st'' st, i', o', match vs' with [v] -> v::vs | _ -> vs) with Not_found -> Builtin.eval conf args f end) - (State.empty, i, [], None) + (State.empty, i, [], []) Skip body in @@ -626,7 +628,7 @@ let eval (defs, body) i = (* Top-level parser *) 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]: <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''} | empty {[], infix} diff --git a/src/SM.ml b/src/SM.ml index a0b05e52d..63109861b 100644 --- a/src/SM.ml +++ b/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 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 @@ -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' | 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 - 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' | 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') @@ -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 eval env (cstack, y::x::stack', c) prg' | 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 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 @@ -128,8 +128,8 @@ let run p i = 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 args, stack' = split n stack in - let (st, i, o, r) = Language.Builtin.eval (st, i, o, None) (List.rev args) f in - let stack'' = if p then stack' else let Some r = r in r::stack' 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 [r] = r in r::stack' in (*Printf.printf "Builtin:\n";*) (cstack, stack'', (st, i, o)) end @@ -146,28 +146,29 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine *) -let compile (defs, p) = +let compile (defs, p) = invalid_arg "" +(* let label s = "L" ^ s in let rec call f args p = let args_code = List.concat @@ List.map expr args in args_code @ [CALL (label f, List.length args, p)] and pattern env lfalse = function - | Stmt.Pattern.Wildcard -> env, false, [DROP] - | Stmt.Pattern.Named (_, p) -> pattern env lfalse p - | Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)] - | Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)] - | Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)] - | Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)] - | Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] - | Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] - | Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] - | Stmt.Pattern.Array ps -> + | Pattern.Wildcard -> env, false, [DROP] + | Pattern.Named (_, p) -> pattern env lfalse p + | Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)] + | Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)] + | Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)] + | Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)] + | Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] + | Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] + | Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] + | Pattern.Array ps -> let lhead, 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 code, env = pattern_list lhead ldrop env ps in env, true, tag @ code @ [DROP] - | Stmt.Pattern.Sexp (t, ps) -> + | Pattern.Sexp (t, ps) -> let lhead, 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 @@ -186,9 +187,9 @@ let compile (defs, p) = List.flatten (List.rev code), env and bindings p = let bindings = - transform(Stmt.Pattern.t) + transform(Pattern.t) (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_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 @@ -315,3 +316,4 @@ let compile (defs, p) = let _, flag, code = compile_stmt lend env p in (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) + *) diff --git a/src/X86.ml b/src/X86.ml index b3f8d6862..bfe814df9 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -539,13 +539,9 @@ class env = *) let genasm (ds, stmt) = let stmt = - Language.Stmt.Seq ( - Language.Stmt.Expr (Language.Expr.Call ("__gc_init", [])), - Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("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])))) - *) + Language.Expr.Seq ( + 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])))) ) in let env, code =