org.lb.Scheme.cs version 2013-01-11

// org.lb.Scheme.cs version 2013-01-11
// A Scheme subset compiler and virtual machine in C#
// Features: Tail calls, CL style macros
// Copyright (c) 2013, Leif Bruder <leifbruder@gmail.com>
//
// Permission to use, copy, modify, and/or distribute this software for any
// purpose with or without fee is hereby granted, provided that the above
// copyright notice and this permission notice appear in all copies.
//
// THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
// WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
// MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
// ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
// WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
// ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
// OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

using System;
using System.Collections;
using System.Collections.Generic;
using System.Globalization;
using System.IO;
using System.Linq;
using System.Text;
using System.Threading;

namespace org.lb.Scheme
{
    public interface VirtualMachine
    {
        int ProgramSize { get; }
        void EmitLabel(string label);
        void EmitArgsToValue();
        void EmitBranchLabel(string label);
        void EmitCall();
        void EmitContinue();
        void EmitDefineVariable(Symbol variable);
        void EmitGetVariable(Symbol variable);
        void EmitGotoLabel(string label);
        void EmitInitArgs();
        void EmitLdConst(object value);
        void EmitLdCont(string label);
        void EmitMakeClosure(string name, string label, bool hasRestParameter, Symbol[] parameterNames);
        void EmitPushParam();
        void EmitRestoreRegisters();
        void EmitSaveRegisters();
        void EmitSetVariable(Symbol variable);
        void EmitValueToArgs();
        string MakeLabel();
        void SetVariable(string name, object value);
        void SetVariable(Symbol name, object value);
        bool HasVariable(Symbol name);
        object GetVariable(Symbol name);
        object Run(int startingPC = 0);
    }


    public sealed class VirtualMachineException : Exception { internal VirtualMachineException(string message) : base(message) { } }
    public sealed class SchemeException : Exception { internal SchemeException(string message) : base(message) { } }
    public sealed class SchemeError : Exception { internal SchemeError(Pair parameters) : base(new Writer().Write(parameters)) { } }

    public sealed class Pair : IEnumerable<object>
    {
        public object First;
        public object Second;

        public Pair(object first, object second) { First = first; Second = second; }
        IEnumerator IEnumerable.GetEnumerator() { return GetEnumerator(); }

        public IEnumerator<object> GetEnumerator()
        {
            Pair i = this;
            while (true)
            {
                yield return i.First;
                if (i.Second == null) yield break;
                if (!(i.Second is Pair))
                {
                    yield return i.Second;
                    yield break;
                }
                i = (Pair)i.Second;
            }
        }

        public static Pair FromEnumerable(IEnumerable values)
        {
            Pair ret = null;
            Pair current = null;
            foreach (object o in values)
            {
                var newPair = new Pair(o, null);
                if (current == null)
                {
                    ret = current = newPair;
                }
                else
                {
                    current.Second = newPair;
                    current = newPair;
                }
            }
            return ret;
        }

        public bool IsDottedList()
        {
            Pair i = this;
            while (true)
            {
                if (i.Second == null) return false;
                if (!(i.Second is Pair)) return true;
                i = (Pair)i.Second;
            }
        }
    }

    public sealed class Symbol
    {
        private readonly string value;
        private readonly int hashCode;

        private Symbol(string value) { this.value = value; this.hashCode = value.GetHashCode(); }
        public override string ToString() { return value; }

        private static readonly Dictionary<string, Symbol> cache = new Dictionary<string, Symbol>();
        public static Symbol FromString(string symbol)
        {
            lock (cache)
            {
                if (cache.ContainsKey(symbol)) return cache[symbol];
                Symbol ret = new Symbol(symbol);
                cache[symbol] = ret;
                return ret;
            }
        }

        public override bool Equals(object obj) { return this == obj; }
        public override int GetHashCode() { return hashCode; }
    }

    internal sealed class Environment
    {
        private readonly Dictionary<Symbol, object> values = new Dictionary<Symbol, object>();
        private readonly Environment parent;

        public Environment(Environment parent = null)
        {
            this.parent = parent;
        }

        public object Get(Symbol variable)
        {
            object ret;
            if (values.TryGetValue(variable, out ret)) return ret;
            if (parent != null) return parent.Get(variable);
            throw new VirtualMachineException("Unknown variable '" + variable + "'");
        }

        public void Define(Symbol variable, object value)
        {
            values[variable] = value;
        }

        public void Set(Symbol variable, object value)
        {
            if (values.ContainsKey(variable)) values[variable] = value;
            else if (parent != null) parent.Set(variable, value);
            else throw new VirtualMachineException("Unknown variable '" + variable + "'");
        }

        public bool HasVariable(Symbol name)
        {
            return values.ContainsKey(name);
        }
    }

    public sealed class RegisterMachine : VirtualMachine
    {
        private int programCounter;
        private Environment environmentRegister;
        private int continueRegister;
        private object valueRegister;
        private object argumentsRegister;

        private readonly List<int> gotosWithoutLabelValue = new List<int>();
        private readonly Dictionary<string, int> labelPositions = new Dictionary<string, int>();
        private readonly List<Instruction> Instructions = new List<Instruction>();
        public int ProgramSize { get { return Instructions.Count; } }

        private readonly Func<object, bool> IsTrue;
        private readonly Stack<object> stack = new Stack<object>();
        private readonly Environment globalEnvironment = new Environment();

        public RegisterMachine(Func<object, bool> isTrue)
        {
            IsTrue = isTrue;
        }

        private void PerformArgsToValue() { valueRegister = argumentsRegister; programCounter++; }
        private void PerformBranchLabel(int target) { programCounter = IsTrue(valueRegister) ? target : programCounter + 1; }
        private void PerformContinue() { programCounter = continueRegister; }
        private void PerformDefineVariable(Symbol variable) { environmentRegister.Define(variable, valueRegister); programCounter++; }
        private void PerformGetVariable(Symbol variable) { valueRegister = environmentRegister.Get(variable); programCounter++; }
        private void PerformGotoLabel(int target) { programCounter = target; }
        private void PerformInitArgs() { argumentsRegister = null; programCounter++; }
        private void PerformLdConst(object value) { valueRegister = value; programCounter++; }
        private void PerformLdCont(int target) { continueRegister = target; programCounter++; }
        private void PerformPushParam() { argumentsRegister = new Pair(valueRegister, argumentsRegister); programCounter++; }
        private void PerformRestoreRegisters() { environmentRegister = (Environment)stack.Pop(); continueRegister = (int)stack.Pop(); argumentsRegister = stack.Pop(); programCounter++; }
        private void PerformSaveRegisters() { stack.Push(argumentsRegister); stack.Push(continueRegister); stack.Push(environmentRegister); programCounter++; }
        private void PerformSetVariable(Symbol variable) { environmentRegister.Set(variable, valueRegister); programCounter++; }
        private void PerformMakeClosure(string name, int target, bool hasRestParameter, Symbol[] parameterNames) { valueRegister = new Closure(name, environmentRegister, target, parameterNames, hasRestParameter); programCounter++; }
        private void PerformValueToArgs() { argumentsRegister = valueRegister; programCounter++; }

        private void PerformCall()
        {
            object[] args;
            if (argumentsRegister == null) args = new object[0];
            else if (argumentsRegister is Pair) args = ((Pair)argumentsRegister).ToArray();
            else throw new VirtualMachineException("Invalid function application: Expected list of arguments, got " + argumentsRegister.GetType());

            argumentsRegister = null;

            if (valueRegister is Func<object[], object>)
            {
                valueRegister = ((Func<object[], object>)valueRegister)(args);
                programCounter = continueRegister;
                return;
            }

            if (valueRegister is Closure)
            {
                var closure = (Closure)valueRegister;
                var env = new Environment((closure).Captured);

                if (closure.HasRestParameter)
                {
                    if (closure.ParameterNames.Length - 1 > args.Length)
                        throw new VirtualMachineException("Invalid parameter count in call to '" + closure.Name + "': Expected " + (closure.ParameterNames.Length - 1) + " or more, got " + args.Length);
                    for (int i = 0; i < closure.ParameterNames.Length - 1; ++i) env.Define(closure.ParameterNames[i], args[i]);
                    env.Define(closure.ParameterNames.Last(), Pair.FromEnumerable(args.Skip(closure.ParameterNames.Length - 1)));
                }
                else
                {
                    if (closure.ParameterNames.Length != args.Length)
                        throw new VirtualMachineException("Invalid parameter count in call to '" + closure.Name + "': Expected " + closure.ParameterNames.Length + ", got " + args.Length);
                    for (int i = 0; i < closure.ParameterNames.Length; ++i) env.Define(closure.ParameterNames[i], args[i]);
                }

                environmentRegister = env;
                programCounter = closure.PC;
                return;
            }

            throw new VirtualMachineException("Invalid CALL target");
        }

        public void EmitLabel(string label)
        {
            if (labelPositions.ContainsKey(label)) throw new VirtualMachineException("Label defined twice: '" + label + "'");
            int targetPC = Instructions.Count;
            labelPositions[label] = targetPC;

            for (int i = 0; i < gotosWithoutLabelValue.Count; ++i)
            {
                if (Instructions[gotosWithoutLabelValue[i]].Label == label)
                {
                    Instructions[gotosWithoutLabelValue[i]].LabelTarget = targetPC;
                    gotosWithoutLabelValue.RemoveAt(i);
                    i--;
                }
            }
        }

        public void EmitArgsToValue() { Emit(new LambdaInstruction(PerformArgsToValue)); }
        public void EmitBranchLabel(string label) { Emit(new BranchLabelInstruction(label)); }
        public void EmitCall() { Emit(new LambdaInstruction(PerformCall)); }
        public void EmitContinue() { Emit(new LambdaInstruction(PerformContinue)); }
        public void EmitDefineVariable(Symbol variable) { Emit(new LambdaInstruction(() => PerformDefineVariable(variable))); }
        public void EmitGetVariable(Symbol variable) { Emit(new LambdaInstruction(() => PerformGetVariable(variable))); }
        public void EmitGotoLabel(string label) { Emit(new GotoLabelInstruction(label)); }
        public void EmitInitArgs() { Emit(new LambdaInstruction(PerformInitArgs)); }
        public void EmitLdConst(object value) { Emit(new LambdaInstruction(() => PerformLdConst(value))); }
        public void EmitLdCont(string label) { Emit(new LdContInstruction(label)); }
        public void EmitMakeClosure(string name, string label, bool hasRestParameter, Symbol[] parameterNames) { Emit(new MakeClosureInstruction(name, label, hasRestParameter, parameterNames)); }
        public void EmitPushParam() { Emit(new LambdaInstruction(PerformPushParam)); }
        public void EmitRestoreRegisters() { Emit(new LambdaInstruction(PerformRestoreRegisters)); }
        public void EmitSaveRegisters() { Emit(new LambdaInstruction(PerformSaveRegisters)); }
        public void EmitSetVariable(Symbol variable) { Emit(new LambdaInstruction(() => PerformSetVariable(variable))); }
        public void EmitValueToArgs() { Emit(new LambdaInstruction(PerformValueToArgs)); }

        private void Emit(Instruction value)
        {
            if (value.Label != null)
            {
                if (labelPositions.ContainsKey(value.Label)) value.LabelTarget = labelPositions[value.Label];
                else gotosWithoutLabelValue.Add(Instructions.Count);
            }
            Instructions.Add(value);
        }

        private void AssertRunnable()
        {
            if (gotosWithoutLabelValue.Any()) throw new VirtualMachineException("Invalid program: Jump targets without valid label");
        }

        private int nextLabelNo;
        public string MakeLabel()
        {
            return "##label##" + nextLabelNo++ + "##";
        }

        public void SetVariable(string name, object value) { globalEnvironment.Define(Symbol.FromString(name), value); }
        public void SetVariable(Symbol name, object value) { globalEnvironment.Define(name, value); }
        public bool HasVariable(Symbol name) { return globalEnvironment.HasVariable(name); }
        public object GetVariable(Symbol name) { return globalEnvironment.Get(name); }

        public object Run(int startingPC = 0)
        {
            AssertRunnable();

            programCounter = startingPC;
            environmentRegister = globalEnvironment;
            continueRegister = -1;
            valueRegister = null;
            argumentsRegister = null;
            stack.Clear();

            while (programCounter < Instructions.Count)
            {
                Instructions[programCounter].Execute(this);
                if (programCounter == -1) break;
            }

            if (stack.Any()) throw new VirtualMachineException("Bad program: Stack not empty after last instruction");
            if (argumentsRegister != null) throw new VirtualMachineException("Bad program: Arguments register not empty after last instruction");
            return valueRegister;
        }

        public static bool IsCallable(object value)
        {
            return value is Func<object[], object> || value is Closure;
        }

        private sealed class Closure
        {
            public readonly Environment Captured;
            public readonly int PC;
            public readonly Symbol[] ParameterNames;
            public readonly bool HasRestParameter;
            public readonly string Name;

            public Closure(string name, Environment captured, int pc, Symbol[] parameterNames, bool hasRestParameter)
            {
                Name = name;
                Captured = captured;
                PC = pc;
                ParameterNames = parameterNames;
                HasRestParameter = hasRestParameter;
            }

            public override string ToString() { return "<Compiled function " + Name + ">"; }
        }

        private class Instruction
        {
            public readonly string Label;
            public int LabelTarget;
            protected Instruction(string label) { Label = label; }
            public virtual void Execute(RegisterMachine machine) { }
        }

        private sealed class LambdaInstruction : Instruction
        {
            private readonly Action f;
            public LambdaInstruction(Action f) : base(null) { this.f = f; }
            public override void Execute(RegisterMachine machine) { f(); }
        }

        private sealed class BranchLabelInstruction : Instruction
        {
            public BranchLabelInstruction(string label) : base(label) { }
            public override void Execute(RegisterMachine machine) { machine.PerformBranchLabel(LabelTarget); }
        }

        private sealed class GotoLabelInstruction : Instruction
        {
            public GotoLabelInstruction(string label) : base(label) { }
            public override void Execute(RegisterMachine machine) { machine.PerformGotoLabel(LabelTarget); }
        }

        private sealed class LdContInstruction : Instruction
        {
            public LdContInstruction(string label) : base(label) { }
            public override void Execute(RegisterMachine machine) { machine.PerformLdCont(LabelTarget); }
        }

        private sealed class MakeClosureInstruction : Instruction
        {
            private readonly string Name;
            private readonly bool HasRestParameter;
            private readonly Symbol[] ParameterNames;
            public MakeClosureInstruction(string name, string label, bool hasRestParameter, Symbol[] parameterNames) : base(label) { Name = name; HasRestParameter = hasRestParameter; ParameterNames = parameterNames; }
            public override void Execute(RegisterMachine machine) { machine.PerformMakeClosure(Name, LabelTarget, HasRestParameter, ParameterNames); }
        }
    }

    public sealed class Reader
    {
        public sealed class EofObject
        {
            public static readonly EofObject Instance = new EofObject();
            private EofObject() { }
        }

        private readonly TextReader input;
        private readonly Symbol dot = Symbol.FromString(".");
        private readonly Symbol listEnd = Symbol.FromString(")");

        public Reader(TextReader input)
        {
            this.input = input;
        }

        public object Read(bool throwOnEof = true)
        {
            SkipWhiteSpace();
            if (IsEof())
            {
                if (throwOnEof) throw new EndOfStreamException();
                return EofObject.Instance;
            }
            switch (PeekChar())
            {
                case ';': SkipComment(); return Read(throwOnEof);
                case '\'': ReadChar(); return new Pair(Symbol.FromString("quote"), new Pair(Read(), null));
                case '(': return ReadList();
                case '"': return ReadString();
                case '#': return ReadSpecial();
                default: return ReadSymbolOrNumber();
            }
        }

        private void SkipWhiteSpace()
        {
            while (!IsEof() && char.IsWhiteSpace(PeekChar()))
                ReadChar();
        }

        private void SkipComment()
        {
            while (!IsEof() && PeekChar() != '\n')
                ReadChar();
        }

        private bool IsEof()
        {
            return input.Peek() == -1;
        }

        private char PeekChar()
        {
            AssertNotEof();
            return (char)input.Peek();
        }

        private char ReadChar()
        {
            AssertNotEof();
            return (char)input.Read();
        }

        private void AssertNotEof()
        {
            if (IsEof())
                throw new EndOfStreamException();
        }

        private object ReadList()
        {
            ReadChar(); // Opening parenthesis
            Pair ret = null;
            Pair current = null;
            while (true)
            {
                object o = Read();
                if (o == listEnd) return ret; // Closing parenthesis
                if (o == dot)
                {
                    if (current == null) throw new SchemeException("Invalid dotted list");
                    o = Read();
                    current.Second = o;
                    if (Read() != listEnd) throw new SchemeException("Invalid dotted list");
                    return ret;
                }

                var newPair = new Pair(o, null);
                if (current == null)
                {
                    ret = current = newPair;
                }
                else
                {
                    current.Second = newPair;
                    current = newPair;
                }
            }
        }

        private object ReadString()
        {
            ReadChar(); // Opening quote
            var sb = new StringBuilder();
            while (PeekChar() != '"')
            {
                char c = ReadChar();
                if (c == '\\')
                {
                    c = ReadChar();
                    if (c == 'n') c = '\n';
                    if (c == 'r') c = '\r';
                    if (c == 't') c = '\t';
                }
                sb.Append(c);
            }
            ReadChar(); // Closing quote
            return sb.ToString();
        }

        private object ReadSpecial()
        {
            ReadChar(); // #
            if (PeekChar() != '\\') return ReadSymbolOrNumber("#");
            ReadChar();
            return ReadCharacter();
        }

        private object ReadCharacter()
        {
            char c = ReadChar();
            if (!char.IsLetter(c)) return c;

            var sb = new StringBuilder();
            sb.Append(c);
            while (!IsEof() && PeekChar() != ')' && !char.IsWhiteSpace(PeekChar())) sb.Append(ReadChar());
            string name = sb.ToString();
            switch (name)
            {
                case "newline": return '\n';
                case "space": return ' ';
                case "tab": return '\t';
                default:
                    if (name.Length == 1) return name[0];
                    throw new SchemeException("Invalid character name: \\" + name);
            }
        }

        private object ReadSymbolOrNumber(string init = "")
        {
            if (init == "" && PeekChar() == ')')
            {
                ReadChar();
                return listEnd;
            }

            var sb = new StringBuilder(init);
            while (!IsEof() && PeekChar() != ')' && !char.IsWhiteSpace(PeekChar())) sb.Append(ReadChar());
            string symbol = sb.ToString();

            int i; if (int.TryParse(symbol, out i)) return i;
            double d; if (double.TryParse(symbol, NumberStyles.Any, CultureInfo.InvariantCulture, out d)) return d;
            if (symbol == "#t") return true;
            if (symbol == "#f") return false;
            if (symbol == "nil") return null;
            return Symbol.FromString(symbol);
        }
    }

    public sealed class Writer
    {
        public string Write(object o)
        {
            if (o == null) return "nil";
            if (o is bool) return (bool)o ? "#t" : "#f";
            if (o is char) return WriteChar((char)o);
            if (o is int) return ((int)o).ToString(CultureInfo.InvariantCulture);
            if (o is double) return ((double)o).ToString(CultureInfo.InvariantCulture);
            if (o is string) return "\"" + ((string)o).Replace("\\", "\\\\").Replace("\n", "\\n").Replace("\r", "\\r").Replace("\t", "\\t") + "\"";
            if (o is Symbol) return o.ToString();
            if (o is Pair) return WritePair((Pair)o);
            if (o is IEnumerable) return WriteEnumerable((IEnumerable)o);

            if (o is float) return ((double)((float)o)).ToString(CultureInfo.InvariantCulture);
            if (o is short) return ((int)((short)o)).ToString(CultureInfo.InvariantCulture);
            if (o is ushort) return ((int)((ushort)o)).ToString(CultureInfo.InvariantCulture);
            if (o is byte) return ((int)((byte)o)).ToString(CultureInfo.InvariantCulture);
            if (o is sbyte) return ((int)((sbyte)o)).ToString(CultureInfo.InvariantCulture);
            throw new VirtualMachineException("Unable to serialize object of type " + o.GetType());
        }

        private string WriteChar(char p)
        {
            if (p == '\n') return "#\\newline";
            if (p == ' ') return "#\\space";
            if (p == '\t') return "#\\tab";
            if (p < 32) throw new VirtualMachineException("Unable to serialize character with numeric code " + (int)p);
            return "#\\" + p;
        }

        private string WritePair(Pair pair)
        {
            var sb = new StringBuilder("(");
            while (true)
            {
                sb.Append(Write(pair.First));
                if (pair.Second == null) return sb + ")";
                if (!(pair.Second is Pair))
                {
                    sb.Append(" . ");
                    sb.Append(Write(pair.Second));
                    return sb + ")";
                }
                pair = (Pair)pair.Second;
                sb.Append(' ');
            }
        }

        private string WriteEnumerable(IEnumerable values)
        {
            var sb = new StringBuilder("(");
            foreach (var o in values)
            {
                sb.Append(Write(o));
                sb.Append(' ');
            }
            if (sb.Length > 1) sb[sb.Length - 1] = ')'; else sb.Append(')');
            return sb.ToString();
        }
    }

    public sealed class Compiler
    {
        private readonly VirtualMachine Machine;

        public Compiler(VirtualMachine machine)
        {
            Machine = machine;
        }

        public void Compile(object form)
        {
            CompileObject(form, false);
        }

        private void CompileObject(object o, bool isTailPosition, bool quoted = false)
        {
            if (o is Symbol)
            {
                if (quoted) Machine.EmitLdConst(o);
                else Machine.EmitGetVariable((Symbol)o);
            }
            else if (o is Pair)
            {
                if (quoted) CompileQuotedList(((Pair)o).ToArray());
                else CompileFuncallOrSpecialForm(((Pair)o).ToArray(), isTailPosition);
            }
            else
                Machine.EmitLdConst(o);
        }

        private void CompileQuotedList(object[] o)
        {
            Machine.EmitSaveRegisters();
            Machine.EmitInitArgs();
            foreach (var arg in o.Reverse())
            {
                CompileObject(arg, false, true);
                Machine.EmitPushParam();
            }
            Machine.EmitArgsToValue();
            Machine.EmitRestoreRegisters();
        }

        private void CompileFuncallOrSpecialForm(object[] o, bool isTailPosition)
        {
            if (o[0] is Symbol)
            {
                Symbol s = (Symbol)o[0];
                switch (s.ToString())
                {
                    case "if": CompileIfSpecialForm(o, isTailPosition); return;
                    case "define": CompileDefineSpecialForm(o, isTailPosition); return;
                    case "set!": CompileSetSpecialForm(o, isTailPosition); return;
                    case "lambda": CompileLambdaSpecialForm(o, isTailPosition); return;
                    case "quote": CompileQuoteSpecialForm(o); return;
                    case "begin": CompileBeginSpecialForm(o, isTailPosition); return;
                    case "sys:apply": CompileApplySpecialForm(o, isTailPosition); return;
                }
            }

            CompileFunctionCall(o, isTailPosition);
        }

        private void CompileFunctionCall(object[] o, bool isTailPosition)
        {
            if (!isTailPosition) Machine.EmitSaveRegisters();
            Machine.EmitInitArgs();

            foreach (var arg in o.Skip(1).Reverse())
            {
                CompileObject(arg, false);
                Machine.EmitPushParam();
            }

            CompileObject(o[0], false);

            if (!isTailPosition)
            {
                string continueLabel = NextLabel();
                Machine.EmitLdCont(continueLabel);
                Machine.EmitCall();
                Machine.EmitLabel(continueLabel);
                Machine.EmitRestoreRegisters();
            }
            else
            {
                Machine.EmitCall();
            }
        }

        private void CompileApplySpecialForm(object[] o, bool isTailPosition)
        {
            if (o.Length != 3) throw new SchemeException("Invalid apply form");

            if (!isTailPosition) Machine.EmitSaveRegisters();
            CompileObject(o[2], false);
            Machine.EmitValueToArgs();
            CompileObject(o[1], false);

            if (!isTailPosition)
            {
                string continueLabel = NextLabel();
                Machine.EmitLdCont(continueLabel);
                Machine.EmitCall();
                Machine.EmitLabel(continueLabel);
                Machine.EmitRestoreRegisters();
            }
            else
            {
                Machine.EmitCall();
            }
        }

        private string NextLabel()
        {
            return Machine.MakeLabel();
        }

        private void CompileIfSpecialForm(object[] form, bool isTailPosition)
        {
            if (form.Length != 3 && form.Length != 4) throw new SchemeException("Invalid if form");

            string trueLabel = NextLabel();
            string nextLabel = NextLabel();

            CompileObject(form[1], false); // Condition
            Machine.EmitBranchLabel(trueLabel);
            if (form.Length == 4) CompileObject(form[3], isTailPosition); else Machine.EmitLdConst(false); // Else-Part or #f
            Machine.EmitGotoLabel(nextLabel);
            Machine.EmitLabel(trueLabel);
            CompileObject(form[2], isTailPosition); // Then-Part
            Machine.EmitLabel(nextLabel);
        }

        private void CompileDefineSpecialForm(object[] form, bool isTailPosition)
        {
            if (form.Length == 3 && form[1] is Symbol) // Define variable
            {
                CompileObject(form[2], false);
                Machine.EmitDefineVariable((Symbol)form[1]);
                return;
            }

            if (form.Length >= 3 && form[1] is Pair) // Define procedure
            {
                var nameAndParameters = ((Pair)form[1]).Cast<Symbol>();
                var name = nameAndParameters.First();
                var parameterNames = nameAndParameters.Skip(1);
                bool hasRestParameter = ((Pair)form[1]).IsDottedList();
                string closureLabel = NextLabel();
                string afterClosureLabel = NextLabel();

                Machine.EmitMakeClosure(name.ToString(), closureLabel, hasRestParameter, parameterNames.ToArray());
                Machine.EmitDefineVariable(name);
                Machine.EmitGotoLabel(afterClosureLabel);
                Machine.EmitLabel(closureLabel);

                for (int i = 2; i < form.Length; ++i)
                    CompileObject(form[i], i == form.Length - 1);

                Machine.EmitContinue();
                Machine.EmitLabel(afterClosureLabel);
                return;
            }

            throw new SchemeException("Invalid define form");
        }

        private void CompileSetSpecialForm(object[] form, bool isTailPosition)
        {
            if (form.Length != 3) throw new SchemeException("Invalid set form: Expected 2 parameters");
            if (!(form[1] is Symbol)) throw new SchemeException("Invalid set form: '" + form[1] + "' is not a symbol");
            CompileObject(form[2], false);
            Machine.EmitSetVariable((Symbol)form[1]);
        }

        private void CompileLambdaSpecialForm(object[] form, bool isTailPosition)
        {
            if (form.Length < 3) throw new SchemeException("Invalid lambda form");

            Symbol[] parameterNames;
            bool hasRestParameter;
            string closureLabel = NextLabel();
            string afterClosureLabel = NextLabel();

            if (form[1] is Symbol) // (lambda a (form) (form) (form))
            {
                parameterNames = new[] { (Symbol)form[1] };
                hasRestParameter = true;
            }
            else if (form[1] == null) // (lambda () (form) (form) (form))
            {
                parameterNames = new Symbol[0];
                hasRestParameter = false;
            }
            else if (form[1] is Pair) // (lambda (a b c) (form) (form) (form))
            {
                hasRestParameter = ((Pair)form[1]).IsDottedList();
                parameterNames = ((Pair)form[1]).Select(s => (Symbol)s).ToArray();
            }
            else throw new SchemeException("Invalid lambda form");

            Machine.EmitMakeClosure("lambda", closureLabel, hasRestParameter, parameterNames);
            Machine.EmitGotoLabel(afterClosureLabel);
            Machine.EmitLabel(closureLabel);

            for (int i = 2; i < form.Length; ++i)
                CompileObject(form[i], i == form.Length - 1);

            Machine.EmitContinue();
            Machine.EmitLabel(afterClosureLabel);
        }

        private void CompileQuoteSpecialForm(object[] form)
        {
            if (form.Length != 2) throw new SchemeException("Invalid quote form");
            CompileObject(form[1], false, true);
        }

        private void CompileBeginSpecialForm(object[] form, bool isTailPosition)
        {
            for (int i = 1; i < form.Length; ++i)
                CompileObject(form[i], isTailPosition && i == form.Length - 1);
        }
    }

    public sealed class PrintEventArgs : EventArgs
    {
        public readonly string WhatToPrint;
        internal PrintEventArgs(string whatToPrint) { WhatToPrint = whatToPrint; }
    }

    public sealed class Scheme
    {
        private readonly VirtualMachine machine;
        private readonly Compiler compiler;
        private readonly Random random;

        public event EventHandler<PrintEventArgs> Print = delegate { };

        private static readonly Writer writer = new Writer();
        public static string ObjectToString(object value) { try { return writer.Write(value); } catch { return value.ToString(); } }

        public void SetVariable(Symbol name, object value) { machine.SetVariable(name, value); }
        public object GetVariable(Symbol name) { return machine.GetVariable(name); }

        public object Eval(string expression)
        {
            try
            {
                object ret = null;

                using (var input = new StringReader(expression))
                {
                    var reader = new Reader(input);

                    while (true)
                    {
                        object o = reader.Read(false);
                        if (o is Reader.EofObject) break;
                        HandleMacros(ref o);

                        int nextPC = machine.ProgramSize;
                        compiler.Compile(o);
                        ret = machine.Run(nextPC);
                    }
                }
                return ret;
            }
            catch (VirtualMachineException ex)
            {
                throw new SchemeException(ex.Message);
            }
        }

        private void HandleMacros(ref object obj)
        {
            if (obj == null) return;
            if (!(obj is Pair)) return;
            if (!(((Pair)obj).First is Symbol)) return;
            var form = ((Pair)obj).ToList();

            if (form[0].ToString() == "defmacro")
            {
                if (!(form[1] is Symbol)) throw new SchemeException("Invalid defmacro form: Name must be a symbol");
                string name = "sys:macro##" + form[1] + "##";
                obj = new Pair(Symbol.FromString("define"), new Pair(new Pair(Symbol.FromString(name), form[2]), ((Pair)((Pair)((Pair)obj).Second).Second).Second));
                return;
            }

            while (true) if (!ExpandMacros(ref obj)) break;
        }

        private bool ExpandMacros(ref object obj)
        {
            if (obj == null) return false;
            if (!(obj is Pair)) return false;
            if (((Pair)obj).First.ToString() == "quote") return false;
            for (object i = obj; i is Pair; i = ((Pair)i).Second) if (ExpandMacros(ref ((Pair)i).First)) return true;

            Symbol o1 = ((Pair)obj).First as Symbol;
            if (o1 == null) return false;

            Symbol macroSymbol = Symbol.FromString("sys:macro##" + o1 + "##");
            if (!machine.HasVariable(macroSymbol)) return false;

            int nextPC = machine.ProgramSize;
            compiler.Compile(new Pair(macroSymbol, Pair.FromEnumerable(((Pair)((Pair)obj).Second).Select(i => new Pair(Symbol.FromString("quote"), new Pair(i, null))))));
            obj = machine.Run(nextPC);

            return true;
        }

        public Scheme()
        {
            random = new Random();
            machine = new RegisterMachine(o => !(o is bool) || (bool)o);
            compiler = new Compiler(machine);
            machine.SetVariable("cons", MakeBinaryFunction("cons", (object a, object b) => new Pair(a, b)));
            machine.SetVariable("car", MakeUnaryFunction("car", a => ((Pair)a).First));
            machine.SetVariable("cdr", MakeUnaryFunction("cdr", a => ((Pair)a).Second));
            machine.SetVariable("set-car!", MakeBinaryFunction("set-car!", (Pair a, object b) => a.First = b));
            machine.SetVariable("set-cdr!", MakeBinaryFunction("set-cdr!", (Pair a, object b) => a.Second = b));
            machine.SetVariable("+", MakeNumericalFunction("+", (i1, i2) => i1 + i2, (d1, d2) => d1 + d2));
            machine.SetVariable("-", MakeNumericalFunction("-", (i1, i2) => i1 - i2, (d1, d2) => d1 - d2));
            machine.SetVariable("*", MakeNumericalFunction("*", (i1, i2) => i1 * i2, (d1, d2) => d1 * d2));
            machine.SetVariable("/", MakeNumericalFunction("/", (i1, i2) => i1 / i2, (d1, d2) => d1 / d2));
            machine.SetVariable("<", MakeNumericalFunction("<", (i1, i2) => i1 < i2, (d1, d2) => d1 < d2));
            machine.SetVariable(">", MakeNumericalFunction(">", (i1, i2) => i1 > i2, (d1, d2) => d1 > d2));
            machine.SetVariable("=", MakeNumericalFunction("=", (i1, i2) => i1 == i2, (d1, d2) => d1 == d2));
            machine.SetVariable("sqrt", MakeUnaryFunction("sqrt", o => Math.Sqrt(Convert.ToDouble(o, CultureInfo.InvariantCulture))));
            machine.SetVariable("expt", MakeNumericalFunction("expt", (i1, i2) => (int)Math.Pow(i1, i2), (d1, d2) => Math.Pow(d1, d2)));
            machine.SetVariable("quotient", MakeNumericalFunction("quotient", (i1, i2) => i1 / i2, (d1, d2) => (int)d1 / (int)d2));
            machine.SetVariable("sys:imod", MakeNumericalFunction("sys:imod", (i1, i2) => i1 % i2, (d1, d2) => (int)d1 % (int)d2));
            machine.SetVariable("eq?", MakeBinaryFunction("eq?", (object a, object b) => a == b));
            machine.SetVariable("pair?", MakeUnaryFunction("pair?", o => o is Pair));
            machine.SetVariable("null?", MakeUnaryFunction("null?", o => o == null));
            machine.SetVariable("string?", MakeUnaryFunction("string?", o => o is string));
            machine.SetVariable("number?", MakeUnaryFunction("number?", o => o is int || o is double));
            machine.SetVariable("char?", MakeUnaryFunction("char?", o => o is char));
            machine.SetVariable("boolean?", MakeUnaryFunction("boolean?", o => o is bool));
            machine.SetVariable("symbol?", MakeUnaryFunction("symbol?", o => o is Symbol));
            machine.SetVariable("integer?", MakeUnaryFunction("integer?", o => o is int));
            machine.SetVariable("real?", MakeUnaryFunction("real?", o => o is double));
            machine.SetVariable("procedure?", MakeUnaryFunction("procedure?", o => RegisterMachine.IsCallable(o)));
            machine.SetVariable("random", MakeUnaryFunction("random", a => random.Next(Convert.ToInt32(a, CultureInfo.InvariantCulture))));
            machine.SetVariable("display", (Func<object[], object>)display);
            machine.SetVariable("char=?", MakeBinaryFunction("char=?", (char a, char b) => a == b));
            machine.SetVariable("char>?", MakeBinaryFunction("char>?", (char a, char b) => a > b));
            machine.SetVariable("char<?", MakeBinaryFunction("char<?", (char a, char b) => a < b));
            machine.SetVariable("char-ci=?", MakeBinaryFunction("char-ci=?", (char a, char b) => char.ToLowerInvariant(a) == char.ToLowerInvariant(b)));
            machine.SetVariable("char-ci>?", MakeBinaryFunction("char-ci>?", (char a, char b) => char.ToLowerInvariant(a) > char.ToLowerInvariant(b)));
            machine.SetVariable("char-ci<?", MakeBinaryFunction("char-ci<?", (char a, char b) => char.ToLowerInvariant(a) < char.ToLowerInvariant(b)));
            machine.SetVariable("char-alphabetic?", MakeUnaryFunction("char-alphabetic?", o => char.IsLetter((char)o)));
            machine.SetVariable("char-numeric?", MakeUnaryFunction("char-numeric?", o => char.IsDigit((char)o)));
            machine.SetVariable("char-whitespace?", MakeUnaryFunction("char-whitespace?", o => char.IsWhiteSpace((char)o)));
            machine.SetVariable("char-upper-case?", MakeUnaryFunction("char-upper-case?", o => char.IsUpper((char)o)));
            machine.SetVariable("char-lower-case?", MakeUnaryFunction("char-lower-case?", o => char.IsLower((char)o)));
            machine.SetVariable("char-upcase", MakeUnaryFunction("char-upcase", o => char.ToUpperInvariant((char)o)));
            machine.SetVariable("char-downcase", MakeUnaryFunction("char-downcase", o => char.ToLowerInvariant((char)o)));
            machine.SetVariable("string=?", MakeBinaryFunction("string=?", (string a, string b) => String.Compare(a, b, false, CultureInfo.InvariantCulture) == 0));
            machine.SetVariable("string>?", MakeBinaryFunction("string>?", (string a, string b) => String.Compare(a, b, false, CultureInfo.InvariantCulture) > 0));
            machine.SetVariable("string<?", MakeBinaryFunction("string<?", (string a, string b) => String.Compare(a, b, false, CultureInfo.InvariantCulture) < 0));
            machine.SetVariable("string-ci=?", MakeBinaryFunction("string-ci=?", (string a, string b) => String.Compare(a, b, true, CultureInfo.InvariantCulture) == 0));
            machine.SetVariable("string-ci>?", MakeBinaryFunction("string-ci>?", (string a, string b) => String.Compare(a, b, true, CultureInfo.InvariantCulture) > 0));
            machine.SetVariable("string-ci<?", MakeBinaryFunction("string-ci<?", (string a, string b) => String.Compare(a, b, true, CultureInfo.InvariantCulture) < 0));
            machine.SetVariable("string-length", MakeUnaryFunction("string-length", o => ((string)o).Length));
            machine.SetVariable("string-append", MakeBinaryFunction("string-append", (string a, string b) => a + b));
            machine.SetVariable("char->integer", MakeUnaryFunction("char->integer", o => (int)(char)o));
            machine.SetVariable("integer->char", MakeUnaryFunction("integer->char", o => (char)(int)o));
            machine.SetVariable("string-ref", MakeBinaryFunction("string-ref", (string s, int index) => s[index]));
            machine.SetVariable("string->symbol", MakeUnaryFunction("string->symbol", o => Symbol.FromString((string)o)));
            machine.SetVariable("symbol->string", MakeUnaryFunction("symbol->string", o => (Symbol)o).ToString());
            machine.SetVariable("string->list", MakeUnaryFunction("string->list", o => Pair.FromEnumerable(((string)o).ToCharArray().Cast<object>())));
            machine.SetVariable("list->string", MakeUnaryFunction("list->string", o => o == null ? "" : new string(((IEnumerable<object>)o).Cast<char>().ToArray())));
            machine.SetVariable("sys:strtonum", MakeBinaryFunction("sys:strtonum", (string s, int b) => s.Contains('.') ? Convert.ToDouble(s, CultureInfo.InvariantCulture) : Convert.ToInt32(s, b)));
            machine.SetVariable("sys:numtostr", MakeBinaryFunction("sys:numtostr", (object i, int b) => (i is int) ? Convert.ToString((int)i, b) : Convert.ToString((double)i)));
            machine.SetVariable("eqv?", MakeBinaryFunction("eqv?", (object a, object b) => Eqv(a, b)));
            machine.SetVariable("equal?", MakeBinaryFunction("equal?", (object a, object b) => Equal(a, b)));
            machine.SetVariable("sys:error", MakeUnaryFunction("sys:error", o => { throw new SchemeError((Pair)o); }));
            machine.SetVariable("sys:sleep", MakeUnaryFunction("sys:sleep", o => { Thread.Sleep(Convert.ToInt32(o, CultureInfo.InvariantCulture)); return null; }));

            //// TODO: string-set, string-fill!, make-string, string-copy. Impossible with .NET strings.
            //AddFunction("sys:clr.", TODO
            //AddFunction("sys:clr-get", (object o, Symbol name) => GetClrProperty(o, name).GetValue(o, new object[0]));
            //AddFunction("sys:clr-set", (object o, Symbol name, object value) => SetClrProperty(o, name, value));

            Eval(initScript);
        }

        private const string initScript =
            "(define (caar x) (car (car x)))" +
            "(define (cadr x) (car (cdr x)))" +
            "(define (cdar x) (cdr (car x)))" +
            "(define (cddr x) (cdr (cdr x)))" +
            "(define (caaar x) (car (car (car x))))" +
            "(define (caadr x) (car (car (cdr x))))" +
            "(define (cadar x) (car (cdr (car x))))" +
            "(define (caddr x) (car (cdr (cdr x))))" +
            "(define (cdaar x) (cdr (car (car x))))" +
            "(define (cdadr x) (cdr (car (cdr x))))" +
            "(define (cddar x) (cdr (cdr (car x))))" +
            "(define (cdddr x) (cdr (cdr (cdr x))))" +
            "(define (list . lst) lst)" +
            "(define (>= a b) (if (< a b) #f #t))" +
            "(define (<= a b) (if (> a b) #f #t))" +
            "(define (char>=? a b) (if (char<? a b) #f #t))" +
            "(define (char<=? a b) (if (char>? a b) #f #t))" +
            "(define (char-ci>=? a b) (if (char-ci<? a b) #f #t))" +
            "(define (char-ci<=? a b) (if (char-ci>? a b) #f #t))" +
            "(define (string>=? a b) (if (string<? a b) #f #t))" +
            "(define (string<=? a b) (if (string>? a b) #f #t))" +
            "(define (string-ci>=? a b) (if (string-ci<? a b) #f #t))" +
            "(define (string-ci<=? a b) (if (string-ci>? a b) #f #t))" +
            "(define (zero? x) (= x 0))" +
            "(define (positive? x) (> x 0))" +
            "(define (negative? x) (< x 0))" +
            "(define (abs x) (if (positive? x) x (- 0 x)))" +
            "(define (sys:sign x) (if (>= x 0) 1 -1))" +
            "(define (remainder a b) (* (sys:sign a) (abs (sys:imod a b))))" +
            "(define (modulo a b) (if (= (sys:sign a) (sys:sign b)) (sys:imod a b) (+ b (sys:imod a b))))" +
            "(define (even? x) (zero? (sys:imod x 2)))" +
            "(define (odd? x) (if (even? x) #f #t))" +
            "(define (not x) (if x #f #t))" +
            "(define (newline) (display \"\\n\"))" +
            "(define (length lst) (define (iter i acc) (if (null? i) acc (iter (cdr i) (+ 1 acc)))) (iter lst 0))" +
            "(define (reverse lst) (define (iter i acc) (if (null? i) acc (iter (cdr i) (cons (car i) acc)))) (iter lst nil))" +
            "(define (map f lst) (define (iter i acc) (if (null? i) (reverse acc) (iter (cdr i) (cons (f (car i)) acc)))) (iter lst nil))" +
            "(define (for-each f lst) (if (null? lst) nil (begin (f (car lst)) (for-each f (cdr lst)))))" +
            "(define (filter f lst) (define (iter i acc) (if (null? i) (reverse acc) (iter (cdr i) (if (f (car i)) (cons (car i) acc) acc)))) (iter lst nil))" +
            "(define (fold f acc lst) (if (null? lst) acc (fold f (f (car lst) acc) (cdr lst))))" +
            "(define (all? f lst) (define (iter i) (if (null? i) #t (if (f (car i)) (iter (cdr i)) #f))) (iter lst))" +
            "(define (any? f lst) (define (iter i) (if (null? i) #f (if (f (car i)) #t (iter (cdr i))))) (iter lst))" +
            "(define (list-tail lst k) (if (zero? k) lst (list-tail (cdr lst) (- k 1))))" +
            "(define (list-ref lst k) (car (list-tail lst k)))" +
            "(define (sys:gcd-of-two a b) (if (= b 0) a (sys:gcd-of-two b (remainder a b))))" +
            "(define (sys:lcm-of-two a b) (/ (* a b) (sys:gcd-of-two a b)))" +
            "(define (gcd . args) (if (zero? (length args)) 0 (abs (fold sys:gcd-of-two (car args) (cdr args)))))" +
            "(define (lcm . args) (if (zero? (length args)) 1 (abs (fold sys:lcm-of-two (car args) (cdr args)))))" +
            "(define (append . lsts) (define (iter current acc) (if (pair? current) (iter (cdr current) (cons (car current) acc)) acc)) (reverse (fold iter nil lsts)))" +
            "(define (error . params) (sys:error params))" +
            "(define (string . values) (list->string values))" +
            "(define (string->number n . rest) (if (pair? rest) (sys:strtonum n (car rest)) (sys:strtonum n 10)))" +
            "(define (number->string n . rest) (if (pair? rest) (sys:numtostr n (car rest)) (sys:numtostr n 10)))" +
            "(define (substring str start end) (define (get-char pos) (string-ref str pos)) (list->string (map get-char (sys:range start (- end 1)))))" +
            "(define (memq obj lst) (if (pair? lst) (if (eq? obj (car lst)) lst (memq obj (cdr lst))) #f))" +
            "(define (memv obj lst) (if (pair? lst) (if (eqv? obj (car lst)) lst (memv obj (cdr lst))) #f))" +
            "(define (member obj lst) (if (pair? lst) (if (equal? obj (car lst)) lst (member obj (cdr lst))) #f))" +
            "(define (assq obj lst) (if (pair? lst) (if (eq? obj (caar lst)) (car lst) (assq obj (cdr lst))) #f))" +
            "(define (assv obj lst) (if (pair? lst) (if (eqv? obj (caar lst)) (car lst) (assv obj (cdr lst))) #f))" +
            "(define (assoc obj lst) (if (pair? lst) (if (equal? obj (caar lst)) (car lst) (assoc obj (cdr lst))) #f))" +
            "(define (apply f args) (sys:apply f args))" +
            "(defmacro let (lst . forms) (cons (cons 'lambda (cons (map car lst) forms)) (map cadr lst)))" +
            "(defmacro cond list-of-forms (define (expand-cond lst) (if (null? lst) #f (if (eq? (caar lst) 'else) (cons 'begin (cdar lst)) (list 'if (caar lst) (cons 'begin (cdar lst)) (expand-cond (cdr lst)))))) (expand-cond list-of-forms))" +
            "(defmacro delay (expression) (list 'let '((##forced_value (quote ##not_forced_yet))) (list 'lambda '() (list 'if '(eq? ##forced_value (quote ##not_forced_yet)) (list 'set! '##forced_value expression)) '##forced_value)))" +
            "(define (force promise) (promise))" +
            "(define (min . args) (define (min-of-two a b) (if (< a b) a b)) (let ((l (length args))) (cond ((= 0 l) (error \"min called without parameters\")) ((= 1 l) (car args)) (else (fold min-of-two (car args) (cdr args))))))" +
            "(define (max . args) (define (max-of-two a b) (if (> a b) a b)) (let ((l (length args))) (cond ((= 0 l) (error \"max called without parameters\")) ((= 1 l) (car args)) (else (fold max-of-two (car args) (cdr args))))))" +
            "(define (sys:curry proc . cargs) (lambda args (apply proc (append cargs args))))" +
            "(define (sys:range from to) (define (iter i acc) (if (> from i) acc (iter (- i 1) (cons i acc)))) (iter to nil))" +
            "(define (sys:count from to f) (if (< to from) nil (begin (f from) (sys:count (+ 1 from) to f))))" +
            "(define (sys:split str sep) (define (iter acc cur s) (cond ((string=? s \"\") (reverse (cons cur acc))) ((char=? (string-ref s 0) sep) (iter (cons cur acc) \"\" (substring s 1 (string-length s)))) (else (iter acc (string-append cur (substring s 0 1)) (substring s 1 (string-length s)))))) (iter '() \"\" str))" +

            "(define (sort x f)" +
            "  (cond ((null? x) x)                                                        " +
            "        ((null? (cdr x)) x)                                                  " +
            "        (else                                                                " +
            "          (let ((pivot (car x)))                                             " +
            "            (let ((part1 (filter (lambda (i) (f i pivot)) (cdr x)))          " +
            "                  (part2 (filter (lambda (i) (not (f i pivot))) (cdr x))))   " +
            "              (append                                                        " +
            "                (sort part1 f)                                               " +
            "                (list pivot)                                                 " +
            "                (sort part2 f)))))))                                         " +


            "(define curry sys:curry)" +
            "(define range sys:range)" +
            "(define count sys:count)" +
            "(define sleep sys:sleep)" +
            "(define split sys:split)" +
            //"(define clr-get sys:clr-get)" +
            //"(define clr-set sys:clr-set)" +
            //"(define clr. sys:clr.)" +
            "";

        // TODO: and, or, sort

        private static void AssertParameterCount(string procedure, int expected, object[] parameters)
        {
            if (parameters.Length != expected) throw new SchemeException(procedure + ": Expected " + expected + " parameter(s), got " + parameters.Length);
        }

        private static Func<object[], object> MakeNumericalFunction(string name, Func<int, int, object> iF, Func<double, double, object> dF)
        {
            return args =>
            {
                AssertParameterCount(name, 2, args);
                object o1 = args[0];
                object o2 = args[1];
                if (!(o1 is int) && !(o1 is double)) throw new SchemeException(name + ": Invalid argument type in arg 1, expected int or double, got " + o1.GetType());
                if (!(o2 is int) && !(o2 is double)) throw new SchemeException(name + ": Invalid argument type in arg 2, expected int or double, got " + o2.GetType());
                return o1 is int && o2 is int ? iF((int)o1, (int)o2) : dF(Convert.ToDouble(o1, CultureInfo.InvariantCulture), Convert.ToDouble(o2, CultureInfo.InvariantCulture));
            };
        }

        private static Func<object[], object> MakeUnaryFunction(string name, Func<object, object> f)
        {
            return args =>
            {
                AssertParameterCount(name, 1, args);
                return f(args[0]);
            };
        }

        private static Func<object[], object> MakeBinaryFunction<A, B>(string name, Func<A, B, object> f)
        {
            return args =>
            {
                AssertParameterCount(name, 2, args);
                if (args[0] != null && !(args[0] is A)) throw new SchemeException(name + ": Expected first parameter to be of type '" + typeof(A) + "', got '" + args[0].GetType() + "'");
                if (args[1] != null && !(args[1] is B)) throw new SchemeException(name + ": Expected second parameter to be of type '" + typeof(B) + "', got '" + args[1].GetType() + "'");
                return f((A)args[0], (B)args[1]);
            };
        }

        private static object Eqv(object a, object b)
        {
            if (a == b) return true;
            if (a is bool && b is bool) return ((bool)a) == ((bool)b);
            if (a is char && b is char) return ((char)a) == ((char)b);
            if (a is int && b is int) return ((int)a) == ((int)b);
            if (a is double && b is double) return ((double)a) == ((double)b);
            return false;
        }

        private static object Equal(object a, object b)
        {
            if ((bool)Eqv(a, b)) return true;
            if (a is string && b is string) return string.Equals(a, b);
            if (a is IEnumerable<object> && b is IEnumerable<object>)
            {
                List<object> l1 = ((IEnumerable<object>)a).ToList();
                List<object> l2 = ((IEnumerable<object>)b).ToList();
                if (l1.Count != l2.Count) return false;
                for (int i = 0; i < l1.Count; ++i) if (!(bool)Equal(l1[i], l2[i])) return false;
                return true;
            }
            return false;
        }

        private object display(object[] parameters)
        {
            Print(this, new PrintEventArgs(string.Join(" ", parameters)));
            return true;
        }
    }
}