├── .editorconfig
├── .gitignore
├── .travis.yml
├── License.md
├── Naggum.Assembler
├── App.config
├── Assembler.fs
├── AssemblyInfo.fs
├── Naggum.Assembler.fsproj
├── Processor.fs
├── Program.fs
├── Representation.fs
└── packages.config
├── Naggum.Backend
├── AssemblyInfo.fs
├── Matchers.fs
├── MaybeMonad.fs
├── Naggum.Backend.fsproj
├── Reader.fs
└── packages.config
├── Naggum.Compiler
├── App.config
├── AssemblyInfo.fs
├── ClrGenerator.fs
├── Context.fs
├── FormGenerator.fs
├── Generator.fs
├── GeneratorFactory.fs
├── Globals.fs
├── IGenerator.fs
├── MathGenerator.fs
├── Naggum.Compiler.fsproj
├── NumberGen.fs
├── Program.fs
├── StringGen.fs
└── packages.config
├── Naggum.Interactive
├── Naggum.Interactive.csproj
├── Program.cs
├── Properties
│ └── AssemblyInfo.cs
└── app.config
├── Naggum.Runtime
├── Cons.cs
├── Naggum.Runtime.csproj
├── Properties
│ └── AssemblyInfo.cs
├── Reader.cs
└── Symbol.cs
├── Naggum.Test
├── AssemblerTests.fs
├── AssemblyInfo.fs
├── CompilerTest.fs
├── InstructionTests.fs
├── MatchersTests.fs
├── Naggum.Test.dll.config
├── Naggum.Test.fsproj
├── Process.fs
├── ProcessorTests.fs
└── packages.config
├── Naggum.sln
├── Readme.md
├── appveyor.yml
├── default.nix
├── docs
├── Makefile
├── about.rst
├── build-guide.rst
├── conf.py
├── index.rst
├── make.bat
├── specification.rst
└── usage.rst
└── tests
├── comment.naggum
├── comment.result
├── let-funcall.naggum
├── let-funcall.result
├── test.naggum
└── test.result
/.editorconfig:
--------------------------------------------------------------------------------
1 | root = true
2 |
3 | [*]
4 | charset = utf-8
5 | indent_style = space
6 | indent_size = 4
7 | trim_trailing_whitespace = true
8 | insert_final_newline = true
9 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | /.idea/
2 | /.vs/
3 | /docs/_build/
4 | /packages/
5 |
6 | /*.user
7 |
8 | bin/
9 | obj/
10 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: csharp
2 | mono:
3 | - 4.4.2
4 | - latest
5 | solution: Naggum.sln
6 | install:
7 | - nuget restore Naggum.sln
8 | - nuget install xunit.runner.console -Version 2.1.0 -OutputDirectory testrunner
9 | script:
10 | - xbuild /p:Configuration=Release /p:TargetFrameworkVersion="v4.5" Naggum.sln
11 | - mono ./testrunner/xunit.runner.console.2.1.0/tools/xunit.console.exe ./Naggum.Test/bin/Release/Naggum.Test.dll
12 |
--------------------------------------------------------------------------------
/License.md:
--------------------------------------------------------------------------------
1 | The MIT License (MIT)
2 | =====================
3 |
4 | Copyright (C) 2011–2016 by Naggum authors
5 |
6 | Permission is hereby granted, free of charge, to any person obtaining a copy
7 | of this software and associated documentation files (the "Software"), to deal
8 | in the Software without restriction, including without limitation the rights
9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10 | copies of the Software, and to permit persons to whom the Software is
11 | furnished to do so, subject to the following conditions:
12 |
13 | The above copyright notice and this permission notice shall be included in
14 | all copies or substantial portions of the Software.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22 | THE SOFTWARE.
23 |
--------------------------------------------------------------------------------
/Naggum.Assembler/App.config:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
--------------------------------------------------------------------------------
/Naggum.Assembler/Assembler.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Assembler.Assembler
2 |
3 | open System
4 | open System.Reflection
5 | open System.Reflection.Emit
6 |
7 | open Naggum.Assembler.Representation
8 |
9 | let private getMethodAttributes (m : MethodDefinition) =
10 | let empty = enum 0
11 | let conditions =
12 | [ (m.Visibility = Public, MethodAttributes.Public)
13 | (true, MethodAttributes.Static) ] // TODO: Proper static method detection
14 |
15 | conditions
16 | |> List.map (fun (c, r) -> if c then r else empty)
17 | |> List.fold (|||) empty
18 |
19 | let private findMethod (signature : MethodSignature) =
20 | let ``type`` = signature.ContainingType.Value
21 | ``type``.GetMethod (signature.Name, Array.ofList signature.ArgumentTypes)
22 |
23 | let private buildMethodBody (m : MethodDefinition) (builder : MethodBuilder) =
24 | use generator = new GrEmit.GroboIL (builder)
25 |
26 | m.Body
27 | |> List.iter (function
28 | | Call signature ->
29 | let methodInfo = findMethod signature
30 | generator.Call methodInfo
31 | | LdcI4 i -> generator.Ldc_I4 i
32 | | Ldstr string -> generator.Ldstr string
33 | | Simple Add -> generator.Add ()
34 | | Simple Div -> generator.Div (false) // TODO: Signed division support
35 | | Simple Mul -> generator.Mul ()
36 | | Simple Ret -> generator.Ret ()
37 | | Simple Sub -> generator.Sub ())
38 |
39 | let private assembleUnit (assemblyBuilder : AssemblyBuilder) (builder : ModuleBuilder) = function
40 | | Method m ->
41 | let name = m.Name
42 | let attributes = getMethodAttributes m
43 | let returnType = m.ReturnType
44 | let argumentTypes = Array.ofList m.ArgumentTypes
45 | let methodBuilder = builder.DefineGlobalMethod (name,
46 | attributes,
47 | returnType,
48 | argumentTypes)
49 | if Set.contains EntryPoint m.Metadata then
50 | assemblyBuilder.SetEntryPoint methodBuilder
51 | buildMethodBody m methodBuilder
52 |
53 | /// Assembles the intermediate program representation. Returns an assembled
54 | /// module.
55 | let assemble (mode : AssemblyBuilderAccess) (assembly : Assembly) =
56 | let name = AssemblyName assembly.Name
57 | let domain = AppDomain.CurrentDomain
58 | let builder = domain.DefineDynamicAssembly (name, mode)
59 | let fileName = assembly.Name + ".exe" // TODO: Proper file naming
60 | let moduleBuilder = builder.DefineDynamicModule (assembly.Name, fileName)
61 | assembly.Units |> List.iter (assembleUnit builder moduleBuilder)
62 | moduleBuilder.CreateGlobalFunctions ()
63 | builder
64 |
65 | /// Assembles the intermediate program representation. Returns a list of
66 | /// assemblies ready for saving.
67 | let assembleAll (mode : AssemblyBuilderAccess)
68 | (assemblies : Assembly seq) : AssemblyBuilder seq =
69 | assemblies
70 | |> Seq.map (assemble mode)
71 |
--------------------------------------------------------------------------------
/Naggum.Assembler/AssemblyInfo.fs:
--------------------------------------------------------------------------------
1 | namespace Naggum.Assembler.AssemblyInfo
2 |
3 | open System.Reflection
4 | open System.Runtime.InteropServices
5 |
6 | []
7 | []
8 | []
9 | []
10 | []
11 | []
12 |
13 | ()
14 |
--------------------------------------------------------------------------------
/Naggum.Assembler/Naggum.Assembler.fsproj:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | Debug
6 | AnyCPU
7 | 2.0
8 | 40b84f1e-1823-4255-80d4-1297613025c1
9 | Exe
10 | Naggum.Assembler
11 | Naggum.Assembler
12 | v4.6.1
13 | true
14 | 4.4.0.0
15 | Naggum.Assembler
16 |
17 |
18 |
19 | true
20 | full
21 | false
22 | false
23 | bin\Debug\
24 | DEBUG;TRACE
25 | 3
26 | AnyCPU
27 | bin\Debug\Naggum.Assembler.XML
28 | true
29 |
30 |
31 | pdbonly
32 | true
33 | true
34 | bin\Release\
35 | TRACE
36 | 3
37 | AnyCPU
38 | bin\Release\Naggum.Assembler.XML
39 | true
40 |
41 |
42 | 11
43 |
44 |
45 |
46 |
47 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets
48 |
49 |
50 |
51 |
52 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
68 | ..\packages\FSharp.Core.4.0.0.1\lib\net40\FSharp.Core.dll
69 | True
70 |
71 |
72 | ..\packages\GrEmit.2.1.7\lib\net40\GrEmit.dll
73 | True
74 |
75 |
76 |
77 |
78 |
79 |
80 | Naggum.Backend
81 | {243738f3-d798-4b09-8797-f90b21414b60}
82 | True
83 |
84 |
85 |
92 |
--------------------------------------------------------------------------------
/Naggum.Assembler/Processor.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Assembler.Processor
2 |
3 | open System
4 | open System.IO
5 | open System.Reflection
6 |
7 | open Naggum.Assembler.Representation
8 | open Naggum.Backend
9 | open Naggum.Backend.Matchers
10 |
11 | let private (|SimpleOpCode|_|) = function
12 | | Symbol "add" -> Some (Simple Add)
13 | | Symbol "div" -> Some (Simple Div)
14 | | Symbol "mul" -> Some (Simple Mul)
15 | | Symbol "ret" -> Some (Simple Ret)
16 | | Symbol "sub" -> Some (Simple Sub)
17 | | _ -> None
18 |
19 | let private processMetadataItem = function
20 | | Symbol ".entrypoint" -> EntryPoint
21 | | other -> failwithf "Unrecognized metadata item definition: %A" other
22 |
23 | let private resolveAssembly _ =
24 | Assembly.GetAssembly(typeof) // TODO: Assembly resolver
25 |
26 | let private resolveType name =
27 | let result = Type.GetType name // TODO: Resolve types from the assembler context
28 | if isNull result then
29 | failwithf "Type %s could not be found" name
30 |
31 | result
32 |
33 | let private resolveTypes =
34 | List.map (function
35 | | Symbol name -> resolveType name
36 | | other -> failwithf "Unrecognized type: %A" other)
37 |
38 | let private processMethodSignature = function
39 | | [Symbol assembly
40 | Symbol typeName
41 | Symbol methodName
42 | List argumentTypes
43 | Symbol returnType] ->
44 | { Assembly = Some (resolveAssembly assembly) // TODO: Resolve types from current assembly
45 | ContainingType = Some (resolveType typeName) // TODO: Resolve methods without a type (e.g. assembly methods)
46 | Name = methodName
47 | ArgumentTypes = resolveTypes argumentTypes
48 | ReturnType = resolveType returnType }
49 | | other -> failwithf "Unrecognized method signature: %A" other
50 |
51 | let private processInstruction = function
52 | | List [Symbol "ldstr"; String s] -> Ldstr s
53 | | List [Symbol "ldc.i4"; Integer i] -> LdcI4 i
54 | | List [Symbol "call"; List calleeSignature] ->
55 | let signature = processMethodSignature calleeSignature
56 | Call signature
57 | | List [SimpleOpCode r] -> r
58 | | other -> failwithf "Unrecognized instruction: %A" other
59 |
60 | let private addMetadata metadata method' =
61 | List.fold (fun ``method`` metadataExpr ->
62 | let metadataItem = processMetadataItem metadataExpr
63 | { ``method`` with Metadata = Set.add metadataItem ``method``.Metadata })
64 | method'
65 | metadata
66 |
67 | let private addBody body method' =
68 | List.fold (fun ``method`` bodyClause ->
69 | let instruction = processInstruction bodyClause
70 | { ``method`` with Body = List.append ``method``.Body [instruction] })
71 | method'
72 | body
73 |
74 | let private processAssemblyUnit = function
75 | | List (Symbol ".method"
76 | :: Symbol name
77 | :: List argumentTypes
78 | :: Symbol returnType
79 | :: List metadata
80 | :: body) ->
81 | let definition =
82 | { Metadata = Set.empty
83 | Visibility = Public // TODO: Determine method visibility
84 | Name = name
85 | ArgumentTypes = resolveTypes argumentTypes
86 | ReturnType = resolveType returnType
87 | Body = List.empty }
88 | definition
89 | |> addMetadata metadata
90 | |> addBody body
91 | |> Method
92 | | other -> failwithf "Unrecognized assembly unit definition: %A" other
93 |
94 | let private prepareTopLevel = function
95 | | List (Symbol ".assembly" :: Symbol name :: units) ->
96 | { Name = name
97 | Units = List.map processAssemblyUnit units }
98 | | other -> failwithf "Unknown top-level construct: %A" other
99 |
100 | /// Prepares the source file for assembling. Returns the intermediate
101 | /// representation of the source code.
102 | let prepare (fileName : string) (stream : Stream) : Assembly seq =
103 | let forms = Reader.parse fileName stream
104 | forms |> Seq.map prepareTopLevel
105 |
--------------------------------------------------------------------------------
/Naggum.Assembler/Program.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Assembler.Program
2 |
3 | open System
4 | open System.IO
5 | open System.Reflection
6 | open System.Reflection.Emit
7 |
8 | type private ReturnCode =
9 | | Success = 0
10 | | Error = 1
11 | | InvalidArguments = 2
12 |
13 | let private printUsage () =
14 | let version = Assembly.GetExecutingAssembly().GetName().Version
15 | printfn "Naggum Assembler %A" version
16 | printfn "Usage: Naggum.Assembler [one or more file names]"
17 |
18 | let private printError (error : Exception) =
19 | printfn "Error: %s" (error.ToString ())
20 |
21 | let private save (assembly : AssemblyBuilder) =
22 | let name = assembly.GetName().Name + ".exe" // TODO: See #45. ~ F
23 | assembly.Save name
24 | printfn "Assembly %s saved" name
25 |
26 | let private assemble fileName =
27 | use stream = File.OpenRead fileName
28 | let repr = Processor.prepare fileName stream
29 | let assemblies = Assembler.assembleAll AssemblyBuilderAccess.Save repr
30 | assemblies |> Seq.iter save
31 |
32 | let private nga =
33 | function
34 | | [| "--help" |] ->
35 | printUsage ()
36 | ReturnCode.Success
37 | | fileNames when fileNames.Length > 0 ->
38 | try
39 | fileNames |> Array.iter assemble
40 | ReturnCode.Success
41 | with
42 | | error ->
43 | printError error
44 | ReturnCode.Error
45 | | _ ->
46 | printUsage ()
47 | ReturnCode.InvalidArguments
48 |
49 | []
50 | let main args =
51 | let result = nga args
52 | int result
53 |
--------------------------------------------------------------------------------
/Naggum.Assembler/Representation.fs:
--------------------------------------------------------------------------------
1 | namespace Naggum.Assembler.Representation
2 |
3 | open System.Reflection
4 |
5 | type MetadataItem =
6 | | EntryPoint
7 |
8 | type Visibility =
9 | | Public
10 |
11 | type Type = System.Type
12 |
13 | type MethodSignature =
14 | { Assembly : Assembly option
15 | ContainingType : Type option
16 | Name : string
17 | ArgumentTypes : Type list
18 | ReturnType : Type }
19 |
20 | type SimpleInstruction =
21 | | Add
22 | | Div
23 | | Mul
24 | | Ret
25 | | Sub
26 |
27 | type Instruction =
28 | | Call of MethodSignature
29 | | Ldstr of string
30 | | LdcI4 of int
31 | | Simple of SimpleInstruction
32 |
33 | type MethodDefinition =
34 | { Metadata : Set
35 | Visibility : Visibility
36 | Name : string
37 | ArgumentTypes : Type list
38 | ReturnType : Type
39 | Body : Instruction list }
40 |
41 | type AssemblyUnit =
42 | | Method of MethodDefinition
43 |
44 | type Assembly =
45 | { Name : string
46 | Units : AssemblyUnit list }
47 | override this.ToString () = sprintf "%A" this
48 |
--------------------------------------------------------------------------------
/Naggum.Assembler/packages.config:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
--------------------------------------------------------------------------------
/Naggum.Backend/AssemblyInfo.fs:
--------------------------------------------------------------------------------
1 | namespace Naggum.Backend.AssemblyInfo
2 |
3 | open System.Reflection
4 | open System.Runtime.InteropServices
5 |
6 | []
7 | []
8 | []
9 | []
10 | []
11 | []
12 |
13 | ()
14 |
--------------------------------------------------------------------------------
/Naggum.Backend/Matchers.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Backend.Matchers
2 |
3 | let (|Symbol|Object|List|) = function
4 | | Reader.Atom (Reader.Object o) -> Object o
5 | | Reader.Atom (Reader.Symbol x) -> Symbol x
6 | | Reader.List l -> List l
7 |
8 | let (|Integer|_|) = function
9 | | Object (:? int as i) -> Some i
10 | | _ -> None
11 |
12 | let (|String|_|) = function
13 | | Object (:? string as s) -> Some s
14 | | _ -> None
15 |
--------------------------------------------------------------------------------
/Naggum.Backend/MaybeMonad.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Backend.MaybeMonad
2 |
3 | type MaybeMonad() =
4 |
5 | member __.Bind (m, f) =
6 | match m with
7 | | Some v -> f v
8 | | None -> None
9 |
10 | member __.Return v = Some v
11 |
12 | let maybe = MaybeMonad ()
13 |
--------------------------------------------------------------------------------
/Naggum.Backend/Naggum.Backend.fsproj:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | Debug
6 | AnyCPU
7 | 2.0
8 | 243738f3-d798-4b09-8797-f90b21414b60
9 | Library
10 | Naggum.Backend
11 | Naggum.Backend
12 | v4.6
13 | 4.4.0.0
14 | true
15 | Naggum.Backend
16 |
17 |
18 | true
19 | full
20 | false
21 | false
22 | bin\Debug\
23 | DEBUG;TRACE
24 | 3
25 | bin\Debug\Naggum.Backend.XML
26 |
27 |
28 | pdbonly
29 | true
30 | true
31 | bin\Release\
32 | TRACE
33 | 3
34 | bin\Release\Naggum.Backend.XML
35 |
36 |
37 | 11
38 |
39 |
40 |
41 |
42 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets
43 |
44 |
45 |
46 |
47 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets
48 |
49 |
50 |
51 |
52 |
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 | ..\packages\FParsec.1.0.2\lib\net40-client\FParsec.dll
62 | True
63 |
64 |
65 | ..\packages\FParsec.1.0.2\lib\net40-client\FParsecCS.dll
66 | True
67 |
68 |
69 | ..\packages\FSharp.Core.4.0.0.1\lib\net40\FSharp.Core.dll
70 | True
71 |
72 |
73 |
74 |
75 |
76 |
77 |
84 |
--------------------------------------------------------------------------------
/Naggum.Backend/Reader.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Backend.Reader
2 |
3 | open System
4 | open System.IO
5 | open FParsec
6 |
7 | type Value =
8 | | Object of obj
9 | | Symbol of string
10 |
11 | type SExp =
12 | | Atom of Value
13 | | List of SExp list
14 |
15 | let comment = (skipChar ';') .>> (skipRestOfLine true)
16 | let skipSpaceAndComments = skipMany (spaces1 <|> comment)
17 | let commented parser = skipSpaceAndComments >>. parser .>> skipSpaceAndComments
18 | let list, listRef = createParserForwardedToRef()
19 | let numberOptions =
20 | NumberLiteralOptions.AllowMinusSign ||| NumberLiteralOptions.AllowExponent ||| NumberLiteralOptions.AllowHexadecimal
21 | ||| NumberLiteralOptions.AllowFraction ||| NumberLiteralOptions.AllowSuffix
22 |
23 | let pnumber : Parser =
24 | let pliteral = numberLiteral numberOptions "number"
25 | fun stream ->
26 | let reply = pliteral stream
27 | if reply.Status = Ok then
28 | let result : NumberLiteral = reply.Result
29 | if result.IsInteger then
30 | if result.SuffixLength = 1 && result.SuffixChar1 = 'L' then
31 | Reply((int64 result.String) :> obj |> Object)
32 | else if not (result.SuffixLength = 1) then Reply((int32 result.String) :> obj |> Object)
33 | else Reply(ReplyStatus.Error, messageError <| sprintf "Unknown suffix: %A" result.SuffixChar1)
34 | else if result.SuffixLength = 1 && result.SuffixChar1 = 'f' then
35 | Reply((float result.String) :> obj |> Object)
36 | else if not (result.SuffixLength = 1) then Reply((single result.String) :> obj |> Object)
37 | else Reply(ReplyStatus.Error, messageError <| sprintf "Unknown suffix: %A" result.SuffixChar1)
38 | else Reply(reply.Status, reply.Error)
39 |
40 | let string =
41 | let normalChar = satisfy (fun c -> c <> '\"')
42 | between (pstring "\"") (pstring "\"") (manyChars normalChar) |>> (fun str -> str :> obj) |>> Object
43 |
44 | let symChars = (anyOf "+-*/=<>!?._") //chars that are valid in the symbol name
45 | let symbol = (many1Chars (letter <|> digit <|> symChars)) |>> Symbol
46 | let atom = (pnumber <|> string <|> symbol) |>> Atom
47 | let listElement = choice [ atom; list ]
48 | let sexp = commented (pchar '(') >>. many (commented listElement) .>> commented (pchar ')') |>> List
49 | let parser = many1 (choice [ atom; sexp ])
50 |
51 | do listRef := sexp
52 |
53 | let parse (sourceName : string) (source : Stream) =
54 | let form = runParserOnStream parser () sourceName source Text.Encoding.UTF8
55 | match form with
56 | | Success(result, _, _) -> result
57 | | Failure(errorMsg, _, _) -> failwithf "Failure: %s" errorMsg
58 |
--------------------------------------------------------------------------------
/Naggum.Backend/packages.config:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
--------------------------------------------------------------------------------
/Naggum.Compiler/App.config:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 |
26 |
--------------------------------------------------------------------------------
/Naggum.Compiler/AssemblyInfo.fs:
--------------------------------------------------------------------------------
1 | namespace Naggum.Compiler.AssemblyInfo
2 |
3 | open System.Reflection
4 | open System.Runtime.InteropServices
5 |
6 | []
7 | []
8 | []
9 | []
10 | []
11 | []
12 |
13 | ()
14 |
--------------------------------------------------------------------------------
/Naggum.Compiler/ClrGenerator.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.ClrGenerator
2 |
3 | open System
4 |
5 | open Naggum.Backend.MaybeMonad
6 | open Naggum.Backend.Reader
7 | open Naggum.Compiler.Context
8 | open Naggum.Compiler.IGenerator
9 |
10 | let nearestOverload (clrType : Type) methodName types =
11 | let rec distanceBetweenTypes (derivedType : Type, baseType) =
12 | match derivedType with
13 | | null -> None
14 | | someType
15 | when someType = baseType -> Some 0
16 | | _ ->
17 | maybe {
18 | let! distance = distanceBetweenTypes (derivedType.BaseType, baseType)
19 | return distance + 1
20 | }
21 | let distance (availableTypes : Type list) (methodTypes : Type list) =
22 | if availableTypes.Length <> methodTypes.Length then
23 | None
24 | else
25 | Seq.zip availableTypes methodTypes
26 | |> Seq.map distanceBetweenTypes
27 | |> Seq.fold (fun state option ->
28 | maybe {
29 | let! stateNum = state
30 | let! optionNum = option
31 | return stateNum + optionNum
32 | }) (Some 0)
33 | let methods = clrType.GetMethods() |> Seq.filter (fun clrMethod -> clrMethod.Name = methodName)
34 | let methodsAndDistances = methods
35 | |> Seq.map (fun clrMethod -> clrMethod,
36 | distance types (clrMethod.GetParameters()
37 | |> Array.map (fun parameter ->
38 | parameter.ParameterType)
39 | |> Array.toList))
40 | |> Seq.filter (snd >> Option.isSome)
41 | |> Seq.map (fun (clrMethod, distance) -> clrMethod, Option.get distance)
42 | |> Seq.toList
43 | if methodsAndDistances.IsEmpty then
44 | None
45 | else
46 | let minDistance = methodsAndDistances |> List.minBy snd |> snd
47 | let methods = methodsAndDistances |> List.filter (snd >> (fun d -> d = minDistance))
48 | |> List.map fst
49 | if methods.IsEmpty then
50 | None
51 | else
52 | Some (List.head methods)
53 |
54 | type ClrCallGenerator (context : Context,
55 | clrType : Type,
56 | methodName : string,
57 | arguments : SExp list,
58 | gf : IGeneratorFactory) =
59 | let args = gf.MakeSequence context arguments
60 | let arg_types = args.ReturnTypes()
61 | let clrMethod = nearestOverload clrType methodName arg_types
62 | interface IGenerator with
63 | member __.Generate il =
64 | args.Generate il
65 | il.Call (Option.get clrMethod)
66 |
67 | member this.ReturnTypes() =
68 | [(Option.get clrMethod).ReturnType]
69 |
70 | type InstanceCallGenerator (context : Context,
71 | instance : SExp,
72 | methodName : string,
73 | arguments : SExp list,
74 | gf : IGeneratorFactory) =
75 | interface IGenerator with
76 | member __.Generate il =
77 | let instGen = gf.MakeGenerator context instance
78 | let argsGen = gf.MakeSequence context arguments
79 | let methodInfo = nearestOverload (instGen.ReturnTypes() |> List.head) methodName (argsGen.ReturnTypes())
80 | if Option.isSome methodInfo then
81 | instGen.Generate il
82 | argsGen.Generate il
83 | il.Call (Option.get methodInfo)
84 | else failwithf "No overload found for method %A with types %A" methodName (argsGen.ReturnTypes())
85 |
86 | member this.ReturnTypes () =
87 | let inst_gen = gf.MakeGenerator context instance
88 | let args_gen = gf.MakeSequence context arguments
89 | let methodInfo = nearestOverload (inst_gen.ReturnTypes() |> List.head) methodName (args_gen.ReturnTypes())
90 | if Option.isSome methodInfo then
91 | [(Option.get methodInfo).ReturnType]
92 | else failwithf "No overload found for method %A with types %A" methodName (args_gen.ReturnTypes())
93 |
--------------------------------------------------------------------------------
/Naggum.Compiler/Context.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.Context
2 |
3 | open System
4 | open System.Collections.Generic
5 | open System.Reflection
6 | open System.Reflection.Emit
7 |
8 | open GrEmit
9 |
10 | open Naggum.Runtime
11 |
12 | type ContextValue =
13 | | Local of GroboIL.Local * Type
14 | | Field of FieldBuilder * Type
15 | | Arg of int * Type
16 |
17 | type Context =
18 | val types : Dictionary
19 | val functions : Dictionary MethodInfo)>
20 | val locals : Dictionary
21 | new (t,f,l) =
22 | {types = t; functions = f; locals = l}
23 | new (ctx : Context) =
24 | let t = new Dictionary(ctx.types)
25 | let f = new Dictionary MethodInfo)>(ctx.functions)
26 | let l = new Dictionary(ctx.locals)
27 | new Context (t,f,l)
28 | new() =
29 | let t = new Dictionary()
30 | let f = new Dictionary MethodInfo)>()
31 | let l = new Dictionary()
32 | new Context (t,f,l)
33 |
34 | member public this.loadAssembly(asm:Assembly) =
35 | let types = List.ofArray (asm.GetTypes())
36 | List.iter (fun (t:Type) -> this.types.Add(new Symbol(t.FullName),t)) types
37 |
38 | member public this.captureLocal(localName: Symbol, typeBuilder: TypeBuilder) =
39 | let local = this.locals.[localName]
40 | match local with
41 | | Local (_,t) ->
42 | let field = typeBuilder.DefineField(localName.Name,t,FieldAttributes.Static ||| FieldAttributes.Private)
43 | this.locals.[localName] <- Field (field, t)
44 | | Field (fb,_) -> ()
45 | | Arg (_,_) -> failwithf "Unable to capture parameter %A" localName.Name
46 |
47 | let create () =
48 | let context = new Context()
49 | context
50 |
--------------------------------------------------------------------------------
/Naggum.Compiler/FormGenerator.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.FormGenerator
2 |
3 | open System
4 | open System.Collections.Generic
5 | open System.Reflection
6 | open System.Reflection.Emit
7 |
8 | open GrEmit
9 |
10 | open Naggum.Backend
11 | open Naggum.Backend.Reader
12 | open Naggum.Backend.Matchers
13 | open Naggum.Runtime
14 | open Naggum.Compiler.Context
15 | open Naggum.Compiler.IGenerator
16 |
17 | type FormGenerator() =
18 | interface IGenerator with
19 | member this.Generate _ = failwith "Internal compiler error: unreified form generator invoked"
20 | member this.ReturnTypes () = failwithf "Internal compiler error: inferring return type of unreified form"
21 |
22 | type ValueGenerator(context:Context,value:Value) =
23 | inherit FormGenerator()
24 | interface IGenerator with
25 | member this.Generate _ = failwith "Internal compiler error: unreified value generator invoked"
26 | member this.ReturnTypes () = failwithf "Internal compiler error: inferring return type of unreified value"
27 |
28 | type SymbolGenerator(context:Context,name:string) =
29 | inherit ValueGenerator(context, Reader.Symbol name)
30 | interface IGenerator with
31 | member __.Generate il =
32 | try
33 | let ctxval = context.locals.[Symbol(name)]
34 | match ctxval with
35 | | Local (local, _) -> il.Ldloc local
36 | | Arg (index, _) -> il.Ldarg index
37 | with
38 | | :? KeyNotFoundException -> failwithf "Symbol %A not bound." name
39 |
40 | member this.ReturnTypes () =
41 | match context.locals.[new Symbol(name)] with
42 | |Local (_,t) -> [t]
43 | |Arg (_,t) -> [t]
44 |
45 | type SequenceGenerator (context : Context, seq : SExp list, gf : IGeneratorFactory) =
46 | let rec sequence (il : GroboIL) (seq : SExp list) =
47 | match seq with
48 | | [] ->
49 | ()
50 | | [last] ->
51 | let gen = gf.MakeGenerator context last
52 | gen.Generate il
53 | | sexp :: rest ->
54 | let gen = gf.MakeGenerator context sexp
55 | ignore (gen.Generate il)
56 | sequence il rest
57 |
58 | interface IGenerator with
59 | member __.Generate il = sequence il seq
60 | member this.ReturnTypes () =
61 | List.map (fun (sexp) -> List.head ((gf.MakeGenerator context sexp).ReturnTypes())) seq
62 |
63 | type BodyGenerator(context : Context,
64 | resultType : Type,
65 | body : SExp list,
66 | gf : IGeneratorFactory) =
67 | let rec genBody (il : GroboIL) (body : SExp list) =
68 | match body with
69 | | [] ->
70 | if resultType <> typeof then
71 | il.Ldnull ()
72 | | [last] ->
73 | let gen = gf.MakeGenerator context last
74 | let stackType = List.head <| gen.ReturnTypes ()
75 | gen.Generate il
76 | match (stackType, resultType) with
77 | | (s, r) when s = typeof && r = typeof -> ()
78 | | (s, r) when s = typeof && r <> typeof -> il.Ldnull ()
79 | | (s, r) when s <> typeof && r = typeof -> il.Pop ()
80 | | _ -> ()
81 | | sexp :: rest ->
82 | let gen = gf.MakeGenerator context sexp
83 | let val_type = gen.ReturnTypes()
84 | gen.Generate il
85 | if List.head val_type <> typeof then
86 | il.Pop ()
87 | genBody il rest
88 |
89 | interface IGenerator with
90 | member __.Generate ilGen =
91 | genBody ilGen body
92 | member __.ReturnTypes () =
93 | match body with
94 | | [] -> [typeof]
95 | | _ -> (gf.MakeGenerator context (List.last body)).ReturnTypes()
96 |
97 | type LetGenerator (context : Context,
98 | resultType : Type,
99 | bindings:SExp,
100 | body : SExp list,
101 | gf : IGeneratorFactory) =
102 | interface IGenerator with
103 | member __.Generate il =
104 | let scope_subctx = new Context (context)
105 | match bindings with
106 | | List list ->
107 | for binding in list do
108 | match binding with
109 | | List [Symbol name; form] ->
110 | let generator = gf.MakeGenerator scope_subctx form
111 | let local_type = List.head (generator.ReturnTypes())
112 | let local = il.DeclareLocal local_type
113 | scope_subctx.locals.[new Symbol(name)] <- Local (local, local_type)
114 | generator.Generate il
115 | il.Stloc local
116 | | other -> failwithf "In let bindings: Expected: (name (form))\nGot: %A\n" other
117 | | other -> failwithf "In let form: expected: list of bindings\nGot: %A" other
118 | let bodyGen = new BodyGenerator (scope_subctx, resultType, body, gf) :> IGenerator
119 | bodyGen.Generate il
120 |
121 | member this.ReturnTypes () =
122 | let type_subctx = new Context(context)
123 | match bindings with
124 | | List list ->
125 | for binding in list do
126 | match binding with
127 | | List [Symbol name; form] ->
128 | let generator = gf.MakeGenerator type_subctx form
129 | type_subctx.locals.[new Symbol(name)] <- Local (null,generator.ReturnTypes() |> List.head)
130 | | other -> failwithf "In let bindings: Expected: (name (form))\nGot: %A\n" other
131 | | other -> failwithf "In let form: expected: list of bindings\nGot: %A" other
132 | (gf.MakeBody type_subctx body).ReturnTypes()
133 |
134 | type ReducedIfGenerator (context : Context, condition : SExp, ifTrue : SExp, gf : IGeneratorFactory) =
135 | let returnTypes = (gf.MakeGenerator context ifTrue).ReturnTypes()
136 | interface IGenerator with
137 | member __.Generate il =
138 | let condGen = gf.MakeGenerator context condition
139 | let ifTrueGen = gf.MakeGenerator context ifTrue
140 | let ifTrueLbl = il.DefineLabel ("then", true)
141 | let endForm = il.DefineLabel ("endif", true)
142 | condGen.Generate il
143 | il.Brtrue ifTrueLbl
144 |
145 | if List.head returnTypes <> typeof
146 | then il.Ldnull ()
147 |
148 | il.Br endForm
149 | il.MarkLabel ifTrueLbl
150 | ifTrueGen.Generate il
151 | il.MarkLabel endForm
152 |
153 | member this.ReturnTypes () =
154 | returnTypes
155 |
156 | type FullIfGenerator (context : Context, condition : SExp, ifTrue : SExp, ifFalse : SExp, gf : IGeneratorFactory) =
157 | interface IGenerator with
158 | member __.Generate il =
159 | let condGen = gf.MakeGenerator context condition
160 | let ifTrueGen = gf.MakeGenerator context ifTrue
161 | let ifFalseGen = gf.MakeGenerator context ifFalse
162 | let ifTrueLbl = il.DefineLabel ("then", true)
163 | let endForm = il.DefineLabel ("endif", true)
164 | ignore (condGen.Generate il)
165 | il.Brtrue ifTrueLbl
166 | ifFalseGen.Generate il
167 | il.Br endForm
168 | il.MarkLabel ifTrueLbl
169 | ifTrueGen.Generate il
170 | il.MarkLabel endForm
171 |
172 | member this.ReturnTypes () =
173 | let true_ret_type = (gf.MakeGenerator context ifTrue).ReturnTypes()
174 | let false_ret_type = (gf.MakeGenerator context ifFalse).ReturnTypes()
175 | List.concat (Seq.ofList [true_ret_type; false_ret_type]) //TODO This should return closest common ancestor of these types
176 |
177 | type FunCallGenerator (context : Context, fname : string, arguments : SExp list, gf : IGeneratorFactory) =
178 | let args = gf.MakeSequence context arguments
179 | let func = context.functions.[new Symbol(fname)] <| args.ReturnTypes()
180 | interface IGenerator with
181 | member __.Generate il =
182 | args.Generate il
183 | il.Call func
184 |
185 | member this.ReturnTypes () =
186 | [func.ReturnType]
187 |
188 | type DefunGenerator (context : Context,
189 | typeBuilder : TypeBuilder,
190 | fname : string,
191 | parameters : SExp list,
192 | body : SExp list,
193 | gf : IGeneratorFactory) =
194 | let bodyGen argTypes =
195 | let methodGen = typeBuilder.DefineMethod(fname, MethodAttributes.Public ||| MethodAttributes.Static, typeof, (Array.ofList argTypes))
196 | use il = new GroboIL (methodGen)
197 | let fun_ctx = new Context(context)
198 | for parm in parameters do
199 | match parm with
200 | | Symbol paramName ->
201 | let parm_idx = (List.findIndex (fun (p) -> p = parm) parameters)
202 | fun_ctx.locals.[new Symbol(paramName)] <- Arg (parm_idx,argTypes. [parm_idx])
203 | | _ -> failwithf "In function %A parameter definition:\nExpected: Atom (Symbol)\nGot: %A" fname parm
204 | let methodFactory = gf.MakeGeneratorFactory typeBuilder methodGen
205 | let bodyGen = methodFactory.MakeBody fun_ctx body
206 | bodyGen.Generate il
207 | il.Ret ()
208 | methodGen :> MethodInfo
209 | do context.functions.[new Symbol(fname)] <- bodyGen
210 |
211 | interface IGenerator with
212 | member this.Generate ilGen =
213 | ()
214 | member this.ReturnTypes() =
215 | [typeof]
216 |
217 | type QuoteGenerator (context : Context, quotedExp : SExp, gf : IGeneratorFactory) =
218 | let generateObject (il : GroboIL) (o : obj) =
219 | let generator = gf.MakeGenerator context (Atom (Object o))
220 | generator.Generate il
221 |
222 | let generateSymbol (il : GroboIL) (name : string) =
223 | let cons = (typeof).GetConstructor [|typeof|]
224 | il.Ldstr name
225 | il.Newobj cons
226 |
227 | let rec generateList (il : GroboIL) (elements : SExp list) =
228 | let generateListElement e =
229 | match e with
230 | | List l -> generateList il l
231 | | Object o -> generateObject il o
232 | | Symbol s -> generateSymbol il s
233 | let cons = (typeof).GetConstructor(Array.create 2 typeof)
234 | List.last elements |> generateListElement
235 | il.Ldnull () //list terminator
236 | il.Newobj cons
237 | List.rev elements |> List.tail |> List.iter (fun (e) ->
238 | generateListElement e
239 | il.Newobj cons)
240 |
241 | interface IGenerator with
242 | member __.Generate il =
243 | match quotedExp with
244 | | List l -> generateList il l
245 | | Object o -> generateObject il o
246 | | Symbol s -> generateSymbol il s
247 | member this.ReturnTypes () =
248 | match quotedExp with
249 | | List _ -> [typeof]
250 | | Object _ -> [typeof]
251 | | Symbol _ -> [typeof]
252 |
253 | type NewObjGenerator (context : Context, typeName : string, arguments : SExp list, gf : IGeneratorFactory) =
254 | interface IGenerator with
255 | member __.Generate il =
256 | let argsGen = gf.MakeSequence context arguments
257 | let argTypes = argsGen.ReturnTypes()
258 | let objType =
259 | if typeName.StartsWith "System" then
260 | Type.GetType typeName
261 | else
262 | context.types.[new Symbol(typeName)]
263 | ignore <| argsGen.Generate il
264 | il.Newobj <| objType.GetConstructor(Array.ofList argTypes)
265 |
266 | member this.ReturnTypes () =
267 | if typeName.StartsWith "System" then
268 | [Type.GetType typeName]
269 | else
270 | [context.types.[new Symbol(typeName)]]
271 |
272 | type TypeGenerator(context : Context, typeBuilder : TypeBuilder, typeName : string, parentTypeName: string, members : SExp list, gf : IGeneratorFactory) =
273 | let newTypeBuilder =
274 | if parentTypeName = "" then
275 | Globals.ModuleBuilder.DefineType(typeName, TypeAttributes.Class ||| TypeAttributes.Public, typeof)
276 | else
277 | Globals.ModuleBuilder.DefineType(typeName, TypeAttributes.Class ||| TypeAttributes.Public, context.types.[new Symbol(parentTypeName)])
278 | let mutable fields : string list = []
279 |
280 | let generate_field field_name =
281 | let fieldBuilder = newTypeBuilder.DefineField(field_name,typeof,FieldAttributes.Public)
282 | fields <- List.append fields [field_name]
283 | let generateMethod method_name method_parms method_body =
284 | let methodGen = newTypeBuilder.DefineMethod(method_name,MethodAttributes.Public,
285 | typeof,
286 | Array.create (List.length method_parms) typeof)
287 | let context = new Context(context)
288 | for parm in method_parms do
289 | match parm with
290 | | Symbol paramName ->
291 | let parm_idx = (List.findIndex (fun (p) -> p = parm) method_parms)
292 | context.locals.[new Symbol(paramName)] <- Arg (parm_idx,typeof)
293 | | _ -> failwithf "In method %A%A parameter definition:\nExpected: Atom(Symbol)\nGot: %A" typeName method_name parm
294 | let newGeneratorFactory = gf.MakeGeneratorFactory newTypeBuilder methodGen
295 | let body_gen = newGeneratorFactory.MakeBody context method_body
296 | use il = new GroboIL (methodGen)
297 | body_gen.Generate il
298 | il.Ret ()
299 |
300 | interface IGenerator with
301 | member this.Generate ilGen =
302 | for m in members do
303 | match m with
304 | | List [Symbol "field"; Symbol name] -> generate_field name
305 | | List [Symbol "field"; Symbol access; Symbol name] -> generate_field name
306 | | List (Symbol "method" :: Symbol name :: List parms :: body) -> generateMethod name parms body
307 | | List (Symbol "method" :: Symbol name :: Symbol access :: List parms :: body) -> generateMethod name parms body
308 | | other -> failwithf "In definition of type %A: \nUnknown member definition: %A" typeName other
309 | member this.ReturnTypes () =
310 | [typeof]
311 |
--------------------------------------------------------------------------------
/Naggum.Compiler/Generator.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.Generator
2 |
3 | open System
4 | open System.IO
5 | open System.Reflection
6 | open System.Reflection.Emit
7 |
8 | open GrEmit
9 |
10 | open Naggum.Backend
11 | open Naggum.Backend.Reader
12 | open Naggum.Compiler.IGenerator
13 | open Naggum.Compiler.GeneratorFactory
14 |
15 | let compileMethod context (generatorFactory : IGeneratorFactory) body (methodBuilder : MethodBuilder) fileName =
16 | use il = new GroboIL (methodBuilder)
17 | try
18 | let gen = generatorFactory.MakeBody context body
19 | gen.Generate il
20 | with
21 | | ex -> printfn "File: %A\nForm: %A\nError: %A" fileName sexp ex.Source
22 |
23 | il.Ret ()
24 |
25 | let compile (source : Stream) (assemblyName : string) (filePath : string) (asmRefs:string list): unit =
26 | let assemblyName = AssemblyName assemblyName
27 | let path = Path.GetDirectoryName filePath
28 | let assemblyPath = if path = "" then null else path
29 | let fileName = Path.GetFileName filePath
30 | let appDomain = AppDomain.CurrentDomain
31 |
32 | let assemblyBuilder = appDomain.DefineDynamicAssembly (assemblyName, AssemblyBuilderAccess.Save, assemblyPath)
33 | Globals.ModuleBuilder <- assemblyBuilder.DefineDynamicModule(assemblyBuilder.GetName().Name, fileName)
34 | let typeBuilder = Globals.ModuleBuilder.DefineType("Program", TypeAttributes.Public ||| TypeAttributes.Class ||| TypeAttributes.BeforeFieldInit)
35 | let methodBuilder = typeBuilder.DefineMethod ("Main",
36 | MethodAttributes.Public ||| MethodAttributes.Static,
37 | typeof,
38 | [| |])
39 |
40 | let gf = new GeneratorFactory(typeBuilder, methodBuilder) :> IGeneratorFactory
41 | assemblyBuilder.SetEntryPoint methodBuilder
42 |
43 | let context = Context.create ()
44 |
45 | //loading language runtime
46 | let rta = Assembly.LoadFrom("Naggum.Runtime.dll")
47 | context.loadAssembly rta
48 |
49 | // Load .NET runtime and all referenced assemblies:
50 | context.loadAssembly <| Assembly.Load "mscorlib"
51 | List.iter context.loadAssembly (List.map Assembly.LoadFrom asmRefs)
52 |
53 | let body = Reader.parse fileName source
54 | compileMethod context gf body methodBuilder fileName
55 |
56 | typeBuilder.CreateType()
57 | |> ignore
58 |
59 | assemblyBuilder.Save fileName
60 |
--------------------------------------------------------------------------------
/Naggum.Compiler/GeneratorFactory.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.GeneratorFactory
2 |
3 | open System
4 | open System.Reflection.Emit
5 | open System.Text.RegularExpressions
6 |
7 | open Naggum.Backend
8 | open Naggum.Backend.MaybeMonad
9 | open Naggum.Backend.Reader
10 | open Naggum.Backend.Matchers
11 | open Naggum.Compiler.ClrGenerator
12 | open Naggum.Compiler.Context
13 | open Naggum.Compiler.FormGenerator
14 | open Naggum.Compiler.IGenerator
15 | open Naggum.Compiler.MathGenerator
16 | open Naggum.Compiler.NumberGen
17 | open Naggum.Compiler.StringGen
18 | open Naggum.Runtime
19 |
20 | type GeneratorFactory(typeBuilder : TypeBuilder,
21 | methodBuilder : MethodBuilder) =
22 | member private this.makeObjectGenerator(o:obj) =
23 | match o with
24 | | :? System.Int32 ->
25 | (new Int32Gen(o :?> System.Int32)) :> IGenerator
26 | | :? System.Int64 ->
27 | (new Int64Gen(o :?> System.Int64)) :> IGenerator
28 | | :? System.Single ->
29 | (new SingleGen(o :?> System.Single)) :> IGenerator
30 | | :? System.Double ->
31 | (new DoubleGen(o :?> System.Double)) :> IGenerator
32 | | :? System.String ->
33 | (new StringGen(o :?> System.String)) :> IGenerator
34 | | other -> failwithf "Not a basic value: %A\n" other
35 |
36 | member private this.makeValueGenerator (context: Context, value:Value) =
37 | match value with
38 | | Reader.Symbol name ->
39 | (new SymbolGenerator(context,name)) :> IGenerator
40 | | Reader.Object o -> this.makeObjectGenerator o
41 |
42 | member private this.MakeFormGenerator (context : Context, form : SExp list) : IGenerator =
43 | match form with
44 | | Symbol "defun" :: Symbol name :: List args :: body ->
45 | upcast new DefunGenerator (context, typeBuilder, name, args, body, this)
46 | | [Symbol "if"; condition; ifTrue; ifFalse] -> // full if form
47 | upcast new FullIfGenerator (context, condition, ifTrue, ifFalse, this)
48 | | [Symbol "if"; condition; ifTrue] -> // reduced if form
49 | upcast new ReducedIfGenerator (context, condition, ifTrue, this)
50 | | Symbol "let" :: bindings :: body -> // let form
51 | upcast new LetGenerator (context,
52 | typeof,
53 | bindings,
54 | body,
55 | this)
56 | | [Symbol "quote"; quotedExp] ->
57 | upcast new QuoteGenerator (context, quotedExp, this)
58 | | Symbol "new" :: Symbol typeName :: args ->
59 | upcast new NewObjGenerator(context, typeName, args, this)
60 | | Symbol "+" :: args ->
61 | upcast new ArithmeticGenerator (context, args, Add, this)
62 | | Symbol "-" :: args ->
63 | upcast new ArithmeticGenerator (context, args, Sub, this)
64 | | Symbol "*" :: args ->
65 | upcast new ArithmeticGenerator (context, args, Mul, this)
66 | | Symbol "/" :: args ->
67 | upcast new ArithmeticGenerator (context, args, Div, this)
68 | | Symbol "=" :: argA :: argB :: [] ->
69 | upcast new SimpleLogicGenerator (context, argA, argB, Ceq, this)
70 | | Symbol "<" :: argA :: argB :: [] ->
71 | upcast new SimpleLogicGenerator (context, argA, argB, Clt, this)
72 | | Symbol ">" :: argA :: argB :: [] ->
73 | upcast new SimpleLogicGenerator (context, argA, argB, Cgt, this)
74 | | Symbol "call" :: Symbol fname :: instance :: args ->
75 | upcast new InstanceCallGenerator (context, instance, fname, args, this)
76 | | Symbol fname :: args -> // generic funcall pattern
77 | let tryGetType typeName =
78 | try Some (context.types.[Symbol(typeName)]) with
79 | | _ ->
80 | try Some (Type.GetType typeName) with
81 | | _ -> None
82 |
83 | let callRegex = Regex(@"([\w\.]+)\.(\w+)", RegexOptions.Compiled)
84 | let callMatch = callRegex.Match fname
85 | let maybeClrType =
86 | maybe {
87 | let! typeName = if callMatch.Success then Some callMatch.Groups.[1].Value else None
88 | let! clrType = tryGetType typeName
89 | return clrType
90 | }
91 |
92 | if Option.isSome maybeClrType then
93 | let clrType = Option.get maybeClrType
94 | let methodName = callMatch.Groups.[2].Value
95 | upcast new ClrCallGenerator (context, clrType, methodName, args, this)
96 | else
97 | upcast new FunCallGenerator(context, fname, args, this)
98 | | _ -> failwithf "Form %A is not supported yet" list
99 |
100 | member private this.MakeSequenceGenerator (context: Context, seq : SExp list) =
101 | new SequenceGenerator (context, seq, (this :> IGeneratorFactory))
102 |
103 | member private this.MakeBodyGenerator (context : Context, body : SExp list) =
104 | new BodyGenerator (context, methodBuilder.ReturnType, body, this)
105 |
106 | interface IGeneratorFactory with
107 | member this.MakeGenerator context sexp =
108 | match sexp with
109 | | Atom value -> this.makeValueGenerator (context, value)
110 | | List form -> this.MakeFormGenerator (context,form)
111 |
112 | member this.MakeSequence context seq = this.MakeSequenceGenerator (context,seq) :> IGenerator
113 |
114 | member this.MakeBody context body = this.MakeBodyGenerator (context,body) :> IGenerator
115 |
116 | member this.MakeGeneratorFactory newTypeBuilder newMethodBuilder =
117 | new GeneratorFactory(newTypeBuilder,
118 | newMethodBuilder) :> IGeneratorFactory
119 |
--------------------------------------------------------------------------------
/Naggum.Compiler/Globals.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.Globals
2 |
3 | open System.Reflection.Emit
4 |
5 | let mutable ModuleBuilder:ModuleBuilder = null
--------------------------------------------------------------------------------
/Naggum.Compiler/IGenerator.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.IGenerator
2 |
3 | open System
4 | open System.Reflection.Emit
5 |
6 | open GrEmit
7 |
8 | open Naggum.Backend.Reader
9 | open Naggum.Compiler.Context
10 |
11 | //TODO: Add a method that returns generated values' types without actually emitting the code.
12 | type IGenerator =
13 | interface
14 | abstract ReturnTypes : unit -> Type list
15 | abstract Generate : GroboIL -> unit
16 | end
17 |
18 | type IGeneratorFactory =
19 | interface
20 | abstract MakeGenerator : Context -> SExp -> IGenerator
21 | abstract MakeSequence : Context -> SExp list -> IGenerator
22 | abstract MakeBody : Context -> SExp list -> IGenerator
23 | abstract MakeGeneratorFactory : TypeBuilder -> MethodBuilder -> IGeneratorFactory
24 | end
25 |
--------------------------------------------------------------------------------
/Naggum.Compiler/MathGenerator.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.MathGenerator
2 |
3 | open Naggum.Backend.Reader
4 | open Naggum.Compiler.Context
5 | open Naggum.Compiler.IGenerator
6 |
7 | type ArithmeticOperation =
8 | | Add
9 | | Div
10 | | Mul
11 | | Sub
12 |
13 | type LogicOperation =
14 | | Ceq
15 | | Cgt
16 | | Clt
17 |
18 | //TODO: Make this useful; i.e. determine eldest type in a numeric tower and convert all junior types to eldest
19 | let tower = dict [(typeof, 1); (typeof, 2); (typeof, 3); (typeof, 4); (typeof,5)]
20 |
21 | let maxType types =
22 | try
23 | let maxOrder = List.maxBy (fun (t) -> tower.[t]) types
24 | (Seq.find (fun (KeyValue(o,_)) -> o = maxOrder) tower).Key
25 | with
26 | | :? System.Collections.Generic.KeyNotFoundException -> failwithf "Some types of %A are not suitable in an arithmetic expression." types
27 |
28 | type ArithmeticGenerator (context : Context,
29 | args : SExp list,
30 | operation : ArithmeticOperation,
31 | gf : IGeneratorFactory) =
32 | interface IGenerator with
33 | member __.Generate il =
34 | // making this just for the sake of return types
35 | let maxType = (gf.MakeSequence context args).ReturnTypes() |> maxType
36 | // loading first arg manually so it won't be succeeded by operation opcode
37 | let argGen = gf.MakeGenerator context (List.head args)
38 | let argType = argGen.ReturnTypes() |> List.head
39 | argGen.Generate il
40 | if argType <> maxType then
41 | il.Newobj <| maxType.GetConstructor [|argType|]
42 | for arg in List.tail args do
43 | let argGen = gf.MakeGenerator context arg
44 | let argType = argGen.ReturnTypes() |> List.head
45 | argGen.Generate il
46 | match operation with
47 | | Add -> il.Add ()
48 | | Div -> il.Div false
49 | | Mul -> il.Mul ()
50 | | Sub -> il.Sub ()
51 |
52 | member this.ReturnTypes () =
53 | [List.map (fun (sexp) -> (gf.MakeGenerator context sexp).ReturnTypes() |> List.head) args |> maxType]
54 |
55 | type SimpleLogicGenerator (context : Context,
56 | argA : SExp,
57 | argB : SExp,
58 | operation : LogicOperation,
59 | gf : IGeneratorFactory) =
60 | interface IGenerator with
61 | member __.Generate il =
62 | let aGen = gf.MakeGenerator context argA
63 | let bGen = gf.MakeGenerator context argB
64 | aGen.Generate il |> ignore
65 | bGen.Generate il |> ignore
66 | match operation with
67 | | Ceq -> il.Ceq ()
68 | | Cgt -> il.Cgt false
69 | | Clt -> il.Clt false
70 |
71 | member this.ReturnTypes () =
72 | [typeof]
73 |
--------------------------------------------------------------------------------
/Naggum.Compiler/Naggum.Compiler.fsproj:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | Debug
5 | x86
6 | 8.0.30703
7 | 2.0
8 | {a4269c5e-e4ac-44bf-a06e-1b45248910ad}
9 | Exe
10 | ngc
11 | Naggum.Compiler
12 | v4.6.1
13 |
14 |
15 | Naggum.Compiler
16 |
17 |
18 | 4.4.0.0
19 | 11
20 |
21 |
22 | true
23 | full
24 | false
25 | false
26 | bin\Debug\
27 | DEBUG;TRACE
28 | 3
29 | AnyCPU
30 | bin\Debug\Naggum.Compiler.XML
31 | ..\..\..\tests\test.naggum
32 |
33 |
34 | pdbonly
35 | true
36 | true
37 | bin\Release\
38 | TRACE
39 | 3
40 | AnyCPU
41 | bin\Release\Naggum.Compiler.XML
42 |
43 |
44 |
45 |
46 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets
47 |
48 |
49 |
50 |
51 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets
52 |
53 |
54 |
55 |
56 |
57 |
58 | Always
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 |
72 |
73 |
74 |
75 |
76 | ..\packages\FParsec.1.0.2\lib\net40-client\FParsec.dll
77 | True
78 |
79 |
80 | ..\packages\FParsec.1.0.2\lib\net40-client\FParsecCS.dll
81 | True
82 |
83 |
84 | ..\packages\FSharp.Core.4.0.0.1\lib\net40\FSharp.Core.dll
85 | True
86 |
87 |
88 | ..\packages\GrEmit.2.1.7\lib\net40\GrEmit.dll
89 | True
90 |
91 |
92 |
93 |
94 |
95 |
96 | Naggum.Backend
97 | {243738f3-d798-4b09-8797-f90b21414b60}
98 | True
99 |
100 |
101 | Naggum.Runtime
102 | {402b5e79-e063-4833-ae4b-2986aeec1d75}
103 | True
104 |
105 |
106 |
113 |
--------------------------------------------------------------------------------
/Naggum.Compiler/NumberGen.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.NumberGen
2 |
3 | open IGenerator
4 | open System
5 |
6 | type NumberGen<'TNumber> (number: 'TNumber) =
7 | interface IGenerator with
8 | member this.Generate _ = failwith "Failure: Tried to generate unreified number constant.\n"
9 | member this.ReturnTypes () = [typeof<'TNumber>]
10 |
11 | type Int32Gen (number: Int32) =
12 | inherit NumberGen(number)
13 | interface IGenerator with
14 | member __.Generate il = il.Ldc_I4 number
15 |
16 | type Int64Gen (number: Int64) =
17 | inherit NumberGen(number)
18 | interface IGenerator with
19 | member __.Generate il = il.Ldc_I8 number
20 |
21 | type SingleGen (number: Single) =
22 | inherit NumberGen(number)
23 | interface IGenerator with
24 | member __.Generate il = il.Ldc_R4 number
25 |
26 | type DoubleGen (number: Double) =
27 | inherit NumberGen(number)
28 | interface IGenerator with
29 | member __.Generate il = il.Ldc_R8 number
30 |
--------------------------------------------------------------------------------
/Naggum.Compiler/Program.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.Program
2 |
3 | open System
4 | open System.IO
5 | open Naggum.Compiler.Generator
6 |
7 | let args = List.ofArray (Environment.GetCommandLineArgs())
8 | let mutable sources = []
9 | let mutable asmRefs = []
10 | for arg in (List.tail args) do
11 | if arg.StartsWith "/r:" then
12 | asmRefs <- arg.Replace("/r:","") :: asmRefs
13 | else
14 | sources <- arg :: sources
15 | for fileName in sources do
16 | let source = File.Open (fileName,FileMode.Open) :> Stream
17 | let assemblyName = Path.GetFileNameWithoutExtension fileName
18 | Generator.compile source assemblyName (assemblyName + ".exe") asmRefs
19 | source.Close()
20 |
--------------------------------------------------------------------------------
/Naggum.Compiler/StringGen.fs:
--------------------------------------------------------------------------------
1 | module Naggum.Compiler.StringGen
2 |
3 | open IGenerator
4 |
5 | type StringGen (str : string) =
6 | interface IGenerator with
7 | member __.Generate il =
8 | il.Ldstr str
9 | member this.ReturnTypes () =
10 | [typeof]
11 |
--------------------------------------------------------------------------------
/Naggum.Compiler/packages.config:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
--------------------------------------------------------------------------------
/Naggum.Interactive/Naggum.Interactive.csproj:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | Debug
5 | x86
6 | 8.0.30703
7 | 2.0
8 | {34E781DF-EAD9-4034-ADE4-8DA41A16644A}
9 | Exe
10 | Properties
11 | Naggum.Interactive
12 | Naggum.Interactive
13 | v4.6.1
14 |
15 |
16 | 512
17 |
18 |
19 | true
20 | bin\Debug\
21 | DEBUG;TRACE
22 | full
23 | AnyCPU
24 | ..\bin\ngi.exe.CodeAnalysisLog.xml
25 | true
26 | GlobalSuppressions.cs
27 | prompt
28 | MinimumRecommendedRules.ruleset
29 | ;C:\Program Files (x86)\Microsoft Visual Studio 10.0\Team Tools\Static Analysis Tools\\Rule Sets
30 | true
31 | ;C:\Program Files (x86)\Microsoft Visual Studio 10.0\Team Tools\Static Analysis Tools\FxCop\\Rules
32 | true
33 | false
34 | false
35 | bin\Debug\Naggum.Interactive.XML
36 |
37 |
38 | bin\Release\
39 | TRACE
40 | true
41 | pdbonly
42 | AnyCPU
43 | ..\bin\ngi.exe.CodeAnalysisLog.xml
44 | true
45 | GlobalSuppressions.cs
46 | prompt
47 | MinimumRecommendedRules.ruleset
48 | ;C:\Program Files (x86)\Microsoft Visual Studio 10.0\Team Tools\Static Analysis Tools\\Rule Sets
49 | true
50 | ;C:\Program Files (x86)\Microsoft Visual Studio 10.0\Team Tools\Static Analysis Tools\FxCop\\Rules
51 | true
52 | false
53 | false
54 | bin\Release\Naggum.Interactive.XML
55 |
56 |
57 |
58 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 | {402B5E79-E063-4833-AE4B-2986AEEC1D75}
72 | Naggum.Runtime
73 |
74 |
75 |
76 |
77 |
78 |
79 |
86 |
--------------------------------------------------------------------------------
/Naggum.Interactive/Program.cs:
--------------------------------------------------------------------------------
1 | using System;
2 | using System.IO;
3 | using Naggum.Runtime;
4 |
5 | namespace Naggum.Interactive
6 | {
7 | class Program
8 | {
9 | static void Main(string[] args)
10 | {
11 | Stream input = System.Console.OpenStandardInput();
12 | for (; ; )
13 | {
14 | System.Console.Out.Write(">");
15 | Object obj = Reader.Read(input);
16 | System.Console.Out.WriteLine(obj.ToString());
17 | }
18 | input.Close();
19 | }
20 | }
21 | }
22 |
--------------------------------------------------------------------------------
/Naggum.Interactive/Properties/AssemblyInfo.cs:
--------------------------------------------------------------------------------
1 | using System.Reflection;
2 | using System.Runtime.InteropServices;
3 |
4 | [assembly: AssemblyTitle("Naggum.Interactive")]
5 | [assembly: AssemblyProduct("Naggum")]
6 | [assembly: AssemblyCopyright("Copyright © Naggum authors 2013–2016")]
7 | [assembly: ComVisible(false)]
8 | [assembly: Guid("fe6d0e11-90e5-4715-9a40-878ecf803b52")]
9 | [assembly: AssemblyVersion("0.0.1.0")]
10 |
--------------------------------------------------------------------------------
/Naggum.Interactive/app.config:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
--------------------------------------------------------------------------------
/Naggum.Runtime/Cons.cs:
--------------------------------------------------------------------------------
1 | using System;
2 | using System.Text;
3 | using System.Collections;
4 |
5 | namespace Naggum.Runtime
6 | {
7 | ///
8 | /// Cons-cell and basic cons manipulation functions.
9 | ///
10 | public class Cons : IEquatable
11 | {
12 | public Object pCar { get; set; }
13 | public Object pCdr { get; set; }
14 |
15 | ///
16 | /// The real cons-cell constructor.
17 | ///
18 | /// CAR part of the new cell
19 | /// CDR part of the new cell
20 | public Cons(Object aCar, Object aCdr)
21 | {
22 | pCar = aCar;
23 | pCdr = aCdr;
24 | }
25 |
26 | ///
27 | ///
28 | /// Cons-cell
29 | /// CAR part of given cell
30 | public static Object Car(Cons aCons)
31 | {
32 | return aCons.pCar;
33 | }
34 | ///
35 | ///
36 | /// Cons-cell
37 | /// CDR part of given cell
38 | public static Object Cdr(Cons aCons)
39 | {
40 | return aCons.pCdr;
41 | }
42 |
43 | ///
44 | /// Checks if the cons-cell is a list
45 | ///
46 | /// Cons-cell
47 | /// True if CDR part of the cell is a list or is null.
48 | /// False otherwise.
49 | public static bool IsList(Cons aCons)
50 | {
51 | if (aCons == null) return true; //Empty list is still a list.
52 | if (aCons.pCdr == null) return true; //List with one element is a list;
53 | else if (aCons.pCdr.GetType() == typeof(Cons)) return IsList((Cons)aCons.pCdr);
54 | else return false; //If it's not null or not a list head, then it's definitely not a list.
55 | }
56 |
57 | ///
58 | /// Converts cons-cell to string representation.
59 | ///
60 | /// String representation of cons-cell.
61 | public override String ToString()
62 | {
63 | StringBuilder buffer = new StringBuilder("");
64 | buffer.Append("(");
65 | if (IsList(this))
66 | {
67 | for (Cons it = this; it != null; it = (Cons)it.pCdr)
68 | {
69 | buffer.Append(it.pCar.ToString());
70 | if (it.pCdr != null) buffer.Append(" ");
71 | }
72 | }
73 | else
74 | {
75 | buffer.Append(pCar.ToString()).Append(" . ").Append(pCdr.ToString());
76 | }
77 | buffer.Append(")");
78 | return buffer.ToString();
79 | }
80 |
81 | ///
82 | /// Checks cons cell for equality with other cell.
83 | ///
84 | /// Other cons cell
85 | /// True if other cell is equal to this; false otherwise.
86 | bool IEquatable.Equals(Cons other)
87 | {
88 | return pCar == other.pCar && pCdr == other.pCdr;
89 | }
90 |
91 | ///
92 | /// Constructs a list.
93 | ///
94 | /// Elements of a list.
95 | /// List with given elements.
96 | public static Cons List(params object[] elements)
97 | {
98 | Cons list = null;
99 | Array.Reverse(elements);
100 | foreach (var element in elements)
101 | {
102 | var tmp = new Cons(element, list);
103 | list = tmp;
104 | }
105 | return list;
106 | }
107 | }
108 | }
109 |
--------------------------------------------------------------------------------
/Naggum.Runtime/Naggum.Runtime.csproj:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | Debug
5 | AnyCPU
6 | 8.0.30703
7 | 2.0
8 | {402B5E79-E063-4833-AE4B-2986AEEC1D75}
9 | Library
10 | Properties
11 | Naggum.Runtime
12 | Naggum.Runtime
13 | v4.6.1
14 | 512
15 |
16 |
17 |
18 | true
19 | full
20 | false
21 | bin\Debug\
22 | DEBUG;TRACE
23 | prompt
24 | 4
25 | false
26 |
27 |
28 | pdbonly
29 | true
30 | bin\Release\
31 | TRACE
32 | prompt
33 | 4
34 | false
35 |
36 |
37 |
38 |
39 |
40 |
41 |
42 |
43 |
44 |
45 |
46 |
47 |
48 |
49 |
50 |
51 |
52 |
59 |
--------------------------------------------------------------------------------
/Naggum.Runtime/Properties/AssemblyInfo.cs:
--------------------------------------------------------------------------------
1 | using System.Reflection;
2 | using System.Runtime.InteropServices;
3 |
4 | [assembly: AssemblyTitle("Naggum.Runtime")]
5 | [assembly: AssemblyProduct("Naggum")]
6 | [assembly: AssemblyCopyright("Copyright © Naggum authors 2011–2016")]
7 | [assembly: ComVisible(false)]
8 | [assembly: Guid("4d6a7899-d5cd-4df7-8bab-dbc94b258e57")]
9 | [assembly: AssemblyVersion("0.0.1.0")]
10 |
--------------------------------------------------------------------------------
/Naggum.Runtime/Reader.cs:
--------------------------------------------------------------------------------
1 | using System;
2 | using System.IO;
3 | using System.Collections.Generic;
4 | using System.Linq;
5 | using System.Text;
6 |
7 | namespace Naggum.Runtime
8 | {
9 | public class Reader
10 | {
11 | ///
12 | /// Checks if the character is constituent, i.e. not whitespace or list separator.
13 | ///
14 | /// character to be checked
15 | /// true if the character is constituent, false otherwise
16 | public static bool isConstituent(char c)
17 | {
18 | return (!Char.IsWhiteSpace(c))
19 | && c != '('
20 | && c != ')';
21 | }
22 |
23 | ///
24 | /// Reads a symbol from a stream.
25 | ///
26 | /// stream to read from
27 | ///
28 | private static Object ReadSymbol(StreamReader reader)
29 | {
30 | bool in_symbol = true;
31 | StringBuilder symbol_name = new StringBuilder();
32 | while (in_symbol)
33 | {
34 | var ch = reader.Peek();
35 | if (ch < 0) throw new IOException("Unexpected end of stream.");
36 | if (isConstituent((char)ch))
37 | {
38 | symbol_name.Append((char)reader.Read());
39 | }
40 | else
41 | {
42 | in_symbol = false;
43 | }
44 | }
45 | if (symbol_name.Length > 0)
46 | return new Symbol(symbol_name.ToString());
47 | else
48 | throw new IOException("Empty symbol.");
49 | }
50 |
51 | ///
52 | /// Reads a list from input stream.
53 | ///
54 | /// stream to read from
55 | ///
56 | private static Object ReadList(StreamReader reader)
57 | {
58 | bool in_list = true;
59 | Stack