mirror of
https://github.com/kanaka/mal.git
synced 2024-10-26 22:28:26 +03:00
033892777a
See issue #587. * Merge eval-ast and eval into a single conditional. * Expand macros during the apply phase, removing lots of duplicate tests, and increasing the overall consistency by allowing the macro to be computed instead of referenced by name (`((defmacro! cond (...)))` is currently illegal for example). * Print "EVAL: $ast" at the top of EVAL if DEBUG-EVAL exists in the MAL environment. * Remove macroexpand and quasiquoteexpand special forms. * Use pattern-matching style in process/step*.txt. Unresolved issues: c.2: unable to reproduce with gcc 11.12.0. elm: the directory is unchanged. groovy: sometimes fail, but not on each rebuild. nasm: fails some new soft tests, but the issue is unreproducible when running the interpreter manually. objpascal: unreproducible with fpc 3.2.2. ocaml: unreproducible with 4.11.1. perl6: unreproducible with rakudo 2021.09. Unrelated changes: Reduce diff betweens steps. Prevent defmacro! from mutating functions: c forth logo miniMAL vb. dart: fix recent errors and warnings ocaml: remove metadata from symbols. Improve the logo implementation. Encapsulate all representation in types.lg and env.lg, unwrap numbers. Replace some manual iterations with logo control structures. Reduce the diff between steps. Use native iteration in env_get and env_map Rewrite the reader with less temporary strings. Reduce the number of temporary lists (for example, reverse iteration with butlast requires O(n^2) allocations). It seems possible to remove a few exceptions: GC settings (Dockerfile), NO_SELF_HOSTING (IMPLS.yml) and step5_EXCLUDES (Makefile.impls) .
186 lines
4.7 KiB
Tcl
186 lines
4.7 KiB
Tcl
source mal_readline.tcl
|
|
source types.tcl
|
|
source reader.tcl
|
|
source printer.tcl
|
|
source env.tcl
|
|
source core.tcl
|
|
|
|
proc READ str {
|
|
read_str $str
|
|
}
|
|
|
|
proc EVAL {ast env} {
|
|
while {true} {
|
|
|
|
set dbgenv [$env find "DEBUG-EVAL"]
|
|
if {$dbgenv != 0} {
|
|
set dbgeval [$env get "DEBUG-EVAL"]
|
|
if {![false_q $dbgeval] && ![nil_q $dbgeval]} {
|
|
set img [PRINT $ast]
|
|
puts "EVAL: ${img}"
|
|
}
|
|
}
|
|
|
|
switch [obj_type $ast] {
|
|
"symbol" {
|
|
set varname [obj_val $ast]
|
|
return [$env get $varname]
|
|
}
|
|
"list" {
|
|
}
|
|
"vector" {
|
|
set res {}
|
|
foreach element [obj_val $ast] {
|
|
lappend res [EVAL $element $env]
|
|
}
|
|
return [vector_new $res]
|
|
}
|
|
"hashmap" {
|
|
set res [dict create]
|
|
dict for {k v} [obj_val $ast] {
|
|
dict set res $k [EVAL $v $env]
|
|
}
|
|
return [hashmap_new $res]
|
|
}
|
|
default { return $ast }
|
|
}
|
|
|
|
lassign [obj_val $ast] a0 a1 a2 a3
|
|
if {$a0 == ""} {
|
|
return $ast
|
|
}
|
|
switch [obj_val $a0] {
|
|
"def!" {
|
|
set varname [obj_val $a1]
|
|
set value [EVAL $a2 $env]
|
|
return [$env set $varname $value]
|
|
}
|
|
"let*" {
|
|
set letenv [Env new $env]
|
|
set bindings_list [obj_val $a1]
|
|
foreach {varnameobj varvalobj} $bindings_list {
|
|
$letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv]
|
|
}
|
|
set ast $a2
|
|
set env $letenv
|
|
# TCO: Continue loop
|
|
}
|
|
"do" {
|
|
foreach element [lrange [obj_val $ast] 1 end-1] {
|
|
EVAL $element $env
|
|
}
|
|
set ast [lindex [obj_val $ast] end]
|
|
# TCO: Continue loop
|
|
}
|
|
"if" {
|
|
set condval [EVAL $a1 $env]
|
|
if {[false_q $condval] || [nil_q $condval]} {
|
|
if {$a3 == ""} {
|
|
return $::mal_nil
|
|
}
|
|
set ast $a3
|
|
} else {
|
|
set ast $a2
|
|
}
|
|
# TCO: Continue loop
|
|
}
|
|
"fn*" {
|
|
set binds {}
|
|
foreach v [obj_val $a1] {
|
|
lappend binds [obj_val $v]
|
|
}
|
|
return [function_new $a2 $env $binds]
|
|
}
|
|
default {
|
|
set lst {}
|
|
foreach element [obj_val $ast] {
|
|
lappend lst [EVAL $element $env]
|
|
}
|
|
set f [lindex $lst 0]
|
|
set call_args [lrange $lst 1 end]
|
|
switch [obj_type $f] {
|
|
function {
|
|
set fn [obj_val $f]
|
|
set ast [dict get $fn body]
|
|
set env [Env new [dict get $fn env] [dict get $fn binds] $call_args]
|
|
# TCO: Continue loop
|
|
}
|
|
nativefunction {
|
|
set body [concat [list [obj_val $f]] {$a}]
|
|
set lambda [list {a} $body]
|
|
return [apply $lambda $call_args]
|
|
}
|
|
default {
|
|
error "Not a function"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc PRINT exp {
|
|
pr_str $exp 1
|
|
}
|
|
|
|
proc REP {str env} {
|
|
PRINT [EVAL [READ $str] $env]
|
|
}
|
|
|
|
proc RE {str env} {
|
|
EVAL [READ $str] $env
|
|
}
|
|
|
|
proc mal_eval {a} {
|
|
global repl_env
|
|
EVAL [lindex $a 0] $repl_env
|
|
}
|
|
|
|
set repl_env [Env new]
|
|
dict for {k v} $core_ns {
|
|
$repl_env set $k $v
|
|
}
|
|
|
|
$repl_env set "eval" [nativefunction_new mal_eval]
|
|
|
|
set argv_list {}
|
|
foreach arg [lrange $argv 1 end] {
|
|
lappend argv_list [string_new $arg]
|
|
}
|
|
$repl_env set "*ARGV*" [list_new $argv_list]
|
|
|
|
# core.mal: defined using the language itself
|
|
RE "(def! not (fn* (a) (if a false true)))" $repl_env
|
|
RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env
|
|
|
|
fconfigure stdout -translation binary
|
|
|
|
set DEBUG_MODE 0
|
|
if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
|
|
set DEBUG_MODE 1
|
|
}
|
|
|
|
if {$argc > 0} {
|
|
REP "(load-file \"[lindex $argv 0]\")" $repl_env
|
|
exit
|
|
}
|
|
|
|
# repl loop
|
|
while {true} {
|
|
set res [_readline "user> "]
|
|
if {[lindex $res 0] == "EOF"} {
|
|
break
|
|
}
|
|
set line [lindex $res 1]
|
|
if {$line == ""} {
|
|
continue
|
|
}
|
|
if { [catch { puts [REP $line $repl_env] } exception] } {
|
|
puts "Error: $exception"
|
|
if { $DEBUG_MODE } {
|
|
puts $::errorInfo
|
|
}
|
|
}
|
|
}
|
|
puts ""
|