Tim Robinson

(define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
(Console.WriteLine "6! = {0}" (fact 6))
(Console.WriteLine "What is your name?")
(Console.WriteLine "Hello, {0}" (Console.ReadLine))

[List
   [Atom "define"; List [Atom "fact"; Atom "n"];
    List
      [Atom "if"; List [Atom "="; Atom "n"; Number 0]; Number 1;
       List
         [Atom "*"; Atom "n";
          List [Atom "fact"; List [Atom "-"; Atom "n"; Number 1]]]]];
 List
   [Atom "Console.WriteLine"; String "6! = {0}"; List [Atom "fact"; Number 6]];
 List [Atom "Console.WriteLine"; String "What is your name?"];
 List
   [Atom "Console.WriteLine"; String "Hello, {0}";
    List [Atom "Console.ReadLine"]]]

// Turn a LispVal into a function or variable name
let extractAtom = function
    | Atom a -> a
    | v -> raise <| Compiler(sprintf "expected atom, got %A" v)

// Note: insertPrimitives accepts a LispVal and returns a LispVal.
// The function keyword combines function declaration with pattern matching.
let rec insertPrimitives = 
    function
    // Convert arithmetic operators into ListPrimitive
    | List (Atom "+" :: args) -> ListPrimitive (Add, args |> List.map insertPrimitives)
    | List (Atom "-" :: args) -> ListPrimitive (Subtract, args |> List.map insertPrimitives)
    | List (Atom "*" :: args) -> ListPrimitive (Multiply, args |> List.map insertPrimitives)
    | List (Atom "/" :: args) -> ListPrimitive (Divide, args |> List.map insertPrimitives)
    | List (Atom "=" :: args) -> ListPrimitive (Equal, args |> List.map insertPrimitives)

    | List (Atom "define" :: args) ->
        match args with
        | [ Atom name; v ] -> 
            // Convert (define variableName value) into VariableDef
            VariableDef (name, insertPrimitives v)

        | [ List (Atom name :: names); body ] -> 
            // Convert (define functionName (x y z) value) into a VariableDef wrapping a LambdaDef
            // This represents a named static .NET method
            VariableDef (name, LambdaDef (names |> List.map extractAtom, insertPrimitives body))

        | _ -> 
            // Note: "raise <| Compiler message" is equivalent to C# "throw new CompilerException(message)"
            raise <| Compiler "expected define name value"

    | List (Atom "if" :: args) ->
        match args with
        | [ testValue; thenValue; elseValue ] -> 
            // Convert (if test then else) into IfPrimitive)
            IfPrimitive (insertPrimitives testValue, insertPrimitives thenValue, insertPrimitives elseValue)

        | _ -> 
            raise <| Compiler "expected three items for if"

    | List (Atom "lambda" :: args) ->
        match args with
        | [ List names; body ] -> 
            // Convert (lambda (x y z) value) into LambdaDef, without a VariableDef
            LambdaDef (names |> List.map extractAtom, insertPrimitives body)

        | _ -> 
            raise <| Compiler "expected lambda names body"

    | List l -> 
        // Apply insertPrimitives recursively on any function invokations
        l |> List.map insertPrimitives |> List

    | v -> v

[VariableDef
   ("fact",
    LambdaDef
      (["n"],
       IfPrimitive
         (ListPrimitive (Equal,[Atom "n"; Number 0]),Number 1,
          ListPrimitive
            (Multiply,
             [Atom "n";
              List [Atom "fact"; ListPrimitive (Subtract,[Atom "n"; Number 1])]]))));
 List
   [Atom "Console.WriteLine"; String "6! = {0}"; List [Atom "fact"; Number 6]];
 List [Atom "Console.WriteLine"; String "What is your name?"];
 List
   [Atom "Console.WriteLine"; String "Hello, {0}";
    List [Atom "Console.ReadLine"]]]

let rec compile
    (generator : ILGenerator)
    (defineMethod : string -> Type -> Type list -> #MethodInfo * ILGenerator)
    (env : Map<string, LispVal>)
    (value : LispVal) 
    : (Map<string, LispVal>)

let rec typeOf (env : Map<string, LispVal>) = function
    | ArgRef _ -> typeof<int>
    | Atom a -> a |> ident env |> typeOf env
    | Bool _ -> typeof<bool>
    | IfPrimitive (_, thenValue, elseValue) ->
        match typeOf env thenValue with
        | t when t = typeOf env elseValue -> t
        | _ -> raise <| Compiler("expected 'then' and 'else' branches to have same type")

    | LambdaDef (_, body) -> typeOf env body
    | LambdaRef (methodBuilder, _, _) -> methodBuilder.ReturnType
    | List (Atom a :: args) -> a |> lambdaIdent args env |> typeOf env
    | List (fn :: _) -> raise <| Compiler(sprintf "can't invoke %A" fn)
    | List [ ] -> raise <| Compiler("can't compile empty list")
    | ListPrimitive _ -> typeof<int>
    | Number _ -> typeof<int>
    | String _ -> typeof<string>
    | VariableDef _ -> typeof<Void>
    | VariableRef local -> local.LocalType  

and lambdaIdent args env (a : string) =
    let envMatches = 
        maybe {
            let! v = Map.tryFind a env
            let! r =
                match v with
                | LambdaRef _ -> Some v
                | _ -> None
            return r
        } |> Option.to_list

    let clrTypeAndMethodName = 
        maybe {
            let! (typeName, methodName) = 
                match a.LastIndexOf('.') with
                | -1 -> None
                | n -> Some (a.Substring(0, n), a.Substring(n + 1))

            let! clrType =
                referencedAssemblies
                |> List.map (fun assembly -> 
                    usingNamespaces 
                    |> List.map (fun usingNamespace -> (assembly, usingNamespace)))
                |> List.concat
                |> List.tryPick (fun (assembly, usingNamespace) -> option_of_nullable <| assembly.GetType(usingNamespace + "." + typeName))

            return (clrType, methodName)
        } 

    let clrMatches =
        match clrTypeAndMethodName with
        | Some (clrType, methodName) -> 
            clrType.GetMethods(BindingFlags.Public ||| BindingFlags.Static) 
            |> List.of_array
            |> List.filter (fun m -> m.Name = methodName)
            |> List.map makeLambdaRef

        | None -> 
            [ ]

    let argsMatchParameters = function
        | LambdaRef (_, isParamArray, parameterTypes) ->
            let rec argsMatchParameters' argTypes (parameterTypes : #Type list) =
                match argTypes, parameterTypes with
                | [ ], [ ] -> 
                    // No args and no parameters -> always OK
                    true

                | [ ], [ _ ] -> 
                    // No args and one parameter -> OK only for params array methods
                    isParamArray

                | [ ], _ ->
                    // No args and two or more parameters -> never OK
                    false

                | argType :: otherArgTypes, [ parameterType ] when isParamArray -> 
                    // One or more args and one parameter, in a params array method ->
                    //  OK if the types of the first arg and the params array are compatible,
                    //  and the rest of the args match the params array
                    parameterType.GetElementType().IsAssignableFrom(argType) 
                    && argsMatchParameters' otherArgTypes parameterTypes

                | argType :: otherArgTypes, parameterType :: otherParameterTypes -> 
                    // One or more args and one or more parameters -> 
                    //  OK if the types of the first arg and parameter are compatible, 
                    //  and the rest of the args match the rest of the parameters
                    parameterType.IsAssignableFrom(argType) 
                    && argsMatchParameters' otherArgTypes otherParameterTypes

                | _ :: _, [ ] -> 
                    // One or more args and no parameters -> never OK
                    false

            argsMatchParameters' (List.map (typeOf env) args) parameterTypes

        | _ -> false

    let candidates = List.append envMatches clrMatches
    match candidates with
    | [ ] -> raise <| Compiler(sprintf "no method called %s" a)
    | _ -> ()

    let allMatches = List.filter argsMatchParameters candidates
    match allMatches with
    | [ ] -> raise <| Compiler(sprintf "no overload of %s is compatible with %A" a args)
    | firstMatch :: _ -> firstMatch

%{
open Tim.Lisp.Core
%}

%start parse
%token <string> Identifier
%token <string> Text
%token <int> Digits
%token Apostrophe LeftParen RightParen Eof
%type <Tim.Lisp.Core.LispVal list> parse

%%

Expr: Identifier { Atom $1 }
    | Text { String $1 }
    | Digits { Number $1 }
    | LeftParen ExprList RightParen { $2 |> List.rev |> List }
    | Apostrophe Expr { List [ Atom "quote"; $2 ] }

ExprList: Expr { [ $1 ] }
        | ExprList Expr { $2 :: $1  }

parse: ExprList Eof { List.rev $1 }

// Signature file for parser generated by fsyacc
#light
type token = 
  | Apostrophe
  | LeftParen
  | RightParen
  | Eof
  | Digits of (int)
  | Text of (string)
  | Identifier of (string)
// snip rest of generated code

{
open System
open System.Text
open Microsoft.FSharp.Text.Lexing
open FSYacc
}

let digit = ['0'-'9']
let alpha = ['a'-'z' 'A'-'Z']
let whitespace = [' ' '\t']
let newline = ('\n' | '\r' '\n')
let identifier = [^'"' '0'-'9' '(' ')' ' ' '\t' '\n' '\r']
 
rule tokenize = parse
| whitespace        { tokenize lexbuf }
| newline           { lexbuf.EndPos <- lexbuf.EndPos.NextLine; tokenize lexbuf }
| ['-']?digit+      { Digits <| Int32.Parse(Encoding.UTF8.GetString(lexbuf.Lexeme)) }
| '('               { LeftParen }
| ')'               { RightParen }
| '\''              { Apostrophe }
| '"' [^'"']* '"'   { let s = Encoding.UTF8.GetString(lexbuf.Lexeme) in Text <| s.Substring(1, s.Length - 2) }
| eof               { Eof }
| identifier+       { Identifier <| Encoding.UTF8.GetString(lexbuf.Lexeme) }

#light
open System.Text
open Microsoft.FSharp.Text.Lexing

module Parser =
    // Accepts a string and either returns a list of LispVal objects or throws an exception
    let parseString (s : string) = FSYacc.parse FSLex.tokenize <| LexBuffer<_>.FromBytes(Encoding.UTF8.GetBytes(s))

(define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
(Console.WriteLine "6! = {0}" (fact 6))
(Console.WriteLine "What is your name?")
(Console.WriteLine "Hello, {0}" (Console.ReadLine))

(*
 * Rough C# equivalent:
 * public enum ListOp { Add, Subtract, Multiply, Divide, Equal }
 *)

type ListOp = Add
            | Subtract 
            | Multiply 
            | Divide 
            | Equal

(*
 * Rough C# equivalent:
 * public abstract class LispVal { }
 *
 * public sealed class ArgRef : LispVal
 * {
 *     public ArgRef(int index)
 *     {
 *         Index = index;
 *     }
 *
 *     public int Index { get; private set; }
 * }
 *
 * public sealed class Atom : LispVal
 * {
 *     public Atom(string text)
 *     {
 *         Text = text;
 *     }
 *
 *     public string Text { get; private set; }
 * }
 *
 * etc., for the other cases
 *)
type LispVal = 
             | ArgRef of int                                
             | Atom of string
             | Bool of bool
             | IfPrimitive of LispVal * LispVal * LispVal
             | LambdaDef of string list * LispVal
             | LambdaRef of MethodInfo * bool * Type list
             | List of LispVal list
             | ListPrimitive of ListOp * LispVal list
             | Number of int
             | QuotePrimitive of LispVal
             | String of string
             | VariableDef of string * LispVal
             | VariableRef of LocalBuilder

(*
 * Rough C# equivalent: an implementation of the visitor pattern
 *)
let rec typeOf (env : Map) = function
    | ArgRef _ -> typeof
    | Atom a -> a |> ident env |> typeOf env
    | Bool _ -> typeof
    | IfPrimitive (_, thenValue, elseValue) ->
        match typeOf env thenValue with
        | t when t = typeOf env elseValue -> t
        | _ -> raise <| Compiler("expected 'then' and 'else' branches to have same type")

    | LambdaDef (_, body) -> typeOf env body
    | LambdaRef (methodBuilder, _, _) -> methodBuilder.ReturnType
    | List (Atom a :: args) -> a |> lambdaIdent args env |> typeOf env
    | List (fn :: _) -> raise <| Compiler(sprintf "can't invoke %A" fn)
    | List [ ] -> raise <| Compiler("can't compile empty list")
    | ListPrimitive _ -> typeof
    | Number _ -> typeof
    | String _ -> typeof
    | QuotePrimitive _ -> typeof
    | VariableDef _ -> typeof
    | VariableRef local -> local.LocalType

public static class Program
{
    private static int Calculate()
    {
        IL.Push(10, 1, 1);
        IL.Emit("add");
        IL.Emit("mul");
        IL.Emit("ret");
        return 0;
    }
 
    public static void Main()
    {
        Console.WriteLine("(1 + 1) * 10 = {0}", Calculate());
    }
}

using System;
using System.Collections.Generic;
using System.Linq;
using System.Reflection;
using Mono.Cecil;
using Mono.Cecil.Cil;
using NUnit.Framework;
 
[TestFixture]
public class InlineIL
{
    private static bool ReplaceInstructions(MethodDefinition method)
    {
        CilWorker worker = method.Body.CilWorker;
        foreach (Instruction instruction in method.Body.Instructions)
        {
            if (instruction.OpCode == OpCodes.Ldstr)
            {
                Instruction next = instruction.Next;
                if (next == null)
                    continue;

                if (next.OpCode != OpCodes.Call)
                    continue;

                MethodReference operand = (MethodReference) next.Operand;
                if (operand.DeclaringType.Name != "IL")
                    continue;

                switch (operand.Name)
                {
                    case "Emit":
                        string asm = ((string) instruction.Operand).Replace('.', '_');
                        FieldInfo field = typeof(OpCodes).GetField(
                            asm,
                            BindingFlags.Public | BindingFlags.Static | BindingFlags.IgnoreCase);

                        if (field == null)
                            throw new InvalidOperationException("Unrecognised opcode " + asm + ".");

                        OpCode opCode = (OpCode) field.GetValue(null);
                        Instruction replacement = worker.Create(opCode);
                        worker.Replace(instruction, replacement);
                        worker.Remove(next);
                        return true;
                }
            }
            else if (instruction.OpCode == OpCodes.Call)
            {
                MethodReference operand = (MethodReference) instruction.Operand;
                if (operand.DeclaringType.Name != "IL")
                    continue;

                switch (operand.Name)
                {
                    case "Push":
                    case "Pop":
                        worker.Remove(instruction);
                        return true;
                }
            }
        }

        return false;
    }

    [Test]
    public void ExpandInlineAsm()
    {
        AssemblyDefinition assembly = AssemblyFactory.GetAssembly("Temp.exe");
        IEnumerable<MethodDefinition> methods =
            from module in assembly.Modules.Cast<ModuleDefinition>()
            from type in module.Types.Cast<TypeDefinition>()
            from method in type.Methods.Cast<MethodDefinition>()
            select method;

        foreach (var method in methods)
        {
            while (ReplaceInstructions(method))
            {
            }
        }

        AssemblyFactory.SaveAssembly(assembly, "Temp.new.exe");
    }
}