Thread: [pure-lang-svn] SF.net SVN: pure-lang: [377] pure/trunk (Page 6)
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
pure-lang-svn
|
From: <js...@us...> - 2008-07-03 05:18:54
|
Revision: 377
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=377&view=rev
Author: jspitz
Date: 2008-07-02 22:19:00 -0700 (Wed, 02 Jul 2008)
Log Message:
-----------
Move set.pure to lib, add test015
Added Paths:
-----------
pure/trunk/lib/set.pure
pure/trunk/test/test015.log
pure/trunk/test/test015.pure
Removed Paths:
-------------
pure/trunk/examples/set.pure
Deleted: pure/trunk/examples/set.pure
===================================================================
--- pure/trunk/examples/set.pure 2008-07-03 00:23:57 UTC (rev 376)
+++ pure/trunk/examples/set.pure 2008-07-03 05:19:00 UTC (rev 377)
@@ -1,438 +0,0 @@
-/* Pure's set and bag data types based on AVL trees. */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
- Copyright (c) 2008 by Jiri Spitz <jir...@bl...>.
-
- This file is part of the Pure programming language and system.
-
- Pure is free software: you can redistribute it and/or modify it under the
- terms of the GNU General Public License as published by the Free Software
- Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- Pure is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
- FOR a PARTICULAR PURPOSE. See the GNU General Public License for more
- details.
-
- You should have received a copy of the GNU General Public License along
- with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-
-/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- The used algorithm of AVL trees has its origin in the SWI-Prolog
- implementation of association lists. The original file was created by
- R. A. O'Keefe and updated for the SWI-Prolog by Jan Wielemaker. For the
- original file see http://www.swi-prolog.org.
-
- The port from SWI-Prolog and the deletion stuff (rmfirst, rmlast, delete)
- missing in the original file was provided by Jiri Spitz
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-
-
-/* Public operations: ******************************************************
-
-emptyset, emptybag: return the empty set or bag
-set xs, bag xs; create a set or bag from list xs
-setp x, bagp x; check whether x is a set or bag
-
-#m size of set or bag m
-
-null m tests whether m is the empty set or bag
-member m x tests whether m contains x
-members m, list m list members of m in ascending order
-
-first m, last m return first and last member of m
-rmfirst m, rmlast m remove first and last member from m
-insert m x insert x into m (replace existing element)
-delete m x remove x from m
-
- *************************************************************************/
-
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-/*****
-Tree for set and bag is either:
-- nil (empty tree) or
-- bin key Balance Left Right (Left, Right: trees)
-
-
-Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
-*****/
-
-// set and bag type checks
-bagp (Bag _) = 1;
-bagp _ = 0;
-
-setp (Set _) = 1;
-setp _ = 0;
-
-// create an empty set or bag
-emptyset = Set nil;
-emptybag = Bag nil;
-
-// create set or bag from a list
-set xs = foldl insert emptyset xs if listp xs;
-bag xs = foldl insert emptybag xs if listp xs;
-
-// insert a new member into a set or bag
-insert (t@Set m) y::int |
-insert (t@Set m) y::string |
-insert (t@Set m) y |
-insert (t@Bag m) y::int |
-insert (t@Bag m) y::string |
-insert (t@Bag m) y = t ((insert m y)!0)
-with
- insert nil key::int |
- insert nil key::string |
- insert nil key
- = [(bin key ( 0) nil nil), 1];
-
- insert (bin k::int b::int l r) key::int |
- insert (bin k::string b::int l r) key::string |
- insert (bin k b::int l r) key
- = [(bin key b l r), 0] if (key == k) && (t === Set);
-
- insert (bin k::int b::int l r) key::int |
- insert (bin k::string b::int l r) key::string |
- insert (bin k b::int l r) key
- = adjust leftHasChanged (bin k b newL r) (-1)
- when [newL, leftHasChanged] = insert l key end if key < k;
-
- insert (bin k::int b::int l r) key::int |
- insert (bin k::string b::int l r) key::string |
- insert (bin k b::int l r) key
- = adjust rightHasChanged (bin k b l newR) ( 1)
- when [newR, rightHasChanged] = insert r key end
- if ((key > k) && (t === Set)) || ((key >= k) && (t === Bag));
-
- adjust 0 oldTree _
- = [oldTree, 0];
-
- adjust 1 (bin key::int b0::int l r) LoR::int |
- adjust 1 (bin key::string b0::int l r) LoR::int |
- adjust 1 (bin key b0::int l r) LoR::int
- = [rebal toBeRebalanced (bin key b0 l r) b1, whatHasChanged]
- when
- [b1, whatHasChanged, toBeRebalanced] = table b0 LoR
- end;
-
- rebal 0 (bin k::int _ l r) b |
- rebal 0 (bin k::string _ l r) b |
- rebal 0 (bin k _ l r) b
- = bin k b l r;
-
- rebal 1 oldTree _
- = (Set_avl_geq oldTree)!0;
-
-// Balance rules for insertions
-// balance where balance whole tree to be
-// before inserted after increased rebalanced
-table ( 0) (-1) = [( 1), 1, 0];
-table ( 0) ( 1) = [(-1), 1, 0];
-table ( 1) (-1) = [( 0), 0, 1];
-table ( 1) ( 1) = [( 0), 0, 0];
-table (-1) (-1) = [( 0), 0, 0];
-table (-1) ( 1) = [( 0), 0, 1];
-end;
-
-// delete a member by key from the data structure
-delete (t@Set m) y::int |
-delete (t@Set m) y::string |
-delete (t@Set m) y |
-delete (t@Bag m) y::int |
-delete (t@Bag m) y::string |
-delete (t@Bag m) y
-= t ((delete m y)!0)
-with
- delete nil _ = [nil, 0];
-
- delete (bin k::int _ nil r) key::int |
- delete (bin k::string _ nil r) key::string |
- delete (bin k _ nil r) key
- = [r, 1] if key == k;
-
- delete (bin k::int _ l nil) key::int |
- delete (bin k::string _ l nil) key::string |
- delete (bin k _ l nil) key
- = [l, 1] if key == k;
-
- delete (bin k::int b::int x@(bin kl::int bl::int rl ll) r) key::int |
- delete (bin k::string b::int x@(bin kl::string bl::int rl ll) r) key::string |
- delete (bin k b::int x@(bin kl bl::int rl ll) r) key
- = Set_adjustd leftHasChanged (bin lk b newL r) (-1)
- when
- lk = last x;
- [newL, leftHasChanged] = rmlast x
- end
- if key == k;
-
- delete (bin k::int b::int l r) key::int |
- delete (bin k::string b::int l r) key::string |
- delete (bin k b::int l r) key
- = Set_adjustd leftHasChanged (bin k b newL r) (-1)
- when
- [newL, leftHasChanged] = delete l key
- end
- if key < k;
-
- delete (bin k::int b::int l r) key::int |
- delete (bin k::string b::int l r) key::string |
- delete (bin k b::int l r) key
- = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
- when
- [newR, rightHasChanged] = delete r key
- end
- if key > k;
-
- rmlast nil = [nil, 0];
- rmlast (bin _ _ l nil) = [l, 1];
- rmlast (bin k b::int l r )
- = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
- when [newR, rightHasChanged] = rmlast r end;
-
- last (bin x _ _ nil) = x;
- last (bin _ _ _ m2 ) = last m2
-end;
-
-// check for the empty data structure
-null (Set nil) = 1;
-null (Set _) = 0;
-
-null (Bag nil) = 1;
-null (Bag _) = 0;
-
-// get a number of members in data structure
-#(Set m) |
-#(Bag m) = #m
-with
- #nil = 0;
- #(bin _ _ m1 m2) = #m1 + #m2 + 1
-end;
-
-// check whether a key exists in data structure
-member (Set m) k::int |
-member (Set m) k::string |
-member (Set m) k |
-member (Bag m) k::int |
-member (Bag m) k::string |
-member (Bag m) k
-= member m k
-with
- member nil _ = 0;
-
- member (bin x _ m1 m2) y::int |
- member (bin x _ m1 m2) y::string |
- member (bin x _ m1 m2) y
- = member m1 y if x > y;
- = member m2 y if x < y;
- = 1 if x == y
-end;
-
-// get all members of data structure as a list
-members (Set m) |
-members (Bag m)
-= members m
-with
- members nil = [];
-
- members (bin x::int _ m1 m2) |
- members (bin x::string _ m1 m2) |
- members (bin x _ m1 m2)
- = (members m1) + (x : (members m2))
-end;
-
-list m@(Set _) |
-list m@(Bag _)
- = members m;
-
-// get the first member of an ordered data structure
-first (Set m) |
-first (Bag m)
-= first m
-with
- first (bin x _ nil _) = x;
- first (bin _ _ m1 _) = first m1
-end;
-
-// get the last member of an ordered data structure
-last (Set m) |
-last (Bag m)
-= last m
-with
- last (bin x _ _ nil) = x;
- last (bin _ _ _ m2 ) = last m2
-end;
-
-// remove the first member from an ordered data structure
-rmfirst (t@Set m) |
-rmfirst (t@Bag m)
-= t ((rmfirst m)!0)
-with
- rmfirst nil = [nil, 0];
- rmfirst (bin _ _ nil r) = [r, 1];
- rmfirst (bin k b::int l r)
- = Set_adjustd leftHasChanged (bin k b newL r) (-1)
- when [newL, leftHasChanged] = rmfirst l end
-end;
-
-// remove the last member from an ordered data structure
-rmlast (t@Set m) |
-rmlast (t@Bag m)
-= t ((rmlast m)!0)
-with
- rmlast nil = [nil, 0];
- rmlast (bin _ _ l nil) = [l, 1];
- rmlast (bin k b::int l r )
- = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
- when [newR, rightHasChanged] = rmlast r end
-end;
-
-// set and bag relations
-m1@(Set _) == m2@(Set _) |
-m1@(Bag _) == m2@(Bag _)
- = (members m1 == members m2);
-
-m1@(Set _) != m2@(Set _) |
-m1@(Bag _) != m2@(Bag _)
- = (members m1 != members m2);
-
-m1@(Set _) <= m2@(Set _) = all (member m2) (members m1);
-m1@(Bag _) <= m2@(Bag _) = null (m1 - m2);
-
-m1@(Set _) >= m2@(Set _) = all (member m1) (members m2);
-m1@(Bag _) >= m2@(Bag _) = null (m2 - m1);
-
-m1@(Set _) < m2@(Set _) |
-m1@(Bag _) < m2@(Bag _)
- = if (m1 <= m2) then (m1 != m2) else 0;
-
-m1@(Set _) > m2@(Set _) |
-m1@(Bag _) > m2@(Bag _)
- = if (m1 >= m2) then (m1 != m2) else 0;
-
-// set and bag union
-m1@(Set _) + m2@(Set _) |
-m1@(Bag _) + m2@(Bag _)
- = foldl insert m1 (members m2);
-
-// set and bag difference
-m1@(Set _) - m2@(Set _) |
-m1@(Bag _) - m2@(Bag _)
- = foldl delete m1 (members m2);
-
-// set and bag intersection
-m1@(Set _) * m2@(Set _) |
-m1@(Bag _) * m2@(Bag _)
- = m1 - (m1 - m2);
-
-
-/* Private functions, don't invoke these directly. */
-
-Set_adjustd ToF::int tree LoR::int
-= adjust ToF tree LoR
-with
- adjust 0 oldTree _ = [oldTree, 0];
-
- adjust 1 (bin key::int b0::int l r) LoR::int |
- adjust 1 (bin key::string b0::int l r) LoR::int |
- adjust 1 (bin key b0::int l r) LoR::int
- = rebal toBeRebalanced (bin key b0 l r) b1 whatHasChanged
- when
- [b1, whatHasChanged, toBeRebalanced] = table b0 LoR;
- end;
-/*
- Note that rebali and rebald are not symmetrical. With insertions it is
- sufficient to know the original balance and insertion side in order to
- decide whether the whole tree increases. With deletions it is sometimes not
- sufficient and we need to know which kind of tree rotation took place.
-*/
- rebal 0 (bin k::int _ l r) b::int whatHasChanged |
- rebal 0 (bin k::string _ l r) b::int whatHasChanged |
- rebal 0 (bin k _ l r) b::int whatHasChanged
- = [bin k b l r, whatHasChanged];
-
- rebal 1 oldTree _ _ = Set_avl_geq oldTree;
-
-// Balance rules for deletions
-// balance where balance whole tree to be
-// before deleted after decreased rebalanced
-table ( 0) ( 1) = [( 1), 0, 0];
-table ( 0) (-1) = [(-1), 0, 0];
-table ( 1) ( 1) = [( 0), 1, 1];
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-
-table ( 1) (-1) = [( 0), 1, 0];
-table (-1) ( 1) = [( 0), 1, 0];
-table (-1) (-1) = [( 0), 1, 1]
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-end;
-
-
-// Single and double tree rotations - these are common for insert and delete
-/*
- The patterns (-1)-(-1), (-1)-( 1), ( 1)-( 1) and ( 1)-(-1) on the LHS always
- change the tree height and these are the only patterns which can happen
- after an insertion. That's the reason why we can use tablei only to decide
- the needed changes.
- The patterns (-1)-( 0) and ( 1)-( 0) do not change the tree height. After a
- deletion any pattern can occur and so we return 1 or 0 as a flag of
- a height change.
-*/
-
-Set_avl_geq x = avl_geq x
-with
- avl_geq (bin a::int (-1) alpha (bin b::int (-1) beta gamma)) |
- avl_geq (bin a::string (-1) alpha (bin b::string (-1) beta gamma)) |
- avl_geq (bin a (-1) alpha (bin b (-1) beta gamma))
- = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1];
-
- avl_geq (bin a::int (-1) alpha (bin b::int ( 0) beta gamma)) |
- avl_geq (bin a::string (-1) alpha (bin b::string ( 0) beta gamma)) |
- avl_geq (bin a (-1) alpha (bin b ( 0) beta gamma))
- = [bin b ( 1) (bin a (-1) alpha beta) gamma, 0];
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin a::int (-1) alpha
- (bin b::int ( 1) (bin x::int b1 beta gamma) delta)) |
- avl_geq (bin a::string (-1) alpha
- (bin b::string ( 1) (bin x::string b1 beta gamma) delta)) |
- avl_geq (bin a (-1) alpha
- (bin b ( 1) (bin x b1 beta gamma) delta))
- = [bin x ( 0) (bin a b2 alpha beta)
- (bin b b3 gamma delta), 1]
- when
- [b2, b3] = table b1
- end;
-
- avl_geq (bin b::int ( 1) (bin a::int ( 1) alpha beta) gamma) |
- avl_geq (bin b::string ( 1) (bin a::string ( 1) alpha beta) gamma) |
- avl_geq (bin b ( 1) (bin a ( 1) alpha beta) gamma)
- = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1];
-
- avl_geq (bin b::int ( 1) (bin a::int ( 0) alpha beta) gamma) |
- avl_geq (bin b::string ( 1) (bin a::string ( 0) alpha beta) gamma) |
- avl_geq (bin b ( 1) (bin a ( 0) alpha beta) gamma)
- = [bin a (-1) alpha (bin b ( 1) beta gamma), 0];
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin b::int ( 1)
- (bin a::int (-1) alpha (bin x::int b1 beta gamma)) delta) |
- avl_geq (bin b::string ( 1)
- (bin a::string (-1) alpha (bin x::string b1 beta gamma)) delta) |
- avl_geq (bin b ( 1)
- (bin a (-1) alpha (bin x b1 beta gamma)) delta)
- = [bin x ( 0) (bin a b2 alpha beta)
- (bin b b3 gamma delta), 1]
- when
- [b2, b3] = table b1
- end;
-
- table ( 1) = [( 0), (-1)];
- table (-1) = [( 1), ( 0)];
- table ( 0) = [( 0), ( 0)]
-end;
Copied: pure/trunk/lib/set.pure (from rev 376, pure/trunk/examples/set.pure)
===================================================================
--- pure/trunk/lib/set.pure (rev 0)
+++ pure/trunk/lib/set.pure 2008-07-03 05:19:00 UTC (rev 377)
@@ -0,0 +1,438 @@
+/* Pure's set and bag data types based on AVL trees. */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+ Copyright (c) 2008 by Jiri Spitz <jir...@bl...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure is free software: you can redistribute it and/or modify it under the
+ terms of the GNU General Public License as published by the Free Software
+ Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ Pure is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR a PARTICULAR PURPOSE. See the GNU General Public License for more
+ details.
+
+ You should have received a copy of the GNU General Public License along
+ with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ The used algorithm of AVL trees has its origin in the SWI-Prolog
+ implementation of association lists. The original file was created by
+ R. A. O'Keefe and updated for the SWI-Prolog by Jan Wielemaker. For the
+ original file see http://www.swi-prolog.org.
+
+ The port from SWI-Prolog and the deletion stuff (rmfirst, rmlast, delete)
+ missing in the original file was provided by Jiri Spitz
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+/* Public operations: ******************************************************
+
+emptyset, emptybag: return the empty set or bag
+set xs, bag xs; create a set or bag from list xs
+setp x, bagp x; check whether x is a set or bag
+
+#m size of set or bag m
+
+null m tests whether m is the empty set or bag
+member m x tests whether m contains x
+members m, list m list members of m in ascending order
+
+first m, last m return first and last member of m
+rmfirst m, rmlast m remove first and last member from m
+insert m x insert x into m (replace existing element)
+delete m x remove x from m
+
+ *************************************************************************/
+
+
+/* Empty tree constant, consider this private. */
+nullary nil;
+
+/*****
+Tree for set and bag is either:
+- nil (empty tree) or
+- bin key Balance Left Right (Left, Right: trees)
+
+
+Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
+*****/
+
+// set and bag type checks
+bagp (Bag _) = 1;
+bagp _ = 0;
+
+setp (Set _) = 1;
+setp _ = 0;
+
+// create an empty set or bag
+emptyset = Set nil;
+emptybag = Bag nil;
+
+// create set or bag from a list
+set xs = foldl insert emptyset xs if listp xs;
+bag xs = foldl insert emptybag xs if listp xs;
+
+// insert a new member into a set or bag
+insert (t@Set m) y::int |
+insert (t@Set m) y::string |
+insert (t@Set m) y |
+insert (t@Bag m) y::int |
+insert (t@Bag m) y::string |
+insert (t@Bag m) y = t ((insert m y)!0)
+with
+ insert nil key::int |
+ insert nil key::string |
+ insert nil key
+ = [(bin key ( 0) nil nil), 1];
+
+ insert (bin k::int b::int l r) key::int |
+ insert (bin k::string b::int l r) key::string |
+ insert (bin k b::int l r) key
+ = [(bin key b l r), 0] if (key == k) && (t === Set);
+
+ insert (bin k::int b::int l r) key::int |
+ insert (bin k::string b::int l r) key::string |
+ insert (bin k b::int l r) key
+ = adjust leftHasChanged (bin k b newL r) (-1)
+ when [newL, leftHasChanged] = insert l key end if key < k;
+
+ insert (bin k::int b::int l r) key::int |
+ insert (bin k::string b::int l r) key::string |
+ insert (bin k b::int l r) key
+ = adjust rightHasChanged (bin k b l newR) ( 1)
+ when [newR, rightHasChanged] = insert r key end
+ if ((key > k) && (t === Set)) || ((key >= k) && (t === Bag));
+
+ adjust 0 oldTree _
+ = [oldTree, 0];
+
+ adjust 1 (bin key::int b0::int l r) LoR::int |
+ adjust 1 (bin key::string b0::int l r) LoR::int |
+ adjust 1 (bin key b0::int l r) LoR::int
+ = [rebal toBeRebalanced (bin key b0 l r) b1, whatHasChanged]
+ when
+ [b1, whatHasChanged, toBeRebalanced] = table b0 LoR
+ end;
+
+ rebal 0 (bin k::int _ l r) b |
+ rebal 0 (bin k::string _ l r) b |
+ rebal 0 (bin k _ l r) b
+ = bin k b l r;
+
+ rebal 1 oldTree _
+ = (Set_avl_geq oldTree)!0;
+
+// Balance rules for insertions
+// balance where balance whole tree to be
+// before inserted after increased rebalanced
+table ( 0) (-1) = [( 1), 1, 0];
+table ( 0) ( 1) = [(-1), 1, 0];
+table ( 1) (-1) = [( 0), 0, 1];
+table ( 1) ( 1) = [( 0), 0, 0];
+table (-1) (-1) = [( 0), 0, 0];
+table (-1) ( 1) = [( 0), 0, 1];
+end;
+
+// delete a member by key from the data structure
+delete (t@Set m) y::int |
+delete (t@Set m) y::string |
+delete (t@Set m) y |
+delete (t@Bag m) y::int |
+delete (t@Bag m) y::string |
+delete (t@Bag m) y
+= t ((delete m y)!0)
+with
+ delete nil _ = [nil, 0];
+
+ delete (bin k::int _ nil r) key::int |
+ delete (bin k::string _ nil r) key::string |
+ delete (bin k _ nil r) key
+ = [r, 1] if key == k;
+
+ delete (bin k::int _ l nil) key::int |
+ delete (bin k::string _ l nil) key::string |
+ delete (bin k _ l nil) key
+ = [l, 1] if key == k;
+
+ delete (bin k::int b::int x@(bin kl::int bl::int rl ll) r) key::int |
+ delete (bin k::string b::int x@(bin kl::string bl::int rl ll) r) key::string |
+ delete (bin k b::int x@(bin kl bl::int rl ll) r) key
+ = Set_adjustd leftHasChanged (bin lk b newL r) (-1)
+ when
+ lk = last x;
+ [newL, leftHasChanged] = rmlast x
+ end
+ if key == k;
+
+ delete (bin k::int b::int l r) key::int |
+ delete (bin k::string b::int l r) key::string |
+ delete (bin k b::int l r) key
+ = Set_adjustd leftHasChanged (bin k b newL r) (-1)
+ when
+ [newL, leftHasChanged] = delete l key
+ end
+ if key < k;
+
+ delete (bin k::int b::int l r) key::int |
+ delete (bin k::string b::int l r) key::string |
+ delete (bin k b::int l r) key
+ = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
+ when
+ [newR, rightHasChanged] = delete r key
+ end
+ if key > k;
+
+ rmlast nil = [nil, 0];
+ rmlast (bin _ _ l nil) = [l, 1];
+ rmlast (bin k b::int l r )
+ = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
+ when [newR, rightHasChanged] = rmlast r end;
+
+ last (bin x _ _ nil) = x;
+ last (bin _ _ _ m2 ) = last m2
+end;
+
+// check for the empty data structure
+null (Set nil) = 1;
+null (Set _) = 0;
+
+null (Bag nil) = 1;
+null (Bag _) = 0;
+
+// get a number of members in data structure
+#(Set m) |
+#(Bag m) = #m
+with
+ #nil = 0;
+ #(bin _ _ m1 m2) = #m1 + #m2 + 1
+end;
+
+// check whether a key exists in data structure
+member (Set m) k::int |
+member (Set m) k::string |
+member (Set m) k |
+member (Bag m) k::int |
+member (Bag m) k::string |
+member (Bag m) k
+= member m k
+with
+ member nil _ = 0;
+
+ member (bin x _ m1 m2) y::int |
+ member (bin x _ m1 m2) y::string |
+ member (bin x _ m1 m2) y
+ = member m1 y if x > y;
+ = member m2 y if x < y;
+ = 1 if x == y
+end;
+
+// get all members of data structure as a list
+members (Set m) |
+members (Bag m)
+= members m
+with
+ members nil = [];
+
+ members (bin x::int _ m1 m2) |
+ members (bin x::string _ m1 m2) |
+ members (bin x _ m1 m2)
+ = (members m1) + (x : (members m2))
+end;
+
+list m@(Set _) |
+list m@(Bag _)
+ = members m;
+
+// get the first member of an ordered data structure
+first (Set m) |
+first (Bag m)
+= first m
+with
+ first (bin x _ nil _) = x;
+ first (bin _ _ m1 _) = first m1
+end;
+
+// get the last member of an ordered data structure
+last (Set m) |
+last (Bag m)
+= last m
+with
+ last (bin x _ _ nil) = x;
+ last (bin _ _ _ m2 ) = last m2
+end;
+
+// remove the first member from an ordered data structure
+rmfirst (t@Set m) |
+rmfirst (t@Bag m)
+= t ((rmfirst m)!0)
+with
+ rmfirst nil = [nil, 0];
+ rmfirst (bin _ _ nil r) = [r, 1];
+ rmfirst (bin k b::int l r)
+ = Set_adjustd leftHasChanged (bin k b newL r) (-1)
+ when [newL, leftHasChanged] = rmfirst l end
+end;
+
+// remove the last member from an ordered data structure
+rmlast (t@Set m) |
+rmlast (t@Bag m)
+= t ((rmlast m)!0)
+with
+ rmlast nil = [nil, 0];
+ rmlast (bin _ _ l nil) = [l, 1];
+ rmlast (bin k b::int l r )
+ = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
+ when [newR, rightHasChanged] = rmlast r end
+end;
+
+// set and bag relations
+m1@(Set _) == m2@(Set _) |
+m1@(Bag _) == m2@(Bag _)
+ = (members m1 == members m2);
+
+m1@(Set _) != m2@(Set _) |
+m1@(Bag _) != m2@(Bag _)
+ = (members m1 != members m2);
+
+m1@(Set _) <= m2@(Set _) = all (member m2) (members m1);
+m1@(Bag _) <= m2@(Bag _) = null (m1 - m2);
+
+m1@(Set _) >= m2@(Set _) = all (member m1) (members m2);
+m1@(Bag _) >= m2@(Bag _) = null (m2 - m1);
+
+m1@(Set _) < m2@(Set _) |
+m1@(Bag _) < m2@(Bag _)
+ = if (m1 <= m2) then (m1 != m2) else 0;
+
+m1@(Set _) > m2@(Set _) |
+m1@(Bag _) > m2@(Bag _)
+ = if (m1 >= m2) then (m1 != m2) else 0;
+
+// set and bag union
+m1@(Set _) + m2@(Set _) |
+m1@(Bag _) + m2@(Bag _)
+ = foldl insert m1 (members m2);
+
+// set and bag difference
+m1@(Set _) - m2@(Set _) |
+m1@(Bag _) - m2@(Bag _)
+ = foldl delete m1 (members m2);
+
+// set and bag intersection
+m1@(Set _) * m2@(Set _) |
+m1@(Bag _) * m2@(Bag _)
+ = m1 - (m1 - m2);
+
+
+/* Private functions, don't invoke these directly. */
+
+Set_adjustd ToF::int tree LoR::int
+= adjust ToF tree LoR
+with
+ adjust 0 oldTree _ = [oldTree, 0];
+
+ adjust 1 (bin key::int b0::int l r) LoR::int |
+ adjust 1 (bin key::string b0::int l r) LoR::int |
+ adjust 1 (bin key b0::int l r) LoR::int
+ = rebal toBeRebalanced (bin key b0 l r) b1 whatHasChanged
+ when
+ [b1, whatHasChanged, toBeRebalanced] = table b0 LoR;
+ end;
+/*
+ Note that rebali and rebald are not symmetrical. With insertions it is
+ sufficient to know the original balance and insertion side in order to
+ decide whether the whole tree increases. With deletions it is sometimes not
+ sufficient and we need to know which kind of tree rotation took place.
+*/
+ rebal 0 (bin k::int _ l r) b::int whatHasChanged |
+ rebal 0 (bin k::string _ l r) b::int whatHasChanged |
+ rebal 0 (bin k _ l r) b::int whatHasChanged
+ = [bin k b l r, whatHasChanged];
+
+ rebal 1 oldTree _ _ = Set_avl_geq oldTree;
+
+// Balance rules for deletions
+// balance where balance whole tree to be
+// before deleted after decreased rebalanced
+table ( 0) ( 1) = [( 1), 0, 0];
+table ( 0) (-1) = [(-1), 0, 0];
+table ( 1) ( 1) = [( 0), 1, 1];
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+
+table ( 1) (-1) = [( 0), 1, 0];
+table (-1) ( 1) = [( 0), 1, 0];
+table (-1) (-1) = [( 0), 1, 1]
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+end;
+
+
+// Single and double tree rotations - these are common for insert and delete
+/*
+ The patterns (-1)-(-1), (-1)-( 1), ( 1)-( 1) and ( 1)-(-1) on the LHS always
+ change the tree height and these are the only patterns which can happen
+ after an insertion. That's the reason why we can use tablei only to decide
+ the needed changes.
+ The patterns (-1)-( 0) and ( 1)-( 0) do not change the tree height. After a
+ deletion any pattern can occur and so we return 1 or 0 as a flag of
+ a height change.
+*/
+
+Set_avl_geq x = avl_geq x
+with
+ avl_geq (bin a::int (-1) alpha (bin b::int (-1) beta gamma)) |
+ avl_geq (bin a::string (-1) alpha (bin b::string (-1) beta gamma)) |
+ avl_geq (bin a (-1) alpha (bin b (-1) beta gamma))
+ = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1];
+
+ avl_geq (bin a::int (-1) alpha (bin b::int ( 0) beta gamma)) |
+ avl_geq (bin a::string (-1) alpha (bin b::string ( 0) beta gamma)) |
+ avl_geq (bin a (-1) alpha (bin b ( 0) beta gamma))
+ = [bin b ( 1) (bin a (-1) alpha beta) gamma, 0];
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin a::int (-1) alpha
+ (bin b::int ( 1) (bin x::int b1 beta gamma) delta)) |
+ avl_geq (bin a::string (-1) alpha
+ (bin b::string ( 1) (bin x::string b1 beta gamma) delta)) |
+ avl_geq (bin a (-1) alpha
+ (bin b ( 1) (bin x b1 beta gamma) delta))
+ = [bin x ( 0) (bin a b2 alpha beta)
+ (bin b b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end;
+
+ avl_geq (bin b::int ( 1) (bin a::int ( 1) alpha beta) gamma) |
+ avl_geq (bin b::string ( 1) (bin a::string ( 1) alpha beta) gamma) |
+ avl_geq (bin b ( 1) (bin a ( 1) alpha beta) gamma)
+ = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1];
+
+ avl_geq (bin b::int ( 1) (bin a::int ( 0) alpha beta) gamma) |
+ avl_geq (bin b::string ( 1) (bin a::string ( 0) alpha beta) gamma) |
+ avl_geq (bin b ( 1) (bin a ( 0) alpha beta) gamma)
+ = [bin a (-1) alpha (bin b ( 1) beta gamma), 0];
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin b::int ( 1)
+ (bin a::int (-1) alpha (bin x::int b1 beta gamma)) delta) |
+ avl_geq (bin b::string ( 1)
+ (bin a::string (-1) alpha (bin x::string b1 beta gamma)) delta) |
+ avl_geq (bin b ( 1)
+ (bin a (-1) alpha (bin x b1 beta gamma)) delta)
+ = [bin x ( 0) (bin a b2 alpha beta)
+ (bin b b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end;
+
+ table ( 1) = [( 0), (-1)];
+ table (-1) = [( 1), ( 0)];
+ table ( 0) = [( 0), ( 0)]
+end;
Added: pure/trunk/test/test015.log
===================================================================
--- pure/trunk/test/test015.log (rev 0)
+++ pure/trunk/test/test015.log 2008-07-03 05:19:00 UTC (rev 377)
@@ -0,0 +1,160 @@
+{
+ rule #0: a = set (1..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let a = set (1..10);
+{
+ rule #0: b = set (6..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let b = set (6..10);
+{
+ rule #0: c = bag (1..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let c = bag (1..10);
+{
+ rule #0: d = bag (6..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let d = bag (6..10);
+{
+ rule #0: e = set (map str (1..10))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let e = set (map str (1..10));
+{
+ rule #0: f = bag (map str (1..10))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let f = bag (map str (1..10));
+a;
+Set (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 0 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil))))
+b;
+Set (bin 7 (-1) (bin 6 0 nil nil) (bin 9 0 (bin 8 0 nil nil) (bin 10 0 nil nil)))
+c;
+Bag (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 0 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil))))
+d;
+Bag (bin 7 (-1) (bin 6 0 nil nil) (bin 9 0 (bin 8 0 nil nil) (bin 10 0 nil nil)))
+e;
+Set (bin "4" 0 (bin "2" 1 (bin "1" (-1) nil (bin "10" 0 nil nil)) (bin "3" 0 nil nil)) (bin "6" (-1) (bin "5" 0 nil nil) (bin "8" 0 (bin "7" 0 nil nil) (bin "9" 0 nil nil))))
+f;
+Bag (bin "4" 0 (bin "2" 1 (bin "1" (-1) nil (bin "10" 0 nil nil)) (bin "3" 0 nil nil)) (bin "6" (-1) (bin "5" 0 nil nil) (bin "8" 0 (bin "7" 0 nil nil) (bin "9" 0 nil nil))))
+setp a;
+1
+setp c;
+0
+bagp c;
+1
+bagp a;
+0
+null emptyset;
+1
+null emptybag;
+1
+null a;
+0
+null c;
+0
+rmfirst a;
+Set (bin 4 (-1) (bin 2 (-1) nil (bin 3 0 nil nil)) (bin 8 0 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil))))
+rmfirst c;
+Bag (bin 4 (-1) (bin 2 (-1) nil (bin 3 0 nil nil)) (bin 8 0 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil))))
+rmlast a;
+Set (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 1 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 0 nil nil)))
+rmlast c;
+Bag (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 1 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 0 nil nil)))
+first a;
+1
+last a;
+10
+first c;
+1
+last c;
+10
+#a;
+10
+#c;
+10
+member a 5;
+1
+member a 50;
+0
+member c 5;
+1
+member c 50;
+0
+a==b;
+0
+a!=b;
+1
+a<b;
+0
+a<=b;
+0
+a>b;
+1
+a>=b;
+1
+a==a;
+1
+a!=a;
+0
+a<a;
+0
+a<=a;
+1
+a>a;
+0
+a>=a;
+1
+c==d;
+0
+c!=d;
+1
+c<d;
+0
+c<=d;
+0
+c>d;
+1
+c>=d;
+1
+c==c;
+1
+c!=c;
+0
+c<c;
+0
+c<=c;
+1
+c>c;
+0
+c>=c;
+1
+a+b;
+Set (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 0 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil))))
+a*b;
+Set (bin 8 0 (bin 6 (-1) nil (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil)))
+a-b;
+Set (bin 4 1 (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 5 0 nil nil))
+c+d;
+Bag (bin 6 (-1) (bin 4 1 (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 5 0 nil nil)) (bin 8 (-1) (bin 7 0 (bin 6 0 nil nil) (bin 7 0 nil nil)) (bin 9 (-1) (bin 8 0 nil nil) (bin 10 0 (bin 9 0 nil nil) (bin 10 0 nil nil)))))
+c*d;
+Bag (bin 8 0 (bin 6 (-1) nil (bin 7 0 nil nil)) (bin 9 (-1) nil (bin 10 0 nil nil)))
+c-d;
+Bag (bin 4 1 (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 5 0 nil nil))
+c+d-d;
+Bag (bin 5 0 (bin 2 (-1) (bin 1 0 nil nil) (bin 4 1 (bin 3 0 nil nil) nil)) (bin 8 0 (bin 7 1 (bin 6 0 nil nil) nil) (bin 9 (-1) nil (bin 10 0 nil nil))))
Added: pure/trunk/test/test015.pure
===================================================================
--- pure/trunk/test/test015.pure (rev 0)
+++ pure/trunk/test/test015.pure 2008-07-03 05:19:00 UTC (rev 377)
@@ -0,0 +1,56 @@
+// Some tests for set and bag data containers
+
+using set;
+
+// Create data structures
+
+let a = set (1..10);
+let b = set (6..10);
+
+let c = bag (1..10);
+let d = bag (6..10);
+
+let e = set (map str (1..10));
+let f = bag (map str (1..10));
+
+a; b; c; d; e; f;
+
+// Type tests
+
+setp a; setp c; bagp c; bagp a;
+
+// Tests for empty data sets
+
+null emptyset; null emptybag; null a; null c;
+
+// Remove the first and last member
+
+rmfirst a; rmfirst c; rmlast a; rmlast c;
+
+// Find the first and last member
+
+first a; last a; first c; last c;
+
+// Size of data set
+
+#a; #c;
+
+// Membership tests
+
+member a 5; member a 50; member c 5; member c 50;
+
+// Relations
+
+a == b; a != b; a < b; a <= b; a > b; a >= b;
+
+a == a; a != a; a < a; a <= a; a > a; a >= a;
+
+c == d; c != d; c < d; c <= d; c > d; c >= d;
+
+c == c; c != c; c < c; c <= c; c > c; c >= c;
+
+// Set operations
+
+a + b; a * b; a - b;
+
+c + d; c * d; c - d; (c + d) - d;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-05 23:50:03
|
Revision: 393
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=393&view=rev
Author: agraef
Date: 2008-07-05 16:50:12 -0700 (Sat, 05 Jul 2008)
Log Message:
-----------
Add time functions to system interface.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/config.h.in
pure/trunk/configure
pure/trunk/configure.ac
pure/trunk/lib/system.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/ChangeLog 2008-07-05 23:50:12 UTC (rev 393)
@@ -1,3 +1,8 @@
+2008-07-06 Albert Graef <Dr....@t-...>
+
+ * runtime.cc/h, lib/system.pure: Added a few time functions to the
+ system interface.
+
2008-07-03 Albert Graef <Dr....@t-...>
* interpreter.cc (run): Temporarily suppress verbose output for
Modified: pure/trunk/config.h.in
===================================================================
--- pure/trunk/config.h.in 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/config.h.in 2008-07-05 23:50:12 UTC (rev 393)
@@ -15,6 +15,12 @@
*/
#undef HAVE_ALLOCA_H
+/* Define to 1 if you have the `ftime' function. */
+#undef HAVE_FTIME
+
+/* Define to 1 if you have the `gettimeofday' function. */
+#undef HAVE_GETTIMEOFDAY
+
/* Define if you have the iconv() function. */
#undef HAVE_ICONV
@@ -42,6 +48,9 @@
/* Define to 1 if you have the <memory.h> header file. */
#undef HAVE_MEMORY_H
+/* Define to 1 if you have the `nanosleep' function. */
+#undef HAVE_NANOSLEEP
+
/* Define to 1 if you have the <stdint.h> header file. */
#undef HAVE_STDINT_H
@@ -63,6 +72,9 @@
/* Define to 1 if you have the <unistd.h> header file. */
#undef HAVE_UNISTD_H
+/* Define to 1 if you have the `usleep' function. */
+#undef HAVE_USLEEP
+
/* Define to the name of the host system. */
#undef HOST
Modified: pure/trunk/configure
===================================================================
--- pure/trunk/configure 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/configure 2008-07-05 23:50:12 UTC (rev 393)
@@ -5366,6 +5366,103 @@
fi
+
+
+
+
+for ac_func in ftime gettimeofday nanosleep usleep
+do
+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
+{ echo "$as_me:$LINENO: checking for $ac_func" >&5
+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }
+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
+ For example, HP-UX 11i <limits.h> declares gettimeofday. */
+#define $ac_func innocuous_$ac_func
+
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func (); below.
+ Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ <limits.h> exists even on freestanding compilers. */
+
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+
+#undef $ac_func
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char $ac_func ();
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined __stub_$ac_func || defined __stub___$ac_func
+choke me
+#endif
+
+int
+main ()
+{
+return $ac_func ();
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ eval "$as_ac_var=yes"
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ eval "$as_ac_var=no"
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+fi
+ac_res=`eval echo '${'$as_ac_var'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+if test `eval echo '${'$as_ac_var'}'` = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+done
+
ac_config_files="$ac_config_files Makefile"
cat >confcache <<\_ACEOF
Modified: pure/trunk/configure.ac
===================================================================
--- pure/trunk/configure.ac 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/configure.ac 2008-07-05 23:50:12 UTC (rev 393)
@@ -85,6 +85,8 @@
AM_LANGINFO_CODESET
dnl Determine how to get alloca.
AC_FUNC_ALLOCA
+dnl Platform-dependent time functions.
+AC_CHECK_FUNCS(ftime gettimeofday nanosleep usleep)
AC_CONFIG_FILES([Makefile])
AC_OUTPUT
Modified: pure/trunk/lib/system.pure
===================================================================
--- pure/trunk/lib/system.pure 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/lib/system.pure 2008-07-05 23:50:12 UTC (rev 393)
@@ -47,6 +47,48 @@
errno = pure_errno;
set_errno val::int = pure_set_errno val;
+/* Time functions. 'time' reports the current time in seconds since the
+ "epoch" a.k.a. 00:00:00 UTC, Jan 1 1970. The result is always a bigint (in
+ fact, the time value is already 64 bit on many OSes nowadays). The ctime
+ and gmtime functions convert a time value to a string in either local time
+ or UTC. (Note that the latter is actually a combination of the C gmtime()
+ and asctime() functions.) */
+
+extern long pure_time() = time;
+extern char* pure_ctime(long) = ctime;
+extern char* pure_gmtime(long) = gmtime;
+
+/* The gettimeofday function also returns wallclock time as seconds since the
+ epoch, but theoretically offers resolutions in the microsec range (actual
+ resolutions vary, but are usually in the msec range for contemporary
+ systems). The result is returned as a double value (which also limits
+ precision). This function may actually be implemented through different
+ system calls, depending on what's available on the host OS. */
+
+extern double pure_gettimeofday() = gettimeofday;
+
+/* The clock function returns the current CPU (not wallclock) time since an
+ arbitrary point in the past, as a machine int. The number of "ticks" per
+ second is given by the CLOCKS_PER_SEC constant. Note that this value will
+ wrap around approximately every 72 minutes. */
+
+extern int clock();
+
+/* The sleep and nanosleep functions suspend execution for a given time
+ interval in seconds. 'sleep' takes integer (int/bigint) arguments only and
+ uses the sleep() system function. 'nanosleep' also accepts double arguments
+ and theoretically supports resolutions down to 1 nanosecond (again, actual
+ resolutions vary). This function may actually be implemented through
+ different system calls, depending on what's available on the host OS. Both
+ functions usually return zero, unless the sleep was interrupted by a
+ signal, in which case the time remaining to be slept is returned. */
+
+extern int sleep(int);
+extern double pure_nanosleep(double) = nanosleep;
+
+sleep t::bigint = sleep (int t);
+nanosleep t::int | nanosleep t::bigint = nanosleep (double t);
+
/* Basic process operations: system executes a shell command, exit terminates
the program with the given status code. */
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/runtime.cc 2008-07-05 23:50:12 UTC (rev 393)
@@ -25,6 +25,7 @@
#include <readline/history.h>
#include <stdlib.h>
#include <stdarg.h>
+#include <unistd.h>
#include <iostream>
#include <sstream>
@@ -2340,7 +2341,112 @@
errno = value;
}
+#include <time.h>
+
+extern "C"
+int64_t pure_time(void)
+{
+ return (int64_t)time(NULL);
+}
+
+extern "C"
+char *pure_ctime(int64_t t)
+{
+ time_t time = (time_t)t;
+ return ctime(&time);
+}
+
+extern "C"
+char *pure_gmtime(int64_t t)
+{
+ time_t time = (time_t)t;
+ return asctime(gmtime(&time));
+}
+
+#ifdef HAVE_GETTIMEOFDAY
+#include <sys/time.h>
+extern "C"
+double pure_gettimeofday(void)
+{
+ struct timeval tv;
+ gettimeofday(&tv, NULL);
+ return ((double)tv.tv_sec)+((double)tv.tv_usec)*1e-6;
+}
+#else
+#ifdef HAVE_FTIME
+#include <sys/timeb.h>
+extern "C"
+double pure_gettimeofday(void)
+{
+ struct timeb tb;
+ ftime(&tb);
+ return ((double)tb.time)+((double)tb.millitm)*1e-3;
+}
+#else
+extern "C"
+double pure_gettimeofday(void)
+{
+ return (double)time(NULL);
+}
+#endif
+#endif
+
#ifdef __MINGW32__
+#include <windows.h>
+double pure_nanosleep(double t)
+{
+ if (t > 0.0) {
+ unsigned long secs;
+ unsigned short msecs;
+ double ip, fp;
+ if (t > LONG_MAX) t = LONG_MAX;
+ fp = modf(t, &ip);
+ secs = (unsigned long)ip;
+ msecs = (unsigned short)(fp*1e3);
+ Sleep(secs*1000U+msecs);
+ }
+ return 0.0;
+}
+#else
+double pure_nanosleep(double t)
+{
+ if (t > 0.0) {
+ double ip, fp;
+ unsigned long secs;
+#ifdef HAVE_NANOSLEEP
+ unsigned long nsecs;
+ struct timespec req, rem;
+ fp = modf(t, &ip);
+ if (ip > LONG_MAX) { ip = (double)LONG_MAX; fp = 0.0; }
+ secs = (unsigned long)ip;
+ nsecs = (unsigned long)(fp*1e9);
+ req.tv_sec = secs; req.tv_nsec = nsecs;
+ if (nanosleep(&req, &rem))
+ return ((double)rem.tv_sec)+((double)rem.tv_nsec)*1e-9;
+ else
+ return 0.0;
+#else
+#ifdef HAVE_USLEEP
+ unsigned long usecs;
+ if (t > LONG_MAX) t = LONG_MAX;
+ fp = modf(t, &ip);
+ secs = (unsigned long)ip;
+ usecs = (unsigned long)(fp*1e6);
+ usleep(secs*1000000U+usecs);
+ return 0.0;
+#else
+ fp = modf(t, &ip);
+ if (ip > LONG_MAX) ip = (double)LONG_MAX;
+ secs = (unsigned long)ip;
+ return (double)sleep(secs);
+#endif
+#endif
+ } else
+ return 0.0;
+}
+#endif
+
+#ifdef __MINGW32__
extern "C"
FILE *popen(const char *command, const char *type)
{
@@ -2621,9 +2727,11 @@
{
interpreter& interp = *interpreter::g_interp;
// standard I/O streams
- interp.defn("stdin", pure_pointer(stdin));
+ interp.defn("stdin", pure_pointer(stdin));
interp.defn("stdout", pure_pointer(stdout));
interp.defn("stderr", pure_pointer(stderr));
+ // clock
+ interp.defn("CLOCKS_PER_SEC", pure_int(CLOCKS_PER_SEC));
// fnmatch, glob
interp.defn("FNM_NOESCAPE", pure_int(FNM_NOESCAPE));
interp.defn("FNM_PATHNAME", pure_int(FNM_PATHNAME));
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-07-05 21:49:42 UTC (rev 392)
+++ pure/trunk/runtime.h 2008-07-05 23:50:12 UTC (rev 393)
@@ -546,6 +546,26 @@
int pure_errno(void);
void pure_set_errno(int value);
+/* time() function. We provide an interface to this routine to account for
+ platform incompatibilities. The result is always int64_t, as time_t
+ nowadays is a 64 bit type on many OSes. We also provide wrappers for
+ ctime() and gmtime() which convert a time value to a string, using either
+ local or UTC time. */
+
+int64_t pure_time(void);
+char *pure_ctime(int64_t t);
+char *pure_gmtime(int64_t t);
+
+/* gettimeofday() interface. This may actually be implemented using different
+ system functions, depending on what's available on the host OS. */
+
+double pure_gettimeofday(void);
+
+/* nanosleep() interface. This may actually be implemented using different
+ system functions, depending on what's available on the host OS. */
+
+double pure_nanosleep(double t);
+
#ifdef __MINGW32__
/* Windows compatibility. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 00:19:58
|
Revision: 394
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=394&view=rev
Author: agraef
Date: 2008-07-05 17:20:07 -0700 (Sat, 05 Jul 2008)
Log Message:
-----------
Turn system constants into real constant definitions.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/runtime.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-05 23:50:12 UTC (rev 393)
+++ pure/trunk/ChangeLog 2008-07-06 00:20:07 UTC (rev 394)
@@ -1,5 +1,8 @@
2008-07-06 Albert Graef <Dr....@t-...>
+ * runtime.cc (pure_sys_vars): Turn system constants into real
+ constant definitions.
+
* runtime.cc/h, lib/system.pure: Added a few time functions to the
system interface.
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-05 23:50:12 UTC (rev 393)
+++ pure/trunk/runtime.cc 2008-07-06 00:20:07 UTC (rev 394)
@@ -2722,56 +2722,75 @@
return x;
}
+static inline void
+df(interpreter& interp, const char* s, pure_expr *x)
+{
+ try {
+ interp.defn(s, x);
+ } catch (err &e) {
+ cerr << "warning: " << e.what() << endl;
+ }
+}
+
+static inline void
+cdf(interpreter& interp, const char* s, pure_expr *x)
+{
+ try {
+ interp.const_defn(s, x);
+ } catch (err &e) {
+ cerr << "warning: " << e.what() << endl;
+ }
+}
+
extern "C"
void pure_sys_vars(void)
{
interpreter& interp = *interpreter::g_interp;
// standard I/O streams
- interp.defn("stdin", pure_pointer(stdin));
- interp.defn("stdout", pure_pointer(stdout));
- interp.defn("stderr", pure_pointer(stderr));
+ df(interp, "stdin", pure_pointer(stdin));
+ df(interp, "stdout", pure_pointer(stdout));
+ df(interp, "stderr", pure_pointer(stderr));
// clock
- interp.defn("CLOCKS_PER_SEC", pure_int(CLOCKS_PER_SEC));
+ cdf(interp, "CLOCKS_PER_SEC", pure_int(CLOCKS_PER_SEC));
// fnmatch, glob
- interp.defn("FNM_NOESCAPE", pure_int(FNM_NOESCAPE));
- interp.defn("FNM_PATHNAME", pure_int(FNM_PATHNAME));
- interp.defn("FNM_PERIOD", pure_int(FNM_PERIOD));
- interp.defn("FNM_CASEFOLD", pure_int(FNM_CASEFOLD));
- interp.defn("GLOB_SIZE", pure_int(sizeof(glob_t))); // not in POSIX
- interp.defn("GLOB_ERR", pure_int(GLOB_ERR));
- interp.defn("GLOB_MARK", pure_int(GLOB_MARK));
- interp.defn("GLOB_NOSORT", pure_int(GLOB_NOSORT));
- interp.defn("GLOB_NOCHECK", pure_int(GLOB_NOCHECK));
- interp.defn("GLOB_NOESCAPE", pure_int(GLOB_NOESCAPE));
+ cdf(interp, "FNM_NOESCAPE", pure_int(FNM_NOESCAPE));
+ cdf(interp, "FNM_PATHNAME", pure_int(FNM_PATHNAME));
+ cdf(interp, "FNM_PERIOD", pure_int(FNM_PERIOD));
+ cdf(interp, "FNM_CASEFOLD", pure_int(FNM_CASEFOLD));
+ cdf(interp, "GLOB_SIZE", pure_int(sizeof(glob_t))); // not in POSIX
+ cdf(interp, "GLOB_ERR", pure_int(GLOB_ERR));
+ cdf(interp, "GLOB_MARK", pure_int(GLOB_MARK));
+ cdf(interp, "GLOB_NOSORT", pure_int(GLOB_NOSORT));
+ cdf(interp, "GLOB_NOCHECK", pure_int(GLOB_NOCHECK));
+ cdf(interp, "GLOB_NOESCAPE", pure_int(GLOB_NOESCAPE));
#ifndef __APPLE__
- interp.defn("GLOB_PERIOD", pure_int(GLOB_PERIOD));
- interp.defn("GLOB_ONLYDIR", pure_int(GLOB_ONLYDIR));
+ cdf(interp, "GLOB_PERIOD", pure_int(GLOB_PERIOD));
+ cdf(interp, "GLOB_ONLYDIR", pure_int(GLOB_ONLYDIR));
#endif
- interp.defn("GLOB_BRACE", pure_int(GLOB_BRACE));
- interp.defn("GLOB_NOMAGIC", pure_int(GLOB_NOMAGIC));
- interp.defn("GLOB_TILDE", pure_int(GLOB_TILDE));
+ cdf(interp, "GLOB_BRACE", pure_int(GLOB_BRACE));
+ cdf(interp, "GLOB_NOMAGIC", pure_int(GLOB_NOMAGIC));
+ cdf(interp, "GLOB_TILDE", pure_int(GLOB_TILDE));
// regex stuff
- interp.defn("REG_SIZE", pure_int(sizeof(regex_t))); // not in POSIX
- interp.defn("REG_EXTENDED", pure_int(REG_EXTENDED));
- interp.defn("REG_ICASE", pure_int(REG_ICASE));
- interp.defn("REG_NOSUB", pure_int(REG_NOSUB));
- interp.defn("REG_NEWLINE", pure_int(REG_NEWLINE));
- interp.defn("REG_NOTBOL", pure_int(REG_NOTBOL));
- interp.defn("REG_NOTEOL", pure_int(REG_NOTEOL));
+ cdf(interp, "REG_SIZE", pure_int(sizeof(regex_t))); // not in POSIX
+ cdf(interp, "REG_EXTENDED", pure_int(REG_EXTENDED));
+ cdf(interp, "REG_ICASE", pure_int(REG_ICASE));
+ cdf(interp, "REG_NOSUB", pure_int(REG_NOSUB));
+ cdf(interp, "REG_NEWLINE", pure_int(REG_NEWLINE));
+ cdf(interp, "REG_NOTBOL", pure_int(REG_NOTBOL));
+ cdf(interp, "REG_NOTEOL", pure_int(REG_NOTEOL));
// regcomp error codes
- interp.defn("REG_BADBR", pure_int(REG_BADBR));
- interp.defn("REG_BADPAT", pure_int(REG_BADPAT));
- interp.defn("REG_BADRPT", pure_int(REG_BADRPT));
- interp.defn("REG_ECOLLATE", pure_int(REG_ECOLLATE));
- interp.defn("REG_ECTYPE", pure_int(REG_ECTYPE));
- interp.defn("REG_EESCAPE", pure_int(REG_EESCAPE));
- interp.defn("REG_ESUBREG", pure_int(REG_ESUBREG));
- interp.defn("REG_EBRACK", pure_int(REG_EBRACK));
- interp.defn("REG_EPAREN", pure_int(REG_EPAREN));
- interp.defn("REG_EBRACE", pure_int(REG_EBRACE));
- interp.defn("REG_ERANGE", pure_int(REG_ERANGE));
- interp.defn("REG_ESPACE", pure_int(REG_ESPACE));
+ cdf(interp, "REG_BADBR", pure_int(REG_BADBR));
+ cdf(interp, "REG_BADPAT", pure_int(REG_BADPAT));
+ cdf(interp, "REG_BADRPT", pure_int(REG_BADRPT));
+ cdf(interp, "REG_ECOLLATE", pure_int(REG_ECOLLATE));
+ cdf(interp, "REG_ECTYPE", pure_int(REG_ECTYPE));
+ cdf(interp, "REG_EESCAPE", pure_int(REG_EESCAPE));
+ cdf(interp, "REG_ESUBREG", pure_int(REG_ESUBREG));
+ cdf(interp, "REG_EBRACK", pure_int(REG_EBRACK));
+ cdf(interp, "REG_EPAREN", pure_int(REG_EPAREN));
+ cdf(interp, "REG_EBRACE", pure_int(REG_EBRACE));
+ cdf(interp, "REG_ERANGE", pure_int(REG_ERANGE));
+ cdf(interp, "REG_ESPACE", pure_int(REG_ESPACE));
// regexec error codes
- interp.defn("REG_NOMATCH", pure_int(REG_NOMATCH));
- interp.defn("REG_ESPACE", pure_int(REG_ESPACE));
+ cdf(interp, "REG_NOMATCH", pure_int(REG_NOMATCH));
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 10:50:04
|
Revision: 400
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=400&view=rev
Author: agraef
Date: 2008-07-06 03:50:05 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Move '=>' constructor from dict.pure to prelude.pure.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/examples/dict.pure
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/ChangeLog 2008-07-06 10:50:05 UTC (rev 400)
@@ -1,5 +1,8 @@
2008-07-06 Albert Graef <Dr....@t-...>
+ * lib/prelude.pure: Added new "mapsto" constructor. Requested by
+ Jiri Spitz.
+
* runtime.cc (pure_sys_vars): Turn system constants into real
constant definitions.
Modified: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/examples/dict.pure 2008-07-06 10:50:05 UTC (rev 400)
@@ -33,10 +33,6 @@
/* Empty tree constant, consider this private. */
nullary nil;
-/* Definition of the mapsto operator used for key=>value pairs */
-infix 2 => ;
-
-
/*****
Tree for dict and hdict is either:
- nil (empty tree) or
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/lib/prelude.pure 2008-07-06 10:50:05 UTC (rev 400)
@@ -47,6 +47,7 @@
infixr 0 $ ; // right-associative application
infixr 1 , ; // pair (tuple)
+infix 2 => ; // mapsto constructor
infixr 2 || ; // logical or (short-circuit)
infixr 3 && ; // logical and (short-circuit)
prefix 3 not ; // logical negation
@@ -89,6 +90,13 @@
uncurry3 f (x,y,z)
= f x y z;
+/* "Mapsto" operator. This constructor is declared here so that it can be used
+ in other standard library modules to denote special kind of pairs which map
+ keys to values. Here we only define equality of such pairs. */
+
+(x=>v)==(y=>w) = if x==y then v==w else 0;
+(x=>v)!=(y=>w) = if x!=y then 1 else v!=w;
+
/* Poor man's tuples(TM). These are constructed with the pairing operator ',',
are always flat and associate to the right. The empty tuple, denoted (), is
neutral with respect to ','. Operations are provided to test for equality/
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/test/prelude.log 2008-07-06 10:50:05 UTC (rev 400)
@@ -10,6 +10,8 @@
curry3 f/*0:0001*/ x/*0:001*/ y/*0:01*/ z/*0:1*/ = f/*0:0001*/ (x/*0:001*/,y/*0:01*/,z/*0:1*/);
uncurry f/*0:01*/ (x/*0:101*/,y/*0:11*/) = f/*0:01*/ x/*0:101*/ y/*0:11*/;
uncurry3 f/*0:01*/ (x/*0:101*/,y/*0:1101*/,z/*0:111*/) = f/*0:01*/ x/*0:101*/ y/*0:1101*/ z/*0:111*/;
+(x/*0:0101*/=>v/*0:011*/)==(y/*0:101*/=>w/*0:11*/) = if x/*0:0101*/==y/*0:101*/ then v/*0:011*/==w/*0:11*/ else 0;
+(x/*0:0101*/=>v/*0:011*/)!=(y/*0:101*/=>w/*0:11*/) = if x/*0:0101*/!=y/*0:101*/ then 1 else v/*0:011*/!=w/*0:11*/;
x/*0:01*/,() = x/*0:01*/;
(),y/*0:1*/ = y/*0:1*/;
(x/*0:0101*/,y/*0:011*/),z/*0:1*/ = x/*0:0101*/,y/*0:011*/,z/*0:1*/;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 22:48:31
|
Revision: 403
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=403&view=rev
Author: agraef
Date: 2008-07-06 15:48:40 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Bugfix in pretty-printing.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/printer.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-06 21:20:06 UTC (rev 402)
+++ pure/trunk/ChangeLog 2008-07-06 22:48:40 UTC (rev 403)
@@ -1,3 +1,8 @@
+2008-07-07 Albert Graef <Dr....@t-...>
+
+ * printer.cc: Add missing parens around low-precedence elements in
+ proper lists. Reported by Jiri Spitz.
+
2008-07-06 Albert Graef <Dr....@t-...>
* lib/prelude.pure: Added new "mapsto" constructor. Requested by
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-07-06 21:20:06 UTC (rev 402)
+++ pure/trunk/printer.cc 2008-07-06 22:48:40 UTC (rev 403)
@@ -250,11 +250,21 @@
prec_t p;
if (x.is_list(xs)) {
// proper list value
+ size_t n = xs.size();
os << "[";
- for (exprl::const_iterator it = xs.begin(); it != xs.end(); ) {
- printx(os, *it, pat);
- if (++it != xs.end()) os << ",";
- }
+ if (n>1) {
+ // list elements at a precedence not larger than ',' have to be
+ // parenthesized
+ p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
+ for (exprl::const_iterator it = xs.begin(); it != xs.end(); ) {
+ os << paren(p, *it, pat);
+ if (++it != xs.end()) os << ",";
+ }
+ } else
+ for (exprl::const_iterator it = xs.begin(); it != xs.end(); ) {
+ printx(os, *it, pat);
+ if (++it != xs.end()) os << ",";
+ }
return os << "]";
} else if (x.is_app(u, v)) {
if (u.ftag() > 0 && (p = sym_nprec(u.ftag())) < 100 && p%10 >= 3) {
@@ -669,12 +679,23 @@
prec_t p;
if (pure_is_list(x, xs)) {
// proper list value
+ size_t n = xs.size();
os << "[";
- for (list<const pure_expr*>::const_iterator it = xs.begin();
- it != xs.end(); ) {
- os << *it;
- if (++it != xs.end()) os << ",";
- }
+ if (n>1) {
+ // list elements at a precedence not larger than ',' have to be
+ // parenthesized
+ p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
+ for (list<const pure_expr*>::const_iterator it = xs.begin();
+ it != xs.end(); ) {
+ os << pure_paren(p, *it);
+ if (++it != xs.end()) os << ",";
+ }
+ } else
+ for (list<const pure_expr*>::const_iterator it = xs.begin();
+ it != xs.end(); ) {
+ os << *it;
+ if (++it != xs.end()) os << ",";
+ }
return os << "]";
}
const pure_expr *u = x->data.x[0], *v = x->data.x[1], *w, *y;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 23:57:54
|
Revision: 405
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=405&view=rev
Author: agraef
Date: 2008-07-06 16:58:01 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Added strftime to system.pure.
Modified Paths:
--------------
pure/trunk/lib/system.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/lib/system.pure
===================================================================
--- pure/trunk/lib/system.pure 2008-07-06 22:49:06 UTC (rev 404)
+++ pure/trunk/lib/system.pure 2008-07-06 23:58:01 UTC (rev 405)
@@ -49,14 +49,19 @@
/* Time functions. 'time' reports the current time in seconds since the
"epoch" a.k.a. 00:00:00 UTC, Jan 1 1970. The result is always a bigint (in
- fact, the time value is already 64 bit on many OSes nowadays). The ctime
- and gmtime functions convert a time value to a string in either local time
- or UTC. (Note that the latter is actually a combination of the C gmtime()
- and asctime() functions.) */
+ fact, the time value is already 64 bit on many OSes nowadays). */
extern long pure_time() = time;
+
+/* Functions to format a time value as a string. The ctime and gmtime
+ functions convert a time value to a string in either local time or UTC.
+ The strftime function also formats a time value as local time, using a
+ format specification supplied by the user. See ctime(3), gmtime(3) and
+ strftime(3) for details. */
+
extern char* pure_ctime(long) = ctime;
extern char* pure_gmtime(long) = gmtime;
+extern char* pure_strftime(char* format, long t) = strftime;
/* The gettimeofday function also returns wallclock time as seconds since the
epoch, but theoretically offers resolutions in the microsec range (actual
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-06 22:49:06 UTC (rev 404)
+++ pure/trunk/runtime.cc 2008-07-06 23:58:01 UTC (rev 405)
@@ -2349,6 +2349,9 @@
return (int64_t)time(NULL);
}
+/* Note that the following are not thread-safe as they use statically
+ allocated buffers. */
+
extern "C"
char *pure_ctime(int64_t t)
{
@@ -2363,6 +2366,20 @@
return asctime(gmtime(&time));
}
+extern "C"
+char *pure_strftime(const char *format, int64_t t)
+{
+ time_t time = (time_t)t;
+ static char buf[1024];
+ if (!strftime(buf, 1024, format, localtime(&time)))
+ /* The interface to strftime is rather brain-damaged since it returns zero
+ both in case of a buffer overflow and when the resulting string is
+ empty. We just pretend that there cannot be any errors and return an
+ empty string in both cases. */
+ buf[0] = 0;
+ return buf;
+}
+
#ifdef HAVE_GETTIMEOFDAY
#include <sys/time.h>
extern "C"
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-07-06 22:49:06 UTC (rev 404)
+++ pure/trunk/runtime.h 2008-07-06 23:58:01 UTC (rev 405)
@@ -550,11 +550,16 @@
platform incompatibilities. The result is always int64_t, as time_t
nowadays is a 64 bit type on many OSes. We also provide wrappers for
ctime() and gmtime() which convert a time value to a string, using either
- local or UTC time. */
+ the local timezone or UTC. */
int64_t pure_time(void);
+
+/* The following routines allow you to convert a time value to a string, using
+ different formats. See ctime(3), gmtime(3) and strftime(3) for details. */
+
char *pure_ctime(int64_t t);
char *pure_gmtime(int64_t t);
+char *pure_strftime(const char *format, int64_t t);
/* gettimeofday() interface. This may actually be implemented using different
system functions, depending on what's available on the host OS. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-07 00:14:00
|
Revision: 406
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=406&view=rev
Author: agraef
Date: 2008-07-06 17:14:10 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Bugfix in init function.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-07-06 23:58:01 UTC (rev 405)
+++ pure/trunk/lib/prelude.pure 2008-07-07 00:14:10 UTC (rev 406)
@@ -263,7 +263,7 @@
init [x] = [];
init (x:xs) = accum [x] xs with
- accum ys [] = reverse ys;
+ accum ys [x] = reverse ys;
accum ys (x:xs) = accum (x:ys) xs;
accum ys xs = reverse ys+init xs;
end;
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-07-06 23:58:01 UTC (rev 405)
+++ pure/trunk/test/prelude.log 2008-07-07 00:14:10 UTC (rev 406)
@@ -355,37 +355,37 @@
foldr1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*0:01*/ x/*0:101*/ (foldl1 (flip f/*0:01*/) (reverse xs/*0:11*/));
head (x/*0:101*/:xs/*0:11*/) = x/*0:101*/;
init [x/*0:101*/] = [];
-init (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ [] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+init xs/*0:1*/ {
- rule #0: accum ys [] = reverse ys
+init (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ [x/*0:101*/] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+init xs/*0:1*/ {
+ rule #0: accum ys [x] = reverse ys
rule #1: accum ys (x:xs) = accum (x:ys) xs
rule #2: accum ys xs = reverse ys+init xs
state 0: #0 #1 #2
<var> state 1
state 1: #0 #1 #2
<var> state 2
- [] state 3
- <app> state 4
+ <app> state 3
state 2: #2
- state 3: #0 #2
- state 4: #1 #2
+ state 3: #0 #1 #2
+ <var> state 4
+ <app> state 6
+ state 4: #2
<var> state 5
- <app> state 7
state 5: #2
- <var> state 6
- state 6: #2
- state 7: #1 #2
+ state 6: #0 #1 #2
+ <var> state 7
+ : state 10
+ state 7: #2
<var> state 8
- : state 11
state 8: #2
<var> state 9
state 9: #2
- <var> state 10
- state 10: #2
- state 11: #1 #2
+ state 10: #0 #1 #2
+ <var> state 11
+ state 11: #0 #1 #2
<var> state 12
+ [] state 13
state 12: #1 #2
- <var> state 13
- state 13: #1 #2
+ state 13: #0 #1 #2
} end;
last [x/*0:101*/] = x/*0:101*/;
last (x/*0:101*/:xs/*0:11*/) = last xs/*0:11*/;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-07 11:19:03
|
Revision: 409
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=409&view=rev
Author: agraef
Date: 2008-07-07 04:19:13 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Make slicing work with strings.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/strings.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-07 00:32:43 UTC (rev 408)
+++ pure/trunk/ChangeLog 2008-07-07 11:19:13 UTC (rev 409)
@@ -1,5 +1,7 @@
2008-07-07 Albert Graef <Dr....@t-...>
+ * lib/strings.pure: Make slicing work with strings.
+
* lib/prelude.pure: Fixed a bug in init function. Reported by
Libor Spacek.
Modified: pure/trunk/lib/strings.pure
===================================================================
--- pure/trunk/lib/strings.pure 2008-07-07 00:32:43 UTC (rev 408)
+++ pure/trunk/lib/strings.pure 2008-07-07 11:19:13 UTC (rev 409)
@@ -143,6 +143,11 @@
end;
end when m = #delim end if not null delim;
+/* Slicing. */
+
+s::string!!ns = strcat [s!n; n=ns; n>=0 && n<m]
+ when m::int = #s end;
+
/* Define the customary list operations on strings, so that these can mostly
be used as if they were lists. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-07 22:07:17
|
Revision: 412
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=412&view=rev
Author: jspitz
Date: 2008-07-07 15:07:25 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Move array, dict and heap from examples to lib, update test #15.
Modified Paths:
--------------
pure/trunk/test/test015.pure
Added Paths:
-----------
pure/trunk/lib/array.pure
pure/trunk/lib/dict.pure
pure/trunk/lib/heap.pure
Removed Paths:
-------------
pure/trunk/examples/array.pure
pure/trunk/examples/dict.pure
pure/trunk/examples/heap.pure
Deleted: pure/trunk/examples/array.pure
===================================================================
--- pure/trunk/examples/array.pure 2008-07-07 20:46:37 UTC (rev 411)
+++ pure/trunk/examples/array.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -1,233 +0,0 @@
-
-/* array.pure: integer-indexed arrays implemented as size-balanced
- binary trees. */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
-
- This file is part of the Pure programming language and system.
-
- Pure is free software: you can redistribute it and/or modify it under the
- terms of the GNU General Public License as published by the Free Software
- Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- Pure is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
- FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
- details.
-
- You should have received a copy of the GNU General Public License along
- with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-/* This script implements an efficient variable-sized array data structure
- which allows to access and update individual array members, as well as
- to add and remove elements at the beginning and end of an array. All these
- operations are carried out in logarithmic time. */
-
-/* Public operations: ******************************************************
-
- emptyarray return the empty array
- array xs create an array from a list xs
- array2 xs create a two-dimensional array from a list of lists
- mkarray x n create an array consisting of n x's
- mkarray2 x (n,m) create a 2D array of n*m x's
- arrayp x check whether x is an array
-
- #a size of a
- a!i return ith member of a
- a!(i,j) two-dimensional subscript
-
- a!!is slicing (get a list of values from a list
- indices
- a!!ijs slicing of two-dimensional array (from a given
- list of pairs (i, j):...:[])
-
- null a tests whether a is the empty array
- members a list of values stored in a
- members2 a list of members in a two-dimensional array
-
- first a, last a first and last member of A
- rmfirst a, rmlast a remove first and last member from a
- insert a x insert x at the beginning of a
- append a x append x to the end of a
- update a i x replace the ith member of a by x
- update2 a (i,j) x update two-dimensional array
-
- *************************************************************************/
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-// array type check
-arrayp (Array _) = 1;
-arrayp _ = 0;
-
-// create an empty array
-emptyarray = Array nil;
-
-// create an array from a list
-array xs = foldl append emptyarray xs if listp xs;
-
-// create a two-dimensional array from a two-dimensional list
-array2 xs = array (map array xs);
-
-// create an array of a given size filled with a constant value
-mkarray x n::int = Array (mkarray x n)
-with
- mkarray x n::int = nil if n <= 0;
- = tip x if n == 1;
- = array_mkbin (n mod 2)
- (mkarray x (n - n div 2))
- (mkarray x (n div 2));
-end;
-
-// create a 2D array of given dimensions filled with a constant value
-mkarray2 x (n::int, m::int) = mkarray (mkarray x m) n;
-
-// get array size
-#(Array a) = #a
-with
- #nil = 0;
- #(tip _) = 1;
- #(bin 0 a1 _) = #a1 * 2;
- #(bin 1 a1 _) = #a1 * 2 - 1;
-end;
-
-// get value by index
-(Array a)!i::int = a!i
-with
- (tip x)!0 = x;
- (bin _ a1 a2)!i::int = a1!(i div 2) if i mod 2 == 0;
- = a2!(i div 2) if i mod 2 == 1;
- _ ! _ = throw out_of_bounds;
-end;
-
-// get value by indices from two-dimensional array
-x@(Array _)!(i::int, j::int) = x!i!j;
-
-// slicing (get list of values from list of indices)
-a@(Array _)!!is@(_::int:_) = [a!i; i = is; (i >= 0) && (i < (#a))];
-
-// slicing of two-dimensional array
-a@(Array _)!!ijs@((_::int, _::int):_)
- = [a!(i, j); (i, j) = ijs; (i >= 0) && (i < (#a))
- && (j >= 0) && (j < (#(a!i)))];
-
-// check for an empty array
-null (Array nil) = 1;
-null (Array _) = 0;
-
-// get all array members in list form
-members (Array a) = members a
-with
- members nil = [];
- members (tip x) = [x];
- members (bin _ a1 a2) = merge (members a1) (members a2);
- // merge lists xs (even elements) and ys (odd elements)
- merge [] ys = ys;
- merge (x:xs) ys = x:merge ys xs;
-end;
-
-// get all members of an two-dimensional array in list form
-members2 x@(Array _) = map members (members x);
-
-// get the first array member
-first (Array a) = first a
-with
- first (tip x) = x;
- first (bin _ a1 _) = first a1;
-end;
-
-// get the last array member
-last (Array a) = last a
-with
- last (tip x) = x;
- last (bin 0 _ a2) = last a2;
- last (bin 1 a1 _) = last a1;
-end;
-
-// remove the first member from an array
-rmfirst (Array a) = Array (rmfirst a)
-with
- rmfirst (tip _) = nil;
- rmfirst (bin 0 a1 a2) = array_mkbin 1 a2 (rmfirst a1);
- rmfirst (bin 1 a1 a2) = array_mkbin 0 a2 (rmfirst a1);
-end;
-
-// remove the last member from an array
-rmlast (Array a) = Array (rmlast a)
-with
- rmlast (tip _) = nil;
- rmlast (bin 0 a1 a2) = array_mkbin 1 a1 (rmlast a2);
- rmlast (bin 1 a1 a2) = array_mkbin 0 (rmlast a1) a2;
-end;
-
-// insert a new member at the beginning of an array
-insert (Array a) y = Array (insert a y)
-with
- insert nil y = tip y;
- insert (tip x) y = bin 0 (tip y) (tip x);
- insert (bin 0 a1 a2) y = array_mkbin 1 (insert a2 y) a1;
- insert (bin 1 a1 a2) y = array_mkbin 0 (insert a2 y) a1;
-end;
-
-// append a new member at the end of an array
-append (Array a) y = Array (append a y)
-with
- append nil y = tip y;
- append (tip x) y = bin 0 (tip x) (tip y);
- append (bin 0 a1 a2) y = array_mkbin 1 (append a1 y) a2;
- append (bin 1 a1 a2) y = array_mkbin 0 a1 (append a2 y);
-end;
-
-// update a given array position with a new value
-update (Array a) i::int y = Array (update a i y)
-with
- update (tip _) 0 y = tip y;
- update (bin b::int a1 a2) i::int y
- = bin b (update a1 (i div 2) y) a2
- if i mod 2 == 0;
- = bin b a1 (update a2 (i div 2) y)
- if i mod 2 == 1;
-end;
-
-// update a given position of a two-dimensional array with a new value
-update2 x@(Array a) (i::int, j::int) y
- = update x i (update (x!i) j y);
-
-// compare two arrays for equality
-Array a == Array b = eq a b
-with
- eq nil nil = 1;
- eq nil (tip _) = 0;
- eq nil (bin _ _ _) = 0;
- eq (tip _) nil = 0;
- eq (tip x) (tip y) = x == y;
- eq (tip _) (bin _ _ _) = 0;
- eq (bin _ _ _) nil = 0;
- eq (bin _ _ _) (tip _) = 0;
- eq (bin b1::int a1 a2) (bin b2::int a3 a4)
- = b1 == b2 && eq a1 a3 && eq a2 a4;
-end;
-
-// compare two arrays for inequality
-Array a != Array b = neq a b
-with
- neq nil nil = 0;
- neq nil (tip _) = 1;
- neq nil (bin _ _ _) = 1;
- neq (tip _) nil = 1;
- neq (tip x) (tip y) = x != y;
- neq (tip _) (bin _ _ _) = 1;
- neq (bin _ _ _) nil = 1;
- neq (bin _ _ _) (tip _) = 1;
- neq (bin b1::int a1 a2) (bin b2::int a3 a4)
- = b1 != b2 || neq a1 a3 || neq a2 a4;
-end;
-
-/* Private functions, don't invoke these directly. */
-
-// construct a binary array node
-array_mkbin _ nil a2 = a2;
-array_mkbin _ a1 nil = a1;
-array_mkbin b::int a1 a2 = bin b a1 a2;
Deleted: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-07 20:46:37 UTC (rev 411)
+++ pure/trunk/examples/dict.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -1,625 +0,0 @@
-/* Pure's dict and hdict data types based on AVL trees. */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
- Copyright (c) 2008 by Jiri Spitz <jir...@bl...>.
-
- This file is part of the Pure programming language and system.
-
- Pure is free software: you can redistribute it and/or modify it under the
- terms of the GNU General Public License as published by the Free Software
- Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- Pure is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
- FOR a PARTICULAR PURPOSE. See the GNU General Public License for more
- details.
-
- You should have received a copy of the GNU General Public License along
- with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-
-/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- The used algorithm of AVL trees has its origin in the SWI-Prolog
- implementation of association lists. The original file was created by
- R. A. O'Keefe and updated for the SWI-Prolog by Jan Wielemaker. For the
- original file see http://www.swi-prolog.org.
-
- The port from SWI-Prolog and the deletion stuff (rmfirst, rmlast, delete)
- missing in the original file was provided by Jiri Spitz
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-/*****
-Tree for dict and hdict is either:
-- nil (empty tree) or
-- bin Key value Balance Left Right (Left, Right: trees)
-
-Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
-*****/
-
-
-/* Public operations: ******************************************************
-
-emptydict, emptyhdict: return the empty dict or bag
-dict xs, hdict xs; create a dict or hdict from list xs
-dictp d, hdictp d; check whether x is a dict or hdict
-mkdict y xs, mkhdict y xs: create dict or hdict from a list of keys and
- a constant value
-
-#d size of dict or hdict d
-d!x: get value from d by key x
-d!!xs slicing (get a list of values
- from a list of keys)
-
-null d tests whether d is the empty dict or hdict
-member d x tests whether d contains member with key x
-members d, list d list members of d (in ascending order fo dict)
-keys d: lists keys of d (in ascending order fo dict)
-values d: list values of d
-
-first d, last d return first and last member of dict
-rmfirst d, rmlast d remove first and last member from dict
-insert d xy insert x into d (replace existing element)
-update d x y fully curried version of insert
-delete d x remove x from d
-
- *************************************************************************/
-
-
-// Dict and hdict type checks
-dictp (Dict _) = 1;
-dictp _ = 0;
-
-hdictp (Hdict _) = 1;
-hdictp _ = 0;
-
-// create an empty dict or hdict
-emptydict = Dict nil;
-emptyhdict = Hdict nil;
-
-// create dict or hdict from a list
-dict xys = foldl insert emptydict xys if listp xys;
-hdict xys = foldl insert emptyhdict xys if listp xys;
-
-// insert a new member into the dict or hdict
-insert (t@Dict d) (x::int => y) |
-insert (t@Dict d) (x::string => y) |
-insert (t@Dict d) (x => y) |
-insert (t@Hdict d) (x => y)
- = if t === Dict
- then t ((insertd d x y)!0)
- else t ((inserth d (hash x) x y)!0)
-with
- insertd nil key::int val |
- insertd nil key::string val |
- insertd nil key val
- = [(bin key val ( 0) nil nil), 1];
-
- insertd (bin k::int _ b l r) key::int val |
- insertd (bin k::string _ b l r) key::string val |
- insertd (bin k _ b l r) key val
- = [(bin key val b l r), 0] if key == k;
-
- insertd (bin k::int v b l r) key::int val |
- insertd (bin k::string v b l r) key::string val |
- insertd (bin k v b l r) key val
- = adjust leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = insertd l key val
- end
- if key < k;
-
- insertd (bin k::int v b l r) key::int val |
- insertd (bin k::string v b l r) key::string val |
- insertd (bin k v b l r) key val
- = adjust rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = insertd r key val
- end
- if key > k;
-
- inserth nil k::int x y = [(bin k [x => y] ( 0) nil nil), 1];
-
- inserth (bin k::int v b l r) key::int x y
- = [(bin k (inserth2 v x y) b l r), 0] if k == key;
-
- inserth (bin k::int v b l r) key::int x y
- = adjust leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = inserth l key x y
- end
- if key < k;
-
- inserth (bin k::int v b l r) key::int x y
- = adjust rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = inserth r key x y
- end
- if key > k;
-
- inserth2 [] x y = [x => y];
- inserth2 ((x1 => y):xys) x2 y1
- = ((x1 => y1):xys) if x1 === x2;
- inserth2 ((x => y):xys) x1 y1
- = ((x => y ):(inserth2 xys x1 y1));
-
- adjust 0 oldTree _ = [oldTree, 0];
-
- adjust 1 (bin key::int val b0 l r) LoR |
- adjust 1 (bin key::string val b0 l r) LoR |
- adjust 1 (bin key val b0 l r) LoR
- = [rebal toBeRebalanced (bin key val b0 l r) b1, whatHasChanged]
- when
- [b1, whatHasChanged, toBeRebalanced] = table b0 LoR
- end;
-
- rebal 0 (bin k::int v _ l r) b |
- rebal 0 (bin k::string v _ l r) b |
- rebal 0 (bin k v _ l r) b
- = bin k v b l r;
-
- rebal 1 oldTree _ = (Dict_avl_geq oldTree)!0;
-
-// Balance rules for insertions
-// balance where balance whole tree to be
-// before inserted after increased rebalanced
-table ( 0) (-1) = [( 1), 1, 0];
-table ( 0) ( 1) = [(-1), 1, 0];
-table ( 1) (-1) = [( 0), 0, 1];
-table ( 1) ( 1) = [( 0), 0, 0];
-table (-1) (-1) = [( 0), 0, 0];
-table (-1) ( 1) = [( 0), 0, 1]
-end;
-
-// delete a member by key from the dict or hdict
-delete (t@Dict d) x::int |
-delete (t@Dict d) x::string |
-delete (t@Dict d) x |
-delete (t@Hdict d) x
- = if t === Dict
- then t ((deleted d x)!0)
- else t ((deleteh d (hash x) x)!0)
-with
- deleted nil _ = [nil, 0];
-
- deleted (bin k::int _ _ nil r ) key::int |
- deleted (bin k::string _ _ nil r ) key::string |
- deleted (bin k _ _ nil r ) key
- = [r, 1] if key == k;
-
- deleted (bin k::int _ _ l nil) key::int |
- deleted (bin k::string _ _ l nil) key::string |
- deleted (bin k _ _ l nil) key
- = [l, 1] if key == k;
-
- deleted (bin k::int _ b (bin kl::int vl bl rl ll) r ) key::int |
- deleted (bin k::string _ b (bin kl::string vl bl rl ll) r ) key::string |
- deleted (bin k _ b (bin kl vl bl rl ll) r ) key
- = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
- when
- [lastk, lastv] = last (bin kl vl bl rl ll);
- [newl, leftHasChanged]
- = rmlast (bin kl vl bl rl ll)
- end
- if key == k;
-
- deleted (bin k::int v b l r) key::int |
- deleted (bin k::string v b l r) key::string |
- deleted (bin k v b l r) key
- = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = deleted l key
- end
- if key < k;
-
- deleted (bin k::int v b l r) key::int |
- deleted (bin k::string v b l r) key::string |
- deleted (bin k v b l r) key
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = deleted r key
- end
- if key > k;
-
- deleteh nil _ _ = [nil, 0];
-
- deleteh (bin k::int xys b nil r ) key::int x
- = (if (newxys == [])
- then [r, 1]
- else [bin k newxys b nil r, 0])
- when
- newxys = deleteh2 xys x
- end
- if k == key;
-
- deleteh (bin k::int xys b l nil) key::int x
- = (if (newxys == [])
- then [l, 1]
- else [bin k newxys b l nil, 0])
- when
- newxys = deleteh2 xys x
- end
- if k == key;
-
- deleteh (bin k::int xys b (bin kl vl bl rl ll) r) key::int x
- = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
- when
- [lastk, lastv] = last (bin kl vl bl rl ll);
- [newl, leftHasChanged] = rmlast (bin kl vl bl rl ll)
- end
- if (k == key) && ((deleteh2 xys x) == []);
-
- deleteh (bin k::int xys b l r) key::int x
- = [bin key (deleteh2 xys x) b l r, 0]
- if k == key;
-
- deleteh (bin k::int v b l r) key::int x
- = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = deleteh l key x
- end
- if key < k;
-
- deleteh (bin k::int v b l r) key::int x
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = deleteh r key x
- end
- if key > k;
-
- deleteh2 [] _ = [];
- deleteh2 ((x1 => _) : xys) x2 = xys if x1 === x2;
- deleteh2 ((x => y) : xys) x1 = (x => y) : (deleteh2 xys x1);
-
- rmlast nil = [nil, 0];
- rmlast (bin _ _ _ l nil) = [l, 1];
- rmlast (bin k v b::int l r )
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when [newr, rightHasChanged] = rmlast r end;
-
- last (bin x y _ _ nil) = [x, y];
- last (bin _ _ _ _ d2 ) = last d2
-end;
-
-
-// create dict or hdict from a list of keys and a constant value
-mkdict y xs = dict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
-mkhdict y xs = hdict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
-
-// check for the empty dict or hdict
-null (Dict nil) = 1;
-null (Dict _) = 0;
-
-null (Hdict nil) = 1;
-null (Hdict _) = 0;
-
-// get a number of members in dict or hdict
-#(Dict d) = #d
-with
- #nil = 0;
- #(bin _ _ _ d1 d2) = #d1 + #d2 + 1
-end;
-
-#(Hdict d) = size d
-with
- size nil = 0;
- size (bin _ xys _ d1 d2) = size d1 + size d2 + #xys
-end;
-
-// check whether a key in dict or hdict
-member (Dict d) k::int |
-member (Dict d) k::string |
-member (Dict d) k = member d k
-with
- member nil _ = 0;
-
- member (bin x _ _ d1 d2) y::int |
- member (bin x _ _ d1 d2) y::string |
- member (bin x _ _ d1 d2) y
- = member d1 y if x > y;
- = member d2 y if x < y;
- = 1 if x == y
-end;
-
-member (Hdict d) k = member d (hash k) k
-with
- member nil _ _ = 0;
- member (bin k::int xys _ d1 d2) k1::int x1
- = member d1 k1 x1 if k > k1;
- = member d2 k1 x1 if k < k1;
- = memberk xys x1;
-
- memberk [] _ = 0;
- memberk ((x1 => y):_ ) x2 = 1 if x1 === x2;
- memberk ( _:xys) x2 = memberk xys x2
-end;;
-
-// get all members of dict or hdict
-members (Dict d) = members d
-with
- members nil = [];
-
- members (bin x::int y _ d1 d2) |
- members (bin x::string y _ d1 d2) |
- members (bin x y _ d1 d2)
- = members d1 + ((x => y) : (members d2))
-end;
-
-members (Hdict d) = members d
-with
- members nil = [];
- members (bin _ xys _ d1 d2) = members d1 + xys + members d2
-end;
-
-list d@(Dict _) |
-list d@(Hdict _) = members d;
-
-// get the first member of a dict
-first (Dict d) = first d
-with
- first (bin x y _ nil _) = (x => y);
- first (bin _ _ _ d1 _) = first d1
-end;
-
-// get the last member of a dict
-last (Dict d) = last d
-with
- last (bin x y _ _ nil) = (x => y);
- last (bin _ _ _ _ d2 ) = last d2
-end;
-
-// remove the first member from a dict
-rmfirst (Dict d) = Dict ((rmfirst d)!0)
-with
- rmfirst nil = [nil, 0];
- rmfirst (bin _ _ _ nil r) = [r, 1];
- rmfirst (bin k v b l r)
- = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = rmfirst l
- end
-end;
-
-// remove the last member from a dict
-rmlast (Dict d) = Dict ((rmlast d)!0)
-with
- rmlast nil = [nil 0];
- rmlast (bin _ _ _ l nil) = [l, 1];
- rmlast (bin k v b l r)
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = rmlast r
- end
-end;
-
-// get a list of all keys from dict or hdict
-keys (Dict d) = keys d
-with
- keys nil = [];
-
- keys (bin x::int _ _ d1 d2) |
- keys (bin x::string _ _ d1 d2) |
- keys (bin x _ _ d1 d2)
- = keys d1 + (x : (keys d2))
-end;
-
-keys (Hdict d) = keys d
-with
- keys nil = [];
- keys (bin _ xys _ d1 d2) = keys d1 + map (\(key => _) -> key) xys + keys d2
-end;
-
-// get a list of all values from dict or hdict
-vals (Dict d) = vals d
-with
- vals nil = [];
- vals (bin _ y _ d1 d2) = vals d1 + (y : (vals d2))
-end;
-
-vals (Hdict d) = vals d
-with
- vals nil = [];
- vals (bin _ xys _ d1 d2) = vals d1 +
- map (\(_ => val) -> val) xys +
- vals d2
-end;
-
-// get a value by key from dict or hdict
-(Dict d)!k::int |
-(Dict d)!k::string |
-(Dict d)!k = d!k
-with
- nil!_ = throw out_of_bounds;
-
- (bin x::int y _ d1 d2)!x1::int |
- (bin x::string y _ d1 d2)!x1::string |
- (bin x y _ d1 d2)!x1
- = d1!x1 if x1 < x;
- = d2!x1 if x1 > x;
- = y
-end;
-
-(Hdict d)!k = lookup d (hash k) k
-with
- lookup nil _ _ = throw out_of_bounds;
-
- lookup (bin k::int xys _ d1 d2) k1::int x1
- = lookup d1 k1 x1 if k > k1;
- = lookup d2 k1 x1 if k < k1;
- = lookupk xys x1;
-
- lookupk [] _ = throw out_of_bounds;
- lookupk ((xa => y):_ ) xb = y if xa === xb;
- lookupk ( _ :xys) x = lookupk xys x
-end;
-
-// slicing (get list of values from list of keys)
-(Dict d)!!xs = slice d [] xs
-with
- slice d ys (x:xs) = slice d
- (case mbr of nil = ys;
- (nonil y) = (y:ys) end) xs
- when
- mbr = d!x
- end;
- slice d ys [] = reverse ys;
-
- nil!_ = nil;
- (bin x::int y _ d1 d2)!x1::int |
- (bin x::string y _ d1 d2)!x1::string |
- (bin x y _ d1 d2)!x1
- = d1!x1 if x1 < x;
- = d2!x1 if x1 > x;
- = nonil y
-end;
-
-(Hdict d)!!xs = slice d [] xs
-with
- slice d ys (x:xs) = slice d
- (case mbr of nil = ys;
- (nonil y) = (y:ys) end) xs
- when
- mbr = lookup d (hash x) x
- end;
- slice d ys [] = reverse ys;
-
- lookup nil _ _ = nil;
- lookup (bin k::int xys _ d1 d2) k1::int x1
- = lookup d1 k1 x1 if k > k1;
- = lookup d2 k1 x1 if k < k1;
- = lookupk xys x1;
-
- lookupk [] _ = nil;
- lookupk ((xa => y):_ ) xb = nonil y if xa === xb;
- lookupk ( _ :xys) x = lookupk xys x
-end;
-
-// curried version of insert for dict and hdict
-update d@(Dict _) x::int y |
-update d@(Dict _) x::string y |
-update d@(Dict _) x y |
-update d@(Hdict _) x y
- = insert d (x => y);
-
-// equality checks for dict and hdict
-d1@(Dict _) == d2@(Dict _) = (members d1) == (members d2);
-
-d1@(Hdict _) == d2@(Hdict _)
- = if (all (member d1) (keys d2))
- then
- if (all (member d2) (keys d1))
- then (vals d1) == (map ((!)d2) (keys d1))
- else 0
- else 0;
-
-
-// inequality checks for dict and hdict
-d1@(Dict _) != d2@(Dict _) = (members d1) != (members d2);
-d1@(Hdict _) != d2@(Hdict _) = not (d1 == d2);
-
-/* Private functions, don't invoke these directly. */
-
-Dict_adjustd ToF::int tree LoR::int
- = adjust ToF tree LoR
-with
- adjust 0 oldTree _ = [oldTree, 0];
-
- adjust 1 (bin key::int val b0 l r) LoR |
- adjust 1 (bin key::string val b0 l r) LoR |
- adjust 1 (bin key val b0 l r) LoR
- = rebal toBeRebalanced (bin key val b0 l r) b1 whatHasChanged
- when
- [b1, whatHasChanged, toBeRebalanced] = tabled b0 LoR
- end;
-
- rebal 0 (bin k::int v _ l r) b whatHasChanged |
- rebal 0 (bin k::string v _ l r) b whatHasChanged |
- rebal 0 (bin k v _ l r) b whatHasChanged
- = [bin k v b l r, whatHasChanged];
-
- rebal 1 oldTree _ _ = Dict_avl_geq oldTree;
-
-// Balance rules for deletions
-// balance where balance whole tree to be
-// before deleted after decreased rebalanced
-tabled ( 0) ( 1) = [( 1), 0, 0];
-tabled ( 0) (-1) = [(-1), 0, 0];
-tabled ( 1) ( 1) = [( 0), 1, 1];
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-
-tabled ( 1) (-1) = [( 0), 1, 0];
-tabled (-1) ( 1) = [( 0), 1, 0];
-tabled (-1) (-1) = [( 0), 1, 1];
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-end;
-
-// Single and double tree rotations - these are common for insert and delete
-/*
- The patterns (-1)-(-1), (-1)-( 1), ( 1)-( 1) and ( 1)-(-1) on the LHS always
- change the tree height and these are the only patterns which can happen
- after an insertion. That's the reason why we can use tablei only to decide
- the needed changes.
- The patterns (-1)-( 0) and ( 1)-( 0) do not change the tree height. After a
- deletion any pattern can occur and so we return 1 or 0 as a flag of
- a height change.
-*/
-Dict_avl_geq d = avl_geq d
-with
- avl_geq (bin a::int va (-1) alpha (bin b::int vb (-1) beta gamma)) |
- avl_geq (bin a::string va (-1) alpha (bin b::string vb (-1) beta gamma)) |
- avl_geq (bin a va (-1) alpha (bin b vb (-1) beta gamma))
- = [bin b vb ( 0) (bin a va ( 0) alpha beta) gamma, 1];
-
- avl_geq (bin a::int va (-1) alpha (bin b::int vb ( 0) beta gamma)) |
- avl_geq (bin a::string va (-1) alpha (bin b::string vb ( 0) beta gamma)) |
- avl_geq (bin a va (-1) alpha (bin b vb ( 0) beta gamma))
- = [bin b vb ( 1) (bin a va (-1) alpha beta) gamma, 0];
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin a::int va (-1) alpha
- (bin b::int vb ( 1)
- (bin x::int vx b1 beta gamma) delta)) |
- avl_geq (bin a::string va (-1) alpha
- (bin b::string vb ( 1)
- (bin x::string vx b1 beta gamma) delta)) |
- avl_geq (bin a va (-1) alpha
- (bin b vb ( 1) (bin x vx b1 beta gamma) delta))
- = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
- when
- [b2, b3] = table b1
- end;
-
- avl_geq (bin b::int vb ( 1) (bin a::int va ( 1) alpha beta) gamma) |
- avl_geq (bin b::string vb ( 1) (bin a::string va ( 1) alpha beta) gamma) |
- avl_geq (bin b vb ( 1) (bin a va ( 1) alpha beta) gamma)
- = [bin a va ( 0) alpha (bin b vb ( 0) beta gamma), 1];
-
- avl_geq (bin b::int vb ( 1) (bin a::int va ( 0) alpha beta) gamma) |
- avl_geq (bin b::string vb ( 1) (bin a::string va ( 0) alpha beta) gamma) |
- avl_geq (bin b vb ( 1) (bin a va ( 0) alpha beta) gamma)
- = [bin a va (-1) alpha (bin b vb ( 1) beta gamma), 0];
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin b::int vb ( 1)
- (bin a::int va (-1) alpha
- (bin x::int vx b1 beta gamma)) delta) |
- avl_geq (bin b::string vb ( 1)
- (bin a::string va (-1) alpha
- (bin x::string vx b1 beta gamma)) delta) |
- avl_geq (bin b vb ( 1)
- (bin a va (-1) alpha (bin x vx b1 beta gamma)) delta)
- = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
- when
- [b2, b3] = table b1
- end;
-
- table ( 1) = [( 0), (-1)];
- table (-1) = [( 1), ( 0)];
- table ( 0) = [( 0), ( 0)]
-end;
Deleted: pure/trunk/examples/heap.pure
===================================================================
--- pure/trunk/examples/heap.pure 2008-07-07 20:46:37 UTC (rev 411)
+++ pure/trunk/examples/heap.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -1,182 +0,0 @@
-/* Pure's priority queue data structure implemented as binary trees */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
-
- This file is part of the Pure programming language and system.
-
- Pure is free software: you can redistribute it and/or modify it under the
- terms of the GNU General Public License as published by the Free Software
- Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- Pure is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
- FOR a PARTICULAR PURPOSE. See the GNU General Public License for more
- details.
-
- You should have received a copy of the GNU General Public License along
- with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-
-/* Heaps allow quick (constant time) access to the smallest member, and to
- remove the smallest nember and insert new elements in logarithmic time.
- This implementation does not allow quick update of heap members; if
- such functionality is required, bags should be used instead
- (see bag in set.pure).
-
- Heap members must be ordered by the <= predicate. Multiple instances
- of the same element may be stored in a heap; however, the order in
- which equal elements are retrieved is not specified. */
-
-/* Public operations: ******************************************************
-
-// #h // size of a heap
-
-// null h // tests whether h is the empty heap
-// list h, members h // lists members of h in ascending order
-
-// first h // first (i.e. smallest) member of h
-// rmfirst h // remove smallest member from h
-// insert h x // insert h into x
-
- *************************************************************************/
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-// create an empty heap
-emptyheap = Heap nil;
-
-// create a heap from a list
-heap xs = foldl insert emptyheap xs if listp xs;
-
-// check whether h is a heap
-heapp (Heap _) = 1;
-heapp _ = 0 otherwise;
-
-// get size of a heap
-#(Heap h) = #h
-with
- #nil = 0;
- #bin 0 _ h1 _ = #h1 * 2 + 1;
- #bin 1 _ h1 _ = #h1 * 2
-end;
-
-// test for an empty heap
-null (Heap nil) = 1;
-null (Heap _) = 0 otherwise;
-
-// get members of a heap as an ordered list
-members h@(Heap _) = [] if null h;
- = accum [first h] (rmfirst h)
-with
- accum ys h = reverse ys if null h;
- = accum ((first h):ys) (rmfirst h)
-end;
-
-list h@(Heap _) = members h;
-
-// get the first (smallest) member of a heap
-first (Heap (bin _ x _ _)) = x;
-
-// remove the first (smallest) member of a heap
-rmfirst (Heap h) = Heap (rmfirst h)
-with
- rmfirst (bin 0 _ nil nil) = nil;
- rmfirst (bin 0 _ h1 h2 ) = update (bin 1 (last h2) h1 (rmlast h2));
- rmfirst (bin 1 _ h1 h2 ) = update (bin 0 (last h1) (rmlast h1) h2);
-
- last (bin 0 x::int nil nil) |
- last (bin 0 x::string nil nil) |
- last (bin 0 x nil nil)
- = x;
- last (bin 0 _ _ h2) = last h2;
- last (bin 1 _ h1 _) = last h1;
-
- update (bin 0 x::int nil nil) |
- update (bin 0 x::string nil nil) |
- update (bin 0 x nil nil)
- = bin 0 x nil nil;
- update (bin 1 x::int (bin b1::int x1::int h1 h2) nil) |
- update (bin 1 x::string (bin b1::int x1::string h1 h2) nil) |
- update (bin 1 x (bin b1::int x1 h1 h2) nil)
- = bin 1 x (bin b1 x1 h1 h2) nil
- if x <= x1;
- = bin 1 x1 (update (bin b1 x h1 h2))
- nil otherwise;
- update (bin b::int x::int (bin b1::int x1::int h1 h2)
- (bin b2::int x2::int h3 h4)) |
- update (bin b::int x::string (bin b1::int x1::string h1 h2)
- (bin b2::int x2::string h3 h4)) |
- update (bin b::int x (bin b1::int x1 h1 h2)
- (bin b2::int x2 h3 h4))
- = bin b x (bin b1 x1 h1 h2) (bin b2 x2 h3 h4)
- if (x <= x1) && (x <= x2);
- = bin b x1 (update (bin b1 x h1 h2))
- (bin b2 x2 h3 h4)
- if x1 <= x2;
- = bin b x2 (bin b1 x1 h1 h2)
- (update (bin b2 x h3 h4))
- otherwise;
-
- rmlast (bin 0 _ nil nil) = nil;
- rmlast (bin 0 x h1 h2 ) = bin 1 x h1 (rmlast h2);
- rmlast (bin 1 x h1 h2 ) = bin 0 x (rmlast h1) h2;
-end;
-
-// insert a new member into a heap
-insert (Heap h) y::int |
-insert (Heap h) y::string |
-insert (Heap h) y = Heap (insert h y)
-with
- insert nil y::int |
- insert nil y::string |
- insert nil y = bin 0 y nil nil;
-
- insert (bin 0 x::int h1 h2) y::int |
- insert (bin 0 x::string h1 h2) y::string |
- insert (bin 0 x h1 h2) y
- = bin 1 x (insert h1 y) h2 if x <= y;
- = bin 1 y (insert h1 x) h2 otherwise;
- insert (bin 1 x::int h1 h2) y::int |
- insert (bin 1 x::string h1 h2) y::string |
- insert (bin 1 x h1 h2) y
- = bin 0 x h1 (insert h2 y) if x <= y;
- = bin 0 y h1 (insert h2 x) otherwise
-end;
-
-// equality test
-(Heap h1) == (Heap h2) = eq h1 h2
-with
- eq nil nil = 1;
- eq nil (bin _ _ _ _) = 0;
- eq (bin _ _ _ _) nil = 0;
- eq (bin b1::int x1::int h1 h2) (bin b2::int x2::int h3 h4) |
- eq (bin b1::int x1::string h1 h2) (bin b2::int x2::string h3 h4) |
- eq (bin b1::int x1 h1 h2) (bin b2::int x2 h3 h4)
- = if (b1 == b2)
- then if (x1 == x2)
- then if eq h1 h3
- then eq h2 h4
- else 0
- else 0
- else 0
-end;;
-
-// inequaliy test
-(Heap h1) != (Heap h2) = neq h1 h2
-with
- neq nil nil = 0;
- neq nil (bin _ _ _ _) = 1;
- neq (bin _ _ _ _) nil = 1;
- neq (bin b1::int x1::int h1 h2) (bin b2::int x2::int h3 h4) |
- neq (bin b1::int x1::string h1 h2) (bin b2::int x2::string h3 h4) |
- neq (bin b1::int x1 h1 h2) (bin b2::int x2 h3 h4)
- = if (b1 != b2)
- then 1
- else if (x1 != x2)
- then 1
- else if neq h1 h3
- then 1
- else neq h2 h4
-end;
Copied: pure/trunk/lib/array.pure (from rev 411, pure/trunk/examples/array.pure)
===================================================================
--- pure/trunk/lib/array.pure (rev 0)
+++ pure/trunk/lib/array.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -0,0 +1,233 @@
+
+/* array.pure: integer-indexed arrays implemented as size-balanced
+ binary trees. */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure is free software: you can redistribute it and/or modify it under the
+ terms of the GNU General Public License as published by the Free Software
+ Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ Pure is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+ details.
+
+ You should have received a copy of the GNU General Public License along
+ with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* This script implements an efficient variable-sized array data structure
+ which allows to access and update individual array members, as well as
+ to add and remove elements at the beginning and end of an array. All these
+ operations are carried out in logarithmic time. */
+
+/* Public operations: ******************************************************
+
+ emptyarray return the empty array
+ array xs create an array from a list xs
+ array2 xs create a two-dimensional array from a list of lists
+ mkarray x n create an array consisting of n x's
+ mkarray2 x (n,m) create a 2D array of n*m x's
+ arrayp x check whether x is an array
+
+ #a size of a
+ a!i return ith member of a
+ a!(i,j) two-dimensional subscript
+
+ a!!is slicing (get a list of values from a list
+ indices
+ a!!ijs slicing of two-dimensional array (from a given
+ list of pairs (i, j):...:[])
+
+ null a tests whether a is the empty array
+ members a list of values stored in a
+ members2 a list of members in a two-dimensional array
+
+ first a, last a first and last member of A
+ rmfirst a, rmlast a remove first and last member from a
+ insert a x insert x at the beginning of a
+ append a x append x to the end of a
+ update a i x replace the ith member of a by x
+ update2 a (i,j) x update two-dimensional array
+
+ *************************************************************************/
+
+/* Empty tree constant, consider this private. */
+nullary nil;
+
+// array type check
+arrayp (Array _) = 1;
+arrayp _ = 0;
+
+// create an empty array
+emptyarray = Array nil;
+
+// create an array from a list
+array xs = foldl append emptyarray xs if listp xs;
+
+// create a two-dimensional array from a two-dimensional list
+array2 xs = array (map array xs);
+
+// create an array of a given size filled with a constant value
+mkarray x n::int = Array (mkarray x n)
+with
+ mkarray x n::int = nil if n <= 0;
+ = tip x if n == 1;
+ = array_mkbin (n mod 2)
+ (mkarray x (n - n div 2))
+ (mkarray x (n div 2));
+end;
+
+// create a 2D array of given dimensions filled with a constant value
+mkarray2 x (n::int, m::int) = mkarray (mkarray x m) n;
+
+// get array size
+#(Array a) = #a
+with
+ #nil = 0;
+ #(tip _) = 1;
+ #(bin 0 a1 _) = #a1 * 2;
+ #(bin 1 a1 _) = #a1 * 2 - 1;
+end;
+
+// get value by index
+(Array a)!i::int = a!i
+with
+ (tip x)!0 = x;
+ (bin _ a1 a2)!i::int = a1!(i div 2) if i mod 2 == 0;
+ = a2!(i div 2) if i mod 2 == 1;
+ _ ! _ = throw out_of_bounds;
+end;
+
+// get value by indices from two-dimensional array
+x@(Array _)!(i::int, j::int) = x!i!j;
+
+// slicing (get list of values from list of indices)
+a@(Array _)!!is@(_::int:_) = [a!i; i = is; (i >= 0) && (i < (#a))];
+
+// slicing of two-dimensional array
+a@(Array _)!!ijs@((_::int, _::int):_)
+ = [a!(i, j); (i, j) = ijs; (i >= 0) && (i < (#a))
+ && (j >= 0) && (j < (#(a!i)))];
+
+// check for an empty array
+null (Array nil) = 1;
+null (Array _) = 0;
+
+// get all array members in list form
+members (Array a) = members a
+with
+ members nil = [];
+ members (tip x) = [x];
+ members (bin _ a1 a2) = merge (members a1) (members a2);
+ // merge lists xs (even elements) and ys (odd elements)
+ merge [] ys = ys;
+ merge (x:xs) ys = x:merge ys xs;
+end;
+
+// get all members of an two-dimensional array in list form
+members2 x@(Array _) = map members (members x);
+
+// get the first array member
+first (Array a) = first a
+with
+ first (tip x) = x;
+ first (bin _ a1 _) = first a1;
+end;
+
+// get the last array member
+last (Array a) = last a
+with
+ last (tip x) = x;
+ last (bin 0 _ a2) = last a2;
+ last (bin 1 a1 _) = last a1;
+end;
+
+// remove the first member from an array
+rmfirst (Array a) = Array (rmfirst a)
+with
+ rmfirst (tip _) = nil;
+ rmfirst (bin 0 a1 a2) = array_mkbin 1 a2 (rmfirst a1);
+ rmfirst (bin 1 a1 a2) = array_mkbin 0 a2 (rmfirst a1);
+end;
+
+// remove the last member from an array
+rmlast (Array a) = Array (rmlast a)
+with
+ rmlast (tip _) = nil;
+ rmlast (bin 0 a1 a2) = array_mkbin 1 a1 (rmlast a2);
+ rmlast (bin 1 a1 a2) = array_mkbin 0 (rmlast a1) a2;
+end;
+
+// insert a new member at the beginning of an array
+insert (Array a) y = Array (insert a y)
+with
+ insert nil y = tip y;
+ insert (tip x) y = bin 0 (tip y) (tip x);
+ insert (bin 0 a1 a2) y = array_mkbin 1 (insert a2 y) a1;
+ insert (bin 1 a1 a2) y = array_mkbin 0 (insert a2 y) a1;
+end;
+
+// append a new member at the end of an array
+append (Array a) y = Array (append a y)
+with
+ append nil y = tip y;
+ append (tip x) y = bin 0 (tip x) (tip y);
+ append (bin 0 a1 a2) y = array_mkbin 1 (append a1 y) a2;
+ append (bin 1 a1 a2) y = array_mkbin 0 a1 (append a2 y);
+end;
+
+// update a given array position with a new value
+update (Array a) i::int y = Array (update a i y)
+with
+ update (tip _) 0 y = tip y;
+ update (bin b::int a1 a2) i::int y
+ = bin b (update a1 (i div 2) y) a2
+ if i mod 2 == 0;
+ = bin b a1 (update a2 (i div 2) y)
+ if i mod 2 == 1;
+end;
+
+// update a given position of a two-dimensional array with a new value
+update2 x@(Array a) (i::int, j::int) y
+ = update x i (update (x!i) j y);
+
+// compare two arrays for equality
+Array a == Array b = eq a b
+with
+ eq nil nil = 1;
+ eq nil (tip _) = 0;
+ eq nil (bin _ _ _) = 0;
+ eq (tip _) nil = 0;
+ eq (tip x) (tip y) = x == y;
+ eq (tip _) (bin _ _ _) = 0;
+ eq (bin _ _ _) nil = 0;
+ eq (bin _ _ _) (tip _) = 0;
+ eq (bin b1::int a1 a2) (bin b2::int a3 a4)
+ = b1 == b2 && eq a1 a3 && eq a2 a4;
+end;
+
+// compare two arrays for inequality
+Array a != Array b = neq a b
+with
+ neq nil nil = 0;
+ neq nil (tip _) = 1;
+ neq nil (bin _ _ _) = 1;
+ neq (tip _) nil = 1;
+ neq (tip x) (tip y) = x != y;
+ neq (tip _) (bin _ _ _) = 1;
+ neq (bin _ _ _) nil = 1;
+ neq (bin _ _ _) (tip _) = 1;
+ neq (bin b1::int a1 a2) (bin b2::int a3 a4)
+ = b1 != b2 || neq a1 a3 || neq a2 a4;
+end;
+
+/* Private functions, don't invoke these directly. */
+
+// construct a binary array node
+array_mkbin _ nil a2 = a2;
+array_mkbin _ a1 nil = a1;
+array_mkbin b::int a1 a2 = bin b a1 a2;
Copied: pure/trunk/lib/dict.pure (from rev 411, pure/trunk/examples/dict.pure)
===================================================================
--- pure/trunk/lib/dict.pure (rev 0)
+++ pure/trunk/lib/dict.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -0,0 +1,625 @@
+/* Pure's dict and hdict data types based on AVL trees. */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+ Copyright (c) 2008 by Jiri Spitz <jir...@bl...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure is free software: you can redistribute it and/or modify it under the
+ terms of the GNU General Public License as published by the Free Software
+ Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ Pure is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR a PARTICULAR PURPOSE. See the GNU General Public License for more
+ details.
+
+ You should have received a copy of the GNU General Public License along
+ with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ The used algorithm of AVL trees has its origin in the SWI-Prolog
+ implementation of association lists. The original file was created by
+ R. A. O'Keefe and updated for the SWI-Prolog by Jan Wielemaker. For the
+ original file see http://www.swi-prolog.org.
+
+ The port from SWI-Prolog and the deletion stuff (rmfirst, rmlast, delete)
+ missing in the original file was provided by Jiri Spitz
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+/* Empty tree constant, consider this private. */
+nullary nil;
+
+/*****
+Tree for dict and hdict is either:
+- nil (empty tree) or
+- bin Key value Balance Left Right (Left, Right: trees)
+
+Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
+*****/
+
+
+/* Public operations: ******************************************************
+
+emptydict, emptyhdict: return the empty dict or bag
+dict xs, hdict xs; create a dict or hdict from list xs
+dictp d, hdictp d; check whether x is a dict or hdict
+mkdict y xs, mkhdict y xs: create dict or hdict from a list of keys and
+ a constant value
+
+#d size of dict or hdict d
+d!x: get value from d by key x
+d!!xs slicing (get a list of values
+ from a list of keys)
+
+null d tests whether d is the empty dict or hdict
+member d x tests whether d contains member with key x
+members d, list d list members of d (in ascending order fo dict)
+keys d: lists keys of d (in ascending order fo dict)
+values d: list values of d
+
+first d, last d return first and last member of dict
+rmfirst d, rmlast d remove first and last member from dict
+insert d xy insert x into d (replace existing element)
+update d x y fully curried version of insert
+delete d x remove x from d
+
+ *************************************************************************/
+
+
+// Dict and hdict type checks
+dictp (Dict _) = 1;
+dictp _ = 0;
+
+hdictp (Hdict _) = 1;
+hdictp _ = 0;
+
+// create an empty dict or hdict
+emptydict = Dict nil;
+emptyhdict = Hdict nil;
+
+// create dict or hdict from a list
+dict xys = foldl insert emptydict xys if listp xys;
+hdict xys = foldl insert emptyhdict xys if listp xys;
+
+// insert a new member into the dict or hdict
+insert (t@Dict d) (x::int => y) |
+insert (t@Dict d) (x::string => y) |
+insert (t@Dict d) (x => y) |
+insert (t@Hdict d) (x => y)
+ = if t === Dict
+ then t ((insertd d x y)!0)
+ else t ((inserth d (hash x) x y)!0)
+with
+ insertd nil key::int val |
+ insertd nil key::string val |
+ insertd nil key val
+ = [(bin key val ( 0) nil nil), 1];
+
+ insertd (bin k::int _ b l r) key::int val |
+ insertd (bin k::string _ b l r) key::string val |
+ insertd (bin k _ b l r) key val
+ = [(bin key val b l r), 0] if key == k;
+
+ insertd (bin k::int v b l r) key::int val |
+ insertd (bin k::string v b l r) key::string val |
+ insertd (bin k v b l r) key val
+ = adjust leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = insertd l key val
+ end
+ if key < k;
+
+ insertd (bin k::int v b l r) key::int val |
+ insertd (bin k::string v b l r) key::string val |
+ insertd (bin k v b l r) key val
+ = adjust rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = insertd r key val
+ end
+ if key > k;
+
+ inserth nil k::int x y = [(bin k [x => y] ( 0) nil nil), 1];
+
+ inserth (bin k::int v b l r) key::int x y
+ = [(bin k (inserth2 v x y) b l r), 0] if k == key;
+
+ inserth (bin k::int v b l r) key::int x y
+ = adjust leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = inserth l key x y
+ end
+ if key < k;
+
+ inserth (bin k::int v b l r) key::int x y
+ = adjust rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = inserth r key x y
+ end
+ if key > k;
+
+ inserth2 [] x y = [x => y];
+ inserth2 ((x1 => y):xys) x2 y1
+ = ((x1 => y1):xys) if x1 === x2;
+ inserth2 ((x => y):xys) x1 y1
+ = ((x => y ):(inserth2 xys x1 y1));
+
+ adjust 0 oldTree _ = [oldTree, 0];
+
+ adjust 1 (bin key::int val b0 l r) LoR |
+ adjust 1 (bin key::string val b0 l r) LoR |
+ adjust 1 (bin key val b0 l r) LoR
+ = [rebal toBeRebalanced (bin key val b0 l r) b1, whatHasChanged]
+ when
+ [b1, whatHasChanged, toBeRebalanced] = table b0 LoR
+ end;
+
+ rebal 0 (bin k::int v _ l r) b |
+ rebal 0 (bin k::string v _ l r) b |
+ rebal 0 (bin k v _ l r) b
+ = bin k v b l r;
+
+ rebal 1 oldTree _ = (Dict_avl_geq oldTree)!0;
+
+// Balance rules for insertions
+// balance where balance whole tree to be
+// before inserted after increased rebalanced
+table ( 0) (-1) = [( 1), 1, 0];
+table ( 0) ( 1) = [(-1), 1, 0];
+table ( 1) (-1) = [( 0), 0, 1];
+table ( 1) ( 1) = [( 0), 0, 0];
+table (-1) (-1) = [( 0), 0, 0];
+table (-1) ( 1) = [( 0), 0, 1]
+end;
+
+// delete a member by key from the dict or hdict
+delete (t@Dict d) x::int |
+delete (t@Dict d) x::string |
+delete (t@Dict d) x |
+delete (t@Hdict d) x
+ = if t === Dict
+ then t ((deleted d x)!0)
+ else t ((deleteh d (hash x) x)!0)
+with
+ deleted nil _ = [nil, 0];
+
+ deleted (bin k::int _ _ nil r ) key::int |
+ deleted (bin k::string _ _ nil r ) key::string |
+ deleted (bin k _ _ nil r ) key
+ = [r, 1] if key == k;
+
+ deleted (bin k::int _ _ l nil) key::int |
+ deleted (bin k::string _ _ l nil) key::string |
+ deleted (bin k _ _ l nil) key
+ = [l, 1] if key == k;
+
+ deleted (bin k::int _ b (bin kl::int vl bl rl ll) r ) key::int |
+ deleted (bin k::string _ b (bin kl::string vl bl rl ll) r ) key::string |
+ deleted (bin k _ b (bin kl vl bl rl ll) r ) key
+ = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
+ when
+ [lastk, lastv] = last (bin kl vl bl rl ll);
+ [newl, leftHasChanged]
+ = rmlast (bin kl vl bl rl ll)
+ end
+ if key == k;
+
+ deleted (bin k::int v b l r) key::int |
+ deleted (bin k::string v b l r) key::string |
+ deleted (bin k v b l r) key
+ = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = deleted l key
+ end
+ if key < k;
+
+ deleted (bin k::int v b l r) key::int |
+ deleted (bin k::string v b l r) key::string |
+ deleted (bin k v b l r) key
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = deleted r key
+ end
+ if key > k;
+
+ deleteh nil _ _ = [nil, 0];
+
+ deleteh (bin k::int xys b nil r ) key::int x
+ = (if (newxys == [])
+ then [r, 1]
+ else [bin k newxys b nil r, 0])
+ when
+ newxys = deleteh2 xys x
+ end
+ if k == key;
+
+ deleteh (bin k::int xys b l nil) key::int x
+ = (if (newxys == [])
+ then [l, 1]
+ else [bin k newxys b l nil, 0])
+ when
+ newxys = deleteh2 xys x
+ end
+ if k == key;
+
+ deleteh (bin k::int xys b (bin kl vl bl rl ll) r) key::int x
+ = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
+ when
+ [lastk, lastv] = last (bin kl vl bl rl ll);
+ [newl, leftHasChanged] = rmlast (bin kl vl bl rl ll)
+ end
+ if (k == key) && ((deleteh2 xys x) == []);
+
+ deleteh (bin k::int xys b l r) key::int x
+ = [bin key (deleteh2 xys x) b l r, 0]
+ if k == key;
+
+ deleteh (bin k::int v b l r) key::int x
+ = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = deleteh l key x
+ end
+ if key < k;
+
+ deleteh (bin k::int v b l r) key::int x
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = deleteh r key x
+ end
+ if key > k;
+
+ deleteh2 [] _ = [];
+ deleteh2 ((x1 => _) : xys) x2 = xys if x1 === x2;
+ deleteh2 ((x => y) : xys) x1 = (x => y) : (deleteh2 xys x1);
+
+ rmlast nil = [nil, 0];
+ rmlast (bin _ _ _ l nil) = [l, 1];
+ rmlast (bin k v b::int l r )
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when [newr, rightHasChanged] = rmlast r end;
+
+ last (bin x y _ _ nil) = [x, y];
+ last (bin _ _ _ _ d2 ) = last d2
+end;
+
+
+// create dict or hdict from a list of keys and a constant value
+mkdict y xs = dict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
+mkhdict y xs = hdict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
+
+// check for the empty dict or hdict
+null (Dict nil) = 1;
+null (Dict _) = 0;
+
+null (Hdict nil) = 1;
+null (Hdict _) = 0;
+
+// get a number of members in dict or hdict
+#(Dict d) = #d
+with
+ #nil = 0;
+ #(bin _ _ _ d1 d2) = #d1 + #d2 + 1
+end;
+
+#(Hdict d) = size d
+with
+ size nil = 0;
+ size (bin _ xys _ d1 d2) = size d1 + size d2 + #xys
+end;
+
+// check whether a key in dict or hdict
+member (Dict d) k::int |
+member (Dict d) k::string |
+member (Dict d) k = member d k
+with
+ member nil _ = 0;
+
+ member (bin x _ _ d1 d2) y::int |
+ member (bin x _ _ d1 d2) y::string |
+ member (bin x _ _ d1 d2) y
+ = member d1 y if x > y;
+ = member d2 y if x < y;
+ = 1 if x == y
+end;
+
+member (Hdict d) k = member d (hash k) k
+with
+ member nil _ _ = 0;
+ member (bin k::int xys _ d1 d2) k1::int x1
+ = member d1 k1 x1 if k > k1;
+ = member d2 k1 x1 if k < k1;
+ = memberk xys x1;
+
+ memberk [] _ = 0;
+ memberk ((x1 => y):_ ) x2 = 1 if x1 === x2;
+ memberk ( _:xys) x2 = memberk xys x2
+end;;
+
+// get all members of dict or hdict
+members (Dict d) = members d
+with
+ members nil = [];
+
+ members (bin x::int y _ d1 d2) |
+ members (bin x::string y _ d1 d2) |
+ members (bin x y _ d1 d2)
+ = members d1 + ((x => y) : (members d2))
+end;
+
+members (Hdict d) = members d
+with
+ members nil = [];
+ members (bin _ xys _ d1 d2) = members d1 + xys + members d2
+end;
+
+list d@(Dict _) |
+list d@(Hdict _) = members d;
+
+// get the first member of a dict
+first (Dict d) = first d
+with
+ first (bin x y _ nil _) = (x => y);
+ first (bin _ _ _ d1 _) = first d1
+end;
+
+// get the last member of a dict
+last (Dict d) = last d
+with
+ last (bin x y _ _ nil) = (x => y);
+ last (bin _ _ _ _ d2 ) = last d2
+end;
+
+// remove the first member from a dict
+rmfirst (Dict d) = Dict ((rmfirst d)!0)
+with
+ rmfirst nil = [nil, 0];
+ rmfirst (bin _ _ _ nil r) = [r, 1];
+ rmfirst (bin k v b l r)
+ = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = rmfirst l
+ end
+end;
+
+// remove the last member from a dict
+rmlast (Dict d) = Dict ((rmlast d)!0)
+with
+ rmlast nil = [nil 0];
+ rmlast (bin _ _ _ l nil) = [l, 1];
+ rmlast (bin k v b l r)
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = rmlast r
+ end
+end;
+
+// get a list of all keys from dict or hdict
+keys (Dict d) = keys d
+with
+ keys nil = [];
+
+ keys (bin x::int _ _ d1 d2) |
+ keys (bin x::string _ _ d1 d2) |
+ keys (bin x _ _ d1 d2)
+ = keys d1 + (x : (keys d2))
+end;
+
+keys (Hdict d) = keys d
+with
+ keys nil = [];
+ keys (bin _ xys _ d1 d2) = keys d1 + map (\(key => _) -> key) xys + keys d2
+end;
+
+// get a list of all values from dict or hdict
+vals (Dict d) = vals d
+with
+ vals nil = [];
+ vals (bin _ y _ d1 d2) = vals d1 + (y : (vals d2))
+end;
+
+vals (Hdict d) = vals d
+with
+ vals nil = [];
+ vals (bin _ xys _ d1 d2) = vals d1 +
+ map (\(_ => val) -> val) xys +
+ vals d2
+end;
+
+// get a value by key from dict or hdict
+(Dict d)!k::int |
+(Dict d)!k::string |
+(Dict d)!k = d!k
+with
+ nil!_ = throw out_of_bounds;
+
+ (bin x::int y _ d1 d2)!x1::int |
+ (bin x::string y _ d1 d2)!x1::string |
+ (bin x y _ d1 d2)!x1
+ = d1!x1 if x1 < x;
+ = d2!x1 if x1 > x;
+ = y
+end;
+
+(Hdict d)!k = lookup d (hash k) k
+with
+ lookup nil _ _ = throw out_of_bounds;
+
+ lookup (bin k::int xys _ d1 d2) k1::int x1
+ = lookup d1 k1 x1 if k > k1;
+ = lookup d2 k1 x1 if k < k1;
+ = lookupk xys x1;
+
+ lookupk [] _ = throw out_of_bounds;
+ lookupk ((xa => y):_ ) xb = y if xa === xb;
+ lookupk ( _ :xys) x = lookupk xys x
+end;
+
+// slicing (get list of values from list of keys)
+(Dict d)!!xs = slice d [] xs
+with
+ slice d ys (x:xs) = slice d
+ (case mbr of nil = ys;
+ (nonil y) = (y:ys) end) xs
+ when
+ mbr = d!x
+ end;
+ slice d ys [] = reverse ys;
+
+ nil!_ = nil;
+ (bin x::int y _ d1 d2)!x1::int |
+ (bin x::string y _ d1 d2)!x1::string |
+ (bin x y _ d1 d2)!x1
+ = d1!x1 if x1 < x;
+ = d2!x1 if x1 > x;
+ = nonil y
+end;
+
+(Hdict d)!!xs = slice d [] xs
+with
+ slice d ys (x:xs) = slice d
+ (case mbr of nil = ys;
+ (nonil y) = (y:ys) end) xs
+ when
+ mbr = lookup d (hash x) x
+ end;
+ slice d ys [] = reverse ys;
+
+ lookup nil _ _ = nil;
+ lookup (bin k::int xys _ d1 d2) k1::int x1
+ = lookup d1 k1 x1 if k > k1;
+ = lookup d2 k1 x1 if k < k1;
+ = lookupk xys x1;
+
+ lookupk [] _ = nil;
+ lookupk ((xa => y):_ ) xb = nonil y if xa === xb;
+ lookupk ( _ :xys) x = lookupk xys x
+end;
+
+// curried version of insert for dict and hdict
+update d@(Dict _) x::int y |
+update d@(Dict _) x::string y |
+update d@(Dict _) x y |
+update d@(Hdict _) x y
+ = insert d (x => y);
+
+// equality checks for dict and hdict
+d1@(Dict _) == d2@(Dict _) = (members d1) == (members d2);
+
+d1@(Hdict _) == d2@(Hdict _)
+ = if (all (member d1) (keys d2))
+ then
+ if (all (member d2) (keys d1))
+ then (vals d1) == (map ((!)d2) (keys d1))
+ else 0
+ else 0;
+
+
+// inequality checks for dict and hdict
+d1@(Dict _) != d2@(Dict _) = (members d1) != (members d2);
+d1@(Hdict _) != d2@(Hdict _) = not (d1 == d2);
+
+/* Private functions, don't invoke these directly. */
+
+Dict_adjustd ToF::int tree LoR::int
+ = adjust ToF tree LoR
+with
+ adjust 0 oldTree _ = [oldTree, 0];
+
+ adjust 1 (bin key::int val b0 l r) LoR |
+ adjust 1 (bin key::string val b0 l r) LoR |
+ adjust 1 (bin key val b0 l r) LoR
+ = rebal toBeRebalanced (bin key val b0 l r) b1 whatHasChanged
+ when
+ [b1, whatHasChanged, toBeRebalanced] = tabled b0 LoR
+ end;
+
+ rebal 0 (bin k::int v _ l r) b whatHasChanged |
+ rebal 0 (bin k::string v _ l r) b whatHasChanged |
+ rebal 0 (bin k v _ l r) b whatHasChanged
+ = [bin k v b l r, whatHasChanged];
+
+ rebal 1 oldTree _ _ = Dict_avl_geq oldTree;
+
+// Balance rules for deletions
+// balance where balance whole tree to be
+// before deleted after decreased rebalanced
+tabled ( 0) ( 1) = [( 1), 0, 0];
+tabled ( 0) (-1) = [(-1), 0, 0];
+tabled ( 1) ( 1) = [( 0), 1, 1];
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+
+tabled ( 1) (-1) = [( 0), 1, 0];
+tabled (-1) ( 1) = [( 0), 1, 0];
+tabled (-1) (-1) = [( 0), 1, 1];
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+end;
+
+// Single and double tree rotations - these are common for insert and delete
+/*
+ The patterns (-1)-(-1), (-1)-( 1), ( 1)-( 1) and ( 1)-(-1) on the LHS always
+ change the tree height and these are the only patterns which can happen
+ after an insertion. That's the reason why we can use tablei only to decide
+ the needed changes.
+ The patterns (-1)-( 0) and ( 1)-( 0) do not change the tree height. After a
+ deletion any pattern can occur and so we return 1 or 0 as a flag of
+ a height change.
+*/
+Dict_avl_geq d = avl_geq d
+with
+ avl_geq (bin a::int va (-1) alpha (bin b::int vb (-1) beta gamma)) |
+ avl_geq (bin a::string va (-1) alpha (bin b::string vb (-1) beta gamma)) |
+ avl_geq (bin a va (-1) alpha (bin b vb (-1) beta gamma))
+ = [bin b vb ( 0) (bin a va ( 0) alpha beta) gamma, 1];
+
+ avl_geq (bin a::int va (-1) alpha (bin b::int vb ( 0) beta gamma)) |
+ avl_geq (bin a::string va (-1) alpha (bin b::string vb ( 0) beta gamma)) |
+ avl_geq (bin a va (-1) alpha (bin b vb ( 0) beta gamma))
+ = [bin b vb ( 1) (bin a va (-1) alpha beta) gamma, 0];
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin a::int va (-1) alpha
+ (bin b::int vb ( 1)
+ (bin x::int vx b1 beta gamma) delta)) |
+ avl_geq (bin a::string va (-1) alpha
+ (bin b::string vb ( 1)
+ (bin x::string vx b1 beta gamma) delta)) |
+ avl_geq (bin a va (-1) alpha
+ (bin b vb ( 1) (bin x vx b1 beta gamma) delta))
+ = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end;
+
+ avl_geq (bin b::int vb ( 1) (bin a::int va ( 1) alpha beta) gamma) |
+ avl_geq (bin b::string vb ( 1) (bin a::string va ( 1) alpha beta) gamma) |
+ avl_geq (bin b vb ( 1) (bin a va ( 1) alpha beta) gamma)
+ = [bin a va ( 0) alpha (bin b vb ( 0) beta gamma), 1];
+
+ avl_geq (bin b::int vb ( 1) (bin a::int va ( 0) alpha beta) gamma) |
+ avl_geq (bin b::string vb ( 1) (bin a::string va ( 0) alpha beta) gamma) |
+ avl_geq (bin b vb ( 1) (bin a va ( 0) alpha beta) gamma)
+ = [bin a va (-1) alpha (bin b vb ( 1) beta gamma), 0];
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin b::int vb ( 1)
+ (bin a::int va (-1) alpha
+ (bin x::int vx b1 beta gamma)) delta) |
+ avl_geq (bin b::string vb ( 1)
+ (bin a::string va (-1) alpha
+ (bin x::string vx b1 beta gamma)) delta) |
+ avl_geq (bin b vb ( 1)
+ (bin a va (-1) alpha (bin x vx b1 beta gamma)) delta)
+ = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end;
+
+ table ( 1) = [( 0), (-1)];
+ table (-1) = [( 1), ( 0)];
+ table ( 0) = [( 0), ( 0)]
+end;
Copied: pure/trunk/lib/heap.pure (from rev 411, pure/trunk/examples/heap.pure)
===================================================================
--- pure/trunk/lib/heap.pure (rev 0)
+++ pure/trunk/lib/heap.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -0,0 +1,182 @@
+/* Pure's priority queue data structure implemented as binary trees */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure is free software: you can redistribute it and/or modify it under the
+ terms of the GNU General Public License as published by the Free Software
+ Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ Pure is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied w...
[truncated message content] |
|
From: <ag...@us...> - 2008-07-08 13:12:32
|
Revision: 423
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=423&view=rev
Author: agraef
Date: 2008-07-08 06:12:34 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Add Mersenne twister to math.pure.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/math.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
pure/trunk/test/test014.log
pure/trunk/test/test014.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-08 10:55:04 UTC (rev 422)
+++ pure/trunk/ChangeLog 2008-07-08 13:12:34 UTC (rev 423)
@@ -1,5 +1,8 @@
2008-07-08 Albert Graef <Dr....@t-...>
+ * runtime.cc/h, lib/math.pure: Add random number generator
+ (Mersenne twister). Suggested by Jiri Spitz.
+
* examples/avltree.pure: Added to examples.
* lib/math.pure: Moved abs, sgn, min, max, pred and succ from
Modified: pure/trunk/lib/math.pure
===================================================================
--- pure/trunk/lib/math.pure 2008-07-08 10:55:04 UTC (rev 422)
+++ pure/trunk/lib/math.pure 2008-07-08 13:12:34 UTC (rev 423)
@@ -22,6 +22,12 @@
def inf = 1.0e307 * 1.0e307; def nan = inf-inf;
+/* Random number generator. This uses the Mersenne twister, in order to avoid
+ bad generators present in some C libraries. Returns pseudo random ints in
+ the range -0x80000000..0x7fffffff. */
+
+extern int pure_random() = random, void pure_srandom(int) = srandom;
+
/* Rounding functions. */
extern double floor(double), double ceil(double);
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-08 10:55:04 UTC (rev 422)
+++ pure/trunk/runtime.cc 2008-07-08 13:12:34 UTC (rev 423)
@@ -1802,6 +1802,112 @@
return pure_tuplel(2, u, v);
}
+// This is the ``Mersenne Twister'' random number generator MT19937, which
+// generates pseudorandom integers uniformly distributed in 0..(2^32 - 1)
+// starting from any odd seed in 0..(2^32 - 1). This version is a recode
+// by Shawn Cokus (Co...@ma...) on March 8, 1998 of a version by
+// Takuji Nishimura (who had suggestions from Topher Cooper and Marc Rieffel in
+// July-August 1997).
+//
+// Effectiveness of the recoding (on Goedel2.math.washington.edu, a DEC Alpha
+// running OSF/1) using GCC -O3 as a compiler: before recoding: 51.6 sec. to
+// generate 300 million random numbers; after recoding: 24.0 sec. for the same
+// (i.e., 46.5% of original time), so speed is now about 12.5 million random
+// number generations per second on this machine.
+//
+// According to the URL <http://www.math.keio.ac.jp/~matumoto/emt.html>
+// (and paraphrasing a bit in places), the Mersenne Twister is ``designed
+// with consideration of the flaws of various existing generators,'' has
+// a period of 2^19937 - 1, gives a sequence that is 623-dimensionally
+// equidistributed, and ``has passed many stringent tests, including the
+// die-hard test of G. Marsaglia and the load test of P. Hellekalek and
+// S. Wegenkittl.'' It is efficient in memory usage (typically using 2506
+// to 5012 bytes of static data, depending on data type sizes, and the code
+// is quite short as well). It generates random numbers in batches of 624
+// at a time, so the caching and pipelining of modern systems is exploited.
+// It is also divide- and mod-free.
+//
+// This library is free software; you can redistribute it and/or modify it
+// under the terms of the GNU Library General Public License as published by
+// the Free Software Foundation (either version 2 of the License or, at your
+// option, any later version). This library is distributed in the hope that
+// it will be useful, but WITHOUT ANY WARRANTY, without even the implied
+// warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See
+// the GNU Library General Public License for more details. You should have
+// received a copy of the GNU Library General Public License along with this
+// library; if not, write to the Free Software Foundation, Inc., 59 Temple
+// Place, Suite 330, Boston, MA 02111-1307, USA.
+//
+// The code as Shawn received it included the following notice:
+//
+// Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. When
+// you use this, send an e-mail to <mat...@ma...> with
+// an appropriate reference to your work.
+//
+// It would be nice to CC: <Co...@ma...> when you write.
+//
+
+// See http://www.math.keio.ac.jp/~matumoto/emt.html for the original sources.
+
+#define N (624)
+#define M (397)
+#define K (0x9908B0DFU)
+#define hiBit(u) ((u) & 0x80000000U)
+#define loBit(u) ((u) & 0x00000001U)
+#define loBits(u) ((u) & 0x7FFFFFFFU)
+#define mixBits(u, v) (hiBit(u)|loBits(v))
+
+// TLD?
+static uint32_t stateMT[N+1];
+static uint32_t *nextMT;
+static int leftMT = -1;
+
+void pure_srandom(uint32_t seed)
+{
+ // MT works best with odd seeds, so we enforce that here.
+ register uint32_t x = (seed | 1U) & 0xFFFFFFFFU, *s = stateMT;
+ register int j;
+
+ for (leftMT=0, *s++=x, j=N; --j; *s++ = (x*=69069U) & 0xFFFFFFFFU);
+}
+
+static uint32_t reloadMT(void)
+{
+ register uint32_t *p0=stateMT, *p2=stateMT+2, *pM=stateMT+M, s0, s1;
+ register int j;
+
+ if (leftMT < -1)
+ pure_srandom(4357U);
+
+ leftMT=N-1, nextMT=stateMT+1;
+
+ for (s0=stateMT[0], s1=stateMT[1], j=N-M+1; --j; s0=s1, s1=*p2++)
+ *p0++ = *pM++ ^ (mixBits(s0, s1) >> 1) ^ (loBit(s1) ? K : 0U);
+
+ for (pM=stateMT, j=M; --j; s0=s1, s1=*p2++)
+ *p0++ = *pM++ ^ (mixBits(s0, s1) >> 1) ^ (loBit(s1) ? K : 0U);
+
+ s1=stateMT[0], *p0 = *pM ^ (mixBits(s0, s1) >> 1) ^ (loBit(s1) ? K : 0U);
+ s1 ^= (s1 >> 11);
+ s1 ^= (s1 << 7) & 0x9D2C5680U;
+ s1 ^= (s1 << 15) & 0xEFC60000U;
+ return(s1 ^ (s1 >> 18));
+}
+
+uint32_t pure_random(void)
+{
+ uint32_t y;
+
+ if(--leftMT < 0)
+ return reloadMT();
+
+ y = *nextMT++;
+ y ^= (y >> 11);
+ y ^= (y << 7) & 0x9D2C5680U;
+ y ^= (y << 15) & 0xEFC60000U;
+ return (y ^ (y >> 18));
+}
+
extern "C"
pure_expr *bigint_neg(mpz_t x)
{
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-07-08 10:55:04 UTC (rev 422)
+++ pure/trunk/runtime.h 2008-07-08 13:12:34 UTC (rev 423)
@@ -420,6 +420,14 @@
pure_expr *pure_rational(double d);
+/* Random number generator. This uses the Mersenne twister, in order to avoid
+ bad generators present in some C libraries. pure_random returns a
+ pseudorandom 32 bit integer, pure_srandom sets the seed of the
+ generator. */
+
+uint32_t pure_random(void);
+void pure_srandom(uint32_t seed);
+
/* Construct a "byte string" from a string. The result is a raw pointer object
pointing to the converted string. The original string is copied (and, in
the case of pure_byte_cstring, converted to the system encoding). The
Modified: pure/trunk/test/test014.log
===================================================================
--- pure/trunk/test/test014.log 2008-07-08 10:55:04 UTC (rev 422)
+++ pure/trunk/test/test014.log 2008-07-08 13:12:34 UTC (rev 423)
@@ -1,3 +1,15 @@
+drop 97 (catmap (\i/*0:*/ -> [random] {
+ rule #0: i = [random]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (1..100)) when () = srandom 0 {
+ rule #0: () = srandom 0
+ state 0: #0
+ () state 1
+ state 1: #0
+} end;
+[1863734801,-639116898,52532575]
{
rule #0: q = 44%(-14)
state 0: #0
Modified: pure/trunk/test/test014.pure
===================================================================
--- pure/trunk/test/test014.pure 2008-07-08 10:55:04 UTC (rev 422)
+++ pure/trunk/test/test014.pure 2008-07-08 13:12:34 UTC (rev 423)
@@ -1,8 +1,12 @@
+using math;
+
+// Random number generator.
+
+drop 97 [random; i=1..100] when () = srandom 0 end;
+
// Some rational arithmetic tests, pilfered from Rob Hubbard's Q+Q manual.
-using math;
-
// Basic arithmetic and pow function.
let q = 44%(-14); q;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-11 02:59:03
|
Revision: 434
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=434&view=rev
Author: agraef
Date: 2008-07-10 19:59:08 -0700 (Thu, 10 Jul 2008)
Log Message:
-----------
Apply Rooslan S. Khayrov's patches to make the interpreter compile with LLVM 2.3.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/INSTALL
pure/trunk/README
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-10 12:23:48 UTC (rev 433)
+++ pure/trunk/ChangeLog 2008-07-11 02:59:08 UTC (rev 434)
@@ -1,3 +1,13 @@
+2008-07-11 Albert Graef <Dr....@t-...>
+
+ * interpreter.cc/h: Apply Rooslan S. Khayrov's patches to make the
+ interpreter compile with LLVM 2.3.
+
+ Note that this means that Pure really needs LLVM 2.3 now. By
+ reverting these changes you can still make it work with LLVM 2.2,
+ but we really recommend using LLVM 2.3 now since it has many
+ improvements and bugfixes.
+
2008-07-08 Albert Graef <Dr....@t-...>
* runtime.cc/h, lib/math.pure: Add random number generator
Modified: pure/trunk/INSTALL
===================================================================
--- pure/trunk/INSTALL 2008-07-10 12:23:48 UTC (rev 433)
+++ pure/trunk/INSTALL 2008-07-11 02:59:08 UTC (rev 434)
@@ -48,12 +48,12 @@
bison, libgmp3c2, libgmp3-dev, readline5-dev, libltdl3, libldtl3-dev,
subversion.
-STEP 2. Get and unpack the LLVM 2.2 sources at:
-http://llvm.org/releases/download.html#2.2
+STEP 2. Get and unpack the LLVM 2.3 sources at:
+http://llvm.org/releases/download.html#2.3
STEP 3. Configure, build and install LLVM as follows:
-$ cd llvm-2.2
+$ cd llvm-2.3
$ ./configure --enable-optimized --disable-assertions --disable-expensive-checks --enable-targets=host-only
$ make
$ sudo make install
@@ -76,7 +76,7 @@
section.
STEP 5. Configure, build and install Pure as follows (x.y denotes the current
-Pure version number, 0.4 at the time of this writing):
+Pure version number, 0.5 at the time of this writing):
$ cd pure-x.y
$ ./configure
@@ -111,10 +111,10 @@
Run Pure interactively as:
$ pure
-Pure 0.4 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
+Pure 0.5 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
This program is free software distributed under the GNU Public License
(GPL V3 or later). Please see the COPYING file for details.
-Loaded prelude from /usr/local/lib/pure-0.4/prelude.pure.
+Loaded prelude from /usr/local/lib/pure-0.5/prelude.pure.
Check that it works:
@@ -371,10 +371,10 @@
-- --- -------
64 bit systems are fully supported by Pure. However, you'll need to patch up
-LLVM 2.2 so that it can be linked into the Pure runtime library on x86-64
+LLVM 2.3 so that it can be linked into the Pure runtime library on x86-64
systems. You also have to configure LLVM with --enable-pic. The patch by
-Cyrille Berger, which is to be applied in the llvm-2.2 source directory, is
-available at http://pure-lang.sf.net/X86JITInfo.cpp.pic.patch.
+Cyrille Berger, which is to be applied in the llvm-2.3 source directory, is
+available at http://pure-lang.sf.net/X86JITInfo.cpp.pic.2.3.patch.
Also, the debug build currently does *not* work on x86-64 Linux versions. This
seems to be a bug in LLVM, so there's hope that it will go away in a future
Modified: pure/trunk/README
===================================================================
--- pure/trunk/README 2008-07-10 12:23:48 UTC (rev 433)
+++ pure/trunk/README 2008-07-11 02:59:08 UTC (rev 434)
@@ -31,8 +31,9 @@
systems, the usual './configure && make && sudo make install' should do the
trick. This requires GNU make and g++. For other setups, you'll probably have
to fiddle with the Makefile and the sources. You'll also need LLVM for the
-compiler backend (version 2.2 has been tested). For your convenience,
-instructions for installing LLVM are also included in the INSTALL file.
+compiler backend (version 2.3 or later is required as of Pure 0.5). For your
+convenience, instructions for installing LLVM are also included in the INSTALL
+file.
USING PURE
----- ----
@@ -44,10 +45,10 @@
can also just type EOF a.k.a. Ctrl-D at the beginning of the interpreter's
command line). For instance:
-Pure 0.4 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
+Pure 0.5 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
This program is free software distributed under the GNU Public License
(GPL V3 or later). Please see the COPYING file for details.
-Loaded prelude from /usr/local/lib/pure-0.4/prelude.pure.
+Loaded prelude from /usr/local/lib/pure-0.5/prelude.pure.
> fact n = if n>0 then n*fact (n-1) else 1;
> map fact (1..10);
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-07-10 12:23:48 UTC (rev 433)
+++ pure/trunk/interpreter.cc 2008-07-11 02:59:08 UTC (rev 434)
@@ -8,6 +8,7 @@
#include <glob.h>
#include <llvm/CallingConv.h>
+#include <llvm/PassManager.h>
#include <llvm/System/DynamicLibrary.h>
#include <llvm/Transforms/Utils/BasicBlockUtils.h>
@@ -1805,7 +1806,7 @@
// Code generation.
-#define Dbl(d) ConstantFP::get(Type::DoubleTy, APFloat(d))
+#define Dbl(d) ConstantFP::get(Type::DoubleTy, d)
#define Bool(i) ConstantInt::get(Type::Int1Ty, i)
#define UInt(i) ConstantInt::get(Type::Int32Ty, i)
#define SInt(i) ConstantInt::get(Type::Int32Ty, (uint64_t)i, true)
@@ -2045,7 +2046,7 @@
// We must garbage-collect args and environment here, immediately before the
// call (if any), or the return instruction otherwise.
if (pi != ret && n == 1 && m == 0)
- new CallInst(free1_fun, "", pi);
+ CallInst::Create(free1_fun, "", pi);
else if (n+m != 0) {
vector<Value*> myargs;
if (pi == ret)
@@ -2054,10 +2055,10 @@
myargs.push_back(ConstantPointerNull::get(interp.ExprPtrTy));
myargs.push_back(UInt(n));
myargs.push_back(UInt(m));
- new CallInst(free_fun, myargs.begin(), myargs.end(), "", pi);
+ CallInst::Create(free_fun, myargs.begin(), myargs.end(), "", pi);
if (pi == ret) {
Value *x[1] = { v };
- new CallInst(interp.module->getFunction("pure_unref"), x, x+1, "", ret);
+ CallInst::Create(interp.module->getFunction("pure_unref"), x, x+1, "", ret);
}
}
return ret;
@@ -2549,7 +2550,7 @@
}
// The function declaration hasn't been assembled yet. Do it now.
FunctionType *ft = FunctionType::get(type, argt, varargs);
- f = new Function(ft, Function::ExternalLinkage, name, module);
+ f = Function::Create(ft, Function::ExternalLinkage, name, module);
// Enter a fixed association into the dynamic linker table. This ensures
// that even if the runtime functions can't be resolved via dlopening
// the interpreter executable (e.g., if the interpreter was linked
@@ -2643,7 +2644,7 @@
// entered into the externals table.
if (!g) {
gt = ft;
- g = new Function(gt, Function::ExternalLinkage, name, module);
+ g = Function::Create(gt, Function::ExternalLinkage, name, module);
Function::arg_iterator a = g->arg_begin();
for (size_t i = 0; a != g->arg_end(); ++a, ++i)
a->setName(mklabel("arg", i));
@@ -2659,7 +2660,7 @@
// programs).
vector<const Type*> argt2(n, ExprPtrTy);
FunctionType *ft2 = FunctionType::get(ExprPtrTy, argt2, false);
- Function *f = new Function(ft2, Function::InternalLinkage,
+ Function *f = Function::Create(ft2, Function::InternalLinkage,
"$$wrap."+asname, module);
vector<Value*> args(n), unboxed(n);
Function::arg_iterator a = f->arg_begin();
@@ -2667,15 +2668,15 @@
a->setName(mklabel("arg", i)); args[i] = a;
}
Builder b;
- BasicBlock *bb = new BasicBlock("entry", f),
- *failedbb = new BasicBlock("failed");
+ BasicBlock *bb = BasicBlock::Create("entry", f),
+ *failedbb = BasicBlock::Create("failed");
b.SetInsertPoint(bb);
// unbox arguments
bool temps = false;
for (size_t i = 0; i < n; i++) {
Value *x = args[i];
if (argt[i] == Type::Int1Ty) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2687,7 +2688,7 @@
Value *iv = b.CreateLoad(b.CreateGEP(pv, idx, idx+2), "intval");
unboxed[i] = b.CreateICmpNE(iv, Zero);
} else if (argt[i] == Type::Int8Ty) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2699,7 +2700,7 @@
Value *iv = b.CreateLoad(b.CreateGEP(pv, idx, idx+2), "intval");
unboxed[i] = b.CreateTrunc(iv, Type::Int8Ty);
} else if (argt[i] == Type::Int16Ty) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2711,7 +2712,7 @@
Value *iv = b.CreateLoad(b.CreateGEP(pv, idx, idx+2), "intval");
unboxed[i] = b.CreateTrunc(iv, Type::Int16Ty);
} else if (argt[i] == Type::Int32Ty) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2723,9 +2724,9 @@
Value *iv = b.CreateLoad(b.CreateGEP(pv, idx, idx+2), "intval");
unboxed[i] = iv;
} else if (argt[i] == Type::Int64Ty) {
- BasicBlock *intbb = new BasicBlock("int");
- BasicBlock *mpzbb = new BasicBlock("mpz");
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *intbb = BasicBlock::Create("int");
+ BasicBlock *mpzbb = BasicBlock::Create("mpz");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
SwitchInst *sw = b.CreateSwitch(tagv, failedbb, 2);
@@ -2751,7 +2752,7 @@
phi->addIncoming(mpzv, mpzbb);
unboxed[i] = phi;
} else if (argt[i] == Type::DoubleTy) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2763,7 +2764,7 @@
Value *dv = b.CreateLoad(b.CreateGEP(pv, idx, idx+2), "dblval");
unboxed[i] = dv;
} else if (argt[i] == CharPtrTy) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2776,7 +2777,7 @@
argt[i] == PointerType::get(Type::Int32Ty, 0) ||
argt[i] == PointerType::get(Type::Int64Ty, 0) ||
argt[i] == PointerType::get(Type::DoubleTy, 0)) {
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
b.CreateCondBr
@@ -2791,9 +2792,9 @@
// passed through
unboxed[i] = x;
} else if (argt[i] == VoidPtrTy) {
- BasicBlock *ptrbb = new BasicBlock("ptr");
- BasicBlock *mpzbb = new BasicBlock("mpz");
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *ptrbb = BasicBlock::Create("ptr");
+ BasicBlock *mpzbb = BasicBlock::Create("mpz");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
SwitchInst *sw = b.CreateSwitch(tagv, failedbb, 3);
@@ -2867,7 +2868,7 @@
b.CreateBitCast(u, VoidPtrTy));
else if (type == ExprPtrTy) {
// check that we actually got a valid pointer; otherwise the call failed
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
b.CreateCondBr
(b.CreateICmpNE(u, NullExprPtr, "cmp"), okbb, failedbb);
f->getBasicBlockList().push_back(okbb);
@@ -3009,8 +3010,8 @@
// compute the matchee
Value *arg = codegen(rhs);
// emit the matching code
- BasicBlock *matchedbb = new BasicBlock("matched");
- BasicBlock *failedbb = new BasicBlock("failed");
+ BasicBlock *matchedbb = BasicBlock::Create("matched");
+ BasicBlock *failedbb = BasicBlock::Create("failed");
matcher m(rule(lhs, rhs));
if (verbose&verbosity::code) std::cout << m << endl;
state *start = m.start;
@@ -3104,9 +3105,9 @@
Env& e = act.act_fmap()[-y.hash()];
push("when", &e);
fun_prolog("anonymous");
- BasicBlock *bodybb = new BasicBlock("body");
- BasicBlock *matchedbb = new BasicBlock("matched");
- BasicBlock *failedbb = new BasicBlock("failed");
+ BasicBlock *bodybb = BasicBlock::Create("body");
+ BasicBlock *matchedbb = BasicBlock::Create("matched");
+ BasicBlock *failedbb = BasicBlock::Create("failed");
e.builder.CreateBr(bodybb);
e.f->getBasicBlockList().push_back(bodybb);
e.builder.SetInsertPoint(bodybb);
@@ -3282,8 +3283,8 @@
Env& e = act_env();
Value *condv = b.CreateICmpNE(u, Zero, "cond");
BasicBlock *iftruebb = b.GetInsertBlock();
- BasicBlock *iffalsebb = new BasicBlock("iffalse");
- BasicBlock *endbb = new BasicBlock("end");
+ BasicBlock *iffalsebb = BasicBlock::Create("iffalse");
+ BasicBlock *endbb = BasicBlock::Create("end");
b.CreateCondBr(condv, endbb, iffalsebb);
e.f->getBasicBlockList().push_back(iffalsebb);
b.SetInsertPoint(iffalsebb);
@@ -3310,8 +3311,8 @@
Env& e = act_env();
Value *condv = b.CreateICmpNE(u, Zero, "cond");
BasicBlock *iffalsebb = b.GetInsertBlock();
- BasicBlock *iftruebb = new BasicBlock("iftrue");
- BasicBlock *endbb = new BasicBlock("end");
+ BasicBlock *iftruebb = BasicBlock::Create("iftrue");
+ BasicBlock *endbb = BasicBlock::Create("end");
b.CreateCondBr(condv, iftruebb, endbb);
e.f->getBasicBlockList().push_back(iftruebb);
b.SetInsertPoint(iftruebb);
@@ -3351,9 +3352,9 @@
return b.CreateAnd(u, v);
else if (f.ftag() == symtab.shl_sym().f) {
// result of shl is undefined if u>=#bits, return 0 in that case
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
BasicBlock *zerobb = b.GetInsertBlock();
- BasicBlock *endbb = new BasicBlock("end");
+ BasicBlock *endbb = BasicBlock::Create("end");
Value *cmp = b.CreateICmpULT(v, UInt(32));
b.CreateCondBr(cmp, okbb, endbb);
act_env().f->getBasicBlockList().push_back(okbb);
@@ -3584,8 +3585,8 @@
if (f.ftag() == symtab.or_sym().f) {
Value *u = get_int(x.xval1().xval2());
Value *condv = b.CreateICmpNE(u, Zero, "cond");
- BasicBlock *iftruebb = new BasicBlock("iftrue");
- BasicBlock *iffalsebb = new BasicBlock("iffalse");
+ BasicBlock *iftruebb = BasicBlock::Create("iftrue");
+ BasicBlock *iffalsebb = BasicBlock::Create("iffalse");
b.CreateCondBr(condv, iftruebb, iffalsebb);
e.f->getBasicBlockList().push_back(iftruebb);
b.SetInsertPoint(iftruebb);
@@ -3596,8 +3597,8 @@
} else if (f.ftag() == symtab.and_sym().f) {
Value *u = get_int(x.xval1().xval2());
Value *condv = b.CreateICmpNE(u, Zero, "cond");
- BasicBlock *iftruebb = new BasicBlock("iftrue");
- BasicBlock *iffalsebb = new BasicBlock("iffalse");
+ BasicBlock *iftruebb = BasicBlock::Create("iftrue");
+ BasicBlock *iffalsebb = BasicBlock::Create("iffalse");
b.CreateCondBr(condv, iftruebb, iffalsebb);
e.f->getBasicBlockList().push_back(iffalsebb);
b.SetInsertPoint(iffalsebb);
@@ -3880,9 +3881,9 @@
// emit the condition (turn the previous result into a flag)
Value *condv = f.builder.CreateICmpNE(iv, Zero, "cond");
// create the basic blocks for the branches
- BasicBlock *thenbb = new BasicBlock("then");
- BasicBlock *elsebb = new BasicBlock("else");
- BasicBlock *endbb = new BasicBlock("end");
+ BasicBlock *thenbb = BasicBlock::Create("then");
+ BasicBlock *elsebb = BasicBlock::Create("else");
+ BasicBlock *endbb = BasicBlock::Create("end");
// create the branch instruction and emit the 'then' block
f.builder.CreateCondBr(condv, thenbb, elsebb);
f.f->getBasicBlockList().push_back(thenbb);
@@ -3928,8 +3929,8 @@
// emit the condition (turn the previous result into a flag)
Value *condv = f.builder.CreateICmpNE(iv, Zero, "cond");
// create the basic blocks for the branches
- BasicBlock *thenbb = new BasicBlock("then");
- BasicBlock *elsebb = new BasicBlock("else");
+ BasicBlock *thenbb = BasicBlock::Create("then");
+ BasicBlock *elsebb = BasicBlock::Create("else");
// create the branch instruction and emit the 'then' block
f.builder.CreateCondBr(condv, thenbb, elsebb);
f.f->getBasicBlockList().push_back(thenbb);
@@ -4425,14 +4426,14 @@
if (have_c_func) pure_name = "$$pure."+name;
if (cc == CallingConv::Fast) {
// create the function
- f.f = new Function(ft, Function::InternalLinkage,
+ f.f = Function::Create(ft, Function::InternalLinkage,
"$$fastcc."+name, module);
assert(f.f); f.f->setCallingConv(cc);
// create the C-callable stub
- f.h = new Function(ft, scope, pure_name, module); assert(f.h);
+ f.h = Function::Create(ft, scope, pure_name, module); assert(f.h);
} else {
// no need for a separate stub
- f.f = new Function(ft, scope, pure_name, module); assert(f.f);
+ f.f = Function::Create(ft, scope, pure_name, module); assert(f.f);
f.h = f.f;
}
/* Give names to the arguments, and provide direct access to these by
@@ -4455,7 +4456,7 @@
}
/* Create the body of the stub. This is just a call to the internal
function, passing through all arguments including the environment. */
- BasicBlock *bb = new BasicBlock("entry", f.h);
+ BasicBlock *bb = BasicBlock::Create("entry", f.h);
f.builder.SetInsertPoint(bb);
CallInst* v = f.builder.CreateCall(f.f, myargs.begin(), myargs.end());
v->setCallingConv(cc);
@@ -4473,7 +4474,7 @@
llvm::cerr << "PROLOG FUNCTION " << f.name << endl;
#endif
// create a new basic block to start insertion into
- BasicBlock *bb = new BasicBlock("entry", f.f);
+ BasicBlock *bb = BasicBlock::Create("entry", f.f);
f.builder.SetInsertPoint(bb);
#if DEBUG>1
if (!f.name.empty()) { ostringstream msg;
@@ -4491,7 +4492,7 @@
#if DEBUG>1
llvm::cerr << "BODY FUNCTION " << f.name << endl;
#endif
- BasicBlock *bodybb = new BasicBlock("body");
+ BasicBlock *bodybb = BasicBlock::Create("body");
f.builder.CreateBr(bodybb);
f.f->getBasicBlockList().push_back(bodybb);
f.builder.SetInsertPoint(bodybb);
@@ -4500,7 +4501,7 @@
msg << "body " << f.name;
debug(msg.str().c_str()); }
#endif
- BasicBlock *failedbb = new BasicBlock("failed");
+ BasicBlock *failedbb = BasicBlock::Create("failed");
// emit the matching code
complex_match(pm, failedbb);
// emit code for a failed match
@@ -4570,8 +4571,8 @@
// throw an exception if v == false
Env& f = act_env();
assert(f.f!=0);
- BasicBlock *errbb = new BasicBlock("err");
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *errbb = BasicBlock::Create("err");
+ BasicBlock *okbb = BasicBlock::Create("ok");
f.builder.CreateCondBr(v, okbb, errbb);
f.f->getBasicBlockList().push_back(errbb);
f.builder.SetInsertPoint(errbb);
@@ -4585,8 +4586,8 @@
// throw an exception if v == true
Env& f = act_env();
assert(f.f!=0);
- BasicBlock *errbb = new BasicBlock("err");
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *errbb = BasicBlock::Create("err");
+ BasicBlock *okbb = BasicBlock::Create("ok");
f.builder.CreateCondBr(v, errbb, okbb);
f.f->getBasicBlockList().push_back(errbb);
f.builder.SetInsertPoint(errbb);
@@ -4650,7 +4651,7 @@
case EXPR::INT:
case EXPR::DBL: {
// first check the tag
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
f.builder.CreateCondBr
(f.builder.CreateICmpEQ(tagv, SInt(t.tag), "cmp"), okbb, failedbb);
@@ -4675,7 +4676,7 @@
case EXPR::STR: {
// first do a quick check on the tag so that we may avoid an expensive
// call if the tags don't match
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
f.builder.CreateCondBr
(f.builder.CreateICmpEQ(tagv, SInt(t.tag), "cmp"), okbb, failedbb);
@@ -4698,8 +4699,8 @@
break;
case EXPR::APP: {
// first match the tag...
- BasicBlock *ok1bb = new BasicBlock("arg1");
- BasicBlock *ok2bb = new BasicBlock("arg2");
+ BasicBlock *ok1bb = BasicBlock::Create("arg1");
+ BasicBlock *ok2bb = BasicBlock::Create("arg2");
Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
f.builder.CreateCondBr
(f.builder.CreateICmpEQ(tagv, SInt(t.tag)), ok1bb, failedbb);
@@ -4748,7 +4749,7 @@
if (f.n == 1 && f.b && pm->r.size() == 1 && pm->r[0].qual.is_null()) {
Value *arg = f.args[0];
// emit the matching code
- BasicBlock *matchedbb = new BasicBlock("matched");
+ BasicBlock *matchedbb = BasicBlock::Create("matched");
state *start = pm->start;
simple_match(arg, start, matchedbb, failedbb);
// matched => emit code for the reduct, and return the result
@@ -4840,7 +4841,7 @@
assert(x->getType() == ExprPtrTy);
// start a new block for this state (this is just for purposes of
// readability, we don't actually need this as a label to branch to)
- BasicBlock *statebb = new BasicBlock(mklabel("state", s->s));
+ BasicBlock *statebb = BasicBlock::Create(mklabel("state", s->s));
f.builder.CreateBr(statebb);
f.f->getBasicBlockList().push_back(statebb);
f.builder.SetInsertPoint(statebb);
@@ -4850,8 +4851,8 @@
debug(msg.str().c_str()); }
#endif
// blocks for retrying with default transitions after a failed match
- BasicBlock *retrybb = new BasicBlock(mklabel("retry.state", s->s));
- BasicBlock *defaultbb = new BasicBlock(mklabel("default.state", s->s));
+ BasicBlock *retrybb = BasicBlock::Create(mklabel("retry.state", s->s));
+ BasicBlock *defaultbb = BasicBlock::Create(mklabel("default.state", s->s));
// first check for a literal match
size_t i, n = s->tr.size(), m = 0;
transl::iterator t0 = s->tr.begin();
@@ -4872,7 +4873,7 @@
transl::iterator t;
for (t = t0, i = 0; t != s->tr.end(); t++, i++) {
// first create the block for this specific transition
- BasicBlock *bb = new BasicBlock(mklabel("trans.state", s->s, t->st->s));
+ BasicBlock *bb = BasicBlock::Create(mklabel("trans.state", s->s, t->st->s));
if (t->tag == EXPR::APP || t->tag > 0) {
// transition on a function symbol; in this case there's only a single
// transition, to which we simply assign the label just generated
@@ -4887,7 +4888,7 @@
// no outer label has been generated yet, do it now and add the
// target to the outer switch
tmap[t->tag].bb =
- new BasicBlock(mklabel("begin.state", s->s, -t->tag));
+ BasicBlock::Create(mklabel("begin.state", s->s, -t->tag));
sw->addCase(SInt(t->tag), tmap[t->tag].bb);
}
}
@@ -4916,7 +4917,7 @@
list<trans_info>::iterator k = l; k++;
BasicBlock *okbb = l->bb;
BasicBlock *trynextbb =
- new BasicBlock(mklabel("next.state", s->s, -tag));
+ BasicBlock::Create(mklabel("next.state", s->s, -tag));
switch (tag) {
case EXPR::INT:
case EXPR::DBL: {
@@ -4984,7 +4985,7 @@
transl::iterator t;
for (t = t1, i = 0; t != s->tr.end() && t->tag == EXPR::VAR; t++, i++) {
vtransbb.push_back
- (new BasicBlock(mklabel("trans.state", s->s, t->st->s)));
+ (BasicBlock::Create(mklabel("trans.state", s->s, t->st->s)));
sw->addCase(SInt(t->ttag), vtransbb[i]);
}
// now handle the transitions on the different type tags
@@ -5021,7 +5022,7 @@
ruleml::const_iterator r = rl.begin();
assert(r != rl.end());
assert(f.fmap_idx == 0);
- BasicBlock* rulebb = new BasicBlock(mklabel("rule.state", s->s, rl.front()));
+ BasicBlock* rulebb = BasicBlock::Create(mklabel("rule.state", s->s, rl.front()));
f.builder.CreateBr(rulebb);
while (r != rl.end()) {
const rule& rr = rules[*r];
@@ -5064,11 +5065,11 @@
iv = get_int(rr.qual);
// emit the condition (turn the previous result into a flag)
Value *condv = f.builder.CreateICmpNE(iv, Zero, "cond");
- BasicBlock *okbb = new BasicBlock("ok");
+ BasicBlock *okbb = BasicBlock::Create("ok");
// determine the next rule block ('failed' if none)
BasicBlock *nextbb;
if (++r != rl.end())
- nextbb = new BasicBlock(mklabel("rule.state", s->s, *r));
+ nextbb = BasicBlock::Create(mklabel("rule.state", s->s, *r));
else
nextbb = failedbb;
f.builder.CreateCondBr(condv, okbb, nextbb);
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-07-10 12:23:48 UTC (rev 433)
+++ pure/trunk/interpreter.hh 2008-07-11 02:59:08 UTC (rev 434)
@@ -9,7 +9,7 @@
#include <llvm/Analysis/Verifier.h>
#include <llvm/Target/TargetData.h>
#include <llvm/Transforms/Scalar.h>
-#include <llvm/Support/LLVMBuilder.h>
+#include <llvm/Support/IRBuilder.h>
#include <time.h>
#include <set>
@@ -83,7 +83,7 @@
};
//#define Builder llvm::LLVMBuilder
-#define Builder llvm::LLVMFoldingBuilder
+#define Builder llvm::IRBuilder
typedef list<Env*> EnvStack;
typedef pair<int32_t,uint8_t> xmap_key;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-12 23:16:32
|
Revision: 436
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=436&view=rev
Author: agraef
Date: 2008-07-12 16:16:41 -0700 (Sat, 12 Jul 2008)
Log Message:
-----------
LLVM 2.3 requires that we add the default shared library extension manually.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/config.h.in
pure/trunk/configure
pure/trunk/configure.ac
pure/trunk/interpreter.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-11 21:28:39 UTC (rev 435)
+++ pure/trunk/ChangeLog 2008-07-12 23:16:41 UTC (rev 436)
@@ -1,3 +1,8 @@
+2008-07-13 Albert Graef <Dr....@t-...>
+
+ * interpreter.cc (run): LLVM 2.3 requires that we add the default
+ shared library extension manually.
+
2008-07-11 Albert Graef <Dr....@t-...>
* interpreter.cc/h: Apply Rooslan S. Khayrov's patches to make the
Modified: pure/trunk/config.h.in
===================================================================
--- pure/trunk/config.h.in 2008-07-11 21:28:39 UTC (rev 435)
+++ pure/trunk/config.h.in 2008-07-12 23:16:41 UTC (rev 436)
@@ -8,6 +8,9 @@
/* Define to 1 if using `alloca.c'. */
#undef C_ALLOCA
+/* Define to the filename extension for shared libraries. */
+#undef DLLEXT
+
/* Define to 1 if you have `alloca', as a function or macro. */
#undef HAVE_ALLOCA
Modified: pure/trunk/configure
===================================================================
--- pure/trunk/configure 2008-07-11 21:28:39 UTC (rev 435)
+++ pure/trunk/configure 2008-07-12 23:16:41 UTC (rev 436)
@@ -1866,6 +1866,11 @@
+
+cat >>confdefs.h <<_ACEOF
+#define DLLEXT "${DLLEXT}"
+_ACEOF
+
# Find a good install program. We prefer a C program (faster),
# so one script is as good as another. But avoid the broken or
# incompatible versions:
Modified: pure/trunk/configure.ac
===================================================================
--- pure/trunk/configure.ac 2008-07-11 21:28:39 UTC (rev 435)
+++ pure/trunk/configure.ac 2008-07-12 23:16:41 UTC (rev 436)
@@ -34,6 +34,7 @@
AC_SUBST(PIC)
AC_SUBST(DLLEXT)
AC_SUBST(AUXLIBS)
+AC_DEFINE_UNQUOTED(DLLEXT, "${DLLEXT}", [Define to the filename extension for shared libraries.])
dnl Check for programs.
AC_PROG_INSTALL
AC_PROG_CXX
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-07-11 21:28:39 UTC (rev 435)
+++ pure/trunk/interpreter.cc 2008-07-12 23:16:41 UTC (rev 436)
@@ -379,15 +379,28 @@
// Run the interpreter on a source file, collection of source files, or on
// string data.
+#ifndef DLLEXT
+#define DLLEXT ".so"
+#endif
+
pure_expr* interpreter::run(const string &s, bool check)
{
// check for library modules
size_t p = s.find(":");
if (p != string::npos && s.substr(0, p) == "lib") {
if (p+1 >= s.size()) throw err("empty lib name");
- string name = s.substr(p+1), msg;
- if (llvm::sys::DynamicLibrary::LoadLibraryPermanently(name.c_str(), &msg))
+ string msg, name = s.substr(p+1), dllname = name;
+ // See whether we need to add the DLLEXT suffix.
+ if (name.substr(name.size()-strlen(DLLEXT)) != DLLEXT)
+ dllname += DLLEXT;
+ // First try to open the library under the given name.
+ if (!llvm::sys::DynamicLibrary::LoadLibraryPermanently(name.c_str(), &msg))
+ return 0;
+ else if (dllname == name)
throw err(msg);
+ // Now try the name with DLLEXT added.
+ else if (llvm::sys::DynamicLibrary::LoadLibraryPermanently(dllname.c_str(), &msg))
+ throw err(msg);
return 0;
}
// ordinary source file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-13 10:25:08
|
Revision: 437
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=437&view=rev
Author: agraef
Date: 2008-07-13 03:25:17 -0700 (Sun, 13 Jul 2008)
Log Message:
-----------
Streamline code for list and tuple expressions.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/expr.cc
pure/trunk/expr.hh
pure/trunk/interpreter.cc
pure/trunk/printer.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-12 23:16:41 UTC (rev 436)
+++ pure/trunk/ChangeLog 2008-07-13 10:25:17 UTC (rev 437)
@@ -1,5 +1,9 @@
2008-07-13 Albert Graef <Dr....@t-...>
+ * interpreter.cc (codegen): Streamline code for list and tuple
+ expressions. This works around some severe performance bugs in the
+ LLVM JIT, which gets awfully slow on deep call graphs.
+
* interpreter.cc (run): LLVM 2.3 requires that we add the default
shared library extension manually.
Modified: pure/trunk/expr.cc
===================================================================
--- pure/trunk/expr.cc 2008-07-12 23:16:41 UTC (rev 436)
+++ pure/trunk/expr.cc 2008-07-13 10:25:17 UTC (rev 437)
@@ -170,11 +170,20 @@
{
expr x, y;
if (is_cons(x, y))
- return !x.is_pair() && y.is_list();
+ return y.is_listx();
else
return is_nil();
}
+bool expr::is_listx() const
+{
+ expr x, y;
+ if (is_cons(x, y))
+ return !x.is_pair() && y.is_listx();
+ else
+ return is_nil();
+}
+
bool expr::is_voidx() const
{
return tag() == interpreter::g_interp->symtab.void_sym().f;
@@ -198,14 +207,33 @@
{
expr x, y;
if (is_cons(x, y)) {
- if (x.is_pair())
+ xs.push_back(x);
+ return y.is_listx(xs);
+ } else if (is_nil())
+ return true;
+ else {
+ xs.clear();
+ return false;
+ }
+}
+
+bool expr::is_listx(exprl &xs) const
+{
+ expr x, y;
+ if (is_cons(x, y)) {
+ if (x.is_pair()) {
+ xs.clear();
return false;
- else {
+ } else {
xs.push_back(x);
- return y.is_list(xs);
+ return y.is_listx(xs);
}
- } else
- return is_nil();
+ } else if (is_nil())
+ return true;
+ else {
+ xs.clear();
+ return false;
+ }
}
bool expr::is_pair(expr &x, expr &y) const
Modified: pure/trunk/expr.hh
===================================================================
--- pure/trunk/expr.hh 2008-07-12 23:16:41 UTC (rev 436)
+++ pure/trunk/expr.hh 2008-07-13 10:25:17 UTC (rev 437)
@@ -460,6 +460,9 @@
bool is_nil() const;
bool is_cons() const;
bool is_list() const;
+ // Check for lists which don't contain tuple elements, so that they can be
+ // printed in standard list format.
+ bool is_listx() const;
bool is_voidx() const;
bool is_pair() const;
// This is always true, as we consider a singleton as a tuple, too. Use
@@ -467,6 +470,7 @@
bool is_tuple() const { return true; }
bool is_cons(expr &x, expr &y) const;
bool is_list(exprl &xs) const;
+ bool is_listx(exprl &xs) const;
bool is_pair(expr &x, expr &y) const;
// Always true (see note above). Use is_pair() && istuple(xs) to test for a
// "real" tuple instead.
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-07-12 23:16:41 UTC (rev 436)
+++ pure/trunk/interpreter.cc 2008-07-13 10:25:17 UTC (rev 437)
@@ -238,6 +238,12 @@
"pure_pointer", "expr*", 1, "void*");
declare_extern((void*)pure_apply,
"pure_apply", "expr*", 2, "expr*", "expr*");
+
+ declare_extern((void*)pure_listl,
+ "pure_listl", "expr*", -1, "int");
+ declare_extern((void*)pure_tuplel,
+ "pure_tuplel", "expr*", -1, "int");
+
declare_extern((void*)pure_cmp_bigint,
"pure_cmp_bigint", "int", 3, "expr*", "int",
sizeof(mp_limb_t)==8?"long*":"int*");
@@ -3672,6 +3678,7 @@
interactive session. */
expr f; uint32_t n = count_args(x, f);
Value *v; Env *e;
+ exprl xs;
if (f.tag() == EXPR::FVAR && (v = funcall(f.vtag(), f.vidx(), n, x)))
// local function call
return v;
@@ -3701,6 +3708,21 @@
argv.push_back(body);
act_env().CreateCall(module->getFunction("pure_new_args"), argv);
return call("pure_catch", handler, body);
+ } else if (x.is_list(xs) || x.is_pair() && x.is_tuple(xs)) {
+ // optimize the case of proper lists and tuples
+ size_t i = 0, n = xs.size();
+ vector<Value*> argv(n+1);
+ argv[0] = UInt(n);
+ for (exprl::iterator it = xs.begin(), end = xs.end(); it != end; it++)
+ argv[++i] = codegen(*it);
+ act_env().CreateCall(module->getFunction("pure_new_args"), argv);
+ return act_env().CreateCall
+ (module->getFunction(x.is_pair()?"pure_tuplel":"pure_listl"), argv);
+ vector<Value*> argv1;
+ argv1.push_back(NullExprPtr);
+ argv1.insert(argv1.end(), argv.begin(), argv.end());
+ act_env().CreateCall(module->getFunction("pure_free_args"), argv1);
+ return v;
} else {
// ordinary function application
Value *u = codegen(x.xval1()), *v = codegen(x.xval2());
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-07-12 23:16:41 UTC (rev 436)
+++ pure/trunk/printer.cc 2008-07-13 10:25:17 UTC (rev 437)
@@ -84,7 +84,7 @@
case EXPR::APP: {
expr u, v, w;
prec_t p;
- if (x.is_list())
+ if (x.is_listx())
return 100;
else if (x.is_app(u, v))
if (u.tag() > 0 && (p = sym_nprec(u.tag())) < 100 && p%10 >= 3)
@@ -248,7 +248,7 @@
expr u, v, w, y;
exprl xs;
prec_t p;
- if (x.is_list(xs)) {
+ if (x.is_listx(xs)) {
// proper list value
size_t n = xs.size();
os << "[";
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X