Stdlib: initial version

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) {

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
@@ -338,11 +342,6 @@ module Expr =
     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
     let isValue x = match x with Void -> false | _ -> true       (* functions for handling atribute *)
@@ -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 _ -> "<expr>") (fun _ -> "<state>") v))
          | (patt, body)::tl ->
@@ -551,7 +550,7 @@ module Expr =
     | 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)
+    | 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 *)
@@ -567,7 +566,7 @@ module Expr =
     | 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)
+    | Case      (e, ps, l, a) -> Case      (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps, l, a)
 
     | Return    _
     | While     _
@@ -578,7 +577,7 @@ module Expr =
     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)
+    | 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))
@@ -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 (e, bs, l#coord, atr)}      
-      
-(*      | %"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)} 
- *)
       | -"(" parse[def][infix][atr] -")"
     )
 

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);                *)

src/X86.ml

@@ -463,8 +463,8 @@ let compile cmd env code =
                 | Closure -> ".closure_tag_patt"
                ) 1
 
-          | FAIL (line, col) ->                       
+          | FAIL ((line, col), value) ->                       
-             let v, env = env#pop in
+             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)]
              

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