7 files changed, 91 insertions(+), 50 deletions(-)

M main.janet
M src/adverbs.janet
M src/calc.janet
M src/parser.janet
M src/print.janet
M test/calc.janet
M test/regressions.janet

@@ 34,9 34,11 @@
 
         (let [bak (array/slice (s :data))]
           (try (calc/push-all s parsed)
-               ([err]
-                (eprint err)
-                (put s :data bak))))))))
+            ([err fib]
+              (eprint err)
+              (if (os/getenv "EC_TRACEBACK")
+                (propagate err fib)
+                (put s :data bak)))))))))
 
 (defn handle-line
   [line]

@@ 8,26 8,55 @@
                     :fun-ref (fn ,name [stack] ,;body))))
 
 (defadv distribute-dyad 3
-  (let [quoted-verb (calc/pop stack)
+  (let [quotation (calc/pop stack)
         object (calc/pop stack)]
     # Leave the initial value on the stack.
+
+    (unless (calc/Quotation? quotation)
+      (errorf "Distribute error: top argument must be a quotation"))
+
     (each elem (calc/data object)
       (calc/push stack elem)
-      (each verb-elem (calc/data quoted-verb)
+
+      (calc/check-arity stack quotation)
+
+      (each verb-elem (calc/data quotation)
         (calc/push stack verb-elem)))))
 
-(defadv apply-vector 1
-  (let [quoted-verb (calc/pop stack)]
-    (each elem (calc/data quoted-verb)
-      (calc/push stack elem))))
+(defadv apply-quotation 1
+  (let [quotation (calc/pop stack)]
+    (if (calc/Quotation? quotation)
+      (do (calc/check-arity stack quotation)
+        (each elem (calc/data quotation)
+          (calc/push stack elem)))
+      (calc/push stack quotation))))
 
 (defadv wrap-stack 0
   (let [v (calc/wrap ;(stack :data))]
     (array/clear (stack :data))
     (calc/push stack v)))
 
+(defadv clear-stack 0
+  (array/clear (stack :data)))
+
 (defadv swap 2
   (let [top (calc/pop stack)
         second (calc/pop stack)]
     (calc/push stack top)
     (calc/push stack second)))
+
+(defadv slurp 2
+  (let [elem (calc/pop stack)
+        quotation (calc/pop stack)
+        new-quotation (if (calc/Quotation? quotation)
+                        (calc/wrap ;(quotation :data) elem)
+                        (calc/wrap quotation elem))]
+    (calc/push stack new-quotation)))
+
+(defadv slurp-left 2
+  (let [quotation (calc/pop stack)
+        elem (calc/pop stack)
+        new-quotation (if (calc/Quotation? quotation)
+                        (calc/wrap elem ;(quotation :data))
+                        (calc/wrap elem quotation))]
+    (calc/push stack new-quotation)))

@@ 10,12 10,19 @@
 (defproto Operation Element type {} arity {:default 0} fun-ref {})
 (defproto Adverb Element type {} arity {:default 0})
 
-(defproto Vector Element
+(defproto Quotation Element
   shape {:default [] :init? true}
-  data {:init? true})
+  data {:init? true}
+  type {:allocate-value :quotation})
 
 (defgeneric get-shape [_] [])
-(defmethod get-shape Vector [self] (self :shape))
+(defmethod get-shape Quotation [self] (self :shape))
+
+(defgeneric get-arity [_] -1)
+(defmethod get-arity Adverb [a] (a :arity))
+(defmethod get-arity Operation [a] (a :arity))
+(defmethod get-arity Quotation [q]
+  (reduce |(+ $0 (get-arity $1)) 0 (q :data)))
 
 (defgeneric fill
   [element shape-to-fill]


@@ 23,10 30,10 @@
     element
     (let [y (array ;shape-to-fill)
           yi (last y)
-          v (:new Vector [yi] (array/new-filled yi element))]
+          v (:new Quotation [yi] (array/new-filled yi element))]
       (fill v y))))
 
-(defmethod fill Vector
+(defmethod fill Quotation
   [self shape-to-fill]
   (let [x (array ;(shape self))
         y (array ;shape-to-fill)]


@@ 35,13 42,13 @@
       (let [xi (array/pop x)
             yi (array/pop y)]
         (unless (= xi yi)
-          (errorf "Shape error: can't fill vector with shape %q to %q"
+          (errorf "Shape error: can't fill quotation with shape %q to %q"
                   (shape self) shape-to-fill))))
 
     (reduce (fn [acc length]
               (let [new-shape (tuple length ;(shape acc))
                     new-data (array/new-filled length acc)]
-                (:new Vector new-shape new-data)))
+                (:new Quotation new-shape new-data)))
             self
             (reverse y))))
 


@@ 52,8 59,8 @@
 (defn- inner-apply
   [op & args]
   (let [x (first args)]
-    (if (Vector? x)
-      (:new Vector
+    (if (Quotation? x)
+      (:new Quotation
             (x :shape)
             (map (partial inner-apply op) ;(map |($ :data) args)))
       (let [f (op :fun-ref)


@@ 74,10 81,10 @@
         inner-shape (get-shape hd)]
     (each datum data
       (unless (deep= (get-shape datum) inner-shape)
-        (errorf "Vector error: can't wrap heterogeneous data. Expected %j, got %j."
+        (errorf "Quotation error: can't wrap heterogeneous data. Expected %j, got %j."
                 inner-shape
                 (get-shape datum))))
-    (:new Vector (tuple (length data) ;inner-shape) data)))
+    (:new Quotation (tuple (length data) ;inner-shape) data)))
 
 (defmethod pop Stack
   [self]


@@ 91,32 98,31 @@
   [self]
   (-> (self :data) (length)))
 
-(defn- check-arity
-  [stack arity name]
-  (when (> arity (size stack))
-    (errorf "Not enough stack; %s has arity %i; stack has size %i"
-            (string name)
-            arity
-            (size stack))))
+(defn check-arity
+  [stack elem]
+  (let [arity (get-arity elem)]
+    (when (> arity (size stack))
+      (errorf "Not enough stack: %s has arity %i; stack has size %i"
+              (string (elem :type))
+              arity
+              (size stack)))))
 
 (defmulti push [Stack Operation]
   [self op]
-  (let [{:arity arity :type op-type} op]
-    (check-arity self arity op-type)
+  (check-arity self op)
+
+  (def buf @[])
+  (loop [_ :range [0 (get-arity op)]]
+    (array/insert buf 0 (pop self)))
 
-    (def buf @[])
-    (loop [_ :range [0 arity]]
-      (array/insert buf 0 (pop self)))
-    
-    (->> (apply-operation op ;buf)
-         (make-element)
-         (push self))))
+  (->> (apply-operation op ;buf)
+       (make-element)
+       (push self)))
 
 (defmulti push [Stack Adverb]
   [self adv]
-  (let [{:arity arity :type adv-type} adv]
-    (check-arity self arity adv-type)
-    ((adv :fun-ref) self)))
+  (check-arity self adv)
+  ((adv :fun-ref) self))
 
 (defmulti push [Stack _]
   [self item]

@@ 15,9 15,13 @@
                  "=" operations/eq
                  "cmp" operations/cmp
                  "/" adverbs/distribute-dyad
-                 "!" adverbs/apply-vector
+                 "!" adverbs/apply-quotation
                  "@" adverbs/wrap-stack
-                 "swap" adverbs/swap})
+                 "swap" adverbs/swap
+                 "slurp" adverbs/slurp
+                 "slurpl" adverbs/slurp-left
+                 "slurpr" adverbs/slurp
+                 "c" adverbs/clear-stack})
 
 (defn handle-parens
   [& patt]

@@ 17,7 17,7 @@
 (defmethod p calc/Adverb
   [a] (string (a :type)))
 
-(defmethod p calc/Vector
+(defmethod p calc/Quotation
   [v]
   (let [inner (map p (v :data))]
     (string "[" (string/join inner " ") "]")))

@@ 6,7 6,7 @@
 (use testament)
 (use /test-support)
 
-(deftest vectors
+(deftest quotations
   (def v (wrap 1 2 3))
   (def v2 (wrap 2 5 10))
 


@@ 20,7 20,7 @@
 
 (deftest matrices
   (is (thrown? (wrap (wrap 1) (wrap 1 2)))
-      "Inner vectors are of differing sizes")
+      "Inner quotations are of differing sizes")
 
   (def m (wrap (wrap 1 2 3)
                (wrap 4 5 6)))


@@ 36,7 36,7 @@
         filled)
 
   (is (thrown? (calc/fill m [2 3 3]))
-      "Vectors can be filled into shapes that share a suffix")
+      "Quotations can be filled into shapes that share a suffix")
 
   (vec= @[@[@[2 4 6]
             @[8 10 12]]


@@ 63,10 63,10 @@
   (calc/push s a/distribute-dyad)
   (pop-and-compare 18 s))
 
-(deftest apply-vector
+(deftest apply-quotation
   (def s (:new calc/Stack))
   (calc/push s (wrap 1 2 3))
-  (calc/push s a/apply-vector)
+  (calc/push s a/apply-quotation)
   (pop-and-compare 3 s)
   (pop-and-compare 2 s)
   (pop-and-compare 1 s)


@@ 77,7 77,7 @@
   (calc/push s (:new calc/Int 3))
   (calc/push s (:new calc/Int 5))
   (calc/push s (wrap o/add))
-  (calc/push s a/apply-vector)
+  (calc/push s a/apply-quotation)
   (pop-and-compare 8 s)
   (is (empty? (s :data))))
 


@@ 91,7 91,7 @@
   (is (= [2] (calc/shape vec)))
   (is (empty? (s :data))))
 
-(deftest wrap-vectors
+(deftest wrap-quotations
   (def s (:new calc/Stack))
   (calc/push s (wrap 1 2))
   (calc/push s (wrap 2 4))

@@ 38,7 38,7 @@
   (def s (:new calc/Stack))
   (let [in (parser/parse "[2 3 4] 1 -")]
     (calc/push-all s in))
-  
+
   (def res (calc/pop s))
   (vec= [1 2 3] res))