From: Vasilij Schneidermann <mail@vasilij.de>
Date: Sun, 9 Jul 2017 08:51:56 +0000 (+0200)
Subject: Implement step 9
X-Git-Url: https://git.hcoop.net/jackhill/mal.git/commitdiff_plain/d38ab263fe3884146e53f928a626868d9f6e8351

Implement step 9
---

diff --git a/gst/core.st b/gst/core.st
index 13708bde..62db39cd 100644
--- a/gst/core.st
+++ b/gst/core.st
@@ -10,6 +10,14 @@ Object subclass: Core [
         block value ifTrue: [ ^MALObject True ] ifFalse: [ ^MALObject False ]
     ]
 
+    Core class >> nilable: args else: block [
+        args first type = #nil ifTrue: [
+            ^MALObject Nil
+        ] ifFalse: [
+            ^block value
+        ]
+    ]
+
     Core class >> printedArgs: args readable: readable sep: sep [
         | items |
         items := args collect:
@@ -63,6 +71,8 @@ Core Ns at: #'read-string' put:
     [ :args | Reader readStr: args first value ].
 Core Ns at: #slurp put:
     [ :args | MALString new: (File path: args first value) contents ].
+Core Ns at: #throw put:
+    [ :args | MALCustomError new signal: args first ].
 
 Core Ns at: #atom put:
     [ :args | MALAtom new: args first ].
@@ -98,21 +108,93 @@ Core Ns at: #nth put:
         items at: index ifAbsent: [ MALOutOfBounds new signal ]
     ].
 Core Ns at: #first put:
-    [ :args |
-        args first type = #nil ifTrue: [
-            MALObject Nil
-        ] ifFalse: [
-            args first value at: 1 ifAbsent: [ MALObject Nil ].
-        ]
-    ].
+    [ :args | Core nilable: args else: [
+        args first value at: 1 ifAbsent: [ MALObject Nil ] ] ].
 Core Ns at: #rest put:
     [ :args |
         | items rest |
         items := args first value.
-        (args first type = #nil or: [ items isEmpty ]) ifTrue: [
+        (args first type = #nil or: [ items isEmpty  ]) ifTrue: [
             rest := {}
         ] ifFalse: [
             rest := items allButFirst
         ].
         MALList new: (OrderedCollection from: rest)
     ].
+
+Core Ns at: #apply put:
+    [ :args |
+        | f rest result |
+        f := args first.
+        f class = Func ifTrue: [ f := f fn ].
+        args size < 3 ifTrue: [
+            rest := {}
+        ] ifFalse: [
+            rest := args copyFrom: 2 to: args size - 1
+        ].
+        rest := rest, args last value.
+        f value: rest
+    ].
+Core Ns at: #map put:
+    [ :args |
+        | items f result |
+        f := args first.
+        f class = Func ifTrue: [ f := f fn ].
+        items := args second value.
+        result := items collect: [ :item | f value: {item} ].
+        MALList new: (OrderedCollection from: result)
+    ].
+
+Core Ns at: #'nil?' put:
+    [ :args | Core coerce: [ args first type = #nil ] ].
+Core Ns at: #'true?' put:
+    [ :args | Core coerce: [ args first type = #true ] ].
+Core Ns at: #'false?' put:
+    [ :args | Core coerce: [ args first type = #false ] ].
+Core Ns at: #'symbol?' put:
+    [ :args | Core coerce: [ args first type = #symbol ] ].
+Core Ns at: #'keyword?' put:
+    [ :args | Core coerce: [ args first type = #keyword ] ].
+Core Ns at: #'vector?' put:
+    [ :args | Core coerce: [ args first type = #vector ] ].
+Core Ns at: #'map?' put:
+    [ :args | Core coerce: [ args first type = #map ] ].
+Core Ns at: #'sequential?' put:
+    [ :args | Core coerce: [ args first type = #list or:
+                            [ args first type = #vector ] ] ].
+
+Core Ns at: #symbol put:
+    [ :args | MALSymbol new: args first value asSymbol ].
+Core Ns at: #keyword put:
+    [ :args | MALKeyword new: args first value asSymbol ].
+Core Ns at: #vector put:
+    [ :args | MALVector new: (OrderedCollection from: args) ].
+Core Ns at: #'hash-map' put:
+    [ :args | MALMap new: args asDictionary ].
+
+Core Ns at: #assoc put:
+    [ :args |
+        | result keyVals |
+        result := Dictionary from: args first value associations.
+        keyVals := args allButFirst.
+        1 to: keyVals size by: 2 do:
+            [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ].
+        MALMap new: result
+    ].
+Core Ns at: #dissoc put:
+    [ :args |
+        | result keys |
+        result := Dictionary from: args first value associations.
+        keys := args allButFirst.
+        keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ].
+        MALMap new: result
+    ].
+Core Ns at: #get put:
+    [ :args | Core nilable: args else:
+        [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ].
+Core Ns at: #'contains?' put:
+    [ :args | Core coerce: [ args first value includesKey: args second ] ].
+Core Ns at: #keys put:
+    [ :args | MALList new: (OrderedCollection from: args first value keys) ].
+Core Ns at: #vals put:
+    [ :args | MALList new: (OrderedCollection from: args first value values) ].
diff --git a/gst/printer.st b/gst/printer.st
index 7079a49a..4bf44d41 100644
--- a/gst/printer.st
+++ b/gst/printer.st
@@ -53,6 +53,6 @@ Object subclass: Printer [
             [ :item |
                 (self prStr: item key printReadably: printReadably), ' ',
                     (self prStr: item value printReadably: printReadably) ].
-        ^'{', (items join: ', '), '}'
+        ^'{', (items join: ' '), '}'
     ]
 ]
diff --git a/gst/step9_try.st b/gst/step9_try.st
new file mode 100644
index 00000000..7b5f6555
--- /dev/null
+++ b/gst/step9_try.st
@@ -0,0 +1,299 @@
+FileStream fileIn: 'readline.st'.
+FileStream fileIn: 'reader.st'.
+FileStream fileIn: 'printer.st'.
+FileStream fileIn: 'env.st'.
+FileStream fileIn: 'func.st'.
+FileStream fileIn: 'core.st'.
+
+Object subclass: MAL [
+    MAL class >> READ: input [
+        ^Reader readStr: input
+    ]
+
+    MAL class >> evalAst: sexp env: env [
+        sexp type = #symbol ifTrue: [
+            ^env get: sexp value
+        ].
+
+        sexp type = #list ifTrue: [
+            ^self evalList: sexp env: env class: MALList
+        ].
+        sexp type = #vector ifTrue: [
+            ^self evalList: sexp env: env class: MALVector
+        ].
+        sexp type = #map ifTrue: [
+            ^self evalList: sexp env: env class: MALMap
+        ].
+
+        ^sexp
+    ]
+
+    MAL class >> evalList: sexp env: env class: aClass [
+        | items |
+        items := sexp value collect:
+            [ :item | self EVAL: item env: env ].
+        ^aClass new: items
+    ]
+
+    MAL class >> quasiquote: ast [
+        | result a a0 a0_ a0_0 a0_1 rest |
+        ast isPair ifFalse: [
+            result := {MALSymbol new: #quote. ast}.
+            ^MALList new: (OrderedCollection from: result)
+        ].
+
+        a := ast value.
+        a0 := a first.
+
+        (a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ].
+
+        a0 isPair ifTrue: [
+            a0_ := a0 value.
+            a0_0 := a0_ first.
+            a0_1 := a0_ second.
+
+            (a0_0 type = #symbol and:
+             [ a0_0 value = #'splice-unquote' ]) ifTrue: [
+                rest := MALList new: a allButFirst.
+                result := {MALSymbol new: #concat. a0_1.
+                           self quasiquote: rest}.
+                ^MALList new: (OrderedCollection from: result)
+            ]
+        ].
+
+        rest := MALList new: a allButFirst.
+        result := {MALSymbol new: #cons. self quasiquote: a0.
+                   self quasiquote: rest}.
+        ^MALList new: (OrderedCollection from: result)
+    ]
+
+    MAL class >> isMacroCall: ast env: env [
+        | a0 a0_ f |
+        ast type = #list ifTrue: [
+            a0 := ast value first.
+            a0_ := a0 value.
+            a0 type = #symbol ifTrue: [
+                f := env find: a0_.
+                (f notNil and: [ f class = Func ]) ifTrue: [
+                    ^f isMacro
+                ]
+            ]
+        ].
+        ^false
+    ]
+
+    MAL class >> macroexpand: aSexp env: env [
+        | sexp |
+
+        "NOTE: redefinition of method arguments is not allowed"
+        sexp := aSexp.
+
+        [ self isMacroCall: sexp env: env ] whileTrue: [
+            | ast a0_ macro rest |
+            ast := sexp value.
+            a0_ := ast first value.
+            macro := env find: a0_.
+            rest := ast allButFirst.
+            sexp := macro fn value: rest.
+        ].
+
+        ^sexp
+    ]
+
+    MAL class >> EVAL: aSexp env: anEnv [
+        | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args |
+
+        "NOTE: redefinition of method arguments is not allowed"
+        sexp := aSexp.
+        env := anEnv.
+
+        [
+            [ :continue |
+                sexp type ~= #list ifTrue: [
+                    ^self evalAst: sexp env: env
+                ].
+                sexp value isEmpty ifTrue: [
+                    ^sexp
+                ].
+
+                sexp := self macroexpand: sexp env: env.
+                sexp type ~= #list ifTrue: [
+                    ^self evalAst: sexp env: env
+                ].
+
+                ast := sexp value.
+                a0 := ast first.
+
+                a0_ := ast first value.
+                a0_ = #'def!' ifTrue: [
+                    | result |
+                    a1_ := ast second value.
+                    a2 := ast third.
+                    result := self EVAL: a2 env: env.
+                    env set: a1_ value: result.
+                    ^result
+                ].
+
+                a0_ = #'defmacro!' ifTrue: [
+                    | result |
+                    a1_ := ast second value.
+                    a2 := ast third.
+                    result := self EVAL: a2 env: env.
+                    result isMacro: true.
+                    env set: a1_ value: result.
+                    ^result
+                ].
+
+                a0_ = #'macroexpand' ifTrue: [
+                    a1 := ast second.
+                    ^self macroexpand: a1 env: env
+                ].
+
+                a0_ = #'let*' ifTrue: [
+                    | env_ |
+                        env_ := Env new: env.
+                    a1_ := ast second value.
+                    a2 := ast third.
+                    1 to: a1_ size by: 2 do:
+                        [ :i | env_ set: (a1_ at: i) value
+                                    value: (self EVAL: (a1_ at: i + 1)
+                                                 env: env_) ].
+                    env := env_.
+                    sexp := a2.
+                    continue value "TCO"
+                ].
+
+                a0_ = #do ifTrue: [
+                    | forms last |
+                    ast size < 2 ifTrue: [
+                        forms := {}.
+                        last := MALObject Nil.
+                    ] ifFalse: [
+                        forms := ast copyFrom: 2 to: ast size - 1.
+                        last := ast last.
+                    ].
+
+                    forms do: [ :form | self EVAL: form env: env ].
+                    sexp := last.
+                    continue value "TCO"
+                ].
+
+                a0_ = #if ifTrue: [
+                    | condition |
+                    a1 := ast second.
+                    a2 := ast third.
+                    a3 := ast at: 4 ifAbsent: [ MALObject Nil ].
+                    condition := self EVAL: a1 env: env.
+
+                    (condition type = #false or:
+                         [ condition type = #nil ]) ifTrue: [
+                             sexp := a3
+                         ] ifFalse: [
+                             sexp := a2
+                         ].
+                    continue value "TCO"
+                ].
+
+                a0_ = #quote ifTrue: [
+                    a1 := ast second.
+                    ^a1
+                ].
+
+                a0_ = #quasiquote ifTrue: [
+                    | result |
+                    a1 := ast second.
+                    sexp := self quasiquote: a1.
+                    continue value "TCO"
+                ].
+
+                a0_ = #'try*' ifTrue: [
+                    | A B C |
+                    A := ast second.
+                    a2_ := ast third value.
+                    B := a2_ second value.
+                    C := a2_ third.
+                    ^[ self EVAL: A env: env ] on: MALError do:
+                        [ :err |
+                            | data env_ result |
+                            data := err data.
+                            data isString ifTrue: [
+                                data := MALString new: data
+                            ].
+                            env_ := Env new: env binds: {B} exprs: {data}.
+                            err return: (self EVAL: C env: env_)
+                        ]
+                ].
+
+                a0_ = #'fn*' ifTrue: [
+                    | binds env_ fn |
+                        a1_ := ast second value.
+                    binds := a1_ collect: [ :item | item value ].
+                    a2 := ast third.
+                    fn := [ :args |
+                        self EVAL: a2 env:
+                            (Env new: env binds: binds exprs: args) ].
+                    ^Func new: a2 params: binds env: env fn: fn
+                ].
+
+                forms := (self evalAst: sexp env: env) value.
+                function := forms first.
+                args := forms allButFirst asArray.
+
+                function class = BlockClosure ifTrue: [ ^function value: args ].
+                function class = Func ifTrue: [
+                    | env_ |
+                    sexp := function ast.
+                    env_ := Env new: function env binds: function params
+                                exprs: args.
+                    env := env_.
+                    continue value "TCO"
+                ]
+            ] valueWithExit
+        ] repeat.
+    ]
+
+    MAL class >> PRINT: sexp [
+        ^Printer prStr: sexp printReadably: true
+    ]
+
+    MAL class >> rep: input env: env [
+        ^self PRINT: (self EVAL: (self READ: input) env: env)
+    ]
+]
+
+| input historyFile replEnv argv |
+
+historyFile := '.mal_history'.
+ReadLine readHistory: historyFile.
+replEnv := Env new: nil.
+
+argv := Smalltalk arguments.
+argv notEmpty ifTrue: [ argv := argv allButFirst ].
+argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]).
+
+Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ].
+replEnv set: #eval value: [ :args | MAL EVAL: args first env: replEnv ].
+replEnv set: #'*ARGV*' value: (MALList new: argv).
+
+MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv.
+MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))' env: replEnv.
+
+MAL rep: '(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)))))))' env: replEnv.
+MAL rep: '(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))))))))' env: replEnv.
+
+Smalltalk arguments notEmpty ifTrue: [
+    MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv
+] ifFalse: [
+    [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [
+        input isEmpty ifFalse: [
+            ReadLine addHistory: input.
+            ReadLine writeHistory: historyFile.
+            [ (MAL rep: input env: replEnv) displayNl ]
+                on: MALEmptyInput do: [ #return ]
+                on: MALError do:
+                    [ :err | ('error: ', err messageText) displayNl. #return ].
+        ]
+    ].
+
+    '' displayNl.
+]
diff --git a/gst/types.st b/gst/types.st
index b9868875..9f3b032a 100644
--- a/gst/types.st
+++ b/gst/types.st
@@ -149,6 +149,8 @@ MALObject subclass: MALAtom [
 Error subclass: MALError [
     description [ ^'A MAL-related error' ]
     isResumable [ ^true ]
+
+    data [ ^self messageText ]
 ]
 
 MALError subclass: MALUnterminatedSequence [
@@ -180,3 +182,10 @@ MALError subclass: MALOutOfBounds [
 
     messageText [ ^'Out of bounds' ]
 ]
+
+MALError subclass: MALCustomError [
+    MALCustomError class >> new [ ^super new ]
+
+    messageText [ ^Printer prStr: self basicMessageText printReadably: true ]
+    data [ ^self basicMessageText ]
+]
diff --git a/gst/util.st b/gst/util.st
index 021caedf..03a226d0 100644
--- a/gst/util.st
+++ b/gst/util.st
@@ -1,4 +1,4 @@
-OrderedCollection extend [
+SequenceableCollection extend [
     asDictionary [
         | dict assoc |
         dict := Dictionary new.