mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Stdlib: initial version
This commit is contained in:
Dmitry Boulytchev
parent
ad920df098
commit
59a7d48568
5 changed files with 166 additions and 47 deletions
|
|
@ -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) {
|
||||
|
|
|
|||
|
|
@ -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 _ -> "<expr>") (fun _ -> "<state>") 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] -")"
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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); *)
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
||||
|
|
|
|||
124
stdlib/Collection.expr
Normal file
124
stdlib/Collection.expr
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue