M lib/utils.hex → lib/utils.hex

@@ -50,8 +50,28 @@ ;;; cons
 ;; a q1 -> q2
 ;; Prepends %:a%% to the beginning of %:q1%%.
 (
-  swap quote swap cat
+  swap ' swap cat
 ) "cons" ::
+
+;;; uncons
+;; q1 -> a q2
+;; Removes the first item from %:q1%% and pushes it on the stack along with %:q2%% containing the rest of the items of %:q1%%.
+(
+  "_uncons_list" :
+  () "_uncons_result" :
+  0x1 "_uncons_c" :
+  _uncons_list 0x0 get ; Push the first item
+  (_uncons_c _uncons_list len <)
+    (
+      _uncons_result _uncons_list _uncons_c get push "_uncons_result" :
+      _uncons_c 0x1 + "_uncons_c" :
+    )
+  while
+  _uncons_result ; Push the rest of the items
+  "_uncons_list"   #
+  "_uncons_result" #
+  "_uncons_c"      #
+) "uncons" ::
 
 ;;; over
 ;; a1 a2 -> a1 a2 a1

M scripts/test.hex → scripts/test.hex

@@ -131,7 +131,7 @@ 
     ((args len 0x2 ==) ("two") ("no") if "two" ==)
     ((dup *) "square" :: 0x2 square 0x4 == "square" #)
     (0x1 "tmp-a" : (tmp-a 0x3 <) (tmp-a 0x1 + "tmp-a" :) while tmp-a 0x3 ==)
-    (symbols len 0x5f ==)
+    (symbols len 0x60 ==)
     ;60
 
     ((0x2 0x0 /) (error "[symbol /] Division by zero" ==) try)
@@ -299,6 +299,18 @@ ("This is a test" "this" begins not)
     ("This is a test" "test" ends)
     ("This is a test" "Test" ends not)
     ;154
+
+    (0x2 (0x1) (0x1) when 0x1 == swap drop)
+    (0x2 (0x0) (0x1) when 0x2 ==)
+    ("ccc" ("aaa") ("bbb") when "ccc" ==)
+    ((0x1) ("yes") ("no") unless "no" == swap drop) 
+    ;158
+
+    (() 0x1 push (0x1) ==)
+    ((0x1 0x2 0x3) pop (0x1 0x2) ==)
+    (0x0 (0x1 0x2 0x3) cons (0x0 0x1 0x2 0x3) ==)
+    ((0x1 0x2 0x3) uncons stack (0x1 (0x2 0x3)) == swap drop swap drop)
+    ;162
 
 ) "TESTS" :