From 42b51cce2575fa138fddf1cfd4581bf1d1568b24 Mon Sep 17 00:00:00 2001 From: David Robillard Date: Wed, 29 Dec 2010 00:35:28 +0000 Subject: Literal lists (i.e. list quoting). Compile type expressions. Only compile a top-level function if program has code to run (i.e. isn't just definitions). Cast tuples to Object when necessary to avoid LLVM IR type mismatches (for cons stores and return values). Fix memory leaks. git-svn-id: http://svn.drobilla.net/resp/resp@369 ad02d1e2-f140-0410-9f75-f8b11f17cedd --- src/c.cpp | 37 +++++++++++++------ src/compile.cpp | 20 +++++++++-- src/constrain.cpp | 29 ++++++++++----- src/expand.cpp | 2 +- src/llvm.cpp | 104 ++++++++++++++++++++++++++++++++++++++++++++---------- src/pprint.cpp | 7 ++-- src/repl.cpp | 29 ++++++++------- src/resp.hpp | 48 +++++++++++++++---------- src/simplify.cpp | 35 +++++++++++++++--- 9 files changed, 231 insertions(+), 80 deletions(-) (limited to 'src') diff --git a/src/c.cpp b/src/c.cpp index a00c89b..7d5b125 100644 --- a/src/c.cpp +++ b/src/c.cpp @@ -43,18 +43,21 @@ struct CEngine : public Engine { CFunc startFn(CEnv& cenv, const string& name, const ATuple* args, const ATuple* type); void pushFnArgs(CEnv& cenv, const ATuple* prot, const ATuple* type, CFunc f); - void finishFn(CEnv& cenv, CFunc f, CVal ret); + void finishFn(CEnv& cenv, CFunc f, CVal ret, const AST* retT); void eraseFn(CEnv& cenv, CFunc f); - CVal compileCall(CEnv& cenv, CFunc f, const ATuple* funcT, const vector& args); - CVal compileCons(CEnv& cenv, const ATuple* type, CVal rtti, const vector& fields); - CVal compileDot(CEnv& cenv, CVal tup, int32_t index); - CVal compileGlobalSet(CEnv& cenv, const string& s, CVal v, const AST* t); - CVal compileGlobalGet(CEnv& cenv, const string& s, CVal v); - CVal compileIf(CEnv& cenv, const AST* cond, const AST* then, const AST* aelse); - CVal compileLiteral(CEnv& cenv, const AST* lit); - CVal compilePrimitive(CEnv& cenv, const ATuple* prim); - CVal compileString(CEnv& cenv, const char* str); + CVal compileCall(CEnv& cenv, CFunc f, const ATuple* funcT, const vector& args); + CVal compileCons(CEnv& cenv, const ATuple* type, CVal rtti, const vector& fields); + CVal compileDot(CEnv& cenv, CVal tup, int32_t index); + CVal compileGlobalSet(CEnv& cenv, const string& s, CVal v, const AST* t); + CVal compileGlobalGet(CEnv& cenv, const string& s, CVal v); + CVal compileIf(CEnv& cenv, const AST* cond, const AST* then, const AST* aelse); + CVal compileLiteral(CEnv& cenv, const AST* lit); + CVal compilePrimitive(CEnv& cenv, const ATuple* prim); + CVal compileString(CEnv& cenv, const char* str); + CType compileType(CEnv& cenv, const char* name, const AST* exp); + + CType objectType(CEnv& cenv); void writeModule(CEnv& cenv, std::ostream& os); @@ -159,6 +162,18 @@ CEngine::compileString(CEnv& cenv, const char* str) return new Value(string("\"") + str + "\""); } +CType +CEngine::compileType(CEnv& cenv, const char* name, const AST* expr) +{ + return NULL; +} + +CType +CEngine::objectType(CEnv& cenv) +{ + return new string("Object"); +} + CFunc CEngine::startFn(CEnv& cenv, const std::string& name, const ATuple* args, const ATuple* type) { @@ -212,7 +227,7 @@ CEngine::pushFnArgs(CEnv& cenv, const ATuple* prot, const ATuple* type, CFunc f) } void -CEngine::finishFn(CEnv& cenv, CFunc f, CVal ret) +CEngine::finishFn(CEnv& cenv, CFunc f, CVal ret, const AST* retT) { out += "return " + *(Value*)ret + ";\n}\n\n"; } diff --git a/src/compile.cpp b/src/compile.cpp index 1de8a78..d2f0530 100644 --- a/src/compile.cpp +++ b/src/compile.cpp @@ -63,6 +63,7 @@ compile_cons(CEnv& cenv, const ATuple* cons) throw() List tlist(type); vector fields; for (ATuple::const_iterator i = cons->iter_at(1); i != cons->end(); ++i) { + assert(cenv.type(*i)); tlist.push_back(cenv.type(*i)); fields.push_back(resp_compile(cenv, *i)); } @@ -96,6 +97,19 @@ compile_def(CEnv& cenv, const ATuple* def) throw() return NULL; } +static CVal +compile_def_type(CEnv& cenv, const ATuple* def) throw() +{ + const ASymbol* name = def->frst()->as_tuple()->fst()->as_symbol(); + cenv.engine()->compileType(cenv, name->sym(), def->frst()); + for (ATuple::const_iterator i = def->iter_at(2); i != def->end(); ++i) { + const ATuple* exp = (*i)->as_tuple(); + const ASymbol* tag = (*exp->begin())->as_symbol(); + cenv.engine()->compileType(cenv, tag->sym(), exp); + } + return NULL; +} + static CVal compile_do(CEnv& cenv, const ATuple* ado) throw() { @@ -111,7 +125,7 @@ compile_fn(CEnv& cenv, const ATuple* fn) throw() { assert(!cenv.currentFn); - const AST* type = cenv.type(fn); + const AST* const type = cenv.type(fn); CFunc f = cenv.findImpl(fn, type); if (f) return f; @@ -127,7 +141,7 @@ compile_fn(CEnv& cenv, const ATuple* fn) throw() retVal = resp_compile(cenv, *i); // Write function conclusion and pop stack frame - cenv.engine()->finishFn(cenv, f, retVal); + cenv.engine()->finishFn(cenv, f, retVal, type->as_tuple()->frrst()); cenv.pop(); cenv.currentFn = NULL; @@ -204,7 +218,7 @@ resp_compile(CEnv& cenv, const AST* ast) throw() else if (form == "def") return compile_def(cenv, call); else if (form == "def-type") - return NULL; // FIXME + return compile_def_type(cenv, call); else if (form == "do") return compile_do(cenv, call); else if (form == "fn") diff --git a/src/constrain.cpp b/src/constrain.cpp index 7530f01..a4a1ad3 100644 --- a/src/constrain.cpp +++ b/src/constrain.cpp @@ -83,6 +83,7 @@ static void constrain_def(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error) { THROW_IF(call->list_len() != 3, call->loc, "`def' requires exactly 2 arguments"); + THROW_IF(!call->frst()->to_symbol(), call->frst()->loc, "`def' name is not a symbol"); const ASymbol* const sym = call->list_ref(1)->as_symbol(); THROW_IF(!sym, call->loc, "`def' has no symbol") const AST* const body = call->list_ref(2); @@ -111,9 +112,7 @@ constrain_def_type(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error) List consT; consT.push_back(sym); for (ATuple::const_iterator i = exp->begin(); i != exp->end(); ++i) { - const ASymbol* sym = (*i)->to_symbol(); - THROW_IF(!sym, (*i)->loc, "type expression element is not a symbol"); - consT.push_back(sym); + consT.push_back(*i); // FIXME: ensure symbol, or list of symbol } consT.head->loc = exp->loc; type.push_back(consT); @@ -259,15 +258,29 @@ constrain_match(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error) c.constrain(tenv, matchee, matcheeT); } +static void +resp_constrain_quoted(TEnv& tenv, Constraints& c, const AST* ast) throw(Error) +{ + switch (ast->tag()) { + case 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()) + resp_constrain_quoted(tenv, c, *i); + return; + default: + resp_constrain(tenv, c, ast); + } +} + static void constrain_quote(TEnv& tenv, Constraints& c, const ATuple* call) throw(Error) { THROW_IF(call->list_len() != 2, call->loc, "`quote' requires exactly 1 argument"); - switch (call->list_ref(1)->tag()) { - case T_TUPLE: c.constrain(tenv, call, tenv.named("List")); return; - case T_SYMBOL: c.constrain(tenv, call, tenv.named("Symbol")); return; - default: return; - } + resp_constrain_quoted(tenv, c, call->frst()); + c.constrain(tenv, call, tenv.var(call->frst())); } static void diff --git a/src/expand.cpp b/src/expand.cpp index 53a415c..e5e3255 100644 --- a/src/expand.cpp +++ b/src/expand.cpp @@ -113,7 +113,7 @@ initLang(PEnv& penv, TEnv& tenv) { // Types const char* types[] = { - "Bool", "Float", "Int", "Nothing", "String", "Symbol", "List", 0 }; + "Bool", "Float", "Int", "Nothing", "String", "Symbol", "List", "Expr", 0 }; for (const char** t = types; *t; ++t) { const ASymbol* sym = penv.sym(*t); tenv.def(sym, sym); // FIXME: define to NULL? diff --git a/src/llvm.cpp b/src/llvm.cpp index 3f48dec..cc4bf47 100644 --- a/src/llvm.cpp +++ b/src/llvm.cpp @@ -58,18 +58,21 @@ struct LLVMEngine : public Engine { CFunc startFn(CEnv& cenv, const string& name, const ATuple* args, const ATuple* type); void pushFnArgs(CEnv& cenv, const ATuple* prot, const ATuple* type, CFunc f); - void finishFn(CEnv& cenv, CFunc f, CVal ret); + void finishFn(CEnv& cenv, CFunc f, CVal ret, const AST* retT); void eraseFn(CEnv& cenv, CFunc f); - CVal compileCall(CEnv& cenv, CFunc f, const ATuple* funcT, const vector& args); - CVal compileCons(CEnv& cenv, const ATuple* type, CVal rtti, const vector& fields); - CVal compileDot(CEnv& cenv, CVal tup, int32_t index); - CVal compileGlobalSet(CEnv& cenv, const string& s, CVal v, const AST* t); - CVal compileGlobalGet(CEnv& cenv, const string& s, CVal v); - CVal compileIf(CEnv& cenv, const AST* cond, const AST* then, const AST* aelse); - CVal compileLiteral(CEnv& cenv, const AST* lit); - CVal compilePrimitive(CEnv& cenv, const ATuple* prim); - CVal compileString(CEnv& cenv, const char* str); + CVal compileCall(CEnv& cenv, CFunc f, const ATuple* funcT, const vector& args); + CVal compileCons(CEnv& cenv, const ATuple* type, CVal rtti, const vector& fields); + CVal compileDot(CEnv& cenv, CVal tup, int32_t index); + CVal compileGlobalSet(CEnv& cenv, const string& s, CVal v, const AST* t); + CVal compileGlobalGet(CEnv& cenv, const string& s, CVal v); + CVal compileIf(CEnv& cenv, const AST* cond, const AST* then, const AST* aelse); + CVal compileLiteral(CEnv& cenv, const AST* lit); + CVal compilePrimitive(CEnv& cenv, const ATuple* prim); + CVal compileString(CEnv& cenv, const char* str); + CType compileType(CEnv& cenv, const char* name, const AST* exp); + + CType objectType(CEnv& cenv); void writeModule(CEnv& cenv, std::ostream& os); @@ -91,6 +94,10 @@ private: IRBuilder<> builder; Function* alloc; FunctionPassManager* opt; + CType objectT; + + typedef std::map CTypes; + CTypes compiledTypes; unsigned labelIndex; }; @@ -114,9 +121,17 @@ LLVMEngine::LLVMEngine() // Declare host provided allocation primitive std::vector argsT(1, Type::getInt32Ty(context)); // unsigned size - FunctionType* funcT = FunctionType::get(PointerType::get(Type::getInt8Ty(context), 0), argsT, false); - alloc = Function::Create(funcT, Function::ExternalLinkage, - "resp_gc_allocate", module); + FunctionType* funcT = FunctionType::get( + PointerType::get(Type::getInt8Ty(context), 0), argsT, false); + alloc = Function::Create( + funcT, Function::ExternalLinkage, "resp_gc_allocate", module); + + // Build Object type (tag only, binary compatible with any constructed thing) + vector ctypes; + ctypes.push_back(PointerType::get(Type::getInt8Ty(context), NULL)); // RTTI + StructType* cObjectT = StructType::get(context, ctypes, false); + module->addTypeName("Object", cObjectT); + objectT = cObjectT; } LLVMEngine::~LLVMEngine() @@ -141,6 +156,7 @@ LLVMEngine::llType(const AST* t) if (sym == "Float") return Type::getFloatTy(context); if (sym == "String") return PointerType::get(Type::getInt8Ty(context), NULL); if (sym == "Symbol") return PointerType::get(Type::getInt8Ty(context), NULL); + if (sym == "Expr") return PointerType::get(Type::getInt8Ty(context), NULL); } else if (is_form(t, "Fn")) { ATuple::const_iterator i = t->as_tuple()->begin(); const ATuple* protT = (*++i)->to_tuple(); @@ -209,9 +225,16 @@ LLVMEngine::compileCons(CEnv& cenv, const ATuple* type, CVal rtti, const vector< if (rtti) builder.CreateStore((Value*)rtti, builder.CreateStructGEP(structPtr, 0, "rtti")); size_t i = 1; - for (vector::const_iterator f = fields.begin(); f != fields.end(); ++f, ++i) { - builder.CreateStore(llVal(*f), - builder.CreateStructGEP(structPtr, i, (format("tup%1%") % i).str().c_str())); + ATuple::const_iterator t = type->iter_at(1); + for (vector::const_iterator f = fields.begin(); f != fields.end(); ++f, ++i, ++t) { + Value* val = llVal(*f); + Value* field = builder.CreateStructGEP( + structPtr, i, (format("tup%1%") % i).str().c_str()); + + if ((*t)->to_tuple()) + val = builder.CreateBitCast(val, llType(*t), "objPtr"); + + builder.CreateStore(val, field); } return structPtr; @@ -245,6 +268,47 @@ LLVMEngine::compileString(CEnv& cenv, const char* str) return builder.CreateGlobalStringPtr(str); } +CType +LLVMEngine::compileType(CEnv& cenv, const char* name, const AST* expr) +{ + CTypes::const_iterator i = compiledTypes.find(name); + if (i != compiledTypes.end()) + return i->second; + + const ATuple* const tup = expr->as_tuple(); + vector ctypes; + ctypes.push_back(PointerType::get(Type::getInt8Ty(context), NULL)); // RTTI + for (ATuple::const_iterator i = tup->iter_at(1); i != tup->end(); ++i) { + const ATuple* tup = (*i)->to_tuple(); + const Type* lt = (tup) + ? (const Type*)compileType(cenv, tup->fst()->as_symbol()->sym(), *i) + : llType(*i); + if (!lt) + return NULL; + ctypes.push_back(lt); + } + + Type* structT = StructType::get(context, ctypes, false); + + // Tell LLVM opaqueT and structT are the same (for recursive types) + //PATypeHolder opaqueT = OpaqueType::get(context); + //((OpaqueType*)opaqueT.get())->refineAbstractTypeTo(structT); + //structT = cast(opaqueT.get()); // updated potentially invalidated structT + + Type* ret = PointerType::get(structT, 0); + module->addTypeName(name, structT); + + compiledTypes.insert(make_pair(name, ret)); + + return ret; +} + +CType +LLVMEngine::objectType(CEnv& cenv) +{ + return objectT; +} + CFunc LLVMEngine::startFn( CEnv& cenv, const std::string& name, const ATuple* args, const ATuple* type) @@ -304,9 +368,13 @@ LLVMEngine::pushFnArgs(CEnv& cenv, const ATuple* prot, const ATuple* type, CFunc } void -LLVMEngine::finishFn(CEnv& cenv, CFunc f, CVal ret) +LLVMEngine::finishFn(CEnv& cenv, CFunc f, CVal ret, const AST* retT) { - builder.CreateRet(llVal(ret)); + if (retT->str() == "Nothing") + builder.CreateRetVoid(); + else + builder.CreateRet(builder.CreateBitCast(llVal(ret), llType(retT), "ret")); + if (verifyFunction(*static_cast(f), llvm::PrintMessageAction)) { module->dump(); throw Error(Cursor(), "Broken module"); diff --git a/src/pprint.cpp b/src/pprint.cpp index 15e9f54..4e0d036 100644 --- a/src/pprint.cpp +++ b/src/pprint.cpp @@ -37,8 +37,11 @@ newline(ostream& out, unsigned indent) static inline void print_annotation(ostream& out, CEnv* cenv, const AST* ast, bool print) { - if (print) - out << " :" << cenv->tsubst.apply(cenv->tenv.var(ast)); + if (print) { + const AST* var = cenv->tenv.var(ast); + if (var) + out << " :" << cenv->tsubst.apply(var); + } } ostream& diff --git a/src/repl.cpp b/src/repl.cpp index 81035bb..6c9b3cf 100644 --- a/src/repl.cpp +++ b/src/repl.cpp @@ -136,7 +136,8 @@ eval(CEnv& cenv, Cursor& cursor, istream& is, bool execute) Code exprs; for (Code::const_iterator i = lifted.begin(); i != lifted.end(); ++i) { const ATuple* call = (*i)->to_tuple(); - if (call && is_form(call, "def") && is_form(call->list_ref(2), "fn")) { + if (call && ( (is_form(call, "def-type")) + || (is_form(call, "def") && is_form(call->frrst(), "fn")))) { val = resp_compile(cenv, call); } else { const ATuple* tup = (*i)->to_tuple(); @@ -146,27 +147,25 @@ eval(CEnv& cenv, Cursor& cursor, istream& is, bool execute) } } - const AST* type = cenv.type(exprs.back()); - const ATuple* fnT = tup(cursor, cenv.tenv.Fn, new ATuple(cursor), type, 0); - - // Create function for top-level of program - f = cenv.engine()->startFn(cenv, "main", new ATuple(cursor), fnT); + if (!exprs.empty()) { + const AST* type = cenv.type(exprs.back()); + const ATuple* fnT = tup(cursor, cenv.tenv.Fn, new ATuple(cursor), type, 0); - // Compile expressions (other than function definitions) into it - for (Code::const_iterator i = exprs.begin(); i != exprs.end(); ++i) - val = resp_compile(cenv, *i); + // Create function for program containing all expressions except definitions + f = cenv.engine()->startFn(cenv, "main", new ATuple(cursor), fnT); + for (Code::const_iterator i = exprs.begin(); i != exprs.end(); ++i) + val = resp_compile(cenv, *i); + cenv.engine()->finishFn(cenv, f, val, type); - // Finish compilation - cenv.engine()->finishFn(cenv, f, val); + // Call and print result + callPrintCollect(cenv, f, ast, type, execute); + } if (cenv.args.find("-S") != cenv.args.end()) { cenv.engine()->writeModule(cenv, cenv.out); return 0; } - // Call and print result - callPrintCollect(cenv, f, ast, type, execute); - } catch (Error& e) { cenv.err << e.what() << endl; return 1; @@ -200,7 +199,7 @@ repl(CEnv& cenv) try { // Create function for this repl loop f = cenv.engine()->startFn(cenv, replFnName, new ATuple(cursor), fnT); - cenv.engine()->finishFn(cenv, f, resp_compile(cenv, ast)); + cenv.engine()->finishFn(cenv, f, resp_compile(cenv, ast), type); callPrintCollect(cenv, f, ast, type, true); if (cenv.args.find("-d") != cenv.args.end()) cenv.engine()->writeModule(cenv, cenv.out); diff --git a/src/resp.hpp b/src/resp.hpp index acf7725..57880f5 100644 --- a/src/resp.hpp +++ b/src/resp.hpp @@ -71,8 +71,9 @@ struct Error { * Backend Types * ***************************************************************************/ -typedef void* CVal; ///< Compiled value (opaque) -typedef void* CFunc; ///< Compiled function (opaque) +typedef const void* CType; ///< Compiled type (opaque) +typedef void* CVal; ///< Compiled value (opaque) +typedef void* CFunc; ///< Compiled function (opaque) /*************************************************************************** @@ -205,9 +206,12 @@ struct ATuple : public AST { ATuple(const AST* fst, const ATuple* rst, Cursor c=Cursor()) : AST(T_TUPLE, c), _fst(fst), _rst(rst) {} - const AST* fst() const { return _fst; } - const ATuple* rst() const { return _rst; } - bool empty() const { return _fst == 0 && _rst ==0; } + inline const AST* fst() const { return _fst; } + inline const ATuple* rst() const { return _rst; } + inline const AST* frst() const { return _rst->_fst; } + inline const AST* frrst() const { return _rst->_rst->_fst; } + + bool empty() const { return _fst == 0 && _rst ==0; } size_t list_len() const { size_t ret = 0; @@ -272,7 +276,7 @@ private: const ATuple* _rst; }; -inline ATuple* tup(Cursor c, AST* ast, ...) { +inline ATuple* tup(Cursor c, const AST* ast, ...) { ATuple* const head = new ATuple(ast, 0, c); if (!ast) return head; @@ -468,6 +472,7 @@ ostream& operator<<(ostream& out, const Env& env) { /// Parse Time Environment (really just a symbol table) struct PEnv : private map { PEnv() : symID(0) {} + ~PEnv() { FOREACHP(const_iterator, i, this) free(const_cast(i->second)); } string gensymstr(const char* s="_") { return (format("%s_%d") % s % symID++).str(); } ASymbol* gensym(const char* s="_") { return sym(gensymstr(s)); } ASymbol* sym(const string& s, Cursor c=Cursor()) { @@ -580,6 +585,8 @@ struct TEnv : public Env { , Closure(penv.sym("Closure")) , Dots(penv.sym("...")) , Fn(penv.sym("Fn")) + , List(penv.sym("List")) + , Empty(penv.sym("Empty")) , Tup(penv.sym("Tup")) , U(penv.sym("U")) { @@ -616,6 +623,8 @@ struct TEnv : public Env { ASymbol* Closure; ASymbol* Dots; ASymbol* Fn; + ASymbol* List; + ASymbol* Empty; ASymbol* Tup; ASymbol* U; }; @@ -643,18 +652,21 @@ struct Engine { const ATuple* type, CFunc f) = 0; - virtual void finishFn(CEnv& cenv, CFunc f, CVal ret) = 0; - virtual void eraseFn(CEnv& cenv, CFunc f) = 0; - - virtual CVal compileCall(CEnv& cenv, CFunc f, const ATuple* fT, CVals& args) = 0; - virtual CVal compileCons(CEnv& cenv, const ATuple* t, CVal rtti, CVals& f) = 0; - virtual CVal compileDot(CEnv& cenv, CVal tup, int32_t index) = 0; - virtual CVal compileGlobalSet(CEnv& cenv, const string& s, CVal v, const AST* t) = 0; - virtual CVal compileGlobalGet(CEnv& cenv, const string& s, CVal v) = 0; - virtual CVal compileIf(CEnv& cenv, const AST* cond, const AST* then, const AST* aelse) = 0; - virtual CVal compileLiteral(CEnv& cenv, const AST* lit) = 0; - virtual CVal compilePrimitive(CEnv& cenv, const ATuple* prim) = 0; - virtual CVal compileString(CEnv& cenv, const char* str) = 0; + virtual void finishFn(CEnv& cenv, CFunc f, CVal ret, const AST* retT) = 0; + virtual void eraseFn(CEnv& cenv, CFunc f) = 0; + + virtual CVal compileCall(CEnv& cenv, CFunc f, const ATuple* fT, CVals& args) = 0; + virtual CVal compileCons(CEnv& cenv, const ATuple* t, CVal rtti, CVals& f) = 0; + virtual CVal compileDot(CEnv& cenv, CVal tup, int32_t index) = 0; + virtual CVal compileGlobalSet(CEnv& cenv, const string& s, CVal v, const AST* t) = 0; + virtual CVal compileGlobalGet(CEnv& cenv, const string& s, CVal v) = 0; + virtual CVal compileIf(CEnv& cenv, const AST* cond, const AST* then, const AST* aelse) = 0; + virtual CVal compileLiteral(CEnv& cenv, const AST* lit) = 0; + virtual CVal compilePrimitive(CEnv& cenv, const ATuple* prim) = 0; + virtual CVal compileString(CEnv& cenv, const char* str) = 0; + virtual CType compileType(CEnv& cenv, const char* name, const AST* exp) = 0; + + virtual CType objectType(CEnv& cenv) = 0; virtual void writeModule(CEnv& cenv, std::ostream& os) = 0; diff --git a/src/simplify.cpp b/src/simplify.cpp index 0c839f7..e27049a 100644 --- a/src/simplify.cpp +++ b/src/simplify.cpp @@ -145,17 +145,44 @@ simplify_let(CEnv& cenv, const ATuple* call) throw() return copy; } +static inline const AST* +simplify_list_elem(CEnv& cenv, const ATuple* node, const AST* type) +{ + if (!node) { + const AST* empty = new ATuple(cenv.tenv.Empty, 0, Cursor()); + cenv.setType(empty, type); + return empty; + } + + assert(cenv.type(node->fst())); + + const AST* const fst = tup(Cursor(), cenv.type(node->fst()), node->fst(), 0); + 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); + cenv.setType(fst, tup(Cursor(), cenv.penv.sym("Expr"), 0)); + cenv.setType(cons, type); + return cons; +} + static const AST* simplify_quote(CEnv& cenv, const ATuple* call) throw() { - switch (call->list_ref(1)->tag()) { - case T_SYMBOL: case T_TUPLE: - // Symbols and lists remain quoted (because semantics differ) + switch (call->frst()->tag()) { + case T_SYMBOL: + // Symbols remain quoted so they are not interpreted as variables return call; + case T_TUPLE: { + // 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)); + } default: // Other literals (e.g. numbers, strings) are self-evaluating, so the // quote can be removed, e.g. (quote 3) => 3 - return call->list_ref(1); + return call->frst(); } } -- cgit v1.2.1