diff --git a/runtime/runtime.c b/runtime/runtime.c index bd8c5fb25..ec18b5fb0 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -810,7 +810,7 @@ extern void __gc_root_scan_stack (); /* ======================================== */ //static size_t SPACE_SIZE = 128; -static size_t SPACE_SIZE = 1280; +static size_t SPACE_SIZE = 1024 * 1024; # define POOL_SIZE (2*SPACE_SIZE) static void swap (size_t ** a, size_t ** b) { diff --git a/src/Language.ml b/src/Language.ml index 918e78348..8472464de 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -304,6 +304,10 @@ module Expr = *) @type 'a value = ('a, 'a value State.t array) Value.t with show, html @type 'a config = 'a value State.t * int list * int list * 'a value list with show, html + (* Reff : parsed expression should return value Reff (look for ":="); + Val : -//- returns simple value; + Void : parsed expression should not return any value; *) + @type atr = Reff | Void | Val with show, html (* The type for expressions. Note, in regular OCaml there is no "@type..." notation, it came from GT. *) @@ -326,7 +330,7 @@ module Expr = (* 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 * Loc.t + (* pattern-matching *) | Case of t * (Pattern.t * t) list * Loc.t * atr (* return statement *) | Return of t option (* ignore a value *) | Ignore of t (* unit value *) | Unit @@ -337,11 +341,6 @@ module Expr = (* control (for control flow) *) | Control of (t config, t * t config) arrow and decl = [`Local | `Public | `Extern | `PublicExtern ] * [`Fun of string list * t | `Variable of t option] with show, html - - (* Reff : parsed expression should return value Reff (look for ":="); - Val : -//- returns simple value; - Void : parsed expression should not return any value; *) - type atr = Reff | Void | Val let notRef x = match x with Reff -> false | _ -> true let isVoid x = match x with Void -> true | _ -> false @@ -501,7 +500,7 @@ module Expr = | Repeat (s, e) -> eval conf (seq (While (Binop ("==", e, Const 0), s)) k) s | Return e -> (match e with None -> (st, i, o, []) | Some e -> eval (st, i, o, []) Skip e) - | Case (e, bs, _)-> + | 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) (fun _ -> "") (fun _ -> "") v)) | (patt, body)::tl -> @@ -547,27 +546,27 @@ module Expr = (* 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, l) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs, l) - | _ -> raise (Semantic_error "not a destination") + | 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, l, a) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs, l, a) + | _ -> raise (Semantic_error "not a destination") (* Balance values *) let rec balance_value = function - | Array es -> Array (List.map balance_value es) - | Sexp (s, es) -> Sexp (s, List.map balance_value es) - | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) - | Elem (b, i) -> Elem (balance_value b, balance_value i) - | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) - | Length x -> Length (balance_value x) - | StringVal x -> StringVal (balance_value x) - | Call (f, es) -> Call (balance_value f, List.map balance_value es) - | Assign (d, s) -> Assign (balance_value d, balance_value s) - | Seq (l, r) -> Seq (balance_void l, balance_value r) - | If (c, t, e) -> If (balance_value c, balance_value t, balance_value e) - | Case (e, ps, l) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps, l) + | Array es -> Array (List.map balance_value es) + | Sexp (s, es) -> Sexp (s, List.map balance_value es) + | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) + | Elem (b, i) -> Elem (balance_value b, balance_value i) + | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) + | Length x -> Length (balance_value x) + | StringVal x -> StringVal (balance_value x) + | Call (f, es) -> Call (balance_value f, List.map balance_value es) + | Assign (d, s) -> Assign (balance_value d, balance_value s) + | Seq (l, r) -> Seq (balance_void l, balance_value r) + | If (c, t, e) -> If (balance_value c, balance_value t, balance_value e) + | Case (e, ps, l, a) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps, l, a) | Return _ | While _ @@ -576,15 +575,15 @@ module Expr = | e -> e and balance_void = function - | If (c, t, e) -> If (balance_value c, balance_void t, balance_void e) - | Seq (l, r) -> Seq (balance_void l, balance_void r) - | Case (e, ps, l) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps, l) - | While (e, s) -> While (balance_value e, balance_void s) - | Repeat (s, e) -> Repeat (balance_void s, balance_value e) - | Return (Some e) -> Return (Some (balance_value e)) - | Return None -> Return None - | Skip -> Skip - | e -> Ignore (balance_value e) + | If (c, t, e) -> If (balance_value c, balance_void t, balance_void e) + | Seq (l, r) -> Seq (balance_void l, balance_void r) + | Case (e, ps, l, a) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps, l, a) + | While (e, s) -> While (balance_value e, balance_void s) + | Repeat (s, e) -> Repeat (balance_void s, balance_value e) + | Return (Some e) -> Return (Some (balance_value e)) + | Return None -> Return None + | Skip -> Skip + | e -> Ignore (balance_value e) (* places ignore if expression should be void *) let ignore atr expr = if isVoid atr then Ignore expr else expr @@ -661,7 +660,7 @@ module Expr = | `Len -> Length b | `Str -> StringVal b | `Post (f, args) -> Call (Var f, b :: match args with None -> [] | Some args -> args) - | `Call args -> (match b with Sexp _ -> invalid_arg "retry!" | _ -> Call (b, args)) + | `Call args -> (match b with Sexp _ -> invalid_arg "retry!" | _ -> Call (b, args)) ) b is @@ -719,11 +718,7 @@ module Expr = | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e} | %"case" l:$ e:parse[def][infix][Val] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])] %"esac" - {Case (e, bs, l#coord)} - -(* | %"case" l:$ e:parse[def][infix][Val] %"of" bs:(!(Pattern.parse) -"->" scope[def][infix][Void][parse def]) => {isVoid atr} => %"esac" - {Case (e, [bs], l#coord)} - *) + {Case (e, bs, l#coord, atr)} | -"(" parse[def][infix][atr] -")" ) diff --git a/src/SM.ml b/src/SM.ml index 5b5aeb8b6..459a10114 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -30,7 +30,7 @@ open Language (* checks the tag and arity of S-expression *) | TAG of string * int (* checks the tag and size of array *) | ARRAY of int (* checks various patterns *) | PATT of patt -(* match failure *) | FAIL of Loc.t +(* match failure (location, leave a value *) | FAIL of Loc.t * bool (* external definition *) | EXTERN of string (* public definition *) | PUBLIC of string with show @@ -207,7 +207,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' | PATT Closure -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Closure _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg' - | FAIL l -> let x::_ = stack in + | FAIL (l, _) -> let x::_ = stack in raise (Failure (Printf.sprintf "matching value %s failure at %s" (show(value) x) (show(Loc.t) l))) ) @@ -715,7 +715,7 @@ let compile cmd ((imports, infixes), p) = | Expr.Leave -> env, false, [] - | Expr.Case (e, brs, loc) -> + | Expr.Case (e, brs, loc, atr) -> let n = List.length brs - 1 in let lfail, env = env#get_label in let lexp , env = env#get_label in @@ -740,7 +740,7 @@ let compile cmd ((imports, infixes), p) = ) (env, None, 0, [], true) brs in - env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] @ if fail then [LABEL lfail; FAIL loc] else [] + env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] @ if fail then [LABEL lfail; FAIL (loc, atr != Expr.Void); JMP l] else [] in let rec compile_fundef env ((name, args, stmt, st) as fd) = (* Printf.eprintf "Compile fundef: %s, state=%s\n" name (show(State.t) (show(Value.designation)) st); *) diff --git a/src/X86.ml b/src/X86.ml index de4c3ef31..859d596b6 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -463,8 +463,8 @@ let compile cmd env code = | Closure -> ".closure_tag_patt" ) 1 - | FAIL (line, col) -> - let v, env = env#pop in + | FAIL ((line, col), value) -> + let v, env = if value then env#peek, env else env#pop in let s, env = env#string cmd#get_infile in env, [Push (L col); Push (L line); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (3 * word_size), esp)] diff --git a/stdlib/Collection.expr b/stdlib/Collection.expr new file mode 100644 index 000000000..ddfbf176f --- /dev/null +++ b/stdlib/Collection.expr @@ -0,0 +1,124 @@ +-- MNode (key, list of values, balance factor, left subtree, right subtree) +-- balance factor = height (left subtree) - height (right subtree) +fun insert (m, k, v) { + fun rot (left, node) { + return + if left + then case node of + MNode (k, v, _, l, MNode (rk, rv, _, ll, rr)) -> + MNode (rk, rv, 0, MNode (k, v, 0, l, ll), rr) + esac + else case node of + MNode (k, v, _, MNode (lk, lv, _, ll, rr), r) -> + MNode (lk, lv, 0, ll, MNode (k, v, 0, rr, r)) + esac + fi + } + + fun factor (x) { + return x [2] + } + + fun inner (m, k, v) { + return + case m of + {} -> [true, MNode (k, {v}, 0, {}, {})] + | MNode (kk, vv, bf, l, r) -> + local c = compare (k, kk); + if c == 0 + then [false, MNode (kk, v : vv, bf, l, r)] + else if c < 0 + then + case inner (l, k, v) of + [true, ll] -> if bf < 0 + then [false, MNode (kk, vv, bf + 1, ll, r)] + elif bf == 1 + then if ll.factor > 0 + then [false, rot (false, MNode (kk, vv, bf, ll, r))] + else [false, rot (false, MNode (kk, vv, bf, rot (true, ll), r))] + fi + else [true, MNode (kk, vv, bf + 1, ll, r)] + fi + | [false, ll] -> [false, MNode (kk, vv, bf, ll, r)] + esac + else + case inner (r, k, v) of + [true, rr] -> if bf > 0 + then [false, MNode (kk, vv, bf - 1, l, rr)] + elif bf == -1 + then if rr.factor < 0 + then [false, rot (true, MNode (kk, vv, bf, l, rr))] + else [false, rot (true, MNode (kk, vv, bf, l, rot (false, rr)))] + fi + else [true, MNode (kk, vv, bf - 1, l, rr)] + fi + | [false, rr] -> [false, MNode (kk, vv, bf, l, rr)] + esac + fi + fi + esac + } + + return inner (m, k, v).snd +} + +fun find (m, k) { + return + case m of + {} -> None + | MNode (kk, vv, _, l, r) -> + local c = compare (k, kk); + if c == 0 + then case vv of v : _ -> Some (v) | _ -> None esac + else find (if c < 0 then l else r fi, k) + fi + esac +} + +fun remove (m, k) { + return + case m of + {} -> m + | MNode (kk, vv, bf, l, r) -> + local c = compare (k, kk); + if c == 0 + then case vv of {} -> m | _ : vt -> MNode (kk, vt, l, r) esac + else if c < 0 + then MNode (kk, vv, bf, remove (l, k), r) + else MNode (kk, vv, bf, l, remove (r, k)) + fi + fi + esac +} + +fun validate (t) { + fun inner (t, verify) { + return + case t of + {} -> 0 + | MNode (k, _, bf, l, r) -> + if verify (k) + then + local lh = validate (l, fun (x) {return x < k}), + rh = validate (r, fun (x) {return x > k}); + + if bf == lh - rh + then 1 + if lh > rh then lh else rh fi + else failure ("Balance violation on key %s\n", k.string) + fi + else failure ("Order violation on key %s\n", k.string) + fi + esac + } + + inner (t, fun (x) {return true}) +} + +local tree = {}, i; + +for i := 1, i <= 100, i := i+1 do + validate (tree); + tree := insert (tree, i, i); + printf ("Inserting: %s\n", i.string); + printf ("Result : %s\n", tree.string) +od \ No newline at end of file