unit tests from https://github.com/conanite/rainbow

Thanks dram for the suggestion: http://arclanguage.org/item?id=17708

ssyntax tests are still failing in core-evaluation-test.

lib/tests/core-errors-continuations-test.arc

@@ -0,0 +1,143 @@
+(def test-find-char (str c)
+  (catch
+    (let i -1
+      (each ch (coerce str 'cons)
+        (++ i)
+        (if (is ch c)
+            (throw i))))))
+
+(register-test '(suite "Foundation Tests"
+  (suite "Errors and Continuations"
+    (suite "ccc"
+      ("use ccc to return a value"
+        (ccc (fn (esc) (esc "bailout value") 42))
+        "bailout value")
+
+      ("catch expands to ccc: call throw"
+        (test-find-char "abcdefg" #\d)
+        3)
+
+      ("catch expands to ccc: nil result"
+        (test-find-char "abcdefg" #\z)
+        nil)
+
+      ("support continuation-passing style to calculate hypoteneuse"
+        ( (fn ((cps* cpsplus cps-sqrt cps-pyth))
+          (assign cps* (fn (x y k) (k (* x y))))
+          (assign cpsplus (fn (x y k) (k (+ x y))))
+          (assign cps-sqrt (fn (x k) (k (sqrt x))))
+          (assign cps-pyth (fn (x y k)
+            (cps* x x (fn (x2)
+              (cps* y y (fn (y2)
+                (cpsplus x2 y2 (fn (x2py2)
+                  (cps-sqrt x2py2 k)))))))))
+          (< 6.40312423743284 (ccc (fn (cc) (cps-pyth 4 5 cc))) 6.40312423743285)) nil)
+        t)
+
+      ("support co-routines" ; adapted from http://community.schemewiki.org/?call-with-current-continuation
+        ((fn (hefty-info)
+          (assign hefty-stuff (fn (other-stuff)
+            (assign rec-hefty (fn (n)
+              (assign hefty-info (cons "A" (cons n hefty-info)))
+              (assign other-stuff (ccc other-stuff))
+              (if (> n 0) (rec-hefty (- n 1)))))
+            (rec-hefty 5)))
+
+          (assign light-stuff (fn (other-stuff)
+            (assign rec-light (fn (x)
+              (assign hefty-info (cons "B" hefty-info))
+              (assign other-stuff (ccc other-stuff))
+              (rec-light 0)))))
+
+          (if (is hefty-info nil) (hefty-stuff light-stuff))
+
+          hefty-info
+        ) nil)
+        ("B" "A" 0 "B" "A" 1 "B" "A" 2 "B" "A" 3 "B" "A" 4 "B" "A" 4 "A" 5))
+    )
+
+    (suite "Protect"
+      ("simple protect"
+        ((fn (x)
+          (protect (fn () (/ 1 2)) (fn () (assign x "protected-foo")))
+          x) nil)
+        "protected-foo")
+
+      ("protect through continuation"
+        (tostring (catch (after (throw pr!problem) pr!-free)))
+        "problem-free")
+
+      ("protect all over the place inside a co-routine pair"
+        (accum trace
+          (assign proc-A (fn (my-b)
+            (trace 'proc-A-start)
+            (assign inner-A (fn (n)
+              (trace (sym:string 'inner-A-start- n))
+              (after (assign my-b (do (trace 'pre-ccc-my-b) (ccc my-b))) (trace (sym:string 'after-ccc-my-b- n)))
+              (trace 'end-inner-A)
+              (if (> n 0) (after (inner-A (- n 1)) (trace (sym:string 'after-inner-A-tail-call- n))))))
+            (after (inner-A 5) (trace 'after-initial-inner-A-call))))
+
+          (assign proc-B (fn (my-a)
+            (trace 'proc-B-start)
+            (assign inner-B (fn (x)
+              (trace 'inner-B-start)
+              (after (assign my-a (do (trace 'pre-ccc-my-a) (ccc my-a))) (trace 'after-ccc-my-a))
+              (trace 'end-inner-B)
+              (after (inner-B 0) (trace 'after-inner-B-tail-call))))))
+
+          (after (proc-A proc-B) (trace 'final-after)))
+
+        (proc-A-start inner-A-start-5 pre-ccc-my-b proc-B-start after-ccc-my-b-5
+         end-inner-A inner-A-start-4 pre-ccc-my-b inner-B-start pre-ccc-my-a
+         after-ccc-my-a after-ccc-my-b-4 after-inner-A-tail-call-5
+         after-ccc-my-b-5 end-inner-A inner-A-start-4 pre-ccc-my-b
+         after-ccc-my-b-4 after-inner-A-tail-call-5 after-ccc-my-a end-inner-B
+         inner-B-start pre-ccc-my-a after-ccc-my-a after-inner-B-tail-call
+         after-ccc-my-b-4 after-inner-A-tail-call-5 after-ccc-my-b-4 end-inner-A
+         inner-A-start-3 pre-ccc-my-b after-ccc-my-b-3 after-inner-A-tail-call-4
+         after-inner-A-tail-call-5 after-ccc-my-a end-inner-B inner-B-start
+         pre-ccc-my-a after-ccc-my-a after-inner-B-tail-call
+         after-inner-B-tail-call after-ccc-my-b-4 after-inner-A-tail-call-5
+         after-ccc-my-b-3 end-inner-A inner-A-start-2 pre-ccc-my-b
+         after-ccc-my-b-2 after-inner-A-tail-call-3 after-inner-A-tail-call-4
+         after-inner-A-tail-call-5 after-ccc-my-a end-inner-B inner-B-start
+         pre-ccc-my-a after-ccc-my-a after-inner-B-tail-call
+         after-inner-B-tail-call after-inner-B-tail-call after-ccc-my-b-4
+         after-inner-A-tail-call-5 after-ccc-my-b-2 end-inner-A inner-A-start-1
+         pre-ccc-my-b after-ccc-my-b-1 after-inner-A-tail-call-2
+         after-inner-A-tail-call-3 after-inner-A-tail-call-4
+         after-inner-A-tail-call-5 after-ccc-my-a end-inner-B inner-B-start
+         pre-ccc-my-a after-ccc-my-a after-inner-B-tail-call
+         after-inner-B-tail-call after-inner-B-tail-call after-inner-B-tail-call
+         after-ccc-my-b-4 after-inner-A-tail-call-5 after-ccc-my-b-1 end-inner-A
+         inner-A-start-0 pre-ccc-my-b after-ccc-my-b-0 after-inner-A-tail-call-1
+         after-inner-A-tail-call-2 after-inner-A-tail-call-3
+         after-inner-A-tail-call-4 after-inner-A-tail-call-5 after-ccc-my-a
+         end-inner-B inner-B-start pre-ccc-my-a after-ccc-my-a
+         after-inner-B-tail-call after-inner-B-tail-call after-inner-B-tail-call
+         after-inner-B-tail-call after-inner-B-tail-call after-ccc-my-b-4
+         after-inner-A-tail-call-5 after-ccc-my-b-0 end-inner-A
+         after-inner-A-tail-call-1 after-inner-A-tail-call-2
+         after-inner-A-tail-call-3 after-inner-A-tail-call-4
+         after-inner-A-tail-call-5 after-initial-inner-A-call final-after)
+      )
+    )
+
+    (suite "Error handling"
+      ("no error"
+        (on-err (fn (ex) "got error")
+                (fn () (* 6 7)))
+        42 )
+
+      ("error"
+        (on-err (fn (ex) (+ "got error " (details ex)))
+                (fn () (/ 42 0)))
+        "got error /: division by zero" )
+
+      ("explicit error"
+        (on-err (fn (ex) (+ "got error " (details ex)))
+                (fn () (err "we can also throw our own exceptions")))
+        "got error we can also throw our own exceptions" )
+    )
+  )))

lib/tests/core-evaluation-test.arc

@@ -0,0 +1,164 @@
+(mac test-double (x) `(+ ,x ,x))
+
+(register-test '(suite "Foundation Tests"
+  (suite "Evaluation"
+    (suite "[ _ ] shortcut"
+      ("call directly"
+        ([* _ _] 15)
+        225)
+
+      ("useful in apply"
+        (apply [* _ _] '(16))
+        256)
+
+      ("handles empty bracket-fn"
+        ([] 21)
+        nil))
+
+    (suite "apply"
+      ("a simple sum function"
+        (apply + '(1 2))
+        3)
+
+      ("an inline function"
+        (apply (fn (x y) (* x y)) '(17 3))
+        51)
+
+      ("passes all args to function"
+        (apply + "a" "b" '("c" "d"))
+        "abcd" )
+
+      ("passes all args to function"
+        (apply + '(a b) '(c d) '((e f) (g h)))
+        (a b c d e f g h)))
+
+    (suite "eval"
+      ("a simple sum function"
+        (eval '(+ 21 4))
+        25)
+
+      ("an inline function invocation"
+        (eval '( (fn (x y) (* x y)) 16 4))
+        64))
+
+    (suite "ssyntax"
+      ("recognises compose"
+        (ssyntax 'a:b)
+        t )
+
+      ("recognises complement and compose"
+        (ssyntax '~a:b)
+        t )
+
+      ("recognises complement alone"
+        (ssyntax '~a)
+        t )
+
+      ("recognises list"
+        (ssyntax 'a.b)
+        t )
+
+      ("recognises list-quoted"
+        (ssyntax 'a!b)
+        t )
+
+      ("andf"
+        (ssyntax 'a&b)
+        t)
+
+      ("andf"
+        (ssyntax '&a&b&)
+        t)
+    )
+
+    (suite "special syntax invocation (compose is implemented in Arc)"
+      ("direct invocation"
+        ((fn ()
+          (sqrt:+ 40 2.25)))
+        6.5 )
+
+      ("compose macro invocation"
+        (coerce (test-double:sqrt 256) 'int)
+        32)
+
+      ("invoke as parameter"
+        ((fn (addand)
+          (addand sqrt:* 5 20 1.0)) (fn (op x y z) (+ z (op x y))))
+        11.0 )))))
+
+(register-test '(suite "ssexpand"
+  ("expand compose"
+    (ssexpand 'x:y)
+    (compose x y))
+
+  ("expand complement"
+    (ssexpand '~p)
+    (complement p))
+
+  ("expand compose/complement"
+    (ssexpand 'p:~q:r)
+    (compose p (complement q) r) )
+
+  ("expand compose/complement"
+    (ssexpand '~p:q:r)
+    (compose (complement p) q r) )
+
+  ("expand compose with numbers"
+    (ssexpand 'x:1.2)
+    (compose x 1.2))              ; bizarre but true
+
+  ("expand compose with numbers"
+    (type ((ssexpand 'x:1.2) 2))
+    num)                          ; bizarre but true
+
+  ("expand list"
+    (ssexpand '*.a.b)
+    ((* a) b))
+
+  ("expand quoted list"
+    (ssexpand 'cons!a!b)
+    ((cons (quote a)) (quote b)) )
+
+  ("expand chained dots and bangs"
+    (ssexpand 'a.b!c.d)
+    (((a b) (quote c)) d))
+
+  ("ssexpand with initial dot"
+    (ssexpand '.a.b.c)
+    (((get a) b) c))
+
+  ("ssexpand with initial quote"
+    (ssexpand '!a.b.c)
+    (((get (quote a)) b) c))
+
+  ("andf"
+    (ssexpand 'a&b)
+    (andf a b))
+))
+
+(register-test '(suite "using special syntax"
+  ("ssyntax copes with embedded nil"
+    list.nil
+    (nil))
+
+  ("ssyntax expands numbers too"
+    ((fn (s) s.1) "foo")
+    #\o)
+
+;?   ("everything at once, in functional position"
+;?     ((fn (x p) (tostring (pr:odd&~x.p 7) (pr:odd&~x.p 8) (pr:odd&~x.p 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+;?     "tnilnil")
+;? 
+;?   ("everything at once, as argument"
+;?     ((fn (y p) (tostring:map pr:odd&~y.p '(7 8 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+;?     "tnilnil")
+;? 
+;?   ("everything at once, as argument"
+;?     ((fn (y p) (tostring:map pr:~y.p '(7 8 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+;?     "ttnil")
+;? 
+;?   ("everything at once, as argument"
+;?     ((fn (y p) (tostring:map odd&pr '(7 8 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+;?     "79")
+
+    ))

lib/tests/core-lists-test.arc

@@ -0,0 +1,89 @@
+(register-test '(suite "Foundation Tests"
+  (suite "Lists"
+    (suite "cons"
+      ("cons creates a list"
+        (cons 'a '(b c))
+        (a b c))
+
+      ("cons conses two strings"
+        (cons "a" "b")
+        ("a" . "b"))
+    )
+
+    (suite "car"
+      ("car of nil is nil"
+        (car nil)
+        nil)
+
+      ("car of empty list is nil"
+        (car '())
+        nil)
+
+      ("car - no need to quote empty list"
+        (car ())
+        nil)
+
+      ("car returns car of argument"
+        (car '(foo 12.34 "bar"))
+        foo)
+    )
+
+    (suite "cdr"
+      ("cdr returns cdr of argument"
+        (cdr '("foo" bar 123.45))
+        (bar 123.45))
+
+      ("cdr of empty list is nil"
+        (cdr ())
+        nil)
+
+      ("'each' macro relies on cdr of empty list returning nil"
+        ((fn stuff
+             ((fn (outer)
+                  (((fn (self)
+                         (assign self
+                                 (fn (inner)
+                                     (if (is (type inner) 'cons)
+                                         ((fn ()
+                                              ((fn (x)
+                                                   (disp x))
+                                               (car inner))
+                                     (self (cdr inner))))) )))
+                     nil)
+                    outer))
+              stuff)))
+        nil)
+    )
+
+    (suite "scar"
+      ("sets the first element of a list"
+        ( (fn (x) (scar x 99) x ) '(1 2 3))
+        (99 2 3) )
+
+      ("sets the first character of a string"
+        ( (fn (x) (scar x #\b) x ) "foo" )
+        "boo" )
+    )
+
+    (suite "scdr"
+      ("scdr sets the remainder of a list"
+        ( (fn (x) (scdr x '(a a)) x ) '(a b c) )
+        (a a a) )
+
+      ("scdr sets the remainder of any list"
+        ( (fn (x) (scdr (cdr (cdr x)) '(d e f)) x ) '(a b c) )
+        (a b c d e f) )
+    )
+
+    ("get the size of a list"
+      (len '(a b c d e f g))
+      7 )
+
+    ("set an element of a list"
+      ( (fn (lst) (sref lst 'b 0) lst) '(a b c) )
+      (b b c) )
+
+    ("get an element of a list"
+      ( '(a b c d) 2 )
+      c )
+  )))