kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-11-10 12:47:45 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'kanaka/master' into kotlin

Browse Source
This commit is contained in:
Javier Fernandez-Ivern 2015-11-18 20:26:25 -06:00
commit d51639075b
56 changed files with 3305 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.gitignore vendored
View File

@ -1,13 +1,19 @@
*/experiments */experiments
make/mal.mk
*/node_modules */node_modules
js/mal.js
js/mal_web.js
bash/mal.sh
c/*.o c/*.o
*.pyc *.pyc
bash/mal.sh
c/mal c/mal
coffee/mal.coffee
crystal/mal
haskell/mal haskell/mal
js/mal.js
js/web/mal.js
make/mal.mk
mal/mal.mal
nim/mal
php/mal.php
python/mal.py
*/step0_repl */step0_repl
*/step1_read_print */step1_read_print
*/step2_eval */step2_eval

1
.travis.yml
View File

@ -52,6 +52,7 @@ matrix:
- env: IMPL=swift NO_DOCKER=1 - env: IMPL=swift NO_DOCKER=1
os: osx os: osx
osx_image: xcode7 osx_image: xcode7
- env: IMPL=tcl
- env: IMPL=vimscript NO_PERF=1 # /dev/stdout not writable - env: IMPL=vimscript NO_PERF=1 # /dev/stdout not writable
- env: IMPL=vb - env: IMPL=vb

2
.travis_test.sh
View File

@ -21,7 +21,7 @@ else
MAKE="docker run -it -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl} make" MAKE="docker run -it -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl} make"
fi fi
${MAKE} TEST_OPTS="--soft --debug-file ../${ACTION}.err" \ ${MAKE} TEST_OPTS="--debug-file ../${ACTION}.err" \
MAL_IMPL=${MAL_IMPL} ${ACTION}^${IMPL} MAL_IMPL=${MAL_IMPL} ${ACTION}^${IMPL}
# no failure so remove error log # no failure so remove error log

10
Makefile
View File

@ -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 \ 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 \ 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 step0 = step0_repl
step1 = step1_read_print step1 = step1_read_print
@ -101,6 +101,7 @@ ruby_STEP_TO_PROG = ruby/$($(1)).rb
rust_STEP_TO_PROG = rust/target/release/$($(1)) rust_STEP_TO_PROG = rust/target/release/$($(1))
scala_STEP_TO_PROG = scala/$($(1)).scala scala_STEP_TO_PROG = scala/$($(1)).scala
swift_STEP_TO_PROG = swift/$($(1)) swift_STEP_TO_PROG = swift/$($(1))
tcl_STEP_TO_PROG = tcl/$($(1)).tcl
vb_STEP_TO_PROG = vb/$($(1)).exe vb_STEP_TO_PROG = vb/$($(1)).exe
vimscript_STEP_TO_PROG = vimscript/$($(1)).vim vimscript_STEP_TO_PROG = vimscript/$($(1)).vim
guile_STEP_TO_PROG = guile/$($(1)).scm guile_STEP_TO_PROG = guile/$($(1)).scm
@ -151,6 +152,7 @@ ruby_RUNSTEP = ruby ../$(2) $(3)
rust_RUNSTEP = ../$(2) $(3) rust_RUNSTEP = ../$(2) $(3)
scala_RUNSTEP = sbt 'run-main $($(1))$(if $(3), $(3),)' scala_RUNSTEP = sbt 'run-main $($(1))$(if $(3), $(3),)'
swift_RUNSTEP = ../$(2) $(3) swift_RUNSTEP = ../$(2) $(3)
tcl_RUNSTEP = tclsh ../$(2) --raw $(3)
vb_RUNSTEP = mono ../$(2) --raw $(3) vb_RUNSTEP = mono ../$(2) --raw $(3)
vimscript_RUNSTEP = ./run_vimscript.sh ../$(2) $(3) vimscript_RUNSTEP = ./run_vimscript.sh ../$(2) $(3)
# needs TERM=dumb to work with readline # needs TERM=dumb to work with readline
@ -184,8 +186,12 @@ IMPL_PERF = $(filter-out $(EXCLUDE_PERFS),$(foreach impl,$(DO_IMPLS),perf^$(impl
# #
# Build a program in an implementation directory # Build a program in an implementation directory
# Make sure we always try and build first because the dependencies are
# encoded in the implementation Makefile not here
.PHONY: $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s))))
$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))): $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))):
$(MAKE) -C $(dir $(@)) $(notdir $(@)) $(foreach impl,$(word 1,$(subst /, ,$(@))),\
$(MAKE) -C $(impl) $(subst $(impl)/,,$(@)))
# Allow test, test^STEP, test^IMPL, and test^IMPL^STEP # Allow test, test^STEP, test^IMPL, and test^IMPL^STEP
.SECONDEXPANSION: .SECONDEXPANSION:

15
README.md
View File

@ -6,7 +6,7 @@
Mal is a Clojure inspired Lisp interpreter. Mal is a Clojure inspired Lisp interpreter.
Mal is implemented in 42 different languages: Mal is implemented in 43 different languages:
* GNU awk * GNU awk
* Bash shell * Bash shell
@ -48,6 +48,7 @@ Mal is implemented in 42 different languages:
* Rust * Rust
* Scala * Scala
* Swift * Swift
* Tcl
* Vimscript * Vimscript
* Visual Basic.NET * Visual Basic.NET
@ -534,6 +535,18 @@ make
./stepX_YYY ./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 ### Vimscript
*The Vimscript implementation was created by [Dov Murik](https://github.com/dubek)* *The Vimscript implementation was created by [Dov Murik](https://github.com/dubek)*

16
bash/types.sh
View File

@ -81,7 +81,7 @@ _equal? () {
case "${ot1}" in case "${ot1}" in
string|symbol|keyword|number) string|symbol|keyword|number)
[[ "${ANON["${1}"]}" == "${ANON["${2}"]}" ]] ;; [[ "${ANON["${1}"]}" == "${ANON["${2}"]}" ]] ;;
list|vector|hash_map) list|vector)
_count "${1}"; local sz1="${r}" _count "${1}"; local sz1="${r}"
_count "${2}"; local sz2="${r}" _count "${2}"; local sz2="${r}"
[[ "${sz1}" == "${sz2}" ]] || return 1 [[ "${sz1}" == "${sz2}" ]] || return 1
@ -91,6 +91,20 @@ _equal? () {
_equal? "${a1[${i}]}" "${a2[${i}]}" || return 1 _equal? "${a1[${i}]}" "${a2[${i}]}" || return 1
done done
;; ;;
hash_map)
local hm1="${ANON["${1}"]}"
eval local ks1="\${!${hm1}[@]}"
local hm2="${ANON["${2}"]}"
eval local ks2="\${!${hm2}[@]}"
[[ "${#ks1}" == "${#ks2}" ]] || return 1
for k in ${ks1}; do
eval v1="\${${hm1}[\"${k}\"]}"
eval v2="\${${hm2}[\"${k}\"]}"
[ "${v1}" ] || return 1
[ "${v2}" ] || return 1
_equal? "${v1}" "${v2}" || return 1
done
;;
*) *)
[[ "${1}" == "${2}" ]] ;; [[ "${1}" == "${2}" ]] ;;
esac esac

21
c/types.c
View File

@ -268,6 +268,9 @@ MalVal *_apply(MalVal *f, MalVal *args) {
int _equal_Q(MalVal *a, MalVal *b) { int _equal_Q(MalVal *a, MalVal *b) {
GHashTableIter iter;
gpointer key, value;
if (a == NULL || b == NULL) { return FALSE; } if (a == NULL || b == NULL) { return FALSE; }
// If types are the same or both are sequential then they might be equal // If types are the same or both are sequential then they might be equal
@ -305,8 +308,22 @@ int _equal_Q(MalVal *a, MalVal *b) {
} }
return TRUE; return TRUE;
case MAL_HASH_MAP: case MAL_HASH_MAP:
_error("_equal_Q does not support hash-maps yet"); if (g_hash_table_size(a->val.hash_table) !=
return FALSE; g_hash_table_size(b->val.hash_table)) {
return FALSE;
}
g_hash_table_iter_init (&iter, a->val.hash_table);
while (g_hash_table_iter_next (&iter, &key, &value)) {
if (!g_hash_table_contains(b->val.hash_table, key)) {
return FALSE;
}
MalVal *aval = (MalVal *) g_hash_table_lookup(a->val.hash_table, key);
MalVal *bval = (MalVal *) g_hash_table_lookup(b->val.hash_table, key);
if (!_equal_Q(aval, bval)) {
return FALSE;
}
}
return TRUE;
case MAL_FUNCTION_C: case MAL_FUNCTION_C:
case MAL_FUNCTION_MAL: case MAL_FUNCTION_MAL:
return a->val.f0 == b->val.f0; return a->val.f0 == b->val.f0;

4
coffee/types.coffee
View File

@ -38,9 +38,7 @@ E._equal_Q = _equal_Q = (a,b) ->
bkeys = (key for key of b) bkeys = (key for key of b)
return false if akeys.length != bkeys.length return false if akeys.length != bkeys.length
for akey,i in akeys for akey,i in akeys
bkey = bkeys[i] return false if !_equal_Q(a[akey], b[akey])
return false if akey != bkey
return false if !_equal_Q(a[akey], b[bkey])
true true
else a == b else a == b

13
cs/types.cs
View File

@ -58,6 +58,19 @@ namespace Mal {
} }
} }
return true; return true;
} else if (a is MalHashMap) {
var akeys = ((MalHashMap)a).getValue().Keys;
var bkeys = ((MalHashMap)b).getValue().Keys;
if (akeys.Count != bkeys.Count) {
return false;
}
foreach (var k in akeys) {
if (!_equal_Q(((MalHashMap)a).getValue()[k],
((MalHashMap)b).getValue()[k])) {
return false;
}
}
return true;
} else { } else {
return a == b; return a == b;
} }

2
erlang/rebar.config
View File

@ -2,7 +2,7 @@
%% rebar configuration file (https://github.com/rebar/rebar) %% rebar configuration file (https://github.com/rebar/rebar)
%% %%
{require_otp_vsn, "17"}. {require_otp_vsn, "17|18"}.
{erl_opts, [debug_info, fail_on_warning]}. {erl_opts, [debug_info, fail_on_warning]}.

2
erlang/src/printer.erl
View File

@ -54,7 +54,7 @@ escape_str(String) ->
case C of case C of
$" -> [C, $\\|AccIn]; $" -> [C, $\\|AccIn];
$\\ -> [C, $\\|AccIn]; $\\ -> [C, $\\|AccIn];
$\n -> [C, $\\|AccIn]; $\n -> [$n, $\\|AccIn];
_ -> [C|AccIn] _ -> [C|AccIn]
end end
end, end,

5
erlang/src/reader.erl
View File

@ -216,8 +216,9 @@ lex_string([], _String) ->
lex_string([$\\,Escaped|Rest], String) -> lex_string([$\\,Escaped|Rest], String) ->
% unescape the string while building it % unescape the string while building it
case Escaped of case Escaped of
[] -> {error, "end of string reached in escape"}; [] -> {error, "end of string reached in escape"};
_ -> lex_string(Rest, [Escaped|String]) $n -> lex_string(Rest, [$\n|String]);
_ -> lex_string(Rest, [Escaped|String])
end; end;
lex_string([$"|Rest], String) -> lex_string([$"|Rest], String) ->
{{string, lists:reverse(String)}, Rest}; {{string, lists:reverse(String)}, Rest};

9
es6/types.js
View File

@ -34,12 +34,9 @@ export function _equal_Q (a, b) {
} }
return true return true
case 'hash-map': case 'hash-map':
let akeys = Object.keys(a).sort(), if (a.size !== b.size) { return false }
bkeys = Object.keys(b).sort() for (let k of a.keys()) {
if (akeys.length !== bkeys.length) { return false } if (! _equal_Q(a.get(k), b.get(k))) { return false }
for (let i=0; i<akeys.length; i++) {
if (akeys[i] !== bkeys[i]) { return false }
if (! _equal_Q(a.get(akeys[i]), b.get(bkeys[i]))) { return false }
} }
return true return true
default: default:

0
mal/clojurewest2014.mal → examples/clojurewest2014.mal
View File

78
examples/equality.mal Normal file
View File

@ -0,0 +1,78 @@
;;
;; equality.mal
;;
;; This file checks whether the `=` function correctly implements equality of
;; hash-maps and sequences (lists and vectors). If not, it redefines the `=`
;; function with a pure mal (recursive) implementation that only relies on the
;; native original `=` function for comparing scalars (integers, booleans,
;; symbols, strings).
;;
;; Save the original (native) `=` as scalar-equal?
(def! scalar-equal? =)
;; A simple `and` macro for two argument which doesn't use `=` internally
(defmacro! and2
(fn* [a b]
`(let* (and2_FIXME ~a)
(if and2_FIXME ~b and2_FIXME))))
;; Implement `=` for two sequential arguments
(def! sequential-equal?
(fn* [a b]
(if (scalar-equal? (count a) (count b))
(if (empty? a)
true
(if (mal-equal? (first a) (first b))
(sequential-equal? (rest a) (rest b))
false))
false)))
;; Helper function
(def! hash-map-vals-equal?
(fn* [a b map-keys]
(if (scalar-equal? 0 (count map-keys))
true
(let* [key (first map-keys)]
(if (and2
(and2 (contains? a key) (contains? b key))
(mal-equal? (get a key) (get b key)))
(hash-map-vals-equal? a b (rest map-keys))
false)))))
;; Implement `=` for two hash-maps
(def! hash-map-equal?
(fn* [a b]
(let* [keys-a (keys a)]
(if (scalar-equal? (count keys-a) (count (keys b)))
(hash-map-vals-equal? a b keys-a)
false))))
;; This implements = in pure mal (using only scalar-equal? as native impl)
(def! mal-equal?
(fn* [a b]
(cond
(and2 (sequential? a) (sequential? b)) (sequential-equal? a b)
(and2 (map? a) (map? b)) (hash-map-equal? a b)
true (scalar-equal? a b))))
(def! hash-map-equality-correct?
(fn* []
(try*
(and2 (= {:a 1} {:a 1})
(not (= {:a 1} {:a 1 :b 2})))
(catch* _ false))))
(def! sequence-equality-correct?
(fn* []
(try*
(and2 (= [:a :b] (list :a :b))
(not (= [:a :b] [:a :b :c])))
(catch* _ false))))
;; If the native `=` implementation doesn't support sequences or hash-maps
;; correctly, replace it with the pure mal implementation
(if (not (and2 (hash-map-equality-correct?) (sequence-equality-correct?)))
(do
(def! = mal-equal?)
(println "equality.mal: Replaced = with pure mal implementation")))

2
examples/hello.mal Normal file
View File

@ -0,0 +1,2 @@
(println "hello world\n\nanother line")
(println "and another line")

123
examples/presentation.mal Executable file
View File

@ -0,0 +1,123 @@
;; Mal Presentation
(def! clear
(fn* ()
(str "")))
(def! bold
(fn* (s)
(str "" s "")))
(def! blue
(fn* (s)
(str "" s "")))
(def! title
(fn* (s)
(bold (blue (str s "\n")))))
(def! title2
(fn* (s)
(bold (blue s))))
(def! slides
(list
(list
(title2 " __ __ _ _")
(title2 "| \/ | / \ | |")
(title2 "| |\/| | / _ \ | | ")
(title2 "| | | |/ ___ \| |___ ")
(title2 "|_| |_/_/ \_\_____|"))
(list
(title "gherkin")
"- a lisp1 written in bash4")
(list
(title "mal - an interpreter for a subset of Clojure"))
(list
(title "mal - an interpreter for a subset of Clojure")
"- written in GNU make")
(list
(title "mal - an interpreter for a subset of Clojure")
"- written in GNU make"
"- and Bash 4")
(list
(title "mal - an interpreter for a subset of Clojure")
"- written in GNU make"
"- and Bash 4"
"- and Javascript")
(list
(title "mal - an interpreter for a subset of Clojure")
"- written in GNU make"
"- and Bash 4"
"- and Javascript"
"- and Python")
(list
(title "mal - an interpreter for a subset of Clojure")
"- written in GNU make"
"- and Bash 4"
"- and Javascript"
"- and Python"
"- and Clojure")
(list
(title "mal - an interpreter for a subset of Clojure")
"- written in GNU make"
"- and Bash 4"
"- and Javascript"
"- and Python"
"- and Clojure"
"- and 17 other languages")
(list
(title "things it has")
"- scalars: integers, strings, symbols, keywords, nil, true, false"
"- immutable collections: lists, vectors, hash-maps"
"- metadata, atoms"
"- def!, fn*, let*"
" - varargs: (fn* (x y & more) ...)"
"- tail call optimization"
" - except GNU make implementation (no iteration)"
"- macros (quote, unquote, quasiquote, splice-quote)"
"- over 500 unit tests"
"- REPL with line editing (GNU readline/libedit/linenoise)")
(list
(title "things it does not have")
"- performance"
"- namespaces"
"- GC (in bash, make, C implmentations)"
"- protocols :-("
"- lots of other things")
(list
(title "why?")
"- because!")
(list
(title "why?")
"- because!"
"- gherkin was an inspiration to higher levels of crazy"
"- evolved into learning tool"
"- way to learn about Lisp and also the target language"
"- each implementation broken into small 11 steps")
(list
(title "thanks to:")
"- Peter Norvig: inspiration: lispy"
" - http://norvig.com/lispy.html"
"- Alan Dipert: gherkin, original gherkin slides"
" - https://github.com/alandipert/gherkin")
(list
(title "mal - Make a Lisp")
"https://github.com/kanaka/mal")
(list
(title "demo"))))
(def! present
(fn* (slides)
(if (> (count slides) 0)
(do
(println (clear))
(apply println (map (fn* (line) (str "\n " line)) (first slides)))
(println "\n\n\n")
(readline "")
(present (rest slides))))))
(present slides)

70
examples/protocols.mal Normal file
View File

@ -0,0 +1,70 @@
;; A sketch of Clojure-like protocols, implemented in Mal
;; By chouser (Chris Houser)
;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc
(def! builtin-type (fn* [obj]
(cond
(list? obj) :mal/list
(vector? obj) :mal/vector
(map? obj) :mal/map
(symbol? obj) :mal/symbol
(keyword? obj) :mal/keyword
(atom? obj) :mal/atom
(nil? obj) nil
(true? obj) :mal/bool
(false? obj) :mal/bool)))
(def! find-protocol-methods (fn* [protocol obj]
(let* [p @protocol]
(or (get p (get (meta obj) :type))
(get p (builtin-type obj))
(get p :mal/default)))))
(def! satisfies? (fn* [protocol obj]
(if (find-protocol-methods protocol obj) true false)))
(defmacro! defprotocol (fn* [proto-name & methods]
`(do
(def! ~proto-name (atom {}))
~@(map (fn* [m]
(let* [name (first m), sig (first (rest m))]
`(def! ~name (fn* [this-FIXME & args-FIXME]
(apply (get (find-protocol-methods ~proto-name this-FIXME)
~(keyword (str name)))
this-FIXME args-FIXME)))))
methods))))
(def! extend (fn* [type proto methods & more]
(do
(swap! proto assoc type methods)
(if (first more)
(apply extend type more)))))
;;----
;; Example:
(def! make-triangle (fn* [o a]
^{:type :shape/triangle} {:opposite o, :adjacent a}))
(def! make-rectangle (fn* [x y]
^{:type :shape/rectangle} {:width x, :height y}))
(defprotocol IDraw
(area [this])
(draw [this]))
(prn :false-> (satisfies? IDraw (make-triangle 5 5))) ;=> false
(extend :shape/rectangle
IDraw
{:area (fn* [obj] (* (get obj :width) (get obj :height)))
:draw (fn* [obj] (println "[]"))})
(extend :shape/triangle
IDraw
{:area (fn* [obj] (/ (* (get obj :opposite) (get obj :adjacent)) 2))
:draw (fn* [obj] (println " .\n.."))})
(prn :true-> (satisfies? IDraw (make-triangle 5 5))) ;=> true
(prn :area-> (area (make-triangle 5 4))) ;=> 10

12
go/src/types/types.go
View File

@ -295,7 +295,17 @@ func Equal_Q(a MalType, b MalType) bool {
} }
return true return true
case HashMap: case HashMap:
return false am := a.(HashMap).Val
bm := b.(HashMap).Val
if len(am) != len(bm) {
return false
}
for k, v := range am {
if !Equal_Q(v, bm[k]) {
return false
}
}
return true
default: default:
return a == b return a == b
} }

3
java/Makefile
View File

@ -11,6 +11,9 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
all: all:
mvn install mvn install
src/main/mal/%.java:
mvn install
#.PHONY: stats tests $(TESTS) #.PHONY: stats tests $(TESTS)
.PHONY: stats .PHONY: stats

14
java/src/main/java/mal/types.java
View File

@ -64,6 +64,20 @@ public class types {
} }
} }
return true; return true;
} else if (a instanceof MalHashMap) {
if (((MalHashMap)a).value.size() != ((MalHashMap)b).value.size()) {
return false;
}
//HashMap<String,MalVal> hm = (HashMap<String,MalVal>)a.value;
MalHashMap mhm = ((MalHashMap)a);
HashMap<String,MalVal> hm = (HashMap<String,MalVal>)mhm.value;
for (String k : hm.keySet()) {
if (! _equal_Q(((MalVal)((MalHashMap)a).value.get(k)),
((MalVal)((MalHashMap)b).value.get(k)))) {
return false;
}
}
return true;
} else { } else {
return a == b; return a == b;
} }

9
js/types.js
View File

@ -43,12 +43,9 @@ function _equal_Q (a, b) {
} }
return true; return true;
case 'hash-map': case 'hash-map':
var akeys = Object.keys(a).sort(), if (Object.keys(a).length !== Object.keys(b).length) { return false; }
bkeys = Object.keys(b).sort(); for (var k in a) {
if (akeys.length !== bkeys.length) { return false; } if (! _equal_Q(a[k], b[k])) { return false; }
for (var i=0; i<akeys.length; i++) {
if (akeys[i] !== bkeys[i]) { return false; }
if (! equal_Q(a[akeys[i]], b[bkeys[i]])) { return false; }
} }
return true; return true;
default: default:

10
julia/types.jl
View File

@ -41,6 +41,16 @@ function equal_Q(a, b)
tuple(a...) == tuple(b...) tuple(a...) == tuple(b...)
elseif isa(a,AbstractString) elseif isa(a,AbstractString)
a == b a == b
elseif isa(a,Dict)
if length(a) !== length(b)
return false
end
for (k,v) in a
if !equal_Q(v,b[k])
return false
end
end
return true
else else
a === b a === b
end end

6
lua/types.lua
View File

@ -17,6 +17,12 @@ function M._equal_Q(a,b)
if not M._equal_Q(v,b[i]) then return false end if not M._equal_Q(v,b[i]) then return false end
end end
return true return true
elseif M._hash_map_Q(a) and M._hash_map_Q(b) then
if #a ~= #b then return false end
for k, v in pairs(a) do
if not M._equal_Q(v,b[k]) then return false end
end
return true
else else
return a == b return a == b
end end

16
make/types.mk
View File

@ -111,16 +111,26 @@ _clone_obj = $(strip \
$(eval $(new_obj)_value := $(strip $($(1)_value)))))\ $(eval $(new_obj)_value := $(strip $($(1)_value)))))\
$(new_obj)))) $(new_obj))))
_hash_equal? = $(strip \
$(if $(and $(call _EQ,$(foreach v,$(call __get_obj_values,$(1)),$(word 4,$(subst _, ,$(v)))),$(foreach v,$(call __get_obj_values,$(2)),$(word 4,$(subst _, ,$(v))))),\
$(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(foreach v,$(call __get_obj_values,$(1)),$($(v))),\
$(foreach v,$(call __get_obj_values,$(2)),$($(v))))))),\
$(__true),))
_equal? = $(strip \ _equal? = $(strip \
$(foreach ot1,$(call _obj_type,$(1)),$(foreach ot2,$(call _obj_type,$(2)),\ $(foreach ot1,$(call _obj_type,$(1)),$(foreach ot2,$(call _obj_type,$(2)),\
$(if $(or $(call _EQ,$(ot1),$(ot2)),\ $(if $(or $(call _EQ,$(ot1),$(ot2)),\
$(and $(call _sequential?,$(1)),$(call _sequential?,$(2)))),\ $(and $(call _sequential?,$(1)),$(call _sequential?,$(2)))),\
$(if $(or $(call _string?,$(1)),$(call _symbol?,$(1)),$(call _keyword?,$(1)),$(call _number?,$(1))),\ $(if $(or $(call _string?,$(1)),$(call _symbol?,$(1)),$(call _keyword?,$(1)),$(call _number?,$(1))),\
$(call _EQ,$($(1)_value),$($(2)_value)),\ $(call _EQ,$($(1)_value),$($(2)_value)),\
$(if $(or $(call _vector?,$(1)),$(call _list?,$(1)),$(call _hash_map?,$(1))),\ $(if $(call _hash_map?,$(1)),\
$(call _hash_equal?,$(1),$(2)),\
$(if $(or $(call _vector?,$(1)),$(call _list?,$(1))),\
$(if $(and $(call _EQ,$(call _count,$(1)),$(call _count,$(2))),\ $(if $(and $(call _EQ,$(call _count,$(1)),$(call _count,$(2))),\
$(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(call __get_obj_values,$(1)),$(call __get_obj_values,$(2)))))),$(__true),),\ $(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(call __get_obj_values,$(1)),\
$(call _EQ,$(1),$(2)))))))) $(call __get_obj_values,$(2)))))),\
$(__true),),\
$(call _EQ,$(1),$(2)))))))))
_undefined? = $(or $(call _EQ,undefined,$(origin $(1))),$(filter $(__undefined),$($(1)))) _undefined? = $(or $(call _EQ,undefined,$(origin $(1))),$(filter $(__undefined),$($(1))))

5
mal/Makefile
View File

@ -5,7 +5,10 @@ SOURCES_BASE =
SOURCES_LISP = env.mal core.mal stepA_mal.mal SOURCES_LISP = env.mal core.mal stepA_mal.mal
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
all: all: mal.mal
mal.mal: stepA_mal.mal
cp $< $@
#.PHONY: stats tests $(TESTS) #.PHONY: stats tests $(TESTS)
.PHONY: stats .PHONY: stats

19
miniMAL/types.json
View File

@ -10,14 +10,31 @@
["_cmp_seqs", ["rest", "a"], ["rest", "b"]], ["_cmp_seqs", ["rest", "a"], ["rest", "b"]],
false]]]]], false]]]]],
["def", "_check_hash_map_keys", ["fn", ["ks", "a", "b"],
["if", ["empty?", "ks"],
true,
["let", ["k", ["first", "ks"]],
["if", ["equal?", ["get", "a", "k"], ["get", "b", "k"]],
["_check_hash_map_keys", ["rest", "ks"], "a", "b"],
false]]]]],
["def", "_cmp_hash_maps", ["fn", ["a", "b"],
["let", ["aks", ["keys", "a"]],
["if", ["not", ["=", ["count", "aks"], ["count", ["keys", "b"]]]],
false,
["_check_hash_map_keys", "aks", "a", "b"]]]]],
["def", "equal?", ["fn", ["a", "b"], ["def", "equal?", ["fn", ["a", "b"],
["if", ["sequential?", "a"], ["if", ["sequential?", "a"],
["if", ["sequential?", "b"], ["if", ["sequential?", "b"],
["_cmp_seqs", "a", "b"], ["_cmp_seqs", "a", "b"],
false], false],
["if", ["map?", "a"],
["if", ["map?", "b"],
["_cmp_hash_maps", "a", "b"],
false],
["if", ["symbol?", "a"], ["if", ["symbol?", "a"],
["=", ["get", "a", ["`", "val"]], ["get", "b", ["`", "val"]]], ["=", ["get", "a", ["`", "val"]], ["get", "b", ["`", "val"]]],
["=", "a", "b"]]]]], ["=", "a", "b"]]]]]],
["def", "_clone", ["fn", ["obj"], ["def", "_clone", ["fn", ["obj"],
["if", ["list?", "obj"], ["if", ["list?", "obj"],

12
perl/types.pm
View File

@ -28,7 +28,7 @@ sub _equal_Q {
return $$a eq $$b; return $$a eq $$b;
} }
when (/^List/ || /^Vector/) { when (/^List/ || /^Vector/) {
if (! scalar(@{$a->{val}}) == scalar(@{$b->{val}})) { if (! (scalar(@{$a->{val}}) == scalar(@{$b->{val}}))) {
return 0; return 0;
} }
for (my $i=0; $i<scalar(@{$a->{val}}); $i++) { for (my $i=0; $i<scalar(@{$a->{val}}); $i++) {
@ -39,7 +39,15 @@ sub _equal_Q {
return 1; return 1;
} }
when (/^HashMap/) { when (/^HashMap/) {
die "TODO: Hash map comparison\n"; if (! (scalar(keys $a->{val}) == scalar(keys $b->{val}))) {
return 0;
}
foreach my $k (keys $a->{val}) {
if (!_equal_Q($a->{val}->{$k}, $b->{val}->{$k})) {
return 0;
}
}
return 1;
} }
default { default {
return $$a eq $$b; return $$a eq $$b;

10
php/types.php
View File

@ -27,6 +27,16 @@ function _equal_Q($a, $b) {
if (!_equal_Q($a[$i], $b[$i])) { return false; } if (!_equal_Q($a[$i], $b[$i])) { return false; }
} }
return true; return true;
} elseif (_hash_map_Q($a)) {
if ($a->count() !== $b->count()) { return false; }
$hm1 = $a->getArrayCopy();
$hm2 = $b->getArrayCopy();
foreach (array_keys($hm1) as $k) {
if ($hm1[$k] !== $hm2[$k]) {
return false;
}
}
return true;
} else { } else {
return $a === $b; return $a === $b;
} }

18
ps/core.ps
View File

@ -42,13 +42,8 @@ end } def
dup null eq { %if hash_map is a nil dup null eq { %if hash_map is a nil
pop pop null pop pop null
}{ %else hash_map is not a nil }{ %else hash_map is not a nil
/data get % stack: args dict exch 1 _nth % stack: hash_map key
exch 1 _nth % stack: dict key _hash_map_get
2 copy known { %if has key
get
}{
pop pop null
} ifelse
} ifelse } ifelse
} def } def
@ -59,13 +54,6 @@ end } def
known known
} def } def
% [hashmap] -> keys -> key_list
/keys {
0 _nth /data get
[ exch { pop dup length string cvs } forall ]
_list_from_array
} def
% [hashmap] -> vals -> val_list % [hashmap] -> vals -> val_list
/vals { /vals {
0 _nth /data get 0 _nth /data get
@ -261,7 +249,7 @@ end } def
(dissoc) { dissoc } (dissoc) { dissoc }
(get) { hash_map_get } (get) { hash_map_get }
(contains?) { contains? } (contains?) { contains? }
(keys) { keys } (keys) { 0 _nth _keys }
(vals) { vals } (vals) { vals }
(sequential?) { 0 _nth _sequential? } (sequential?) { 0 _nth _sequential? }

43
ps/types.ps
View File

@ -58,15 +58,13 @@ end } def
/_equal? { 6 dict begin /_equal? { 6 dict begin
/b exch def /b exch def
/a exch def /a exch def
/ota a type def
/otb b type def
a type b type eq a type b type eq
a _sequential? b _sequential? and a _sequential? b _sequential? and
or not { %if type mismatch and not sequential or not { %if type mismatch and not sequential
false false
}{ }{
a _sequential? { %if list a _sequential? b _sequential? and { %if list/vector
/ret true def /ret true def
a _count b _count eq not { %if length mismatch a _count b _count eq not { %if length mismatch
/ret false def /ret false def
@ -80,8 +78,25 @@ end } def
} for } for
} ifelse } ifelse
ret ret
}{ %else not a list }{ %else not list/vector
a b eq a _hash_map? b _hash_map? and { %if hash_map
/ret true def
/a_keys a _keys def
a_keys _count b _keys _count eq not {
/ret false def
}{
a_keys /data get { %foreach key in a_keys
/key exch def
a key _hash_map_get b key _hash_map_get _equal? not { %if not items _equal?
/ret false def
exit
} if
} forall
} ifelse
ret
}{ %else not hash_map
a b eq
} ifelse
} ifelse } ifelse
} ifelse } ifelse
end } def end } def
@ -122,6 +137,24 @@ end } def
_list_from_array _list_from_array
} def } def
% hashmap -> _keys -> key_list
/_keys {
/data get
[ exch { pop dup length string cvs } forall ]
_list_from_array
} def
% hashmap key -> _hash_map_get -> val
/_hash_map_get {
exch % stack: key hashmap
/data get % stack: key dict
exch % stack: dict key
2 copy known { %if has key
get
}{
pop pop null
} ifelse
} def
% Errors/Exceptions % Errors/Exceptions

2
python/mal_types.py
View File

@ -36,7 +36,7 @@ def _equal_Q(a, b):
if len(akeys) != len(bkeys): return False if len(akeys) != len(bkeys): return False
for i in range(len(akeys)): for i in range(len(akeys)):
if akeys[i] != bkeys[i]: return False if akeys[i] != bkeys[i]: return False
if not equal_Q(a[akeys[i]], b[bkeys[i]]): return False if not _equal_Q(a[akeys[i]], b[bkeys[i]]): return False
return True return True
else: else:
return a == b return a == b

39
rpython/mal_types.py
View File

@ -1,7 +1,19 @@
import sys, copy, types as pytypes import sys, copy, types as pytypes
IS_RPYTHON = sys.argv[0].endswith('rpython')
if IS_RPYTHON:
from rpython.rlib.listsort import TimSort
else:
import re
# General functions # General functions
class StringSort(TimSort):
def lt(self, a, b):
assert isinstance(a, unicode)
assert isinstance(b, unicode)
return a < b
def _equal_Q(a, b): def _equal_Q(a, b):
assert isinstance(a, MalType) and isinstance(b, MalType) assert isinstance(a, MalType) and isinstance(b, MalType)
ota, otb = a.__class__, b.__class__ ota, otb = a.__class__, b.__class__
@ -18,16 +30,23 @@ def _equal_Q(a, b):
for i in range(len(a)): for i in range(len(a)):
if not _equal_Q(a[i], b[i]): return False if not _equal_Q(a[i], b[i]): return False
return True return True
## elif _hash_map_Q(a): elif _hash_map_Q(a):
## akeys = a.keys() assert isinstance(a, MalHashMap)
## akeys.sort() assert isinstance(b, MalHashMap)
## bkeys = b.keys() akeys = a.dct.keys()
## bkeys.sort() bkeys = b.dct.keys()
## if len(akeys) != len(bkeys): return False if len(akeys) != len(bkeys): return False
## for i in range(len(akeys)):
## if akeys[i] != bkeys[i]: return False StringSort(akeys).sort()
## if not equal_Q(a[akeys[i]], b[bkeys[i]]): return False StringSort(bkeys).sort()
## return True for i in range(len(akeys)):
ak, bk = akeys[i], bkeys[i]
assert isinstance(ak, unicode)
assert isinstance(bk, unicode)
if ak != bk: return False
av, bv = a.dct[ak], b.dct[bk]
if not _equal_Q(av, bv): return False
return True
elif a is b: elif a is b:
return True return True
else: else:

8
runtest.py
View File

@ -49,8 +49,8 @@ parser.add_argument('--log-file', type=str,
help="Write messages to the named file in addition the screen") help="Write messages to the named file in addition the screen")
parser.add_argument('--debug-file', type=str, parser.add_argument('--debug-file', type=str,
help="Write all test interaction the named file") help="Write all test interaction the named file")
parser.add_argument('--soft', action='store_true', parser.add_argument('--hard', action='store_true',
help="Report but do not fail tests after ';>>> soft=True'") help="Turn soft tests following a ';>>> soft=True' into hard failures")
parser.add_argument('test_file', type=argparse.FileType('r'), parser.add_argument('test_file', type=argparse.FileType('r'),
help="a test file formatted as with mal test data") help="a test file formatted as with mal test data")
@ -252,13 +252,13 @@ while t.next():
log(" -> SUCCESS") log(" -> SUCCESS")
pass_cnt += 1 pass_cnt += 1
else: else:
if args.soft and t.soft: if t.soft and not args.hard:
log(" -> SOFT FAIL (line %d):" % t.line_num) log(" -> SOFT FAIL (line %d):" % t.line_num)
soft_fail_cnt += 1 soft_fail_cnt += 1
else: else:
log(" -> FAIL (line %d):" % t.line_num) log(" -> FAIL (line %d):" % t.line_num)
fail_cnt += 1 fail_cnt += 1
log(" Expected : %s" % repr(expected)) log(" Expected : %s" % repr(expected[0]))
log(" Got : %s" % repr(res)) log(" Got : %s" % repr(res))
except: except:
_, exc, _ = sys.exc_info() _, exc, _ = sys.exc_info()

26
tcl/Dockerfile Normal file
View File

@ -0,0 +1,26 @@
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
ENV HOME /mal

12
tcl/Makefile Normal file
View 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
View 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
View 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
}
}

54
tcl/mal_readline.tcl Normal file
View File

@ -0,0 +1,54 @@
if {[lindex $argv 0] == "--raw"} {
set ::readline_mode "raw"
set argv [lrange $argv 1 end]
incr argc -1
} else {
if {[catch {package require tclreadline}]} {
set ::readline_mode "raw"
} else {
set ::readline_mode "library"
}
}
set ::historyfile "$env(HOME)/.mal-history"
set ::readline_library_initalized 0
proc readline_library_init {} {
if {$::readline_library_initalized} {
return
}
::tclreadline::readline initialize $::historyfile
::tclreadline::readline builtincompleter 0
::tclreadline::readline customcompleter ""
set ::readline_library_initalized 1
}
proc _readline_library prompt {
readline_library_init
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
}
proc _readline_raw prompt {
puts -nonewline $prompt
flush stdout
if {[gets stdin line] < 0} {
return {"EOF" ""}
}
list "OK" $line
}
proc _readline prompt {
if {$::readline_mode == "library"} {
_readline_library $prompt
} else {
_readline_raw $prompt
}
}

56
tcl/printer.tcl Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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"}
}

11
tests/step0_repl.mal
View File

@ -1,14 +1,17 @@
hello world ;; Testing basic string
;=>hello world
abcABC123 abcABC123
;=>abcABC123 ;=>abcABC123
;; Testing string containing spaces
hello mal world
;=>hello mal world
;; Testing string containing symbols
[]{}"'* ;:() []{}"'* ;:()
;=>[]{}"'* ;:() ;=>[]{}"'* ;:()
;;; Test long line ;; Test long string
hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*)
;=>hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) ;=>hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*)

18
tests/step9_try.mal
View File

@ -261,4 +261,22 @@
;=>true ;=>true
;; ------- Optional Functionality --------------
;; ------- (Not needed for self-hosting) -------
;>>> soft=True
;; Testing equality of hash-maps
(= {} {})
;=>true
(= {:a 11 :b 22} (hash-map :b 22 :a 11))
;=>true
(= {:a 11 :b 22} (hash-map :b 23 :a 11))
;=>false
(= {:a 11 :b 22} (hash-map :a 11))
;=>false
(= {:a 11 :b 22} (list :a 11 :b 22))
;=>false
(= {} [])
;=>false
(= [] {})
;=>false