From 363ae1da82cbb83b57b57f78b716125b79e2ac39 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 28 Dec 2013 15:47:35 +0100
Subject: pk-crypto: Add 'canonical-sexp-length' and related procedures.

* guix/pk-crypto.scm (canonical-sexp-length, canonical-sexp-null?,
  canonical-sexp-list?): New procedures.
* tests/pk-crypto.scm ("canonical-sexp-length", "canonical-sexp-list?"):
  New tests.
---
 guix/pk-crypto.scm  | 20 ++++++++++++++++++++
 tests/pk-crypto.scm | 12 ++++++++++++
 2 files changed, 32 insertions(+)

diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
index e5ada6a177..0d1af07313 100644
--- a/guix/pk-crypto.scm
+++ b/guix/pk-crypto.scm
@@ -32,6 +32,9 @@
             canonical-sexp-cdr
             canonical-sexp-nth
             canonical-sexp-nth-data
+            canonical-sexp-length
+            canonical-sexp-null?
+            canonical-sexp-list?
             bytevector->hash-data
             hash-data->bytevector
             sign
@@ -156,6 +159,14 @@ different from Scheme's 'list-ref'.)"
                        0 (native-endianness)
                        (sizeof size_t)))
 
+(define canonical-sexp-length
+  (let* ((ptr  (libgcrypt-func "gcry_sexp_length"))
+         (proc (pointer->procedure int ptr '(*))))
+    (lambda (sexp)
+      "Return the length of SEXP if it's a list (including the empty list);
+return zero if SEXP is an atom."
+      (proc (canonical-sexp->pointer sexp)))))
+
 (define token-string?
   (let ((token-cs (char-set-union char-set:digit
                                   char-set:letter
@@ -263,4 +274,13 @@ return #f if not found."
             #f
             (pointer->canonical-sexp res))))))
 
+(define-inlinable (canonical-sexp-null? sexp)
+  "Return #t if SEXP is the empty-list sexp."
+  (null-pointer? (canonical-sexp->pointer sexp)))
+
+(define (canonical-sexp-list? sexp)
+  "Return #t if SEXP is a list."
+  (or (canonical-sexp-null? sexp)
+      (> (canonical-sexp-length sexp) 0)))
+
 ;;; pk-crypto.scm ends here
diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm
index 8da533f5b2..3135d5a60c 100644
--- a/tests/pk-crypto.scm
+++ b/tests/pk-crypto.scm
@@ -82,6 +82,18 @@
 
 (gc)
 
+(test-equal "canonical-sexp-length"
+  '(0 1 2 4 0 0)
+  (map (compose canonical-sexp-length string->canonical-sexp)
+       '("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#")))
+
+(test-equal "canonical-sexp-list?"
+  '(#t #f #t #f)
+  (map (compose canonical-sexp-list? string->canonical-sexp)
+       '("()" "\"abc\"" "(a b c)" "#123456#")))
+
+(gc)
+
 (test-equal "canonical-sexp-car + cdr"
   '("(b \n (c xyz)\n )")
   (let ((lst (string->canonical-sexp "(a (b (c xyz)))")))
-- 
cgit v1.2.3