Add span-upto.

3 files changed, 38 insertions, 3 deletions

diff --git a/module/calp/util.scm b/module/calp/util.scm
index 93e9fd0c..e1e2131a 100644
--- a/module/calp/util.scm
+++ b/module/calp/util.scm
@@ -388,6 +388,31 @@
                  (cdr rem))])))
 
 
+
+;; Simar to span from srfi-1, but never takes more than
+;; @var{count} items. Can however still take less.
+;; @example
+;; (span-upto 2 char-numeric? (string->list "123456"))
+;; ⇒ (#\1 #\2)
+;; ⇒ (#\3 #\4 #\5 #\6)
+;; (span-upto 2 char-numeric? (string->list "H123456"))
+;; ⇒ ()
+;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6)
+;; @end example
+(define-public (span-upto count predicate list)
+  (let loop ((remaining count)
+             (taken '())
+             (list list))
+    (if (or (zero? remaining) (null? list))
+        (values (reverse! taken) list)
+        (if (predicate (car list))
+            (loop (1- remaining)
+                  (cons (car list) taken)
+                  (cdr list))
+            (loop (1- remaining)
+                  taken list)))))
+
+
 ;; Returns the cross product between l1 and l2.
 ;; each element is a cons cell.
 (define (cross-product% l1 l2)
diff --git a/module/datetime.scm b/module/datetime.scm
index 66eab8ca..e4a17779 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -712,7 +712,7 @@ Returns -1 on failure"
                         ;; other than the top level, to allow better error
                         ;; messages.
                         (scm-error 'misc-error "string->datetime"
-                               "Mismatched symbol, expected ~a got ~a"
+                               "Mismatched symbol, expected ~s got ~s"
                                (list #\~ (car str))
                                #f))]
              ;; TODO is this lost if not at the end?
@@ -801,7 +801,7 @@ Returns -1 on failure"
                      (cdr fmt)
                      dt)
                (scm-error 'misc-error "string->datetime"
-                      "Mismatched symbol, expected ~a got ~a"
+                      "Mismatched symbol, expected ~s got ~s"
                       (list (car fmt) (car str))
                       #f))])))
 
diff --git a/tests/util.scm b/tests/util.scm
index de8d4b2a..6d4ca262 100644
--- a/tests/util.scm
+++ b/tests/util.scm
@@ -3,7 +3,7 @@
 ;;; Code:
 
 (((calp util) filter-sorted set/r!
-  find-min find-max))
+  find-min find-max span-upto))
 
 (test-equal "Filter sorted"
   '(3 4 5)
@@ -36,3 +36,13 @@
 
 
 (test-error 'misc-error (find-extreme '()))
+
+(call-with-values (lambda () (span-upto 2 char-numeric? (string->list "123456")))
+  (lambda (head tail)
+    (test-equal '(#\1 #\2) head)
+    (test-equal '(#\3 #\4 #\5 #\6) tail)))
+
+(call-with-values (lambda () (span-upto 2 char-numeric? (string->list "H123456")))
+  (lambda (head tail)
+    (test-equal '() head)
+    (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail)))