private ISExpression RewriteLetStar(ISchemeVM vm, ISExpression expr)
{
var x = expr as Cons;
var c = x.ListCount();
if (c < 3)
{
ThrowErr("let*", "invalid number of arguments", expr.String());
}
var bindings = x.Get(1);
var body = x.Get(2);
if (!bindings.IsList())
{
ThrowErr("let*", "invalid argument 'bindings'", expr.String());
}
if (bindings == AtomHelper.Nil || bindings.GetUnsafeCdr() == AtomHelper.Nil)
{
return(RewriteLet(vm, expr));
}
var first = bindings.GetUnsafeCar();
var remain = bindings.GetUnsafeCdr();
return(RewriteLet(vm, AtomHelper.CreateList(CompilerConstants.Let, AtomHelper.CreateList(Compile(vm, first)),
AtomHelper.CreateList(CompilerConstants.LetStar, Compile(vm, remain), Compile(vm, body)))));
}
public override IInstruction Execute(ISchemeVM vm)
{
var a = Closure(Body, vm.E, Vars);
SetA(vm, a);
return(Next);
}
public override ISExpression Compile(ISchemeVM vm, ISExpression expr)
{
if (!expr.IsList() || expr == AtomHelper.Nil)
{
return(expr);
}
var c = (Cons)expr;
var op = c.Get(0);
if (op == CompilerConstants.If)
{
var count = c.ListCount();
if (count < 3 || count > 4)
{
ThrowErr("if", "invalid number of arguments", expr.String());
}
if (count == 3)
{
var test = Compile(vm, c.Get(1));
var then = Compile(vm, c.Get(2));
return(AtomHelper.CreateList(CompilerConstants.If, test, then, AtomHelper.Nil));
}
}
return(expr);
}
protected ISExpression Continuation(Stack <IFrame> s, ISchemeVM vm)
{
var v = AtomHelper.SymbolFromString("v");
return(Closure(new NuateInstruction(s, v), AtomHelper.CreateEnvironment(),
AtomHelper.CreateList(v)));
}
public override IInstruction Execute(ISchemeVM vm)
{
IEnvironment e = vm.E;
if (vm.A.IsClosure())
{
var c = vm.A as Closure;
if (c.Body.Name != "native")
{
if (c.Vars.IsSymbol())
{
e = Extend(vm.E, CreateMap(AtomHelper.CreateList(c.Vars), vm.R));
}
else if (c.Vars.IsList())
{
e = Extend(vm.E, CreateMap(c.Vars, vm.R));
}
else if (!c.Vars.IsNil())
{
ThrowErr("apply", "attempted application with invalid binding parameter", $"parameter vars: {c.Vars.String()}");
}
}
SetE(vm, e);
return(c.Body);
}
ThrowErr("apply", "attempted application of non-function", $"({vm.A.String()})");
return(null);
}
public static IInstruction Compile(ISchemeVM vm, ISExpression expr)
{
var p1 = DoPass <RewriteLetPass, ISExpression, ISExpression>(vm, expr);
var p2 = DoPass <RewriteTwoArmIfPass, ISExpression, ISExpression>(vm, p1);
var p3 = DoPass <InstructionPass, ISExpression, IInstruction>(vm, p2);
return(p3);
}
public override IInstruction Execute(ISchemeVM vm)
{
if (vm.A == AtomHelper.False)
{
return(Else);
}
return(Then);
}
public override IInstruction Execute(ISchemeVM vm)
{
var a = Lookup(Var, vm.E);
SetA(vm, a);
SetS(vm, Stack);
return(new ReturnInstruction());
}
private static IInstruction CompileLambdaBody(ISchemeVM vm, ISExpression body, IInstruction next)
{
if (body.GetUnsafeCdr() == AtomHelper.Nil)
{
return(Compile(vm, body.GetUnsafeCar(), next));
}
return(Compile(vm, body.GetUnsafeCar(), CompileLambdaBody(vm, body.GetUnsafeCdr(), next)));
}
public override IInstruction Execute(ISchemeVM vm)
{
Proc.EnsureArgsValid(vm.R);
SetA(vm, Proc.Proc(vm.R));
SetR(vm, new Stack <ISExpression>());
return(Next);
}
public static void PopulateEnvironment(IEnvironment e, ISchemeVM vm)
{
var lib = Library.CreateBase();
foreach (var l in lib)
{
CreatePrimitive(l.Key.Val, (Procedure)l.Value, e, vm);
}
}
public override IInstruction Execute(ISchemeVM vm)
{
var success = vm.E.Set(Var, vm.A);
if (!success)
{
ThrowErr("assign", "attempted assignment of undefined indentifier", $"{Var.String()}");
}
return(Next);
}
public override IInstruction Execute(ISchemeVM vm)
{
if (!vm.E.IsDefined(Var))
{
vm.E.DefineHere(Var, vm.A);
return(Next);
}
ThrowErr("define", "attempted define of already defined indentifier", $"{Var.String()}");
return(null);
}
public override IInstruction Execute(ISchemeVM vm)
{
var frame = vm.S.Pop();
SetE(vm, frame.E);
SetR(vm, frame.R);
SetS(vm, frame.S);
return(frame.X);
}
public override ISExpression Compile(ISchemeVM vm, string i)
{
var exprs = ParserHelpers.Parse(i);
if (exprs.Length == 1)
{
return(exprs[0]);
}
return(AtomHelper.CreateCons(CompilerConstants.Begin, exprs.Unflatten()));
}
public override IInstruction Execute(ISchemeVM vm)
{
var a = Lookup(Var, vm.E);
if (a == null)
{
ThrowErr("refer", "attempted reference of undefined indentifier", $"{Var.String()}");
}
SetA(vm, a);
return(Next);
}
public override IInstruction Execute(ISchemeVM vm)
{
var e = AtomHelper.CreateEnvironment();
if (Populate)
{
AtomHelper.PopulateEnvironment(e, vm);
}
SetA(vm, e);
return(Next);
}
public static IInstruction Compile(ISchemeVM vm, ISExpression expr, IInstruction next)
{
if (expr.IsSymbol())
{
return(new ReferInstruction(expr, next));
}
else if (expr.IsCons())
{
return(CompileCons(vm, expr, next));
}
else if (expr.IsProcedure())
{
return(new NativeInstruction(expr as Procedure, new ReturnInstruction()));
}
return(new ConstantInstruction(expr, next));
}
public override ISExpression Compile(ISchemeVM vm, ISExpression expr)
{
if (expr.IsList() && expr != AtomHelper.Nil)
{
var op = (expr as Cons).Get(0);
if (op == CompilerConstants.Let)
{
return(RewriteLet(vm, expr));
}
else if (op == CompilerConstants.LetStar)
{
return(RewriteLetStar(vm, expr));
}
}
if (expr.IsCons())
{
var c = expr as Cons;
return(new Cons(Compile(vm, c.Car), Compile(vm, c.Cdr)));
}
return(expr);
}
public override IInstruction Execute(ISchemeVM vm)
{
vm.R.Push(vm.A);
return(Next);
}
public override IInstruction Execute(ISchemeVM vm)
{
PushFrame(vm, Ret, vm.E, vm.R, vm.S);
SetR(vm, new Stack <ISExpression>());
return(Next);
}
public override IInstruction Compile(ISchemeVM vm, ISExpression expr)
{
return(Compile(vm, expr, new HaltInstruction()));
}
private static IInstruction CompileCons(ISchemeVM vm, ISExpression expr, IInstruction next)
{
var x = expr as Cons;
if (!x.IsList())
{
return(new ConstantInstruction(x, next));
}
var op = x.Get(0);
/*if (op == CompilerConstants.Eval)
* {
* if (x.ListCount() != 3)
* ThrowErr("eval", "invalid number of arguments", x.String());
*
* var e = x.Get(1);
*
* if (e.IsList() && e.GetUnsafeCar() == CompilerConstants.Quote)
* e = e.GetUnsafeCdr().GetUnsafeCar();
*
* var env = x.Get(2);
*
* if (!env.IsList() || env.ListCount() != 2)
* ThrowErr("eval", "invalid argument 'environment specifier'", x.String());
*
* var specifier = env.GetUnsafeCar();
* if (!(specifier == CompilerConstants.SchemeReportEnvironment || specifier == CompilerConstants.NullEnvironment))
* ThrowErr("eval", "invalid argument 'environment specifier'", x.String());
*
* var version = env.GetUnsafeCdr().GetUnsafeCar();
* if (!version.IsInteger() || ((NumberAtom)version).Val != Complex.CreateExactReal(5))
* ThrowErr("eval", "invalid version for argument 'environment specifier'", x.String());
*
* var populate = specifier == CompilerConstants.SchemeReportEnvironment;
*
* return new FrameInstruction(next, new EnvironmentInstruction(populate, Compile(e, new ReturnInstruction())));
* }*/
if (op == CompilerConstants.SchemeReportEnvironment || op == CompilerConstants.NullEnvironment)
{
var version = x.Get(1);
if (!version.IsInteger() || ((NumberAtom)version).Val != Complex.CreateExactReal(5))
{
ThrowErr("eval", "invalid version for argument 'environment specifier'", x.String());
}
var populate = op == CompilerConstants.SchemeReportEnvironment;
return(new EnvironmentInstruction(populate, next));
}
if (op == CompilerConstants.Quote)
{
if (x.ListCount() != 2)
{
ThrowErr("quote", "invalid number of arguments", x.String());
}
return(new ConstantInstruction(x.Cdr.GetUnsafeCar(), next));
}
else if (op == CompilerConstants.Lambda)
{
if (x.ListCount() < 3)
{
ThrowErr("lambda", "invalid number of arguments", x.String());
}
var vars = x.Get(1);
var body = x.GetUnsafeCdr().GetUnsafeCdr();
return(new CloseInstruction(vars, CompileLambdaBody(vm, body, new ReturnInstruction()), next));
}
else if (op == CompilerConstants.Begin)
{
var body = x.Cdr;
if (body == AtomHelper.Nil)
{
return(new ConstantInstruction(body, next));
}
return(CompileLambdaBody(vm, body, next));
}
else if (op == CompilerConstants.If)
{
var c = x.ListCount();
var test = x.Get(1);
IInstruction tc, ec;
var then = x.Get(2);
tc = Compile(vm, then, next);
var elsa = x.Get(3);
ec = Compile(vm, elsa, next);
return(Compile(vm, test, new TestInstruction(tc, ec)));
}
else if (op == CompilerConstants.SetBang)
{
if (x.ListCount() != 3)
{
ThrowErr("set!", "invalid number of arguments", x.String());
}
var set_v = x.Get(1);
var set_expr = x.Get(2);
CheckNotIllegalSymbol(set_v);
return(Compile(vm, set_expr, new AssignInstruction(set_v, next)));
}
else if (op == CompilerConstants.Define)
{
if (x.ListCount() != 3)
{
ThrowErr("define", "invalid number of arguments", x.String());
}
var def_v = x.Get(1);
CheckNotIllegalSymbol(def_v);
if (def_v.IsSymbol())
{
var def_expr = x.Get(2);
return(Compile(vm, def_expr, new DefineInstruction(def_v, next)));
}
else if (def_v.IsCons())
{
var v = def_v.GetUnsafeCar();
var formals = def_v.GetUnsafeCdr();
return(new CloseInstruction(formals, CompileLambdaBody(vm, x.GetUnsafeCdr().GetUnsafeCdr(),
new ReturnInstruction()), new DefineInstruction(v, next)));
}
ThrowErr("define", "invalid argument '<variable> <formals>'", x.String());
return(null);
}
else if (op == CompilerConstants.CallCC)
{
if (x.ListCount() != 2)
{
ThrowErr("call/cc", "invalid number of arguments", x.String());
}
var e = x.Get(1);
var c = new ContiInstruction(new ArgumentInstruction(Compile(vm, e, new ApplyInstruction())));
// tail?
if (next.Name == "return")
{
return(c);
}
else
{
return(new FrameInstruction(next, c));
}
}
else
{
var args = x.Cdr;
var c = Compile(vm, x.Car, new ApplyInstruction());
while (true)
{
if (args == AtomHelper.Nil)
{
// tail?
if (next.Name == "return")
{
return(c);
}
else
{
return(new FrameInstruction(next, c));
}
}
c = Compile(vm, ((Cons)args).Car, new ArgumentInstruction(c));
args = ((Cons)args).Cdr;
}
}
}
public override IInstruction Execute(ISchemeVM vm)
{
return(null);
}
private ISExpression RewriteLet(ISchemeVM vm, ISExpression expr)
{
List <ISExpression> vars = new List <ISExpression>(), vals = new List <ISExpression>();
ISExpression defs;
var x = expr as Cons;
var c = x.ListCount();
if (c < 3)
{
ThrowErr("let", "invalid number of arguments", expr.String());
}
// (let name ((var val) ...) body)
if (x.Get(1).IsSymbol())
{
var sym = x.Get(1);
defs = x.Get(2);
while (defs != AtomHelper.Nil)
{
var n = defs.GetUnsafeCar().GetUnsafeCar();
var v = defs.GetUnsafeCar().GetUnsafeCdr().GetUnsafeCar();
if (!n.IsSymbol())
{
ThrowErr("let", "invalid argument 'bindings'", x.String());
}
vars.Add(n);
vals.Add(v);
defs = defs.GetUnsafeCdr();
}
// ((lambda ()
// (define name (lambda (vars) body))
// (name vals)))
var body = x.GetUnsafeCdr().GetUnsafeCdr().GetUnsafeCdr();
var innerLambda = AtomHelper.CreateCons(
CompilerConstants.Lambda,
AtomHelper.CreateCons(vars.Unflatten(),
Compile(vm, body))
);
var define = AtomHelper.CreateList(CompilerConstants.Define, sym, innerLambda);
var loopCall = AtomHelper.CreateCons(sym, Compile(vm, vals.Unflatten()));
var outerLambda = AtomHelper.CreateList(CompilerConstants.Lambda, AtomHelper.Nil, define, loopCall);
return(AtomHelper.CreateList(outerLambda));
}
// (let ((var val) ...) body)
else if (x.Get(1).IsList())
{
defs = x.Get(1);
while (defs != AtomHelper.Nil)
{
var d = defs.GetUnsafeCar();
if (!d.IsList() || d.ListCount() != 2)
{
ThrowErr("let", "invalid argument 'bindings'", x.String());
}
var n = d.GetUnsafeCar();
var v = d.GetUnsafeCdr().GetUnsafeCar();
if (!n.IsSymbol())
{
ThrowErr("let", "invalid argument 'bindings'", x.String());
}
vars.Add(n);
vals.Add(v);
defs = defs.GetUnsafeCdr();
}
// ((lambda (vars) body) vals)
var body = x.GetUnsafeCdr().GetUnsafeCdr();
var lambda = AtomHelper.CreateCons(CompilerConstants.Lambda,
AtomHelper.CreateCons(vars.Unflatten(), Compile(vm, body)));
return(AtomHelper.CreateCons(lambda, Compile(vm, vals.Unflatten())));
}
ThrowErr("let", "invalid argument 'bindings'", x.String());
return(null);
}
private static void CreatePrimitive(string name, Procedure p, IEnvironment e, ISchemeVM vm)
{
var def = AtomHelper.CreateList(
AtomHelper.SymbolFromString("define"),
AtomHelper.SymbolFromString(name),
AtomHelper.CreateList(AtomHelper.SymbolFromString("lambda"), AtomHelper.Nil, p)
);
var inst = SchemeCompiler.Compile(vm, def);
var tmp = vm.E;
vm.E = e;
vm.Execute(inst);
vm.E = tmp;
}
public override IInstruction Execute(ISchemeVM vm)
{
SetA(vm, Obj);
return(Next);
}
private static O DoPass <T, I, O>(ISchemeVM vm, I i) where T : ICompilerPass <I, O>, new()
{
var pass = new T();
return(pass.Compile(vm, i));
}
public abstract O Compile(ISchemeVM vm, I i);
public static IInstruction Compile(ISchemeVM vm, string input)
{
var p1 = DoPass <ParserPass, string, ISExpression>(vm, input);
return(Compile(vm, p1));
}