Add span-upto.

2 files changed, 27 insertions, 2 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))])))