From 5aedc3cc57fd7eb2478989ae04e9db19151ce1bb Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 20 Aug 2019 07:21:37 -0700
Subject: [PATCH] cbor: add support for reading simple values and tagged data
 items.

---
 extra/cbor/cbor-tests.factor | 18 +++++++++---------
 extra/cbor/cbor.factor       | 28 +++++++++++++++++-----------
 2 files changed, 26 insertions(+), 20 deletions(-)

diff --git a/extra/cbor/cbor-tests.factor b/extra/cbor/cbor-tests.factor
index ccbb9e89fa..799890015f 100644
--- a/extra/cbor/cbor-tests.factor
+++ b/extra/cbor/cbor-tests.factor
@@ -53,15 +53,15 @@ tools.test ;
 { t } [ B{ 0xf5 } cbor> ] unit-test
 { +cbor-nil+ } [ B{ 0xf6 } cbor> ] unit-test
 { +cbor-undefined+ } [ B{ 0xf7 } cbor> ] unit-test
-! simple(16) 0xf0
-! simple(24) 0xf818
-! simple(255) 0xf8ff
-! 0("2013-03-21T20:04:00Z") 0xc074323031332d30332d32315432303a30343a30305a
-! 1(1363896240) 0xc11a514b67b0
-! 1(1363896240.5) 0xc1fb41d452d9ec200000
-! 23(h'01020304') 0xd74401020304
-! 24(h'6449455446') 0xd818456449455446
-! 32("http://www.example.com") 0xd82076687474703a2f2f7777772e6578616d706c652e636f6d
+{ { "simple" 16 } } [ B{ 0xf0 } cbor> ] unit-test
+{ { "simple" 24 } } [ B{ 0xf8 0x18 } cbor> ] unit-test
+{ { "simple" 255 } } [ B{ 0xf8 0xff } cbor> ] unit-test
+{ { 0 "2013-03-21T20:04:00Z" } } [ "c074323031332d30332d32315432303a30343a30305a" hex-string>bytes cbor> ] unit-test
+{ { 1 1363896240 } } [ "c11a514b67b0" hex-string>bytes cbor> ] unit-test
+{ { 1 1363896240.5 } } [ "c1fb41d452d9ec200000" hex-string>bytes cbor> ] unit-test
+{ { 23 B{ 0x01 0x02 0x03 0x04 } } } [ "d74401020304" hex-string>bytes cbor> ] unit-test
+{ { 24 B{ 0x64 0x49 0x45 0x54 0x46 } } } [ "d818456449455446" hex-string>bytes cbor> ] unit-test
+{ { 32 "http://www.example.com" } } [ "d82076687474703a2f2f7777772e6578616d706c652e636f6d" hex-string>bytes cbor> ] unit-test
 { B{ } } [ B{ 0x40 } cbor> ] unit-test
 { B{ 1 2 3 4 } } [ B{ 0x44 0x01 0x02 0x03 0x04 } cbor> ] unit-test
 { "" } [ B{ 0x60 } cbor> ] unit-test
diff --git a/extra/cbor/cbor.factor b/extra/cbor/cbor.factor
index dda1cb3cb2..9bda61d35c 100644
--- a/extra/cbor/cbor.factor
+++ b/extra/cbor/cbor.factor
@@ -56,17 +56,23 @@ SINGLETON: +cbor-indefinite+
         [ read-cbor read-cbor 2array ] replicate
     ] if ;
 
+: read-tagged ( info -- tagged )
+    read-unsigned read-cbor 2array ;
+
 : read-float ( info -- float )
-    {
-        { 20 [ f ] }
-        { 21 [ t ] }
-        { 22 [ +cbor-nil+ ] }
-        { 23 [ +cbor-undefined+ ] }
-        { 25 [ 2 read be> bits>half ] }
-        { 26 [ 4 read be> bits>float ] }
-        { 27 [ 8 read be> bits>double ] }
-        { 31 [ +cbor-break+ ] }
-    } case ;
+    dup 20 < [ "simple" swap 2array ] [
+        {
+            { 20 [ f ] }
+            { 21 [ t ] }
+            { 22 [ +cbor-nil+ ] }
+            { 23 [ +cbor-undefined+ ] }
+            { 24 [ read1 "simple" swap 2array ] }
+            { 25 [ 2 read be> bits>half ] }
+            { 26 [ 4 read be> bits>float ] }
+            { 27 [ 8 read be> bits>double ] }
+            { 31 [ +cbor-break+ ] }
+        } case
+    ] if ;
 
 PRIVATE>
 
@@ -78,7 +84,7 @@ PRIVATE>
         { 3 [ read-textstring ] }
         { 4 [ read-array ] }
         { 5 [ read-map ] }
-        { 6 [ "optional semantic tagging not supported" throw ] }
+        { 6 [ read-tagged ] }
         { 7 [ read-float ] }
     } case ;