diff --git a/runtime/Std.i b/runtime/Std.i index 8ac04441b..907a38bb2 100644 --- a/runtime/Std.i +++ b/runtime/Std.i @@ -1,3 +1,4 @@ +F,makeArray; F,clone; F,hash; F,fst; diff --git a/runtime/runtime.c b/runtime/runtime.c index 7078064e6..edbc2e97b 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -650,6 +650,24 @@ extern void* Belem (void *p, int i) { return (void*) ((int*) a->contents)[i]; } +extern void* LmakeArray (int length) { + data *r; + int n; + + ASSERT_UNBOXED("makeArray:1", length); + + __pre_gc (); + + n = UNBOX(length); + r = (data*) alloc (sizeof(int) * (n+1)); + + r->tag = ARRAY_TAG | (n << 3); + + __post_gc (); + + return r->contents; +} + extern void* LmakeString (int length) { int n = UNBOX(length); data *r; diff --git a/src/Language.ml b/src/Language.ml index 4ae458e5d..c0560144d 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -916,9 +916,9 @@ module Definition = | `Extern, Some _ -> report_error ~loc:(Some l#coord) (Printf.sprintf "initial value for an external variable \"%s\" can not be specified" name) | _ -> name, (m,`Variable value) }; - parse[infix][expr][def]: + parse[infix][expr][expr'][def]: m:(%"local" {`Local} | %"public" e:(%"external")? {match e with None -> `Public | Some _ -> `PublicExtern} | %"external" {`Extern}) - locs:!(Util.list (local_var m infix expr def)) ";" {locs, infix} + locs:!(Util.list (local_var m infix expr' def)) ";" {locs, infix} | - <(m, orig_name, name, infix', flag)> : head[infix] -"(" -args:!(Util.list0 arg) -")" (l:$ "{" body:expr[def][infix'][Expr.Weak] "}" { if flag && List.length args != 2 then report_error ~loc:(Some l#coord) "infix operator should accept two arguments"; @@ -1056,7 +1056,9 @@ ostap ( (is, Infix.extract_exports infix'), Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e) }; definitions[infix]: - <(def, infix')> : !(Definition.parse infix (fun def infix atr -> Expr.scope def infix atr (Expr.parse def)) definitions) <(defs, infix'')> : definitions[infix'] { + <(def, infix')> : !(Definition.parse infix (fun def infix atr -> Expr.scope def infix atr (Expr.parse def)) + (fun def infix atr -> Expr.basic def infix atr) + definitions) <(defs, infix'')> : definitions[infix'] { def @ defs, infix'' } | empty {[], infix} diff --git a/stdlib/Array.expr b/stdlib/Array.expr new file mode 100644 index 000000000..f17b51bab --- /dev/null +++ b/stdlib/Array.expr @@ -0,0 +1,73 @@ +import List; + +public fun initArray (n, f) { + local a = makeArray (n), i; + + for i := 0, i < n, i := i + 1 do + a [i] := f (i) + od; + + a +} + +public fun mapArray (f, a) { + initArray (a.length, fun (i) {a[i]}) +} + +public fun arrayList (a) { + local i = 0, res = [0, {}], curr = res; + + for skip, i < a.length, i := i + 1 do + curr [1] := a [i] : curr [1]; + curr := curr [1] + od; + + res [1] +} + +public fun listArray (l) { + local a = makeArray (l.size); + + fun inner (i, l) { + case l of {} -> skip | h : t -> a[i] := h; inner (i+1, t) esac + } + + inner (0, l); + a +} + +public fun foldlArray (f, acc, a) { + local i = 0; + + for skip, i < a.length, i := i+1 do + acc := f (acc, a[i]) + od; + + acc +} + +public fun foldrArray (f, acc, a) { + local i = a.length - 1; + + for skip, i >= 0, i := i-1 do + acc := f (acc, a[i]) + od; + + acc +} + +public fun iterArray (f, a) { + local i = 0; + + for skip, i < a.length, i := i+1 do + f (a [i]) + od +} + +public fun iteriArray (f, a) { + local i = 0; + + for skip, i < a.length, i := i+1 do + f (i, a [i]) + od +} diff --git a/stdlib/Collection.expr b/stdlib/Collection.expr index d1f0f6e5e..701ce5f12 100644 --- a/stdlib/Collection.expr +++ b/stdlib/Collection.expr @@ -6,15 +6,14 @@ import List; -fun insertColl (m, k, v, sort) { +fun insertColl (m, pk, v, sort) { + local k = case sort of Hash -> hash (pk) | _ -> pk esac; + fun append (v, vs) { case sort of Map -> v : vs | Set -> v - | Hash -> case find (fun (x) {x == v}, vs) of - None -> v : vs - | _ -> vs - esac + | Hash -> [pk, v] : vs esac } @@ -75,11 +74,17 @@ fun insertColl (m, k, v, sort) { inner (m).snd } -fun findColl (m, k, sort) { +fun findColl (m, pk, sort) { + local k = case sort of Hash -> hash (pk) | _ -> pk esac; + fun extract (vv) { case sort of - Map -> case vv of v : _ -> Some (v) | _ -> None esac - | Set -> Some (vv) + Map -> case vv of v : _ -> Some (v) | _ -> None esac + | Set -> Some (vv) + | Hash -> case find (fun (x) {x.fst == pk}, vv) of + Some (p) -> Some (p.snd) + | None -> None + esac esac } @@ -98,11 +103,14 @@ fun findColl (m, k, sort) { inner (m) } -fun removeColl (m, k, sort) { +fun removeColl (m, pk, sort) { + local k = case sort of Hash -> hash (pk) | _ -> pk esac; + fun delete (vs) { case sort of - Map -> case vs of {} -> {} | _ : vv -> vv esac - | Set -> false + Map -> case vs of {} -> {} | _ : vv -> vv esac + | Set -> false + | Hash -> remove (fun (x) {x.fst == pk}, vs) esac } @@ -249,11 +257,45 @@ public fun foldSet (f, acc, s) { foldl (f, acc, elements (s)) } --- Hash structure +-- Hash consing public fun emptyMemo () { [{}] } public fun lookupMemo (m, v) { - skip + case v of + #unboxed -> v + | _ -> + case findMap (m[0], v) of + Some (w) -> w + | None -> + case v of + #string -> m[0] := addMap (m[0], v, v); v + | _ -> + local vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac; + for skip, i < v.length, i := i + 1 do + vc [i] := lookupMemo (m, vc [i]) + od; + m[0] := addMap (m[0], vc, vc); + vc + esac + esac + esac +} + +-- Maps of hashed pointers +public fun emptyHashTab () { + {} +} + +public fun addHashTab (t, k, v) { + insertColl (t, k, v, Hash) +} + +public fun findHashTab (t, k) { + findColl (t, k, Hash) +} + +public fun removeHashTab (t, k) { + removeColl (t, k, Hash) } \ No newline at end of file diff --git a/stdlib/List.expr b/stdlib/List.expr index 4bece0362..26ebe507b 100644 --- a/stdlib/List.expr +++ b/stdlib/List.expr @@ -1,3 +1,10 @@ +public fun size (l) { + case l of + {} -> 0 + | _ : t -> 1 + size (t) + esac +} + public fun foldl (f, acc, l) { case l of {} -> acc @@ -59,13 +66,13 @@ public fun find (f, l) { } public fun flatten (l) { - local res = [0, {}]; + local res = [0, {}], curr = [res]; fun append (x) { - local new = {x}; + local new = x : {}; - res [1] := new; - res := new + curr [0][1] := new; + curr [0] := new } iter (fun (x) {iter (append, x)}, l); @@ -88,4 +95,18 @@ public fun unzip (a) { [aa, bb] -> [a : aa, b : bb] esac esac +} + +public fun remove (f, l) { + case l of + {} -> {} + | h : t -> if f (h) then t else h : remove (f, t) fi + esac +} + +public fun filter (f, l) { + case l of + {} -> {} + | h : t -> if f (h) then h : filter (f, t) else filter (f, t) fi + esac } \ No newline at end of file diff --git a/stdlib/Makefile b/stdlib/Makefile index d0f6b3e29..e608e70c3 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -8,6 +8,8 @@ all: $(ALL) Collection.o: List.o +Array.o: List.o + %.o: %.expr $(RC) -I . -c $< diff --git a/stdlib/regression/Makefile b/stdlib/regression/Makefile index 606ab2227..d76ef6592 100644 --- a/stdlib/regression/Makefile +++ b/stdlib/regression/Makefile @@ -8,7 +8,7 @@ check: $(TESTS) $(TESTS): %: %.expr @echo $@ - RC_RUNTIME=../../runtime $(RC) -I .. $< && ./$@ > $@.log && diff $@.log orig/$@.log + RC_RUNTIME=../../runtime $(RC) -I .. -ds -dp $< && ./$@ > $@.log && diff $@.log orig/$@.log clean: $(RM) test*.log *.s *~ $(TESTS) *.i diff --git a/stdlib/regression/orig/test05.log b/stdlib/regression/orig/test05.log new file mode 100644 index 000000000..ad1599531 --- /dev/null +++ b/stdlib/regression/orig/test05.log @@ -0,0 +1,9 @@ +Cached: 1 +Cached: 1 +Cached: 1 +Cached: 1 +Cached: 1 +Cached: 1 +Cached: 1 +Cached: 1 +Cached: 1 diff --git a/stdlib/regression/orig/test06.log b/stdlib/regression/orig/test06.log new file mode 100644 index 000000000..c4ed9eda0 --- /dev/null +++ b/stdlib/regression/orig/test06.log @@ -0,0 +1,6 @@ +Flattening: 0 +Flattening: 0 +Flattening: {1, 2, 3} +Flattening: {1, 2, 3, 4, 5, 6, 7, 8, 9} +List to array: [1, 2, 3, 4, 5] +Array to list: {1, 2, 3, 4, 5} diff --git a/stdlib/regression/orig/test07.log b/stdlib/regression/orig/test07.log new file mode 100644 index 000000000..3eabcf1be --- /dev/null +++ b/stdlib/regression/orig/test07.log @@ -0,0 +1,6 @@ +HashTab internal structure: MNode (-624426958, {[{1, 2, 3}, 100]}, 0, 0, 0) +HashTab internal structure: MNode (-624426958, {[{1, 2, 3}, 200], [{1, 2, 3}, 100]}, 0, 0, 0) +Searching: Some (100) +Searching: Some (200) +Replaced: Some (800) +Restored: Some (100) diff --git a/stdlib/regression/test05.expr b/stdlib/regression/test05.expr new file mode 100644 index 000000000..0e1298b6b --- /dev/null +++ b/stdlib/regression/test05.expr @@ -0,0 +1,22 @@ +import Collection; + +fun f (x, y) { + fun () {x+y} +} + +local t = emptyMemo (), + a = lookupMemo (t, "abc"), + b = lookupMemo (t, [1, 2, 3, 4, "abc"]), + c = lookupMemo (t, f (5, 6)); + +printf ("Cached: %d\n", lookupMemo (t, "abc") == a); +printf ("Cached: %d\n", lookupMemo (t, "abc") == a); +printf ("Cached: %d\n", lookupMemo (t, "abc") == a); + +printf ("Cached: %d\n", lookupMemo (t, [1, 2, 3, 4, "abc"]) == b); +printf ("Cached: %d\n", lookupMemo (t, [1, 2, 3, 4, "abc"]) == b); +printf ("Cached: %d\n", lookupMemo (t, [1, 2, 3, 4, "abc"]) == b); + +printf ("Cached: %d\n", lookupMemo (t, f (5, 6)) == c); +printf ("Cached: %d\n", lookupMemo (t, f (5, 6)) == c); +printf ("Cached: %d\n", lookupMemo (t, f (5, 6)) == c) diff --git a/stdlib/regression/test06.expr b/stdlib/regression/test06.expr new file mode 100644 index 000000000..b0117889f --- /dev/null +++ b/stdlib/regression/test06.expr @@ -0,0 +1,9 @@ +import List; +import Array; + +printf ("Flattening: %s\n", flatten ({}).string); +printf ("Flattening: %s\n", flatten ({{}, {}, {}}).string); +printf ("Flattening: %s\n", flatten ({1, 2, 3} : {}).string); +printf ("Flattening: %s\n", flatten ({{1, 2, 3}, {4, 5, 6}, {7, 8, 9}}).string); +printf ("List to array: %s\n", listArray ({1, 2, 3, 4, 5}).string); +printf ("Array to list: %s\n", arrayList ([1, 2,3, 4, 5]).string) \ No newline at end of file diff --git a/stdlib/regression/test07.expr b/stdlib/regression/test07.expr new file mode 100644 index 000000000..e637cda5a --- /dev/null +++ b/stdlib/regression/test07.expr @@ -0,0 +1,26 @@ +import Collection; + +local a = {1, 2, 3}, b = {1, 2, 3}, t = emptyHashTab (); + +t := addHashTab (t, a, 100); +validateColl (); +printf ("HashTab internal structure: %s\n", t.string); + +t := addHashTab (t, b, 200); +validateColl (); +printf ("HashTab internal structure: %s\n", t.string); + +printf ("Searching: %s\n", findHashTab (t, a).string); +printf ("Searching: %s\n", findHashTab (t, b).string); + +t := addHashTab (t, a, 800); +validateColl (t); + +printf ("Replaced: %s\n", findHashTab (t, a).string); + +t := removeHashTab (t, a); +validateColl (t); +printf ("Restored: %s\n", findHashTab (t, a).string) + + +