pure-lang-svn Mailing List for Pure (Page 18)
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
pure-lang-svn — SVN commits.
You can subscribe to this list here.
| 2008 |
Jan
|
Feb
|
Mar
|
Apr
(5) |
May
(141) |
Jun
(184) |
Jul
(97) |
Aug
(232) |
Sep
(196) |
Oct
|
Nov
|
Dec
|
|---|
|
From: <ag...@us...> - 2008-08-04 06:50:13
|
Revision: 445
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=445&view=rev
Author: agraef
Date: 2008-08-04 06:50:23 +0000 (Mon, 04 Aug 2008)
Log Message:
-----------
Move fmap size check into FMap class.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-08-04 06:36:13 UTC (rev 444)
+++ pure/trunk/interpreter.cc 2008-08-04 06:50:23 UTC (rev 445)
@@ -5060,7 +5060,7 @@
while (r != rl.end()) {
const rule& rr = rules[*r];
reduced.insert(*r);
- if (f.fmap.size() > 1) f.fmap.set(*r);
+ f.fmap.set(*r);
f.f->getBasicBlockList().push_back(rulebb);
f.builder.SetInsertPoint(rulebb);
#if DEBUG>1
@@ -5118,5 +5118,5 @@
toplevel_codegen(rr.rhs);
rulebb = nextbb;
}
- if (f.fmap.size() > 1) f.fmap.first();
+ f.fmap.first();
}
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-08-04 06:36:13 UTC (rev 444)
+++ pure/trunk/interpreter.hh 2008-08-04 06:50:23 UTC (rev 445)
@@ -102,12 +102,10 @@
void clear() { m.clear(); idx = 0; }
// resize (set number of maps)
void resize(size_t n) { m.resize(n); }
- // current size (number of maps)
- size_t size() const { return m.size(); }
// set index to first, next and given map
void first() { idx = 0; }
void next() { idx++; }
- void set(size_t n) { idx = n; }
+ void set(size_t n) { if (m.size() > 1) idx = n; }
// access the current map
map<int32_t,Env>& act() { return m[idx]; }
};
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-04 06:36:03
|
Revision: 444
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=444&view=rev
Author: agraef
Date: 2008-08-04 06:36:13 +0000 (Mon, 04 Aug 2008)
Log Message:
-----------
Refactoring of FMap/Env printing code.
Modified Paths:
--------------
pure/trunk/interpreter.hh
pure/trunk/lexer.ll
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-08-02 07:07:44 UTC (rev 443)
+++ pure/trunk/interpreter.hh 2008-08-04 06:36:13 UTC (rev 444)
@@ -88,31 +88,28 @@
typedef list<Env*> EnvStack;
typedef pair<int32_t,uint8_t> xmap_key;
-class FMap {
+struct FMap {
// manage local function environments
- vector< map<int32_t,Env> > fmap;
+ vector< map<int32_t,Env> > m;
// current map index
size_t idx;
-public:
// constructor (create one empty map by default)
- FMap() : fmap(1), idx(0) {}
+ FMap() : m(1), idx(0) {}
// assignment
FMap& operator= (const FMap& f)
- { fmap = f.fmap; idx = f.idx; return *this; }
+ { m = f.m; idx = f.idx; return *this; }
// clear local environments
- void clear() { fmap.clear(); idx = 0; }
+ void clear() { m.clear(); idx = 0; }
// resize (set number of maps)
- void resize(size_t n) { fmap.resize(n); }
+ void resize(size_t n) { m.resize(n); }
// current size (number of maps)
- size_t size() const { return fmap.size(); }
+ size_t size() const { return m.size(); }
// set index to first, next and given map
void first() { idx = 0; }
void next() { idx++; }
void set(size_t n) { idx = n; }
// access the current map
- map<int32_t,Env>& act() { return fmap[idx]; }
- // access the given map (read-only)
- const map<int32_t,Env>& act(size_t n) const { return fmap[n]; }
+ map<int32_t,Env>& act() { return m[idx]; }
};
struct Env {
@@ -180,6 +177,8 @@
// interface to CreateRet() which also takes care of collecting temporaries
// and patching up tail calls
llvm::ReturnInst *CreateRet(llvm::Value *v);
+ // print the code of all functions in an environment, recursively
+ void print_defs(ostream& os) const;
// default constructor
Env()
: tag(0), n(0), m(0), f(0), h(0), fp(0), args(0), envs(0),
@@ -580,7 +579,6 @@
// Interface to the lexer.
public:
bool declare_op;
- void print_defs(ostream& os, const Env& e);
private:
bool lex_begin();
void lex_end();
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-08-02 07:07:44 UTC (rev 443)
+++ pure/trunk/lexer.ll 2008-08-04 06:36:13 UTC (rev 444)
@@ -543,7 +543,7 @@
sout << " " << rules << ";";
if (aflag && m) sout << endl << *m;
if (dflag && fenv != interp.globalfuns.end() && fenv->second.f)
- interp.print_defs(sout, fenv->second);
+ fenv->second.print_defs(sout);
} else {
sout << " " << argc << " args, " << rules.size() << " rules";
}
@@ -560,7 +560,7 @@
if (n > 0) {
if (aflag && m) sout << *m << endl;
if (dflag && fenv != interp.globalfuns.end() && fenv->second.f)
- interp.print_defs(sout, fenv->second);
+ fenv->second.print_defs(sout);
nrules += n;
++nfuns;
}
@@ -936,14 +936,14 @@
result = k;
}
-void interpreter::print_defs(ostream& os, const Env& e)
+void Env::print_defs(ostream& os) const
{
- if (!e.f) return; // not used, probably a shadowed rule
- if (e.h && e.h != e.f) e.h->print(os);
- e.f->print(os);
- for (size_t i = 0, n = e.fmap.size(); i < n; i++) {
- for (map<int32_t,Env>::const_iterator f = e.fmap.act(i).begin(),
- end = e.fmap.act(i).end(); f != end; f++)
- print_defs(os, f->second);
+ if (!f) return; // not used, probably a shadowed rule
+ if (h && h != f) h->print(os);
+ f->print(os);
+ for (size_t i = 0, n = fmap.m.size(); i < n; i++) {
+ for (map<int32_t,Env>::const_iterator f = fmap.m[i].begin(),
+ end = fmap.m[i].end(); f != end; f++)
+ f->second.print_defs(os);
}
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-02 07:07:35
|
Revision: 443
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=443&view=rev
Author: agraef
Date: 2008-08-02 07:07:44 +0000 (Sat, 02 Aug 2008)
Log Message:
-----------
Move map of local function environments to separate class.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
pure/trunk/lexer.ll
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-07-31 12:16:17 UTC (rev 442)
+++ pure/trunk/interpreter.cc 2008-08-02 07:07:44 UTC (rev 443)
@@ -1942,8 +1942,7 @@
args = e.args; envs = e.envs;
b = e.b; local = e.local; parent = e.parent;
}
- fmap = e.fmap; fmap_idx = e.fmap_idx;
- xmap = e.xmap; xtab = e.xtab; prop = e.prop; m = e.m;
+ fmap = e.fmap; xmap = e.xmap; xtab = e.xtab; prop = e.prop; m = e.m;
return *this;
}
@@ -1961,7 +1960,7 @@
interp.JIT->freeMachineCodeForFunction(f);
f->dropAllReferences(); if (h != f) h->dropAllReferences();
fp = 0;
- fmap.clear(); fmap_idx = 0;
+ fmap.clear();
to_be_deleted.push_back(f); if (h != f) to_be_deleted.push_back(h);
} else {
#if DEBUG>2
@@ -1978,8 +1977,7 @@
}
fp = 0;
// delete all nested environments and reinitialize other body-related data
- fmap.clear(); fmap_idx = 0;
- xmap.clear(); xtab.clear(); prop.clear(); m = 0;
+ fmap.clear(); xmap.clear(); xtab.clear(); prop.clear(); m = 0;
// now that all references have been removed, delete the function pointers
for (list<Function*>::iterator fi = to_be_deleted.begin();
fi != to_be_deleted.end(); fi++) {
@@ -2130,7 +2128,7 @@
fenv = *ei++;
}
assert(fenv->act_fmap().find(x.vtag()) != fenv->act_fmap().end());
- fenv = &fenv->act_fmap()[x.vtag()];
+ fenv = &fenv->fmap.act()[x.vtag()];
if (!fenv->local) break;
// fenv now points to the environment of the (local) function
assert(fenv != this && fenv->tag == x.vtag());
@@ -2190,7 +2188,7 @@
if (n == 2 && f.tag() == interp.symtab.catch_sym().f) {
expr h = x.xval1().xval2(), y = x.xval2();
push("catch");
- Env& e = act_fmap()[-x.hash()] = Env(0, 0, y, true, true);
+ Env& e = fmap.act()[-x.hash()] = Env(0, 0, y, true, true);
e.build_map(y); e.promote_map();
pop();
build_map(h);
@@ -2207,14 +2205,14 @@
break;
case EXPR::LAMBDA: {
push("lambda");
- Env& e = act_fmap()[-x.hash()] = Env(0, 1, x.xval2(), true, true);
+ Env& e = fmap.act()[-x.hash()] = Env(0, 1, x.xval2(), true, true);
e.build_map(x.xval2()); e.promote_map();
pop();
break;
}
case EXPR::CASE: {
push("case");
- Env& e = act_fmap()[-x.hash()] = Env(0, 1, x.xval(), true, true);
+ Env& e = fmap.act()[-x.hash()] = Env(0, 1, x.xval(), true, true);
e.build_map(*x.rules()); e.promote_map();
pop();
build_map(x.xval());
@@ -2231,13 +2229,13 @@
for (env::const_iterator p = fe->begin(); p != fe->end(); p++) {
int32_t ftag = p->first;
const env_info& info = p->second;
- act_fmap()[ftag] = Env(ftag, info, false, true);
+ fmap.act()[ftag] = Env(ftag, info, false, true);
}
// Now recursively build the maps for the child environments.
for (env::const_iterator p = fe->begin(); p != fe->end(); p++) {
int32_t ftag = p->first;
const env_info& info = p->second;
- Env& e = act_fmap()[ftag];
+ Env& e = fmap.act()[ftag];
e.build_map(info); e.promote_map();
}
pop();
@@ -2261,7 +2259,7 @@
rulel::const_iterator s = r;
expr y = (++s == end)?x:s->rhs;
push("when");
- Env& e = act_fmap()[-y.hash()] = Env(0, 1, y, true, true);
+ Env& e = fmap.act()[-y.hash()] = Env(0, 1, y, true, true);
e.build_map(x, s, end); e.promote_map();
pop();
build_map(r->rhs);
@@ -2288,9 +2286,9 @@
while (r != info.rules->end()) {
build_map(r->rhs);
if (!r->qual.is_null()) build_map(r->qual);
- r++; fmap_idx++;
+ r++; fmap.next();
}
- fmap_idx = 0;
+ fmap.first();
#if DEBUG>1
if (!local) print_map(std::cerr, this);
#endif
@@ -3120,8 +3118,8 @@
Env& act = act_env();
rulel::const_iterator s = r;
expr y = (++s == end)?x:s->rhs;
- assert(act.act_fmap().find(-y.hash()) != act.act_fmap().end());
- Env& e = act.act_fmap()[-y.hash()];
+ assert(act.fmap.act().find(-y.hash()) != act.fmap.act().end());
+ Env& e = act.fmap.act()[-y.hash()];
push("when", &e);
fun_prolog("anonymous");
BasicBlock *bodybb = BasicBlock::Create("body");
@@ -3548,7 +3546,7 @@
int offs = idx-1;
if (idx == 0) {
// function in current environment ('with'-bound)
- f = &act_env().act_fmap()[tag];
+ f = &act_env().fmap.act()[tag];
} else {
// function in an outer environment, the de Bruijn index idx tells us
// where on the current environment stack it's at
@@ -3556,7 +3554,7 @@
size_t i = idx;
for (; i > 0; e++, i--) assert(e != envstk.end());
// look up the function in the environment
- f = &(*e)->act_fmap()[tag];
+ f = &(*e)->fmap.act()[tag];
}
if (f->n == n) {
// bingo! saturated call
@@ -3694,8 +3692,8 @@
// through pure_catch()
expr h = x.xval1().xval2(), y = x.xval2();
Env& act = act_env();
- assert(act.act_fmap().find(-x.hash()) != act.act_fmap().end());
- Env& e = act.act_fmap()[-x.hash()];
+ assert(act.fmap.act().find(-x.hash()) != act.fmap.act().end());
+ Env& e = act.fmap.act()[-x.hash()];
push("catch", &e);
fun_prolog("anonymous");
e.CreateRet(codegen(y));
@@ -3735,8 +3733,8 @@
// anonymous closure:
case EXPR::LAMBDA: {
Env& act = act_env();
- assert(act.act_fmap().find(-x.hash()) != act.act_fmap().end());
- Env& e = act.act_fmap()[-x.hash()];
+ assert(act.fmap.act().find(-x.hash()) != act.fmap.act().end());
+ Env& e = act.fmap.act()[-x.hash()];
push("lambda", &e);
fun("anonymous", x.pm(), true);
pop(&e);
@@ -3747,8 +3745,8 @@
// case expression: treated like an anonymous closure (see the lambda case
// above) which gets applied to the subject term to be matched
Env& act = act_env();
- assert(act.act_fmap().find(-x.hash()) != act.act_fmap().end());
- Env& e = act.act_fmap()[-x.hash()];
+ assert(act.fmap.act().find(-x.hash()) != act.fmap.act().end());
+ Env& e = act.fmap.act()[-x.hash()];
push("case", &e);
fun("anonymous", x.pm(), true);
pop(&e);
@@ -3774,16 +3772,16 @@
// mutually recursive definitions
for (p = fe->begin(); p != fe->end(); p++) {
int32_t ftag = p->first;
- assert(act.act_fmap().find(ftag) != act.act_fmap().end());
- Env& e = act.act_fmap()[ftag];
+ assert(act.fmap.act().find(ftag) != act.fmap.act().end());
+ Env& e = act.fmap.act()[ftag];
push("with", &e);
- act.act_fmap()[ftag].f = fun_prolog(symtab.sym(ftag).s);
+ act.fmap.act()[ftag].f = fun_prolog(symtab.sym(ftag).s);
pop(&e);
}
for (p = fe->begin(); p != fe->end(); p++) {
int32_t ftag = p->first;
const env_info& info = p->second;
- Env& e = act.act_fmap()[ftag];
+ Env& e = act.fmap.act()[ftag];
push("with", &e);
fun_body(info.m);
pop(&e);
@@ -4078,7 +4076,7 @@
assert(!envstk.empty());
if (idx == 0) {
// function in current environment ('with'-bound)
- Env& f = act_env().act_fmap()[tag];
+ Env& f = act_env().fmap.act()[tag];
return fbox(f, thunked);
}
// If we come here, the function is defined in an outer environment. Locate
@@ -4088,7 +4086,7 @@
size_t i = idx;
for (; i > 0; e++, i--) assert(e != envstk.end());
// look up the function in the environment
- Env& f = (*e)->act_fmap()[tag];
+ Env& f = (*e)->fmap.act()[tag];
assert(f.f);
// Now create the closure. This is essentially just like fbox(), but we are
// called inside a nested environment here, and hence the de Bruijn indices
@@ -5062,7 +5060,7 @@
while (r != rl.end()) {
const rule& rr = rules[*r];
reduced.insert(*r);
- if (f.fmap.size() > 1) f.fmap_idx = *r;
+ if (f.fmap.size() > 1) f.fmap.set(*r);
f.f->getBasicBlockList().push_back(rulebb);
f.builder.SetInsertPoint(rulebb);
#if DEBUG>1
@@ -5120,5 +5118,5 @@
toplevel_codegen(rr.rhs);
rulebb = nextbb;
}
- if (f.fmap.size() > 1) f.fmap_idx = 0;
+ if (f.fmap.size() > 1) f.fmap.first();
}
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-07-31 12:16:17 UTC (rev 442)
+++ pure/trunk/interpreter.hh 2008-08-02 07:07:44 UTC (rev 443)
@@ -88,6 +88,33 @@
typedef list<Env*> EnvStack;
typedef pair<int32_t,uint8_t> xmap_key;
+class FMap {
+ // manage local function environments
+ vector< map<int32_t,Env> > fmap;
+ // current map index
+ size_t idx;
+public:
+ // constructor (create one empty map by default)
+ FMap() : fmap(1), idx(0) {}
+ // assignment
+ FMap& operator= (const FMap& f)
+ { fmap = f.fmap; idx = f.idx; return *this; }
+ // clear local environments
+ void clear() { fmap.clear(); idx = 0; }
+ // resize (set number of maps)
+ void resize(size_t n) { fmap.resize(n); }
+ // current size (number of maps)
+ size_t size() const { return fmap.size(); }
+ // set index to first, next and given map
+ void first() { idx = 0; }
+ void next() { idx++; }
+ void set(size_t n) { idx = n; }
+ // access the current map
+ map<int32_t,Env>& act() { return fmap[idx]; }
+ // access the given map (read-only)
+ const map<int32_t,Env>& act(size_t n) const { return fmap[n]; }
+};
+
struct Env {
// function environment
int32_t tag; // function id, zero for anonymous functions
@@ -106,14 +133,8 @@
map<xmap_key,uint32_t > xmap;
// info about captured variables
list<VarInfo> xtab;
- // local function environments; note that there's actually a separate child
- // environment for each rule of the parent function (this gets initialized
- // to a single empty environment)
- vector< map<int32_t,Env> > fmap;
- // the current fmap index; this gets updated each time a new rule is added
- size_t fmap_idx;
- // convenience function to access the current fmap
- map<int32_t,Env>& act_fmap() { return fmap[fmap_idx]; }
+ // local function environments
+ FMap fmap;
// propagation links for environment variables (pointers to call sites)
// e in prop means that there's a call with de Bruijn index prop[e] at e
map<Env*,uint8_t> prop;
@@ -162,11 +183,11 @@
// default constructor
Env()
: tag(0), n(0), m(0), f(0), h(0), fp(0), args(0), envs(0),
- fmap(1), fmap_idx(0), b(false), local(false), parent(0), refc(0) {}
+ b(false), local(false), parent(0), refc(0) {}
// environment for an anonymous closure with given body x
Env(int32_t _tag, uint32_t _n, expr x, bool _b, bool _local = false)
: tag(_tag), n(_n), m(0), f(0), h(0), fp(0), args(n), envs(0),
- fmap(1), fmap_idx(0), b(_b), local(_local), parent(0), refc(0)
+ b(_b), local(_local), parent(0), refc(0)
{
if (envstk.empty()) {
assert(!local);
@@ -180,7 +201,7 @@
// environment for a named closure with given definition info
Env(int32_t _tag, const env_info& info, bool _b, bool _local = false)
: tag(_tag), n(info.argc), m(0), f(0), h(0), fp(0), args(n), envs(0),
- fmap(1), fmap_idx(0), b(_b), local(_local), parent(0), refc(0)
+ b(_b), local(_local), parent(0), refc(0)
{
if (envstk.empty()) {
assert(!local);
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-07-31 12:16:17 UTC (rev 442)
+++ pure/trunk/lexer.ll 2008-08-02 07:07:44 UTC (rev 443)
@@ -942,8 +942,8 @@
if (e.h && e.h != e.f) e.h->print(os);
e.f->print(os);
for (size_t i = 0, n = e.fmap.size(); i < n; i++) {
- map<int32_t,Env>::const_iterator f;
- for (f = e.fmap[i].begin(); f != e.fmap[i].end(); f++)
+ for (map<int32_t,Env>::const_iterator f = e.fmap.act(i).begin(),
+ end = e.fmap.act(i).end(); f != end; f++)
print_defs(os, f->second);
}
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-31 12:16:08
|
Revision: 442
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=442&view=rev
Author: agraef
Date: 2008-07-31 12:16:17 +0000 (Thu, 31 Jul 2008)
Log Message:
-----------
Comment change.
Modified Paths:
--------------
pure/trunk/interpreter.hh
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-07-30 20:40:04 UTC (rev 441)
+++ pure/trunk/interpreter.hh 2008-07-31 12:16:17 UTC (rev 442)
@@ -128,7 +128,7 @@
Builder builder;
// parent environment (if any)
Env *parent;
- // reference counter (currently unused)
+ // reference counter
uint32_t refc;
// convenience functions for invoking CreateGEP() and CreateLoad()
llvm::Value *CreateGEP
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-30 20:39:56
|
Revision: 441
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=441&view=rev
Author: agraef
Date: 2008-07-30 20:40:04 +0000 (Wed, 30 Jul 2008)
Log Message:
-----------
Update entity definitions to latest from W3C.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/w3centities.c
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-30 20:16:55 UTC (rev 440)
+++ pure/trunk/ChangeLog 2008-07-30 20:40:04 UTC (rev 441)
@@ -1,3 +1,7 @@
+2008-07-30 Albert Graef <Dr....@t-...>
+
+ * w3centities.c: Updated to latest from W3C.
+
2008-07-13 Albert Graef <Dr....@t-...>
* interpreter.cc (codegen): Streamline code for list and tuple
Modified: pure/trunk/w3centities.c
===================================================================
--- pure/trunk/w3centities.c 2008-07-30 20:16:55 UTC (rev 440)
+++ pure/trunk/w3centities.c 2008-07-30 20:40:04 UTC (rev 441)
@@ -1,4 +1,4 @@
-/* generated from w3centities.ent Fri Jan 18 03:24:08 2008 */
+/* generated from w3centities.ent Wed Jul 30 22:28:13 2008 */
typedef struct ENTITY { const char *name; long c; } Entity;
@@ -239,7 +239,7 @@
{ "Lcaron", 0x0013D },
{ "Lcedil", 0x0013B },
{ "Lcy", 0x0041B },
- { "LeftAngleBracket", 0x02329 },
+ { "LeftAngleBracket", 0x027E8 },
{ "LeftArrowBar", 0x021E4 },
{ "LeftArrowRightArrow", 0x021C6 },
{ "LeftCeiling", 0x02308 },
@@ -370,9 +370,9 @@
{ "Otimes", 0x02A37 },
{ "Ouml", 0x000D6 },
{ "OverBar", 0x000AF },
- { "OverBrace", 0x0FE37 },
+ { "OverBrace", 0x023DE },
{ "OverBracket", 0x023B4 },
- { "OverParenthesis", 0x0FE35 },
+ { "OverParenthesis", 0x023DC },
{ "PHgr", 0x003A6 },
{ "PSgr", 0x003A8 },
{ "PartialD", 0x02202 },
@@ -413,7 +413,7 @@
{ "Rfr", 0x0211C },
{ "Rgr", 0x003A1 },
{ "Rho", 0x003A1 },
- { "RightAngleBracket", 0x0232A },
+ { "RightAngleBracket", 0x027E9 },
{ "RightArrowBar", 0x021E5 },
{ "RightArrowLeftArrow", 0x021C4 },
{ "RightCeiling", 0x02309 },
@@ -513,9 +513,9 @@
{ "Ugr", 0x003A5 },
{ "Ugrave", 0x000D9 },
{ "Umacr", 0x0016A },
- { "UnderBrace", 0x0FE38 },
+ { "UnderBrace", 0x023DF },
{ "UnderBracket", 0x023B5 },
- { "UnderParenthesis", 0x0FE36 },
+ { "UnderParenthesis", 0x023DD },
{ "Union", 0x022C3 },
{ "UnionPlus", 0x0228E },
{ "Uogon", 0x00172 },
@@ -1228,9 +1228,9 @@
{ "laemptyv", 0x029B4 },
{ "lagran", 0x02112 },
{ "lambda", 0x003BB },
- { "lang", 0x02329 },
+ { "lang", 0x027E8 },
{ "langd", 0x02991 },
- { "langle", 0x02329 },
+ { "langle", 0x027E8 },
{ "lap", 0x02A85 },
{ "laquo", 0x000AB },
{ "larr", 0x02190 },
@@ -1246,7 +1246,7 @@
{ "latail", 0x02919 },
{ "late", 0x02AAD },
{ "lbarr", 0x0290C },
- { "lbbrk", 0x02997 },
+ { "lbbrk", 0x02772 },
{ "lbrace", 0x0007B },
{ "lbrack", 0x0005B },
{ "lbrke", 0x0298B },
@@ -1596,7 +1596,7 @@
{ "pfr", 0x1D52D },
{ "pgr", 0x003C0 },
{ "phgr", 0x003C6 },
- { "phi", 0x003D5 },
+ { "phi", 0x003C6 },
{ "phiv", 0x003C6 },
{ "phmmat", 0x02133 },
{ "phone", 0x0260E },
@@ -1669,10 +1669,10 @@
{ "racute", 0x00155 },
{ "radic", 0x0221A },
{ "raemptyv", 0x029B3 },
- { "rang", 0x0232A },
+ { "rang", 0x027E9 },
{ "rangd", 0x02992 },
{ "range", 0x029A5 },
- { "rangle", 0x0232A },
+ { "rangle", 0x027E9 },
{ "raquo", 0x000BB },
{ "rarr", 0x02192 },
{ "rarrap", 0x02975 },
@@ -1690,7 +1690,7 @@
{ "ratio", 0x02236 },
{ "rationals", 0x0211A },
{ "rbarr", 0x0290D },
- { "rbbrk", 0x02998 },
+ { "rbbrk", 0x02773 },
{ "rbrace", 0x0007D },
{ "rbrack", 0x0005D },
{ "rbrke", 0x0298C },
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-30 20:16:48
|
Revision: 440
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=440&view=rev
Author: agraef
Date: 2008-07-30 20:16:55 +0000 (Wed, 30 Jul 2008)
Log Message:
-----------
Handle a few additional whitespace characters.
Modified Paths:
--------------
pure/trunk/lexer.ll
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-07-29 12:13:14 UTC (rev 439)
+++ pure/trunk/lexer.ll 2008-07-30 20:16:55 UTC (rev 440)
@@ -221,7 +221,7 @@
exp ([Ee][+-]?[0-9]+)
float [0-9]+{exp}|[0-9]+\.{exp}|[0-9]*\.[0-9]+{exp}?
str ([^\"\\\n]|\\(.|\n))*
-blank [ \t]
+blank [ \t\f\v\r]
inttag ::{blank}*int
binttag ::{blank}*bigint
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-29 12:13:06
|
Revision: 439
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=439&view=rev
Author: agraef
Date: 2008-07-29 12:13:14 +0000 (Tue, 29 Jul 2008)
Log Message:
-----------
Add remark about command prompt.
Modified Paths:
--------------
pure/trunk/pure.1.in
Modified: pure/trunk/pure.1.in
===================================================================
--- pure/trunk/pure.1.in 2008-07-16 08:05:23 UTC (rev 438)
+++ pure/trunk/pure.1.in 2008-07-29 12:13:14 UTC (rev 439)
@@ -177,7 +177,9 @@
Pure is a fairly simple language. Programs are collections of equational rules
defining functions, \fBdef\fP and \fBlet\fP commands binding global constant
and variable symbols, and expressions to be evaluated. Here's a simple
-example, entered interactively in the interpreter:
+example, entered interactively in the interpreter (note that the \fB>\fP
+symbol at the beginning of each input line is the interpreter's default
+command prompt):
.sp
.nf
> // my first Pure example
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-16 08:05:20
|
Revision: 438
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=438&view=rev
Author: agraef
Date: 2008-07-16 01:05:23 -0700 (Wed, 16 Jul 2008)
Log Message:
-----------
Add limits.h.
Modified Paths:
--------------
pure/trunk/runtime.cc
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-13 10:25:17 UTC (rev 437)
+++ pure/trunk/runtime.cc 2008-07-16 08:05:23 UTC (rev 438)
@@ -26,6 +26,7 @@
#include <stdlib.h>
#include <stdarg.h>
#include <unistd.h>
+#include <limits.h>
#include <iostream>
#include <sstream>
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.
|
|
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-11 21:28:29
|
Revision: 435
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=435&view=rev
Author: agraef
Date: 2008-07-11 14:28:39 -0700 (Fri, 11 Jul 2008)
Log Message:
-----------
Reworded paragraph on ldconfig.
Modified Paths:
--------------
pure/trunk/INSTALL
Modified: pure/trunk/INSTALL
===================================================================
--- pure/trunk/INSTALL 2008-07-11 02:59:08 UTC (rev 434)
+++ pure/trunk/INSTALL 2008-07-11 21:28:39 UTC (rev 435)
@@ -92,8 +92,8 @@
to write C/C++ extensions modules, if you need to access and manipulate Pure
expressions from C/C++.)
-On some systems you may have to tell the dynamic linker to update its cache so
-that it finds the Pure runtime library. E.g., on Linux this can be done as
+On some systems you have to tell the dynamic linker to update its cache so
+that it finds the Pure runtime library. E.g., on Linux this is done as
follows:
$ sudo /sbin/ldconfig
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: <ed...@us...> - 2008-07-10 12:24:36
|
Revision: 433
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=433&view=rev
Author: eddier
Date: 2008-07-10 05:23:48 -0700 (Thu, 10 Jul 2008)
Log Message:
-----------
Add inexactp predicate.
Modified Paths:
--------------
pure/trunk/lib/math.pure
Modified: pure/trunk/lib/math.pure
===================================================================
--- pure/trunk/lib/math.pure 2008-07-09 23:16:20 UTC (rev 432)
+++ pure/trunk/lib/math.pure 2008-07-10 12:23:48 UTC (rev 433)
@@ -560,8 +560,9 @@
realp x = intp x || bigintp x || doublep x || rationalp x;
numberp x = realp x || complexp x;
-exactp x = intp x || bigintp x || rationalp ||
- complexp x && exactp (re x) && exactp (im x) if numberp x;
+inexactp x = doublep x || doublep (re x) || doublep (im x) if numberp x;
+exactp x = not(doublep x || doublep (re x) || doublep (im x))
+ if numberp x;
infp x::double = not nanp x && nanp (x-x);
nanp x::double = x===nan;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-09 23:16:13
|
Revision: 432
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=432&view=rev
Author: jspitz
Date: 2008-07-09 16:16:20 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
Remove testing 'set_test.pure' from examples
Removed Paths:
-------------
pure/trunk/examples/set_test.pure
Deleted: pure/trunk/examples/set_test.pure
===================================================================
--- pure/trunk/examples/set_test.pure 2008-07-09 20:20:47 UTC (rev 431)
+++ pure/trunk/examples/set_test.pure 2008-07-09 23:16:20 UTC (rev 432)
@@ -1,389 +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 |
-insert (t@Bag m) y = t ((insert m y)!0)
-with
- insert nil key
- = [(bin key ( 0) nil nil), 1];
-
- insert (bin k b::int l r) key
- = [(bin key b l r), 0] if (key == k) && (t === Set);
-
- 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 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 ToF oldTree _
- = [oldTree, 0] if ToF == 0;
-
- adjust ToF (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
- if ToF == 1;
-
- rebal ToF (bin k _ l r) b
- = bin k b l r if ToF == 0;
-
- rebal ToF oldTree _
- = (Set_avl_geq oldTree)!0 if ToF == 1;
-
-// Balance rules for insertions
-// balance whole tree to be balance where
-// after increased rebalanced before inserted
-table bb wi
- = [( 1), 1, 0] if (bb == ( 0)) && (wi == (-1));
- = [(-1), 1, 0] if (bb == ( 0)) && (wi == ( 1));
- = [( 0), 0, 1] if (bb == ( 1)) && (wi == (-1));
- = [( 0), 0, 0] if (bb == ( 1)) && (wi == ( 1));
- = [( 0), 0, 0] if (bb == (-1)) && (wi == (-1));
- = [( 0), 0, 1] if (bb == (-1)) && (wi == ( 1));
-end;
-
-// delete a member by key from the data structure
-delete (t@Set m) y |
-delete (t@Bag m) y
-= t ((delete m y)!0)
-with
- delete nil _ = [nil, 0];
-
- delete (bin k _ nil r) key
- = [r, 1] if key == k;
-
- delete (bin k _ l nil) key
- = [l, 1] if key == k;
-
- 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 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 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 set or bag
-null (Set nil) = 1;
-null (Set _) = 0;
-
-null (Bag nil) = 1;
-null (Bag _) = 0;
-
-// get a number of members in set or bag
-#(Set m) |
-#(Bag m) = #m
-with
- #nil = 0;
- #(bin _ _ m1 m2) = #m1 + #m2 + 1
-end;
-
-// check whether a key exists in set or bag
-member (Set m) k |
-member (Bag m) k
-= member m k
-with
- member nil _ = 0;
-
- 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 set or bag as a list
-members (Set m) |
-members (Bag m)
-= members m
-with
- members nil = [];
-
- members (bin x _ m1 m2)
- = (members m1) + (x : (members m2))
-end;
-
-list m@(Set _) |
-list m@(Bag _)
- = members m;
-
-// get the first member of set or bag
-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 set or bag
-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 set or bag
-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 set or bag
-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 ToF oldTree _ = [oldTree, 0] if ToF == 0;
-
- adjust ToF (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
- if ToF == 1;
-/*
- 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 ToF (bin k _ l r) b::int whatHasChanged
- = [bin k b l r, whatHasChanged]
- if ToF == 0;
-
- rebal ToF oldTree _ _ = Set_avl_geq oldTree if ToF == 1;
-
-// Balance rules for deletions
-// balance whole tree to be balance where
-// after decreased rebalanced before deleted
-table bb wi
- = [( 1), 0, 0] if (bb == ( 0)) && (wi == ( 1));
- = [(-1), 0, 0] if (bb == ( 0)) && (wi == (-1));
- = [( 0), 1, 1] if (bb == ( 1)) && (wi == ( 1));
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
- = [( 0), 1, 0] if (bb == ( 1)) && (wi == (-1));
- = [( 0), 1, 0] if (bb == (-1)) && (wi == ( 1));
- = [( 0), 1, 1] if (bb == (-1)) && (wi == (-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 bala alpha (bin b balb beta gamma))
- = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1]
- if (bala == (-1)) && (balb == (-1));
-
- avl_geq (bin a bala alpha (bin b balb beta gamma))
- = [bin b ( 1) (bin a (-1) alpha beta) gamma, 0]
- if (bala == (-1)) && (balb == ( 0));
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin a bala alpha
- (bin b balb (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
- if (bala == (-1)) && (balb == ( 1));
-
- avl_geq (bin b balb (bin a bala alpha beta) gamma)
- = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1]
- if (balb == ( 1)) && (bala == ( 1));
-
- avl_geq (bin b balb (bin a bala alpha beta) gamma)
- = [bin a (-1) alpha (bin b ( 1) beta gamma), 0]
- if (balb == ( 1)) && (bala == ( 0));
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin b balb
- (bin a bala 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
- if (balb == ( 1)) && (bala == (-1));
-
- table bal = [( 0), (-1)] if bal == ( 1);
- = [( 1), ( 0)] if bal == (-1);
- = [( 0), ( 0)] if bal == ( 0);
-end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-09 20:20:39
|
Revision: 431
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=431&view=rev
Author: yes
Date: 2008-07-09 13:20:47 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
made timex work with any number of arguments and return rounded ms cputime and elapsed time
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-09 19:58:31 UTC (rev 430)
+++ pure/trunk/examples/libor/date.pure 2008-07-09 20:20:47 UTC (rev 431)
@@ -26,9 +26,14 @@
def venusinf = 1187409600;// 18th August 2007, 4am Venus inferior conjunction
/******************************************************************************/
-// first a couple of functions generally useful in Pure:
-// Albert Graef's timer function: returns cputime, value of (f onearg)
-timex f x = (clock-t0)/CLOCKS_PER_SEC, res when t0 = clock; res = f x end;
+// first some functions generally useful in Pure:
+round n::double = int (n+0.5);
+mstime = 1000.0*gettimeofday;
+mscpu = 1000.0*clock/CLOCKS_PER_SEC;
+
+// timex returns a list: [ evaluated string argument, cputime, realtime ]
+timex s::string = [(eval s), round (mscpu-c0), round (mstime-d0)]
+ when d0::double = mstime; c0::double = mscpu end;
/* extended mod operator to work on doubles, so that int, bigint and double
times can be conveniently used */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-09 19:58:24
|
Revision: 430
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=430&view=rev
Author: jspitz
Date: 2008-07-09 12:58:31 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
Remove testing 'set_test2.pure' from examples.
Removed Paths:
-------------
pure/trunk/examples/set_test2.pure
Deleted: pure/trunk/examples/set_test2.pure
===================================================================
--- pure/trunk/examples/set_test2.pure 2008-07-09 19:56:14 UTC (rev 429)
+++ pure/trunk/examples/set_test2.pure 2008-07-09 19:58:31 UTC (rev 430)
@@ -1,404 +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 |
-insert (t@Bag m) y = t ((insert m y)!0)
-with
- insert nil key
- = [(bin key ( 0) nil nil), 1];
-
- insert (bin k b::int l r) key
- = [(bin key b l r), 0] if (key == k) && (t === Set);
-
- 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 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 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 _ l r) b
- = bin k b l r;
-
- rebal 1 oldTree _
- = (Set_avl_geq oldTree)!0;
-/*
-// Balance rules for insertions
-// balance whole tree to be balance where
-// after increased rebalanced before inserted
-table bb wi
- = [( 1), 1, 0] if (bb == ( 0)) && (wi == (-1));
- = [(-1), 1, 0] if (bb == ( 0)) && (wi == ( 1));
- = [( 0), 0, 1] if (bb == ( 1)) && (wi == (-1));
- = [( 0), 0, 0] if (bb == ( 1)) && (wi == ( 1));
- = [( 0), 0, 0] if (bb == (-1)) && (wi == (-1));
- = [( 0), 0, 1] if (bb == (-1)) && (wi == ( 1));
-*/
-// table w/o pattern matching
- table bb::int wi::int = [ba, wti, tbr]
- when
- ba = if bb == 0 then -wi else 0;
- wti = bb == 0;
- tbr = (bb + wi) == 0;
- end
-end;
-
-// delete a member by key from the data structure
-delete (t@Set m) y |
-delete (t@Bag m) y
-= t ((delete m y)!0)
-with
- delete nil _ = [nil, 0];
-
- delete (bin k _ nil r) key
- = [r, 1] if key == k;
-
- delete (bin k _ l nil) key
- = [l, 1] if key == k;
-
- 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 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 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 set or bag
-null (Set nil) = 1;
-null (Set _) = 0;
-
-null (Bag nil) = 1;
-null (Bag _) = 0;
-
-// get a number of members in set or bag
-#(Set m) |
-#(Bag m) = #m
-with
- #nil = 0;
- #(bin _ _ m1 m2) = #m1 + #m2 + 1
-end;
-
-// check whether a key exists in set or bag
-member (Set m) k |
-member (Bag m) k
-= member m k
-with
- member nil _ = 0;
-
- 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 set or bag as a list
-members (Set m) |
-members (Bag m)
-= members m
-with
- members nil = [];
-
- members (bin x _ m1 m2)
- = (members m1) + (x : (members m2))
-end;
-
-list m@(Set _) |
-list m@(Bag _)
- = members m;
-
-// get the first member of set or bag
-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 set or bag
-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 set or bag
-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 set or bag
-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 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 _ l r) b::int whatHasChanged
- = [bin k b l r, whatHasChanged];
-
- rebal 1 oldTree _ _ = Set_avl_geq oldTree;
-
-// Balance rules for deletions
-// balance whole tree to be balance where
-// after decreased rebalanced before deleted
-/*
-table bb wi
- = [( 1), 0, 0] if (bb == ( 0)) && (wi == ( 1));
- = [(-1), 0, 0] if (bb == ( 0)) && (wi == (-1));
- = [( 0), 1, 1] if (bb == ( 1)) && (wi == ( 1));
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
- = [( 0), 1, 0] if (bb == ( 1)) && (wi == (-1));
- = [( 0), 1, 0] if (bb == (-1)) && (wi == ( 1));
- = [( 0), 1, 1] if (bb == (-1)) && (wi == (-1));
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-*/
-// table w/o pattern matching
- table bb wd = [ba, wtd, tbr]
- when
- ba = if bb == 0 then wd else 0;
- wtd = abs bb;
- tbr = bb == wd;
- end
-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 (-1) alpha (bin b (-1) beta gamma))
- = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1];
-
- 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 (-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 ( 1) (bin a ( 1) alpha beta) gamma)
- = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1];
-
- 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 ( 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 bal = [( 0), (-1)] if bal == ( 1);
- = [( 1), ( 0)] if bal == (-1);
- = [( 0), ( 0)] if bal == ( 0);
-*/
-// table w/o pattern matching
- table bal = [b1, b2]
- when
- b1 = bal == (-1);
- b2 = -(bal == 1);
- end
-end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-09 19:56:09
|
Revision: 429
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=429&view=rev
Author: jspitz
Date: 2008-07-09 12:56:14 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
Update 'set.pure' and 'dict.pure' with versions that compile faster.
Modified Paths:
--------------
pure/trunk/lib/dict.pure
pure/trunk/lib/set.pure
Modified: pure/trunk/lib/dict.pure
===================================================================
--- pure/trunk/lib/dict.pure 2008-07-09 13:44:01 UTC (rev 428)
+++ pure/trunk/lib/dict.pure 2008-07-09 19:56:14 UTC (rev 429)
@@ -86,26 +86,18 @@
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
@@ -113,8 +105,6 @@
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
@@ -149,21 +139,18 @@
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
@@ -173,11 +160,18 @@
table ( 1) ( 1) = [( 0), 0, 0];
table (-1) (-1) = [( 0), 0, 0];
table (-1) ( 1) = [( 0), 0, 1]
+*/
+
+// table w/o pattern matching
+ table bb::int wi::int = [ba, wti, tbr]
+ when
+ ba = if bb == 0 then -wi else 0;
+ wti = bb == 0;
+ tbr = (bb + wi) == 0;
+ end
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
@@ -186,18 +180,12 @@
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
@@ -207,8 +195,6 @@
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
@@ -216,8 +202,6 @@
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
@@ -311,14 +295,10 @@
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;
@@ -343,8 +323,6 @@
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;
@@ -401,8 +379,6 @@
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;
@@ -429,14 +405,10 @@
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;
@@ -469,8 +441,6 @@
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;
@@ -499,8 +469,6 @@
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);
@@ -528,35 +496,41 @@
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
+ [b1, whatHasChanged, toBeRebalanced] = table 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];
+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
-tabled ( 1) (-1) = [( 0), 1, 0];
-tabled (-1) ( 1) = [( 0), 1, 0];
-tabled (-1) (-1) = [( 0), 1, 1];
+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
+*/
+
+// table w/o pattern matching
+ table bb wd = [ba, wtd, tbr]
+ when
+ ba = if bb == 0 then wd else 0;
+ wtd = abs bb;
+ tbr = bb == wd;
+ end
end;
// Single and double tree rotations - these are common for insert and delete
@@ -571,23 +545,13 @@
*/
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]
@@ -595,23 +559,13 @@
[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]
@@ -619,7 +573,16 @@
[b2, b3] = table b1
end;
+/*
table ( 1) = [( 0), (-1)];
table (-1) = [( 1), ( 0)];
table ( 0) = [( 0), ( 0)]
+*/
+
+// table w/o pattern matching
+ table bal = [b1, b2]
+ when
+ b1 = bal == (-1);
+ b2 = -(bal == 1);
+ end
end;
Modified: pure/trunk/lib/set.pure
===================================================================
--- pure/trunk/lib/set.pure 2008-07-09 13:44:01 UTC (rev 428)
+++ pure/trunk/lib/set.pure 2008-07-09 19:56:14 UTC (rev 429)
@@ -78,31 +78,19 @@
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
@@ -111,22 +99,18 @@
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
@@ -136,31 +120,30 @@
table ( 1) ( 1) = [( 0), 0, 0];
table (-1) (-1) = [( 0), 0, 0];
table (-1) ( 1) = [( 0), 0, 1];
+*/
+
+// table w/o pattern matching
+ table bb::int wi::int = [ba, wti, tbr]
+ when
+ ba = if bb == 0 then -wi else 0;
+ wti = bb == 0;
+ tbr = (bb + wi) == 0;
+ end
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
@@ -169,8 +152,6 @@
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
@@ -178,8 +159,6 @@
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
@@ -213,18 +192,12 @@
end;
// check whether a key exists in set or bag
-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;
@@ -238,8 +211,6 @@
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;
@@ -336,8 +307,6 @@
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
@@ -349,14 +318,13 @@
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];
@@ -370,9 +338,17 @@
table (-1) (-1) = [( 0), 1, 1]
// ^^^^
// It depends on the tree pattern in avl_geq whether it really decreases
+*/
+
+// table w/o pattern matching
+ table bb wd = [ba, wtd, tbr]
+ when
+ ba = if bb == 0 then wd else 0;
+ wtd = abs bb;
+ tbr = bb == wd;
+ end
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
@@ -386,21 +362,13 @@
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)
@@ -409,21 +377,13 @@
[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)
@@ -431,8 +391,16 @@
when
[b2, b3] = table b1
end;
-
+/*
table ( 1) = [( 0), (-1)];
table (-1) = [( 1), ( 0)];
table ( 0) = [( 0), ( 0)]
+*/
+
+// table w/o pattern matching
+ table bal = [b1, b2]
+ when
+ b1 = bal == (-1);
+ b2 = -(bal == 1);
+ end
end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-09 13:43:58
|
Revision: 428
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=428&view=rev
Author: jspitz
Date: 2008-07-09 06:44:01 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
Add set_test2.pure for compilation speed testing"
Added Paths:
-----------
pure/trunk/examples/set_test2.pure
Added: pure/trunk/examples/set_test2.pure
===================================================================
--- pure/trunk/examples/set_test2.pure (rev 0)
+++ pure/trunk/examples/set_test2.pure 2008-07-09 13:44:01 UTC (rev 428)
@@ -0,0 +1,404 @@
+/* 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 |
+insert (t@Bag m) y = t ((insert m y)!0)
+with
+ insert nil key
+ = [(bin key ( 0) nil nil), 1];
+
+ insert (bin k b::int l r) key
+ = [(bin key b l r), 0] if (key == k) && (t === Set);
+
+ 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 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 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 _ l r) b
+ = bin k b l r;
+
+ rebal 1 oldTree _
+ = (Set_avl_geq oldTree)!0;
+/*
+// Balance rules for insertions
+// balance whole tree to be balance where
+// after increased rebalanced before inserted
+table bb wi
+ = [( 1), 1, 0] if (bb == ( 0)) && (wi == (-1));
+ = [(-1), 1, 0] if (bb == ( 0)) && (wi == ( 1));
+ = [( 0), 0, 1] if (bb == ( 1)) && (wi == (-1));
+ = [( 0), 0, 0] if (bb == ( 1)) && (wi == ( 1));
+ = [( 0), 0, 0] if (bb == (-1)) && (wi == (-1));
+ = [( 0), 0, 1] if (bb == (-1)) && (wi == ( 1));
+*/
+// table w/o pattern matching
+ table bb::int wi::int = [ba, wti, tbr]
+ when
+ ba = if bb == 0 then -wi else 0;
+ wti = bb == 0;
+ tbr = (bb + wi) == 0;
+ end
+end;
+
+// delete a member by key from the data structure
+delete (t@Set m) y |
+delete (t@Bag m) y
+= t ((delete m y)!0)
+with
+ delete nil _ = [nil, 0];
+
+ delete (bin k _ nil r) key
+ = [r, 1] if key == k;
+
+ delete (bin k _ l nil) key
+ = [l, 1] if key == k;
+
+ 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 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 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 set or bag
+null (Set nil) = 1;
+null (Set _) = 0;
+
+null (Bag nil) = 1;
+null (Bag _) = 0;
+
+// get a number of members in set or bag
+#(Set m) |
+#(Bag m) = #m
+with
+ #nil = 0;
+ #(bin _ _ m1 m2) = #m1 + #m2 + 1
+end;
+
+// check whether a key exists in set or bag
+member (Set m) k |
+member (Bag m) k
+= member m k
+with
+ member nil _ = 0;
+
+ 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 set or bag as a list
+members (Set m) |
+members (Bag m)
+= members m
+with
+ members nil = [];
+
+ members (bin x _ m1 m2)
+ = (members m1) + (x : (members m2))
+end;
+
+list m@(Set _) |
+list m@(Bag _)
+ = members m;
+
+// get the first member of set or bag
+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 set or bag
+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 set or bag
+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 set or bag
+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 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 _ l r) b::int whatHasChanged
+ = [bin k b l r, whatHasChanged];
+
+ rebal 1 oldTree _ _ = Set_avl_geq oldTree;
+
+// Balance rules for deletions
+// balance whole tree to be balance where
+// after decreased rebalanced before deleted
+/*
+table bb wi
+ = [( 1), 0, 0] if (bb == ( 0)) && (wi == ( 1));
+ = [(-1), 0, 0] if (bb == ( 0)) && (wi == (-1));
+ = [( 0), 1, 1] if (bb == ( 1)) && (wi == ( 1));
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+ = [( 0), 1, 0] if (bb == ( 1)) && (wi == (-1));
+ = [( 0), 1, 0] if (bb == (-1)) && (wi == ( 1));
+ = [( 0), 1, 1] if (bb == (-1)) && (wi == (-1));
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+*/
+// table w/o pattern matching
+ table bb wd = [ba, wtd, tbr]
+ when
+ ba = if bb == 0 then wd else 0;
+ wtd = abs bb;
+ tbr = bb == wd;
+ end
+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 (-1) alpha (bin b (-1) beta gamma))
+ = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1];
+
+ 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 (-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 ( 1) (bin a ( 1) alpha beta) gamma)
+ = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1];
+
+ 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 ( 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 bal = [( 0), (-1)] if bal == ( 1);
+ = [( 1), ( 0)] if bal == (-1);
+ = [( 0), ( 0)] if bal == ( 0);
+*/
+// table w/o pattern matching
+ table bal = [b1, b2]
+ when
+ b1 = bal == (-1);
+ b2 = -(bal == 1);
+ end
+end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-09 09:28:28
|
Revision: 427
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=427&view=rev
Author: yes
Date: 2008-07-09 02:28:37 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
fixed 'timex', removed succ and pred from queens.pure, as they are now in prelude.pure
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
pure/trunk/examples/libor/queens.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-09 04:06:57 UTC (rev 426)
+++ pure/trunk/examples/libor/date.pure 2008-07-09 09:28:37 UTC (rev 427)
@@ -27,8 +27,8 @@
/******************************************************************************/
// first a couple of functions generally useful in Pure:
-// timer function: (timex (id (foo arg))) returns cputime, value of (foo arg)
-timex fn = (clock-t)/CLOCKS_PER_SEC $ res when t = clock; res = fn end;
+// Albert Graef's timer function: returns cputime, value of (f onearg)
+timex f x = (clock-t0)/CLOCKS_PER_SEC, res when t0 = clock; res = f x end;
/* extended mod operator to work on doubles, so that int, bigint and double
times can be conveniently used */
Modified: pure/trunk/examples/libor/queens.pure
===================================================================
--- pure/trunk/examples/libor/queens.pure 2008-07-09 04:06:57 UTC (rev 426)
+++ pure/trunk/examples/libor/queens.pure 2008-07-09 09:28:37 UTC (rev 427)
@@ -11,9 +11,6 @@
>tailqueens 8; // gives solution no. 89, which is a reflection of no. 52
>map succ (thequeens 8); // gives solution no. 56 */
-// increment and decrement general utility
-succ x::int = 1+x; pred x::int = x-1;
-
// row j in current column not attacked by any queens in preceding columns?
safe _ _ [] = 1;
safe id::int j::int (j2::int:l) = // id is the column positions difference
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-09 04:06:48
|
Revision: 426
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=426&view=rev
Author: agraef
Date: 2008-07-08 21:06:57 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Fix Windows compilation quirks.
Modified Paths:
--------------
pure/trunk/runtime.cc
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-08 20:38:51 UTC (rev 425)
+++ pure/trunk/runtime.cc 2008-07-09 04:06:57 UTC (rev 426)
@@ -1908,6 +1908,10 @@
return (y ^ (y >> 18));
}
+#undef N
+#undef M
+#undef K
+
extern "C"
pure_expr *bigint_neg(mpz_t x)
{
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-08 20:38:42
|
Revision: 425
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=425&view=rev
Author: yes
Date: 2008-07-08 13:38:51 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
added 'timex' function discussed earlier on pure-lang-users list
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-08 17:37:56 UTC (rev 424)
+++ pure/trunk/examples/libor/date.pure 2008-07-08 20:38:51 UTC (rev 425)
@@ -24,13 +24,17 @@
def fullmoon = 1213810200;// 18th June 2008, 17:30, full moon in posix seconds
def venussyn = 50450688;// duration of the Venus synodic cycle
def venusinf = 1187409600;// 18th August 2007, 4am Venus inferior conjunction
-
+
+/******************************************************************************/
+// first a couple of functions generally useful in Pure:
+// timer function: (timex (id (foo arg))) returns cputime, value of (foo arg)
+timex fn = (clock-t)/CLOCKS_PER_SEC $ res when t = clock; res = fn end;
+
/* extended mod operator to work on doubles, so that int, bigint and double
times can be conveniently used */
x::double mod y::int =
(x - intx) + (intx mod y) when intx = (int x) end; // mod of a double
-
-// can also use secsnow = gettimeofday mod secsinday; double for more accuracy
+/******************************************************************************/
secsnow = time mod secsinday; // int seconds since midnight
// either mayan or julian posix epoch (plus posix seconds), gives a double mjday
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-08 17:37:49
|
Revision: 424
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=424&view=rev
Author: jspitz
Date: 2008-07-08 10:37:56 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Add revamped set to examples as 'set_test.pure'
Added Paths:
-----------
pure/trunk/examples/set_test.pure
Added: pure/trunk/examples/set_test.pure
===================================================================
--- pure/trunk/examples/set_test.pure (rev 0)
+++ pure/trunk/examples/set_test.pure 2008-07-08 17:37:56 UTC (rev 424)
@@ -0,0 +1,389 @@
+/* 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 |
+insert (t@Bag m) y = t ((insert m y)!0)
+with
+ insert nil key
+ = [(bin key ( 0) nil nil), 1];
+
+ insert (bin k b::int l r) key
+ = [(bin key b l r), 0] if (key == k) && (t === Set);
+
+ 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 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 ToF oldTree _
+ = [oldTree, 0] if ToF == 0;
+
+ adjust ToF (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
+ if ToF == 1;
+
+ rebal ToF (bin k _ l r) b
+ = bin k b l r if ToF == 0;
+
+ rebal ToF oldTree _
+ = (Set_avl_geq oldTree)!0 if ToF == 1;
+
+// Balance rules for insertions
+// balance whole tree to be balance where
+// after increased rebalanced before inserted
+table bb wi
+ = [( 1), 1, 0] if (bb == ( 0)) && (wi == (-1));
+ = [(-1), 1, 0] if (bb == ( 0)) && (wi == ( 1));
+ = [( 0), 0, 1] if (bb == ( 1)) && (wi == (-1));
+ = [( 0), 0, 0] if (bb == ( 1)) && (wi == ( 1));
+ = [( 0), 0, 0] if (bb == (-1)) && (wi == (-1));
+ = [( 0), 0, 1] if (bb == (-1)) && (wi == ( 1));
+end;
+
+// delete a member by key from the data structure
+delete (t@Set m) y |
+delete (t@Bag m) y
+= t ((delete m y)!0)
+with
+ delete nil _ = [nil, 0];
+
+ delete (bin k _ nil r) key
+ = [r, 1] if key == k;
+
+ delete (bin k _ l nil) key
+ = [l, 1] if key == k;
+
+ 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 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 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 set or bag
+null (Set nil) = 1;
+null (Set _) = 0;
+
+null (Bag nil) = 1;
+null (Bag _) = 0;
+
+// get a number of members in set or bag
+#(Set m) |
+#(Bag m) = #m
+with
+ #nil = 0;
+ #(bin _ _ m1 m2) = #m1 + #m2 + 1
+end;
+
+// check whether a key exists in set or bag
+member (Set m) k |
+member (Bag m) k
+= member m k
+with
+ member nil _ = 0;
+
+ 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 set or bag as a list
+members (Set m) |
+members (Bag m)
+= members m
+with
+ members nil = [];
+
+ members (bin x _ m1 m2)
+ = (members m1) + (x : (members m2))
+end;
+
+list m@(Set _) |
+list m@(Bag _)
+ = members m;
+
+// get the first member of set or bag
+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 set or bag
+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 set or bag
+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 set or bag
+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 ToF oldTree _ = [oldTree, 0] if ToF == 0;
+
+ adjust ToF (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
+ if ToF == 1;
+/*
+ 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 ToF (bin k _ l r) b::int whatHasChanged
+ = [bin k b l r, whatHasChanged]
+ if ToF == 0;
+
+ rebal ToF oldTree _ _ = Set_avl_geq oldTree if ToF == 1;
+
+// Balance rules for deletions
+// balance whole tree to be balance where
+// after decreased rebalanced before deleted
+table bb wi
+ = [( 1), 0, 0] if (bb == ( 0)) && (wi == ( 1));
+ = [(-1), 0, 0] if (bb == ( 0)) && (wi == (-1));
+ = [( 0), 1, 1] if (bb == ( 1)) && (wi == ( 1));
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+ = [( 0), 1, 0] if (bb == ( 1)) && (wi == (-1));
+ = [( 0), 1, 0] if (bb == (-1)) && (wi == ( 1));
+ = [( 0), 1, 1] if (bb == (-1)) && (wi == (-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 bala alpha (bin b balb beta gamma))
+ = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1]
+ if (bala == (-1)) && (balb == (-1));
+
+ avl_geq (bin a bala alpha (bin b balb beta gamma))
+ = [bin b ( 1) (bin a (-1) alpha beta) gamma, 0]
+ if (bala == (-1)) && (balb == ( 0));
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin a bala alpha
+ (bin b balb (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
+ if (bala == (-1)) && (balb == ( 1));
+
+ avl_geq (bin b balb (bin a bala alpha beta) gamma)
+ = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1]
+ if (balb == ( 1)) && (bala == ( 1));
+
+ avl_geq (bin b balb (bin a bala alpha beta) gamma)
+ = [bin a (-1) alpha (bin b ( 1) beta gamma), 0]
+ if (balb == ( 1)) && (bala == ( 0));
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin b balb
+ (bin a bala 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
+ if (balb == ( 1)) && (bala == (-1));
+
+ table bal = [( 0), (-1)] if bal == ( 1);
+ = [( 1), ( 0)] if bal == (-1);
+ = [( 0), ( 0)] if bal == ( 0);
+end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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-08 10:55:02
|
Revision: 422
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=422&view=rev
Author: agraef
Date: 2008-07-08 03:55:04 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Updated ChangeLog.
Modified Paths:
--------------
pure/trunk/ChangeLog
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-08 10:53:09 UTC (rev 421)
+++ pure/trunk/ChangeLog 2008-07-08 10:55:04 UTC (rev 422)
@@ -1,5 +1,7 @@
2008-07-08 Albert Graef <Dr....@t-...>
+ * examples/avltree.pure: Added to examples.
+
* lib/math.pure: Moved abs, sgn, min, max, pred and succ from
math.pure to primitives.pure, so that they are included in the
prelude. Make x%0 behave like x div 0 (which raises SIGFPE).
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-08 10:53:03
|
Revision: 421
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=421&view=rev
Author: agraef
Date: 2008-07-08 03:53:09 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Comment change.
Modified Paths:
--------------
pure/trunk/examples/hello.pure
Modified: pure/trunk/examples/hello.pure
===================================================================
--- pure/trunk/examples/hello.pure 2008-07-08 10:51:02 UTC (rev 420)
+++ pure/trunk/examples/hello.pure 2008-07-08 10:53:09 UTC (rev 421)
@@ -232,9 +232,9 @@
/* Lists are all good and fine, but what about other, more complicated kinds
of data? Luckily, as a term rewriting language Pure is well-suited to
process any kind of tree-structured data. We only discuss a simple example
- here, but using similar, more elaborate techniques like AVL trees, it is
- possible to implement almost any kind of container data structure in an
- efficient way.
+ here, but using similar, more elaborate techniques like AVL trees (see
+ avltree.pure for an example), it is possible to implement almost any kind
+ of container data structure in an efficient way.
So let's see how we can implement simple binary search trees in Pure. These
are represented using the constant symbol 'nil' (which denotes the empty
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
