Thread: [pure-lang-svn] SF.net SVN: pure-lang:[720] pure/trunk (Page 5)
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
pure-lang-svn
|
From: <ag...@us...> - 2008-09-05 14:12:05
|
Revision: 720
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=720&view=rev
Author: agraef
Date: 2008-09-05 14:12:15 +0000 (Fri, 05 Sep 2008)
Log Message:
-----------
Print warning message if the prelude wasn't found.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/pure.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-05 13:40:46 UTC (rev 719)
+++ pure/trunk/ChangeLog 2008-09-05 14:12:15 UTC (rev 720)
@@ -1,5 +1,9 @@
2008-09-05 Albert Graef <Dr....@t-...>
+ * pure.cc (main): In interactive mode, print a warning if -n was
+ not specified and the prelude wasn't found. Suggested by Rob
+ Hubbard.
+
* printer.cc (operator << (ostream& os, const pure_expr *x)):
Experimental support for calling a user-defined __show__ function
to override print representations of expressions at runtime.
Modified: pure/trunk/pure.cc
===================================================================
--- pure/trunk/pure.cc 2008-09-05 13:40:46 UTC (rev 719)
+++ pure/trunk/pure.cc 2008-09-05 14:12:15 UTC (rev 720)
@@ -408,6 +408,8 @@
<< COPYRIGHT << endl << LICENSE;
if (have_prelude)
cout << "Loaded prelude from " << prelude << ".\n";
+ else if (want_prelude)
+ cout << "Couldn't find the prelude. Please check your PURELIB environment variable.\n";
cout << endl;
}
interp.compile();
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-06 07:57:38
|
Revision: 725
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=725&view=rev
Author: agraef
Date: 2008-09-06 07:57:49 +0000 (Sat, 06 Sep 2008)
Log Message:
-----------
Add support for interactive startup files (.purerc).
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/pure.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-06 07:39:02 UTC (rev 724)
+++ pure/trunk/ChangeLog 2008-09-06 07:57:49 UTC (rev 725)
@@ -1,3 +1,8 @@
+2008-09-06 Albert Graef <Dr....@t-...>
+
+ * pure.cc (main): Source interactive startup files (first
+ $HOME/.purerc, then $PWD/.purerc).
+
2008-09-05 Albert Graef <Dr....@t-...>
* pure.cc (main): In interactive mode, print a warning if -n was
Modified: pure/trunk/pure.cc
===================================================================
--- pure/trunk/pure.cc 2008-09-06 07:39:02 UTC (rev 724)
+++ pure/trunk/pure.cc 2008-09-06 07:57:49 UTC (rev 725)
@@ -233,6 +233,7 @@
int count = 0;
bool quiet = false, force_interactive = false,
want_prelude = true, have_prelude = false;
+ string rcfile;
// This is used in advisory stack checks.
interpreter::baseptr = &base;
/* Set up handlers for all standard POSIX termination signals (except
@@ -267,8 +268,10 @@
setlocale(LC_ALL, "");
// get some settings from the environment
const char *env;
- if ((env = getenv("HOME")))
+ if ((env = getenv("HOME"))) {
interp.histfile = string(env)+"/.pure_history";
+ rcfile = string(env)+"/.purerc";
+ }
if ((env = getenv("PURE_PS")))
interp.ps = string(env);
if ((env = getenv("PURE_STACK"))) {
@@ -429,7 +432,17 @@
interp.temp = 1;
if (last_modno < 0) force_interactive = false;
if (force_interactive) interp.modno = last_modno;
- interp.run("", false, force_interactive);
+ // source the initialization files, if any
+ bool sticky = force_interactive;
+ if (!rcfile.empty() && chkfile(rcfile)) {
+ interp.run(rcfile, false, sticky);
+ sticky = true;
+ }
+ if (chkfile(".purerc")) {
+ interp.run(".purerc", false, sticky);
+ sticky = true;
+ }
+ interp.run("", false, sticky);
if (interp.ttymode) cout << endl;
return 0;
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-06 08:48:58
|
Revision: 726
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=726&view=rev
Author: agraef
Date: 2008-09-06 08:49:07 +0000 (Sat, 06 Sep 2008)
Log Message:
-----------
Overhaul of command line options.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/pure.cc
pure/trunk/runtime.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-06 07:57:49 UTC (rev 725)
+++ pure/trunk/ChangeLog 2008-09-06 08:49:07 UTC (rev 726)
@@ -1,8 +1,18 @@
2008-09-06 Albert Graef <Dr....@t-...>
+ * runtime.cc (pure_create_interp): Add new command line options
+ (see below).
+
* pure.cc (main): Source interactive startup files (first
$HOME/.purerc, then $PWD/.purerc).
+ Add options --norc to not source the rc files and --noediting to
+ suppress readline editing, as well as --noprelude (long form of
+ -n), --help (long form of -h) and --version (like --help, but only
+ print version information).
+
+ Overhaul help message.
+
2008-09-05 Albert Graef <Dr....@t-...>
* pure.cc (main): In interactive mode, print a warning if -n was
Modified: pure/trunk/pure.cc
===================================================================
--- pure/trunk/pure.cc 2008-09-06 07:57:49 UTC (rev 725)
+++ pure/trunk/pure.cc 2008-09-06 08:49:07 UTC (rev 726)
@@ -32,25 +32,21 @@
#define COPYRIGHT "Copyright (c) 2008 by Albert Graef"
#define USAGE \
-"Usage: pure [options ...] [script ...] [-- args ...]\n\
- pure [options ...] -x script [args ...]\n\
-Options:\n\
--h Print this message and exit.\n\
--i Force interactive mode (read commands from stdin).\n\
--Idirectory Add directory to search for included source files.\n\
--Ldirectory Add directory to search for dynamic libraries.\n\
--n Suppress automatic inclusion of the prelude.\n\
--q Quiet startup (suppresses sign-on message).\n\
--v[level] Set debugging level (default: 1).\n\
--x Execute script with given command line arguments.\n\
--- Stop option processing, pass remaining args in argv variable.\n\
-Environment:\n\
-PURELIB Directory to search for library scripts and the prelude.\n\
-PURE_INCLUDE Path to search for included source files.\n\
-PURE_LIBRARY Path to search for dynamic libraries.\n\
-PURE_MORE Shell command for paging through output of the 'show' command.\n\
-PURE_PS Command prompt to be used in the interactive command loop.\n\
-PURE_STACK Maximum stack size in kilobytes (default: 0 = unlimited).\n"
+"Usage: pure [options ...] [script ...] [-- args ...]\n\
+ pure [options ...] -x script [args ...]\n\
+--help, -h Print this message and exit.\n\
+-i Force interactive mode (read commands from stdin).\n\
+-Idirectory Add directory to search for included source files.\n\
+-Ldirectory Add directory to search for dynamic libraries.\n\
+--noediting Do not use readline for command-line editing.\n\
+--noprelude, -n Do not load the prelude.\n\
+--norc Do not run the interactive startup files.\n\
+-q Quiet startup (suppresses sign-on message).\n\
+-v[level] Set debugging level (default: 1).\n\
+--version Print version information and exit.\n\
+-x Execute script with given command line arguments.\n\
+-- Stop option processing.\n\
+Type 'help' in the interpreter for more help.\n"
#define LICENSE "This program is free software distributed under the GNU Public License\n(GPL V3 or later). Please see the COPYING file for details.\n"
static const char *commands[] = {
@@ -232,7 +228,8 @@
interpreter interp;
int count = 0;
bool quiet = false, force_interactive = false,
- want_prelude = true, have_prelude = false;
+ want_prelude = true, have_prelude = false,
+ want_rcfile = true, want_editing = true;
string rcfile;
// This is used in advisory stack checks.
interpreter::baseptr = &base;
@@ -295,14 +292,22 @@
const string prog = *argv;
list<string> myargs;
for (char **args = ++argv; *args; ++args)
- if (*args == string("-h")) {
+ if (*args == string("-h") || *args == string("--help")) {
cout << "Pure " << PACKAGE_VERSION << " (" << HOST << ") "
<< COPYRIGHT << endl << USAGE;
return 0;
+ } else if (*args == string("--version")) {
+ cout << "Pure " << PACKAGE_VERSION << " (" << HOST << ") "
+ << COPYRIGHT << endl;
+ return 0;
} else if (*args == string("-i"))
force_interactive = true;
- else if (*args == string("-n"))
+ else if (*args == string("-n") || *args == string("--noprelude"))
want_prelude = false;
+ else if (*args == string("--norc"))
+ want_rcfile = false;
+ else if (*args == string("--noediting"))
+ want_editing = false;
else if (*args == string("-q"))
quiet = true;
else if (string(*args).substr(0,2) == "-I") {
@@ -418,7 +423,7 @@
interp.compile();
interp.ttymode = true;
}
- if (isatty(fileno(stdin))) {
+ if (want_editing && isatty(fileno(stdin))) {
// initialize readline
extern bool using_readline;
using_readline = true;
@@ -434,14 +439,16 @@
if (force_interactive) interp.modno = last_modno;
// source the initialization files, if any
bool sticky = force_interactive;
- if (!rcfile.empty() && chkfile(rcfile)) {
- interp.run(rcfile, false, sticky);
- sticky = true;
+ if (want_rcfile) {
+ if (!rcfile.empty() && chkfile(rcfile)) {
+ interp.run(rcfile, false, sticky);
+ sticky = true;
+ }
+ if (chkfile(".purerc")) {
+ interp.run(".purerc", false, sticky);
+ sticky = true;
+ }
}
- if (chkfile(".purerc")) {
- interp.run(".purerc", false, sticky);
- sticky = true;
- }
interp.run("", false, sticky);
if (interp.ttymode) cout << endl;
return 0;
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-06 07:57:49 UTC (rev 725)
+++ pure/trunk/runtime.cc 2008-09-06 08:49:07 UTC (rev 726)
@@ -1062,12 +1062,18 @@
// scan the command line options
list<string> myargs;
for (char **args = ++argv; *args; ++args)
- if (*args == string("-h"))
+ if (*args == string("-h") || *args == string("--help"))
/* ignored */;
+ else if (*args == string("--version"))
+ /* ignored */;
else if (*args == string("-i"))
/* ignored */;
- else if (*args == string("-n"))
+ else if (*args == string("-n") || *args == string("--noprelude"))
want_prelude = false;
+ else if (*args == string("--norc"))
+ /* ignored */;
+ else if (*args == string("--noediting"))
+ /* ignored */;
else if (*args == string("-q"))
/* ignored */;
else if (string(*args).substr(0,2) == "-I") {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-06 17:31:53
|
Revision: 730
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=730&view=rev
Author: agraef
Date: 2008-09-06 17:32:03 +0000 (Sat, 06 Sep 2008)
Log Message:
-----------
Add dump command.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lexer.ll
pure/trunk/pure.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-06 16:59:50 UTC (rev 729)
+++ pure/trunk/ChangeLog 2008-09-06 17:32:03 UTC (rev 730)
@@ -1,5 +1,15 @@
2008-09-06 Albert Graef <Dr....@t-...>
+ * pure.cc, lexer.ll: Add 'dump' command. This is similar to
+ 'show', but dumps temporary definitions to a hidden file named
+ '.pure', which, if present, is loaded after .purerc during
+ interactive startup. This provides a quick-and-dirty means to save
+ an interactive session and have it restored later. (This is not
+ perfect, though, as variable values containing special objects
+ such as thunks and pointers can't be reconstructed, and 'using' or
+ 'extern' declarations are not recorded. For those you should use
+ the .purerc file instead.)
+
* runtime.cc (pure_create_interp): Add new command line options
(see below).
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-09-06 16:59:50 UTC (rev 729)
+++ pure/trunk/lexer.ll 2008-09-06 17:32:03 UTC (rev 730)
@@ -8,6 +8,7 @@
#include <readline/history.h>
#include <string>
#include <sstream>
+#include <fstream>
#include "interpreter.hh"
#include "parser.hh"
#include "util.hh"
@@ -132,7 +133,7 @@
now. */
static const char *commands[] = {
- "cd", "clear", "const", "def", "extern", "help", "infix", "infixl",
+ "cd", "clear", "const", "def", "dump", "extern", "help", "infix", "infixl",
"infixr", "let", "ls", "nullary", "override", "postfix", "prefix",
"private", "pwd", "quit", "run", "save", "show", "stats", "underride",
"using", 0
@@ -744,6 +745,252 @@
out:
interpreter::g_verbose = s_verbose;
}
+^dump.* {
+ // dump command is only permitted in interactive mode
+ if (!interp.interactive) REJECT;
+ uint8_t tflag = 1; int pflag = -1;
+ bool cflag = false, fflag = false, mflag = false, vflag = false;
+ bool gflag = false;
+ const char *s = yytext+4;
+ if (*s && !isspace(*s)) REJECT;
+ yylloc->step();
+ argl args(s, "dump");
+ list<string>::iterator arg;
+ if (!args.ok) goto out2;
+ // process option arguments
+ for (arg = args.l.begin(); arg != args.l.end(); arg++) {
+ const char *s = arg->c_str();
+ if (s[0] != '-' || !s[1] || !strchr("cfghmptv", s[1])) break;
+ while (*++s) {
+ switch (*s) {
+ case 'c': cflag = true; break;
+ case 'f': fflag = true; break;
+ case 'g': gflag = true; break;
+ case 'm': mflag = true; break;
+ case 'p':
+ if (isdigit(s[1])) {
+ pflag = strtoul(s+1, 0, 10)>0;
+ while (isdigit(s[1])) ++s;
+ } else
+ pflag = 1;
+ break;
+ case 'v': vflag = true; break;
+ case 't':
+ if (isdigit(s[1])) {
+ tflag = strtoul(s+1, 0, 10);
+ while (isdigit(s[1])) ++s;
+ } else
+ tflag = interp.temp;
+ break;
+ case 'h':
+ cout << "dump command help: dump [options ...] [symbol ...]\n\
+Options may be combined, e.g., dump -cv is the same as show -c -v.\n\
+-c Dump defined constants.\n\
+-f Dump defined functions.\n\
+-g Indicates that the following symbols are actually shell glob patterns\n\
+ and that all matching symbols should be dumped.\n\
+-h Print this list.\n\
+-m Dump defined macros.\n\
+-p[flag] Dump only private symbols in the current module if flag is\n\
+ nonzero (the default), otherwise dump only public symbols of all\n\
+ modules. Dump both private and public symbols if -p is omitted.\n\
+-t[level] Dump only symbols and definitions at the given temporary level\n\
+ (the current level by default) or above. Level 1 denotes all temporary\n\
+ definitions (the default if -t is omitted), level 0 *all* definitions.\n\
+-v Dump defined variables.\n";
+ goto out2;
+ default:
+ cerr << "show: invalid option character '" << *s << "'\n";
+ goto out2;
+ }
+ }
+ }
+ args.l.erase(args.l.begin(), arg);
+ if (!cflag && !fflag && !mflag && !vflag)
+ cflag = fflag = mflag = vflag = true;
+ {
+ list<env_sym> l; set<int32_t> syms;
+ for (env::const_iterator it = interp.globenv.begin();
+ it != interp.globenv.end(); ++it) {
+ int32_t f = it->first;
+ const env_info& e = it->second;
+ const symbol& sym = interp.symtab.sym(f);
+ if (sym.modno >= 0 && sym.modno != interp.modno ||
+ pflag >= 0 && (pflag > 0) != (sym.modno >= 0) ||
+ !((e.t == env_info::fun)?fflag:
+ (e.t == env_info::cvar)?cflag:
+ (e.t == env_info::fvar)?vflag:0))
+ continue;
+ bool matches = e.temp >= tflag;
+ if (!matches && args.l.empty() &&
+ e.t == env_info::fun && fflag) {
+ // dump temporary rules for a non-temporary symbol
+ rulel::const_iterator r;
+ for (r = e.rules->begin(); r != e.rules->end(); r++)
+ if (r->temp >= tflag) {
+ matches = true;
+ break;
+ }
+ }
+ if (!matches) continue;
+ if (!args.l.empty()) {
+ // see whether we actually want the defined symbol to be dumped
+ matches = false;
+ for (arg = args.l.begin(); arg != args.l.end(); ++arg) {
+ if (gflag ? (!fnmatch(arg->c_str(), sym.s.c_str(), 0)) :
+ (*arg == sym.s)) {
+ matches = true;
+ break;
+ }
+ }
+ }
+ if (!matches) continue;
+ syms.insert(f);
+ l.push_back(env_sym(sym, it, interp.macenv.find(f),
+ interp.externals.find(f)));
+ }
+ if (fflag && tflag == 0) {
+ // also process the declared externals which don't have any rules yet
+ for (extmap::const_iterator it = interp.externals.begin();
+ it != interp.externals.end(); ++it) {
+ int32_t f = it->first;
+ if (syms.find(f) == syms.end()) {
+ const symbol& sym = interp.symtab.sym(f);
+ if (sym.modno >= 0 && sym.modno != interp.modno ||
+ pflag >= 0 && (pflag > 0) != (sym.modno >= 0))
+ continue;
+ bool matches = true;
+ if (!args.l.empty()) {
+ matches = false;
+ for (arg = args.l.begin(); arg != args.l.end(); ++arg) {
+ if (gflag ? (!fnmatch(arg->c_str(), sym.s.c_str(), 0)) :
+ (*arg == sym.s)) {
+ matches = true;
+ break;
+ }
+ }
+ }
+ if (!matches) continue;
+ l.push_back(env_sym(sym, interp.globenv.end(),
+ interp.macenv.find(f), it));
+ }
+ }
+ }
+ if (mflag) {
+ // also dump any symbols defined as macros, unless they've already been
+ // considered
+ for (env::const_iterator it = interp.macenv.begin();
+ it != interp.macenv.end(); ++it) {
+ int32_t f = it->first;
+ if (syms.find(f) == syms.end()) {
+ const env_info& e = it->second;
+ const symbol& sym = interp.symtab.sym(f);
+ if (sym.modno >= 0 && sym.modno != interp.modno ||
+ pflag >= 0 && (pflag > 0) != (sym.modno >= 0))
+ continue;
+ bool matches = e.temp >= tflag;
+ if (!matches && args.l.empty()) {
+ // also dump temporary rules for a non-temporary symbol
+ rulel::const_iterator r;
+ for (r = e.rules->begin(); r != e.rules->end(); r++)
+ if (r->temp >= tflag) {
+ matches = true;
+ break;
+ }
+ }
+ if (!matches) continue;
+ if (!args.l.empty()) {
+ // see whether we actually want the defined symbol to be dumped
+ matches = false;
+ for (arg = args.l.begin(); arg != args.l.end(); ++arg) {
+ if (gflag ? (!fnmatch(arg->c_str(), sym.s.c_str(), 0)) :
+ (*arg == sym.s)) {
+ matches = true;
+ break;
+ }
+ }
+ }
+ if (!matches) continue;
+ syms.insert(f);
+ l.push_back(env_sym(sym, interp.globenv.end(), it,
+ interp.externals.end()));
+ }
+ }
+ }
+ l.sort(env_compare);
+ if (l.empty()) {
+ unlink(".pure");
+ goto out2;
+ }
+ ofstream fout;
+ fout.open(".pure");
+ for (list<env_sym>::const_iterator it = l.begin();
+ it != l.end(); ++it) {
+ const symbol& sym = *it->sym;
+ int32_t ftag = sym.f;
+ map<int32_t,Env>::iterator fenv = interp.globalfuns.find(ftag);
+ const env::const_iterator jt = it->it, kt = it->jt;
+ const extmap::const_iterator xt = it->xt;
+ if (jt == interp.globenv.end() && kt == interp.macenv.end()) {
+ assert(xt != interp.externals.end());
+ const ExternInfo& info = xt->second;
+ fout << info << ";\n";
+ } else if (jt != interp.globenv.end() &&
+ jt->second.t == env_info::fvar) {
+ fout << "let " << sym.s << " = " << *(pure_expr**)jt->second.val
+ << ";\n";
+ } else if (jt != interp.globenv.end() &&
+ jt->second.t == env_info::cvar) {
+ fout << "const " << sym.s << " = " << *jt->second.cval
+ << ";\n";
+ } else {
+ if (sym.fix == nullary)
+ fout << "nullary " << sym.s << ";\n";
+ else if (sym.prec < 10) {
+ switch (sym.fix) {
+ case infix:
+ fout << "infix"; break;
+ case infixl:
+ fout << "infixl"; break;
+ case infixr:
+ fout << "infixr"; break;
+ case prefix:
+ fout << "prefix"; break;
+ case postfix:
+ fout << "postfix"; break;
+ case nullary:
+ assert(0 && "this can't happen"); break;
+ }
+ fout << " " << (int)sym.prec << " " << sym.s << ";\n";
+ }
+ if (fflag && xt != interp.externals.end()) {
+ const ExternInfo& info = xt->second;
+ fout << info << ";\n";
+ }
+ if (mflag && kt != interp.macenv.end()) {
+ const rulel& rules = *kt->second.rules;
+ for (rulel::const_iterator it = rules.begin();
+ it != rules.end(); ++it) {
+ if (it->temp >= tflag) {
+ fout << "def " << *it << ";\n";
+ }
+ }
+ }
+ if (fflag && jt != interp.globenv.end()) {
+ const rulel& rules = *jt->second.rules;
+ for (rulel::const_iterator it = rules.begin();
+ it != rules.end(); ++it) {
+ if (it->temp >= tflag) {
+ fout << *it << ";\n";
+ }
+ }
+ }
+ }
+ }
+ }
+ out2:
+ ;
+}
^save.* {
// save command is only permitted in interactive mode
if (!interp.interactive) REJECT;
Modified: pure/trunk/pure.cc
===================================================================
--- pure/trunk/pure.cc 2008-09-06 16:59:50 UTC (rev 729)
+++ pure/trunk/pure.cc 2008-09-06 17:32:03 UTC (rev 730)
@@ -50,7 +50,7 @@
#define LICENSE "This program is free software distributed under the GNU Public License\n(GPL V3 or later). Please see the COPYING file for details.\n"
static const char *commands[] = {
- "cd", "clear", "const", "def", "extern", "help", "infix", "infixl",
+ "cd", "clear", "const", "def", "dump", "extern", "help", "infix", "infixl",
"infixr", "let", "ls", "nullary", "override", "postfix", "prefix",
"private", "pwd", "quit", "run", "save", "show", "stats", "underride",
"using", 0
@@ -448,6 +448,10 @@
interp.run(".purerc", false, sticky);
sticky = true;
}
+ if (chkfile(".pure")) {
+ interp.run(".pure", false, sticky);
+ sticky = true;
+ }
}
interp.run("", false, sticky);
if (interp.ttymode) cout << endl;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-06 18:04:27
|
Revision: 731
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=731&view=rev
Author: agraef
Date: 2008-09-06 18:04:33 +0000 (Sat, 06 Sep 2008)
Log Message:
-----------
Handle external objects in input more gracefully.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/lexer.ll
pure/trunk/parser.yy
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-06 17:32:03 UTC (rev 730)
+++ pure/trunk/interpreter.cc 2008-09-06 18:04:33 UTC (rev 731)
@@ -346,14 +346,17 @@
void
interpreter::error(const yy::location& l, const string& m)
{
+ string m1 = m;
+ if (m.find("bad token"))
+ m1 = "bad anonymous function or pointer value";
nerrs++;
if (source_s) {
ostringstream msg;
- msg << l << ": " << m << endl;
+ msg << l << ": " << m1 << endl;
errmsg += msg.str();
} else {
cout.flush();
- cerr << l << ": " << m << endl;
+ cerr << l << ": " << m1 << endl;
}
}
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-09-06 17:32:03 UTC (rev 730)
+++ pure/trunk/lexer.ll 2008-09-06 18:04:33 UTC (rev 731)
@@ -1214,6 +1214,7 @@
}
[@=|;()\[\]\\] return yy::parser::token_type(yytext[0]);
"->" return token::MAPSTO;
+"#<"{id}(" "{int})?">" return token::BADTOK;
([[:punct:]]|[\200-\377])+ {
if (yytext[0] == '/' && yytext[1] == '*') REJECT; // comment starter
while (yyleng > 1 && yytext[yyleng-1] == ';') yyless(yyleng-1);
Modified: pure/trunk/parser.yy
===================================================================
--- pure/trunk/parser.yy 2008-09-06 17:32:03 UTC (rev 730)
+++ pure/trunk/parser.yy 2008-09-06 18:04:33 UTC (rev 731)
@@ -222,6 +222,7 @@
%token EOFTOK 0 "end of file"
%token ERRTOK "invalid character"
+%token BADTOK "bad token"
%token MAPSTO "->"
%token <sval> ID "identifier"
%token <csval> STR "string"
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-07 07:21:06
|
Revision: 740
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=740&view=rev
Author: agraef
Date: 2008-09-07 07:21:17 +0000 (Sun, 07 Sep 2008)
Log Message:
-----------
Bugfixes.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-07 06:58:12 UTC (rev 739)
+++ pure/trunk/interpreter.cc 2008-09-07 07:21:17 UTC (rev 740)
@@ -2663,14 +2663,16 @@
{
interpreter& interp = *interpreter::g_interp;
assert(info.tag > 0);
- os << "extern " << interp.type_name(info.type) << " "
- << interp.symtab.sym(info.tag).s << "(";
+ const symbol& sym = interp.symtab.sym(info.tag);
+ os << "extern " << interp.type_name(info.type) << " " << info.name << "(";
size_t n = info.argtypes.size();
for (size_t i = 0; i < n; i++) {
if (i > 0) os << ", ";
os << interp.type_name(info.argtypes[i]);
}
- return os << ")";
+ os << ")";
+ if (sym.s != info.name) os << " = " << sym.s;
+ return os;
}
FMap& FMap::operator= (const FMap& f)
@@ -3452,7 +3454,7 @@
externals.find(sym.f) == externals.end())
// There already is a Pure function or global variable for this symbol.
// This is an error (unless the symbol is already declared as an external).
- throw err("symbol '"+name+"' is already defined as a Pure "+
+ throw err("symbol '"+asname+"' is already defined as a Pure "+
((globenv[sym.f].t == env_info::fun) ? "function" :
(globenv[sym.f].t == env_info::fvar) ? "variable" :
(globenv[sym.f].t == env_info::cvar) ? "constant" :
@@ -3491,7 +3493,7 @@
vector<const Type*> argt(n);
for (size_t i = 0; i < n; i++)
argt[i] = gt->getParamType(i);
- ExternInfo info(sym.f, gt->getReturnType(), argt, g);
+ ExternInfo info(sym.f, name, gt->getReturnType(), argt, g);
ostringstream msg;
msg << "declaration of extern function '" << name
<< "' does not match builtin declaration: " << info;
@@ -3884,7 +3886,7 @@
verifyFunction(*f);
if (FPM) FPM->run(*f);
if (verbose&verbosity::dump) f->print(std::cout);
- externals[sym.f] = ExternInfo(sym.f, type, argt, f);
+ externals[sym.f] = ExternInfo(sym.f, name, type, argt, f);
return f;
}
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-09-07 06:58:12 UTC (rev 739)
+++ pure/trunk/interpreter.hh 2008-09-07 07:21:17 UTC (rev 740)
@@ -274,15 +274,16 @@
struct ExternInfo {
// info about extern (C) functions callable from the Pure script
int32_t tag; // function symbol
+ string name; // real function name
const llvm::Type* type; // return type
vector<const llvm::Type*> argtypes; // argument types
llvm::Function *f; // Pure wrapper for the external
ExternInfo()
: tag(0), type(0), argtypes(0), f(0)
{}
- ExternInfo(int32_t _tag, const llvm::Type *_type,
+ ExternInfo(int32_t _tag, const string&_name, const llvm::Type *_type,
vector<const llvm::Type*> _argtypes, llvm::Function *_f)
- : tag(_tag), type(_type), argtypes(_argtypes), f(_f)
+ : tag(_tag), name(_name), type(_type), argtypes(_argtypes), f(_f)
{}
};
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-08 14:25:25
|
Revision: 745
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=745&view=rev
Author: agraef
Date: 2008-09-08 14:25:33 +0000 (Mon, 08 Sep 2008)
Log Message:
-----------
Add checks for signal functions (requires reconfigure).
Modified Paths:
--------------
pure/trunk/config/aclocal.m4
pure/trunk/config.h.in
pure/trunk/configure
pure/trunk/configure.ac
Modified: pure/trunk/config/aclocal.m4
===================================================================
--- pure/trunk/config/aclocal.m4 2008-09-08 14:24:48 UTC (rev 744)
+++ pure/trunk/config/aclocal.m4 2008-09-08 14:25:33 UTC (rev 745)
@@ -82,3 +82,105 @@
[Define if you have <langinfo.h> and nl_langinfo(CODESET).])
fi
])
+
+dnl Check type of signal routines (posix, 4.2bsd, 4.1bsd or v7).
+
+AC_DEFUN([AC_SIGNAL_CHECK],
+[AC_REQUIRE([AC_TYPE_SIGNAL])
+AC_MSG_CHECKING(for type of signal functions)
+AC_CACHE_VAL(q_cv_signal_vintage,
+[
+ AC_TRY_LINK([#include <signal.h>],[
+ sigset_t ss;
+ struct sigaction sa;
+ sigemptyset(&ss); sigsuspend(&ss);
+ sigaction(SIGINT, &sa, (struct sigaction *) 0);
+ sigprocmask(SIG_BLOCK, &ss, (sigset_t *) 0);
+ ], q_cv_signal_vintage=posix,
+ [
+ AC_TRY_LINK([#include <signal.h>], [
+ int mask = sigmask(SIGINT);
+ sigsetmask(mask); sigblock(mask); sigpause(mask);
+ ], q_cv_signal_vintage=4.2bsd,
+ [
+ AC_TRY_LINK([
+ #include <signal.h>
+ RETSIGTYPE foo() { }], [
+ int mask = sigmask(SIGINT);
+ sigset(SIGINT, foo); sigrelse(SIGINT);
+ sighold(SIGINT); sigpause(SIGINT);
+ ], q_cv_signal_vintage=svr3, q_cv_signal_vintage=v7
+ )]
+ )]
+)
+])
+AC_MSG_RESULT($q_cv_signal_vintage)
+if test "$q_cv_signal_vintage" = posix; then
+AC_DEFINE(HAVE_POSIX_SIGNALS, 1, [Define if POSIX signal functions are available.])
+elif test "$q_cv_signal_vintage" = "4.2bsd"; then
+AC_DEFINE(HAVE_BSD_SIGNALS, 1, [Define if BSD signal functions are available.])
+elif test "$q_cv_signal_vintage" = svr3; then
+AC_DEFINE(HAVE_USG_SIGHOLD, 1, [Define if SVR3 signal functions are available.])
+fi
+])
+
+dnl Check whether signal handlers must be reinstalled when invoked.
+
+AC_DEFUN([AC_REINSTALL_SIGHANDLERS],
+[AC_REQUIRE([AC_TYPE_SIGNAL])
+AC_REQUIRE([AC_SIGNAL_CHECK])
+AC_MSG_CHECKING([if signal handlers must be reinstalled when invoked])
+AC_CACHE_VAL(q_cv_must_reinstall_sighandlers,
+[AC_TRY_RUN([
+#include <signal.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+typedef RETSIGTYPE sigfunc();
+int nsigint;
+#ifdef HAVE_POSIX_SIGNALS
+sigfunc *
+set_signal_handler(sig, handler)
+ int sig;
+ sigfunc *handler;
+{
+ struct sigaction act, oact;
+ act.sa_handler = handler;
+ act.sa_flags = 0;
+ sigemptyset (&act.sa_mask);
+ sigemptyset (&oact.sa_mask);
+ sigaction (sig, &act, &oact);
+ return (oact.sa_handler);
+}
+#else
+#define set_signal_handler(s, h) signal(s, h)
+#endif
+RETSIGTYPE
+sigint(s)
+ int s;
+{
+ nsigint++;
+}
+main()
+{
+ nsigint = 0;
+ set_signal_handler(SIGINT, sigint);
+ kill((int)getpid(), SIGINT);
+ kill((int)getpid(), SIGINT);
+ exit(nsigint != 2);
+}
+], q_cv_must_reinstall_sighandlers=no, q_cv_must_reinstall_sighandlers=yes,
+if test "$q_cv_signal_vintage" = svr3; then
+ q_cv_must_reinstall_sighandlers=yes
+else
+ q_cv_must_reinstall_sighandlers=no
+fi)])
+if test "$cross_compiling" = yes; then
+ AC_MSG_RESULT([$q_cv_must_reinstall_sighandlers assumed for cross compilation])
+else
+ AC_MSG_RESULT($q_cv_must_reinstall_sighandlers)
+fi
+if test "$q_cv_must_reinstall_sighandlers" = yes; then
+ AC_DEFINE(MUST_REINSTALL_SIGHANDLERS, 1, [Define if signal handlers must be reinstalled by handler.])
+fi
+])
Modified: pure/trunk/config.h.in
===================================================================
--- pure/trunk/config.h.in 2008-09-08 14:24:48 UTC (rev 744)
+++ pure/trunk/config.h.in 2008-09-08 14:25:33 UTC (rev 745)
@@ -18,6 +18,9 @@
*/
#undef HAVE_ALLOCA_H
+/* Define if BSD signal functions are available. */
+#undef HAVE_BSD_SIGNALS
+
/* Define to 1 if you have the `ftime' function. */
#undef HAVE_FTIME
@@ -54,6 +57,9 @@
/* Define to 1 if you have the `nanosleep' function. */
#undef HAVE_NANOSLEEP
+/* Define if POSIX signal functions are available. */
+#undef HAVE_POSIX_SIGNALS
+
/* Define to 1 if you have the <stdint.h> header file. */
#undef HAVE_STDINT_H
@@ -75,6 +81,9 @@
/* Define to 1 if you have the <unistd.h> header file. */
#undef HAVE_UNISTD_H
+/* Define if SVR3 signal functions are available. */
+#undef HAVE_USG_SIGHOLD
+
/* Define to 1 if you have the `usleep' function. */
#undef HAVE_USLEEP
@@ -90,6 +99,9 @@
/* Define as const if the declaration of iconv() needs const. */
#undef ICONV_CONST
+/* Define if signal handlers must be reinstalled by handler. */
+#undef MUST_REINSTALL_SIGHANDLERS
+
/* Define to the address where bug reports for this package should be sent. */
#undef PACKAGE_BUGREPORT
@@ -105,6 +117,9 @@
/* Define to the version of this package. */
#undef PACKAGE_VERSION
+/* Define as the return type of signal handlers (`int' or `void'). */
+#undef RETSIGTYPE
+
/* The size of `void *', as computed by sizeof. */
#undef SIZEOF_VOID_P
Modified: pure/trunk/configure
===================================================================
--- pure/trunk/configure 2008-09-08 14:24:48 UTC (rev 744)
+++ pure/trunk/configure 2008-09-08 14:25:33 UTC (rev 745)
@@ -5472,6 +5472,352 @@
fi
done
+{ echo "$as_me:$LINENO: checking return type of signal handlers" >&5
+echo $ECHO_N "checking return type of signal handlers... $ECHO_C" >&6; }
+if test "${ac_cv_type_signal+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <sys/types.h>
+#include <signal.h>
+
+int
+main ()
+{
+return *(signal (0, 0)) (0) == 1;
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_type_signal=int
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_type_signal=void
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_type_signal" >&5
+echo "${ECHO_T}$ac_cv_type_signal" >&6; }
+
+cat >>confdefs.h <<_ACEOF
+#define RETSIGTYPE $ac_cv_type_signal
+_ACEOF
+
+
+
+{ echo "$as_me:$LINENO: checking for type of signal functions" >&5
+echo $ECHO_N "checking for type of signal functions... $ECHO_C" >&6; }
+if test "${q_cv_signal_vintage+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <signal.h>
+int
+main ()
+{
+
+ sigset_t ss;
+ struct sigaction sa;
+ sigemptyset(&ss); sigsuspend(&ss);
+ sigaction(SIGINT, &sa, (struct sigaction *) 0);
+ sigprocmask(SIG_BLOCK, &ss, (sigset_t *) 0);
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ q_cv_signal_vintage=posix
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <signal.h>
+int
+main ()
+{
+
+ int mask = sigmask(SIGINT);
+ sigsetmask(mask); sigblock(mask); sigpause(mask);
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ q_cv_signal_vintage=4.2bsd
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+ #include <signal.h>
+ RETSIGTYPE foo() { }
+int
+main ()
+{
+
+ int mask = sigmask(SIGINT);
+ sigset(SIGINT, foo); sigrelse(SIGINT);
+ sighold(SIGINT); sigpause(SIGINT);
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ q_cv_signal_vintage=svr3
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ q_cv_signal_vintage=v7
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+
+fi
+
+{ echo "$as_me:$LINENO: result: $q_cv_signal_vintage" >&5
+echo "${ECHO_T}$q_cv_signal_vintage" >&6; }
+if test "$q_cv_signal_vintage" = posix; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_POSIX_SIGNALS 1
+_ACEOF
+
+elif test "$q_cv_signal_vintage" = "4.2bsd"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_BSD_SIGNALS 1
+_ACEOF
+
+elif test "$q_cv_signal_vintage" = svr3; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_USG_SIGHOLD 1
+_ACEOF
+
+fi
+
+
+
+{ echo "$as_me:$LINENO: checking if signal handlers must be reinstalled when invoked" >&5
+echo $ECHO_N "checking if signal handlers must be reinstalled when invoked... $ECHO_C" >&6; }
+if test "${q_cv_must_reinstall_sighandlers+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if test "$cross_compiling" = yes; then
+ if test "$q_cv_signal_vintage" = svr3; then
+ q_cv_must_reinstall_sighandlers=yes
+else
+ q_cv_must_reinstall_sighandlers=no
+fi
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <signal.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+typedef RETSIGTYPE sigfunc();
+int nsigint;
+#ifdef HAVE_POSIX_SIGNALS
+sigfunc *
+set_signal_handler(sig, handler)
+ int sig;
+ sigfunc *handler;
+{
+ struct sigaction act, oact;
+ act.sa_handler = handler;
+ act.sa_flags = 0;
+ sigemptyset (&act.sa_mask);
+ sigemptyset (&oact.sa_mask);
+ sigaction (sig, &act, &oact);
+ return (oact.sa_handler);
+}
+#else
+#define set_signal_handler(s, h) signal(s, h)
+#endif
+RETSIGTYPE
+sigint(s)
+ int s;
+{
+ nsigint++;
+}
+main()
+{
+ nsigint = 0;
+ set_signal_handler(SIGINT, sigint);
+ kill((int)getpid(), SIGINT);
+ kill((int)getpid(), SIGINT);
+ exit(nsigint != 2);
+}
+
+_ACEOF
+rm -f conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+ { (case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ q_cv_must_reinstall_sighandlers=no
+else
+ echo "$as_me: program exited with status $ac_status" >&5
+echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+q_cv_must_reinstall_sighandlers=yes
+fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+
+
+fi
+
+if test "$cross_compiling" = yes; then
+ { echo "$as_me:$LINENO: result: $q_cv_must_reinstall_sighandlers assumed for cross compilation" >&5
+echo "${ECHO_T}$q_cv_must_reinstall_sighandlers assumed for cross compilation" >&6; }
+else
+ { echo "$as_me:$LINENO: result: $q_cv_must_reinstall_sighandlers" >&5
+echo "${ECHO_T}$q_cv_must_reinstall_sighandlers" >&6; }
+fi
+if test "$q_cv_must_reinstall_sighandlers" = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define MUST_REINSTALL_SIGHANDLERS 1
+_ACEOF
+
+fi
+
{ echo "$as_me:$LINENO: checking for _Complex float" >&5
echo $ECHO_N "checking for _Complex float... $ECHO_C" >&6; }
if test "${ac_cv_type__Complex_float+set}" = set; then
Modified: pure/trunk/configure.ac
===================================================================
--- pure/trunk/configure.ac 2008-09-08 14:24:48 UTC (rev 744)
+++ pure/trunk/configure.ac 2008-09-08 14:25:33 UTC (rev 745)
@@ -91,6 +91,8 @@
AC_FUNC_ALLOCA
dnl Platform-dependent time functions.
AC_CHECK_FUNCS(ftime gettimeofday nanosleep usleep)
+dnl Platform specifics of signal handlers.
+AC_REINSTALL_SIGHANDLERS
dnl Check to see whether we have POSIX/ISOC99 complex numbers.
AC_CHECK_TYPES([_Complex float, _Complex double])
AC_CONFIG_FILES([Makefile])
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-11 15:53:53
|
Revision: 750
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=750&view=rev
Author: agraef
Date: 2008-09-11 15:54:04 +0000 (Thu, 11 Sep 2008)
Log Message:
-----------
Handle thunked values in runtime routines.
Modified Paths:
--------------
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-11 14:47:38 UTC (rev 749)
+++ pure/trunk/runtime.cc 2008-09-11 15:54:04 UTC (rev 750)
@@ -1387,12 +1387,14 @@
}
}
+#define is_thunk(x) ((x)->tag == 0 && (x)->data.clos && (x)->data.clos->n == 0)
+
extern "C"
pure_expr *pure_force(pure_expr *x)
{
char test;
assert(x);
- if (x->tag == 0 && x->data.clos && x->data.clos->n == 0) {
+ if (is_thunk(x)) {
// parameterless anonymous closure (thunk)
assert(x->data.clos->thunked);
pure_expr *ret;
@@ -1438,12 +1440,12 @@
else
ret = ((pure_expr*(*)())fp)();
#if DEBUG>1
- cerr << "pure_force: result " << x << " = " << ret << " -> " << (void*)ret << ", refc = " << ret->refc << endl;
+ cerr << "pure_force: result " << x << " = " << ret << " -> " << (void*)ret << ", refc = " << ret->refc << endl;
#endif
// check whether the result is again a thunk, then we have to evaluate
// that recursively
- if (ret->tag == 0 && ret->data.clos && ret->data.clos->n == 0)
- ret = pure_force(pure_new_internal(ret));
+ if (is_thunk(ret))
+ pure_force(pure_new_internal(ret));
pure_new_internal(ret);
// memoize the result
assert(x!=ret);
@@ -1485,7 +1487,7 @@
char test;
assert(x && y && x->refc > 0 && y->refc > 0);
// if the function in this call is a thunk, evaluate it now
- if (x->tag == 0 && x->data.clos && x->data.clos->n == 0) pure_force(x);
+ if (is_thunk(x)) pure_force(x);
// travel down the spine, count arguments
pure_expr *f = x, *f0, *ret;
uint32_t n = 1;
@@ -2019,6 +2021,7 @@
pure_expr *pure_intval(pure_expr *x)
{
assert(x);
+ if (is_thunk(x)) pure_force(x);
switch (x->tag) {
case EXPR::INT: return x;
case EXPR::BIGINT: return pure_int(pure_get_int(x));
@@ -2038,6 +2041,7 @@
pure_expr *pure_dblval(pure_expr *x)
{
assert(x);
+ if (is_thunk(x)) pure_force(x);
switch (x->tag) {
case EXPR::INT: return pure_double((double)x->data.i);
case EXPR::BIGINT: return pure_double(mpz_get_d(x->data.z));
@@ -2050,6 +2054,7 @@
pure_expr *pure_pointerval(pure_expr *x)
{
assert(x);
+ if (is_thunk(x)) pure_force(x);
switch (x->tag) {
case EXPR::PTR: return x;
case EXPR::STR: return pure_pointer(x->data.s);
@@ -2099,6 +2104,7 @@
pure_expr *pure_bigintval(pure_expr *x)
{
assert(x);
+ if (is_thunk(x)) pure_force(x);
if (x->tag == EXPR::BIGINT)
return x;
else if (x->tag == EXPR::PTR)
@@ -2465,12 +2471,17 @@
pure_expr *string_concat_list(pure_expr *xs)
{
// linear-time concatenation of a list of strings
+ assert(xs);
+ if (is_thunk(xs)) pure_force(xs);
// calculate the size of the result string
pure_expr *ys = xs, *z, *zs;
size_t n = 0;
- while (is_cons(ys, z, zs) && z->tag == EXPR::STR) {
+ while (is_cons(ys, z, zs)) {
+ if (is_thunk(z)) pure_force(z);
+ if (z->tag != EXPR::STR) break;
n += strlen(z->data.s);
ys = zs;
+ if (is_thunk(ys)) pure_force(ys);
}
if (!is_nil(ys)) return 0;
// allocate the result string
@@ -2593,9 +2604,10 @@
}
extern "C"
-uint32_t hash(const pure_expr *x)
+uint32_t hash(pure_expr *x)
{
char test;
+ if (is_thunk(x)) pure_force(x);
switch (x->tag) {
case EXPR::INT:
return (uint32_t)x->data.i;
@@ -2630,10 +2642,8 @@
char test;
if (x == y)
return 1;
- if (x->tag == 0 && x->data.clos && x->data.clos->n == 0)
- pure_force(x);
- if (y->tag == 0 && y->data.clos && y->data.clos->n == 0)
- pure_force(y);
+ if (is_thunk(x)) pure_force(x);
+ if (is_thunk(y)) pure_force(y);
if (x->tag != y->tag)
return 0;
else if (x->tag >= 0 && y->tag >= 0)
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-11 14:47:38 UTC (rev 749)
+++ pure/trunk/runtime.h 2008-09-11 15:54:04 UTC (rev 750)
@@ -545,7 +545,7 @@
/* Compute a 32 bit hash code of a Pure expression. This makes it possible to
use arbitary Pure values as keys in a hash table. */
-uint32_t hash(const pure_expr *x);
+uint32_t hash(pure_expr *x);
/* Check whether two objects are the "same" (syntactically). */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-11 20:30:39
|
Revision: 752
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=752&view=rev
Author: agraef
Date: 2008-09-11 20:30:06 +0000 (Thu, 11 Sep 2008)
Log Message:
-----------
Final touches (0.6 release).
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/NEWS
pure/trunk/README
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-11 16:13:05 UTC (rev 751)
+++ pure/trunk/ChangeLog 2008-09-11 20:30:06 UTC (rev 752)
@@ -1,3 +1,9 @@
+2008-09-11 Albert Graef <Dr....@t-...>
+
+ * 0.6 release.
+
+ * runtime.cc, lib/math.pure: More bugfixes.
+
2008-09-06 Albert Graef <Dr....@t-...>
* pure.cc, lexer.ll: Add 'dump' command. This is similar to
Modified: pure/trunk/NEWS
===================================================================
--- pure/trunk/NEWS 2008-09-11 16:13:05 UTC (rev 751)
+++ pure/trunk/NEWS 2008-09-11 20:30:06 UTC (rev 752)
@@ -1,5 +1,5 @@
-** Pure 0.6 (in progress)
+** Pure 0.6 2008-09-11
New stuff in this release (please see the ChangeLog and the manual for
details):
Modified: pure/trunk/README
===================================================================
--- pure/trunk/README 2008-09-11 16:13:05 UTC (rev 751)
+++ pure/trunk/README 2008-09-11 20:30:06 UTC (rev 752)
@@ -45,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.5 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
+Pure 0.6 (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.5/prelude.pure.
+Loaded prelude from /usr/local/lib/pure-0.6/prelude.pure.
> fact n = if n>0 then n*fact (n-1) else 1;
> map fact (1..10);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-11 22:06:44
|
Revision: 754
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=754&view=rev
Author: agraef
Date: 2008-09-11 22:06:53 +0000 (Thu, 11 Sep 2008)
Log Message:
-----------
Final touches (0.6 release).
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/NEWS
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-11 22:06:02 UTC (rev 753)
+++ pure/trunk/ChangeLog 2008-09-11 22:06:53 UTC (rev 754)
@@ -1,7 +1,11 @@
-2008-09-11 Albert Graef <Dr....@t-...>
+2008-09-12 Albert Graef <Dr....@t-...>
* 0.6 release.
+ * interpreter.cc: Speedups in pattern-matching code.
+
+2008-09-11 Albert Graef <Dr....@t-...>
+
* runtime.cc, lib/math.pure: More bugfixes.
2008-09-06 Albert Graef <Dr....@t-...>
Modified: pure/trunk/NEWS
===================================================================
--- pure/trunk/NEWS 2008-09-11 22:06:02 UTC (rev 753)
+++ pure/trunk/NEWS 2008-09-11 22:06:53 UTC (rev 754)
@@ -1,5 +1,5 @@
-** Pure 0.6 2008-09-11
+** Pure 0.6 2008-09-12
New stuff in this release (please see the ChangeLog and the manual for
details):
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-12 11:39:15
|
Revision: 759
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=759&view=rev
Author: agraef
Date: 2008-09-12 11:39:25 +0000 (Fri, 12 Sep 2008)
Log Message:
-----------
Add configury for GSL support.
Modified Paths:
--------------
pure/trunk/config.h.in
pure/trunk/configure
pure/trunk/configure.ac
pure/trunk/interpreter.cc
pure/trunk/pure.cc
pure/trunk/runtime.cc
Modified: pure/trunk/config.h.in
===================================================================
--- pure/trunk/config.h.in 2008-09-12 00:38:24 UTC (rev 758)
+++ pure/trunk/config.h.in 2008-09-12 11:39:25 UTC (rev 759)
@@ -27,6 +27,12 @@
/* Define to 1 if you have the `gettimeofday' function. */
#undef HAVE_GETTIMEOFDAY
+/* Define when building with GSL vector/matrix support. */
+#undef HAVE_GSL
+
+/* Define to 1 if you have the <gsl/gsl_version.h> header file. */
+#undef HAVE_GSL_GSL_VERSION_H
+
/* Define if you have the iconv() function. */
#undef HAVE_ICONV
@@ -42,9 +48,18 @@
/* Define to 1 if you have the `gmp' library (-lgmp). */
#undef HAVE_LIBGMP
+/* Define to 1 if you have the `gsl' library (-lgsl). */
+#undef HAVE_LIBGSL
+
+/* Define to 1 if you have the `gslcblas' library (-lgslcblas). */
+#undef HAVE_LIBGSLCBLAS
+
/* Define to 1 if you have the `iconv' library (-liconv). */
#undef HAVE_LIBICONV
+/* Define to 1 if you have the `m' library (-lm). */
+#undef HAVE_LIBM
+
/* Define to 1 if you have the `readline' library (-lreadline). */
#undef HAVE_LIBREADLINE
Modified: pure/trunk/configure
===================================================================
--- pure/trunk/configure 2008-09-12 00:38:24 UTC (rev 758)
+++ pure/trunk/configure 2008-09-12 11:39:25 UTC (rev 759)
@@ -1271,10 +1271,11 @@
Optional Features:
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --enable-release enable the release build
+ --enable-gsl build with GSL support (default, experimental)
--enable-debug enable the debug build
--enable-debug2 enable the maintenance build
- --disable-shared link the interpreter statically
+ --enable-release enable the release build
+ --enable-shared build the shared runtime library (default)
--enable-warnings enable compiler warnings (-Wall)
Optional Packages:
@@ -4280,10 +4281,11 @@
_ACEOF
-# Check whether --enable-release was given.
-if test "${enable_release+set}" = set; then
- enableval=$enable_release; case "${enableval}" in
- yes) CPPFLAGS="-DNDEBUG -DDEBUG=0"; CXXFLAGS="-O3" ;;
+gsllib=yes
+# Check whether --enable-gsl was given.
+if test "${enable_gsl+set}" = set; then
+ enableval=$enable_gsl; case "${enableval}" in
+ no) gsllib=no ;;
esac
fi
@@ -4301,6 +4303,13 @@
esac
fi
+# Check whether --enable-release was given.
+if test "${enable_release+set}" = set; then
+ enableval=$enable_release; case "${enableval}" in
+ yes) CPPFLAGS="-DNDEBUG -DDEBUG=0"; CXXFLAGS="-O3" ;;
+ esac
+fi
+
sharedlib=yes
# Check whether --enable-shared was given.
if test "${enable_shared+set}" = set; then
@@ -4460,6 +4469,77 @@
fi
+{ echo "$as_me:$LINENO: checking for cos in -lm" >&5
+echo $ECHO_N "checking for cos in -lm... $ECHO_C" >&6; }
+if test "${ac_cv_lib_m_cos+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lm $LIBS"
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char cos ();
+int
+main ()
+{
+return cos ();
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ ac_cv_lib_m_cos=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_lib_m_cos=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_lib_m_cos" >&5
+echo "${ECHO_T}$ac_cv_lib_m_cos" >&6; }
+if test $ac_cv_lib_m_cos = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define HAVE_LIBM 1
+_ACEOF
+
+ LIBS="-lm $LIBS"
+
+fi
+
+
{ echo "$as_me:$LINENO: checking for libiconv in -liconv" >&5
echo $ECHO_N "checking for libiconv in -liconv... $ECHO_C" >&6; }
if test "${ac_cv_lib_iconv_libiconv+set}" = set; then
@@ -5941,6 +6021,303 @@
fi
+if test $gsllib = yes; then
+
+{ echo "$as_me:$LINENO: checking for cblas_dgemm in -lgslcblas" >&5
+echo $ECHO_N "checking for cblas_dgemm in -lgslcblas... $ECHO_C" >&6; }
+if test "${ac_cv_lib_gslcblas_cblas_dgemm+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lgslcblas $LIBS"
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char cblas_dgemm ();
+int
+main ()
+{
+return cblas_dgemm ();
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ ac_cv_lib_gslcblas_cblas_dgemm=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_lib_gslcblas_cblas_dgemm=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_lib_gslcblas_cblas_dgemm" >&5
+echo "${ECHO_T}$ac_cv_lib_gslcblas_cblas_dgemm" >&6; }
+if test $ac_cv_lib_gslcblas_cblas_dgemm = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define HAVE_LIBGSLCBLAS 1
+_ACEOF
+
+ LIBS="-lgslcblas $LIBS"
+
+fi
+
+
+{ echo "$as_me:$LINENO: checking for gsl_blas_dgemm in -lgsl" >&5
+echo $ECHO_N "checking for gsl_blas_dgemm in -lgsl... $ECHO_C" >&6; }
+if test "${ac_cv_lib_gsl_gsl_blas_dgemm+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lgsl $LIBS"
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char gsl_blas_dgemm ();
+int
+main ()
+{
+return gsl_blas_dgemm ();
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ ac_cv_lib_gsl_gsl_blas_dgemm=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_lib_gsl_gsl_blas_dgemm=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_dgemm" >&5
+echo "${ECHO_T}$ac_cv_lib_gsl_gsl_blas_dgemm" >&6; }
+if test $ac_cv_lib_gsl_gsl_blas_dgemm = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define HAVE_LIBGSL 1
+_ACEOF
+
+ LIBS="-lgsl $LIBS"
+
+fi
+
+
+for ac_header in gsl/gsl_version.h
+do
+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ { echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+fi
+ac_res=`eval echo '${'$as_ac_Header'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+else
+ # Is the header compilable?
+{ echo "$as_me:$LINENO: checking $ac_header usability" >&5
+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; }
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+#include <$ac_header>
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_header_compiler=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_header_compiler=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
+echo "${ECHO_T}$ac_header_compiler" >&6; }
+
+# Is the header present?
+{ echo "$as_me:$LINENO: checking $ac_header presence" >&5
+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; }
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <$ac_header>
+_ACEOF
+if { (ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then
+ ac_header_preproc=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_header_preproc=no
+fi
+
+rm -f conftest.err conftest.$ac_ext
+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
+echo "${ECHO_T}$ac_header_preproc" >&6; }
+
+# So? What about this header?
+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
+ yes:no: )
+ { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
+echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
+ ac_header_preproc=yes
+ ;;
+ no:yes:* )
+ { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
+echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
+echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
+echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
+echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
+
+ ;;
+esac
+{ echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ eval "$as_ac_Header=\$ac_header_preproc"
+fi
+ac_res=`eval echo '${'$as_ac_Header'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+
+fi
+if test `eval echo '${'$as_ac_Header'}'` = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+
+done
+
+ gsllib=no
+ if test $ac_cv_lib_gsl_gsl_blas_dgemm = yes; then
+ if test $ac_cv_header_gsl_gsl_version_h = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_GSL 1
+_ACEOF
+
+ { echo "$as_me:$LINENO: result: Building with GSL support." >&5
+echo "${ECHO_T}Building with GSL support." >&6; }
+ gsllib=yes
+ fi
+ fi
+fi
ac_config_files="$ac_config_files Makefile"
cat >confcache <<\_ACEOF
@@ -7071,6 +7448,7 @@
Compiler: $CXX $CXXFLAGS $CPPFLAGS
Linker: $CXX $LDFLAGS $LIBS
Build libpure: $sharedlib
+ GSL support: $gsllib
Now run 'make' to build everything, and 'make install' to install this
software on your system. To remove the installed software at a later
@@ -7084,6 +7462,7 @@
Compiler: $CXX $CXXFLAGS $CPPFLAGS
Linker: $CXX $LDFLAGS $LIBS
Build libpure: $sharedlib
+ GSL support: $gsllib
Now run 'make' to build everything, and 'make install' to install this
software on your system. To remove the installed software at a later
Modified: pure/trunk/configure.ac
===================================================================
--- pure/trunk/configure.ac 2008-09-12 00:38:24 UTC (rev 758)
+++ pure/trunk/configure.ac 2008-09-12 11:39:25 UTC (rev 759)
@@ -44,10 +44,11 @@
dnl Determine pointer sizes. This will be 8 on 64 bit systems.
AC_CHECK_SIZEOF(void *)
dnl Parse --enable options.
-AC_ARG_ENABLE(release,
- [ --enable-release enable the release build],
+gsllib=yes
+AC_ARG_ENABLE(gsl,
+ [ --enable-gsl build with GSL support (default, experimental)],
[case "${enableval}" in
- yes) CPPFLAGS="-DNDEBUG -DDEBUG=0"; CXXFLAGS="-O3" ;;
+ no) gsllib=no ;;
esac])
AC_ARG_ENABLE(debug,
[ --enable-debug enable the debug build],
@@ -59,9 +60,14 @@
[case "${enableval}" in
yes) CPPFLAGS="-DDEBUG=2"; CXXFLAGS="-g" ;;
esac])
+AC_ARG_ENABLE(release,
+ [ --enable-release enable the release build],
+ [case "${enableval}" in
+ yes) CPPFLAGS="-DNDEBUG -DDEBUG=0"; CXXFLAGS="-O3" ;;
+ esac])
sharedlib=yes
AC_ARG_ENABLE(shared,
- [ --disable-shared link the interpreter statically],
+ [ --enable-shared build the shared runtime library (default)],
[case "${enableval}" in
no) LDFLAGS="$LDFLAGS $rdynamic"; sharedlib=no ;;
esac])
@@ -74,6 +80,7 @@
dnl Check for libraries.
AC_CHECK_LIB(gmp, __gmpz_init)
AC_CHECK_LIB(readline, readline)
+AC_CHECK_LIB(m, cos)
dnl On some systems iconv is in a separate library, and may actually be named
dnl libiconv.
AC_CHECK_LIB(iconv, libiconv)
@@ -95,6 +102,20 @@
AC_REINSTALL_SIGHANDLERS
dnl Check to see whether we have POSIX/ISOC99 complex numbers.
AC_CHECK_TYPES([_Complex float, _Complex double])
+dnl Check for GSL support.
+if test $gsllib = yes; then
+ AC_CHECK_LIB(gslcblas, cblas_dgemm)
+ AC_CHECK_LIB(gsl, gsl_blas_dgemm)
+ AC_CHECK_HEADERS([gsl/gsl_version.h])
+ gsllib=no
+ if test $ac_cv_lib_gsl_gsl_blas_dgemm = yes; then
+ if test $ac_cv_header_gsl_gsl_version_h = yes; then
+ AC_DEFINE(HAVE_GSL, 1, [Define when building with GSL vector/matrix support.])
+ AC_MSG_RESULT([Building with GSL support.])
+ gsllib=yes
+ fi
+ fi
+fi
AC_CONFIG_FILES([Makefile])
AC_OUTPUT
@@ -106,6 +127,7 @@
Compiler: $CXX $CXXFLAGS $CPPFLAGS
Linker: $CXX $LDFLAGS $LIBS
Build libpure: $sharedlib
+ GSL support: $gsllib
Now run 'make' to build everything, and 'make install' to install this
software on your system. To remove the installed software at a later
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-12 00:38:24 UTC (rev 758)
+++ pure/trunk/interpreter.cc 2008-09-12 11:39:25 UTC (rev 759)
@@ -14,6 +14,10 @@
#include "config.h"
+#ifdef HAVE_GSL
+#include <gsl/gsl_version.h>
+#endif
+
uint8_t interpreter::g_verbose = 0;
bool interpreter::g_interactive = false;
interpreter* interpreter::g_interp = 0;
@@ -339,6 +343,9 @@
defn("argv", args);
defn("version", pure_cstring_dup(version.c_str()));
defn("sysinfo", pure_cstring_dup(host.c_str()));
+#ifdef HAVE_GSL
+ defn("gsl_version", pure_cstring_dup(gsl_version));
+#endif
}
// Errors and warnings.
Modified: pure/trunk/pure.cc
===================================================================
--- pure/trunk/pure.cc 2008-09-12 00:38:24 UTC (rev 758)
+++ pure/trunk/pure.cc 2008-09-12 11:39:25 UTC (rev 759)
@@ -18,6 +18,10 @@
#include "config.h"
+#if HAVE_GSL
+#include <gsl/gsl_errno.h>
+#endif
+
using namespace std;
#ifndef HOST
@@ -339,6 +343,10 @@
// need to have USE_FASTCC in interpreter.hh enabled).
llvm::PerformTailCallOpt = true;
#endif
+#if defined(HAVE_GSL) && DEBUG<2
+ // Turn off GSL's own error handler which aborts the program.
+ gsl_set_error_handler_off();
+#endif
// scan the command line options
const string prog = *argv;
list<string> myargs;
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-12 00:38:24 UTC (rev 758)
+++ pure/trunk/runtime.cc 2008-09-12 11:39:25 UTC (rev 759)
@@ -34,6 +34,10 @@
#include "config.h"
#include "funcall.h"
+#ifdef HAVE_GSL
+#include <gsl/gsl_errno.h>
+#endif
+
// Hooks to report stack overflows and other kinds of hard errors.
#define checkstk(test) if (interpreter::stackmax > 0 && \
interpreter::stackdir*(&test - interpreter::baseptr) \
@@ -1059,6 +1063,10 @@
// need to have USE_FASTCC in interpreter.hh enabled).
llvm::PerformTailCallOpt = true;
#endif
+#if defined(HAVE_GSL) && DEBUG<2
+ // Turn off GSL's own error handler which aborts the program.
+ gsl_set_error_handler_off();
+#endif
// scan the command line options
list<string> myargs;
for (char **args = ++argv; *args; ++args)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-15 06:28:52
|
Revision: 764
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=764&view=rev
Author: agraef
Date: 2008-09-15 06:29:02 +0000 (Mon, 15 Sep 2008)
Log Message:
-----------
Move inf and nan definitions back to primitives.pure, but make sure that they come after the definition of the arithmetic operators, so that the double arithmetic gets expanded at compile time.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/lib/primitives.pure
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-15 05:45:18 UTC (rev 763)
+++ pure/trunk/interpreter.cc 2008-09-15 06:29:02 UTC (rev 764)
@@ -330,7 +330,6 @@
const string& host,
const list<string>& argv)
{
- static const double inf = 1.0e307 * 1.0e307, nan = inf-inf;
// command line arguments, system and version information
pure_expr *args = pure_const(symtab.nil_sym().f);
for (list<string>::const_reverse_iterator it = argv.rbegin();
@@ -347,8 +346,6 @@
#ifdef HAVE_GSL
defn("gsl_version", pure_cstring_dup(gsl_version));
#endif
- const_defn("inf", pure_double(inf));
- const_defn("nan", pure_double(nan));
}
// Errors and warnings.
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-09-15 05:45:18 UTC (rev 763)
+++ pure/trunk/lib/primitives.pure 2008-09-15 06:29:02 UTC (rev 764)
@@ -63,11 +63,6 @@
tuplep (x,xs) = 1;
tuplep _ = 0 otherwise;
-/* Predicates to check for IEEE floating point infinities and NaNs. */
-
-infp x = case x of x::double = x==inf || x==-inf; _ = 0 end;
-nanp x = case x of x::double = not (x==x); _ = 0 end;
-
/* Compute a 32 bit hash code of a Pure expression. */
extern int hash(expr*);
@@ -388,6 +383,16 @@
x::pointer==y::pointer = bigint x == bigint y;
x::pointer!=y::pointer = bigint x != bigint y;
+/* IEEE floating point infinities and NaNs. Place these after the definitions
+ of the built-in operators so that the double arithmetic works. */
+
+const inf = 1.0e307 * 1.0e307; const nan = inf-inf;
+
+/* Predicates to check for inf and nan values. */
+
+infp x = case x of x::double = x==inf || x==-inf; _ = 0 end;
+nanp x = case x of x::double = not (x==x); _ = 0 end;
+
/* Direct memory accesses. Use with care ... or else! */
private pointer_get_byte pointer_get_int pointer_get_double
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-15 06:48:14
|
Revision: 765
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=765&view=rev
Author: agraef
Date: 2008-09-15 06:48:25 +0000 (Mon, 15 Sep 2008)
Log Message:
-----------
Bump version number.
Modified Paths:
--------------
pure/trunk/INSTALL
pure/trunk/README
pure/trunk/configure
pure/trunk/configure.ac
Modified: pure/trunk/INSTALL
===================================================================
--- pure/trunk/INSTALL 2008-09-15 06:29:02 UTC (rev 764)
+++ pure/trunk/INSTALL 2008-09-15 06:48:25 UTC (rev 765)
@@ -76,7 +76,7 @@
section.
STEP 5. Configure, build and install Pure as follows (x.y denotes the current
-Pure version number, 0.6 at the time of this writing):
+Pure version number, 0.7 at the time of this writing):
$ cd pure-x.y
$ ./configure
@@ -114,10 +114,10 @@
Run Pure interactively as:
$ pure
-Pure 0.6 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
+Pure 0.7 (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.6/prelude.pure.
+Loaded prelude from /usr/local/lib/pure-0.7/prelude.pure.
Check that it works:
Modified: pure/trunk/README
===================================================================
--- pure/trunk/README 2008-09-15 06:29:02 UTC (rev 764)
+++ pure/trunk/README 2008-09-15 06:48:25 UTC (rev 765)
@@ -45,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.6 (i686-pc-linux-gnu) Copyright (c) 2008 by Albert Graef
+Pure 0.7 (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.6/prelude.pure.
+Loaded prelude from /usr/local/lib/pure-0.7/prelude.pure.
> fact n = if n>0 then n*fact (n-1) else 1;
> map fact (1..10);
Modified: pure/trunk/configure
===================================================================
--- pure/trunk/configure 2008-09-15 06:29:02 UTC (rev 764)
+++ pure/trunk/configure 2008-09-15 06:48:25 UTC (rev 765)
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.61 for pure 0.6.
+# Generated by GNU Autoconf 2.61 for pure 0.7.
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
@@ -572,8 +572,8 @@
# Identity of this package.
PACKAGE_NAME='pure'
PACKAGE_TARNAME='pure'
-PACKAGE_VERSION='0.6'
-PACKAGE_STRING='pure 0.6'
+PACKAGE_VERSION='0.7'
+PACKAGE_STRING='pure 0.7'
PACKAGE_BUGREPORT=''
# Factoring default headers for most tests.
@@ -1199,7 +1199,7 @@
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures pure 0.6 to adapt to many kinds of systems.
+\`configure' configures pure 0.7 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1264,7 +1264,7 @@
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of pure 0.6:";;
+ short | recursive ) echo "Configuration of pure 0.7:";;
esac
cat <<\_ACEOF
@@ -1358,7 +1358,7 @@
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-pure configure 0.6
+pure configure 0.7
generated by GNU Autoconf 2.61
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
@@ -1372,7 +1372,7 @@
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by pure $as_me 0.6, which was
+It was created by pure $as_me 0.7, which was
generated by GNU Autoconf 2.61. Invocation command line was
$ $0 $@
@@ -6716,7 +6716,7 @@
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by pure $as_me 0.6, which was
+This file was extended by pure $as_me 0.7, which was
generated by GNU Autoconf 2.61. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -6765,7 +6765,7 @@
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
-pure config.status 0.6
+pure config.status 0.7
configured by $0, generated by GNU Autoconf 2.61,
with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
Modified: pure/trunk/configure.ac
===================================================================
--- pure/trunk/configure.ac 2008-09-15 06:29:02 UTC (rev 764)
+++ pure/trunk/configure.ac 2008-09-15 06:48:25 UTC (rev 765)
@@ -2,7 +2,7 @@
dnl To regenerate the configury after changes:
dnl autoconf -I config && autoheader -I config
-AC_INIT(pure, 0.6)
+AC_INIT(pure, 0.7)
AC_CONFIG_AUX_DIR(config)
dnl AC_CONFIG_MACRO_DIR(config)
AC_CONFIG_HEADERS(config.h)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-16 12:07:39
|
Revision: 769
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=769&view=rev
Author: agraef
Date: 2008-09-16 12:07:48 +0000 (Tue, 16 Sep 2008)
Log Message:
-----------
Add basic GSL matrix infrastructure (not quite finished yet).
Modified Paths:
--------------
pure/trunk/expr.cc
pure/trunk/expr.hh
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
pure/trunk/lib/prelude.pure
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/expr.cc
===================================================================
--- pure/trunk/expr.cc 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/expr.cc 2008-09-16 12:07:48 UTC (rev 769)
@@ -29,6 +29,9 @@
if (data.x[1]) data.x[1]->del();
if (data.x[2]) data.x[2]->del();
break;
+ case MATRIX:
+ if (data.xs) delete data.xs;
+ break;
case CASE:
if (data.c.x) data.c.x->del();
if (data.c.r) delete data.c.r;
Modified: pure/trunk/expr.hh
===================================================================
--- pure/trunk/expr.hh 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/expr.hh 2008-09-16 12:07:48 UTC (rev 769)
@@ -72,6 +72,21 @@
size_t len() const { return size; }
};
+/* Smart expression pointers (see below for the full definition). These are
+ used recursively as components in matrix representations and rule lists in
+ the expression data structure. */
+
+class expr;
+
+/* Expression lists and lists of those. These are used to represent
+ collections of expressions and generic matrix data in a structured way
+ which facilitates code generation. In the case of exprll, each list member
+ represents a matrix "row" which is in turn described by a list of
+ "columns". */
+
+typedef list<expr> exprl;
+typedef list<exprl> exprll;
+
/* Rule lists are used to encode collections of equations and other rule sets
in 'case' expressions and the like. See the definition of the rule struct
at the end of this header. */
@@ -113,6 +128,16 @@
CASE = -10, // case expression
WHEN = -11, // when expression
WITH = -12, // with expression
+ // GSL matrix types:
+ MATRIX = -32, // generic GSL matrix, double matrix in runtime exprs
+ CMATRIX = -31, // complex matrix in runtime exprs
+ IMATRIX = -30, // integer matrix in runtime exprs
+ /* Other values in the range -17..-29 reserved for later use in the
+ runtime expression data structure. Note that all GSL-related tags,
+ taken as an unsigned binary quantity, are of the form 0xffffffe0+t,
+ where the least significant nibble t=0x0..0xf denotes corresponding
+ subtypes in runtime matrix data. For compile time expressions only the
+ EXPR::MATRIX tag (t=0) is used. */
};
// special flag values used during compilation:
@@ -137,6 +162,7 @@
uint8_t idx; // de Bruin index
} v;
EXPR *x[3]; // APP, LAMBDA, COND
+ exprll *xs; // MATRIX
struct { // CASE, WHEN, WITH
EXPR *x; // expression
union {
@@ -204,6 +230,9 @@
refc(0), tag(_tag), m(0), flags(0), ttag(0), astag(0), aspath(0)
{ assert(_tag == WITH);
data.c.x = newref(_arg); data.c.e = _e; }
+ EXPR(int32_t _tag, exprll *_args) :
+ refc(0), tag(_tag), m(0), flags(0), ttag(0), astag(0), aspath(0)
+ { assert(_tag == MATRIX); data.xs = _args; }
EXPR(EXPR *_fun, EXPR *_arg) :
refc(0), tag(APP), m(0), flags(0), ttag(0), astag(0), aspath(0)
{ data.x[0] = newref(_fun); data.x[1] = newref(_arg); }
@@ -222,9 +251,6 @@
/* Smart expression pointers. These take care of reference counting
automagically. */
-class expr;
-typedef list<expr> exprl;
-
class expr {
EXPR* p;
// debug helper
@@ -278,6 +304,8 @@
p(new EXPR(tag, &*arg, rules)) { p->incref(); }
expr(int32_t tag, expr arg, env *e) :
p(new EXPR(tag, &*arg, e)) { p->incref(); }
+ expr(int32_t tag, exprll *args) :
+ p(new EXPR(tag, args)) { p->incref(); }
expr(expr fun, expr arg) :
p(new EXPR(&*fun, &*arg)) { p->incref(); }
expr(expr fun, expr arg1, expr arg2) :
@@ -337,6 +365,8 @@
p->tag == EXPR::WHEN ||
p->tag == EXPR::WITH);
return expr(p->data.c.x); }
+ exprll *xvals() const { assert(p->tag == EXPR::MATRIX);
+ return p->data.xs; }
rulel *rules() const { assert(p->tag == EXPR::CASE ||
p->tag == EXPR::WHEN);
return p->data.c.r; }
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/interpreter.cc 2008-09-16 12:07:48 UTC (rev 769)
@@ -16,6 +16,7 @@
#ifdef HAVE_GSL
#include <gsl/gsl_version.h>
+#include <gsl/gsl_matrix.h>
#endif
uint8_t interpreter::g_verbose = 0;
@@ -246,6 +247,11 @@
declare_extern((void*)pure_apply,
"pure_apply", "expr*", 2, "expr*", "expr*");
+ declare_extern((void*)pure_matrix_rows,
+ "pure_matrix_rows", "expr*", -1, "int");
+ declare_extern((void*)pure_matrix_columns,
+ "pure_matrix_columns", "expr*", -1, "int");
+
declare_extern((void*)pure_listl,
"pure_listl", "expr*", -1, "int");
declare_extern((void*)pure_tuplel,
@@ -862,6 +868,68 @@
// Only null pointer constants permitted right now.
throw err("pointer must be null in constant definition");
return expr(EXPR::PTR, x->data.p);
+ case EXPR::MATRIX: {
+#ifdef HAVE_GSL
+ if (x->data.mat && x->data.mat->p) {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat->p;
+ exprll *xs = new exprll;
+ for (size_t i = 0; i < m->size1; i++) {
+ xs->push_back(exprl());
+ exprl& ys = xs->back();
+ for (size_t j = 0; j < m->size2; j++) {
+ ys.push_back(expr(EXPR::DBL, m->data[i * m->tda + j]));
+ }
+ }
+ return expr(EXPR::MATRIX, m);
+ } else
+ return expr(EXPR::MATRIX, new exprll);
+#else
+ throw err("GSL matrices not supported in this implementation");
+ return expr(EXPR::MATRIX, new exprll);
+#endif
+ }
+ case EXPR::IMATRIX: {
+#ifdef HAVE_GSL
+ if (x->data.mat && x->data.mat->p) {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat->p;
+ exprll *xs = new exprll;
+ for (size_t i = 0; i < m->size1; i++) {
+ xs->push_back(exprl());
+ exprl& ys = xs->back();
+ for (size_t j = 0; j < m->size2; j++) {
+ ys.push_back(expr(EXPR::INT, m->data[i * m->tda + j]));
+ }
+ }
+ return expr(EXPR::MATRIX, m);
+ } else
+ return expr(EXPR::MATRIX, new exprll);
+#else
+ throw err("GSL matrices not supported in this implementation");
+ return expr(EXPR::MATRIX, new exprll);
+#endif
+ }
+ case EXPR::CMATRIX: {
+#ifdef HAVE_GSL
+ if (x->data.mat && x->data.mat->p) {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat->p;
+ exprll *xs = new exprll;
+ for (size_t i = 0; i < m->size1; i++) {
+ xs->push_back(exprl());
+ exprl& ys = xs->back();
+ for (size_t j = 0; j < m->size2; j++) {
+ expr u = expr(EXPR::DBL, m->data[2*(i * m->tda + j)]);
+ expr v = expr(EXPR::DBL, m->data[2*(i * m->tda + j) + 1]);
+ ys.push_back(expr(symtab.complex_rect_sym().x, u, v));
+ }
+ }
+ return expr(EXPR::MATRIX, m);
+ } else
+ return expr(EXPR::MATRIX, new exprll);
+#else
+ throw err("GSL matrices not supported in this implementation");
+ return expr(EXPR::MATRIX, new exprll);
+#endif
+ }
default:
assert(x->tag > 0);
if (x->data.clos && x->data.clos->local)
@@ -1126,6 +1194,14 @@
{
if (x.is_null()) return;
switch (x.tag()) {
+ case EXPR::MATRIX:
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++)
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ compile(*ys);
+ }
+ break;
case EXPR::APP:
compile(x.xval1());
compile(x.xval2());
@@ -1578,6 +1654,9 @@
break;
}
// these must not occur on the lhs:
+ case EXPR::MATRIX:
+ throw err("matrix expression not permitted in pattern");
+ break;
case EXPR::LAMBDA:
throw err("lambda expression not permitted in pattern");
break;
@@ -1717,6 +1796,20 @@
case EXPR::STR:
case EXPR::PTR:
return x;
+ // matrix:
+ case EXPR::MATRIX: {
+ exprll *us = new exprll;
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++) {
+ us->push_back(exprl());
+ exprl& vs = us->back();
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ vs.push_back(subst(vars, *ys, idx));
+ }
+ }
+ return expr(EXPR::MATRIX, us);
+ }
// application:
case EXPR::APP:
if (x.xval1().tag() == symtab.amp_sym().f) {
@@ -1827,6 +1920,20 @@
case EXPR::STR:
case EXPR::PTR:
return x;
+ // matrix:
+ case EXPR::MATRIX: {
+ exprll *us = new exprll;
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++) {
+ us->push_back(exprl());
+ exprl& vs = us->back();
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ vs.push_back(fsubst(funs, *ys, idx));
+ }
+ }
+ return expr(EXPR::MATRIX, us);
+ }
// application:
case EXPR::APP:
if (x.xval1().tag() == symtab.amp_sym().f) {
@@ -1929,6 +2036,20 @@
case EXPR::STR:
case EXPR::PTR:
return x;
+ // matrix:
+ case EXPR::MATRIX: {
+ exprll *us = new exprll;
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++) {
+ us->push_back(exprl());
+ exprl& vs = us->back();
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ vs.push_back(csubst(*ys));
+ }
+ }
+ return expr(EXPR::MATRIX, us);
+ }
// application:
case EXPR::APP:
if (x.xval1().tag() == symtab.amp_sym().f) {
@@ -2044,6 +2165,20 @@
case EXPR::STR:
case EXPR::PTR:
return x;
+ // matrix:
+ case EXPR::MATRIX: {
+ exprll *us = new exprll;
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++) {
+ us->push_back(exprl());
+ exprl& vs = us->back();
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ vs.push_back(macsubst(*ys));
+ }
+ }
+ return expr(EXPR::MATRIX, us);
+ }
// application:
case EXPR::APP: {
expr u = macsubst(x.xval1()),
@@ -2132,6 +2267,20 @@
case EXPR::STR:
case EXPR::PTR:
return x;
+ // matrix:
+ case EXPR::MATRIX: {
+ exprll *us = new exprll;
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++) {
+ us->push_back(exprl());
+ exprl& vs = us->back();
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ vs.push_back(varsubst(*ys, offs));
+ }
+ }
+ return expr(EXPR::MATRIX, us);
+ }
// application:
case EXPR::APP: {
expr u = varsubst(x.xval1(), offs),
@@ -2226,6 +2375,20 @@
return v;
} else
return y;
+ // matrix:
+ case EXPR::MATRIX: {
+ exprll *us = new exprll;
+ for (exprll::iterator xs = y.xvals()->begin(), end = y.xvals()->end();
+ xs != end; xs++) {
+ us->push_back(exprl());
+ exprl& vs = us->back();
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ vs.push_back(macred(x, *ys, idx));
+ }
+ }
+ return expr(EXPR::MATRIX, us);
+ }
// application:
case EXPR::APP:
if (y.xval1().tag() == symtab.amp_sym().f) {
@@ -3034,6 +3197,14 @@
}
}
break;
+ case EXPR::MATRIX:
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++)
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++) {
+ build_map(*ys);
+ }
+ break;
case EXPR::APP: {
expr f; uint32_t n = count_args(x, f);
interpreter& interp = *interpreter::g_interp;
@@ -3919,6 +4090,8 @@
return pure_string_dup(x.sval());
case EXPR::PTR:
return pure_pointer(x.pval());
+ case EXPR::MATRIX:
+ return const_matrix_value(x);
case EXPR::APP:
return const_app_value(x);
default: {
@@ -3959,6 +4132,36 @@
}
}
+pure_expr *interpreter::const_matrix_value(expr x)
+{
+ size_t n = x.xvals()->size(), m = 0, i = 0, j = 0;
+ pure_expr **us = new pure_expr*[n], **vs = 0, *ret;
+ assert(us);
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++, i++) {
+ m = xs->size(); j = 0; vs = new pure_expr*[m];
+ assert(vs);
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++, j++) {
+ vs[j] = const_value(*ys);
+ if (!vs[j]) goto err;
+ }
+ us[i] = pure_matrix_columnsv(m, vs);
+ if (!us[i]) goto err;
+ delete[] vs;
+ }
+ ret = pure_matrix_rowsv(n, us);
+ delete[] us;
+ return ret;
+ err:
+ // bail out
+ for (size_t k = 0; k < j; k++) pure_freenew(vs[k]);
+ if (vs) delete[] vs;
+ for (size_t k = 0; k < i; k++) pure_freenew(us[k]);
+ if (us) delete[] us;
+ return 0;
+}
+
pure_expr *interpreter::const_app_value(expr x)
{
if (x.tag() == EXPR::APP) {
@@ -4802,6 +5005,25 @@
// FIXME: Only null pointers are supported right now.
assert(x.pval() == 0);
return pbox(x.pval());
+ // matrix:
+ case EXPR::MATRIX: {
+ size_t n = x.xvals()->size(), i = 1;
+ vector<Value*> us(n+1);
+ us[0] = UInt(n);
+ for (exprll::iterator xs = x.xvals()->begin(), end = x.xvals()->end();
+ xs != end; xs++, i++) {
+ size_t m = xs->size(), j = 1;
+ vector<Value*> vs(m+1);
+ vs[0] = UInt(m);
+ for (exprl::iterator ys = xs->begin(), end = xs->end();
+ ys != end; ys++, j++) {
+ vs[j] = codegen(*ys);
+ }
+ us[i] =
+ act_env().CreateCall(module->getFunction("pure_matrix_columns"), vs);
+ }
+ return act_env().CreateCall(module->getFunction("pure_matrix_rows"), us);
+ }
// application:
case EXPR::APP:
if (x.ttag() != 0) {
@@ -5928,6 +6150,9 @@
case EXPR::PTR:
assert(0 && "not implemented");
break;
+ case EXPR::MATRIX:
+ assert(0 && "not implemented");
+ break;
case EXPR::APP: {
// first match the tag...
BasicBlock *ok1bb = BasicBlock::Create("arg1");
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/interpreter.hh 2008-09-16 12:07:48 UTC (rev 769)
@@ -520,6 +520,7 @@
Env& act_env() { assert(!envstk.empty()); return *envstk.front(); }
Builder& act_builder() { return act_env().builder; }
pure_expr *const_value(expr x);
+ pure_expr *const_matrix_value(expr x);
pure_expr *const_app_value(expr x);
expr pure_expr_to_expr(pure_expr *x);
pure_expr *doeval(expr x, pure_expr*& e);
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/lib/prelude.pure 2008-09-16 12:07:48 UTC (rev 769)
@@ -27,6 +27,8 @@
nullary failed_cond; // failed conditional (guard, if-then-else)
nullary failed_match; // failed pattern match (lambda, case, etc.)
nullary stack_fault; // not enough stack space (PURE_STACK limit)
+nullary not_implemented; // operation not implemented
+// bad_matrix_value x; // error in matrix construction
/* Other exceptions defined by the prelude. */
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/printer.cc 2008-09-16 12:07:48 UTC (rev 769)
@@ -6,6 +6,12 @@
#include <sstream>
+#include "config.h"
+
+#ifdef HAVE_GSL
+#include <gsl/gsl_matrix.h>
+#endif
+
static inline const string& pname(int32_t f)
{
assert(f > 0);
@@ -60,6 +66,7 @@
case EXPR::VAR:
case EXPR::STR:
case EXPR::PTR:
+ case EXPR::MATRIX:
return 100;
case EXPR::FVAR:
return sym_nprec(x.vtag());
@@ -160,6 +167,8 @@
return os << "::double";
case EXPR::STR:
return os << "::string";
+ case EXPR::MATRIX:
+ return os << "::matrix";
default:
return os;
}
@@ -246,6 +255,30 @@
}
case EXPR::PTR:
return os << "#<pointer " << x.pval() << ">";
+ case EXPR::MATRIX: {
+ os << "{";
+ for (exprll::const_iterator xs = x.xvals()->begin(),
+ end = x.xvals()->end(); xs != end; ) {
+ size_t n = xs->size();
+ if (n>1 || n==1 && xs->front().is_pair()) {
+ // matrix elements at a precedence not larger than ',' have to be
+ // parenthesized
+ prec_t p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
+ for (exprl::const_iterator it = xs->begin(), end = xs->end();
+ it != end; ) {
+ os << paren(p, *it, pat);
+ if (++it != end) os << ",";
+ }
+ } else
+ for (exprl::const_iterator it = xs->begin(), end = xs->end();
+ it != end; ) {
+ printx(os, *it, pat);
+ if (++it != end) os << ",";
+ }
+ if (++xs != end) os << ";";
+ }
+ return os << "}";
+ }
case EXPR::APP: {
expr u, v, w, y;
exprl xs;
@@ -565,6 +598,9 @@
switch (x->tag) {
case EXPR::STR:
case EXPR::PTR:
+ case EXPR::MATRIX:
+ case EXPR::CMATRIX:
+ case EXPR::IMATRIX:
return 100;
case EXPR::INT:
if (x->data.i < 0)
@@ -718,6 +754,54 @@
}
case EXPR::PTR:
return os << "#<pointer " << x->data.p << ">";
+ /* NOTE: For performance reasons, we don't do any custom representations for
+ matrix elements. As a workaround, you can define __show__ on matrices as
+ a whole. */
+ case EXPR::MATRIX:
+ os << "{";
+ if (x->data.mat && x->data.mat->p) {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat->p;
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ os << m->data[i * m->tda + j];
+ }
+ }
+ }
+ return os << "}";
+ case EXPR::IMATRIX:
+ os << "{";
+ if (x->data.mat && x->data.mat->p) {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat->p;
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ os << m->data[i * m->tda + j];
+ }
+ }
+ }
+ return os << "}";
+ case EXPR::CMATRIX:
+ os << "{";
+ if (x->data.mat && x->data.mat->p) {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat->p;
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ /* GSL represents complex matrices using pairs of double values.
+ FIXME: We take a shortcut here by just printing complex numbers
+ in rectangular format using the +: operator defined in math.pure.
+ This has to be adapted when the representation in math.pure
+ changes. */
+ os << m->data[2*(i * m->tda + j)] << "+:"
+ << m->data[2*(i * m->tda + j) + 1];
+ }
+ }
+ }
+ return os << "}";
case EXPR::APP: {
list<const pure_expr*> xs;
prec_t p;
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/runtime.cc 2008-09-16 12:07:48 UTC (rev 769)
@@ -36,6 +36,7 @@
#ifdef HAVE_GSL
#include <gsl/gsl_errno.h>
+#include <gsl/gsl_matrix.h>
#endif
// Hooks to report stack overflows and other kinds of hard errors.
@@ -127,6 +128,12 @@
return pure_const(interpreter::g_interp->symtab.segfault_sym().f);
}
+static inline pure_expr* not_implemented_exception()
+{
+ if (!interpreter::g_interp) return 0;
+ return pure_const(interpreter::g_interp->symtab.not_implemented_sym().f);
+}
+
static inline pure_expr *get_sentry(pure_expr *x)
{
if (x==0)
@@ -263,6 +270,40 @@
return ret;
}
+static void pure_free_matrix(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ assert(x->data.mat && "pure_free_matrix: null data");
+ assert(x->data.mat->refc > 0 && "pure_free_matrix: unreferenced data");
+ assert(x->data.mat->p && "pure_free_matrix: corrupt data");
+ if (--x->data.mat->refc == 0) {
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat->p;
+ m->owner = 1;
+ gsl_matrix_free(m);
+ break;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat->p;
+ m->owner = 1;
+ gsl_matrix_complex_free(m);
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat->p;
+ m->owner = 1;
+ gsl_matrix_int_free(m);
+ break;
+ }
+ default:
+ assert(0 && "pure_free_matrix: corrupt data");
+ break;
+ }
+ }
+#endif
+}
+
#if 1
/* This is implemented (mostly) non-recursively to prevent stack overflows,
@@ -286,6 +327,7 @@
goto loop;
case EXPR::INT:
case EXPR::DBL:
+ case EXPR::PTR:
// nothing to do
break;
case EXPR::BIGINT:
@@ -294,8 +336,10 @@
case EXPR::STR:
free(x->data.s);
break;
- case EXPR::PTR:
- // noop right now, should provide installable hook in the future
+ case EXPR::MATRIX:
+ case EXPR::CMATRIX:
+ case EXPR::IMATRIX:
+ if (x->data.mat) pure_free_matrix(x);
break;
default:
assert(x->tag >= 0);
@@ -542,6 +586,110 @@
}
extern "C"
+pure_expr *pure_double_matrix(void *p)
+{
+#ifdef HAVE_GSL
+ return 0; // XXXTODO
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_complex_matrix(void *p)
+{
+#ifdef HAVE_GSL
+ return 0; // XXXTODO
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_int_matrix(void *p)
+{
+#ifdef HAVE_GSL
+ return 0; // XXXTODO
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_double_matrix_dup(const void *p)
+{
+#ifdef HAVE_GSL
+ return 0; // XXXTODO
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_complex_matrix_dup(const void *p)
+{
+#ifdef HAVE_GSL
+ return 0; // XXXTODO
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_int_matrix_dup(const void *p)
+{
+#ifdef HAVE_GSL
+ return 0; // XXXTODO
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_matrix_rowsl(uint32_t n, ...)
+{
+#ifdef HAVE_GSL
+ // XXXTODO
+ return 0;
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_matrix_rowsv(uint32_t n, pure_expr **elems)
+{
+#ifdef HAVE_GSL
+ // XXXTODO
+ return 0;
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_matrix_columnsl(uint32_t n, ...)
+{
+#ifdef HAVE_GSL
+ // XXXTODO
+ return 0;
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_matrix_columnsv(uint32_t n, pure_expr **elems)
+{
+#ifdef HAVE_GSL
+ // XXXTODO
+ return 0;
+#else
+ return 0;
+#endif
+}
+
+extern "C"
pure_expr *pure_app(pure_expr *fun, pure_expr *arg)
{
return pure_apply2(fun, arg);
@@ -726,6 +874,36 @@
}
extern "C"
+bool pure_is_double_matrix(const pure_expr *x, const void **p)
+{
+ if (x->tag == EXPR::MATRIX && x->data.mat) {
+ *p = x->data.mat->p;
+ return true;
+ } else
+ return false;
+}
+
+extern "C"
+bool pure_is_complex_matrix(const pure_expr *x, const void **p)
+{
+ if (x->tag == EXPR::CMATRIX && x->data.mat) {
+ *p = x->data.mat->p;
+ return true;
+ } else
+ return false;
+}
+
+extern "C"
+bool pure_is_int_matrix(const pure_expr *x, const void **p)
+{
+ if (x->tag == EXPR::IMATRIX && x->data.mat) {
+ *p = x->data.mat->p;
+ return true;
+ } else
+ return false;
+}
+
+extern "C"
bool pure_is_app(const pure_expr *x, pure_expr **fun, pure_expr **arg)
{
assert(x);
@@ -1355,7 +1533,43 @@
return &x->data.z;
}
+static inline pure_expr* bad_matrix_exception(pure_expr *x)
+{
+ if (!interpreter::g_interp) return 0;
+ pure_expr *f = pure_const(interpreter::g_interp->symtab.bad_matrix_sym().f);
+ if (x)
+ return pure_apply2(f, x);
+ else
+ return f;
+}
+
extern "C"
+pure_expr *pure_matrix_rows(uint32_t n, ...)
+{
+#ifdef HAVE_GSL
+ // XXXTODO
+ pure_throw(not_implemented_exception());
+ return 0;
+#else
+ pure_throw(not_implemented_exception());
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *pure_matrix_columns(uint32_t n, ...)
+{
+#ifdef HAVE_GSL
+ // XXXTODO
+ pure_throw(not_implemented_exception());
+ return 0;
+#else
+ pure_throw(not_implemented_exception());
+ return 0;
+#endif
+}
+
+extern "C"
pure_expr *pure_call(pure_expr *x)
{
char test;
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/runtime.h 2008-09-16 12:07:48 UTC (rev 769)
@@ -30,6 +30,16 @@
bool thunked; // thunked closure? (kept unevaluated)
} pure_closure;
+/* Matrix data. The GSL matrix data is represented as a void* whose actual
+ type depends on the expression tag. Different expressions may share the
+ same underlying memory block, so we do our own reference counting to manage
+ these. */
+
+typedef struct {
+ uint32_t refc; // reference counter
+ void *p; // pointer to GSL matrix struct
+} pure_matrix;
+
/* The runtime expression data structure. Keep this lean and mean. */
typedef struct _pure_expr {
@@ -44,6 +54,7 @@
double d; // double (EXPR::DBL)
char *s; // C string (EXPR::STR)
void *p; // generic pointer (EXPR::PTR)
+ pure_matrix *mat; // matrix data (EXPR::MATRIX et al)
pure_closure *clos; // closure (0 if none)
} data;
/* Internal fields (DO NOT TOUCH). The JIT doesn't care about these. */
@@ -115,6 +126,37 @@
pure_expr *pure_string(char *s);
pure_expr *pure_cstring(char *s);
+/* Matrix constructors. The given pointer must point to a valid GSL matrix
+ struct of the corresponding GSL matrix type (gsl_matrix, gsl_matrix_complex,
+ gsl_matrix_int). (These are just given as void* here to avoid depending on
+ the GSL headers which might not be available for some implementations.) In
+ the case of the _matrix routines, the matrix must be allocated dynamically
+ and Pure takes ownership of the matrix. The matrix_dup routines first take
+ a copy of the matrix, so the ownership of the original matrix remains with
+ the caller. The result is a Pure expression representing the matrix object,
+ or null if GSL matrix support is not available or some other error
+ occurs. */
+
+pure_expr *pure_double_matrix(void *p);
+pure_expr *pure_complex_matrix(void *p);
+pure_expr *pure_int_matrix(void *p);
+pure_expr *pure_double_matrix_dup(const void *p);
+pure_expr *pure_complex_matrix_dup(const void *p);
+pure_expr *pure_int_matrix_dup(const void *p);
+
+/* Convenience functions to construct a Pure matrix from a vector or a varargs
+ list of element expressions, which can be component matrices or scalars.
+ The pure_matrix_rows functions arrange the elements vertically, while the
+ pure_matrix_columns functions arrange them horizontally, given that the
+ other dimensions match. The elems vectors are owned by the caller and won't
+ be freed. A null expression is returned in case of an error (no matrix
+ support, dimension mismatch, or invalid element type). */
+
+pure_expr *pure_matrix_rowsl(uint32_t n, ...);
+pure_expr *pure_matrix_rowsv(uint32_t n, pure_expr **elems);
+pure_expr *pure_matrix_columnsl(uint32_t n, ...);
+pure_expr *pure_matrix_columnsv(uint32_t n, pure_expr **elems);
+
/* Function applications. pure_app applies the given function to the given
argument. The result is evaluated if possible (i.e., if it is a saturated
function call). Otherwise, the result is a literal application and
@@ -172,6 +214,14 @@
bool pure_is_string_dup(const pure_expr *x, char **s);
bool pure_is_cstring_dup(const pure_expr *x, char **s);
+/* Matrix deconstructors. The returned GSL matrix pointer (represented as a
+ const void*) points to memory owned by Pure which should be considered
+ read-only and must not be freed. */
+
+bool pure_is_double_matrix(const pure_expr *x, const void **p);
+bool pure_is_complex_matrix(const pure_expr *x, const void **p);
+bool pure_is_int_matrix(const pure_expr *x, const void **p);
+
/* Deconstruct literal applications. */
bool pure_is_app(const pure_expr *x, pure_expr **fun, pure_expr **arg);
@@ -345,6 +395,14 @@
int64_t pure_get_long(pure_expr *x);
int32_t pure_get_int(pure_expr *x);
+/* Additional matrix constructors. These work like pure_matrix_rowsl and
+ pure_matrix_columnsl in the public API, but are intended to be called
+ directly from generated code and raise the appropriate Pure exceptions in
+ case of an error condition. */
+
+pure_expr *pure_matrix_rows(uint32_t n, ...);
+pure_expr *pure_matrix_columns(uint32_t n, ...);
+
/* Execute a closure. If the given expression x (or x y in the case of
pure_apply) is a parameterless closure (or a saturated application of a
closure), call it with the appropriate parameters and environment, if
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/symtable.cc 2008-09-16 12:07:48 UTC (rev 769)
@@ -34,12 +34,17 @@
fdiv_sym();
div_sym();
mod_sym();
+ // complex_rect_sym() and complex_polar_sym() are not initialized here, as
+ // they're supposed to come from math.pure which is not included in the
+ // prelude
catch_sym();
catmap_sym();
failed_match_sym();
failed_cond_sym();
signal_sym();
segfault_sym();
+ not_implemented_sym();
+ bad_matrix_sym();
amp_sym();
}
@@ -363,6 +368,24 @@
return sym("mod", 7, infixl);
}
+symbol& symtable::complex_rect_sym()
+{
+ symbol *_sym = lookup("+:");
+ if (_sym)
+ return *_sym;
+ else
+ return sym("+", 5, infix);
+}
+
+symbol& symtable::complex_polar_sym()
+{
+ symbol *_sym = lookup("<:");
+ if (_sym)
+ return *_sym;
+ else
+ return sym("+", 5, infix);
+}
+
symbol& symtable::amp_sym()
{
symbol *_sym = lookup("&");
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-09-16 07:35:33 UTC (rev 768)
+++ pure/trunk/symtable.hh 2008-09-16 12:07:48 UTC (rev 769)
@@ -90,12 +90,16 @@
symbol& fdiv_sym();
symbol& div_sym();
symbol& mod_sym();
+ symbol& complex_rect_sym();
+ symbol& complex_polar_sym();
symbol& catch_sym() { return sym("catch"); }
symbol& catmap_sym() { return sym("catmap"); }
symbol& failed_match_sym() { return sym("failed_match"); }
symbol& failed_cond_sym() { return sym("failed_cond"); }
symbol& signal_sym() { return sym("signal"); }
symbol& segfault_sym() { return sym("stack_fault"); }
+ symbol& not_implemented_sym() { return sym("not_implemented"); }
+ symbol& bad_matrix_sym() { return sym("bad_matrix_value"); }
symbol& amp_sym();
};
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-16 12:45:19
|
Revision: 771
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=771&view=rev
Author: agraef
Date: 2008-09-16 12:45:29 +0000 (Tue, 16 Sep 2008)
Log Message:
-----------
Bugfixes.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-16 12:22:28 UTC (rev 770)
+++ pure/trunk/interpreter.cc 2008-09-16 12:45:29 UTC (rev 771)
@@ -870,8 +870,8 @@
return expr(EXPR::PTR, x->data.p);
case EXPR::MATRIX: {
#ifdef HAVE_GSL
- if (x->data.mat && x->data.mat->p) {
- gsl_matrix *m = (gsl_matrix*)x->data.mat->p;
+ if (x->data.mat.p) {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
exprll *xs = new exprll;
for (size_t i = 0; i < m->size1; i++) {
xs->push_back(exprl());
@@ -890,8 +890,8 @@
}
case EXPR::IMATRIX: {
#ifdef HAVE_GSL
- if (x->data.mat && x->data.mat->p) {
- gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat->p;
+ if (x->data.mat.p) {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
exprll *xs = new exprll;
for (size_t i = 0; i < m->size1; i++) {
xs->push_back(exprl());
@@ -910,8 +910,8 @@
}
case EXPR::CMATRIX: {
#ifdef HAVE_GSL
- if (x->data.mat && x->data.mat->p) {
- gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat->p;
+ if (x->data.mat.p) {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
exprll *xs = new exprll;
for (size_t i = 0; i < m->size1; i++) {
xs->push_back(exprl());
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-16 12:22:28 UTC (rev 770)
+++ pure/trunk/printer.cc 2008-09-16 12:45:29 UTC (rev 771)
@@ -759,8 +759,8 @@
a whole. */
case EXPR::MATRIX:
os << "{";
- if (x->data.mat && x->data.mat->p) {
- gsl_matrix *m = (gsl_matrix*)x->data.mat->p;
+ if (x->data.mat.p) {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
for (size_t i = 0; i < m->size1; i++) {
if (i > 0) os << ";";
for (size_t j = 0; j < m->size2; j++) {
@@ -772,8 +772,8 @@
return os << "}";
case EXPR::IMATRIX:
os << "{";
- if (x->data.mat && x->data.mat->p) {
- gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat->p;
+ if (x->data.mat.p) {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
for (size_t i = 0; i < m->size1; i++) {
if (i > 0) os << ";";
for (size_t j = 0; j < m->size2; j++) {
@@ -785,8 +785,8 @@
return os << "}";
case EXPR::CMATRIX:
os << "{";
- if (x->data.mat && x->data.mat->p) {
- gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat->p;
+ if (x->data.mat.p) {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
for (size_t i = 0; i < m->size1; i++) {
if (i > 0) os << ";";
for (size_t j = 0; j < m->size2; j++) {
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-16 12:22:28 UTC (rev 770)
+++ pure/trunk/runtime.cc 2008-09-16 12:45:29 UTC (rev 771)
@@ -272,26 +272,26 @@
static void pure_free_matrix(pure_expr *x)
{
- assert(x->data.mat && "pure_free_matrix: null data");
- assert(x->data.mat->refc > 0 && "pure_free_matrix: unreferenced data");
- assert(x->data.mat->p && "pure_free_matrix: corrupt data");
- bool owner = --x->data.mat->refc == 0;
+ if (!x->data.mat.p) return;
+ assert(x->data.mat.refc && "pure_free_matrix: corrupt data");
+ assert(*x->data.mat.refc > 0 && "pure_free_matrix: unreferenced data");
+ bool owner = --*x->data.mat.refc == 0;
#ifdef HAVE_GSL
switch (x->tag) {
case EXPR::MATRIX: {
- gsl_matrix *m = (gsl_matrix*)x->data.mat->p;
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
m->owner = owner;
gsl_matrix_free(m);
break;
}
case EXPR::CMATRIX: {
- gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat->p;
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
m->owner = owner;
gsl_matrix_complex_free(m);
break;
}
case EXPR::IMATRIX: {
- gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat->p;
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
m->owner = owner;
gsl_matrix_int_free(m);
break;
@@ -301,7 +301,7 @@
break;
}
#endif
- if (owner) free(x->data.mat);
+ if (owner) free(x->data.mat.refc);
}
#if 1
@@ -339,7 +339,7 @@
case EXPR::MATRIX:
case EXPR::CMATRIX:
case EXPR::IMATRIX:
- if (x->data.mat) pure_free_matrix(x);
+ pure_free_matrix(x);
break;
default:
assert(x->tag >= 0);
@@ -876,8 +876,8 @@
extern "C"
bool pure_is_double_matrix(const pure_expr *x, const void **p)
{
- if (x->tag == EXPR::MATRIX && x->data.mat) {
- *p = x->data.mat->p;
+ if (x->tag == EXPR::MATRIX) {
+ *p = x->data.mat.p;
return true;
} else
return false;
@@ -886,8 +886,8 @@
extern "C"
bool pure_is_complex_matrix(const pure_expr *x, const void **p)
{
- if (x->tag == EXPR::CMATRIX && x->data.mat) {
- *p = x->data.mat->p;
+ if (x->tag == EXPR::CMATRIX) {
+ *p = x->data.mat.p;
return true;
} else
return false;
@@ -896,8 +896,8 @@
extern "C"
bool pure_is_int_matrix(const pure_expr *x, const void **p)
{
- if (x->tag == EXPR::IMATRIX && x->data.mat) {
- *p = x->data.mat->p;
+ if (x->tag == EXPR::IMATRIX) {
+ *p = x->data.mat.p;
return true;
} else
return false;
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-16 12:22:28 UTC (rev 770)
+++ pure/trunk/runtime.h 2008-09-16 12:45:29 UTC (rev 771)
@@ -36,7 +36,7 @@
these. */
typedef struct {
- uint32_t refc; // reference counter
+ uint32_t *refc; // reference counter
void *p; // pointer to GSL matrix struct
} pure_matrix;
@@ -54,7 +54,7 @@
double d; // double (EXPR::DBL)
char *s; // C string (EXPR::STR)
void *p; // generic pointer (EXPR::PTR)
- pure_matrix *mat; // matrix data (EXPR::MATRIX et al)
+ pure_matrix mat; // matrix data (EXPR::MATRIX et al)
pure_closure *clos; // closure (0 if none)
} data;
/* Internal fields (DO NOT TOUCH). The JIT doesn't care about these. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-16 18:46:20
|
Revision: 775
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=775&view=rev
Author: agraef
Date: 2008-09-16 18:46:30 +0000 (Tue, 16 Sep 2008)
Log Message:
-----------
Add support for cmatrix and imatrix tags.
Modified Paths:
--------------
pure/trunk/lexer.ll
pure/trunk/printer.cc
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-09-16 18:36:59 UTC (rev 774)
+++ pure/trunk/lexer.ll 2008-09-16 18:46:30 UTC (rev 775)
@@ -255,6 +255,8 @@
strtag ::{blank}*string
ptrtag ::{blank}*pointer
mattag ::{blank}*matrix
+cmattag ::{blank}*cmatrix
+imattag ::{blank}*imatrix
%x comment xdecl xdecl_comment xusing xusing_comment
@@ -1187,6 +1189,8 @@
{strtag}/[^a-zA-Z_0-9] yylval->ival = EXPR::STR; return token::TAG;
{ptrtag}/[^a-zA-Z_0-9] yylval->ival = EXPR::PTR; return token::TAG;
{mattag}/[^a-zA-Z_0-9] yylval->ival = EXPR::MATRIX; return token::TAG;
+{cmattag}/[^a-zA-Z_0-9] yylval->ival = EXPR::CMATRIX; return token::TAG;
+{imattag}/[^a-zA-Z_0-9] yylval->ival = EXPR::IMATRIX; return token::TAG;
extern BEGIN(xdecl); return token::EXTERN;
infix yylval->fix = infix; return token::FIX;
infixl yylval->fix = infixl; return token::FIX;
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-16 18:36:59 UTC (rev 774)
+++ pure/trunk/printer.cc 2008-09-16 18:46:30 UTC (rev 775)
@@ -169,6 +169,10 @@
return os << "::string";
case EXPR::MATRIX:
return os << "::matrix";
+ case EXPR::CMATRIX:
+ return os << "::cmatrix";
+ case EXPR::IMATRIX:
+ return os << "::imatrix";
default:
return os;
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-17 08:32:38
|
Revision: 776
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=776&view=rev
Author: agraef
Date: 2008-09-17 08:32:48 +0000 (Wed, 17 Sep 2008)
Log Message:
-----------
Various fixes, partial implementation of matrix constructors.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-16 18:46:30 UTC (rev 775)
+++ pure/trunk/interpreter.cc 2008-09-17 08:32:48 UTC (rev 776)
@@ -913,13 +913,15 @@
if (x->data.mat.p) {
gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
exprll *xs = new exprll;
+ symbol *rect = symtab.complex_rect_sym();
+ expr f = rect?rect->x:symtab.pair_sym().x;
for (size_t i = 0; i < m->size1; i++) {
xs->push_back(exprl());
exprl& ys = xs->back();
for (size_t j = 0; j < m->size2; j++) {
expr u = expr(EXPR::DBL, m->data[2*(i * m->tda + j)]);
expr v = expr(EXPR::DBL, m->data[2*(i * m->tda + j) + 1]);
- ys.push_back(expr(symtab.complex_rect_sym().x, u, v));
+ ys.push_back(expr(f, u, v));
}
}
return expr(EXPR::MATRIX, m);
@@ -5031,7 +5033,10 @@
us[i] =
act_env().CreateCall(module->getFunction("pure_matrix_columns"), vs);
}
- return act_env().CreateCall(module->getFunction("pure_matrix_rows"), us);
+ if (n == 1)
+ return us[1];
+ else
+ return act_env().CreateCall(module->getFunction("pure_matrix_rows"), us);
}
// application:
case EXPR::APP:
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-16 18:46:30 UTC (rev 775)
+++ pure/trunk/printer.cc 2008-09-17 08:32:48 UTC (rev 776)
@@ -713,6 +713,26 @@
return false;
}
+static inline ostream& print_double(ostream& os, double d)
+{
+ char buf[64];
+ if (is_inf(d))
+ if (d > 0)
+ strcpy(buf, "inf");
+ else
+ strcpy(buf, "-inf");
+ else if (is_nan(d))
+ strcpy(buf, "nan");
+ else
+ my_formatd(buf, "%0.15g", d);
+ // make sure that the output conforms to Pure syntax
+ os << buf;
+ if (strchr("0123456789", buf[buf[0]=='-'?1:0]) &&
+ !strchr(buf, '.') && !strchr(buf, 'e') && !strchr(buf, 'E'))
+ os << ".0";
+ return os;
+}
+
ostream& operator << (ostream& os, const pure_expr *x)
{
char test;
@@ -720,7 +740,6 @@
interpreter::stackdir*(&test - interpreter::baseptr) >=
interpreter::stackmax)
throw err("stack overflow in printer");
- char buf[64];
assert(x);
if (pstr(os, (pure_expr*)x)) return os;
//os << "{" << x->refc << "}";
@@ -732,24 +751,8 @@
os << s << "L"; free(s);
return os;
}
- case EXPR::DBL: {
- double d = x->data.d;
- if (is_inf(d))
- if (d > 0)
- strcpy(buf, "inf");
- else
- strcpy(buf, "-inf");
- else if (is_nan(d))
- strcpy(buf, "nan");
- else
- my_formatd(buf, "%0.15g", d);
- // make sure that the output conforms to Pure syntax
- os << buf;
- if (strchr("0123456789", buf[buf[0]=='-'?1:0]) &&
- !strchr(buf, '.') && !strchr(buf, 'e') && !strchr(buf, 'E'))
- os << ".0";
- return os;
- }
+ case EXPR::DBL:
+ return print_double(os, x->data.d);
case EXPR::STR: {
char *s = printstr(x->data.s);
os << '"' << s << '"';
@@ -758,6 +761,7 @@
}
case EXPR::PTR:
return os << "#<pointer " << x->data.p << ">";
+#ifdef HAVE_GSL
/* NOTE: For performance reasons, we don't do any custom representations for
matrix elements. As a workaround, you can define __show__ on matrices as
a whole. */
@@ -769,7 +773,7 @@
if (i > 0) os << ";";
for (size_t j = 0; j < m->size2; j++) {
if (j > 0) os << ",";
- os << m->data[i * m->tda + j];
+ print_double(os, m->data[i * m->tda + j]);
}
}
}
@@ -791,21 +795,44 @@
os << "{";
if (x->data.mat.p) {
gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- /* GSL represents complex matrices using pairs of double values.
- FIXME: We take a shortcut here by just printing complex numbers
- in rectangular format using the +: operator defined in math.pure.
- This has to be adapted when the representation in math.pure
- changes. */
- os << m->data[2*(i * m->tda + j)] << "+:"
- << m->data[2*(i * m->tda + j) + 1];
+ /* GSL represents complex matrices using pairs of double values, while
+ Pure provides its own complex type in math.pure. If math.pure has
+ been loaded, then the '+:' operator is defined and we use this
+ representation. Otherwise, we print complex values as pairs of real
+ and imaginary part. */
+ symbol *rect = interpreter::g_interp->symtab.complex_rect_sym();
+ if (rect)
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ print_double(os, m->data[2*(i * m->tda + j)]);
+ os << rect->s;
+ print_double(os, m->data[2*(i * m->tda + j) + 1]);
+ }
}
- }
+ else
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ os << "(";
+ print_double(os, m->data[2*(i * m->tda + j)]);
+ os << ",";
+ print_double(os, m->data[2*(i * m->tda + j) + 1]);
+ os << ")";
+ }
+ }
}
return os << "}";
+#else
+ case EXPR::MATRIX:
+ return os << "#<matrix " << x->data.mat.p << ">";
+ case EXPR::IMATRIX:
+ return os << "#<imatrix " << x->data.mat.p << ">";
+ case EXPR::CMATRIX:
+ return os << "#<cmatrix " << x->data.mat.p << ">";
+#endif
case EXPR::APP: {
list<const pure_expr*> xs;
prec_t p;
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-16 18:46:30 UTC (rev 775)
+++ pure/trunk/runtime.cc 2008-09-17 08:32:48 UTC (rev 776)
@@ -301,7 +301,7 @@
break;
}
#endif
- if (owner) free(x->data.mat.refc);
+ if (owner) delete x->data.mat.refc;
}
#if 1
@@ -589,7 +589,15 @@
pure_expr *pure_double_matrix(void *p)
{
#ifdef HAVE_GSL
- return 0; // XXXTODO
+ gsl_matrix *m = (gsl_matrix*)p;
+ if (!m || !m->owner) return 0;
+ pure_expr *x = new_expr();
+ x->tag = EXPR::MATRIX;
+ x->data.mat.p = p;
+ x->data.mat.refc = new uint32_t;
+ *x->data.mat.refc = 1;
+ MEMDEBUG_NEW(x)
+ return x;
#else
return 0;
#endif
@@ -599,7 +607,15 @@
pure_expr *pure_complex_matrix(void *p)
{
#ifdef HAVE_GSL
- return 0; // XXXTODO
+ gsl_matrix_complex *m = (gsl_matrix_complex*)p;
+ if (!m || !m->owner) return 0;
+ pure_expr *x = new_expr();
+ x->tag = EXPR::CMATRIX;
+ x->data.mat.p = p;
+ x->data.mat.refc = new uint32_t;
+ *x->data.mat.refc = 1;
+ MEMDEBUG_NEW(x)
+ return x;
#else
return 0;
#endif
@@ -609,7 +625,15 @@
pure_expr *pure_int_matrix(void *p)
{
#ifdef HAVE_GSL
- return 0; // XXXTODO
+ gsl_matrix_int *m = (gsl_matrix_int*)p;
+ if (!m || !m->owner) return 0;
+ pure_expr *x = new_expr();
+ x->tag = EXPR::IMATRIX;
+ x->data.mat.p = p;
+ x->data.mat.refc = new uint32_t;
+ *x->data.mat.refc = 1;
+ MEMDEBUG_NEW(x)
+ return x;
#else
return 0;
#endif
@@ -619,7 +643,11 @@
pure_expr *pure_double_matrix_dup(const void *p)
{
#ifdef HAVE_GSL
- return 0; // XXXTODO
+ gsl_matrix *m1 = (gsl_matrix*)p;
+ if (!m1) return 0;
+ gsl_matrix *m2 = gsl_matrix_alloc(m1->size1, m1->size2);
+ gsl_matrix_memcpy(m2, m1);
+ return pure_double_matrix(m2);
#else
return 0;
#endif
@@ -629,7 +657,11 @@
pure_expr *pure_complex_matrix_dup(const void *p)
{
#ifdef HAVE_GSL
- return 0; // XXXTODO
+ gsl_matrix_complex *m1 = (gsl_matrix_complex*)p;
+ if (!m1) return 0;
+ gsl_matrix_complex *m2 = gsl_matrix_complex_alloc(m1->size1, m1->size2);
+ gsl_matrix_complex_memcpy(m2, m1);
+ return pure_complex_matrix(m2);
#else
return 0;
#endif
@@ -639,12 +671,194 @@
pure_expr *pure_int_matrix_dup(const void *p)
{
#ifdef HAVE_GSL
- return 0; // XXXTODO
+ gsl_matrix_int *m1 = (gsl_matrix_int*)p;
+ if (!m1) return 0;
+ gsl_matrix_int *m2 = gsl_matrix_int_alloc(m1->size1, m1->size2);
+ gsl_matrix_int_memcpy(m2, m1);
+ return pure_int_matrix(m2);
#else
return 0;
#endif
}
+#ifdef HAVE_GSL
+static pure_expr*
+double_matrix_rows(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
+{
+ gsl_matrix *mat = gsl_matrix_alloc(nrows, ncols);
+ if (!mat) return 0; // XXXTODO: empty matrices
+ double *data = mat->data;
+ size_t tda = mat->tda;
+ for (size_t count = 0, i = 0; count < n; count++) {
+ pure_expr *x = xs[count];
+ switch (x->tag) {
+ case EXPR::INT:
+ data[i++*tda] = (double)x->data.i;
+ break;
+ case EXPR::BIGINT:
+ data[i++*tda] = mpz_get_d(x->data.z);
+ break;
+ case EXPR::DBL:
+ data[i++*tda] = x->data.d;
+ break;
+ case EXPR::MATRIX: {
+ gsl_matrix *mat1 = (gsl_matrix*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; i++, j++)
+ memcpy(data+i*tda, mat1->data+j*mat1->tda, ncols*sizeof(double));
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *mat1 = (gsl_matrix_int*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; i++, j++)
+ for (size_t k = 0; k < mat1->size2; k++)
+ data[i*tda+k] = (double)mat1->data[j*mat1->tda+k];
+ break;
+ }
+ default:
+ assert(0 && "bad matrix element");
+ break;
+ }
+ pure_freenew(x);
+ }
+ return pure_double_matrix(mat);
+}
+
+static pure_expr*
+double_matrix_columns(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
+{
+ gsl_matrix *mat = gsl_matrix_alloc(nrows, ncols);
+ if (!mat) return 0; // XXXTODO: empty matrices
+ double *data = mat->data;
+ size_t tda = mat->tda;
+ for (size_t count = 0, i = 0; count < n; count++) {
+ pure_expr *x = xs[count];
+ switch (x->tag) {
+ case EXPR::INT:
+ data[i++] = (double)x->data.i;
+ break;
+ case EXPR::BIGINT:
+ data[i++] = mpz_get_d(x->data.z);
+ break;
+ case EXPR::DBL:
+ data[i++] = x->data.d;
+ break;
+ case EXPR::MATRIX: {
+ gsl_matrix *mat1 = (gsl_matrix*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; i++, j++)
+ memcpy(data+j*tda+i, mat1->data+j*mat1->tda, ncols*sizeof(double));
+ i += mat1->size2;
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *mat1 = (gsl_matrix_int*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; j++)
+ for (size_t k = 0; k < mat1->size2; k++)
+ data[j*tda+k+i] = (double)mat1->data[j*mat1->tda+k];
+ i += mat1->size2;
+ break;
+ }
+ default:
+ assert(0 && "bad matrix element");
+ break;
+ }
+ pure_freenew(x);
+ }
+ return pure_double_matrix(mat);
+}
+
+static pure_expr*
+int_matrix_rows(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
+{
+ gsl_matrix_int *mat = gsl_matrix_int_alloc(nrows, ncols);
+ if (!mat) return 0; // XXXTODO: empty matrices
+ int *data = mat->data;
+ size_t tda = mat->tda;
+ for (size_t count = 0, i = 0; count < n; count++) {
+ pure_expr *x = xs[count];
+ switch (x->tag) {
+ case EXPR::INT:
+ data[i++*tda] = x->data.i;
+ break;
+ case EXPR::BIGINT:
+ data[i++*tda] = pure_get_int(x);
+ break;
+ case EXPR::DBL:
+ data[i++*tda] = (int)x->data.d;
+ break;
+ case EXPR::MATRIX: {
+ gsl_matrix_int *mat1 = (gsl_matrix_int*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; i++, j++)
+ for (size_t k = 0; k < mat1->size2; k++)
+ data[i*tda+k] = (int)mat1->data[j*mat1->tda+k];
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix *mat1 = (gsl_matrix*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; i++, j++)
+ memcpy(data+i*tda, mat1->data+j*mat1->tda, ncols*sizeof(int));
+ break;
+ }
+ default:
+ assert(0 && "bad matrix element");
+ break;
+ }
+ pure_freenew(x);
+ }
+ return pure_int_matrix(mat);
+}
+
+static pure_expr*
+int_matrix_columns(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
+{
+ gsl_matrix_int *mat = gsl_matrix_int_alloc(nrows, ncols);
+ if (!mat) return 0; // XXXTODO: empty matrices
+ int *data = mat->data;
+ size_t tda = mat->tda;
+ for (size_t count = 0, i = 0; count < n; count++) {
+ pure_expr *x = xs[count];
+ switch (x->tag) {
+ case EXPR::INT:
+ data[i++] = x->data.i;
+ break;
+ case EXPR::BIGINT:
+ data[i++] = pure_get_int(x);
+ break;
+ case EXPR::DBL:
+ data[i++] = (int)x->data.d;
+ break;
+ case EXPR::MATRIX: {
+ gsl_matrix_int *mat1 = (gsl_matrix_int*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; j++)
+ for (size_t k = 0; k < mat1->size2; k++)
+ data[j*tda+k+i] = (int)mat1->data[j*mat1->tda+k];
+ i += mat1->size2;
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix *mat1 = (gsl_matrix*)x->data.mat.p;
+ if (mat1)
+ for (size_t j = 0; j < mat1->size1; i++, j++)
+ memcpy(data+j*tda+i, mat1->data+j*mat1->tda, ncols*sizeof(int));
+ i += mat1->size2;
+ break;
+ }
+ default:
+ assert(0 && "bad matrix element");
+ break;
+ }
+ pure_freenew(x);
+ }
+ return pure_int_matrix(mat);
+}
+#endif
+
extern "C"
pure_expr *pure_matrix_rowsl(uint32_t n, ...)
{
@@ -1547,9 +1761,114 @@
pure_expr *pure_matrix_rows(uint32_t n, ...)
{
#ifdef HAVE_GSL
- // XXXTODO
- pure_throw(not_implemented_exception());
- return 0;
+ va_list ap;
+ va_start(ap, n);
+ pure_expr **xs = (pure_expr**)alloca(n*sizeof(pure_expr*));
+ size_t m = 0; int k = -1;
+ size_t nrows = 0, ncols = 0;
+ int32_t target = EXPR::IMATRIX;
+ for (size_t i = 0; i < n; i++) {
+ pure_expr *x = va_arg(ap, pure_expr*);
+ switch (x->tag) {
+ case EXPR::DBL:
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ case EXPR::INT:
+ case EXPR::BIGINT:
+ if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
+ xs[m++] = x; nrows++;
+ k = 1;
+ break;
+ case EXPR::APP: {
+ pure_expr *u = x->data.x[0], *v = x->data.x[1];
+ if (u->tag == EXPR::APP) {
+ interpreter& interp = *interpreter::g_interp;
+ pure_expr *f = u->data.x[0];
+ symbol *rect = interp.symtab.complex_rect_sym(),
+ *polar = interp.symtab.complex_polar_sym();
+ if ((!rect || f->tag != rect->f) &&
+ (!polar || f->tag != polar->f) &&
+ f->tag != interp.symtab.pair_sym().f)
+ pure_throw(bad_matrix_exception(x));
+ u = u->data.x[1];
+ if (u->tag != EXPR::INT && u->tag != EXPR::BIGINT &&
+ u->tag != EXPR::DBL)
+ pure_throw(bad_matrix_exception(x));
+ if (v->tag != EXPR::INT && v->tag != EXPR::BIGINT &&
+ v->tag != EXPR::DBL)
+ pure_throw(bad_matrix_exception(x));
+ } else
+ pure_throw(bad_matrix_exception(x));
+ if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
+ target = EXPR::CMATRIX;
+ xs[m++] = x; nrows++;
+ k = 1;
+ break;
+ }
+ case EXPR::MATRIX: {
+ gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ pure_throw(bad_matrix_exception(x));
+ if (mp->size1 > 0) xs[m++] = x;
+ nrows += mp->size1;
+ k = mp->size2;
+ } else if (k>0)
+ pure_throw(bad_matrix_exception(x));
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ break;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ pure_throw(bad_matrix_exception(x));
+ if (mp->size1 > 0) xs[m++] = x;
+ nrows += mp->size1;
+ k = mp->size2;
+ } else if (k>0)
+ pure_throw(bad_matrix_exception(x));
+ target = EXPR::CMATRIX;
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ pure_throw(bad_matrix_exception(x));
+ if (mp->size1 > 0) xs[m++] = x;
+ nrows += mp->size1;
+ k = mp->size2;
+ } else if (k>0)
+ pure_throw(bad_matrix_exception(x));
+ break;
+ }
+ default:
+ pure_throw(bad_matrix_exception(x));
+ break;
+ }
+ }
+ va_end(ap);
+ if (k < 0) k = 0;
+ ncols = k;
+ if (nrows == 0 && ncols == 0) target = EXPR::MATRIX;
+ pure_expr *ret = 0;
+ switch (target) {
+ case EXPR::MATRIX:
+ ret = double_matrix_rows(nrows, ncols, m, xs);
+ break;
+#if 0 // XXXTODO
+ case EXPR::CMATRIX:
+ ret = complex_matrix_rows(nrows, ncols, m, xs);
+ break;
+#endif
+ case EXPR::IMATRIX:
+ ret = int_matrix_rows(nrows, ncols, m, xs);
+ break;
+ default:
+ break;
+ }
+ if (!ret) pure_throw(not_implemented_exception());
+ return ret;
#else
pure_throw(not_implemented_exception());
return 0;
@@ -1560,9 +1879,114 @@
pure_expr *pure_matrix_columns(uint32_t n, ...)
{
#ifdef HAVE_GSL
- // XXXTODO
- pure_throw(not_implemented_exception());
- return 0;
+ va_list ap;
+ va_start(ap, n);
+ pure_expr **xs = (pure_expr**)alloca(n*sizeof(pure_expr*));
+ size_t m = 0; int k = -1;
+ size_t nrows = 0, ncols = 0;
+ int32_t target = EXPR::IMATRIX;
+ for (size_t i = 0; i < n; i++) {
+ pure_expr *x = va_arg(ap, pure_expr*);
+ switch (x->tag) {
+ case EXPR::DBL:
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ case EXPR::INT:
+ case EXPR::BIGINT:
+ if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
+ xs[m++] = x; ncols++;
+ k = 1;
+ break;
+ case EXPR::APP: {
+ pure_expr *u = x->data.x[0], *v = x->data.x[1];
+ if (u->tag == EXPR::APP) {
+ interpreter& interp = *interpreter::g_interp;
+ pure_expr *f = u->data.x[0];
+ symbol *rect = interp.symtab.complex_rect_sym(),
+ *polar = interp.symtab.complex_polar_sym();
+ if ((!rect || f->tag != rect->f) &&
+ (!polar || f->tag != polar->f) &&
+ f->tag != interp.symtab.pair_sym().f)
+ pure_throw(bad_matrix_exception(x));
+ u = u->data.x[1];
+ if (u->tag != EXPR::INT && u->tag != EXPR::BIGINT &&
+ u->tag != EXPR::DBL)
+ pure_throw(bad_matrix_exception(x));
+ if (v->tag != EXPR::INT && v->tag != EXPR::BIGINT &&
+ v->tag != EXPR::DBL)
+ pure_throw(bad_matrix_exception(x));
+ } else
+ pure_throw(bad_matrix_exception(x));
+ if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
+ target = EXPR::CMATRIX;
+ xs[m++] = x; ncols++;
+ k = 1;
+ break;
+ }
+ case EXPR::MATRIX: {
+ gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size1 != (size_t)k)
+ pure_throw(bad_matrix_exception(x));
+ if (mp->size2 > 0) xs[m++] = x;
+ ncols += mp->size2;
+ k = mp->size1;
+ } else if (k>0)
+ pure_throw(bad_matrix_exception(x));
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ break;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size1 != (size_t)k)
+ pure_throw(bad_matrix_exception(x));
+ if (mp->size2 > 0) xs[m++] = x;
+ ncols += mp->size2;
+ k = mp->size1;
+ } else if (k>0)
+ pure_throw(bad_matrix_exception(x));
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ pure_throw(bad_matrix_exception(x));
+ if (mp->size1 > 0) xs[m++] = x;
+ ncols += mp->size2;
+ k = mp->size2;
+ } else if (k>0)
+ pure_throw(bad_matrix_exception(x));
+ target = EXPR::CMATRIX;
+ break;
+ }
+ default:
+ pure_throw(bad_matrix_exception(x));
+ break;
+ }
+ }
+ va_end(ap);
+ if (k < 0) k = 0;
+ nrows = k;
+ if (nrows == 0 && ncols == 0) target = EXPR::MATRIX;
+ pure_expr *ret = 0;
+ switch (target) {
+ case EXPR::MATRIX:
+ ret = double_matrix_columns(nrows, ncols, m, xs);
+ break;
+#if 0 // XXXTODO
+ case EXPR::CMATRIX:
+ ret = complex_matrix_columns(nrows, ncols, m, xs);
+ break;
+#endif
+ case EXPR::IMATRIX:
+ ret = int_matrix_columns(nrows, ncols, m, xs);
+ break;
+ default:
+ break;
+ }
+ if (!ret) pure_throw(not_implemented_exception());
+ return ret;
#else
pure_throw(not_implemented_exception());
return 0;
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-09-16 18:46:30 UTC (rev 775)
+++ pure/trunk/symtable.cc 2008-09-17 08:32:48 UTC (rev 776)
@@ -368,24 +368,6 @@
return sym("mod", 7, infixl);
}
-symbol& symtable::complex_rect_sym()
-{
- symbol *_sym = lookup("+:");
- if (_sym)
- return *_sym;
- else
- return sym("+", 5, infix);
-}
-
-symbol& symtable::complex_polar_sym()
-{
- symbol *_sym = lookup("<:");
- if (_sym)
- return *_sym;
- else
- return sym("+", 5, infix);
-}
-
symbol& symtable::amp_sym()
{
symbol *_sym = lookup("&");
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-09-16 18:46:30 UTC (rev 775)
+++ pure/trunk/symtable.hh 2008-09-17 08:32:48 UTC (rev 776)
@@ -90,8 +90,6 @@
symbol& fdiv_sym();
symbol& div_sym();
symbol& mod_sym();
- symbol& complex_rect_sym();
- symbol& complex_polar_sym();
symbol& catch_sym() { return sym("catch"); }
symbol& catmap_sym() { return sym("catmap"); }
symbol& failed_match_sym() { return sym("failed_match"); }
@@ -101,6 +99,9 @@
symbol& not_implemented_sym() { return sym("not_implemented"); }
symbol& bad_matrix_sym() { return sym("bad_matrix_value"); }
symbol& amp_sym();
+ // these may be undefined
+ symbol* complex_rect_sym() { return lookup("+:"); }
+ symbol* complex_polar_sym() { return lookup("<:"); }
};
#endif // ! SYMTABLE_HH
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-17 15:26:10
|
Revision: 777
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=777&view=rev
Author: agraef
Date: 2008-09-17 15:05:12 +0000 (Wed, 17 Sep 2008)
Log Message:
-----------
Bugfixes.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-17 08:32:48 UTC (rev 776)
+++ pure/trunk/interpreter.cc 2008-09-17 15:05:12 UTC (rev 777)
@@ -5033,10 +5033,7 @@
us[i] =
act_env().CreateCall(module->getFunction("pure_matrix_columns"), vs);
}
- if (n == 1)
- return us[1];
- else
- return act_env().CreateCall(module->getFunction("pure_matrix_rows"), us);
+ return act_env().CreateCall(module->getFunction("pure_matrix_rows"), us);
}
// application:
case EXPR::APP:
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-17 08:32:48 UTC (rev 776)
+++ pure/trunk/runtime.cc 2008-09-17 15:05:12 UTC (rev 777)
@@ -686,11 +686,19 @@
double_matrix_rows(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
{
gsl_matrix *mat = gsl_matrix_alloc(nrows, ncols);
- if (!mat) return 0; // XXXTODO: empty matrices
+ if (!mat) {
+ // XXXTODO: empty matrices
+ for (size_t i = 0; i < n; i++)
+ pure_new_internal(xs[i]);
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
+ return 0;
+ }
double *data = mat->data;
size_t tda = mat->tda;
for (size_t count = 0, i = 0; count < n; count++) {
pure_expr *x = xs[count];
+ pure_new_internal(x);
switch (x->tag) {
case EXPR::INT:
data[i++*tda] = (double)x->data.i;
@@ -720,8 +728,9 @@
assert(0 && "bad matrix element");
break;
}
- pure_freenew(x);
}
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
return pure_double_matrix(mat);
}
@@ -729,11 +738,19 @@
double_matrix_columns(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
{
gsl_matrix *mat = gsl_matrix_alloc(nrows, ncols);
- if (!mat) return 0; // XXXTODO: empty matrices
+ if (!mat) {
+ // XXXTODO: empty matrices
+ for (size_t i = 0; i < n; i++)
+ pure_new_internal(xs[i]);
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
+ return 0;
+ }
double *data = mat->data;
size_t tda = mat->tda;
for (size_t count = 0, i = 0; count < n; count++) {
pure_expr *x = xs[count];
+ pure_new_internal(x);
switch (x->tag) {
case EXPR::INT:
data[i++] = (double)x->data.i;
@@ -747,8 +764,9 @@
case EXPR::MATRIX: {
gsl_matrix *mat1 = (gsl_matrix*)x->data.mat.p;
if (mat1)
- for (size_t j = 0; j < mat1->size1; i++, j++)
- memcpy(data+j*tda+i, mat1->data+j*mat1->tda, ncols*sizeof(double));
+ for (size_t j = 0; j < mat1->size1; j++)
+ memcpy(data+j*tda+i, mat1->data+j*mat1->tda,
+ mat1->size2*sizeof(double));
i += mat1->size2;
break;
}
@@ -765,8 +783,9 @@
assert(0 && "bad matrix element");
break;
}
- pure_freenew(x);
}
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
return pure_double_matrix(mat);
}
@@ -774,11 +793,19 @@
int_matrix_rows(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
{
gsl_matrix_int *mat = gsl_matrix_int_alloc(nrows, ncols);
- if (!mat) return 0; // XXXTODO: empty matrices
+ if (!mat) {
+ // XXXTODO: empty matrices
+ for (size_t i = 0; i < n; i++)
+ pure_new_internal(xs[i]);
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
+ return 0;
+ }
int *data = mat->data;
size_t tda = mat->tda;
for (size_t count = 0, i = 0; count < n; count++) {
pure_expr *x = xs[count];
+ pure_new_internal(x);
switch (x->tag) {
case EXPR::INT:
data[i++*tda] = x->data.i;
@@ -808,8 +835,9 @@
assert(0 && "bad matrix element");
break;
}
- pure_freenew(x);
}
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
return pure_int_matrix(mat);
}
@@ -817,11 +845,19 @@
int_matrix_columns(size_t nrows, size_t ncols, size_t n, pure_expr **xs)
{
gsl_matrix_int *mat = gsl_matrix_int_alloc(nrows, ncols);
- if (!mat) return 0; // XXXTODO: empty matrices
+ if (!mat) {
+ // XXXTODO: empty matrices
+ for (size_t i = 0; i < n; i++)
+ pure_new_internal(xs[i]);
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
+ return 0;
+ }
int *data = mat->data;
size_t tda = mat->tda;
for (size_t count = 0, i = 0; count < n; count++) {
pure_expr *x = xs[count];
+ pure_new_internal(x);
switch (x->tag) {
case EXPR::INT:
data[i++] = x->data.i;
@@ -844,8 +880,9 @@
case EXPR::IMATRIX: {
gsl_matrix *mat1 = (gsl_matrix*)x->data.mat.p;
if (mat1)
- for (size_t j = 0; j < mat1->size1; i++, j++)
- memcpy(data+j*tda+i, mat1->data+j*mat1->tda, ncols*sizeof(int));
+ for (size_t j = 0; j < mat1->size1; j++)
+ memcpy(data+j*tda+i, mat1->data+j*mat1->tda,
+ mat1->size2*sizeof(int));
i += mat1->size2;
break;
}
@@ -853,8 +890,9 @@
assert(0 && "bad matrix element");
break;
}
- pure_freenew(x);
}
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
return pure_int_matrix(mat);
}
#endif
@@ -1762,21 +1800,25 @@
{
#ifdef HAVE_GSL
va_list ap;
- va_start(ap, n);
pure_expr **xs = (pure_expr**)alloca(n*sizeof(pure_expr*));
- size_t m = 0; int k = -1;
+ int k = -1;
size_t nrows = 0, ncols = 0;
int32_t target = EXPR::IMATRIX;
+ bool have_matrix = false;
+ pure_expr *x = 0, *ret = 0;
+ va_start(ap, n);
+ for (size_t i = 0; i < n; i++)
+ xs[i] = va_arg(ap, pure_expr*);
+ va_end(ap);
for (size_t i = 0; i < n; i++) {
- pure_expr *x = va_arg(ap, pure_expr*);
+ x = xs[i];
switch (x->tag) {
case EXPR::DBL:
if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
case EXPR::INT:
case EXPR::BIGINT:
- if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
- xs[m++] = x; nrows++;
- k = 1;
+ if (k >= 0 && k != 1) goto err;
+ nrows++; k = 1;
break;
case EXPR::APP: {
pure_expr *u = x->data.x[0], *v = x->data.x[1];
@@ -1788,87 +1830,93 @@
if ((!rect || f->tag != rect->f) &&
(!polar || f->tag != polar->f) &&
f->tag != interp.symtab.pair_sym().f)
- pure_throw(bad_matrix_exception(x));
+ goto err;
u = u->data.x[1];
if (u->tag != EXPR::INT && u->tag != EXPR::BIGINT &&
u->tag != EXPR::DBL)
- pure_throw(bad_matrix_exception(x));
+ goto err;
if (v->tag != EXPR::INT && v->tag != EXPR::BIGINT &&
v->tag != EXPR::DBL)
- pure_throw(bad_matrix_exception(x));
+ goto err;
} else
- pure_throw(bad_matrix_exception(x));
- if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
+ goto err;
+ if (k >= 0 && k != 1) goto err;
target = EXPR::CMATRIX;
- xs[m++] = x; nrows++;
- k = 1;
+ nrows++; k = 1;
break;
}
case EXPR::MATRIX: {
gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
if (mp) {
if (k >= 0 && mp->size2 != (size_t)k)
- pure_throw(bad_matrix_exception(x));
- if (mp->size1 > 0) xs[m++] = x;
- nrows += mp->size1;
- k = mp->size2;
+ goto err;
+ nrows += mp->size1; k = mp->size2;
} else if (k>0)
- pure_throw(bad_matrix_exception(x));
+ goto err;
if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ have_matrix = true;
break;
}
case EXPR::CMATRIX: {
gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
if (mp) {
if (k >= 0 && mp->size2 != (size_t)k)
- pure_throw(bad_matrix_exception(x));
- if (mp->size1 > 0) xs[m++] = x;
- nrows += mp->size1;
- k = mp->size2;
+ goto err;
+ nrows += mp->size1; k = mp->size2;
} else if (k>0)
- pure_throw(bad_matrix_exception(x));
+ goto err;
target = EXPR::CMATRIX;
+ have_matrix = true;
break;
}
case EXPR::IMATRIX: {
gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
if (mp) {
if (k >= 0 && mp->size2 != (size_t)k)
- pure_throw(bad_matrix_exception(x));
- if (mp->size1 > 0) xs[m++] = x;
- nrows += mp->size1;
- k = mp->size2;
+ goto err;
+ nrows += mp->size1; k = mp->size2;
} else if (k>0)
- pure_throw(bad_matrix_exception(x));
+ goto err;
+ have_matrix = true;
break;
}
default:
- pure_throw(bad_matrix_exception(x));
+ goto err;
break;
}
}
- va_end(ap);
+ if (n == 1 && have_matrix) return xs[0];
if (k < 0) k = 0;
ncols = k;
if (nrows == 0 && ncols == 0) target = EXPR::MATRIX;
- pure_expr *ret = 0;
switch (target) {
case EXPR::MATRIX:
- ret = double_matrix_rows(nrows, ncols, m, xs);
+ ret = double_matrix_rows(nrows, ncols, n, xs);
break;
#if 0 // XXXTODO
case EXPR::CMATRIX:
- ret = complex_matrix_rows(nrows, ncols, m, xs);
+ ret = complex_matrix_rows(nrows, ncols, n, xs);
break;
#endif
case EXPR::IMATRIX:
- ret = int_matrix_rows(nrows, ncols, m, xs);
+ ret = int_matrix_rows(nrows, ncols, n, xs);
break;
default:
break;
}
if (!ret) pure_throw(not_implemented_exception());
return ret;
+ err:
+ /* This is called without a shadow stack frame, so we do our own cleanup
+ here to avoid having temporaries hanging around indefinitely. */
+ if (x) x->refc++;
+ for (size_t i = 0; i < n; i++)
+ pure_new_internal(xs[i]);
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
+ pure_unref_internal(x);
+ pure_throw(bad_matrix_exception(x));
+ return 0;
#else
pure_throw(not_implemented_exception());
return 0;
@@ -1880,21 +1928,25 @@
{
#ifdef HAVE_GSL
va_list ap;
- va_start(ap, n);
pure_expr **xs = (pure_expr**)alloca(n*sizeof(pure_expr*));
- size_t m = 0; int k = -1;
+ int k = -1;
size_t nrows = 0, ncols = 0;
int32_t target = EXPR::IMATRIX;
+ bool have_matrix = false;
+ pure_expr *x = 0, *ret = 0;
+ va_start(ap, n);
+ for (size_t i = 0; i < n; i++)
+ xs[i] = va_arg(ap, pure_expr*);
+ va_end(ap);
for (size_t i = 0; i < n; i++) {
- pure_expr *x = va_arg(ap, pure_expr*);
+ x = xs[i];
switch (x->tag) {
case EXPR::DBL:
if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
case EXPR::INT:
case EXPR::BIGINT:
- if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
- xs[m++] = x; ncols++;
- k = 1;
+ if (k >= 0 && k != 1) goto err;
+ ncols++; k = 1;
break;
case EXPR::APP: {
pure_expr *u = x->data.x[0], *v = x->data.x[1];
@@ -1906,87 +1958,93 @@
if ((!rect || f->tag != rect->f) &&
(!polar || f->tag != polar->f) &&
f->tag != interp.symtab.pair_sym().f)
- pure_throw(bad_matrix_exception(x));
+ goto err;
u = u->data.x[1];
if (u->tag != EXPR::INT && u->tag != EXPR::BIGINT &&
u->tag != EXPR::DBL)
- pure_throw(bad_matrix_exception(x));
+ goto err;
if (v->tag != EXPR::INT && v->tag != EXPR::BIGINT &&
v->tag != EXPR::DBL)
- pure_throw(bad_matrix_exception(x));
+ goto err;
} else
- pure_throw(bad_matrix_exception(x));
- if (k >= 0 && k != 1) pure_throw(bad_matrix_exception(x));
+ goto err;
+ if (k >= 0 && k != 1) goto err;
target = EXPR::CMATRIX;
- xs[m++] = x; ncols++;
- k = 1;
+ ncols++; k = 1;
break;
}
case EXPR::MATRIX: {
gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
if (mp) {
if (k >= 0 && mp->size1 != (size_t)k)
- pure_throw(bad_matrix_exception(x));
- if (mp->size2 > 0) xs[m++] = x;
- ncols += mp->size2;
- k = mp->size1;
+ goto err;
+ ncols += mp->size2; k = mp->size1;
} else if (k>0)
- pure_throw(bad_matrix_exception(x));
+ goto err;
if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ have_matrix = true;
break;
}
case EXPR::CMATRIX: {
gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
if (mp) {
if (k >= 0 && mp->size1 != (size_t)k)
- pure_throw(bad_matrix_exception(x));
- if (mp->size2 > 0) xs[m++] = x;
- ncols += mp->size2;
- k = mp->size1;
+ goto err;
+ ncols += mp->size2; k = mp->size1;
} else if (k>0)
- pure_throw(bad_matrix_exception(x));
+ goto err;
+ target = EXPR::CMATRIX;
+ have_matrix = true;
break;
}
case EXPR::IMATRIX: {
gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
if (mp) {
- if (k >= 0 && mp->size2 != (size_t)k)
- pure_throw(bad_matrix_exception(x));
- if (mp->size1 > 0) xs[m++] = x;
- ncols += mp->size2;
- k = mp->size2;
+ if (k >= 0 && mp->size1 != (size_t)k)
+ goto err;
+ ncols += mp->size2; k = mp->size1;
} else if (k>0)
- pure_throw(bad_matrix_exception(x));
- target = EXPR::CMATRIX;
+ goto err;
+ have_matrix = true;
break;
}
default:
- pure_throw(bad_matrix_exception(x));
+ goto err;
break;
}
}
- va_end(ap);
+ if (n == 1 && have_matrix) return xs[0];
if (k < 0) k = 0;
nrows = k;
if (nrows == 0 && ncols == 0) target = EXPR::MATRIX;
- pure_expr *ret = 0;
switch (target) {
case EXPR::MATRIX:
- ret = double_matrix_columns(nrows, ncols, m, xs);
+ ret = double_matrix_columns(nrows, ncols, n, xs);
break;
#if 0 // XXXTODO
case EXPR::CMATRIX:
- ret = complex_matrix_columns(nrows, ncols, m, xs);
+ ret = complex_matrix_columns(nrows, ncols, n, xs);
break;
#endif
case EXPR::IMATRIX:
- ret = int_matrix_columns(nrows, ncols, m, xs);
+ ret = int_matrix_columns(nrows, ncols, n, xs);
break;
default:
break;
}
if (!ret) pure_throw(not_implemented_exception());
return ret;
+ err:
+ /* This is called without a shadow stack frame, so we do our own cleanup
+ here to avoid having temporaries hanging around indefinitely. */
+ if (x) x->refc++;
+ for (size_t i = 0; i < n; i++)
+ pure_new_internal(xs[i]);
+ for (size_t i = 0; i < n; i++)
+ pure_free_internal(xs[i]);
+ pure_unref_internal(x);
+ pure_throw(bad_matrix_exception(x));
+ return 0;
#else
pure_throw(not_implemented_exception());
return 0;
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-17 08:32:48 UTC (rev 776)
+++ pure/trunk/runtime.h 2008-09-17 15:05:12 UTC (rev 777)
@@ -148,9 +148,11 @@
list of element expressions, which can be component matrices or scalars.
The pure_matrix_rows functions arrange the elements vertically, while the
pure_matrix_columns functions arrange them horizontally, given that the
- other dimensions match. The elems vectors are owned by the caller and won't
- be freed. A null expression is returned in case of an error (no matrix
- support, dimension mismatch, or invalid element type). */
+ other dimensions match. A null expression is returned in case of an error
+ (no matrix support, dimension mismatch, or invalid element type). Otherwise
+ a new matrix expression is returned. Temporary element expressions are
+ taken over by the callee and will be garbage-collected, but the elems
+ vectors are owned by the caller and won't be freed. */
pure_expr *pure_matrix_rowsl(uint32_t n, ...);
pure_expr *pure_matrix_rowsv(uint32_t n, pure_expr **elems);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-18 11:44:19
|
Revision: 782
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=782&view=rev
Author: agraef
Date: 2008-09-18 11:44:30 +0000 (Thu, 18 Sep 2008)
Log Message:
-----------
Implement the remaining matrix functions in the public runtime API. This completes basic GSL matrix support, but note that not all functionality has been fully tested yet, and operations to inspect matrix values are still missing.
Modified Paths:
--------------
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-18 11:41:11 UTC (rev 781)
+++ pure/trunk/runtime.cc 2008-09-18 11:44:30 UTC (rev 782)
@@ -1128,19 +1128,97 @@
pure_expr *pure_matrix_rowsl(uint32_t n, ...)
{
#ifdef HAVE_GSL
- // XXXTODO
- return 0;
+ va_list ap;
+ pure_expr **xs = (pure_expr**)alloca(n*sizeof(pure_expr*));
+ va_start(ap, n);
+ for (size_t i = 0; i < n; i++)
+ xs[i] = va_arg(ap, pure_expr*);
+ va_end(ap);
+ return pure_matrix_rowsv(n, xs);
#else
return 0;
#endif
}
extern "C"
-pure_expr *pure_matrix_rowsv(uint32_t n, pure_expr **elems)
+pure_expr *pure_matrix_rowsv(uint32_t n, pure_expr **xs)
{
#ifdef HAVE_GSL
- // XXXTODO
- return 0;
+ int k = -1;
+ size_t nrows = 0, ncols = 0;
+ int32_t target = EXPR::IMATRIX;
+ bool have_matrix = false;
+ for (size_t i = 0; i < n; i++) {
+ pure_expr *x = xs[i];
+ switch (x->tag) {
+ case EXPR::DBL:
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ case EXPR::INT:
+ case EXPR::BIGINT:
+ if (k >= 0 && k != 1) return 0;
+ nrows++; k = 1;
+ break;
+ case EXPR::APP: {
+ double a, b;
+ if (!get_complex(x, a, b)) return 0;
+ if (k >= 0 && k != 1) return 0;
+ target = EXPR::CMATRIX;
+ nrows++; k = 1;
+ break;
+ }
+ case EXPR::MATRIX: {
+ gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ return 0;
+ nrows += mp->size1; k = mp->size2;
+ } else if (k>0)
+ return 0;
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ have_matrix = true;
+ break;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ return 0;
+ nrows += mp->size1; k = mp->size2;
+ } else if (k>0)
+ return 0;
+ target = EXPR::CMATRIX;
+ have_matrix = true;
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size2 != (size_t)k)
+ return 0;
+ nrows += mp->size1; k = mp->size2;
+ } else if (k>0)
+ return 0;
+ have_matrix = true;
+ break;
+ }
+ default:
+ return 0;
+ }
+ }
+ if (n == 1 && have_matrix) return xs[0];
+ if (k < 0) k = 0;
+ ncols = k;
+ if (nrows == 0 && ncols == 0) target = EXPR::MATRIX;
+ switch (target) {
+ case EXPR::MATRIX:
+ return double_matrix_rows(nrows, ncols, n, xs);
+ case EXPR::CMATRIX:
+ return complex_matrix_rows(nrows, ncols, n, xs);
+ case EXPR::IMATRIX:
+ return int_matrix_rows(nrows, ncols, n, xs);
+ default:
+ return 0;
+ }
#else
return 0;
#endif
@@ -1150,19 +1228,97 @@
pure_expr *pure_matrix_columnsl(uint32_t n, ...)
{
#ifdef HAVE_GSL
- // XXXTODO
- return 0;
+ va_list ap;
+ pure_expr **xs = (pure_expr**)alloca(n*sizeof(pure_expr*));
+ va_start(ap, n);
+ for (size_t i = 0; i < n; i++)
+ xs[i] = va_arg(ap, pure_expr*);
+ va_end(ap);
+ return pure_matrix_columnsv(n, xs);
#else
return 0;
#endif
}
extern "C"
-pure_expr *pure_matrix_columnsv(uint32_t n, pure_expr **elems)
+pure_expr *pure_matrix_columnsv(uint32_t n, pure_expr **xs)
{
#ifdef HAVE_GSL
- // XXXTODO
- return 0;
+ int k = -1;
+ size_t nrows = 0, ncols = 0;
+ int32_t target = EXPR::IMATRIX;
+ bool have_matrix = false;
+ for (size_t i = 0; i < n; i++) {
+ pure_expr *x = xs[i];
+ switch (x->tag) {
+ case EXPR::DBL:
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ case EXPR::INT:
+ case EXPR::BIGINT:
+ if (k >= 0 && k != 1) return 0;
+ ncols++; k = 1;
+ break;
+ case EXPR::APP: {
+ double a, b;
+ if (!get_complex(x, a, b)) return 0;
+ if (k >= 0 && k != 1) return 0;
+ target = EXPR::CMATRIX;
+ ncols++; k = 1;
+ break;
+ }
+ case EXPR::MATRIX: {
+ gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size1 != (size_t)k)
+ return 0;
+ ncols += mp->size2; k = mp->size1;
+ } else if (k>0)
+ return 0;
+ if (target == EXPR::IMATRIX) target = EXPR::MATRIX;
+ have_matrix = true;
+ break;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size1 != (size_t)k)
+ return 0;
+ ncols += mp->size2; k = mp->size1;
+ } else if (k>0)
+ return 0;
+ target = EXPR::CMATRIX;
+ have_matrix = true;
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
+ if (mp) {
+ if (k >= 0 && mp->size1 != (size_t)k)
+ return 0;
+ ncols += mp->size2; k = mp->size1;
+ } else if (k>0)
+ return 0;
+ have_matrix = true;
+ break;
+ }
+ default:
+ return 0;
+ }
+ }
+ if (n == 1 && have_matrix) return xs[0];
+ if (k < 0) k = 0;
+ nrows = k;
+ if (nrows == 0 && ncols == 0) target = EXPR::MATRIX;
+ switch (target) {
+ case EXPR::MATRIX:
+ return double_matrix_columns(nrows, ncols, n, xs);
+ case EXPR::CMATRIX:
+ return complex_matrix_columns(nrows, ncols, n, xs);
+ case EXPR::IMATRIX:
+ return int_matrix_columns(nrows, ncols, n, xs);
+ default:
+ return 0;
+ }
#else
return 0;
#endif
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-18 11:41:11 UTC (rev 781)
+++ pure/trunk/runtime.h 2008-09-18 11:44:30 UTC (rev 782)
@@ -149,10 +149,10 @@
The pure_matrix_rows functions arrange the elements vertically, while the
pure_matrix_columns functions arrange them horizontally, given that the
other dimensions match. A null expression is returned in case of an error
- (no matrix support, dimension mismatch, or invalid element type). Otherwise
- a new matrix expression is returned. Temporary element expressions are
- taken over by the callee and will be garbage-collected, but the elems
- vectors are owned by the caller and won't be freed. */
+ (no matrix support, dimension mismatch, or invalid element type), leaving
+ the input expressions untouched. Otherwise a new matrix expression is
+ returned and temporary element expressions are garbage-collected. In any
+ case, the elems vectors are owned by the caller and won't be freed. */
pure_expr *pure_matrix_rowsl(uint32_t n, ...);
pure_expr *pure_matrix_rowsv(uint32_t n, pure_expr **elems);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-18 13:19:21
|
Revision: 785
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=785&view=rev
Author: agraef
Date: 2008-09-18 20:19:31 +0000 (Thu, 18 Sep 2008)
Log Message:
-----------
Add some basic matrix operations (matrix size and dimensions, indexing, slicing).
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/primitives.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-18 17:35:01 UTC (rev 784)
+++ pure/trunk/ChangeLog 2008-09-18 20:19:31 UTC (rev 785)
@@ -1,17 +1,36 @@
2008-09-18 Albert Graef <Dr....@t-...>
+ * lib/primitives.pure: Add definitions of basic matrix operations.
+ Currently only size, dimensions and indexing are supported.
+
+ Synopsis:
+ - #x total number of elements
+ - dim x number of rows and columns (as a pair)
+ - x!i ith matrix element in row-major order
+ - x!(i,j) jth element in ith row of the matrix
+
* expr.cc, interpreter.cc, runtime.cc, printer.cc: Add basic GSL
matrix support. GSL double, complex and integer matrices can be
created with the new {x,y;u,v} syntax, which works more or less
like Octave/MATLAB matrices, but using curly braces instead of
- brackets.
+ brackets. Moreover, various basic operations to handle this kind
+ of objects (conversions, determining sizes, indexing, slicing)
+ have been added to the runtime, including some public API
+ operations to create and inspect matrix objects.
+ Note that the {...} syntax can be used only on the right-hand side
+ of a definition, matrix patterns are not supported right now. As a
+ remedy, there are three new type tags, matrix, cmatrix and
+ imatrix, which can be used in patterns to match double, complex
+ and integer matrices, respectively.
+
GSL matrices are always homogeneous, i.e., they only contain
values from one numeric type. Integer matrices can be created from
any combination of Pure machine int and bigint values (the latter
are converted to machine ints automatically). Matrices with at
least one double or complex element become double and complex
- matrices, respectively.
+ matrices, respectively, casting the other matrix elements as
+ needed.
Complex matrices can be created from either pairs of double or
integer values, such as {(1,2),(3,4)}, or from Pure complex
@@ -20,18 +39,10 @@
math.pure has been loaded in which case complex values are printed
in rectangular format x+:y. Also note that, for performance
reasons, the expression printer doesn't use the __show__ function
- to print matrix elements, but of course it is possible to override
- the default print representation of matrix values as a whole.
+ to print individual matrix elements, but of course it is possible
+ to override the default print representation of matrix values as a
+ whole.
- Note that the {...} syntax can be used only on the right-hand side
- of a definition, matrix patterns are not supported right now. As a
- remedy, there are three new type tags, matrix, cmatrix and
- imatrix, which can be used in patterns to match double, complex
- and integer matrices, respectively.
-
- Operations to handle Pure matrix expressions have been added to
- the public runtime API.
-
2008-09-15 Albert Graef <Dr....@t-...>
* configure.ac: Bump version number.
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-09-18 17:35:01 UTC (rev 784)
+++ pure/trunk/lib/primitives.pure 2008-09-18 20:19:31 UTC (rev 785)
@@ -42,6 +42,10 @@
stringp x = case x of _::string = 1; _ = 0 end;
pointerp x = case x of _::pointer = 1; _ = 0 end;
+matrixp x = case x of _::matrix = 1; _ = 0 end;
+cmatrixp x = case x of _::cmatrix = 1; _ = 0 end;
+imatrixp x = case x of _::imatrix = 1; _ = 0 end;
+
/* Predicates to check for function objects, global (unbound) variables,
function applications, proper lists, list nodes and tuples. */
@@ -383,6 +387,31 @@
x::pointer==y::pointer = bigint x == bigint y;
x::pointer!=y::pointer = bigint x != bigint y;
+/* Basic matrix operations. */
+
+private matrix_size matrix_dim;
+extern int matrix_size(expr *x), expr* matrix_dim(expr *x);
+
+#x::matrix | #x::cmatrix | #x::imatrix = matrix_size x;
+dim x::matrix | dim x::cmatrix | dim x::imatrix = matrix_dim x;
+
+private matrix_elem_at;
+extern expr* matrix_elem_at(expr* x, int i);
+
+x::matrix!i::int | x::cmatrix!i::int | x::imatrix!i::int
+ = matrix_elem_at x i if i>=0 && i<#x;
+ = throw out_of_bounds otherwise;
+
+private matrix_elem;
+extern expr* matrix_elem(expr* x, int i, int j);
+
+x::matrix!(i::int,j::int) | x::cmatrix!(i::int,j::int) |
+x::imatrix!(i::int,j::int)
+ = matrix_elem x i j
+ if (i>=0 && i<n && j>=0 && j<m
+ when n,m = dim x end);
+ = throw out_of_bounds otherwise;
+
/* IEEE floating point infinities and NaNs. Place these after the definitions
of the built-in operators so that the double arithmetic works. */
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-18 17:35:01 UTC (rev 784)
+++ pure/trunk/runtime.cc 2008-09-18 20:19:31 UTC (rev 785)
@@ -3611,6 +3611,184 @@
return interp.errmsg.c_str();
}
+extern "C"
+uint32_t matrix_size(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
+ return m->size1*m->size2;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
+ return m->size1*m->size2;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
+ return m->size1*m->size2;
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_dim(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
+ return pure_tuplel(2, pure_int(m->size1), pure_int(m->size2));
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
+ return pure_tuplel(2, pure_int(m->size1), pure_int(m->size2));
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
+ return pure_tuplel(2, pure_int(m->size1), pure_int(m->size2));
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+static inline pure_expr *make_complex(double a, double b)
+{
+ interpreter& interp = *interpreter::g_interp;
+ symbol *rect = interp.symtab.complex_rect_sym();
+ if (rect)
+ return pure_appl(pure_symbol(rect->f), 2, pure_double(a), pure_double(b));
+ else
+ return pure_tuplel(2, pure_double(a), pure_double(b));
+}
+
+extern "C"
+pure_expr *matrix_elem_at(pure_expr *x, uint32_t i)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
+ return pure_double(m->data[i]);
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
+ return make_complex(m->data[2*i], m->data[2*i+1]);
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
+ return pure_int(m->data[i]);
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_elem(pure_expr *x, uint32_t i, uint32_t j)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
+ size_t k = i*m->tda+j;
+ return pure_double(m->data[k]);
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
+ size_t k = 2*(i*m->tda+j);
+ return make_complex(m->data[k], m->data[k+1]);
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
+ size_t k = i*m->tda+j;
+ return pure_int(m->data[k]);
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_slice(pure_expr *x, uint32_t i1, uint32_t j1,
+ uint32_t i2, uint32_t j2)
+{
+#ifdef HAVE_GSL
+ void *p = 0;
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
+ size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (n1 == 0 || n2 == 0) // empty matrix
+ return pure_double_matrix(create_double_matrix(n1, n2));
+ gsl_matrix_view v = gsl_matrix_submatrix(m, i1, j1, n1, n2);
+ // take a copy of the view matrix
+ gsl_matrix *m1 = (gsl_matrix*)malloc(sizeof(gsl_matrix));
+ assert(m1 && v.matrix.data);
+ *m1 = v.matrix;
+ p = m1;
+ break;
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
+ size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (n1 == 0 || n2 == 0) // empty matrix
+ return pure_complex_matrix(create_complex_matrix(n1, n2));
+ gsl_matrix_complex_view v =
+ gsl_matrix_complex_submatrix(m, i1, j1, n1, n2);
+ // take a copy of the view matrix
+ gsl_matrix_complex *m1 =
+ (gsl_matrix_complex*)malloc(sizeof(gsl_matrix_complex));
+ assert(m1 && v.matrix.data);
+ *m1 = v.matrix;
+ p = m1;
+ break;
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
+ size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (n1 == 0 || n2 == 0) // empty matrix
+ return pure_int_matrix(create_int_matrix(n1, n2));
+ gsl_matrix_int_view v = gsl_matrix_int_submatrix(m, i1, j1, n1, n2);
+ // take a copy of the view matrix
+ gsl_matrix_int *m1 = (gsl_matrix_int*)malloc(sizeof(gsl_matrix_int));
+ assert(m1 && v.matrix.data);
+ *m1 = v.matrix;
+ p = m1;
+ break;
+ }
+ default:
+ return 0;
+ }
+ // create a new expression for the slice, update the reference counter for
+ // the underlying GSL matrix
+ pure_expr *y = new_expr();
+ y->tag = EXPR::MATRIX;
+ y->data.mat.p = p;
+ y->data.mat.refc = x->data.mat.refc;
+ *y->data.mat.refc++;
+ MEMDEBUG_NEW(y)
+ return y;
+#else
+ return 0;
+#endif
+}
+
static uint32_t mpz_hash(const mpz_t z)
{
uint32_t h = 0;
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-18 17:35:01 UTC (rev 784)
+++ pure/trunk/runtime.h 2008-09-18 20:19:31 UTC (rev 785)
@@ -602,6 +602,30 @@
const char *lasterr();
+/* Basic matrix operations. These work with all supported GSL matrix types.
+ matrix_size determines the number of elements in a matrix, matrix_dim the
+ number of rows and columns, which are returned as a pair (n,m). */
+
+uint32_t matrix_size(pure_expr *x);
+pure_expr *matrix_dim(pure_expr *x);
+
+/* Matrix elements can be retrieved either by a single index (using row-major
+ order), or by row and column index. All indices are zero-based. Indices
+ aren't range-checked, if this is needed you have to do it beforehand using
+ matrix_size or matrix_dim above. */
+
+pure_expr *matrix_elem_at(pure_expr *x, uint32_t i);
+pure_expr *matrix_elem(pure_expr *x, uint32_t i, uint32_t j);
+
+/* The following operation retrieves a slice a.k.a. submatrix of a matrix and
+ returns it as a matrix object. The new matrix object shares the underlying
+ storage with the original matrix (i.e., matrix elements are *not* copied)
+ and so this is a comparatively cheap operation. Indices are zero-based and
+ not checked. */
+
+pure_expr *matrix_slice(pure_expr *x, uint32_t i1, uint32_t j1,
+ uint32_t i2, uint32_t j2);
+
/* Compute a 32 bit hash code of a Pure expression. This makes it possible to
use arbitary Pure values as keys in a hash table. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-18 22:26:27
|
Revision: 787
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=787&view=rev
Author: agraef
Date: 2008-09-19 05:26:38 +0000 (Fri, 19 Sep 2008)
Log Message:
-----------
Add matrix transposition and conversion operations.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/lib/primitives.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-18 20:35:54 UTC (rev 786)
+++ pure/trunk/lib/prelude.pure 2008-09-19 05:26:38 UTC (rev 787)
@@ -58,6 +58,7 @@
infixl 6 + - or ; // addition, bitwise or
infixl 7 * / div mod and ; // multiplication, bitwise and
prefix 7 ~ ; // bitwise not
+postfix 7 ' ; // matrix transposition
infixr 8 ^ ; // exponentiation
prefix 8 # ; // size operator
infixl 9 ! !! ; // indexing, slicing
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-09-18 20:35:54 UTC (rev 786)
+++ pure/trunk/lib/primitives.pure 2008-09-19 05:26:38 UTC (rev 787)
@@ -428,6 +428,25 @@
when n::int,m::int = dim x end);
= throw out_of_bounds otherwise;
+private matrix_transpose;
+extern expr* matrix_transpose(expr *x);
+
+x::matrix' | x::cmatrix' | x::imatrix' = matrix_transpose x;
+
+private matrix_double matrix_complex matrix_int;
+extern expr* matrix_double(expr *x), expr* matrix_complex(expr *x),
+ expr* matrix_int(expr *x);
+
+dmatrix x::matrix | dmatrix x::imatrix = matrix_double x;
+imatrix x::matrix | imatrix x::imatrix = matrix_int x;
+cmatrix x::matrix | cmatrix x::cmatrix | cmatrix x::imatrix = matrix_complex x;
+
+private matrix_re matrix_im;
+extern expr* matrix_re(expr *x), expr* matrix_im(expr *x);
+
+re x::matrix | re x::cmatrix | re x::imatrix = matrix_re x;
+im x::matrix | im x::cmatrix | im x::imatrix = matrix_im x;
+
/* IEEE floating point infinities and NaNs. Place these after the definitions
of the built-in operators so that the double arithmetic works. */
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-18 20:35:54 UTC (rev 786)
+++ pure/trunk/runtime.cc 2008-09-19 05:26:38 UTC (rev 787)
@@ -3789,6 +3789,201 @@
#endif
}
+extern "C"
+pure_expr *matrix_transpose(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m1 = (gsl_matrix*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix *m2 = create_double_matrix(m, n);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++)
+ m2->data[j*m2->tda+i] = m1->data[i*m1->tda+j];
+ return pure_double_matrix(m2);
+ }
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m1 = (gsl_matrix_complex*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix_complex *m2 = create_complex_matrix(m, n);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++) {
+ size_t k = 2*(i*m1->tda+j), l = 2*(j*m2->tda+i);
+ m2->data[l] = m1->data[k];
+ m2->data[l+1] = m1->data[k+1];
+ }
+ return pure_complex_matrix(m2);
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m1 = (gsl_matrix_int*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix_int *m2 = create_int_matrix(m, n);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++)
+ m2->data[j*m2->tda+i] = m1->data[i*m1->tda+j];
+ return pure_int_matrix(m2);
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_double(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX:
+ return x;
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m1 = (gsl_matrix_int*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix *m2 = create_double_matrix(n, m);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++)
+ m2->data[i*m2->tda+j] = (double)m1->data[i*m1->tda+j];
+ return pure_double_matrix(m2);
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_complex(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m1 = (gsl_matrix*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix_complex *m2 = create_complex_matrix(n, m);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++) {
+ size_t k = 2*(i*m2->tda+j);
+ m2->data[k] = m1->data[i*m1->tda+j];
+ m2->data[k+1] = 0.0;
+ }
+ return pure_complex_matrix(m2);
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m1 = (gsl_matrix_int*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix_complex *m2 = create_complex_matrix(n, m);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++) {
+ size_t k = 2*(i*m2->tda+j);
+ m2->data[k] = (double)m1->data[i*m1->tda+j];
+ m2->data[k+1] = 0.0;
+ }
+ return pure_complex_matrix(m2);
+ }
+ case EXPR::CMATRIX:
+ return x;
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_int(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::MATRIX: {
+ gsl_matrix *m1 = (gsl_matrix*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix_int *m2 = create_int_matrix(n, m);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++)
+ m2->data[i*m2->tda+j] = (int)m1->data[i*m1->tda+j];
+ return pure_int_matrix(m2);
+ }
+ case EXPR::IMATRIX:
+ return x;
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_re(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m1 = (gsl_matrix_complex*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix *m2 = create_double_matrix(n, m);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++) {
+ size_t k = 2*(i*m1->tda+j), l = i*m2->tda+j;
+ m2->data[l] = m1->data[k];
+ }
+ return pure_double_matrix(m2);
+ }
+ case EXPR::MATRIX:
+ case EXPR::IMATRIX:
+ return x;
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
+extern "C"
+pure_expr *matrix_im(pure_expr *x)
+{
+#ifdef HAVE_GSL
+ switch (x->tag) {
+ case EXPR::CMATRIX: {
+ gsl_matrix_complex *m1 = (gsl_matrix_complex*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix *m2 = create_double_matrix(n, m);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++) {
+ size_t k = 2*(i*m1->tda+j), l = i*m2->tda+j;
+ m2->data[l] = m1->data[k+1];
+ }
+ return pure_double_matrix(m2);
+ }
+ case EXPR::MATRIX: {
+ gsl_matrix *m1 = (gsl_matrix*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix *m2 = create_double_matrix(n, m);
+ memset(m2->data, 0, n*m*sizeof(double));
+ return pure_double_matrix(m2);
+ }
+ case EXPR::IMATRIX: {
+ gsl_matrix_int *m1 = (gsl_matrix_int*)x->data.mat.p;
+ size_t n = m1->size1, m = m1->size2;
+ gsl_matrix_int *m2 = create_int_matrix(n, m);
+ memset(m2->data, 0, n*m*sizeof(int));
+ return pure_int_matrix(m2);
+ }
+ default:
+ return 0;
+ }
+#else
+ return 0;
+#endif
+}
+
static uint32_t mpz_hash(const mpz_t z)
{
uint32_t h = 0;
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-18 20:35:54 UTC (rev 786)
+++ pure/trunk/runtime.h 2008-09-19 05:26:38 UTC (rev 787)
@@ -626,6 +626,27 @@
pure_expr *matrix_slice(pure_expr *x, uint32_t i1, uint32_t j1,
uint32_t i2, uint32_t j2);
+/* Transpose a matrix. The resulting matrix has the rows of the original
+ matrix as its columns, and vice versa. */
+
+pure_expr *matrix_transpose(pure_expr *x);
+
+/* Convert an existing matrix to a double, complex or int matrix,
+ respectively. Any kind of matrix can be converted to a complex matrix, but
+ the input must be a double or integer matrix for the other conversions (see
+ matrix_re and matrix_im below to handle the complex->double case). */
+
+pure_expr *matrix_double(pure_expr *x);
+pure_expr *matrix_complex(pure_expr *x);
+pure_expr *matrix_int(pure_expr *x);
+
+/* Extract the real and imaginary parts of a matrix. If the input is a complex
+ matrix, the result is a double matrix. Otherwise the type of the result is
+ the same as that of the input matrix. */
+
+pure_expr *matrix_re(pure_expr *x);
+pure_expr *matrix_im(pure_expr *x);
+
/* Compute a 32 bit hash code of a Pure expression. This makes it possible to
use arbitary Pure values as keys in a hash table. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-20 08:58:06
|
Revision: 802
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=802&view=rev
Author: agraef
Date: 2008-09-20 08:57:43 +0000 (Sat, 20 Sep 2008)
Log Message:
-----------
Bugfixes.
Modified Paths:
--------------
pure/trunk/lib/primitives.pure
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-09-20 08:20:26 UTC (rev 801)
+++ pure/trunk/lib/primitives.pure 2008-09-20 08:57:43 UTC (rev 802)
@@ -460,7 +460,7 @@
/* Extract a submatrix of a given size at a given offset. */
submat x::matrix (i::int,j::int) (n::int,m::int)
- = matrix_slice x i j (i+n) (j+m);
+ = matrix_slice x i j (i+n-1) (j+m-1);
/* Construct matrices from lists of rows and columns. These take either
scalars or submatrices as inputs; corresponding dimensions must match.
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-20 08:20:26 UTC (rev 801)
+++ pure/trunk/printer.cc 2008-09-20 08:57:43 UTC (rev 802)
@@ -764,33 +764,37 @@
}
case EXPR::PTR:
return os << "#<pointer " << x->data.p << ">";
-#ifdef HAVE_GSL
/* NOTE: For performance reasons, we don't do any custom representations for
matrix elements. As a workaround, you can define __show__ on matrices as
a whole. */
case EXPR::MATRIX:
os << "{";
if (x->data.mat.p) {
- prec_t p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
gsl_matrix_symbolic *m = (gsl_matrix_symbolic*)x->data.mat.p;
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- os << pure_paren(p, m->data[i * m->tda + j]);
+ if (m->size1>0 && m->size2>0) {
+ prec_t p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ os << pure_paren(p, m->data[i * m->tda + j]);
+ }
}
}
}
return os << "}";
+#ifdef HAVE_GSL
case EXPR::DMATRIX:
os << "{";
if (x->data.mat.p) {
gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- print_double(os, m->data[i * m->tda + j]);
+ if (m->size1>0 && m->size2>0) {
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ print_double(os, m->data[i * m->tda + j]);
+ }
}
}
}
@@ -799,11 +803,15 @@
os << "{";
if (x->data.mat.p) {
gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- os << m->data[i * m->tda + j];
+ if (m->size1>0 && m->size2>0) {
+ if (m->size1>0 && m->size2>0) {
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ os << m->data[i * m->tda + j];
+ }
+ }
}
}
}
@@ -812,39 +820,39 @@
os << "{";
if (x->data.mat.p) {
gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
- /* GSL represents complex matrices using pairs of double values, while
- Pure provides its own complex type in math.pure. If math.pure has
- been loaded, then the '+:' operator is defined and we use this
- representation. Otherwise, we print complex values as pairs of real
- and imaginary part. */
- symbol *rect = interpreter::g_interp->symtab.complex_rect_sym();
- if (rect)
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- print_double(os, m->data[2*(i * m->tda + j)]);
- os << rect->s;
- print_double(os, m->data[2*(i * m->tda + j) + 1]);
+ if (m->size1>0 && m->size2>0) {
+ /* GSL represents complex matrices using pairs of double values, while
+ Pure provides its own complex type in math.pure. If math.pure has
+ been loaded, then the '+:' operator is defined and we use this
+ representation. Otherwise, we print complex values as pairs of real
+ and imaginary part. */
+ symbol *rect = interpreter::g_interp->symtab.complex_rect_sym();
+ if (rect)
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ print_double(os, m->data[2*(i * m->tda + j)]);
+ os << rect->s;
+ print_double(os, m->data[2*(i * m->tda + j) + 1]);
+ }
}
- }
- else
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- os << "(";
- print_double(os, m->data[2*(i * m->tda + j)]);
- os << ",";
- print_double(os, m->data[2*(i * m->tda + j) + 1]);
- os << ")";
+ else
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ os << "(";
+ print_double(os, m->data[2*(i * m->tda + j)]);
+ os << ",";
+ print_double(os, m->data[2*(i * m->tda + j) + 1]);
+ os << ")";
+ }
}
- }
+ }
}
return os << "}";
#else
- case EXPR::MATRIX:
- return os << "#<matrix " << x->data.mat.p << ">";
case EXPR::DMATRIX:
return os << "#<dmatrix " << x->data.mat.p << ">";
case EXPR::IMATRIX:
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-20 08:20:26 UTC (rev 801)
+++ pure/trunk/runtime.cc 2008-09-20 08:57:43 UTC (rev 802)
@@ -4053,7 +4053,7 @@
}
extern "C"
-pure_expr *matrix_elem_at(pure_expr *x, uint32_t i)
+pure_expr *matrix_elem_at(pure_expr *x, int32_t i)
{
switch (x->tag) {
case EXPR::MATRIX: {
@@ -4080,7 +4080,7 @@
}
extern "C"
-pure_expr *matrix_elem_at2(pure_expr *x, uint32_t i, uint32_t j)
+pure_expr *matrix_elem_at2(pure_expr *x, int32_t i, int32_t j)
{
switch (x->tag) {
case EXPR::MATRIX: {
@@ -4111,14 +4111,18 @@
}
extern "C"
-pure_expr *matrix_slice(pure_expr *x, uint32_t i1, uint32_t j1,
- uint32_t i2, uint32_t j2)
+pure_expr *matrix_slice(pure_expr *x, int32_t i1, int32_t j1,
+ int32_t i2, int32_t j2)
{
void *p = 0;
+ if (i1<0) i1 = 0; if (j1<0) j1 = 0;
switch (x->tag) {
case EXPR::MATRIX: {
gsl_matrix_symbolic *m = (gsl_matrix_symbolic*)x->data.mat.p;
- size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (i2 >= (int)m->size1) i2 = m->size1-1;
+ if (j2 >= (int)m->size2) j2 = m->size2-1;
+ size_t n1 = (i1<(int)m->size1 && i2>=i1)?(i2+1-i1):0,
+ n2 = (j1<(int)m->size2 && j2>=j1)?(j2+1-j1):0;
if (n1 == 0 || n2 == 0) // empty matrix
return pure_symbolic_matrix(create_symbolic_matrix(n1, n2));
gsl_matrix_symbolic_view v =
@@ -4134,7 +4138,10 @@
#ifdef HAVE_GSL
case EXPR::DMATRIX: {
gsl_matrix *m = (gsl_matrix*)x->data.mat.p;
- size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (i2 >= (int)m->size1) i2 = m->size1-1;
+ if (j2 >= (int)m->size2) j2 = m->size2-1;
+ size_t n1 = (i1<(int)m->size1 && i2>=i1)?(i2+1-i1):0,
+ n2 = (j1<(int)m->size2 && j2>=j1)?(j2+1-j1):0;
if (n1 == 0 || n2 == 0) // empty matrix
return pure_double_matrix(create_double_matrix(n1, n2));
gsl_matrix_view v = gsl_matrix_submatrix(m, i1, j1, n1, n2);
@@ -4147,7 +4154,10 @@
}
case EXPR::CMATRIX: {
gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
- size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (i2 >= (int)m->size1) i2 = m->size1-1;
+ if (j2 >= (int)m->size2) j2 = m->size2-1;
+ size_t n1 = (i1<(int)m->size1 && i2>=i1)?(i2+1-i1):0,
+ n2 = (j1<(int)m->size2 && j2>=j1)?(j2+1-j1):0;
if (n1 == 0 || n2 == 0) // empty matrix
return pure_complex_matrix(create_complex_matrix(n1, n2));
gsl_matrix_complex_view v =
@@ -4162,7 +4172,10 @@
}
case EXPR::IMATRIX: {
gsl_matrix_int *m = (gsl_matrix_int*)x->data.mat.p;
- size_t n1 = (i2>=i1)?(i2+1-i1):0, n2 = (j2>=j1)?(j2+1-j1):0;
+ if (i2 >= (int)m->size1) i2 = m->size1-1;
+ if (j2 >= (int)m->size2) j2 = m->size2-1;
+ size_t n1 = (i1<(int)m->size1 && i2>=i1)?(i2+1-i1):0,
+ n2 = (j1<(int)m->size2 && j2>=j1)?(j2+1-j1):0;
if (n1 == 0 || n2 == 0) // empty matrix
return pure_int_matrix(create_int_matrix(n1, n2));
gsl_matrix_int_view v = gsl_matrix_int_submatrix(m, i1, j1, n1, n2);
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-20 08:20:26 UTC (rev 801)
+++ pure/trunk/runtime.h 2008-09-20 08:57:43 UTC (rev 802)
@@ -659,17 +659,17 @@
aren't range-checked, if this is needed you have to do it beforehand,
checking against matrix_size or matrix_dim above. */
-pure_expr *matrix_elem_at(pure_expr *x, uint32_t i);
-pure_expr *matrix_elem_at2(pure_expr *x, uint32_t i, uint32_t j);
+pure_expr *matrix_elem_at(pure_expr *x, int32_t i);
+pure_expr *matrix_elem_at2(pure_expr *x, int32_t i, int32_t j);
/* The following operation retrieves a slice a.k.a. submatrix of a matrix and
returns it as a new matrix object. The result matrix shares the underlying
storage with the input matrix (i.e., matrix elements are *not* copied) and
- so this is a comparatively cheap operation. Indices are zero-based and must
- be checked by the caller if necessary. */
+ so this is a comparatively cheap operation. Indices are zero-based and are
+ clamped to the available index range automatically. */
-pure_expr *matrix_slice(pure_expr *x, uint32_t i1, uint32_t j1,
- uint32_t i2, uint32_t j2);
+pure_expr *matrix_slice(pure_expr *x, int32_t i1, int32_t j1,
+ int32_t i2, int32_t j2);
/* Matrix construction. These work like the pure_matrix_rows/
pure_matrix_columns functions in the public API, but take their input from
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-20 09:50:09
|
Revision: 805
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=805&view=rev
Author: agraef
Date: 2008-09-20 09:49:59 +0000 (Sat, 20 Sep 2008)
Log Message:
-----------
Cosmetic changes to arithmetic sequence syntax, to make it easier to write matrix slices.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-20 09:24:14 UTC (rev 804)
+++ pure/trunk/lib/prelude.pure 2008-09-20 09:49:59 UTC (rev 805)
@@ -45,8 +45,8 @@
infixl 0 $$ ; // sequence operator
infixr 0 $ ; // right-associative application
-infix 1 .. ; // arithmetic sequences
infixr 1 , ; // pair (tuple)
+infix 2 .. ; // arithmetic sequences
infix 2 => ; // mapsto constructor
infixr 2 || ; // logical or (short-circuit)
infixr 3 && ; // logical and (short-circuit)
@@ -254,7 +254,7 @@
/* Arithmetic sequences. */
-n1,n2..m = if m===s*inf then iterate (\x->x+k) n1
+n1:n2..m = if m===s*inf then iterate (\x->x+k) n1
else while (\i->s*i<=s*m) (\x->x+k) n1
when k = n2-n1; s = if k>0 then 1 else -1 end if n1!=n2;
n..m = if m===inf then iterate (\x->x+1) n
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-09-20 09:24:14 UTC (rev 804)
+++ pure/trunk/test/prelude.log 2008-09-20 09:49:59 UTC (rev 805)
@@ -319,7 +319,7 @@
<var> state 2
state 2: #0
} end;
-n1/*0:0101*/,n2/*0:011*/..m/*0:1*/ = if m/*2:1*/===s/*0:*/*inf then iterate (\x/*0:*/ -> x/*0:*/+k/*2:*/ {
+n1/*0:0101*/:n2/*0:011*/..m/*0:1*/ = if m/*2:1*/===s/*0:*/*inf then iterate (\x/*0:*/ -> x/*0:*/+k/*2:*/ {
rule #0: x = x+k
state 0: #0
<var> state 1
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-20 16:39:45
|
Revision: 808
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=808&view=rev
Author: agraef
Date: 2008-09-20 16:39:35 +0000 (Sat, 20 Sep 2008)
Log Message:
-----------
Syntax changes (list and array comprehension syntax).
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
pure/trunk/parser.yy
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-20 16:37:50 UTC (rev 807)
+++ pure/trunk/interpreter.cc 2008-09-20 16:39:35 UTC (rev 808)
@@ -2754,6 +2754,40 @@
return new expr(y);
}
+expr interpreter::mkmatcomp_expr(expr x, size_t n,
+ comp_clause_list::iterator cs,
+ comp_clause_list::iterator end)
+{
+ if (cs == end)
+ return expr::cons(x, expr::nil());
+ else {
+ comp_clause& c = *cs;
+ if (c.second.is_null()) {
+ expr p = c.first;
+ return expr::cond(p, mkmatcomp_expr(x, n, ++cs, end), expr::nil());
+ } else {
+ expr pat = c.first, body = mkmatcomp_expr(x, n-1, ++cs, end),
+ arg = c.second;
+ closure(pat, body);
+ expr f = (n&1)?symtab.colcatmap_sym().x:symtab.rowcatmap_sym().x;
+ return expr(f, expr::lambda(pat, body), arg);
+ }
+ }
+}
+
+expr *interpreter::mkmatcomp_expr(expr *x, comp_clause_list *cs)
+{
+ size_t n = 0;
+ for (comp_clause_list::iterator it = cs->begin(), end = cs->end();
+ it != end; it++) {
+ comp_clause& c = *it;
+ if (!c.second.is_null()) n++;
+ }
+ expr y = mkmatcomp_expr(*x, n, cs->begin(), cs->end());
+ delete x; delete cs;
+ return new expr(y);
+}
+
// Code generation.
#define Dbl(d) ConstantFP::get(Type::DoubleTy, d)
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-09-20 16:37:50 UTC (rev 807)
+++ pure/trunk/interpreter.hh 2008-09-20 16:39:35 UTC (rev 808)
@@ -483,6 +483,9 @@
expr *mklistcomp_expr(expr *x, comp_clause_list *cs);
expr mklistcomp_expr(expr x, comp_clause_list::iterator cs,
comp_clause_list::iterator end);
+ expr *mkmatcomp_expr(expr *x, comp_clause_list *cs);
+ expr mkmatcomp_expr(expr x, size_t n, comp_clause_list::iterator cs,
+ comp_clause_list::iterator end);
// LLVM code generation and execution.
Modified: pure/trunk/parser.yy
===================================================================
--- pure/trunk/parser.yy 2008-09-20 16:37:50 UTC (rev 807)
+++ pure/trunk/parser.yy 2008-09-20 16:39:35 UTC (rev 808)
@@ -526,8 +526,14 @@
| DBL { $$ = new expr(EXPR::DBL, $1); }
| STR { $$ = new expr(EXPR::STR, $1); }
| '{' rows '}' { $$ = new expr(EXPR::MATRIX, $2); }
+| '{' expr '|' comp_clauses '}'
+ { $$ = interp.mkmatcomp_expr($2, $4); }
| '[' expr ']' { $$ = interp.mklist_expr($2); }
| '[' expr ';' comp_clauses ']'
+ { interp.warning(yyloc,
+ "warning: deprecated comprehension syntax");
+ $$ = interp.mklistcomp_expr($2, $4); }
+| '[' expr '|' comp_clauses ']'
{ $$ = interp.mklistcomp_expr($2, $4); }
| '(' expr ')' { $$ = $2;
if ($$->is_pair()) $$->flags() |= EXPR::PAREN; }
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-09-20 16:37:50 UTC (rev 807)
+++ pure/trunk/symtable.cc 2008-09-20 16:39:35 UTC (rev 808)
@@ -34,11 +34,10 @@
fdiv_sym();
div_sym();
mod_sym();
- // complex_rect_sym() and complex_polar_sym() are not initialized here, as
- // they're supposed to come from math.pure which is not included in the
- // prelude
catch_sym();
catmap_sym();
+ rowcatmap_sym();
+ colcatmap_sym();
failed_match_sym();
failed_cond_sym();
signal_sym();
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-09-20 16:37:50 UTC (rev 807)
+++ pure/trunk/symtable.hh 2008-09-20 16:39:35 UTC (rev 808)
@@ -92,6 +92,8 @@
symbol& mod_sym();
symbol& catch_sym() { return sym("catch"); }
symbol& catmap_sym() { return sym("catmap"); }
+ symbol& rowcatmap_sym() { return sym("rowcatmap"); }
+ symbol& colcatmap_sym() { return sym("colcatmap"); }
symbol& failed_match_sym() { return sym("failed_match"); }
symbol& failed_cond_sym() { return sym("failed_cond"); }
symbol& signal_sym() { return sym("signal"); }
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-20 18:50:30
|
Revision: 811
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=811&view=rev
Author: agraef
Date: 2008-09-20 18:50:23 +0000 (Sat, 20 Sep 2008)
Log Message:
-----------
Get rid of the pair representation for complex values in GSL matrices, as it interferes with symbolic matrices containing pairs.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-20 17:56:26 UTC (rev 810)
+++ pure/trunk/interpreter.cc 2008-09-20 18:50:23 UTC (rev 811)
@@ -928,8 +928,8 @@
if (x->data.mat.p) {
gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
exprll *xs = new exprll;
- symbol *rect = symtab.complex_rect_sym();
- expr f = rect?rect->x:symtab.pair_sym().x;
+ symbol *rect = symtab.complex_rect_sym(true);
+ expr f = rect->x;
for (size_t i = 0; i < m->size1; i++) {
xs->push_back(exprl());
exprl& ys = xs->back();
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-20 17:56:26 UTC (rev 810)
+++ pure/trunk/printer.cc 2008-09-20 18:50:23 UTC (rev 811)
@@ -817,38 +817,25 @@
}
return os << "}";
case EXPR::CMATRIX:
+ /* Print complex values in rectangular format using the infix notation
+ defined in math.pure. FIXME: We require the +: symbol to be predefined
+ no matter whether math.pure has actually been loaded. */
os << "{";
if (x->data.mat.p) {
+ interpreter& interp = *interpreter::g_interp;
+ symbol *rect = interp.symtab.complex_rect_sym(true);
+ string& rectsym = rect->s;
gsl_matrix_complex *m = (gsl_matrix_complex*)x->data.mat.p;
if (m->size1>0 && m->size2>0) {
- /* GSL represents complex matrices using pairs of double values, while
- Pure provides its own complex type in math.pure. If math.pure has
- been loaded, then the '+:' operator is defined and we use this
- representation. Otherwise, we print complex values as pairs of real
- and imaginary part. */
- symbol *rect = interpreter::g_interp->symtab.complex_rect_sym();
- if (rect)
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- print_double(os, m->data[2*(i * m->tda + j)]);
- os << rect->s;
- print_double(os, m->data[2*(i * m->tda + j) + 1]);
- }
+ for (size_t i = 0; i < m->size1; i++) {
+ if (i > 0) os << ";";
+ for (size_t j = 0; j < m->size2; j++) {
+ if (j > 0) os << ",";
+ print_double(os, m->data[2*(i * m->tda + j)]);
+ os << rectsym;
+ print_double(os, m->data[2*(i * m->tda + j) + 1]);
}
- else
- for (size_t i = 0; i < m->size1; i++) {
- if (i > 0) os << ";";
- for (size_t j = 0; j < m->size2; j++) {
- if (j > 0) os << ",";
- os << "(";
- print_double(os, m->data[2*(i * m->tda + j)]);
- os << ",";
- print_double(os, m->data[2*(i * m->tda + j) + 1]);
- os << ")";
- }
- }
+ }
}
}
return os << "}";
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-20 17:56:26 UTC (rev 810)
+++ pure/trunk/runtime.cc 2008-09-20 18:50:23 UTC (rev 811)
@@ -889,8 +889,7 @@
symbol *rect = interp.symtab.complex_rect_sym(),
*polar = interp.symtab.complex_polar_sym();
if ((!rect || f->tag != rect->f) &&
- (!polar || f->tag != polar->f) &&
- f->tag != interp.symtab.pair_sym().f)
+ (!polar || f->tag != polar->f))
return false;
u = u->data.x[1];
switch (u->tag) {
@@ -927,13 +926,13 @@
if (rect)
return pure_appl(pure_symbol(rect->f), 2, pure_double(a), pure_double(b));
else
- return pure_tuplel(2, pure_double(a), pure_double(b));
+ return 0;
}
static inline pure_expr *make_complex(double a, double b)
{
interpreter& interp = *interpreter::g_interp;
- symbol *rect = interp.symtab.complex_rect_sym();
+ symbol *rect = interp.symtab.complex_rect_sym(true);
return make_complex2(rect, a, b);
}
@@ -1338,7 +1337,7 @@
gsl_matrix_complex *mat1 = (gsl_matrix_complex*)x->data.mat.p;
if (mat1) {
interpreter& interp = *interpreter::g_interp;
- symbol *rect = interp.symtab.complex_rect_sym();
+ symbol *rect = interp.symtab.complex_rect_sym(true);
for (size_t j = 0; j < mat1->size1; i++, j++)
for (size_t k = 0; k < mat1->size2; k++) {
size_t l = 2*(j*mat1->tda+k);
@@ -1400,7 +1399,7 @@
gsl_matrix_complex *mat1 = (gsl_matrix_complex*)x->data.mat.p;
if (mat1) {
interpreter& interp = *interpreter::g_interp;
- symbol *rect = interp.symtab.complex_rect_sym();
+ symbol *rect = interp.symtab.complex_rect_sym(true);
for (size_t j = 0; j < mat1->size1; j++)
for (size_t k = 0; k < mat1->size2; k++) {
size_t l = 2*(j*mat1->tda+k);
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-09-20 17:56:26 UTC (rev 810)
+++ pure/trunk/symtable.cc 2008-09-20 18:50:23 UTC (rev 811)
@@ -374,3 +374,21 @@
else
return sym("&", 9, postfix);
}
+
+symbol* symtable::complex_rect_sym(bool force)
+{
+ symbol *_sym = lookup("+:");
+ if (!force || _sym)
+ return _sym;
+ else
+ return &sym("+:", 5, infix);
+}
+
+symbol* symtable::complex_polar_sym(bool force)
+{
+ symbol *_sym = lookup("<:");
+ if (!force || _sym)
+ return _sym;
+ else
+ return &sym("<:", 5, infix);
+}
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-09-20 17:56:26 UTC (rev 810)
+++ pure/trunk/symtable.hh 2008-09-20 18:50:23 UTC (rev 811)
@@ -100,9 +100,11 @@
symbol& segfault_sym() { return sym("stack_fault"); }
symbol& bad_matrix_sym() { return sym("bad_matrix_value"); }
symbol& amp_sym();
- // these may be undefined
- symbol* complex_rect_sym() { return lookup("+:"); }
- symbol* complex_polar_sym() { return lookup("<:"); }
+ // These aren't predefined and aren't in the prelude either, so they may be
+ // undefined in which case a null pointer is returned. Pass force=true to
+ // forcibly create these symbols.
+ symbol* complex_rect_sym(bool force = false);
+ symbol* complex_polar_sym(bool force = false);
};
#endif // ! SYMTABLE_HH
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X