├── README.md
├── Lispkit.sln
├── Lispkit.fsproj
└── Program.fs


/README.md:
--------------------------------------------------------------------------------
1 | # Lispkit
2 | 
3 | Lispkit Lisp running on an SECD machine (Peter Landin) in a hundred lines of F#; built while reading Peter Henderson's excellent "Functional Programming - Application and Implementation".
4 | 


--------------------------------------------------------------------------------
/Lispkit.sln:
--------------------------------------------------------------------------------
 1 | 
 2 | Microsoft Visual Studio Solution File, Format Version 12.00
 3 | # Visual Studio 15
 4 | VisualStudioVersion = 15.0.26228.9
 5 | MinimumVisualStudioVersion = 10.0.40219.1
 6 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Lispkit", "Lispkit.fsproj", "{588D20A4-79E8-4430-BD85-020144E9C730}"
 7 | EndProject
 8 | Global
 9 | 	GlobalSection(SolutionConfigurationPlatforms) = preSolution
10 | 		Debug|Any CPU = Debug|Any CPU
11 | 		Release|Any CPU = Release|Any CPU
12 | 	EndGlobalSection
13 | 	GlobalSection(ProjectConfigurationPlatforms) = postSolution
14 | 		{588D20A4-79E8-4430-BD85-020144E9C730}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
15 | 		{588D20A4-79E8-4430-BD85-020144E9C730}.Debug|Any CPU.Build.0 = Debug|Any CPU
16 | 		{588D20A4-79E8-4430-BD85-020144E9C730}.Release|Any CPU.ActiveCfg = Release|Any CPU
17 | 		{588D20A4-79E8-4430-BD85-020144E9C730}.Release|Any CPU.Build.0 = Release|Any CPU
18 | 	EndGlobalSection
19 | 	GlobalSection(SolutionProperties) = preSolution
20 | 		HideSolutionNode = FALSE
21 | 	EndGlobalSection
22 | EndGlobal
23 | 


--------------------------------------------------------------------------------
/Lispkit.fsproj:
--------------------------------------------------------------------------------
 1 | <?xml version="1.0" encoding="utf-8"?>
 2 | <Project ToolsVersion="15.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
 3 |   <Import Project="$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props" Condition="Exists('$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props')" />
 4 |   <PropertyGroup>
 5 |     <Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
 6 |     <Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
 7 |     <SchemaVersion>2.0</SchemaVersion>
 8 |     <ProjectGuid>588d20a4-79e8-4430-bd85-020144e9c730</ProjectGuid>
 9 |     <OutputType>Exe</OutputType>
10 |     <RootNamespace>Lispkit</RootNamespace>
11 |     <AssemblyName>Lispkit</AssemblyName>
12 |     <TargetFrameworkVersion>v4.5.2</TargetFrameworkVersion>
13 |     <AutoGenerateBindingRedirects>true</AutoGenerateBindingRedirects>
14 |     <TargetFSharpCoreVersion>4.4.1.0</TargetFSharpCoreVersion>
15 |     <Name>Lispkit</Name>
16 |   </PropertyGroup>
17 |   <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
18 |     <DebugSymbols>true</DebugSymbols>
19 |     <DebugType>full</DebugType>
20 |     <Optimize>false</Optimize>
21 |     <Tailcalls>false</Tailcalls>
22 |     <OutputPath>bin\$(Configuration)\</OutputPath>
23 |     <DefineConstants>DEBUG;TRACE</DefineConstants>
24 |     <WarningLevel>3</WarningLevel>
25 |     <PlatformTarget>AnyCPU</PlatformTarget>
26 |     <DocumentationFile>bin\$(Configuration)\$(AssemblyName).XML</DocumentationFile>
27 |     <Prefer32Bit>true</Prefer32Bit>
28 |   </PropertyGroup>
29 |   <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
30 |     <DebugType>pdbonly</DebugType>
31 |     <Optimize>true</Optimize>
32 |     <Tailcalls>true</Tailcalls>
33 |     <OutputPath>bin\$(Configuration)\</OutputPath>
34 |     <DefineConstants>TRACE</DefineConstants>
35 |     <WarningLevel>3</WarningLevel>
36 |     <PlatformTarget>AnyCPU</PlatformTarget>
37 |     <DocumentationFile>bin\$(Configuration)\$(AssemblyName).XML</DocumentationFile>
38 |     <Prefer32Bit>true</Prefer32Bit>
39 |   </PropertyGroup>
40 |   <PropertyGroup>
41 |     <MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
42 |   </PropertyGroup>
43 |   <Choose>
44 |     <When Condition="'$(VisualStudioVersion)' == '11.0'">
45 |       <PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets')">
46 |         <FSharpTargetsPath>$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets</FSharpTargetsPath>
47 |       </PropertyGroup>
48 |     </When>
49 |     <Otherwise>
50 |       <PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets')">
51 |         <FSharpTargetsPath>$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets</FSharpTargetsPath>
52 |       </PropertyGroup>
53 |     </Otherwise>
54 |   </Choose>
55 |   <Import Project="$(FSharpTargetsPath)" />
56 |   <ItemGroup>
57 |     <Compile Include="Program.fs" />
58 |   </ItemGroup>
59 |   <ItemGroup>
60 |     <Reference Include="mscorlib" />
61 |     <Reference Include="FSharp.Core">
62 |       <Name>FSharp.Core</Name>
63 |       <AssemblyName>FSharp.Core.dll</AssemblyName>
64 |       <HintPath>$(MSBuildProgramFiles32)\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\$(TargetFSharpCoreVersion)\FSharp.Core.dll</HintPath>
65 |     </Reference>
66 |     <Reference Include="System" />
67 |     <Reference Include="System.Core" />
68 |     <Reference Include="System.Numerics" />
69 |     <Reference Include="System.ValueTuple">
70 |       <HintPath>..\packages\System.ValueTuple.4.3.0\lib\netstandard1.0\System.ValueTuple.dll</HintPath>
71 |     </Reference>
72 |   </ItemGroup>
73 |   <!-- To modify your build process, add your task inside one of the targets below and uncomment it. 
74 |        Other similar extension points exist, see Microsoft.Common.targets.
75 |   <Target Name="BeforeBuild">
76 |   </Target>
77 |   <Target Name="AfterBuild">
78 |   </Target>
79 |   -->
80 | </Project>


--------------------------------------------------------------------------------
/Program.fs:
--------------------------------------------------------------------------------
  1 | open System
  2 | 
  3 | // tokenizer
  4 | 
  5 | type Token =
  6 |     | Symbolic of string
  7 |     | Numeric of string
  8 |     | Delimiter of char
  9 |     | End
 10 | 
 11 | let tokenize source =
 12 |     let rec skip = function ' ' :: cs -> skip cs | cs -> cs
 13 |     let toString = Seq.rev >> Seq.toArray >> String
 14 |     let rec number n = function c :: cs when Char.IsDigit c -> number (c :: n) cs | cs -> Numeric (toString n), cs
 15 |     let rec symbol s = function c :: cs when Char.IsLetter c || Char.IsDigit c -> symbol (c :: s) cs | cs -> Symbolic (toString s), cs
 16 |     let rec tokenize' tokens = function
 17 |         | c :: cs when c = '-' || Char.IsDigit c -> let (n, cs') = number [c] cs in tokenize' (n :: tokens) cs'
 18 |         | c :: cs when Char.IsLetter c -> let (s, cs') = symbol [c] cs in tokenize' (s :: tokens) cs'
 19 |         | c :: cs -> tokenize' (Delimiter c :: tokens) cs
 20 |         | [] -> (End :: tokens) |> Seq.rev
 21 |     source |> List.ofSeq |> skip |> tokenize' []
 22 | 
 23 | // parser
 24 | 
 25 | type Cell = { mutable Head: Expression; Tail: Expression } // this uglyness (record with `mutable Head`) is needed to allow in-place environment update
 26 | and Expression =
 27 |     | Sym of string
 28 |     | Num of int
 29 |     | Cons of Cell
 30 | let cons h t = Cons { Head = h; Tail = t }
 31 | let nil = Sym "NIL"
 32 | 
 33 | let parse tokens =
 34 |     let rec parse' = function
 35 |         | Numeric n :: t -> n |> int |> Num, t
 36 |         | Symbolic s :: t -> Sym s, t
 37 |         | Delimiter '(' :: t -> let lst, t' = parseList t in lst, t'
 38 |         | Delimiter d :: _ -> failwith "Unexpected character"
 39 |         | End :: t -> failwith "Expected token"
 40 |         | [] -> failwith "Expected single expression"
 41 |     and parseList tokens =
 42 |         let head, tokens' = parse' tokens
 43 |         match tokens' with
 44 |         | Delimiter '.' :: t ->
 45 |             match parse' t with
 46 |             | tail, (Delimiter ')' :: tokens'') -> cons head tail, tokens''
 47 |             | _ -> failwith "Unexpected expression following dotted pair"
 48 |         | Delimiter ')' :: t -> cons head nil, t
 49 |         | h :: t -> let lst, t' = parseList t in cons head lst, t'
 50 |         | [] -> failwith "Unexpected end of list expression"
 51 |     match tokens |> List.ofSeq |> parse' with
 52 |     | parsed, [End] -> parsed
 53 |     | _ -> failwith "Unexpected trailing tokens"
 54 | 
 55 | // pretty printer
 56 | 
 57 | let print expression =
 58 |     let rec print' i out comp exp =
 59 |         let j = i - 1 // TODO
 60 |         if i > 0 then
 61 |             match exp with
 62 |             | Sym s -> s :: out
 63 |             | Num n -> sprintf "%i" n :: out
 64 |             | Cons { Head = h; Tail = Cons c } ->
 65 |                 let p = print' j [] false h
 66 |                 let p' = print' j [] true (Cons c)
 67 |                 p' @ " " :: p @ [(if comp then "" else "(")] @ out
 68 |             | Cons { Head = h; Tail = Sym "NIL" } -> let p = print' j [] false h in (")" :: p @ [(if comp then "" else "(")] @ out)
 69 |             | Cons { Head = h; Tail = d } -> let p, p' = print' j [] false h, print' j [] false d in ")" :: p' @ ["."] @ p @ [(if comp then "" else "(")] @ out
 70 |         else "..." :: out
 71 |     print' 10000 [] false expression |> Seq.rev |> String.Concat
 72 | 
 73 | // SECD machine
 74 | 
 75 | let exec exp args =
 76 |     let rec exec' s e c d =
 77 |         // printfn "DEBUG: S=%s E=%s C=%s D=%s" (print s) (print e) (print c) (print d)
 78 |         let rec nth i = function Cons { Head = e'; Tail = e } -> (if i > 0 then nth (i - 1) e else e') | _ -> failwith "Invalid environment state"
 79 |         let rplaca e v = match e with Cons e' -> e'.Head <- v; Cons e' | _ -> failwith "Invalid environment" // note: this is the *only* mutation
 80 |         match (s, e, c, d) with 
 81 |         | s, e, Cons { Head = Num 1 (* LD *); Tail = Cons { Head = Cons { Head = Num n; Tail = Num m }; Tail = c }}, d -> exec' (cons (nth m (nth n e)) s) e c d
 82 |         | s, e, Cons { Head = Num 2 (* LDC *); Tail = Cons { Head = x; Tail = c }}, d -> exec' (cons x s) e c d
 83 |         | s, e, Cons { Head = Num 3 (* LDF *); Tail = Cons { Head = c'; Tail = c }}, d -> exec' (cons (cons c' e) s) e c d
 84 |         | Cons { Head = Cons { Head = c'; Tail = e' }; Tail = Cons { Head = v; Tail = s }}, e, Cons { Head = Num 4 (* AP *); Tail = c }, d -> exec' nil (cons v e') c' (cons s (cons e (cons c d)))
 85 |         | Cons { Head = r; Tail = Sym "NIL" }, _, Cons { Head = Num 5 (* RTN *); Tail = Sym "NIL" }, (Cons { Head = s; Tail = Cons { Head = e; Tail = Cons { Head = c; Tail = d }}}) -> exec' (cons r s) e c d
 86 |         | s, e, Cons { Head = Num 6 (* DUM *); Tail = c }, d -> exec' s (cons nil e) c d
 87 |         | (Cons { Head = Cons { Head = c'; Tail = e' }; Tail = Cons { Head = v; Tail = s }}), (Cons { Head = Sym "NIL"; Tail = e }), Cons { Head = Num 7 (* RAP *); Tail = c }, d -> exec' nil (rplaca e' v) c' (cons s (cons e (cons c d)))
 88 |         | Cons { Head = x; Tail = s }, e, Cons { Head = Num 8 (* SEL *); Tail = Cons { Head = t; Tail = Cons { Head = f; Tail = c }}}, d -> exec' s e (if x = Sym "T" then t else f) (cons c d)
 89 |         | s, e, Cons { Head = Num 9 (* JOIN *); Tail = Sym "NIL" }, (Cons { Head = c; Tail = d }) -> exec' s e c d
 90 |         | Cons { Head = Cons { Head = x; Tail = _ }; Tail = s }, e, Cons { Head = Num 10 (* CAR *); Tail = c }, d -> exec' (cons x s) e c d
 91 |         | Cons { Head = Cons { Head = _; Tail = x }; Tail = s }, e, Cons { Head = Num 11 (* CDR *); Tail = c }, d -> exec' (cons x s) e c d
 92 |         | Cons { Head = x; Tail = s }, e, Cons { Head = Num 12 (* ATOM *); Tail = c }, d -> exec' (cons (Sym (match x with Sym _ | Num _ -> "T" | _ -> "F")) s) e c d
 93 |         | Cons { Head = h; Tail = Cons { Head = t; Tail = s }}, e, Cons { Head = Num 13 (* CONS *); Tail = c }, d -> exec' (cons (cons h t) s) e c d
 94 |         | Cons { Head = x; Tail = Cons { Head = y; Tail = s }}, e, Cons { Head = Num 14 (* EQ *); Tail = c }, d -> exec' (cons (Sym (if y = x then "T" else "F")) s) e c d
 95 |         | Cons { Head = Num x; Tail = Cons { Head = Num y; Tail = s }}, e, Cons { Head = Num 15 (* ADD *); Tail = c }, d -> exec' (cons (Num (y + x)) s) e c d
 96 |         | Cons { Head = Num x; Tail = Cons { Head = Num y; Tail = s }}, e, Cons { Head = Num 16 (* SUB *); Tail = c }, d -> exec' (cons (Num (y - x)) s) e c d
 97 |         | Cons { Head = Num x; Tail = Cons { Head = Num y; Tail = s }}, e, Cons { Head = Num 17 (* MUL *); Tail = c }, d -> exec' (cons (Num (y * x)) s) e c d
 98 |         | Cons { Head = Num x; Tail = Cons { Head = Num y; Tail = s }}, e, Cons { Head = Num 18 (* DIV *); Tail = c }, d -> exec' (cons (Num (y / x)) s) e c d
 99 |         | Cons { Head = Num x; Tail = Cons { Head = Num y; Tail = s }}, e, Cons { Head = Num 19 (* REM *); Tail = c }, d -> exec' (cons (Num (y % x)) s) e c d
100 |         | Cons { Head = Num x; Tail = Cons { Head = Num y; Tail = s }}, e, Cons { Head = Num 20 (* LEQ *); Tail = c }, d -> exec' (cons (Sym (if y <= x then "T" else "F")) s) e c d
101 |         | Cons { Head = r; Tail = _ }, _, Cons { Head = Num 21 (* STOP *); Tail = Sym "NIL" }, _ -> r
102 |         | _ -> failwith "Invalid machine state"
103 |     exec' (Cons { Head = args; Tail = nil }) nil exp nil
104 | 
105 | let run exp args = exec (exp |> tokenize |> parse) (args |> tokenize |> parse)
106 | 
107 | // tests
108 | 
109 | let testParse source =
110 |     let tokens = tokenize source
111 |     let expression = parse tokens
112 |     let printed = print expression
113 |     if printed <> source then 
114 |         printfn "!!!PARSER TEST FAILURE!!!\nSOURCE: %s\nTOKENS: %A\nEXPRESSION: %A\nPRINTED: %s\n" source (List.ofSeq tokens) expression printed
115 | 
116 | testParse "123"
117 | testParse "FOO"
118 | testParse "(42)"
119 | testParse "(A.B)"
120 | testParse "(A BAY 73)"
121 | testParse "(A (B C) D)"
122 | testParse "(A (D E F) (B.C) 123)"
123 | testParse "(A (B.C) (D E F) 123)"
124 | 
125 | let testExec exp args expected =
126 |     let result = run exp args |> print
127 |     if result <> expected then printfn "!!!SECD MACHINE TEST FAILURE!!!\nPROGRAM: %s\nARGUMENTS: %s\nEXPECTED: %s\nRESULT: %s" exp args expected result
128 | 
129 | testExec "(2 123 21)" "42" "123" // LDC
130 | testExec "(10 21)" "(7 42 123)" "7" // CAR
131 | testExec "(11 21)" "(7 42 123)" "(42 123)" // CDR
132 | testExec "(12 21)" "7" "T" // ATOM
133 | testExec "(12 21)" "FOO" "T" // ATOM
134 | testExec "(12 21)" "(FOO BAR)" "F" // ATOM
135 | testExec "(2 123 2 7 13 21)" "42" "(7.123)" // CONS
136 | testExec "(2 123 2 7 14 21)" "42" "F" // EQ
137 | testExec "(2 7 2 7 14 21)" "42" "T" // EQ
138 | testExec "(2 FOO 2 BAR 14 21)" "42" "F" // EQ
139 | testExec "(2 FOO 2 FOO 14 21)" "42" "T" // EQ
140 | testExec "(2 123 2 7 15 21)" "42" "130" // ADD
141 | testExec "(2 123 2 7 16 21)" "42" "116" // SUB
142 | testExec "(2 123 2 7 17 21)" "42" "861" // MUL
143 | testExec "(2 123 2 7 18 21)" "42" "17" // DIV
144 | testExec "(2 123 2 7 19 21)" "42" "4" // REM
145 | testExec "(2 123 2 7 20 21)" "42" "F" // LEQ
146 | testExec "(2 7 2 123 20 21)" "42" "T" // LEQ
147 | testExec "(2 7 2 7 20 21)" "42" "T" // LEQ
148 | testExec "(21)" "(B C)" "(B C)" // (STOP)
149 | testExec "(2 A 21)" "42" "A" // (LDC A STOP)
150 | testExec "(2 A 12 21)" "42" "T" // (LDC A ATOM STOP)
151 | testExec "(2 (A) 12 21)" "42" "F" // (LDC (A) ATOM STOP)
152 | testExec "(2 (A) 10 21)" "42" "A" // (LDC (A) CAR STOP)
153 | testExec "(2 A 2 B 13 21)" "42" "(B.A)" // (LDC A LDC B CONS STOP)
154 | testExec "(2 A 2 B 14 21)" "42" "F" // (LDC A LDC B EQ STOP)
155 | testExec "(2 A 2 A 14 21)" "42" "T" // (LDC A LDC A EQ STOP)
156 | testExec "(2 T 8 (2 A 21) (2 B 21))" "42" "A" // (LDC T SEL (LDC A STOP) (LDC B STOP))
157 | testExec "(2 F 8 (2 A 21) (2 B 21))" "42" "B" // (LDC F SEL (LDC A STOP) (LDC B STOP))
158 | testExec "(2 T 8 (2 A 9) (2 B 9) 21)" "42" "A" // (LDC T SEL (LDC A JOIN) (LDC B JOIN) STOP)
159 | testExec "(2 F 8 (2 A 9) (2 B 9) 21)" "42" "B" // (LDC F SEL (LDC A JOIN) (LDC B JOIN) STOP)
160 | testExec "(3 (2 A) 21)" "((B C))" "((2 A))" // (LDF (LDC A) STOP)
161 | testExec "(3 (2 A 21) 4)" "((B C))" "A" // (LDF (LDC A STOP) AP)
162 | testExec "(3 (2 A 5) 4 21)" "((B C))" "A" // (LDF (LDC A RTN) AP STOP)
163 | testExec "(3 (1 (0.0) 21) 4 21)" "((B C))" "(B C)" // (LDF (LD (0.0) RTN) AP STOP)
164 | testExec "(3 (1 (0.1) 21) 4 21)" "((B C) (D E))" "(D E)" // (LDF (LD (0.1) RTN) AP STOP)
165 | testExec "(3 (6 1 (1.0) 21) 4 21)" "((B C))" "(B C)" // (LDF (DUM LD (1.0) RTN) AP STOP)
166 | testExec "(3 (6 1 (1.1) 21) 4 21)" "((B C) (D E))" "(D E)" // (LDF (DUM LD (1.1) RTN) AP STOP)
167 | testExec "(6 3 (1 (0.0) 21) 7)" "((B C))" "(B C)" // (DUM LDF (LD (0.0) STOP) RAP)
168 | 
169 | // from appendix of Functional Programming - Application and Implementation, Peter Henderson 
170 | let compilerSource = "(LETREC COMPILE (COMPILE LAMBDA (E) (COMP E (QUOTE NIL) (QUOTE (4 21)))) (COMP LAMBDA (E N C) (IF (ATOM E) (CONS (QUOTE 1) (CONS (LOCATION E N) C)) (IF (EQ (CAR E) (QUOTE QUOTE)) (CONS (QUOTE 2) (CONS (CAR (CDR E)) C)) (IF (EQ (CAR E) (QUOTE ADD)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 15) C))) (IF (EQ (CAR E) (QUOTE SUB)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 16) C))) (IF (EQ (CAR E) (QUOTE MUL)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 17) C))) (IF (EQ (CAR E) (QUOTE DIV)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 18) C))) (IF (EQ (CAR E) (QUOTE REM)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 19) C))) (IF (EQ (CAR E) (QUOTE LEQ)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 20) C))) (IF (EQ (CAR E) (QUOTE EQ)) (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 14) C))) (IF (EQ (CAR E) (QUOTE CAR)) (COMP (CAR (CDR E)) N (CONS (QUOTE 10) C)) (IF (EQ (CAR E) (QUOTE CDR)) (COMP (CAR (CDR E)) N (CONS (QUOTE 11) C)) (IF (EQ (CAR E) (QUOTE ATOM)) (COMP (CAR (CDR E)) N (CONS (QUOTE 12) C)) (IF (EQ (CAR E) (QUOTE CONS)) (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 13) C))) (IF (EQ (CAR E) (QUOTE IF)) (LET (COMP (CAR (CDR E)) N (CONS (QUOTE 8) (CONS THENPT (CONS ELSEPT C)))) (THENPT COMP (CAR (CDR (CDR E))) N (QUOTE (9))) (ELSEPT COMP (CAR (CDR (CDR (CDR E)))) N (QUOTE (9)))) (IF (EQ (CAR E) (QUOTE LAMBDA)) (LET (CONS (QUOTE 3) (CONS BODY C)) (BODY COMP (CAR (CDR (CDR E))) (CONS (CAR (CDR E)) N) (QUOTE (5)))) (IF (EQ (CAR E) (QUOTE LET)) (LET (LET (COMPLIS ARGS N (CONS (QUOTE 3) (CONS BODY (CONS (QUOTE 4) C)))) (BODY COMP (CAR (CDR E)) M (QUOTE (5)))) (M CONS (VARS (CDR (CDR E))) N) (ARGS EXPRS (CDR (CDR E)))) (IF (EQ (CAR E) (QUOTE LETREC)) (LET (LET (CONS (QUOTE 6) (COMPLIS ARGS M (CONS (QUOTE 3) (CONS BODY (CONS (QUOTE 7) C))))) (BODY COMP (CAR (CDR E)) M (QUOTE (5)))) (M CONS (VARS (CDR (CDR E))) N) (ARGS EXPRS (CDR (CDR E)))) (COMPLIS (CDR E) N (COMP (CAR E) N (CONS (QUOTE 4) C))))))))))))))))))))) (COMPLIS LAMBDA (E N C) (IF (EQ E (QUOTE NIL)) (CONS (QUOTE 2) (CONS (QUOTE NIL) C)) (COMPLIS (CDR E) N (COMP (CAR E) N (CONS (QUOTE 13) C))))) (LOCATION LAMBDA (E N) (LETREC (IF (MEMBER E (CAR N)) (CONS (QUOTE 0) (POSN E (CAR N))) (INCAR (LOCATION E (CDR N)))) (MEMBER LAMBDA (E N) (IF (EQ N (QUOTE NIL)) (QUOTE F) (IF (EQ E (CAR N)) (QUOTE T) (MEMBER E (CDR N))))) (POSN LAMBDA (E N) (IF (EQ E (CAR N)) (QUOTE 0) (ADD (QUOTE 1) (POSN E (CDR N))))) (INCAR LAMBDA (L) (CONS (ADD (QUOTE 1) (CAR L)) (CDR L))))) (VARS LAMBDA (D) (IF (EQ D (QUOTE NIL)) (QUOTE NIL) (CONS (CAR (CAR D)) (VARS (CDR D))))) (EXPRS LAMBDA (D) (IF (EQ D (QUOTE NIL)) (QUOTE NIL) (CONS (CDR (CAR D)) (EXPRS (CDR D))))))"
171 | let compilerCode = "(6 2 NIL 3 (1 (0.0) 2 NIL 14 8 (2 NIL 9) (2 NIL 1 (0.0) 11 13 1 (1.5) 4 1 (0.0) 10 11 13 9) 5) 13 3 (1 (0.0) 2 NIL 14 8 (2 NIL 9) (2 NIL 1 (0.0) 11 13 1 (1.4) 4 1 (0.0) 10 10 13 9) 5) 13 3 (6 2 NIL 3 (1 (0.0) 11 2 1 1 (0.0) 10 15 13 5) 13 3 (1 (0.0) 1 (0.1) 10 14 8 (2 0 9) (2 1 2 NIL 1 (0.1) 11 13 1 (0.0) 13 1 (1.1) 4 15 9) 5) 13 3 (1 (0.1) 2 NIL 14 8 (2 F 9) (1 (0.0) 1 (0.1) 10 14 8 (2 T 9) (2 NIL 1 (0.1) 11 13 1 (0.0) 13 1 (1.0) 4 9) 9) 5) 13 3 (2 NIL 1 (1.1) 10 13 1 (1.0) 13 1 (0.0) 4 8 (2 NIL 1 (1.1) 10 13 1 (1.0) 13 1 (0.1) 4 2 0 13 9) (2 NIL 2 NIL 1 (1.1) 11 13 1 (1.0) 13 1 (2.3) 4 13 1 (0.2) 4 9) 5) 7 5) 13 3 (1 (0.0) 2 NIL 14 8 (1 (0.2) 2 NIL 13 2 2 13 9) (2 NIL 2 NIL 1 (0.2) 2 13 13 13 1 (0.1) 13 1 (0.0) 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 13 1 (1.2) 4 9) 5) 13 3 (1 (0.0) 12 8 (1 (0.2) 2 NIL 1 (0.1) 13 1 (0.0) 13 1 (1.3) 4 13 2 1 13 9) (1 (0.0) 10 2 QUOTE 14 8 (1 (0.2) 1 (0.0) 11 10 13 2 2 13 9) (1 (0.0) 10 2 ADD 14 8 (2 NIL 2 NIL 1 (0.2) 2 15 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 SUB 14 8 (2 NIL 2 NIL 1 (0.2) 2 16 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 MUL 14 8 (2 NIL 2 NIL 1 (0.2) 2 17 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 DIV 14 8 (2 NIL 2 NIL 1 (0.2) 2 18 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 REM 14 8 (2 NIL 2 NIL 1 (0.2) 2 19 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 LEQ 14 8 (2 NIL 2 NIL 1 (0.2) 2 20 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 EQ 14 8 (2 NIL 2 NIL 1 (0.2) 2 14 13 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 CAR 14 8 (2 NIL 1 (0.2) 2 10 13 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 CDR 14 8 (2 NIL 1 (0.2) 2 11 13 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 ATOM 14 8 (2 NIL 1 (0.2) 2 12 13 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 CONS 14 8 (2 NIL 2 NIL 1 (0.2) 2 13 13 13 1 (0.1) 13 1 (0.0) 11 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 9) (1 (0.0) 10 2 IF 14 8 (2 NIL 2 NIL 2 (9) 13 1 (0.1) 13 1 (0.0) 11 11 11 10 13 1 (1.1) 4 13 2 NIL 2 (9) 13 1 (0.1) 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 3 (2 NIL 1 (1.2) 1 (0.1) 13 1 (0.0) 13 2 8 13 13 1 (1.1) 13 1 (1.0) 11 10 13 1 (2.1) 4 5) 4 9) (1 (0.0) 10 2 LAMBDA 14 8 (2 NIL 2 NIL 2 (5) 13 1 (0.1) 1 (0.0) 11 10 13 13 1 (0.0) 11 11 10 13 1 (1.1) 4 13 3 (1 (1.2) 1 (0.0) 13 2 3 13 5) 4 9) (1 (0.0) 10 2 LET 14 8 (2 NIL 2 NIL 1 (0.0) 11 11 13 1 (1.5) 4 13 1 (0.1) 2 NIL 1 (0.0) 11 11 13 1 (1.4) 4 13 13 3 (2 NIL 2 NIL 2 (5) 13 1 (0.0) 13 1 (1.0) 11 10 13 1 (2.1) 4 13 3 (2 NIL 1 (2.2) 2 4 13 1 (0.0) 13 2 3 13 13 1 (2.1) 13 1 (1.1) 13 1 (3.2) 4 5) 4 5) 4 9) (1 (0.0) 10 2 LETREC 14 8 (2 NIL 2 NIL 1 (0.0) 11 11 13 1 (1.5) 4 13 1 (0.1) 2 NIL 1 (0.0) 11 11 13 1 (1.4) 4 13 13 3 (2 NIL 2 NIL 2 (5) 13 1 (0.0) 13 1 (1.0) 11 10 13 1 (2.1) 4 13 3 (2 NIL 1 (2.2) 2 7 13 1 (0.0) 13 2 3 13 13 1 (1.0) 13 1 (1.1) 13 1 (3.2) 4 2 6 13 5) 4 5) 4 9) (2 NIL 2 NIL 1 (0.2) 2 4 13 13 1 (0.1) 13 1 (0.0) 10 13 1 (1.1) 4 13 1 (0.1) 13 1 (0.0) 11 13 1 (1.2) 4 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 9) 5) 13 3 (2 NIL 2 (4 21) 13 2 NIL 13 1 (0.0) 13 1 (1.1) 4 5) 13 3 (1 (0.0) 5) 7 4 21)"
172 | 
173 | let compile source = sprintf "(%s)" source |> run compilerCode
174 | 
175 | let testCompiler source expected = 
176 |     let result = compile source |> print
177 |     if result <> expected then printfn "!!!COMPILER ERROR!!!\nEXPECTED: %s\nRESULT: %s" expected result
178 | 
179 | testCompiler "(QUOTE A)" "(2 A 4 21)" // (LDC A AP STOP)
180 | testCompiler "(CAR (QUOTE A))" "(2 A 10 4 21)" // (LDC A CAR AP STOP)
181 | testCompiler "(CDR (QUOTE A))" "(2 A 11 4 21)" // (LDC A CDR AP STOP)
182 | testCompiler "(ATOM (QUOTE A))" "(2 A 12 4 21)" // (LDC A ATOM AP STOP)
183 | testCompiler "(CONS (QUOTE A) (QUOTE B))" "(2 B 2 A 13 4 21)" // (LDC B LDC A CONS AP STOP)
184 | testCompiler "(ADD (QUOTE A) (QUOTE B))" "(2 A 2 B 15 4 21)" // (LDC A LDC B ADD AP STOP)
185 | testCompiler "(SUB (QUOTE A) (QUOTE B))" "(2 A 2 B 16 4 21)" // (LDC A LDC B SUB AP STOP)
186 | testCompiler "(MUL (QUOTE A) (QUOTE B))" "(2 A 2 B 17 4 21)" // (LDC A LDC B MUL AP STOP)
187 | testCompiler "(DIV (QUOTE A) (QUOTE B))" "(2 A 2 B 18 4 21)" // (LDC A LDC B DIV AP STOP)
188 | testCompiler "(REM (QUOTE A) (QUOTE B))" "(2 A 2 B 19 4 21)" // (LDC A LDC B REM AP STOP)
189 | testCompiler "(EQ (QUOTE A) (QUOTE B))" "(2 A 2 B 14 4 21)" // (LDC A LDC B EQ AP STOP)
190 | testCompiler "(LEQ (QUOTE A) (QUOTE B))" "(2 A 2 B 20 4 21)" // (LDC A LDC B LEQ AP STOP)
191 | testCompiler "(LAMBDA (X) (QUOTE A))" "(3 (2 A 5) 4 21)" // (LDF (LDC A RTN) AP STOP)
192 | testCompiler "(LAMBDA (X) X)" "(3 (1 (0.0) 5) 4 21)" // (LDF (LD (0.0) RTN) AP STOP)
193 | testCompiler "(LAMBDA (X Y) Y)" "(3 (1 (0.1) 5) 4 21)" // (LDF (LD (0.1) RTN) AP STOP)
194 | testCompiler "((LAMBDA (X) X) (QUOTE A))" "(2 NIL 2 A 13 3 (1 (0.0) 5) 4 4 21)" // (LDC NIL LDC A CONS LDF (LD (0.0) RTN) AP AP STOP)
195 | testCompiler "(LET X (X QUOTE A))" "(2 NIL 2 A 13 3 (1 (0.0) 5) 4 4 21)" // (LDC NIL LDC A CONS LDF (LD (0.0) RTN) AP AP STOP)
196 | testCompiler "(LETREC X (X QUOTE A))" "(6 2 NIL 2 A 13 3 (1 (0.0) 5) 7 4 21)" // (DUM LDC NIL LDC A CONS LDF (LD (0.0) RTN) RAP AP STOP)
197 | testCompiler "(IF (QUOTE A) (QUOTE B) (QUOTE C))" "(2 A 8 (2 B 9) (2 C 9) 4 21)" // (LDC A SEL (LDC B JOIN) (LDC C JOIN) AP STOP)
198 | 
199 | // ultimate test, compile the compiler - metecircularity baby!
200 | testCompiler compilerSource compilerCode
201 | 
202 | // REPL
203 | 
204 | let rec repl output = 
205 |     printf "%s\n> " output 
206 |     try exec (Console.ReadLine() |> compile) (tokenize "((42))" |> parse) |> print |> repl 
207 |     with ex -> repl ex.Message
208 | 
209 | repl "Welcome to Lispkit Lisp\n\nExample: (LETREC TEST (TEST LAMBDA (X) (CONS (QUOTE HELLO) (QUOTE WORLD))))\n"


--------------------------------------------------------------------------------