aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compile.cpp4
-rw-r--r--src/constrain.cpp131
-rw-r--r--src/depoly.cpp130
-rw-r--r--src/repl.cpp11
-rw-r--r--src/resp.cpp2
-rw-r--r--src/resp.hpp11
-rw-r--r--src/simplify.cpp13
7 files changed, 248 insertions, 54 deletions
diff --git a/src/compile.cpp b/src/compile.cpp
index ecd0807..d7b535d 100644
--- a/src/compile.cpp
+++ b/src/compile.cpp
@@ -56,6 +56,10 @@ compile_literal_symbol(CEnv& cenv, const ASymbol* sym) throw()
static CVal
compile_cons(CEnv& cenv, const ATuple* cons) throw()
{
+ if (is_form(cons, "Symbol")) {
+ return compile_literal_symbol(cenv, cons->frst()->as_symbol());
+ }
+
const ASymbol* tname = cons->fst()->as_symbol();
ATuple* type = new ATuple(tname, NULL, Cursor());
List tlist(type);
diff --git a/src/constrain.cpp b/src/constrain.cpp
index 78accf6..83a027a 100644
--- a/src/constrain.cpp
+++ b/src/constrain.cpp
@@ -35,26 +35,57 @@ constrain_symbol(TEnv& tenv, Constraints& c, const ASymbol* sym) throw(Error)
static void
constrain_cons(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
{
- const ASymbol* sym = (*call->begin())->as_symbol();
- const AST* type = NULL;
+ const ASymbol* name = (*call->begin())->as_symbol();
+ // Constrain each argument
for (ATuple::const_iterator i = call->iter_at(1); i != call->end(); ++i)
- resp_constrain(tenv, c, *i);
+ resp_constrain(tenv, c, *i); // ::= ?Targi
- if (!strcmp(sym->sym(), "Tup")) {
- List tupT(new ATuple(tenv.Tup, NULL, call->loc));
+ if (!strcmp(name->sym(), "Tup")) {
+ // Build a type expression like (Tup ?Targ1 ...)
+ List tupT(new ATuple(name, NULL, call->loc));
for (ATuple::const_iterator i = call->iter_at(1); i != call->end(); ++i) {
tupT.push_back(tenv.var(*i));
}
- type = tupT;
+ c.constrain(tenv, call, tupT);
} else {
- const AST** consTRef = tenv.ref(sym);
- THROW_IF(!consTRef, call->loc,
- (format("call to undefined constructor `%1%'") % sym->sym()).str());
- const AST* consT = *consTRef;
- type = new ATuple(consT->as_tuple()->fst(), 0, call->loc);
+ // Look up constructor and use its type
+ TEnv::Tags::const_iterator tag = tenv.tags.find(name->str());
+ THROW_IF(tag == tenv.tags.end(), name->loc,
+ (format("undefined constructor `%1%'") % name->sym()).str());
+
+ // Build a substitution for every tvar in the constructor pattern
+ Subst subst;
+ const ATuple* expr = tag->second.expr->as_tuple();
+ ATuple::const_iterator e = expr->iter_at(1);
+ for (ATuple::const_iterator i = call->iter_at(1); i != call->end(); ++i, ++e) {
+ const ASymbol* sym = (*e)->to_symbol();
+ if (sym && !isupper(sym->str()[0])) {
+ // Argument corresponds to type variable in constructor pattern
+ subst.add(*e, tenv.var(*i));
+ }
+ }
+
+ // Substitute tvar symbols with the tvar for the corresponding argument
+ const AST* pattern = subst.apply(tag->second.type);
+
+ // Replace remaining tvar symbols with a free tvar
+ for (ATuple::const_iterator i = pattern->as_tuple()->iter_at(1);
+ i != pattern->as_tuple()->end(); ++i) {
+ const ASymbol* sym = (*i)->to_symbol();
+ if (sym && islower(sym->str()[0])) {
+ subst.add(sym, tenv.var());
+ }
+ }
+
+ // Constrain every argument to the corresponding pattern element
+ e = expr->iter_at(1);
+ for (ATuple::const_iterator i = call->iter_at(1); i != call->end(); ++i, ++e) {
+ c.constrain(tenv, *i, subst.apply(*e));
+ }
+
+ c.constrain(tenv, call, subst.apply(pattern));
}
- c.constrain(tenv, call, type);
}
static void
@@ -105,18 +136,12 @@ constrain_def_type(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
const ASymbol* sym = (*prot->begin())->as_symbol();
THROW_IF(!sym, (*prot->begin())->loc, "type name is not a symbol");
THROW_IF(tenv.ref(sym), call->loc, "type redefinition");
- List type(new ATuple(tenv.U, NULL, call->loc));
+ List type(call->loc, tenv.penv.sym("Lambda"), prot->rst(), NULL);
for (ATuple::const_iterator i = call->iter_at(2); i != call->end(); ++i) {
- const ATuple* exp = (*i)->as_tuple();
- const ASymbol* tag = (*exp->begin())->as_symbol();
- List consT;
- consT.push_back(sym);
- for (ATuple::const_iterator i = exp->begin(); i != exp->end(); ++i) {
- consT.push_back(*i); // FIXME: ensure symbol, or list of symbol
- }
- consT.head->loc = exp->loc;
- type.push_back(consT);
- tenv.def(tag, consT);
+ const ATuple* exp = (*i)->as_tuple();
+ const ASymbol* tag = (*exp->begin())->as_symbol();
+ tenv.tags.insert(std::make_pair(tag->str(), TEnv::Constructor(exp, prot)));
+ type.push_back(exp);
}
tenv.def(sym, type);
}
@@ -233,35 +258,42 @@ constrain_match(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
THROW_IF(call->list_len() < 5, call->loc, "`match' requires at least 4 arguments");
const AST* matchee = call->list_ref(1);
const AST* retT = tenv.var();
- const AST* matcheeT = NULL;
+ const AST* matcheeT = tenv.var();
resp_constrain(tenv, c, matchee);
for (ATuple::const_iterator i = call->iter_at(2); i != call->end();) {
const AST* exp = *i++;
const ATuple* pattern = exp->to_tuple();
- THROW_IF(!pattern, exp->loc, "pattern expression expected");
+ THROW_IF(!pattern, exp->loc, "missing pattern");
+ THROW_IF(i == call->end(), pattern->loc, "missing expression");
+
+ const AST* body = *i++;
const ASymbol* name = (*pattern->begin())->to_symbol();
THROW_IF(!name, (*pattern->begin())->loc, "pattern does not start with a symbol");
- THROW_IF(!tenv.ref(name), name->loc,
- (format("undefined constructor `%1%'") % name->sym()).str());
- const AST* consT = *tenv.ref(name);
+ TEnv::Tags::const_iterator tag = tenv.tags.find(name->str());
+ THROW_IF(tag == tenv.tags.end(), name->loc,
+ (format("undefined constructor `%1%'") % name->sym()).str());
- if (!matcheeT) {
- const AST* headT = consT->as_tuple()->fst();
- matcheeT = new ATuple(headT, 0, call->loc);
+ const TEnv::Constructor& constructor = tag->second;
+ TEnv::Frame frame;
+ ATuple::const_iterator ei = constructor.expr->as_tuple()->iter_at(1);
+ for (ATuple::const_iterator pi = pattern->iter_at(1); pi != pattern->end(); ++pi, ++ei) {
+ const AST* tvar = tenv.var(*pi);
+ frame.push_back(make_pair((*pi)->as_symbol()->sym(), tvar));
}
- THROW_IF(i == call->end(), pattern->loc, "missing pattern body");
- const AST* body = *i++;
-
- TEnv::Frame frame;
- ATuple::const_iterator ti = consT->as_tuple()->iter_at(2);
- for (ATuple::const_iterator pi = pattern->iter_at(1); pi != pattern->end(); ++pi)
- frame.push_back(make_pair((*pi)->as_symbol()->sym(), *ti++));
-
tenv.push(frame);
resp_constrain(tenv, c, body);
c.constrain(tenv, body, retT);
+
+ // Copy the type's prototype replacing symbols with real type variables
+ List type(matchee->loc, constructor.type->as_tuple()->fst(), NULL);
+ for (ATuple::const_iterator t = constructor.type->as_tuple()->iter_at(1);
+ t != constructor.type->as_tuple()->end(); ++t) {
+ type.push_back(tenv.var());
+ }
+
+ c.constrain(tenv, matchee, type);
tenv.pop();
}
c.constrain(tenv, call, retT);
@@ -271,16 +303,21 @@ constrain_match(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error)
static void
resp_constrain_quoted(TEnv& tenv, Constraints& c, const AST* ast) throw(Error)
{
- switch (ast->tag()) {
- case T_SYMBOL:
+ if (ast->tag() == T_SYMBOL) {
c.constrain(tenv, ast, tenv.named("Symbol"));
- return;
- case T_TUPLE:
- c.constrain(tenv, ast, tenv.named("List"));
- FOREACHP(ATuple::const_iterator, i, ast->as_tuple())
+ } else if (ast->tag() == T_TUPLE) {
+ List tupT(new ATuple(tenv.List, NULL, ast->loc));
+ const ATuple* tup = ast->as_tuple();
+ const AST* fstT = tenv.var(tup->fst());
+
+ tupT.push_back(tenv.penv.sym("Expr"));
+ c.constrain(tenv, ast, tupT);
+ c.constrain(tenv, tup->fst(), fstT);
+ FOREACHP(ATuple::const_iterator, i, ast->as_tuple()) {
resp_constrain_quoted(tenv, c, *i);
- return;
- default:
+ }
+
+ } else {
resp_constrain(tenv, c, ast);
}
}
diff --git a/src/depoly.cpp b/src/depoly.cpp
new file mode 100644
index 0000000..2b8554b
--- /dev/null
+++ b/src/depoly.cpp
@@ -0,0 +1,130 @@
+/* Resp: A programming language
+ * Copyright (C) 2008-2012 David Robillard <http://drobilla.net>
+ *
+ * Resp is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Resp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Resp. If not, see <http://www.gnu.org/licenses/>.
+ */
+
+/** @file
+ * @brief Lift instances of parametric types
+ */
+
+#include <string>
+#include <vector>
+
+#include "resp.hpp"
+
+using namespace std;
+
+static bool
+is_concrete(const AST* type)
+{
+ if (type->tag() == T_TVAR) {
+ return false;
+ } else if (type->tag() == T_SYMBOL) {
+ return isupper(type->as_symbol()->str()[0]);
+ } else {
+ const ATuple* tup = type->as_tuple();
+ for (ATuple::const_iterator i = tup->begin(); i != tup->end(); ++i) {
+ if (!is_concrete(*i)) {
+ return false;
+ }
+ }
+ }
+ return true;
+}
+
+static const AST*
+depoly_def_type(CEnv& cenv, Code& code, const ATuple* def) throw()
+{
+ const ASymbol* name = def->frst()->to_symbol();
+ if (name) {
+ cenv.tenv.def(name, def->frrst());
+ return def;
+ } else if (is_concrete(def->frst())) {
+ name = def->frst()->as_tuple()->fst()->as_symbol();
+ cenv.tenv.def(name, def->frrst());
+ return def;
+ }
+ return NULL;
+}
+
+// Create concrete type definitions for a parametric type instantation
+static void
+raise_type(CEnv& cenv, Code& code, const ATuple* type)
+{
+ const ASymbol* tag = type->fst()->as_symbol();
+ if (tag->str() == "Tup" || !type->rst()) {
+ return;
+ }
+
+ const ATuple* exp = (*cenv.tenv.ref(tag))->as_tuple();
+ const ATuple* prot = exp->frst()->as_tuple();
+
+ List def(Cursor(), cenv.penv.sym("def-type"), type, NULL);
+
+ // Build a substitution for each type parameter to its instantiation
+ Subst subst;
+ ATuple::const_iterator t = type->iter_at(1);
+ for (ATuple::const_iterator p = prot->iter_at(0);
+ p != prot->end() && t != type->end();
+ ++p, ++t) {
+ subst.add(*p, *t);
+ }
+
+ // Apply substitution to each clause and add it to the new type definition
+ for (ATuple::const_iterator i = exp->iter_at(2); i != exp->end(); ++i) {
+ def.push_back(subst.apply(*i));
+ }
+
+ code.push_back(def);
+}
+
+static const AST*
+depoly_args(CEnv& cenv, Code& code, const ATuple* call) throw()
+{
+ for (ATuple::const_iterator i = call->begin(); i != call->end(); ++i) {
+ const AST* type = cenv.type(*i);
+ if (type && type->to_tuple()) {
+ if (is_concrete(type)) {
+ raise_type(cenv, code, type->as_tuple());
+ }
+ }
+ }
+ return call;
+}
+
+const AST*
+resp_depoly(CEnv& cenv, Code& code, const AST* ast) throw()
+{
+ switch (ast->tag()) {
+ case T_TUPLE: {
+ const ATuple* const call = ast->as_tuple();
+ const ASymbol* const sym = call->fst()->to_symbol();
+ const std::string form = sym ? sym->sym() : "";
+ assert(form != "fn");
+ if (form == "quote")
+ return ast;
+ else if (form == "def-type")
+ return depoly_def_type(cenv, code, call);
+ else
+ return depoly_args(cenv, code, call);
+ }
+ default:
+ return ast;
+ }
+
+ cenv.err << "Attempt to depoly unknown type: " << ast << endl;
+ assert(false);
+ return NULL;
+}
diff --git a/src/repl.cpp b/src/repl.cpp
index 4e9c44c..1169b3d 100644
--- a/src/repl.cpp
+++ b/src/repl.cpp
@@ -109,10 +109,19 @@ compile(CEnv& cenv, const Code& parsed, Code& defs, bool& hasMain, const char* m
if (cenv.args.find("-L") != cenv.args.end())
return dump(cenv, lifted);
+ // Depoly all expressions
+ Code concrete;
+ for (Code::const_iterator i = lifted.begin(); i != lifted.end(); ++i)
+ if ((exp = resp_depoly(cenv, concrete, *i)))
+ concrete.push_back(exp);
+ if (cenv.args.find("-D") != cenv.args.end()) {
+ return dump(cenv, concrete);
+ }
+
// Flatten expressions
const AST* retT = NULL;
Code exprs;
- for (Code::const_iterator i = lifted.begin(); i != lifted.end(); ++i) {
+ for (Code::const_iterator i = concrete.begin(); i != concrete.end(); ++i) {
const ATuple* call = (*i)->to_tuple();
if (call && (is_form(*i, "def-type")
|| (is_form(*i, "def") && is_form(call->frrst(), "fn")))) {
diff --git a/src/resp.cpp b/src/resp.cpp
index b0d1f72..51e5ea6 100644
--- a/src/resp.cpp
+++ b/src/resp.cpp
@@ -80,6 +80,7 @@ print_usage(char* name, bool error)
os << " -R Reduce to simpler forms only" << endl;
os << " -C Convert to CPS only" << endl;
os << " -L Lambda lift only" << endl;
+ os << " -D Depoly only" << endl;
os << " -F Flatten only" << endl;
os << " -S Compile to assembly only (do not execute)" << endl;
@@ -101,6 +102,7 @@ main(int argc, char** argv)
} else if (!strncmp(argv[i], "-C", 3)
|| !strncmp(argv[i], "-F", 3)
|| !strncmp(argv[i], "-L", 3)
+ || !strncmp(argv[i], "-D", 3)
|| !strncmp(argv[i], "-P", 3)
|| !strncmp(argv[i], "-R", 3)
|| !strncmp(argv[i], "-S", 3)
diff --git a/src/resp.hpp b/src/resp.hpp
index d6a46ab..8d37cd3 100644
--- a/src/resp.hpp
+++ b/src/resp.hpp
@@ -640,7 +640,17 @@ struct TEnv : public Env<const AST*> {
typedef map<const AST*, const AST*> Vars;
+ /// Discriminated Union Constructor
+ struct Constructor {
+ Constructor(const AST* x, const AST* t) : expr(x), type(t) {}
+ const AST* expr;
+ const AST* type;
+ };
+
+ typedef map<const std::string, Constructor> Tags;
+
Vars vars;
+ Tags tags;
PEnv& penv;
unsigned varID;
@@ -834,6 +844,7 @@ const AST* resp_simplify(CEnv& cenv, const AST* ast) throw();
const AST* resp_cps(CEnv& cenv, const AST* ast, const AST* k) throw();
const AST* resp_lift(CEnv& cenv, Code& code, const AST* ast) throw();
const AST* resp_flatten(CEnv& cenv, Code& code, const AST* ast) throw();
+const AST* resp_depoly(CEnv& cenv, Code& code, const AST* ast) throw();
CVal resp_compile(CEnv& cenv, const AST* ast) throw();
bool is_form(const AST* ast, const std::string& form);
diff --git a/src/simplify.cpp b/src/simplify.cpp
index 2085ad9..e081bf7 100644
--- a/src/simplify.cpp
+++ b/src/simplify.cpp
@@ -78,7 +78,8 @@ simplify_match(CEnv& cenv, const ATuple* match) throw()
const_cast<ASymbol*>(consTag)->tag(T_LITSYM);
cenv.setType(consTag, cenv.tenv.named("Symbol"));
- const ATuple* texp = cenv.tenv.named(consTag->sym())->as_tuple();
+ const TEnv::Constructor& constructor = cenv.tenv.tags.find(consTag->str())->second;
+ const ATuple* texp = constructor.expr->as_tuple();
// Append condition for this case
List cond(Cursor(), cenv.penv.sym("="), tsym, consTag, 0);
@@ -87,7 +88,7 @@ simplify_match(CEnv& cenv, const ATuple* match) throw()
// If constructor has no variables, append body and continue
// (don't generate pointless fn)
- if (texp->list_len() == 2) {
+ if (texp->list_len() == 1) {
copyIf.push_back(body);
continue;
}
@@ -95,11 +96,11 @@ simplify_match(CEnv& cenv, const ATuple* match) throw()
// Build fn for the body of this case
const ASymbol* osym = cenv.penv.gensym("__obj");
const ATuple* prot = new ATuple(osym, 0, Cursor());
- const ATuple* protT = new ATuple(texp->rst(), 0, Cursor());
+ const ATuple* protT = new ATuple(texp, 0, Cursor());
List fn(Cursor(), cenv.penv.sym("fn"), prot, 0);
int idx = 0;
- ATuple::const_iterator ti = texp->iter_at(2);
+ ATuple::const_iterator ti = texp->iter_at(1);
for (ATuple::const_iterator j = pat->iter_at(1); j != pat->end(); ++j, ++ti, ++idx) {
const AST* index = new ALiteral<int32_t>(T_INT32, idx, Cursor());
const AST* dot = tup(Cursor(), cenv.penv.sym("."), osym, index, 0);
@@ -186,7 +187,7 @@ simplify_list_elem(CEnv& cenv, const ATuple* node, const AST* type)
const AST* const rst = simplify_list_elem(cenv, node->rst(), type);
assert(node->fst());
assert(rst);
- List cons(node->loc, cenv.tenv.List, fst, rst, 0);
+ List cons(node->loc, cenv.tenv.Tup, fst, rst, 0);
cenv.setType(fst, tup(Cursor(), cenv.penv.sym("Expr"), 0));
cenv.setType(cons, type);
return cons;
@@ -203,7 +204,7 @@ simplify_quote(CEnv& cenv, const ATuple* call) throw()
// Lists are transformed into nested conses
const ATuple* const list = call->frst()->as_tuple();
return simplify_list_elem(cenv, list,
- tup(Cursor(), cenv.tenv.List, cenv.penv.sym("Expr"), 0));
+ tup(Cursor(), cenv.tenv.Tup, cenv.penv.sym("Expr"), 0));
}
default:
// Other literals (e.g. numbers, strings) are self-evaluating, so the
generated by cgit v1.2.1 (git 2.18.0) at 2025-03-14 07:37:02 +0000