[pure-lang-svn] SF.net SVN: pure-lang: [279] pure/trunk
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
[pure-lang-svn] SF.net SVN: pure-lang: [279] pure/trunk
|
From: <ag...@us...> - 2008-06-22 21:07:09
|
Revision: 279
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=279&view=rev
Author: agraef
Date: 2008-06-22 14:07:18 -0700 (Sun, 22 Jun 2008)
Log Message:
-----------
Implement Haskell-like "as" patterns.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/expr.cc
pure/trunk/expr.hh
pure/trunk/interpreter.cc
pure/trunk/interpreter.hh
pure/trunk/lexer.ll
pure/trunk/parser.yy
pure/trunk/printer.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/ChangeLog 2008-06-22 21:07:18 UTC (rev 279)
@@ -1,3 +1,8 @@
+2008-06-22 Albert Graef <Dr....@t-...>
+
+ * expr.cc, interpreter.cc, parser.yy, lexer.ll: Implement
+ Haskell-like "as" patterns.
+
2008-06-21 Albert Graef <Dr....@t-...>
* etc/pure-mode.el.in, etc/pure.vim, etc/pure.xml, etc/pure.lang:
Modified: pure/trunk/expr.cc
===================================================================
--- pure/trunk/expr.cc 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/expr.cc 2008-06-22 21:07:18 UTC (rev 279)
@@ -44,6 +44,7 @@
if (data.c.e) delete data.c.e;
break;
}
+ if (aspath) delete aspath;
}
map<EXPR*,uint32_t> expr::h;
Modified: pure/trunk/expr.hh
===================================================================
--- pure/trunk/expr.hh 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/expr.hh 2008-06-22 21:07:18 UTC (rev 279)
@@ -146,60 +146,64 @@
// extra built-in type tag used in code generation:
int8_t ttag;
+ // "as" patterns:
+ int32_t astag;
+ path *aspath;
+
EXPR *incref() { refc++; return this; }
uint32_t decref() { if (refc > 0) --refc; return refc; }
void del() { if (decref() == 0) delete this; }
static EXPR *newref(EXPR *x) { return x?x->incref():0; }
EXPR(int32_t _tag) :
- refc(0), tag(_tag), m(0), ttag(0) { }
+ refc(0), tag(_tag), m(0), ttag(0), astag(0), aspath(0) { }
EXPR(int32_t _tag, int32_t _vtag, uint8_t _idx,
int8_t _ttag = 0, const path& _p = path()) :
- refc(0), tag(_tag), m(0), ttag(_ttag)
+ refc(0), tag(_tag), m(0), ttag(_ttag), astag(0), aspath(0)
{ assert(_tag == VAR || _tag == FVAR);
data.v.vtag = _vtag; data.v.idx = _idx;
data.v.p = (_tag == VAR)?new path(_p):0; }
EXPR(int32_t _tag, int32_t _i) :
- refc(0), tag(_tag), m(0), ttag(_tag)
+ refc(0), tag(_tag), m(0), ttag(_tag), astag(0), aspath(0)
{ assert(_tag == INT); data.i = _i; }
EXPR(int32_t _tag, mpz_t _z) :
- refc(0), tag(_tag), m(0), ttag(_tag)
+ refc(0), tag(_tag), m(0), ttag(_tag), astag(0), aspath(0)
{ assert(_tag == BIGINT); mpz_init_set(data.z, _z); mpz_clear(_z); }
EXPR(int32_t _tag, double _d) :
- refc(0), tag(_tag), m(0), ttag(_tag)
+ refc(0), tag(_tag), m(0), ttag(_tag), astag(0), aspath(0)
{ assert(_tag == DBL); data.d = _d; }
explicit EXPR(int32_t _tag, char *_s) :
- refc(0), tag(_tag), m(0), ttag(_tag)
+ refc(0), tag(_tag), m(0), ttag(_tag), astag(0), aspath(0)
{ assert(_tag == STR); data.s = _s; }
explicit EXPR(int32_t _tag, void *_p) :
- refc(0), tag(_tag), m(0), ttag(_tag)
+ refc(0), tag(_tag), m(0), ttag(_tag), astag(0), aspath(0)
{ assert(_tag == PTR); data.p = _p; }
EXPR(int32_t _tag, EXPR *_arg1, EXPR *_arg2, EXPR *_arg3) :
- refc(0), tag(_tag), m(0), ttag(0)
+ refc(0), tag(_tag), m(0), ttag(0), astag(0), aspath(0)
{ assert(_tag == COND);
data.x[0] = newref(_arg1); data.x[1] = newref(_arg2);
data.x[2] = newref(_arg3); }
EXPR(int32_t _tag, EXPR *_arg, EXPR *_body) :
- refc(0), tag(_tag), m(0), ttag(0)
+ refc(0), tag(_tag), m(0), ttag(0), astag(0), aspath(0)
{ assert(_tag == LAMBDA);
data.x[0] = newref(_arg); data.x[1] = newref(_body); }
EXPR(int32_t _tag, EXPR *_arg, rulel *_rules) :
- refc(0), tag(_tag), m(0), ttag(0)
+ refc(0), tag(_tag), m(0), ttag(0), astag(0), aspath(0)
{ assert(_tag == CASE || _tag == WHEN);
data.c.x = newref(_arg); data.c.r = _rules; }
EXPR(int32_t _tag, EXPR *_arg, env *_e) :
- refc(0), tag(_tag), m(0), ttag(0)
+ refc(0), tag(_tag), m(0), ttag(0), astag(0), aspath(0)
{ assert(_tag == WITH);
data.c.x = newref(_arg); data.c.e = _e; }
EXPR(EXPR *_fun, EXPR *_arg) :
- refc(0), tag(APP), m(0), ttag(0)
+ refc(0), tag(APP), m(0), ttag(0), astag(0), aspath(0)
{ data.x[0] = newref(_fun); data.x[1] = newref(_arg); }
EXPR(EXPR *_fun, EXPR *_arg1, EXPR *_arg2) :
- refc(0), tag(APP), m(0), ttag(0)
+ refc(0), tag(APP), m(0), ttag(0), astag(0), aspath(0)
{ data.x[0] = new EXPR(_fun, _arg1);
data.x[0]->incref(); data.x[1] = newref(_arg2); }
EXPR(EXPR *_fun, EXPR *_arg1, EXPR *_arg2, EXPR *_arg3) :
- refc(0), tag(APP), m(0), ttag(0)
+ refc(0), tag(APP), m(0), ttag(0), astag(0), aspath(0)
{ data.x[0] = new EXPR(_fun, _arg1, _arg2);
data.x[0]->incref(); data.x[1] = newref(_arg3); }
@@ -333,8 +337,13 @@
p->tag == EXPR::CASE ||
p->tag == EXPR::WHEN);
return p->m; }
+ int32_t astag() const { return p->astag; }
+ path &aspath() const { assert(p->aspath); return *p->aspath; }
void set_ttag(int8_t tag) { p->ttag = tag; }
+ void set_astag(int32_t tag) { p->astag = tag; }
+ void set_aspath(const path& _p)
+ { if (p->aspath) delete p->aspath; p->aspath = new path(_p); }
bool is_null() const { return p==0; }
bool is_fun() const { return p->tag > 0; }
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/interpreter.cc 2008-06-22 21:07:18 UTC (rev 279)
@@ -671,6 +671,10 @@
void interpreter::build_env(env& vars, expr x)
{
assert(!x.is_null());
+ if (x.astag() > 0) {
+ const symbol& sym = symtab.sym(x.astag());
+ if (sym.s != "_") vars[sym.f] = env_info(0, x.aspath());
+ }
switch (x.tag()) {
case EXPR::VAR: {
const symbol& sym = symtab.sym(x.vtag());
@@ -999,6 +1003,7 @@
expr interpreter::bind(env& vars, expr x, bool b, path p)
{
assert(!x.is_null());
+ expr y;
switch (x.tag()) {
case EXPR::VAR: {
// previously bound variable (successor rule)
@@ -1007,7 +1012,8 @@
assert(p == x.vpath());
vars[sym.f] = env_info(x.ttag(), p);
}
- return x;
+ y = x;
+ break;
}
// constants:
case EXPR::FVAR:
@@ -1016,26 +1022,33 @@
case EXPR::DBL:
case EXPR::STR:
case EXPR::PTR:
- return x;
+ y = x;
+ break;
// application:
case EXPR::APP: {
if (p.len() >= MAXDEPTH)
throw err("error in pattern (nesting too deep)");
expr u = bind(vars, x.xval1(), 1, path(p, 0)),
v = bind(vars, x.xval2(), 1, path(p, 1));
- return expr(u, v);
+ y = expr(u, v);
+ break;
}
// these must not occur on the lhs:
case EXPR::LAMBDA:
throw err("lambda expression not permitted in pattern");
+ break;
case EXPR::COND:
throw err("conditional expression not permitted in pattern");
+ break;
case EXPR::CASE:
throw err("case expression not permitted in pattern");
+ break;
case EXPR::WHEN:
throw err("when expression not permitted in pattern");
+ break;
case EXPR::WITH:
throw err("with expression not permitted in pattern");
+ break;
default:
assert(x.tag() > 0);
const symbol& sym = symtab.sym(x.tag());
@@ -1043,17 +1056,37 @@
p.len() > 0 && p.last() == 0) {
// constant or constructor
if (x.ttag() != 0)
- throw err("error in expression (misplaced type tag)");
- return x;
+ throw err("error in pattern (misplaced type tag)");
+ y = x;
+ } else {
+ env::iterator it = vars.find(sym.f);
+ if (sym.s != "_") { // '_' = anonymous variable
+ if (it != vars.end())
+ throw err("error in pattern (repeated variable '"+sym.s+"')");
+ vars[sym.f] = env_info(x.ttag(), p);
+ }
+ y = expr(EXPR::VAR, sym.f, 0, x.ttag(), p);
}
- env::iterator it = vars.find(sym.f);
- if (sym.s != "_") { // '_' = anonymous variable
- if (it != vars.end())
+ break;
+ }
+ // check for "as" patterns
+ if (x.astag() > 0) {
+ const symbol& sym = symtab.sym(x.astag());
+ if (sym.s != "_") {
+ if (sym.prec < 10 || sym.fix == nullary)
+ throw err("error in pattern (bad variable symbol '"+sym.s+"')");
+ if (p.len() == 0 && !b)
+ throw err("error in pattern (misplaced variable '"+sym.s+"')");
+ env::iterator it = vars.find(sym.f);
+ if (it != vars.end()) {
throw err("error in pattern (repeated variable '"+sym.s+"')");
- vars[sym.f] = env_info(x.ttag(), p);
+ }
+ vars[sym.f] = env_info(0, p);
+ y.set_astag(x.astag());
+ y.set_aspath(p);
}
- return expr(EXPR::VAR, sym.f, 0, x.ttag(), p);
}
+ return y;
}
void interpreter::promote_ttags(expr f, expr x, expr u)
@@ -1124,6 +1157,8 @@
expr interpreter::subst(const env& vars, expr x, uint8_t idx)
{
if (x.is_null()) return x;
+ if (x.astag() > 0)
+ throw err("error in expression (misplaced \"as\" pattern)");
switch (x.tag()) {
// constants:
case EXPR::VAR:
@@ -1373,7 +1408,12 @@
expr *x;
const symbol &sym = symtab.sym(*s);
if (tag == 0)
- x = new expr(sym.x);
+ if (*s == "_")
+ // Return a new instance here, since the anonymous variable may have
+ // multiple occurrences on the lhs.
+ x = new expr(sym.f);
+ else
+ x = new expr(sym.x);
else if (sym.f <= 0 || sym.prec < 10 || sym.fix == nullary)
throw err("error in expression (misplaced type tag)");
else {
@@ -1385,6 +1425,22 @@
return x;
}
+expr *interpreter::mkas_expr(string *s, expr *x)
+{
+ const symbol &sym = symtab.sym(*s);
+ if (sym.f <= 0 || sym.prec < 10 || sym.fix == nullary)
+ throw err("error in pattern (bad variable symbol '"+sym.s+"')");
+ if (x->tag() > 0) {
+ // Avoid globbering cached function symbols.
+ expr *y = new expr(x->tag());
+ delete x;
+ x = y;
+ }
+ x->set_astag(sym.f);
+ delete s;
+ return x;
+}
+
expr *interpreter::mkcond_expr(expr *x, expr *y, expr *z)
{
expr *u = new expr(expr::cond(*x, *y, *z));
Modified: pure/trunk/interpreter.hh
===================================================================
--- pure/trunk/interpreter.hh 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/interpreter.hh 2008-06-22 21:07:18 UTC (rev 279)
@@ -369,6 +369,7 @@
expr *mkexpr(expr *x, expr *y);
expr *mkexpr(expr *x, expr *y, expr *z);
expr *mksym_expr(string *s, int8_t tag = 0);
+ expr *mkas_expr(string *s, expr *x);
expr *mkcond_expr(expr *x, expr *y, expr *z);
expr *mklambda_expr(exprl *args, expr *body);
expr *mkcase_expr(expr *x, rulel *rules);
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/lexer.ll 2008-06-22 21:07:18 UTC (rev 279)
@@ -755,7 +755,7 @@
return token::ID;
}
}
-[=|;()\[\]\\] return yy::parser::token_type(yytext[0]);
+[@=|;()\[\]\\] return yy::parser::token_type(yytext[0]);
"->" return token::MAPSTO;
[[:punct:]]+ {
if (yytext[0] == '/' && yytext[1] == '*') REJECT; // comment starter
Modified: pure/trunk/parser.yy
===================================================================
--- pure/trunk/parser.yy 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/parser.yy 2008-06-22 21:07:18 UTC (rev 279)
@@ -498,6 +498,11 @@
interp.error(yyloc, e.what());
$$ = interp.mksym_expr($1);
} }
+| ID '@' prim { try { $$ = interp.mkas_expr($1, $3); }
+ catch (err &e) {
+ interp.error(yyloc, e.what());
+ $$ = $3;
+ } }
| INT { $$ = new expr(EXPR::INT, $1); }
| BIGINT { $$ = new expr(EXPR::BIGINT, *$1); free($1); }
| DBL { $$ = new expr(EXPR::DBL, $1); }
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-06-21 22:23:15 UTC (rev 278)
+++ pure/trunk/printer.cc 2008-06-22 21:07:18 UTC (rev 279)
@@ -53,9 +53,9 @@
}
}
-static prec_t expr_nprec(expr x)
+static prec_t expr_nprec(expr x, bool aspat = true)
{
- if (x.is_null()) return 100;
+ if (x.is_null() || aspat && x.astag()>0) return 100;
switch (x.tag()) {
case EXPR::VAR:
case EXPR::STR:
@@ -119,7 +119,8 @@
: x(_x), pat(_pat) { }
};
-static ostream& printx(ostream& os, const expr& x, bool pat);
+static ostream& printx(ostream& os, const expr& x, bool pat,
+ bool aspat = true);
ostream& operator << (ostream& os, const pattern& p)
{
@@ -162,11 +163,23 @@
}
}
-static ostream& printx(ostream& os, const expr& x, bool pat)
+static ostream& printx(ostream& os, const expr& x, bool pat, bool aspat)
{
char buf[64];
if (x.is_null()) return os << "<<NULL>>";
//os << "{" << x.refc() << "}";
+ // handle "as" patterns
+ if (aspat && x.astag()>0) {
+ const symbol& sym = interpreter::g_interp->symtab.sym(x.astag());
+ if (expr_nprec(x, false) < 100) {
+ os << sym.s << "@(";
+ printx(os, x, pat, false);
+ return os << ")";
+ } else {
+ os << sym.s << "@";
+ return printx(os, x, pat, false);
+ }
+ }
switch (x.tag()) {
case EXPR::VAR: {
const symbol& sym = interpreter::g_interp->symtab.sym(x.vtag());
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
