mirror of
https://github.com/kanaka/mal.git
synced 2024-09-11 13:55:55 +03:00
Tcl implementation
This commit is contained in:
Dov Murik
parent
595376919b
commit
54d9903c0c
4
Makefile
4
Makefile
@ -18,7 +18,7 @@ mal_TEST_OPTS = --start-timeout 60 --test-timeout 120
|
||||
|
||||
IMPLS = awk bash c clojure coffee cpp crystal cs erlang elixir es6 factor forth fsharp go groovy \
|
||||
guile haskell java julia js kotlin lua make mal ocaml matlab miniMAL nim \
|
||||
perl php ps python r racket rpython ruby rust scala swift vb vimscript
|
||||
perl php ps python r racket rpython ruby rust scala swift tcl vb vimscript
|
||||
|
||||
step0 = step0_repl
|
||||
step1 = step1_read_print
|
||||
@ -101,6 +101,7 @@ ruby_STEP_TO_PROG = ruby/$($(1)).rb
|
||||
rust_STEP_TO_PROG = rust/target/release/$($(1))
|
||||
scala_STEP_TO_PROG = scala/$($(1)).scala
|
||||
swift_STEP_TO_PROG = swift/$($(1))
|
||||
tcl_STEP_TO_PROG = tcl/$($(1)).tcl
|
||||
vb_STEP_TO_PROG = vb/$($(1)).exe
|
||||
vimscript_STEP_TO_PROG = vimscript/$($(1)).vim
|
||||
guile_STEP_TO_PROG = guile/$($(1)).scm
|
||||
@ -151,6 +152,7 @@ ruby_RUNSTEP = ruby ../$(2) $(3)
|
||||
rust_RUNSTEP = ../$(2) $(3)
|
||||
scala_RUNSTEP = sbt 'run-main $($(1))$(if $(3), $(3),)'
|
||||
swift_RUNSTEP = ../$(2) $(3)
|
||||
tcl_RUNSTEP = tclsh ../$(2) $(3)
|
||||
vb_RUNSTEP = mono ../$(2) --raw $(3)
|
||||
vimscript_RUNSTEP = ./run_vimscript.sh ../$(2) $(3)
|
||||
# needs TERM=dumb to work with readline
|
||||
|
||||
15
README.md
15
README.md
@ -6,7 +6,7 @@
|
||||
|
||||
Mal is a Clojure inspired Lisp interpreter.
|
||||
|
||||
Mal is implemented in 42 different languages:
|
||||
Mal is implemented in 43 different languages:
|
||||
|
||||
* GNU awk
|
||||
* Bash shell
|
||||
@ -48,6 +48,7 @@ Mal is implemented in 42 different languages:
|
||||
* Rust
|
||||
* Scala
|
||||
* Swift
|
||||
* Tcl
|
||||
* Vimscript
|
||||
* Visual Basic.NET
|
||||
|
||||
@ -534,6 +535,18 @@ make
|
||||
./stepX_YYY
|
||||
```
|
||||
|
||||
### Tcl 8.6
|
||||
|
||||
*The Tcl implementation was created by [Dov Murik](https://github.com/dubek)*
|
||||
|
||||
The Tcl implementation of mal requires Tcl 8.6 to run. For readline line
|
||||
editing support, install tclreadline.
|
||||
|
||||
```
|
||||
cd tcl
|
||||
tclsh ./stepX_YYY.tcl
|
||||
```
|
||||
|
||||
### Vimscript
|
||||
|
||||
*The Vimscript implementation was created by [Dov Murik](https://github.com/dubek)*
|
||||
|
||||
24
tcl/Dockerfile
Normal file
24
tcl/Dockerfile
Normal file
@ -0,0 +1,24 @@
|
||||
FROM ubuntu:vivid
|
||||
MAINTAINER Joel Martin <github@martintribe.org>
|
||||
|
||||
##########################################################
|
||||
# General requirements for testing or common across many
|
||||
# implementations
|
||||
##########################################################
|
||||
|
||||
RUN apt-get -y update
|
||||
|
||||
# Required for running tests
|
||||
RUN apt-get -y install make python
|
||||
|
||||
# Some typical implementation and test requirements
|
||||
RUN apt-get -y install curl libreadline-dev libedit-dev
|
||||
|
||||
RUN mkdir -p /mal
|
||||
WORKDIR /mal
|
||||
|
||||
##########################################################
|
||||
# Specific implementation requirements
|
||||
##########################################################
|
||||
|
||||
RUN apt-get -y install tcl tcl-tclreadline
|
||||
12
tcl/Makefile
Normal file
12
tcl/Makefile
Normal file
@ -0,0 +1,12 @@
|
||||
SOURCES_BASE = mal_readline.tcl types.tcl reader.tcl printer.tcl
|
||||
SOURCES_LISP = env.tcl core.tcl stepA_mal.tcl
|
||||
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
|
||||
|
||||
.PHONY: stats stats-lisp
|
||||
|
||||
stats: $(SOURCES)
|
||||
@wc $^
|
||||
@printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
|
||||
stats-lisp: $(SOURCES_LISP)
|
||||
@wc $^
|
||||
@printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*\"|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
|
||||
404
tcl/core.tcl
Normal file
404
tcl/core.tcl
Normal file
@ -0,0 +1,404 @@
|
||||
proc mal_equal {a} {
|
||||
bool_new [equal_q [lindex $a 0] [lindex $a 1]]
|
||||
}
|
||||
|
||||
set ::mal_exception_obj 0
|
||||
proc mal_throw {a} {
|
||||
set ::mal_exception_obj [lindex $a 0]
|
||||
error "__MalException__"
|
||||
}
|
||||
|
||||
proc mal_nil_q {a} {
|
||||
bool_new [nil_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_true_q {a} {
|
||||
bool_new [true_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_false_q {a} {
|
||||
bool_new [false_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_symbol {a} {
|
||||
symbol_new [obj_val [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_symbol_q {a} {
|
||||
bool_new [symbol_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_keyword {a} {
|
||||
keyword_new [obj_val [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_keyword_q {a} {
|
||||
bool_new [keyword_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc render_array {arr readable delim} {
|
||||
set res {}
|
||||
foreach e $arr {
|
||||
lappend res [pr_str $e $readable]
|
||||
}
|
||||
join $res $delim
|
||||
}
|
||||
|
||||
proc mal_pr_str {a} {
|
||||
string_new [render_array $a 1 " "]
|
||||
}
|
||||
|
||||
proc mal_str {a} {
|
||||
string_new [render_array $a 0 ""]
|
||||
}
|
||||
|
||||
proc mal_prn {a} {
|
||||
puts [render_array $a 1 " "]
|
||||
return $::mal_nil
|
||||
}
|
||||
|
||||
proc mal_println {a} {
|
||||
puts [render_array $a 0 " "]
|
||||
return $::mal_nil
|
||||
}
|
||||
|
||||
proc mal_read_string {a} {
|
||||
read_str [obj_val [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_readline {a} {
|
||||
set prompt [obj_val [lindex $a 0]]
|
||||
set res [_readline $prompt]
|
||||
if {[lindex $res 0] == "EOF"} {
|
||||
return $::mal_nil
|
||||
}
|
||||
string_new [lindex $res 1]
|
||||
}
|
||||
|
||||
proc mal_slurp {a} {
|
||||
set filename [obj_val [lindex $a 0]]
|
||||
set file [open $filename]
|
||||
set content [read $file]
|
||||
close $file
|
||||
string_new $content
|
||||
}
|
||||
|
||||
proc mal_lt {a} {
|
||||
bool_new [expr {[obj_val [lindex $a 0]] < [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_lte {a} {
|
||||
bool_new [expr {[obj_val [lindex $a 0]] <= [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_gt {a} {
|
||||
bool_new [expr {[obj_val [lindex $a 0]] > [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_gte {a} {
|
||||
bool_new [expr {[obj_val [lindex $a 0]] >= [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_add {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_sub {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_mul {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_div {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_time_ms {a} {
|
||||
integer_new [clock milliseconds]
|
||||
}
|
||||
|
||||
proc mal_list {a} {
|
||||
list_new $a
|
||||
}
|
||||
|
||||
proc mal_list_q {a} {
|
||||
bool_new [list_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_vector {a} {
|
||||
vector_new $a
|
||||
}
|
||||
|
||||
proc mal_vector_q {a} {
|
||||
bool_new [vector_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_hash_map {a} {
|
||||
set d [dict create]
|
||||
foreach {k v} $a {
|
||||
dict set d [obj_val $k] $v
|
||||
}
|
||||
hashmap_new $d
|
||||
}
|
||||
|
||||
proc mal_map_q {a} {
|
||||
bool_new [hashmap_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_assoc {a} {
|
||||
set d [dict create]
|
||||
dict for {k v} [obj_val [lindex $a 0]] {
|
||||
dict set d $k $v
|
||||
}
|
||||
foreach {k v} [lrange $a 1 end] {
|
||||
dict set d [obj_val $k] $v
|
||||
}
|
||||
hashmap_new $d
|
||||
}
|
||||
|
||||
proc mal_dissoc {a} {
|
||||
set d [dict create]
|
||||
dict for {k v} [obj_val [lindex $a 0]] {
|
||||
dict set d $k $v
|
||||
}
|
||||
foreach k [lrange $a 1 end] {
|
||||
dict unset d [obj_val $k]
|
||||
}
|
||||
hashmap_new $d
|
||||
}
|
||||
|
||||
proc mal_get {a} {
|
||||
lassign $a hashmap_obj key_obj
|
||||
if {[dict exists [obj_val $hashmap_obj] [obj_val $key_obj]]} {
|
||||
dict get [obj_val $hashmap_obj] [obj_val $key_obj]
|
||||
} else {
|
||||
return $::mal_nil
|
||||
}
|
||||
}
|
||||
|
||||
proc mal_contains_q {a} {
|
||||
lassign $a hashmap_obj key_obj
|
||||
bool_new [dict exists [obj_val $hashmap_obj] [obj_val $key_obj]]
|
||||
}
|
||||
|
||||
proc mal_keys {a} {
|
||||
set res {}
|
||||
foreach k [dict keys [obj_val [lindex $a 0]]] {
|
||||
lappend res [string_new $k]
|
||||
}
|
||||
list_new $res
|
||||
}
|
||||
|
||||
proc mal_vals {a} {
|
||||
list_new [dict values [obj_val [lindex $a 0]]]
|
||||
}
|
||||
|
||||
proc mal_sequential_q {a} {
|
||||
bool_new [sequential_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_cons {a} {
|
||||
lassign $a head lst
|
||||
list_new [concat [list $head] [obj_val $lst]]
|
||||
}
|
||||
|
||||
proc mal_concat {a} {
|
||||
set res {}
|
||||
foreach lst $a {
|
||||
if {[nil_q $lst]} {
|
||||
continue
|
||||
}
|
||||
set res [concat $res [obj_val $lst]]
|
||||
}
|
||||
list_new $res
|
||||
}
|
||||
|
||||
proc mal_nth {a} {
|
||||
lassign $a lst_obj index_obj
|
||||
set index [obj_val $index_obj]
|
||||
set lst [obj_val $lst_obj]
|
||||
if {$index >= [llength $lst]} {
|
||||
error "nth: index out of range"
|
||||
}
|
||||
lindex $lst $index
|
||||
}
|
||||
|
||||
proc mal_first {a} {
|
||||
lassign $a lst
|
||||
if {[nil_q $lst] || [llength [obj_val $lst]] == 0} {
|
||||
return $::mal_nil
|
||||
}
|
||||
lindex [obj_val $lst] 0
|
||||
}
|
||||
|
||||
proc mal_rest {a} {
|
||||
lassign $a lst
|
||||
list_new [lrange [obj_val $lst] 1 end]
|
||||
}
|
||||
|
||||
proc mal_empty_q {a} {
|
||||
bool_new [expr {[llength [obj_val [lindex $a 0]]] == 0}]
|
||||
}
|
||||
|
||||
proc mal_count {a} {
|
||||
integer_new [llength [obj_val [lindex $a 0]]]
|
||||
}
|
||||
|
||||
proc mal_apply {a} {
|
||||
set f [lindex $a 0]
|
||||
if {[llength $a] > 1} {
|
||||
set mid_args [lrange $a 1 end-1]
|
||||
set last_list [lindex $a end]
|
||||
set apply_args [concat $mid_args [obj_val $last_list]]
|
||||
} else {
|
||||
set apply_args {}
|
||||
}
|
||||
|
||||
switch [obj_type $f] {
|
||||
function {
|
||||
set funcdict [obj_val $f]
|
||||
set body [dict get $funcdict body]
|
||||
set env [dict get $funcdict env]
|
||||
set binds [dict get $funcdict binds]
|
||||
set funcenv [Env new $env $binds $apply_args]
|
||||
return [EVAL $body $funcenv]
|
||||
}
|
||||
nativefunction {
|
||||
set body [concat [list [obj_val $f]] {$a}]
|
||||
set lambda [list {a} $body]
|
||||
return [apply $lambda $apply_args]
|
||||
}
|
||||
default {
|
||||
error "Not a function"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc mal_map {a} {
|
||||
lassign $a f seq
|
||||
set res {}
|
||||
foreach item [obj_val $seq] {
|
||||
set mappeditem [mal_apply [list $f [list_new [list $item]]]]
|
||||
lappend res $mappeditem
|
||||
}
|
||||
list_new $res
|
||||
}
|
||||
|
||||
proc mal_conj {a} {
|
||||
lassign $a a0
|
||||
if {[list_q $a0]} {
|
||||
set lst $a0
|
||||
foreach item [lrange $a 1 end] {
|
||||
set lst [mal_cons [list $item $lst]]
|
||||
}
|
||||
return $lst
|
||||
} elseif {[vector_q $a0]} {
|
||||
set res [obj_val $a0]
|
||||
foreach item [lrange $a 1 end] {
|
||||
lappend res $item
|
||||
}
|
||||
vector_new $res
|
||||
} else {
|
||||
error "conj requires list or vector"
|
||||
}
|
||||
}
|
||||
|
||||
proc mal_meta {a} {
|
||||
obj_meta [lindex $a 0]
|
||||
}
|
||||
|
||||
proc mal_with_meta {a} {
|
||||
lassign $a a0 a1
|
||||
obj_new [obj_type $a0] [obj_val $a0] $a1
|
||||
}
|
||||
|
||||
proc mal_atom {a} {
|
||||
atom_new [lindex $a 0]
|
||||
}
|
||||
|
||||
proc mal_atom_q {a} {
|
||||
bool_new [atom_q [lindex $a 0]]
|
||||
}
|
||||
|
||||
proc mal_deref {a} {
|
||||
obj_val [lindex $a 0]
|
||||
}
|
||||
|
||||
proc mal_reset_bang {a} {
|
||||
lassign $a a0 a1
|
||||
obj_set_val $a0 $a1
|
||||
}
|
||||
|
||||
proc mal_swap_bang {a} {
|
||||
lassign $a a0 f
|
||||
set apply_args [concat [list [obj_val $a0]] [lrange $a 2 end]]
|
||||
set newval [mal_apply [list $f [list_new $apply_args]]]
|
||||
mal_reset_bang [list $a0 $newval]
|
||||
}
|
||||
|
||||
set core_ns [dict create \
|
||||
"=" [nativefunction_new mal_equal] \
|
||||
"throw" [nativefunction_new mal_throw] \
|
||||
\
|
||||
"nil?" [nativefunction_new mal_nil_q] \
|
||||
"true?" [nativefunction_new mal_true_q] \
|
||||
"false?" [nativefunction_new mal_false_q] \
|
||||
"symbol" [nativefunction_new mal_symbol] \
|
||||
"symbol?" [nativefunction_new mal_symbol_q] \
|
||||
"keyword" [nativefunction_new mal_keyword] \
|
||||
"keyword?" [nativefunction_new mal_keyword_q] \
|
||||
\
|
||||
"pr-str" [nativefunction_new mal_pr_str] \
|
||||
"str" [nativefunction_new mal_str] \
|
||||
"prn" [nativefunction_new mal_prn] \
|
||||
"println" [nativefunction_new mal_println] \
|
||||
"read-string" [nativefunction_new mal_read_string] \
|
||||
"readline" [nativefunction_new mal_readline] \
|
||||
"slurp" [nativefunction_new mal_slurp] \
|
||||
\
|
||||
"<" [nativefunction_new mal_lt] \
|
||||
"<=" [nativefunction_new mal_lte] \
|
||||
">" [nativefunction_new mal_gt] \
|
||||
">=" [nativefunction_new mal_gte] \
|
||||
"+" [nativefunction_new mal_add] \
|
||||
"-" [nativefunction_new mal_sub] \
|
||||
"*" [nativefunction_new mal_mul] \
|
||||
"/" [nativefunction_new mal_div] \
|
||||
"time-ms" [nativefunction_new mal_time_ms] \
|
||||
\
|
||||
"list" [nativefunction_new mal_list] \
|
||||
"list?" [nativefunction_new mal_list_q] \
|
||||
"vector" [nativefunction_new mal_vector] \
|
||||
"vector?" [nativefunction_new mal_vector_q] \
|
||||
"hash-map" [nativefunction_new mal_hash_map] \
|
||||
"map?" [nativefunction_new mal_map_q] \
|
||||
"assoc" [nativefunction_new mal_assoc] \
|
||||
"dissoc" [nativefunction_new mal_dissoc] \
|
||||
"get" [nativefunction_new mal_get] \
|
||||
"contains?" [nativefunction_new mal_contains_q] \
|
||||
"keys" [nativefunction_new mal_keys] \
|
||||
"vals" [nativefunction_new mal_vals] \
|
||||
\
|
||||
"sequential?" [nativefunction_new mal_sequential_q] \
|
||||
"cons" [nativefunction_new mal_cons] \
|
||||
"concat" [nativefunction_new mal_concat] \
|
||||
"nth" [nativefunction_new mal_nth] \
|
||||
"first" [nativefunction_new mal_first] \
|
||||
"rest" [nativefunction_new mal_rest] \
|
||||
"empty?" [nativefunction_new mal_empty_q] \
|
||||
"count" [nativefunction_new mal_count] \
|
||||
"apply" [nativefunction_new mal_apply] \
|
||||
"map" [nativefunction_new mal_map] \
|
||||
\
|
||||
"conj" [nativefunction_new mal_conj] \
|
||||
\
|
||||
"meta" [nativefunction_new mal_meta] \
|
||||
"with-meta" [nativefunction_new mal_with_meta] \
|
||||
"atom" [nativefunction_new mal_atom] \
|
||||
"atom?" [nativefunction_new mal_atom_q] \
|
||||
"deref" [nativefunction_new mal_deref] \
|
||||
"reset!" [nativefunction_new mal_reset_bang] \
|
||||
"swap!" [nativefunction_new mal_swap_bang] \
|
||||
]
|
||||
49
tcl/env.tcl
Normal file
49
tcl/env.tcl
Normal file
@ -0,0 +1,49 @@
|
||||
oo::class create Env {
|
||||
variable outer data
|
||||
|
||||
constructor {{outerenv 0} {binds ""} {exprs ""}} {
|
||||
set outer $outerenv
|
||||
set data [dict create]
|
||||
if {$binds != ""} {
|
||||
for {set i 0} {$i < [llength $binds]} {incr i} {
|
||||
set b [lindex $binds $i]
|
||||
if {$b == "&"} {
|
||||
set varrest [lindex $binds [expr {$i + 1}]]
|
||||
set restexprs [list_new [lrange $exprs $i end]]
|
||||
my set $varrest $restexprs
|
||||
break
|
||||
} else {
|
||||
my set $b [lindex $exprs $i]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method set {symbol objval} {
|
||||
dict set data $symbol $objval
|
||||
return $objval
|
||||
}
|
||||
|
||||
method find {symbol} {
|
||||
if {[dict exist $data $symbol]} {
|
||||
return [self]
|
||||
} elseif {$outer != 0} {
|
||||
return [$outer find $symbol]
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
|
||||
method get {symbol} {
|
||||
set foundenv [my find $symbol]
|
||||
if {$foundenv == 0} {
|
||||
error "'$symbol' not found"
|
||||
} else {
|
||||
return [$foundenv get_symbol $symbol]
|
||||
}
|
||||
}
|
||||
|
||||
method get_symbol {symbol} {
|
||||
dict get $data $symbol
|
||||
}
|
||||
}
|
||||
24
tcl/mal_readline.tcl
Normal file
24
tcl/mal_readline.tcl
Normal file
@ -0,0 +1,24 @@
|
||||
if {[catch {package require tclreadline}]} {
|
||||
proc _readline prompt {
|
||||
puts -nonewline $prompt
|
||||
flush stdout
|
||||
if {[gets stdin line] < 0} {
|
||||
return {"EOF" ""}
|
||||
}
|
||||
list "OK" $line
|
||||
}
|
||||
} else {
|
||||
set ::historyfile "$env(HOME)/.mal-history"
|
||||
::tclreadline::readline initialize $::historyfile
|
||||
|
||||
proc _readline prompt {
|
||||
set reached_eof 0
|
||||
::tclreadline::readline eofchar { set reached_eof 1 }
|
||||
set line [::tclreadline::readline read $prompt]
|
||||
if {$reached_eof} {
|
||||
return {"EOF" ""}
|
||||
}
|
||||
::tclreadline::readline write $::historyfile
|
||||
list "OK" $line
|
||||
}
|
||||
}
|
||||
56
tcl/printer.tcl
Normal file
56
tcl/printer.tcl
Normal file
@ -0,0 +1,56 @@
|
||||
proc format_list {elements start_char end_char readable} {
|
||||
set res {}
|
||||
foreach element $elements {
|
||||
lappend res [pr_str $element $readable]
|
||||
}
|
||||
set joined [join $res " "]
|
||||
return "${start_char}${joined}${end_char}"
|
||||
}
|
||||
|
||||
proc format_hashmap {dictionary readable} {
|
||||
set lst {}
|
||||
dict for {keystr valobj} $dictionary {
|
||||
lappend lst [string_new $keystr]
|
||||
lappend lst $valobj
|
||||
}
|
||||
format_list $lst "\{" "\}" $readable
|
||||
}
|
||||
|
||||
proc format_string {str readable} {
|
||||
if {[string index $str 0] == "\u029E"} {
|
||||
return ":[string range $str 1 end]"
|
||||
} elseif {$readable} {
|
||||
set escaped [string map {"\n" "\\n" "\"" "\\\"" "\\" "\\\\"} $str]
|
||||
return "\"$escaped\""
|
||||
} else {
|
||||
return $str
|
||||
}
|
||||
}
|
||||
|
||||
proc format_function {funcdict} {
|
||||
set type "function"
|
||||
if {[dict get $funcdict is_macro]} {
|
||||
set type "macro"
|
||||
}
|
||||
return "<$type:args=[join [dict get $funcdict binds] ","]>"
|
||||
}
|
||||
|
||||
proc pr_str {ast readable} {
|
||||
set nodetype [obj_type $ast]
|
||||
set nodevalue [obj_val $ast]
|
||||
switch $nodetype {
|
||||
nil { return "nil" }
|
||||
true { return "true" }
|
||||
false { return "false" }
|
||||
integer { return $nodevalue }
|
||||
symbol { return $nodevalue }
|
||||
string { return [format_string $nodevalue $readable] }
|
||||
list { return [format_list $nodevalue "(" ")" $readable] }
|
||||
vector { return [format_list $nodevalue "\[" "\]" $readable] }
|
||||
hashmap { return [format_hashmap [dict get $nodevalue] $readable] }
|
||||
atom { return "(atom [pr_str $nodevalue $readable])" }
|
||||
function { return [format_function $nodevalue] }
|
||||
nativefunction { return "<nativefunction:$nodevalue>" }
|
||||
default { error "cannot print type $nodetype" }
|
||||
}
|
||||
}
|
||||
124
tcl/reader.tcl
Normal file
124
tcl/reader.tcl
Normal file
@ -0,0 +1,124 @@
|
||||
oo::class create Reader {
|
||||
variable pos tokens
|
||||
|
||||
constructor {tokens_list} {
|
||||
set tokens $tokens_list
|
||||
set pos 0
|
||||
}
|
||||
|
||||
method peek {} {
|
||||
lindex $tokens $pos
|
||||
}
|
||||
|
||||
method next {} {
|
||||
set token [my peek]
|
||||
incr pos
|
||||
return $token
|
||||
}
|
||||
}
|
||||
|
||||
proc tokenize str {
|
||||
set re {[\s,]*(~@|[\[\]\{\}()'`~^@]|\"(?:\\.|[^\\\"])*\"|;.*|[^\s\[\]\{\}('\"`~^@,;)]*)}
|
||||
set tokens {}
|
||||
foreach {_ capture} [regexp -line -all -inline $re $str] {
|
||||
if {[string length $capture] > 0 && [string range $capture 0 0] != ";"} {
|
||||
lappend tokens $capture
|
||||
}
|
||||
}
|
||||
return $tokens
|
||||
}
|
||||
|
||||
proc read_tokens_list {reader start_char end_char} {
|
||||
set token [$reader next]
|
||||
if {$token != $start_char} {
|
||||
error "expected '$start_char'"
|
||||
}
|
||||
|
||||
set elements {}
|
||||
set token [$reader peek]
|
||||
while {$token != $end_char} {
|
||||
if {$token == ""} {
|
||||
error "expected '$end_char'"
|
||||
}
|
||||
lappend elements [read_form $reader]
|
||||
set token [$reader peek]
|
||||
}
|
||||
$reader next
|
||||
return $elements
|
||||
}
|
||||
|
||||
proc read_list {reader} {
|
||||
set elements [read_tokens_list $reader "(" ")"]
|
||||
list_new $elements
|
||||
}
|
||||
|
||||
proc read_vector {reader} {
|
||||
set elements [read_tokens_list $reader "\[" "\]"]
|
||||
vector_new $elements
|
||||
}
|
||||
|
||||
proc read_hashmap {reader} {
|
||||
set res [dict create]
|
||||
foreach {keytoken valtoken} [read_tokens_list $reader "{" "}"] {
|
||||
dict set res [obj_val $keytoken] $valtoken
|
||||
}
|
||||
hashmap_new $res
|
||||
}
|
||||
|
||||
proc parse_string {str} {
|
||||
set res [string range $str 1 end-1]
|
||||
string map {"\\n" "\n" "\\\"" "\"" "\\\\" "\\"} $res
|
||||
}
|
||||
|
||||
proc parse_keyword {str} {
|
||||
# Remove initial ":"
|
||||
string range $str 1 end
|
||||
}
|
||||
|
||||
proc read_atom {reader} {
|
||||
set token [$reader next]
|
||||
switch -regexp $token {
|
||||
^-?[0-9]+$ { return [obj_new "integer" $token] }
|
||||
^nil$ { return $::mal_nil }
|
||||
^true$ { return $::mal_true }
|
||||
^false$ { return $::mal_false }
|
||||
^: { return [keyword_new [parse_keyword $token]] }
|
||||
^\".*\"$ { return [string_new [parse_string $token]] }
|
||||
default { return [symbol_new $token] }
|
||||
}
|
||||
}
|
||||
|
||||
proc symbol_shortcut {symbol_name reader} {
|
||||
$reader next
|
||||
list_new [list [symbol_new $symbol_name] [read_form $reader]]
|
||||
}
|
||||
|
||||
proc read_form {reader} {
|
||||
switch [$reader peek] {
|
||||
"'" { return [symbol_shortcut "quote" $reader] }
|
||||
"`" { return [symbol_shortcut "quasiquote" $reader] }
|
||||
"~" { return [symbol_shortcut "unquote" $reader] }
|
||||
"~@" { return [symbol_shortcut "splice-unquote" $reader] }
|
||||
"^" {
|
||||
$reader next
|
||||
set meta [read_form $reader]
|
||||
return [list_new [list [symbol_new "with-meta"] [read_form $reader] $meta]]
|
||||
}
|
||||
"@" { return [symbol_shortcut "deref" $reader] }
|
||||
"(" { return [read_list $reader] }
|
||||
")" { error "unexpected ')'" }
|
||||
"\[" { return [read_vector $reader] }
|
||||
"\]" { error "unexpected '\]'" }
|
||||
"\{" { return [read_hashmap $reader] }
|
||||
"\}" { error "unexpected '\}'" }
|
||||
default { return [read_atom $reader] }
|
||||
}
|
||||
}
|
||||
|
||||
proc read_str str {
|
||||
set tokens [tokenize $str]
|
||||
set reader [Reader new $tokens]
|
||||
set res [read_form $reader]
|
||||
$reader destroy
|
||||
return $res
|
||||
}
|
||||
33
tcl/step0_repl.tcl
Normal file
33
tcl/step0_repl.tcl
Normal file
@ -0,0 +1,33 @@
|
||||
source mal_readline.tcl
|
||||
|
||||
proc READ str {
|
||||
return $str
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
return $ast
|
||||
}
|
||||
|
||||
proc PRINT exp {
|
||||
return $exp
|
||||
}
|
||||
|
||||
proc REP str {
|
||||
PRINT [EVAL [READ $str] {}]
|
||||
}
|
||||
|
||||
fconfigure stdout -translation binary
|
||||
|
||||
# repl loop
|
||||
while {true} {
|
||||
set res [_readline "user> "]
|
||||
if {[lindex $res 0] == "EOF"} {
|
||||
break
|
||||
}
|
||||
set line [lindex $res 1]
|
||||
if {$line == ""} {
|
||||
continue
|
||||
}
|
||||
puts [REP $line]
|
||||
}
|
||||
puts ""
|
||||
38
tcl/step1_read_print.tcl
Normal file
38
tcl/step1_read_print.tcl
Normal file
@ -0,0 +1,38 @@
|
||||
source mal_readline.tcl
|
||||
source types.tcl
|
||||
source reader.tcl
|
||||
source printer.tcl
|
||||
|
||||
proc READ str {
|
||||
read_str $str
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
return $ast
|
||||
}
|
||||
|
||||
proc PRINT exp {
|
||||
pr_str $exp 1
|
||||
}
|
||||
|
||||
proc REP str {
|
||||
PRINT [EVAL [READ $str] {}]
|
||||
}
|
||||
|
||||
fconfigure stdout -translation binary
|
||||
|
||||
# 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] } exception] } {
|
||||
puts "Error: $exception"
|
||||
}
|
||||
}
|
||||
puts ""
|
||||
103
tcl/step2_eval.tcl
Normal file
103
tcl/step2_eval.tcl
Normal file
@ -0,0 +1,103 @@
|
||||
source mal_readline.tcl
|
||||
source types.tcl
|
||||
source reader.tcl
|
||||
source printer.tcl
|
||||
|
||||
proc READ str {
|
||||
read_str $str
|
||||
}
|
||||
|
||||
proc eval_ast {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
if {[dict exists $env $varname]} {
|
||||
return [dict get $env $varname]
|
||||
} else {
|
||||
error "'$varname' not found"
|
||||
}
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
set lst_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
set f [lindex $lst 0]
|
||||
set call_args [lrange $lst 1 end]
|
||||
apply $f $call_args
|
||||
}
|
||||
|
||||
proc PRINT exp {
|
||||
pr_str $exp 1
|
||||
}
|
||||
|
||||
proc REP {str env} {
|
||||
PRINT [EVAL [READ $str] $env]
|
||||
}
|
||||
|
||||
proc mal_add {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_sub {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_mul {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_div {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
set repl_env [dict create \
|
||||
"+" {{a} {mal_add $a}} \
|
||||
"-" {{a} {mal_sub $a}} \
|
||||
"*" {{a} {mal_mul $a}} \
|
||||
"/" {{a} {mal_div $a}} \
|
||||
]
|
||||
|
||||
fconfigure stdout -translation binary
|
||||
|
||||
# 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"
|
||||
}
|
||||
}
|
||||
puts ""
|
||||
119
tcl/step3_env.tcl
Normal file
119
tcl/step3_env.tcl
Normal file
@ -0,0 +1,119 @@
|
||||
source mal_readline.tcl
|
||||
source types.tcl
|
||||
source reader.tcl
|
||||
source printer.tcl
|
||||
source env.tcl
|
||||
|
||||
proc READ str {
|
||||
read_str $str
|
||||
}
|
||||
|
||||
proc eval_ast {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
set a0 [lindex [obj_val $ast] 0]
|
||||
set a1 [lindex [obj_val $ast] 1]
|
||||
set a2 [lindex [obj_val $ast] 2]
|
||||
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]
|
||||
}
|
||||
return [EVAL $a2 $letenv]
|
||||
}
|
||||
default {
|
||||
set lst_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
set f [lindex $lst 0]
|
||||
set call_args [lrange $lst 1 end]
|
||||
return [apply $f $call_args]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc PRINT exp {
|
||||
pr_str $exp 1
|
||||
}
|
||||
|
||||
proc REP {str env} {
|
||||
PRINT [EVAL [READ $str] $env]
|
||||
}
|
||||
|
||||
proc mal_add {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_sub {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_mul {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
proc mal_div {a} {
|
||||
integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}]
|
||||
}
|
||||
|
||||
set repl_env [Env new]
|
||||
$repl_env set "+" {{a} {mal_add $a}}
|
||||
$repl_env set "-" {{a} {mal_sub $a}}
|
||||
$repl_env set "*" {{a} {mal_mul $a}}
|
||||
$repl_env set "/" {{a} {mal_div $a}}
|
||||
|
||||
fconfigure stdout -translation binary
|
||||
|
||||
# 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"
|
||||
}
|
||||
}
|
||||
puts ""
|
||||
155
tcl/step4_if_fn_do.tcl
Normal file
155
tcl/step4_if_fn_do.tcl
Normal file
@ -0,0 +1,155 @@
|
||||
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 {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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]
|
||||
}
|
||||
return [EVAL $a2 $letenv]
|
||||
}
|
||||
"do" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $env
|
||||
return [EVAL [lindex [obj_val $ast] end] $env]
|
||||
}
|
||||
"if" {
|
||||
set condval [EVAL $a1 $env]
|
||||
if {[false_q $condval] || [nil_q $condval]} {
|
||||
if {$a3 == ""} {
|
||||
return $::mal_nil
|
||||
}
|
||||
return [EVAL $a3 $env]
|
||||
}
|
||||
return [EVAL $a2 $env]
|
||||
}
|
||||
"fn*" {
|
||||
set binds {}
|
||||
foreach v [obj_val $a1] {
|
||||
lappend binds [obj_val $v]
|
||||
}
|
||||
return [function_new $a2 $env $binds]
|
||||
}
|
||||
default {
|
||||
set lst_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
set f [lindex $lst 0]
|
||||
set call_args [lrange $lst 1 end]
|
||||
switch [obj_type $f] {
|
||||
function {
|
||||
set funcdict [obj_val $f]
|
||||
set body [dict get $funcdict body]
|
||||
set env [dict get $funcdict env]
|
||||
set binds [dict get $funcdict binds]
|
||||
set funcenv [Env new $env $binds $call_args]
|
||||
return [EVAL $body $funcenv]
|
||||
}
|
||||
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
|
||||
}
|
||||
|
||||
set repl_env [Env new]
|
||||
dict for {k v} $core_ns {
|
||||
$repl_env set $k $v
|
||||
}
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
RE "(def! not (fn* (a) (if a false true)))" $repl_env
|
||||
|
||||
fconfigure stdout -translation binary
|
||||
|
||||
set DEBUG_MODE 0
|
||||
if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
|
||||
set DEBUG_MODE 1
|
||||
}
|
||||
|
||||
# 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 ""
|
||||
160
tcl/step5_tco.tcl
Normal file
160
tcl/step5_tco.tcl
Normal file
@ -0,0 +1,160 @@
|
||||
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 {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
while {true} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $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_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
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
|
||||
}
|
||||
|
||||
set repl_env [Env new]
|
||||
dict for {k v} $core_ns {
|
||||
$repl_env set $k $v
|
||||
}
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
RE "(def! not (fn* (a) (if a false true)))" $repl_env
|
||||
|
||||
fconfigure stdout -translation binary
|
||||
|
||||
set DEBUG_MODE 0
|
||||
if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
|
||||
set DEBUG_MODE 1
|
||||
}
|
||||
|
||||
# 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 ""
|
||||
179
tcl/step6_file.tcl
Normal file
179
tcl/step6_file.tcl
Normal file
@ -0,0 +1,179 @@
|
||||
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 {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
while {true} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $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_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
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) \")\")))))" $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 ""
|
||||
206
tcl/step7_quote.tcl
Normal file
206
tcl/step7_quote.tcl
Normal file
@ -0,0 +1,206 @@
|
||||
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 is_pair {ast} {
|
||||
expr {[sequential_q $ast] && [llength [obj_val $ast]] > 0}
|
||||
}
|
||||
|
||||
proc quasiquote {ast} {
|
||||
if {![is_pair $ast]} {
|
||||
return [list_new [list [symbol_new "quote"] $ast]]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1
|
||||
if {[symbol_q $a0] && [obj_val $a0] == "unquote"} {
|
||||
return $a1
|
||||
}
|
||||
lassign [obj_val $a0] a00 a01
|
||||
set rest [list_new [lrange [obj_val $ast] 1 end]]
|
||||
if {[is_pair $a0] && [symbol_q $a00] && [obj_val $a00] == "splice-unquote"} {
|
||||
return [list_new [list [symbol_new "concat"] $a01 [quasiquote $rest]]]
|
||||
} else {
|
||||
return [list_new [list [symbol_new "cons"] [quasiquote $a0] [quasiquote $rest]]]
|
||||
}
|
||||
}
|
||||
|
||||
proc eval_ast {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
while {true} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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
|
||||
}
|
||||
"quote" {
|
||||
return $a1
|
||||
}
|
||||
"quasiquote" {
|
||||
set ast [quasiquote $a1]
|
||||
}
|
||||
"do" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $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_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
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) \")\")))))" $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 ""
|
||||
258
tcl/step8_macros.tcl
Normal file
258
tcl/step8_macros.tcl
Normal file
@ -0,0 +1,258 @@
|
||||
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 is_pair {ast} {
|
||||
expr {[sequential_q $ast] && [llength [obj_val $ast]] > 0}
|
||||
}
|
||||
|
||||
proc quasiquote {ast} {
|
||||
if {![is_pair $ast]} {
|
||||
return [list_new [list [symbol_new "quote"] $ast]]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1
|
||||
if {[symbol_q $a0] && [obj_val $a0] == "unquote"} {
|
||||
return $a1
|
||||
}
|
||||
lassign [obj_val $a0] a00 a01
|
||||
set rest [list_new [lrange [obj_val $ast] 1 end]]
|
||||
if {[is_pair $a0] && [symbol_q $a00] && [obj_val $a00] == "splice-unquote"} {
|
||||
return [list_new [list [symbol_new "concat"] $a01 [quasiquote $rest]]]
|
||||
} else {
|
||||
return [list_new [list [symbol_new "cons"] [quasiquote $a0] [quasiquote $rest]]]
|
||||
}
|
||||
}
|
||||
|
||||
proc is_macro_call {ast env} {
|
||||
if {![list_q $ast]} {
|
||||
return 0
|
||||
}
|
||||
set a0 [lindex [obj_val $ast] 0]
|
||||
if {![symbol_q $a0]} {
|
||||
return 0
|
||||
}
|
||||
set varname [obj_val $a0]
|
||||
set foundenv [$env find $varname]
|
||||
if {$foundenv == 0} {
|
||||
return 0
|
||||
}
|
||||
macro_q [$env get $varname]
|
||||
}
|
||||
|
||||
proc macroexpand {ast env} {
|
||||
while {[is_macro_call $ast $env]} {
|
||||
set a0 [mal_first [list $ast]]
|
||||
set macro_name [obj_val $a0]
|
||||
set macro_obj [$env get $macro_name]
|
||||
set macro_args [obj_val [mal_rest [list $ast]]]
|
||||
|
||||
set funcdict [obj_val $macro_obj]
|
||||
set body [dict get $funcdict body]
|
||||
set env [dict get $funcdict env]
|
||||
set binds [dict get $funcdict binds]
|
||||
set funcenv [Env new $env $binds $macro_args]
|
||||
set ast [EVAL $body $funcenv]
|
||||
}
|
||||
return $ast
|
||||
}
|
||||
|
||||
proc eval_ast {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
while {true} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
|
||||
set ast [macroexpand $ast $env]
|
||||
if {![list_q $ast]} {
|
||||
return $ast
|
||||
}
|
||||
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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
|
||||
}
|
||||
"quote" {
|
||||
return $a1
|
||||
}
|
||||
"quasiquote" {
|
||||
set ast [quasiquote $a1]
|
||||
}
|
||||
"defmacro!" {
|
||||
set varname [obj_val $a1]
|
||||
set value [EVAL $a2 $env]
|
||||
set fn [obj_val $value]
|
||||
dict set fn is_macro 1
|
||||
obj_set_val $value $fn
|
||||
return [$env set $varname $value]
|
||||
}
|
||||
"macroexpand" {
|
||||
return [macroexpand $a1 $env]
|
||||
}
|
||||
"do" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $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_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
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) \")\")))))" $repl_env
|
||||
RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env
|
||||
RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" $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 ""
|
||||
273
tcl/step9_try.tcl
Normal file
273
tcl/step9_try.tcl
Normal file
@ -0,0 +1,273 @@
|
||||
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 is_pair {ast} {
|
||||
expr {[sequential_q $ast] && [llength [obj_val $ast]] > 0}
|
||||
}
|
||||
|
||||
proc quasiquote {ast} {
|
||||
if {![is_pair $ast]} {
|
||||
return [list_new [list [symbol_new "quote"] $ast]]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1
|
||||
if {[symbol_q $a0] && [obj_val $a0] == "unquote"} {
|
||||
return $a1
|
||||
}
|
||||
lassign [obj_val $a0] a00 a01
|
||||
set rest [list_new [lrange [obj_val $ast] 1 end]]
|
||||
if {[is_pair $a0] && [symbol_q $a00] && [obj_val $a00] == "splice-unquote"} {
|
||||
return [list_new [list [symbol_new "concat"] $a01 [quasiquote $rest]]]
|
||||
} else {
|
||||
return [list_new [list [symbol_new "cons"] [quasiquote $a0] [quasiquote $rest]]]
|
||||
}
|
||||
}
|
||||
|
||||
proc is_macro_call {ast env} {
|
||||
if {![list_q $ast]} {
|
||||
return 0
|
||||
}
|
||||
set a0 [lindex [obj_val $ast] 0]
|
||||
if {![symbol_q $a0]} {
|
||||
return 0
|
||||
}
|
||||
set varname [obj_val $a0]
|
||||
set foundenv [$env find $varname]
|
||||
if {$foundenv == 0} {
|
||||
return 0
|
||||
}
|
||||
macro_q [$env get $varname]
|
||||
}
|
||||
|
||||
proc macroexpand {ast env} {
|
||||
while {[is_macro_call $ast $env]} {
|
||||
set a0 [mal_first [list $ast]]
|
||||
set macro_name [obj_val $a0]
|
||||
set macro_obj [$env get $macro_name]
|
||||
set macro_args [obj_val [mal_rest [list $ast]]]
|
||||
|
||||
set funcdict [obj_val $macro_obj]
|
||||
set body [dict get $funcdict body]
|
||||
set env [dict get $funcdict env]
|
||||
set binds [dict get $funcdict binds]
|
||||
set funcenv [Env new $env $binds $macro_args]
|
||||
set ast [EVAL $body $funcenv]
|
||||
}
|
||||
return $ast
|
||||
}
|
||||
|
||||
proc eval_ast {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
while {true} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
|
||||
set ast [macroexpand $ast $env]
|
||||
if {![list_q $ast]} {
|
||||
return $ast
|
||||
}
|
||||
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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
|
||||
}
|
||||
"quote" {
|
||||
return $a1
|
||||
}
|
||||
"quasiquote" {
|
||||
set ast [quasiquote $a1]
|
||||
}
|
||||
"defmacro!" {
|
||||
set varname [obj_val $a1]
|
||||
set value [EVAL $a2 $env]
|
||||
set fn [obj_val $value]
|
||||
dict set fn is_macro 1
|
||||
obj_set_val $value $fn
|
||||
return [$env set $varname $value]
|
||||
}
|
||||
"macroexpand" {
|
||||
return [macroexpand $a1 $env]
|
||||
}
|
||||
"try*" {
|
||||
set res {}
|
||||
if { [catch { set res [EVAL $a1 $env] } exception] } {
|
||||
set exc_var [obj_val [lindex [obj_val $a2] 1]]
|
||||
if {$exception == "__MalException__"} {
|
||||
set exc_value $::mal_exception_obj
|
||||
} else {
|
||||
set exc_value [string_new $exception]
|
||||
}
|
||||
set catch_env [Env new $env [list $exc_var] [list $exc_value]]
|
||||
return [EVAL [lindex [obj_val $a2] 2] $catch_env]
|
||||
} else {
|
||||
return $res
|
||||
}
|
||||
}
|
||||
"do" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $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_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
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) \")\")))))" $repl_env
|
||||
RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env
|
||||
RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" $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 ""
|
||||
279
tcl/stepA_mal.tcl
Normal file
279
tcl/stepA_mal.tcl
Normal file
@ -0,0 +1,279 @@
|
||||
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 is_pair {ast} {
|
||||
expr {[sequential_q $ast] && [llength [obj_val $ast]] > 0}
|
||||
}
|
||||
|
||||
proc quasiquote {ast} {
|
||||
if {![is_pair $ast]} {
|
||||
return [list_new [list [symbol_new "quote"] $ast]]
|
||||
}
|
||||
lassign [obj_val $ast] a0 a1
|
||||
if {[symbol_q $a0] && [obj_val $a0] == "unquote"} {
|
||||
return $a1
|
||||
}
|
||||
lassign [obj_val $a0] a00 a01
|
||||
set rest [list_new [lrange [obj_val $ast] 1 end]]
|
||||
if {[is_pair $a0] && [symbol_q $a00] && [obj_val $a00] == "splice-unquote"} {
|
||||
return [list_new [list [symbol_new "concat"] $a01 [quasiquote $rest]]]
|
||||
} else {
|
||||
return [list_new [list [symbol_new "cons"] [quasiquote $a0] [quasiquote $rest]]]
|
||||
}
|
||||
}
|
||||
|
||||
proc is_macro_call {ast env} {
|
||||
if {![list_q $ast]} {
|
||||
return 0
|
||||
}
|
||||
set a0 [lindex [obj_val $ast] 0]
|
||||
if {![symbol_q $a0]} {
|
||||
return 0
|
||||
}
|
||||
set varname [obj_val $a0]
|
||||
set foundenv [$env find $varname]
|
||||
if {$foundenv == 0} {
|
||||
return 0
|
||||
}
|
||||
macro_q [$env get $varname]
|
||||
}
|
||||
|
||||
proc macroexpand {ast env} {
|
||||
while {[is_macro_call $ast $env]} {
|
||||
set a0 [mal_first [list $ast]]
|
||||
set macro_name [obj_val $a0]
|
||||
set macro_obj [$env get $macro_name]
|
||||
set macro_args [obj_val [mal_rest [list $ast]]]
|
||||
|
||||
set funcdict [obj_val $macro_obj]
|
||||
set body [dict get $funcdict body]
|
||||
set env [dict get $funcdict env]
|
||||
set binds [dict get $funcdict binds]
|
||||
set funcenv [Env new $env $binds $macro_args]
|
||||
set ast [EVAL $body $funcenv]
|
||||
}
|
||||
return $ast
|
||||
}
|
||||
|
||||
proc eval_ast {ast env} {
|
||||
switch [obj_type $ast] {
|
||||
"symbol" {
|
||||
set varname [obj_val $ast]
|
||||
return [$env get $varname]
|
||||
}
|
||||
"list" {
|
||||
set res {}
|
||||
foreach element [obj_val $ast] {
|
||||
lappend res [EVAL $element $env]
|
||||
}
|
||||
return [list_new $res]
|
||||
}
|
||||
"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 }
|
||||
}
|
||||
}
|
||||
|
||||
proc EVAL {ast env} {
|
||||
while {true} {
|
||||
if {![list_q $ast]} {
|
||||
return [eval_ast $ast $env]
|
||||
}
|
||||
|
||||
set ast [macroexpand $ast $env]
|
||||
if {![list_q $ast]} {
|
||||
return $ast
|
||||
}
|
||||
|
||||
lassign [obj_val $ast] a0 a1 a2 a3
|
||||
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
|
||||
}
|
||||
"quote" {
|
||||
return $a1
|
||||
}
|
||||
"quasiquote" {
|
||||
set ast [quasiquote $a1]
|
||||
}
|
||||
"defmacro!" {
|
||||
set varname [obj_val $a1]
|
||||
set value [EVAL $a2 $env]
|
||||
set fn [obj_val $value]
|
||||
dict set fn is_macro 1
|
||||
obj_set_val $value $fn
|
||||
return [$env set $varname $value]
|
||||
}
|
||||
"macroexpand" {
|
||||
return [macroexpand $a1 $env]
|
||||
}
|
||||
"tcl*" {
|
||||
return [string_new [eval [obj_val $a1]]]
|
||||
}
|
||||
"try*" {
|
||||
set res {}
|
||||
if { [catch { set res [EVAL $a1 $env] } exception] } {
|
||||
set exc_var [obj_val [lindex [obj_val $a2] 1]]
|
||||
if {$exception == "__MalException__"} {
|
||||
set exc_value $::mal_exception_obj
|
||||
} else {
|
||||
set exc_value [string_new $exception]
|
||||
}
|
||||
set catch_env [Env new $env [list $exc_var] [list $exc_value]]
|
||||
return [EVAL [lindex [obj_val $a2] 2] $catch_env]
|
||||
} else {
|
||||
return $res
|
||||
}
|
||||
}
|
||||
"do" {
|
||||
set el [list_new [lrange [obj_val $ast] 1 end-1]]
|
||||
eval_ast $el $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_obj [eval_ast $ast $env]
|
||||
set lst [obj_val $lst_obj]
|
||||
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! *host-language* \"tcl\")" $repl_env
|
||||
RE "(def! not (fn* (a) (if a false true)))" $repl_env
|
||||
RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env
|
||||
RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env
|
||||
RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" $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
|
||||
}
|
||||
|
||||
REP "(println (str \"Mal \[\" *host-language* \"\]\"))" $repl_env
|
||||
|
||||
# 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 ""
|
||||
28
tcl/tests/stepA_mal.mal
Normal file
28
tcl/tests/stepA_mal.mal
Normal file
@ -0,0 +1,28 @@
|
||||
;; Testing basic Tcl interop
|
||||
;;
|
||||
;; Note that in Tcl "everything is a string", so we don't have enough
|
||||
;; information to convert the results to other Mal types.
|
||||
|
||||
(tcl* "expr {3 ** 4}")
|
||||
;=>"81"
|
||||
|
||||
(tcl* "llength {a b c d}")
|
||||
;=>"4"
|
||||
|
||||
(tcl* "concat {a b} c {d e} f g")
|
||||
;=>"a b c d e f g"
|
||||
|
||||
(tcl* "puts \"hello [expr {5 + 6}] world\"")
|
||||
; hello 11 world
|
||||
;=>""
|
||||
|
||||
(tcl* "set ::foo 8")
|
||||
(tcl* "expr {$::foo}")
|
||||
;=>"8"
|
||||
|
||||
(tcl* "proc mult3 {x} { expr {$x * 3} }")
|
||||
(tcl* "mult3 6")
|
||||
;=>"18"
|
||||
|
||||
(tcl* "string range $::tcl_version 0 1")
|
||||
;=>"8."
|
||||
184
tcl/types.tcl
Normal file
184
tcl/types.tcl
Normal file
@ -0,0 +1,184 @@
|
||||
oo::class create MalObj {
|
||||
variable type val meta
|
||||
|
||||
constructor {obj_type obj_val {obj_meta 0}} {
|
||||
set type $obj_type
|
||||
set val $obj_val
|
||||
set meta $obj_meta
|
||||
}
|
||||
|
||||
method get_type {} {
|
||||
return $type
|
||||
}
|
||||
|
||||
method get_val {} {
|
||||
return $val
|
||||
}
|
||||
|
||||
method get_meta {} {
|
||||
return $meta
|
||||
}
|
||||
|
||||
method set_val {new_val} {
|
||||
set val $new_val
|
||||
return $new_val
|
||||
}
|
||||
}
|
||||
|
||||
proc obj_new {obj_type obj_val {obj_meta 0}} {
|
||||
MalObj new $obj_type $obj_val $obj_meta
|
||||
}
|
||||
|
||||
proc obj_type {obj} {
|
||||
$obj get_type
|
||||
}
|
||||
|
||||
proc obj_val {obj} {
|
||||
$obj get_val
|
||||
}
|
||||
|
||||
proc obj_meta {obj} {
|
||||
$obj get_meta
|
||||
}
|
||||
|
||||
proc obj_set_val {obj new_val} {
|
||||
$obj set_val $new_val
|
||||
}
|
||||
|
||||
set ::mal_nil [obj_new "nil" {}]
|
||||
set ::mal_true [obj_new "true" {}]
|
||||
set ::mal_false [obj_new "false" {}]
|
||||
|
||||
proc nil_q {obj} {
|
||||
expr {[obj_type $obj] == "nil"}
|
||||
}
|
||||
|
||||
proc false_q {obj} {
|
||||
expr {[obj_type $obj] == "false"}
|
||||
}
|
||||
|
||||
proc true_q {obj} {
|
||||
expr {[obj_type $obj] == "true"}
|
||||
}
|
||||
|
||||
proc bool_new {val} {
|
||||
if {$val == 0} {
|
||||
return $::mal_false
|
||||
} else {
|
||||
return $::mal_true
|
||||
}
|
||||
}
|
||||
|
||||
proc integer_new {num} {
|
||||
obj_new "integer" $num
|
||||
}
|
||||
|
||||
proc symbol_new {name} {
|
||||
obj_new "symbol" $name
|
||||
}
|
||||
|
||||
proc symbol_q {obj} {
|
||||
expr {[obj_type $obj] == "symbol"}
|
||||
}
|
||||
|
||||
proc string_new {val} {
|
||||
obj_new "string" $val
|
||||
}
|
||||
|
||||
proc keyword_new {val} {
|
||||
string_new "\u029E$val"
|
||||
}
|
||||
|
||||
proc keyword_q {obj} {
|
||||
expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] == "\u029E"}
|
||||
}
|
||||
|
||||
proc list_new {lst} {
|
||||
obj_new "list" $lst $::mal_nil
|
||||
}
|
||||
|
||||
proc list_q {obj} {
|
||||
expr {[obj_type $obj] == "list"}
|
||||
}
|
||||
|
||||
proc vector_new {lst} {
|
||||
obj_new "vector" $lst $::mal_nil
|
||||
}
|
||||
|
||||
proc vector_q {obj} {
|
||||
expr {[obj_type $obj] == "vector"}
|
||||
}
|
||||
|
||||
proc hashmap_new {lst} {
|
||||
obj_new "hashmap" $lst $::mal_nil
|
||||
}
|
||||
|
||||
proc hashmap_q {obj} {
|
||||
expr {[obj_type $obj] == "hashmap"}
|
||||
}
|
||||
|
||||
proc sequential_q {obj} {
|
||||
expr {[list_q $obj] || [vector_q $obj]}
|
||||
}
|
||||
|
||||
proc sequential_equal_q {seq_a seq_b} {
|
||||
foreach obj_a [obj_val $seq_a] obj_b [obj_val $seq_b] {
|
||||
if {$obj_a == "" || $obj_b == "" || ![equal_q $obj_a $obj_b]} {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
return 1
|
||||
}
|
||||
|
||||
proc hashmap_equal_q {hashmap_a hashmap_b} {
|
||||
set dict_a [obj_val $hashmap_a]
|
||||
set dict_b [obj_val $hashmap_b]
|
||||
set keys_a [lsort [dict keys $dict_a]]
|
||||
set keys_b [lsort [dict keys $dict_b]]
|
||||
if {$keys_a != $keys_b} {
|
||||
return 0
|
||||
}
|
||||
foreach key $keys_a {
|
||||
set obj_a [dict get $dict_a $key]
|
||||
set obj_b [dict get $dict_b $key]
|
||||
if {![equal_q $obj_a $obj_b]} {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
return 1
|
||||
}
|
||||
|
||||
proc equal_q {a b} {
|
||||
if {[sequential_q $a] && [sequential_q $b]} {
|
||||
sequential_equal_q $a $b
|
||||
} elseif {[hashmap_q $a] && [hashmap_q $b]} {
|
||||
hashmap_equal_q $a $b
|
||||
} else {
|
||||
expr {[obj_type $a] == [obj_type $b] && [obj_val $a] == [obj_val $b]}
|
||||
}
|
||||
}
|
||||
|
||||
proc nativefunction_new {name} {
|
||||
obj_new "nativefunction" $name $::mal_nil
|
||||
}
|
||||
|
||||
proc function_new {body env binds} {
|
||||
set funcdict [dict create body $body env $env binds $binds is_macro 0]
|
||||
obj_new "function" $funcdict $::mal_nil
|
||||
}
|
||||
|
||||
proc function_q {obj} {
|
||||
expr {[obj_type $obj] == "function"}
|
||||
}
|
||||
|
||||
proc macro_q {obj} {
|
||||
expr {[obj_type $obj] == "function" && [dict get [obj_val $obj] is_macro]}
|
||||
}
|
||||
|
||||
proc atom_new {val} {
|
||||
obj_new "atom" $val $::mal_nil
|
||||
}
|
||||
|
||||
proc atom_q {obj} {
|
||||
expr {[obj_type $obj] == "atom"}
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user