#include "pch.h" #include "ast.h" ////////////////////////////////////////////////////////////////////////////// // // Closure // ////////////////////////////////////////////////////////////////////////////// class Closure : public Value { public: virtual TRef Evaluate(Delay* pdelay) = 0; static TRef StaticGetType() { return new FunctionType( new PolymorphicType(), new PolymorphicType() ); } }; ////////////////////////////////////////////////////////////////////////////// // // Closure // ////////////////////////////////////////////////////////////////////////////// class ExpressionClosure : public Closure { private: ZString m_str; TRef m_penv; TRef m_pexpr; public: ExpressionClosure(Environment* penv, const ZString& str, Expression* pexpr) : m_str(str), m_penv(penv), m_pexpr(pexpr) { } TRef Evaluate(Delay* pdelay) { return CreateDelay( new Environment(m_penv, m_str, pdelay), m_pexpr ); } ZString GetString() { return "(function arg -> expr)"; } }; ////////////////////////////////////////////////////////////////////////////// // // Expression // ////////////////////////////////////////////////////////////////////////////// bool Expression::IsValue() { return false; } Value* Expression::GetValue() { return NULL; } ////////////////////////////////////////////////////////////////////////////// // // ValueExpression // ////////////////////////////////////////////////////////////////////////////// class ValueExpression : public Expression { private: TRef m_pvalue; public: ValueExpression(Value* pvalue) : m_pvalue(pvalue) { } bool IsValue() { return true; } Value* GetValue() { return m_pvalue; } TRef GetType(Environment* penv) { return m_pvalue->GetType(); } TRef Evaluate(Environment* penv) { return CreateDelay(NULL, this); } }; TRef CreateValueExpression(Value* pvalue) { return new ValueExpression(pvalue); } ////////////////////////////////////////////////////////////////////////////// // // SymbolExpression // ////////////////////////////////////////////////////////////////////////////// class SymbolExpression : public Expression { private: ZString m_str; public: SymbolExpression(const ZString& str) : m_str(str) { } TRef GetType(Environment* penv) { TRef pdelay = penv->Find(m_str); if (pdelay == NULL) { ZError("Undefined symbol: " + m_str); } return pdelay->GetType(); } TRef Evaluate(Environment* penv) { return penv->Find(m_str); } }; TRef CreateSymbolExpression(const ZString& str) { return new SymbolExpression(str); } ////////////////////////////////////////////////////////////////////////////// // // ApplyExpression // ////////////////////////////////////////////////////////////////////////////// class ApplyExpression : public Expression { private: TRef m_pexprFunc; TRef m_pexprArg; public: ApplyExpression(Expression* pexprFunc, Expression* pexprArg) : m_pexprFunc(pexprFunc), m_pexprArg(pexprArg) { } TRef GetType(Environment* penv) { TRef ptypeFunc = m_pexprFunc->GetType(penv); ZVerify(ptypeFunc->IsMatch(Closure::StaticGetType())); TRef pfuncType = ptypeFunc->GetFunctionType(); TRef ptypeFuncArg = pfuncType->GetArgType(); TRef ptypeArg = m_pexprArg->GetType(penv); if (ptypeFuncArg->IsMatch(ptypeArg)) { return pfuncType->GetResultType(); } else { int id = 'a'; ZError( "Type mismatch: " + ptypeFuncArg->GetString(id) + " != " + ptypeArg->GetString(id) ); return NULL; } } TRef Evaluate(Environment* penv) { TRef pdelayFunc = m_pexprFunc->Evaluate(penv); TRef pvalue = pdelayFunc->Evaluate(); TRef pclosure; CastTo(pclosure, pvalue); TRef pdelayArg = m_pexprArg->Evaluate(penv); return pclosure->Evaluate(pdelayArg); } }; TRef CreateApplyExpression(Expression* pexprFunc, Expression* pexprArg) { return new ApplyExpression(pexprFunc, pexprArg); } ////////////////////////////////////////////////////////////////////////////// // // FunctionExpression // ////////////////////////////////////////////////////////////////////////////// class FunctionExpression : public Expression { private: ZString m_str; TRef m_pexpr; public: FunctionExpression(const ZString& str, Expression* pexpr) : m_str(str), m_pexpr(pexpr) { } TRef GetType(Environment* penv) { TRef ptypeArg = new PolymorphicType(); penv = new Environment( penv, m_str, CreateTypeDelay(ptypeArg) ); TRef ptypeResult = m_pexpr->GetType(penv); return new FunctionType(ptypeArg, ptypeResult); } TRef Evaluate(Environment* penv) { TRef pvalue = new ExpressionClosure(penv, m_str, m_pexpr); TRef pexpr = new ValueExpression(pvalue); return CreateDelay(NULL, pexpr); } }; TRef CreateFunctionExpression(const ZString& str, Expression* pexpr) { return new FunctionExpression(str, pexpr); } ////////////////////////////////////////////////////////////////////////////// // // LetExpression // ////////////////////////////////////////////////////////////////////////////// class LetExpression : public Expression { private: TRef m_penv; TRef m_pexprIn; public: LetExpression(Environment* penv, Expression* pexprIn) : m_penv(penv), m_pexprIn(pexprIn) { } TRef GetType(Environment* penv) { ZUnimplemented(); return NULL; } TRef Evaluate(Environment* penv) { Environment* penvLet = m_penv; TRef penvTop = new Environment(NULL, "let", NULL); while (penvLet != NULL) { TRef pdelay = penvLet->GetDelay(); TRef pexpr; if (pdelay != NULL) { pexpr = pdelay->GetExpression(); } penv = new Environment( penv, penvLet->GetString(), CreateDelay( penvTop, pexpr ) ); penvLet = penvLet->GetNext(); } penvTop->SetNext(penv); return CreateDelay(penvTop, m_pexprIn); } }; TRef CreateLetExpression(Environment* penv, Expression* pexprIn) { return new LetExpression(penv, pexprIn); } ////////////////////////////////////////////////////////////////////////////// // // TypeDelay // ////////////////////////////////////////////////////////////////////////////// class TypeDelay : public Delay { private: TRef m_ptype; public: TypeDelay(Type* ptype) : m_ptype(ptype) { } Expression* GetExpression() { return NULL; } TRef Evaluate() { return NULL; } TRef GetType() { return m_ptype; } }; TRef CreateTypeDelay(Type* ptype) { return new TypeDelay(ptype); } ////////////////////////////////////////////////////////////////////////////// // // Delay // ////////////////////////////////////////////////////////////////////////////// class DelayImpl : public Delay { private: TRef m_penv; TRef m_pexpr; TRef m_ptype; TRef m_pvalue; public: DelayImpl(Environment* penv, Expression* pexpr) : m_penv(penv), m_pexpr(pexpr) { } Expression* GetExpression() { return m_pexpr; } TRef Evaluate() { if (m_pvalue == NULL) { if (m_pexpr->IsValue()) { m_pvalue = m_pexpr->GetValue(); } else { m_pvalue = m_pexpr->Evaluate(m_penv)->Evaluate(); } } return m_pvalue; } TRef GetType() { if (m_ptype) { return m_ptype; } else { m_ptype = new PolymorphicType(); TRef ptype = m_pexpr->GetType(m_penv); ZVerify(m_ptype->IsMatch(ptype)); m_ptype = NULL; return ptype; } } }; TRef CreateDelay(Environment* penv, Expression* pexpr) { return new DelayImpl(penv, pexpr); } ////////////////////////////////////////////////////////////////////////////// // // Environment // ////////////////////////////////////////////////////////////////////////////// Environment::Environment(Environment* penv, const ZString& str, Delay* pdelay) : m_penv(penv), m_str(str), m_pdelay(pdelay) { } Delay* Environment::Find(const ZString& str) { if (m_str == str) { return m_pdelay; } else if (m_penv != NULL) { return m_penv->Find(str); } return NULL; } Delay* Environment::GetArgument(int index) { if (index == 1) { return m_pdelay; } else { return m_penv->GetArgument(index - 1); } }