diff --git a/regression/Makefile b/regression/Makefile index 0c712d8cf..16fdefec9 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -9,7 +9,7 @@ check: $(TESTS) $(TESTS): %: %.expr #@$(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 test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test039.log b/regression/orig/test039.log new file mode 100644 index 000000000..c41010416 --- /dev/null +++ b/regression/orig/test039.log @@ -0,0 +1,6 @@ +> 1 +1 +1 +1 +0 +0 diff --git a/regression/test038.expr b/regression/test038.expr index 623017ecd..e13e88c87 100644 --- a/regression/test038.expr +++ b/regression/test038.expr @@ -21,4 +21,3 @@ printList (x); printList (y); printList (append (x, y)); printList (append (y, x)) - diff --git a/regression/test039.expr b/regression/test039.expr new file mode 100644 index 000000000..1eaff0a70 --- /dev/null +++ b/regression/test039.expr @@ -0,0 +1,31 @@ +fun insert (t, x) { + case t of + `leaf -> return `node (x, `leaf, `leaf) + | `node (y, l, r) -> if x > y + then return `node (y, insert (l, x), r) + else return `node (y, l, insert (r, x)) + fi + esac +} + +fun find (t, x) { + case t of + `leaf -> 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 + esac +} + +n := read (); + +t := insert (insert (insert (insert (`leaf, 5), 4), 6), 3); + +write (find (t, 5)); +write (find (t, 4)); +write (find (t, 6)); +write (find (t, 3)); +write (find (t, 2)); +write (find (t, 1)) + diff --git a/regression/test039.input b/regression/test039.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test039.input @@ -0,0 +1 @@ +0 diff --git a/src/Language.ml b/src/Language.ml index 910ea3bf7..845988477 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -50,7 +50,10 @@ module State = (* Undefined state *) let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x) - + + (* Bind a variable to a value in a state *) + let bind x v s = fun y -> if x = y then v else s y + (* Empty state *) let empty = G undefined @@ -58,11 +61,10 @@ module State = to value v and returns the new state w.r.t. a scope *) let update x v s = - let u x v s = fun y -> if x = y then v else s y in let rec inner = function - | G s -> G (u x v s) + | G s -> G (bind x v s) | L (scope, s, enclosing) -> - if List.mem x scope then L (scope, u x v s, enclosing) else L (scope, s, inner enclosing) + if List.mem x scope then L (scope, bind x v s, enclosing) else L (scope, s, inner enclosing) in inner s @@ -109,8 +111,9 @@ module Builtin = | ".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 s.[i] - | Value.Array a -> List.nth a i + | Value.String s -> Value.of_int @@ Char.code s.[i] + | Value.Array a -> List.nth a i + | Value.Sexp (_, a) -> List.nth a i ) ) | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s))) @@ -266,11 +269,6 @@ module Stmt = (* wildcard "-" *) | Wildcard (* S-expression *) | Sexp of string * t list (* identifier *) | Ident of string - (* constant *) | Const of int - (* string *) | String of string - (* array *) | Array of t list - (* arbitrary array *) | IsArray - (* arbitrary string *) | IsString with show, foldl (* Pattern parser *) @@ -279,16 +277,10 @@ module Stmt = %"_" {Wildcard} | "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} | x:IDENT {Ident x} - | n:DECIMAL {Const n} - | s:STRING {String s} - | a:(-"[" !(Util.list)[parse] -"]") {Array a} - | "#" "[" "]" {IsArray} - | "#" {IsString} ) let vars p = - let module S = Set.Make (String) in - S.elements @@ transform(t) (object inherit [S.t] @t[foldl] method c_Ident s _ name = S.add name s end) S.empty p + transform(t) (object inherit [string list] @t[foldl] method c_Ident s _ name = name::s end) [] p end @@ -300,7 +292,7 @@ module Stmt = (* 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 * Expr.t option * t) list + (* pattern-matching *) | Case of Expr.t * (Pattern.t * t) list (* return statement *) | Return of Expr.t option (* call a procedure *) | Call of string * Expr.t list (* leave a scope *) | Leave with show @@ -344,43 +336,29 @@ module Stmt = | Return e -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e) | Call (f, args) -> eval env (Expr.eval env conf (Expr.Call (f, args))) 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, con, body)::tl -> - let rec match_patt patt v st = - let update x v = function - | None -> None - | Some s -> Some (fun y -> if y = x then v else s y) - in - match patt, v with - | Pattern.Ident x , v -> update x v st - | Pattern.Wildcard , _ -> st - | Pattern.Const n , Value.Int n' when n = n' -> st - | Pattern.String s , Value.String s' when s = s' -> st - | Pattern.Array p , Value.Array p' -> match_list p p' st - | Pattern.IsArray , Value.Array _ -> st - | Pattern.IsString , Value.String _ -> st - | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs 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' -> - let st'' = State.push st st' (Pattern.vars patt) in - let (st''', i', o', Some c) = - match con with - | None -> (st'', i, o, Some (Value.of_int 1)) - | Some c -> Expr.eval env (st'', i, o, None) c + 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 - if Value.to_int c <> 0 - then eval env (st''', i', o', None) k (Seq (body, Leave)) - else branch (st''', i', o', None) tl + match patt, v with + | Pattern.Ident x , v -> update x v st + | Pattern.Wildcard , _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs 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 @@ -409,7 +387,7 @@ module Stmt = } | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} | %"return" e:!(Expr.parse)? {Return e} - | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? -"->" parse)] %"esac" {Case (e, bs)} + | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse)] %"esac" {Case (e, bs)} | x:IDENT s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} | "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)} diff --git a/src/Makefile b/src/Makefile index 8eb66bcfd..489cb2c69 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,12 +1,11 @@ TOPFILE = rc -OCAMLC = ocamlc -OCAMLOPT = ocamlopt -OCAMLDEP = ocamldep +OCAMLC = ocamlfind c +OCAMLOPT = ocamlfind opt +OCAMLDEP = ocamlfind dep SOURCES = Language.ml SM.ml X86.ml Driver.ml -LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma -CAMLP5 = -pp "camlp5o -I `ocamlfind -query GT.syntax` -I `ocamlfind -query ostap.syntax` pa_ostap.cmo pa_gt.cmo -L `ocamlfind -query GT.syntax`" +CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap` +BFLAGS = -rectypes OFLAGS = $(BFLAGS) all: .depend $(TOPFILE).opt @@ -15,10 +14,10 @@ all: .depend $(TOPFILE).opt $(OCAMLDEP) $(PXFLAGS) *.ml > .depend $(TOPFILE).opt: $(SOURCES:.ml=.cmx) - $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx) + $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx) $(TOPFILE).byte: $(SOURCES:.ml=.cmo) - $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo) + $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo) clean: rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend diff --git a/src/SM.ml b/src/SM.ml index bb28a1992..39a421007 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -17,7 +17,13 @@ open Language (* end procedure definition *) | END (* calls a function/procedure *) | CALL of string * int * bool (* returns from a function *) | RET of bool - | DROP | DUP | OVER with show +(* drops the top element off *) | DROP +(* duplicates the top element *) | DUP +(* swaps two top elements *) | SWAP +(* checks the tag of S-expression *) | TAG of string +(* enters a scope *) | ENTER of string list +(* leaves a scope *) | LEAVE +with show (* The type for the stack machine program *) type prg = insn list @@ -69,6 +75,17 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' | [] -> conf ) + | DROP -> eval env (cstack, List.tl stack, c) prg' + | DUP -> eval env (cstack, List.hd stack :: stack, c) prg' + | SWAP -> let x::y::stack' = stack in + eval env (cstack, y::x::stack', c) prg' + | TAG t -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', _) when t' = t -> 1 | _ -> 0) :: stack', c) prg' + + | ENTER xs -> let vs, stack' = split (List.length xs) stack in + eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' + + | LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg' ) (* Top-level evaluation @@ -78,7 +95,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function Takes a program, an input stream, and returns an output stream this program calculates *) let run p i = - (*print_prg p; *) + (*print_prg p;*) let module M = Map.Make (String) in let rec make_map m = function | [] -> m @@ -117,25 +134,29 @@ let compile (defs, p) = 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 = function - | Stmt.Pattern.Wildcard -> [DROP; CONST 1] - | Stmt.Pattern.Const n -> [CONST n; BINOP "=="] - | Stmt.Pattern.String s -> [STRING s; CALL ("strcmp", 2, false)] - | Stmt.Pattern.Ident n -> [DROP; CONST 1] - | Stmt.Pattern.Array ps -> [DUP; - CALL ("isArray", 1, false); - OVER; - CALL (".length", 1, false); - CONST (List.length ps); - BINOP "=="; - BINOP "&&"; - ] - | Stmt.Pattern.IsArray -> [CALL ("isArray", 1, false)] - | Stmt.Pattern.IsString -> [CALL ("isString", 1, false)] - | Stmt.Pattern.Sexp (t, ps) -> [] - and patterns = function - | [] -> [] - | (e, p)::ps -> expr e @ pattern p @ [BINOP "&&"] @ patterns ps + and pattern lfalse = function + | Stmt.Pattern.Wildcard -> false, [DROP] + | Stmt.Pattern.Ident n -> false, [DROP] + | Stmt.Pattern.Sexp (t, ps) -> + true, + [DUP; TAG t; CJMP ("z", lfalse)] @ + (List.concat @@ + List.mapi + (fun i p -> + [DUP; CONST i; CALL (".elem", 2, false)] @ + snd @@ pattern lfalse p + ) + ps + ) + and bindings p = + let rec inner = function + | Stmt.Pattern.Ident n -> [SWAP] + | Stmt.Pattern.Wildcard -> [DROP] + | Stmt.Pattern.Sexp (_, ps) -> + (List.flatten @@ List.mapi (fun i p -> [DUP; CONST i; CALL (".elem", 2, false)] @ inner p) ps) @ + [DROP] + in + inner p @ [ENTER (Stmt.Pattern.vars p)] and expr = function | Expr.Var x -> [LD x] | Expr.Const n -> [CONST n] @@ -143,7 +164,7 @@ let compile (defs, p) = | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] | Expr.Call (f, args) -> call f args false | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)] - | Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)] + | Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [SEXP (t, List.length xs)] | Expr.Elem (a, i) -> expr a @ expr i @ [CALL (".elem", 2, false)] | Expr.Length e -> expr e @ [CALL (".length", 1, false)] in @@ -175,6 +196,31 @@ let compile (defs, p) = | Stmt.Call (f, args) -> env, false, call f args true | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)] + + | Stmt.Leave -> env, false, [LEAVE] + + | Stmt.Case (e, [p, s]) -> + let pflag, pcode = pattern l p in + let env, sflag, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in + env, pflag || sflag, expr e @ pcode @ bindings p @ scode + + | Stmt.Case (e, brs) -> + let n = List.length brs - 1 in + let env, _, _, code = + List.fold_left + (fun (env, lab, i, code) (p, s) -> + let (lfalse, env), jmp = + if i = n + then (l, env), [] + else env#get_label, [JMP l] + in + let _, pcode = pattern lfalse p in + let env, _, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in + (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l]) @ pcode @ bindings p @ scode @ jmp) :: code) + ) + (env, None, 0, []) brs + in + env, true, expr e @ List.flatten @@ List.rev code in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in