Interpret refs

src/ludus/interpreter.clj

@@ -33,14 +33,14 @@
     (= 0 (:length pattern) (dec (count value))) {:success true :ctx {}}
 
     :else (let [members (:members pattern)]
-      (loop [i (:length pattern)
+            (loop [i (:length pattern)
-       ctx {}]
+                   ctx {}]
-       (if (= 0 i)
+              (if (= 0 i)
-        {:success true :ctx ctx}
+                {:success true :ctx ctx}
-        (let [match? (match (nth members (dec i)) (nth value i) ctx-vol)]
+                (let [match? (match (nth members (dec i)) (nth value i) ctx-vol)]
-          (if (:success match?)
+                  (if (:success match?)
-            (recur (dec i) (merge ctx (:ctx match?)))
+                    (recur (dec i) (merge ctx (:ctx match?)))
-            {:success false :reason (str "Could not match " pattern " with " value)})))))))
+                    {:success false :reason (str "Could not match " pattern " with " value)})))))))
 
 (defn- match [pattern value ctx-vol]
   (let [ctx @ctx-vol]
@@ -71,10 +71,10 @@
 ;; TODO: get typed exceptions to distinguish panics
 (defn- interpret-let [ast ctx]
   (let [pattern (:pattern ast)
-    expr (:expr ast)
+        expr (:expr ast)
-    value (interpret-ast expr ctx)
+        value (interpret-ast expr ctx)
-    match (match pattern value ctx)
+        match (match pattern value ctx)
-    success (:success match)]
+        success (:success match)]
     (if success
       (vswap! ctx update-ctx (:ctx match))
       (throw (ex-info (:reason match) {})))
@@ -82,42 +82,42 @@
 
 (defn- interpret-if [ast ctx]
   (let [if-expr (:if ast)
-    then-expr (:then ast)
+        then-expr (:then ast)
-    else-expr (:else ast)
+        else-expr (:else ast)
-    if-value (interpret-ast if-expr ctx)]
+        if-value (interpret-ast if-expr ctx)]
     (if if-value
       (interpret-ast then-expr ctx)
       (interpret-ast else-expr ctx))))
 
 (defn- interpret-match [ast ctx]
   (let [match-expr (:expr ast)
-    expr (interpret-ast match-expr ctx)
+        expr (interpret-ast match-expr ctx)
-    clauses (:clauses ast)]
+        clauses (:clauses ast)]
     (loop [clause (first clauses)
-     clauses (rest clauses)]
+           clauses (rest clauses)]
-     (if clause
+      (if clause
-      (let [pattern (:pattern clause)
+        (let [pattern (:pattern clause)
-        body (:body clause)
+              body (:body clause)
-        new-ctx (volatile! {::parent ctx})
+              new-ctx (volatile! {::parent ctx})
-        match? (match pattern expr new-ctx)
+              match? (match pattern expr new-ctx)
-        success (:success match?)
+              success (:success match?)
-        clause-ctx (:ctx match?)]
+              clause-ctx (:ctx match?)]
-        (if success
+          (if success
-          (do
+            (do
-            (vswap! new-ctx #(merge % clause-ctx))
+              (vswap! new-ctx #(merge % clause-ctx))
-            (interpret-ast body new-ctx))
+              (interpret-ast body new-ctx))
-          (recur (first clauses) (rest clauses))))
+            (recur (first clauses) (rest clauses))))
-      (throw (ex-info "Match Error: No match found" {}))))))
+        (throw (ex-info "Match Error: No match found" {}))))))
 
 (defn- interpret-cond [ast ctx]
   (let [clauses (:clauses ast)]
     (loop [clause (first clauses)
-      clauses (rest clauses)]
+           clauses (rest clauses)]
       (if (not clause)
         (throw (ex-info "Cond Error: No match found" {}))
         (let [test-expr (:test clause)
-          body (:body clause)
+              body (:body clause)
-          truthy? (boolean (interpret-ast test-expr ctx))]
+              truthy? (boolean (interpret-ast test-expr ctx))]
           (if truthy?
             (interpret-ast body ctx)
             (recur (first clauses) (rest clauses))
@@ -131,7 +131,7 @@
   (if (not (= 1 (:length tuple)))
     (throw (ex-info "Called keywords must be unary" {}))
     (let [kw (interpret-ast kw ctx)
-      map (second (interpret-ast tuple ctx))]
+          map (second (interpret-ast tuple ctx))]
       (if (::data/struct map)
         (if (contains? map kw)
           (kw map)
@@ -147,34 +147,34 @@
     {::data/type ::data/clj
      :name (str (:name lfn) "{partial}")
      :body (fn [arg] 
-      (call-fn 
+             (call-fn 
-        lfn 
+               lfn 
-        (concat [::data/tuple] (replace {::data/placeholder arg} (rest tuple))) 
+               (concat [::data/tuple] (replace {::data/placeholder arg} (rest tuple))) 
-        ctx))}
+               ctx))}
 
-     (= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple))
+    (= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple))
 
-     (= (::data/type lfn) ::data/fn)
+    (= (::data/type lfn) ::data/fn)
-     (let [clauses (:clauses lfn)]
+    (let [clauses (:clauses lfn)]
       (loop [clause (first clauses)
-       clauses (rest clauses)]
+             clauses (rest clauses)]
-       (if clause
+        (if clause
-        (let [pattern (:pattern clause)
+          (let [pattern (:pattern clause)
-          body (:body clause)
+                body (:body clause)
-          new-ctx (volatile! {::parent ctx})
+                new-ctx (volatile! {::parent ctx})
-          match? (match pattern tuple new-ctx)
+                match? (match pattern tuple new-ctx)
-          success (:success match?)
+                success (:success match?)
-          clause-ctx (:ctx match?)]
+                clause-ctx (:ctx match?)]
-          (if success
+            (if success
-            (do
+              (do
-              (vswap! new-ctx #(merge % clause-ctx))
+                (vswap! new-ctx #(merge % clause-ctx))
-              (interpret-ast body new-ctx))
+                (interpret-ast body new-ctx))
-            (recur (first clauses) (rest clauses))))
+              (recur (first clauses) (rest clauses))))
 
-        (throw (ex-info "Match Error: No match found" {:fn-name (:name lfn)})))))
+          (throw (ex-info "Match Error: No match found" {:fn-name (:name lfn)})))))
 
-     (keyword? lfn)
+    (keyword? lfn)
-     (if (= 2 (count tuple))
+    (if (= 2 (count tuple))
       (let [target (second tuple) kw lfn]
         (if (::data/struct target)
           (if (contains? target kw)
@@ -187,7 +187,7 @@
           (kw target)))
       (throw (ex-info "Called keywords take a single argument" {})))
 
-     :else (throw (ex-info "I don't know how to call that" {:fn lfn}))))
+    :else (throw (ex-info "I don't know how to call that" {:fn lfn}))))
 
 (defn- interpret-synthetic-term [prev-value curr ctx]
   (let [type (::ast/type curr)]
@@ -203,25 +203,25 @@
 
 (defn- interpret-synthetic [ast ctx]
   (let [terms (:terms ast)
-    first (first terms)
+        first (first terms)
-    second (second terms)
+        second (second terms)
-    rest (rest (rest terms))
+        rest (rest (rest terms))
-    first-term-type (::ast/type first)
+        first-term-type (::ast/type first)
-    first-val (if (= first-term-type ::ast/atom)
+        first-val (if (= first-term-type ::ast/atom)
-      (interpret-called-kw first second ctx)
+                    (interpret-called-kw first second ctx)
-      (interpret-synthetic-term (interpret-ast first ctx) second ctx))]
+                    (interpret-synthetic-term (interpret-ast first ctx) second ctx))]
     (reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)))
 
 (defn- interpret-fn [ast ctx]
   (let [name (:name ast)
-    clauses (:clauses ast)]
+        clauses (:clauses ast)]
     (if (= name ::ast/anon)
       {::data/type ::data/fn
        :name name
        :clauses clauses}
-       (let [fn {::data/type ::data/fn
+      (let [fn {::data/type ::data/fn
-        :name name
+                :name name
-        :clauses clauses}]
+                :clauses clauses}]
         (if (contains? @ctx name)
           (throw (ex-info (str "Name " name " is already bound") {}))
           (do
@@ -230,14 +230,14 @@
 
 (defn- interpret-do [ast ctx]
   (let [exprs (:exprs ast)
-    origin (interpret-ast (first exprs) ctx)
+        origin (interpret-ast (first exprs) ctx)
-    fns (rest exprs)]
+        fns (rest exprs)]
     (reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) origin fns)))
 
 (defn- map-values [f]
   (map (fn [kv]
-   (let [[k v] kv]
+         (let [[k v] kv]
-     [k (f v)]))))
+           [k (f v)]))))
 
 (defn- interpret-ns [ast ctx]
   (let [members (:members ast) 
@@ -245,27 +245,37 @@
     (if (contains? @ctx name)
       (throw (ex-info (str "ns name " name " is already bound") {}))
       (let [ns (into
-        {::data/struct true ::data/type ::data/ns ::data/name name}
+                 {::data/struct true ::data/type ::data/ns ::data/name name}
-        (map-values #(interpret-ast % ctx))
+                 (map-values #(interpret-ast % ctx))
-        members)]
+                 members)]
-      (do
+        (do
-        (vswap! ctx update-ctx {name ns})
+          (vswap! ctx update-ctx {name ns})
-        ns)))))
+          ns)))))
 
 (defn- interpret-import [ast ctx]
   (let [path (:path ast)
-    name (:name ast)]
+        name (:name ast)]
     (if (contains? @ctx name)
       (throw (ex-info (str "Name " name " is alrady bound") {}))
-  (let [result  ;; TODO: add any error handling at all   
+      (let [result  ;; TODO: add any error handling at all   
-    (-> path
+            (-> path
-          (slurp)
+              (slurp)
-          (scanner/scan)
+              (scanner/scan)
-          (parser/parse)
+              (parser/parse)
-          (interpret))]
+              (interpret))]
-    (vswap! ctx update-ctx {name result})
+        (vswap! ctx update-ctx {name result})
-    result ;; TODO: test this!
+        result ;; TODO: test this!
-    ))))
+        ))))
+
+(defn- interpret-ref [ast ctx]
+  (let [name (:name ast) expr (:expr ast)]
+    (if (contains? @ctx name)
+      (throw (ex-info (str "Name " name " is already bound") {})))
+    (let [value (interpret-ast expr ctx)
+          box (atom value)
+          ref {::data/ref true ::data/value box ::data/name name}]
+      (vswap! ctx update-ctx {name ref})
+      ref)))
 
 (defn interpret-ast [ast ctx]
   (case (::ast/type ast)
@@ -294,19 +304,21 @@
 
     ::ast/import (interpret-import ast ctx)
 
+    ::ast/ref (interpret-ref ast ctx)
+
     ::ast/block
     (let [exprs (:exprs ast)
-      inner (pop exprs)
+          inner (pop exprs)
-      last (peek exprs)
+          last (peek exprs)
-      ctx (volatile! {::parent ctx})]
+          ctx (volatile! {::parent ctx})]
       (run! #(interpret-ast % ctx) inner)
       (interpret-ast last ctx))
 
     ::ast/script
     (let [exprs (:exprs ast)
-      inner (pop exprs)
+          inner (pop exprs)
-      last (peek exprs)
+          last (peek exprs)
-      ctx (volatile! prelude/prelude)]
+          ctx (volatile! prelude/prelude)]
       (run! #(interpret-ast % ctx) inner)
       (interpret-ast last ctx))
 
@@ -346,23 +358,28 @@
       (pp/pprint (ex-data e))
       (System/exit 67))))
 
-(comment
+(defn interpret-safe [parsed]
+  (try 
+    (interpret-ast (::parser/ast parsed) {})
+    (catch clojure.lang.ExceptionInfo e
+      (println "Ludus panicked!")
+      (println (ex-message e))
+      (pp/pprint (ex-data e)))))
+
+(do
 
   (def source "
 
-    let foo = 2
+    fn swap! (r, f) -> {
-
+      let val = deref (r)
-    match foo with {
+      let new = f (val)
-      1 -> :one
+      set! (r, new)
-      2 -> :two
-      else -> :oops
     }
 
-    ns bar {
+    ref foo = 0
-      foo
-    }
 
-    bar :foo
+    swap! (foo, inc)
+    swap! (foo, inc)
 
     ")
 
@@ -374,7 +391,7 @@
   (-> source
     (scanner/scan)
     (parser/parse)
-    (interpret)
+    (interpret-safe)
     (pp/pprint)))
 
 (comment "