mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 10:07:45 +03:00
Merge remote-tracking branch 'kanaka/master' into kotlin
This commit is contained in:
Javier Fernandez-Ivern
commit
d51639075b
14
.gitignore
vendored
14
.gitignore
vendored
@ -1,13 +1,19 @@
|
||||
*/experiments
|
||||
make/mal.mk
|
||||
*/node_modules
|
||||
js/mal.js
|
||||
js/mal_web.js
|
||||
bash/mal.sh
|
||||
c/*.o
|
||||
*.pyc
|
||||
bash/mal.sh
|
||||
c/mal
|
||||
coffee/mal.coffee
|
||||
crystal/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
|
||||
*/step1_read_print
|
||||
*/step2_eval
|
||||
|
||||
@ -52,6 +52,7 @@ matrix:
|
||||
- env: IMPL=swift NO_DOCKER=1
|
||||
os: osx
|
||||
osx_image: xcode7
|
||||
- env: IMPL=tcl
|
||||
- env: IMPL=vimscript NO_PERF=1 # /dev/stdout not writable
|
||||
- env: IMPL=vb
|
||||
|
||||
|
||||
@ -21,7 +21,7 @@ else
|
||||
MAKE="docker run -it -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl} make"
|
||||
fi
|
||||
|
||||
${MAKE} TEST_OPTS="--soft --debug-file ../${ACTION}.err" \
|
||||
${MAKE} TEST_OPTS="--debug-file ../${ACTION}.err" \
|
||||
MAL_IMPL=${MAL_IMPL} ${ACTION}^${IMPL}
|
||||
|
||||
# no failure so remove error log
|
||||
|
||||
10
Makefile
10
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) --raw $(3)
|
||||
vb_RUNSTEP = mono ../$(2) --raw $(3)
|
||||
vimscript_RUNSTEP = ./run_vimscript.sh ../$(2) $(3)
|
||||
# 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
|
||||
# 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)))):
|
||||
$(MAKE) -C $(dir $(@)) $(notdir $(@))
|
||||
$(foreach impl,$(word 1,$(subst /, ,$(@))),\
|
||||
$(MAKE) -C $(impl) $(subst $(impl)/,,$(@)))
|
||||
|
||||
# Allow test, test^STEP, test^IMPL, and test^IMPL^STEP
|
||||
.SECONDEXPANSION:
|
||||
|
||||
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)*
|
||||
|
||||
@ -81,7 +81,7 @@ _equal? () {
|
||||
case "${ot1}" in
|
||||
string|symbol|keyword|number)
|
||||
[[ "${ANON["${1}"]}" == "${ANON["${2}"]}" ]] ;;
|
||||
list|vector|hash_map)
|
||||
list|vector)
|
||||
_count "${1}"; local sz1="${r}"
|
||||
_count "${2}"; local sz2="${r}"
|
||||
[[ "${sz1}" == "${sz2}" ]] || return 1
|
||||
@ -91,6 +91,20 @@ _equal? () {
|
||||
_equal? "${a1[${i}]}" "${a2[${i}]}" || return 1
|
||||
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}" ]] ;;
|
||||
esac
|
||||
|
||||
21
c/types.c
21
c/types.c
@ -268,6 +268,9 @@ MalVal *_apply(MalVal *f, MalVal *args) {
|
||||
|
||||
|
||||
int _equal_Q(MalVal *a, MalVal *b) {
|
||||
GHashTableIter iter;
|
||||
gpointer key, value;
|
||||
|
||||
if (a == NULL || b == NULL) { return FALSE; }
|
||||
|
||||
// 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;
|
||||
case MAL_HASH_MAP:
|
||||
_error("_equal_Q does not support hash-maps yet");
|
||||
return FALSE;
|
||||
if (g_hash_table_size(a->val.hash_table) !=
|
||||
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_MAL:
|
||||
return a->val.f0 == b->val.f0;
|
||||
|
||||
@ -38,9 +38,7 @@ E._equal_Q = _equal_Q = (a,b) ->
|
||||
bkeys = (key for key of b)
|
||||
return false if akeys.length != bkeys.length
|
||||
for akey,i in akeys
|
||||
bkey = bkeys[i]
|
||||
return false if akey != bkey
|
||||
return false if !_equal_Q(a[akey], b[bkey])
|
||||
return false if !_equal_Q(a[akey], b[akey])
|
||||
true
|
||||
else a == b
|
||||
|
||||
|
||||
13
cs/types.cs
13
cs/types.cs
@ -58,6 +58,19 @@ namespace Mal {
|
||||
}
|
||||
}
|
||||
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 {
|
||||
return a == b;
|
||||
}
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
%% rebar configuration file (https://github.com/rebar/rebar)
|
||||
%%
|
||||
|
||||
{require_otp_vsn, "17"}.
|
||||
{require_otp_vsn, "17|18"}.
|
||||
|
||||
{erl_opts, [debug_info, fail_on_warning]}.
|
||||
|
||||
|
||||
@ -54,7 +54,7 @@ escape_str(String) ->
|
||||
case C of
|
||||
$" -> [C, $\\|AccIn];
|
||||
$\\ -> [C, $\\|AccIn];
|
||||
$\n -> [C, $\\|AccIn];
|
||||
$\n -> [$n, $\\|AccIn];
|
||||
_ -> [C|AccIn]
|
||||
end
|
||||
end,
|
||||
|
||||
@ -216,8 +216,9 @@ lex_string([], _String) ->
|
||||
lex_string([$\\,Escaped|Rest], String) ->
|
||||
% unescape the string while building it
|
||||
case Escaped of
|
||||
[] -> {error, "end of string reached in escape"};
|
||||
_ -> lex_string(Rest, [Escaped|String])
|
||||
[] -> {error, "end of string reached in escape"};
|
||||
$n -> lex_string(Rest, [$\n|String]);
|
||||
_ -> lex_string(Rest, [Escaped|String])
|
||||
end;
|
||||
lex_string([$"|Rest], String) ->
|
||||
{{string, lists:reverse(String)}, Rest};
|
||||
|
||||
@ -34,12 +34,9 @@ export function _equal_Q (a, b) {
|
||||
}
|
||||
return true
|
||||
case 'hash-map':
|
||||
let akeys = Object.keys(a).sort(),
|
||||
bkeys = Object.keys(b).sort()
|
||||
if (akeys.length !== bkeys.length) { 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 }
|
||||
if (a.size !== b.size) { return false }
|
||||
for (let k of a.keys()) {
|
||||
if (! _equal_Q(a.get(k), b.get(k))) { return false }
|
||||
}
|
||||
return true
|
||||
default:
|
||||
|
||||
78
examples/equality.mal
Normal file
78
examples/equality.mal
Normal 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
2
examples/hello.mal
Normal file
@ -0,0 +1,2 @@
|
||||
(println "hello world\n\nanother line")
|
||||
(println "and another line")
|
||||
123
examples/presentation.mal
Executable file
123
examples/presentation.mal
Executable file
@ -0,0 +1,123 @@
|
||||
;; Mal Presentation
|
||||
|
||||
(def! clear
|
||||
(fn* ()
|
||||
(str "[2J[;H")))
|
||||
|
||||
(def! bold
|
||||
(fn* (s)
|
||||
(str "[1m" s "[0m")))
|
||||
|
||||
(def! blue
|
||||
(fn* (s)
|
||||
(str "[1;34m" s "[0m")))
|
||||
|
||||
(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
70
examples/protocols.mal
Normal 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
|
||||
@ -295,7 +295,17 @@ func Equal_Q(a MalType, b MalType) bool {
|
||||
}
|
||||
return true
|
||||
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:
|
||||
return a == b
|
||||
}
|
||||
|
||||
@ -11,6 +11,9 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
|
||||
all:
|
||||
mvn install
|
||||
|
||||
src/main/mal/%.java:
|
||||
mvn install
|
||||
|
||||
#.PHONY: stats tests $(TESTS)
|
||||
.PHONY: stats
|
||||
|
||||
|
||||
@ -64,6 +64,20 @@ public class types {
|
||||
}
|
||||
}
|
||||
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 {
|
||||
return a == b;
|
||||
}
|
||||
|
||||
@ -43,12 +43,9 @@ function _equal_Q (a, b) {
|
||||
}
|
||||
return true;
|
||||
case 'hash-map':
|
||||
var akeys = Object.keys(a).sort(),
|
||||
bkeys = Object.keys(b).sort();
|
||||
if (akeys.length !== bkeys.length) { 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; }
|
||||
if (Object.keys(a).length !== Object.keys(b).length) { return false; }
|
||||
for (var k in a) {
|
||||
if (! _equal_Q(a[k], b[k])) { return false; }
|
||||
}
|
||||
return true;
|
||||
default:
|
||||
|
||||
@ -41,6 +41,16 @@ function equal_Q(a, b)
|
||||
tuple(a...) == tuple(b...)
|
||||
elseif isa(a,AbstractString)
|
||||
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
|
||||
a === b
|
||||
end
|
||||
|
||||
@ -17,6 +17,12 @@ function M._equal_Q(a,b)
|
||||
if not M._equal_Q(v,b[i]) then return false end
|
||||
end
|
||||
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
|
||||
return a == b
|
||||
end
|
||||
|
||||
@ -111,16 +111,26 @@ _clone_obj = $(strip \
|
||||
$(eval $(new_obj)_value := $(strip $($(1)_value)))))\
|
||||
$(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 \
|
||||
$(foreach ot1,$(call _obj_type,$(1)),$(foreach ot2,$(call _obj_type,$(2)),\
|
||||
$(if $(or $(call _EQ,$(ot1),$(ot2)),\
|
||||
$(and $(call _sequential?,$(1)),$(call _sequential?,$(2)))),\
|
||||
$(if $(or $(call _string?,$(1)),$(call _symbol?,$(1)),$(call _keyword?,$(1)),$(call _number?,$(1))),\
|
||||
$(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))),\
|
||||
$(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(call __get_obj_values,$(1)),$(call __get_obj_values,$(2)))))),$(__true),),\
|
||||
$(call _EQ,$(1),$(2))))))))
|
||||
$(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(call __get_obj_values,$(1)),\
|
||||
$(call __get_obj_values,$(2)))))),\
|
||||
$(__true),),\
|
||||
$(call _EQ,$(1),$(2)))))))))
|
||||
|
||||
_undefined? = $(or $(call _EQ,undefined,$(origin $(1))),$(filter $(__undefined),$($(1))))
|
||||
|
||||
|
||||
@ -5,7 +5,10 @@ SOURCES_BASE =
|
||||
SOURCES_LISP = env.mal core.mal stepA_mal.mal
|
||||
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
|
||||
|
||||
all:
|
||||
all: mal.mal
|
||||
|
||||
mal.mal: stepA_mal.mal
|
||||
cp $< $@
|
||||
|
||||
#.PHONY: stats tests $(TESTS)
|
||||
.PHONY: stats
|
||||
|
||||
@ -10,14 +10,31 @@
|
||||
["_cmp_seqs", ["rest", "a"], ["rest", "b"]],
|
||||
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"],
|
||||
["if", ["sequential?", "a"],
|
||||
["if", ["sequential?", "b"],
|
||||
["_cmp_seqs", "a", "b"],
|
||||
false],
|
||||
["if", ["map?", "a"],
|
||||
["if", ["map?", "b"],
|
||||
["_cmp_hash_maps", "a", "b"],
|
||||
false],
|
||||
["if", ["symbol?", "a"],
|
||||
["=", ["get", "a", ["`", "val"]], ["get", "b", ["`", "val"]]],
|
||||
["=", "a", "b"]]]]],
|
||||
["=", "a", "b"]]]]]],
|
||||
|
||||
["def", "_clone", ["fn", ["obj"],
|
||||
["if", ["list?", "obj"],
|
||||
|
||||
@ -28,7 +28,7 @@ sub _equal_Q {
|
||||
return $$a eq $$b;
|
||||
}
|
||||
when (/^List/ || /^Vector/) {
|
||||
if (! scalar(@{$a->{val}}) == scalar(@{$b->{val}})) {
|
||||
if (! (scalar(@{$a->{val}}) == scalar(@{$b->{val}}))) {
|
||||
return 0;
|
||||
}
|
||||
for (my $i=0; $i<scalar(@{$a->{val}}); $i++) {
|
||||
@ -39,7 +39,15 @@ sub _equal_Q {
|
||||
return 1;
|
||||
}
|
||||
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 {
|
||||
return $$a eq $$b;
|
||||
|
||||
@ -27,6 +27,16 @@ function _equal_Q($a, $b) {
|
||||
if (!_equal_Q($a[$i], $b[$i])) { return false; }
|
||||
}
|
||||
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 {
|
||||
return $a === $b;
|
||||
}
|
||||
|
||||
18
ps/core.ps
18
ps/core.ps
@ -42,13 +42,8 @@ end } def
|
||||
dup null eq { %if hash_map is a nil
|
||||
pop pop null
|
||||
}{ %else hash_map is not a nil
|
||||
/data get % stack: args dict
|
||||
exch 1 _nth % stack: dict key
|
||||
2 copy known { %if has key
|
||||
get
|
||||
}{
|
||||
pop pop null
|
||||
} ifelse
|
||||
exch 1 _nth % stack: hash_map key
|
||||
_hash_map_get
|
||||
} ifelse
|
||||
} def
|
||||
|
||||
@ -59,13 +54,6 @@ end } def
|
||||
known
|
||||
} 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
|
||||
/vals {
|
||||
0 _nth /data get
|
||||
@ -261,7 +249,7 @@ end } def
|
||||
(dissoc) { dissoc }
|
||||
(get) { hash_map_get }
|
||||
(contains?) { contains? }
|
||||
(keys) { keys }
|
||||
(keys) { 0 _nth _keys }
|
||||
(vals) { vals }
|
||||
|
||||
(sequential?) { 0 _nth _sequential? }
|
||||
|
||||
43
ps/types.ps
43
ps/types.ps
@ -58,15 +58,13 @@ end } def
|
||||
/_equal? { 6 dict begin
|
||||
/b exch def
|
||||
/a exch def
|
||||
/ota a type def
|
||||
/otb b type def
|
||||
|
||||
a type b type eq
|
||||
a _sequential? b _sequential? and
|
||||
or not { %if type mismatch and not sequential
|
||||
false
|
||||
}{
|
||||
a _sequential? { %if list
|
||||
a _sequential? b _sequential? and { %if list/vector
|
||||
/ret true def
|
||||
a _count b _count eq not { %if length mismatch
|
||||
/ret false def
|
||||
@ -80,8 +78,25 @@ end } def
|
||||
} for
|
||||
} ifelse
|
||||
ret
|
||||
}{ %else not a list
|
||||
a b eq
|
||||
}{ %else not list/vector
|
||||
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
|
||||
end } def
|
||||
@ -122,6 +137,24 @@ end } def
|
||||
_list_from_array
|
||||
} 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
|
||||
|
||||
@ -36,7 +36,7 @@ def _equal_Q(a, b):
|
||||
if len(akeys) != len(bkeys): return False
|
||||
for i in range(len(akeys)):
|
||||
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
|
||||
else:
|
||||
return a == b
|
||||
|
||||
@ -1,7 +1,19 @@
|
||||
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
|
||||
|
||||
class StringSort(TimSort):
|
||||
def lt(self, a, b):
|
||||
assert isinstance(a, unicode)
|
||||
assert isinstance(b, unicode)
|
||||
return a < b
|
||||
|
||||
def _equal_Q(a, b):
|
||||
assert isinstance(a, MalType) and isinstance(b, MalType)
|
||||
ota, otb = a.__class__, b.__class__
|
||||
@ -18,16 +30,23 @@ def _equal_Q(a, b):
|
||||
for i in range(len(a)):
|
||||
if not _equal_Q(a[i], b[i]): return False
|
||||
return True
|
||||
## elif _hash_map_Q(a):
|
||||
## akeys = a.keys()
|
||||
## akeys.sort()
|
||||
## bkeys = b.keys()
|
||||
## bkeys.sort()
|
||||
## if len(akeys) != len(bkeys): return False
|
||||
## for i in range(len(akeys)):
|
||||
## if akeys[i] != bkeys[i]: return False
|
||||
## if not equal_Q(a[akeys[i]], b[bkeys[i]]): return False
|
||||
## return True
|
||||
elif _hash_map_Q(a):
|
||||
assert isinstance(a, MalHashMap)
|
||||
assert isinstance(b, MalHashMap)
|
||||
akeys = a.dct.keys()
|
||||
bkeys = b.dct.keys()
|
||||
if len(akeys) != len(bkeys): return False
|
||||
|
||||
StringSort(akeys).sort()
|
||||
StringSort(bkeys).sort()
|
||||
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:
|
||||
return True
|
||||
else:
|
||||
|
||||
@ -49,8 +49,8 @@ parser.add_argument('--log-file', type=str,
|
||||
help="Write messages to the named file in addition the screen")
|
||||
parser.add_argument('--debug-file', type=str,
|
||||
help="Write all test interaction the named file")
|
||||
parser.add_argument('--soft', action='store_true',
|
||||
help="Report but do not fail tests after ';>>> soft=True'")
|
||||
parser.add_argument('--hard', action='store_true',
|
||||
help="Turn soft tests following a ';>>> soft=True' into hard failures")
|
||||
|
||||
parser.add_argument('test_file', type=argparse.FileType('r'),
|
||||
help="a test file formatted as with mal test data")
|
||||
@ -252,13 +252,13 @@ while t.next():
|
||||
log(" -> SUCCESS")
|
||||
pass_cnt += 1
|
||||
else:
|
||||
if args.soft and t.soft:
|
||||
if t.soft and not args.hard:
|
||||
log(" -> SOFT FAIL (line %d):" % t.line_num)
|
||||
soft_fail_cnt += 1
|
||||
else:
|
||||
log(" -> FAIL (line %d):" % t.line_num)
|
||||
fail_cnt += 1
|
||||
log(" Expected : %s" % repr(expected))
|
||||
log(" Expected : %s" % repr(expected[0]))
|
||||
log(" Got : %s" % repr(res))
|
||||
except:
|
||||
_, exc, _ = sys.exc_info()
|
||||
|
||||
26
tcl/Dockerfile
Normal file
26
tcl/Dockerfile
Normal 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
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
|
||||
}
|
||||
}
|
||||
54
tcl/mal_readline.tcl
Normal file
54
tcl/mal_readline.tcl
Normal 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
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"}
|
||||
}
|
||||
@ -1,14 +1,17 @@
|
||||
hello world
|
||||
;=>hello world
|
||||
|
||||
;; Testing basic string
|
||||
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 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*)
|
||||
|
||||
|
||||
@ -261,4 +261,22 @@
|
||||
;=>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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user