Commit | Line | Data |
---|---|---|
f6146aef JM |
1 | $ErrorActionPreference = "Stop" |
2 | ||
3 | Import-Module $PSScriptRoot/types.psm1 | |
4 | Import-Module $PSScriptRoot/reader.psm1 | |
5 | Import-Module $PSScriptRoot/printer.psm1 | |
6 | Import-Module $PSScriptRoot/env.psm1 | |
7 | Import-Module $PSScriptRoot/core.psm1 | |
8 | ||
9 | # READ | |
10 | function READ([String] $str) { | |
11 | return read_str($str) | |
12 | } | |
13 | ||
14 | # EVAL | |
fbfe6784 NB |
15 | function starts_with($lst, $sym) { |
16 | if ($lst.values.Count -ne 2) { return $false } | |
17 | $a0 = $lst.nth(0) | |
18 | return (symbol? $a0) -and ($a0.value -ceq $sym) | |
f6146aef | 19 | } |
fbfe6784 NB |
20 | function qq_loop($elt, $acc) { |
21 | if ((list? $elt) -and (starts_with $elt "splice-unquote")) { | |
22 | return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) | |
f6146aef | 23 | } else { |
fbfe6784 NB |
24 | return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) |
25 | } | |
26 | } | |
27 | function qq_foldr($xs) { | |
28 | $acc = new-list @() | |
29 | for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { | |
30 | $acc = qq_loop $xs[$i] $acc | |
31 | } | |
32 | return $acc | |
33 | } | |
34 | function quasiquote($ast) { | |
35 | if ($ast -eq $null) { return $ast } | |
36 | switch ($ast.GetType().Name) { | |
37 | "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } | |
38 | "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } | |
39 | "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } | |
40 | "List" { | |
41 | if (starts_with $ast "unquote") { | |
42 | return $ast.values[1] | |
43 | } else { | |
44 | return qq_foldr $ast.values | |
f6146aef JM |
45 | } |
46 | } | |
fbfe6784 | 47 | default { return $ast } |
f6146aef JM |
48 | } |
49 | } | |
50 | ||
51 | function eval_ast($ast, $env) { | |
52 | if ($ast -eq $null) { return $ast } | |
53 | switch ($ast.GetType().Name) { | |
54 | "Symbol" { return $env.get($ast) } | |
55 | "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } | |
56 | "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } | |
57 | "HashMap" { | |
58 | $hm = new-hashmap @() | |
59 | foreach ($k in $ast.values.Keys) { | |
60 | $hm.values[$k] = EVAL $ast.values[$k] $env | |
61 | } | |
62 | return $hm | |
63 | } | |
64 | default { return $ast } | |
65 | } | |
66 | } | |
67 | ||
68 | function EVAL($ast, $env) { | |
69 | while ($true) { | |
70 | #Write-Host "EVAL $(pr_str $ast)" | |
71 | if (-not (list? $ast)) { | |
72 | return (eval_ast $ast $env) | |
73 | } | |
74 | if (empty? $ast) { return $ast } | |
75 | ||
76 | $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) | |
77 | switch -casesensitive ($a0.value) { | |
78 | "def!" { | |
79 | return $env.set($a1, (EVAL $a2 $env)) | |
80 | } | |
81 | "let*" { | |
82 | $let_env = new-env $env | |
83 | for ($i=0; $i -lt $a1.values.Count; $i+=2) { | |
84 | $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) | |
85 | } | |
86 | $env = $let_env | |
87 | $ast = $a2 # TCO | |
88 | } | |
89 | "quote" { | |
90 | return $a1 | |
91 | } | |
fbfe6784 NB |
92 | "quasiquoteexpand" { |
93 | return (quasiquote $a1) | |
94 | } | |
f6146aef JM |
95 | "quasiquote" { |
96 | $ast = quasiquote $a1 | |
97 | } | |
98 | "do" { | |
99 | if ($ast.values.Count -gt 2) { | |
100 | $middle = new-list $ast.values[1..($ast.values.Count-2)] | |
101 | $_ = eval_ast $middle $env | |
102 | } | |
103 | $ast = $ast.last() # TCO | |
104 | } | |
105 | "if" { | |
106 | $cond = (EVAL $a1 $env) | |
107 | if ($cond -eq $null -or | |
108 | ($cond -is [Boolean] -and $cond -eq $false)) { | |
109 | $ast = $ast.nth(3) # TCO | |
110 | } else { | |
111 | $ast = $a2 # TCO | |
112 | } | |
113 | } | |
114 | "fn*" { | |
115 | # Save EVAL into a variable that will get closed over | |
116 | $feval = Get-Command EVAL | |
117 | $fn = { | |
118 | return (&$feval $a2 (new-env $env $a1.values $args)) | |
119 | }.GetNewClosure() | |
120 | return new-malfunc $a2 $a1.values $env $fn | |
121 | } | |
122 | default { | |
123 | $el = (eval_ast $ast $env) | |
124 | $f, $fargs = $el.first(), $el.rest().values | |
125 | if (malfunc? $f) { | |
126 | $env = (new-env $f.env $f.params $fargs) | |
127 | $ast = $f.ast # TCO | |
128 | } else { | |
129 | return &$f @fargs | |
130 | } | |
131 | } | |
132 | } | |
133 | } | |
134 | } | |
135 | ||
136 | ||
137 | function PRINT($exp) { | |
138 | return pr_str $exp $true | |
139 | } | |
140 | ||
141 | # REPL | |
142 | $repl_env = new-env | |
143 | ||
144 | function REP([String] $str) { | |
145 | return PRINT (EVAL (READ $str) $repl_env) | |
146 | } | |
147 | ||
148 | # core.EXT: defined using PowerShell | |
149 | foreach ($kv in $core_ns.GetEnumerator()) { | |
150 | $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) | |
151 | } | |
152 | $_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) | |
153 | $_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) | |
154 | ||
155 | # core.mal: defined using the language itself | |
156 | $_ = REP('(def! not (fn* (a) (if a false true)))') | |
e6d41de4 | 157 | $_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') |
f6146aef JM |
158 | |
159 | ||
160 | if ($args.Count -gt 0) { | |
161 | $_ = REP('(load-file "' + $args[0] + '")') | |
162 | exit 0 | |
163 | } | |
164 | ||
165 | while ($true) { | |
166 | Write-Host "user> " -NoNewline | |
167 | $line = [Console]::ReadLine() | |
168 | if ($line -eq $null) { | |
169 | break | |
170 | } | |
171 | try { | |
172 | Write-Host (REP($line)) | |
173 | } catch { | |
174 | Write-Host "Exception: $($_.Exception.Message)" | |
175 | } | |
176 | } |