guile/module/ice-9/arrays.scm

;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 1999, 2001, 2004, 2006, 2017, 2025 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (ice-9 arrays)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (array-copy)
  ;; FIXME: Use #:export when deprecated code removed.
  #:replace (array-fill!
             array-copy!
             array-copy-in-order!
             array-map!
             array-for-each
             array-index-map!
             array-equal?
             array-slice-for-each
             array-slice-for-each-in-order
             array-cell-ref
             array-cell-set!))

(define (string-accessors buffer)
  (values (string-length buffer)
          (lambda (x i) (string-ref x i))
          (lambda (x i v) (string-set! x i v))))

(define (vector-accessors buffer)
  (values (vector-length buffer)
          (lambda (x i) (vector-ref x i))
          (lambda (x i v) (vector-set! x i v))))

(define (bitvector-accessors buffer)
  (values (bitvector-length buffer)
          (lambda (x i) (bitvector-bit-set? x i))
          (lambda (x i v)
            (if v
                (bitvector-set-bit! x i)
                (bitvector-clear-bit! x i)))))

(define (bytevector-accessors buffer)
  (case (array-type buffer)
    ((u8 vu8)
     (values (bytevector-length buffer)
             (lambda (x i) (bytevector-u8-ref x i))
             (lambda (x i v) (bytevector-u8-set! x i v))))
    ((s8)
     (values (bytevector-length buffer)
             (lambda (x i) (bytevector-s8-ref x i))
             (lambda (x i v) (bytevector-s8-set! x i v))))
    ((u16)
     (values (ash (bytevector-length buffer) -1)
             (lambda (x i) (bytevector-u16-native-ref x (ash i 1)))
             (lambda (x i v) (bytevector-u16-native-set! x (ash i 1) v))))
    ((s16)
     (values (ash (bytevector-length buffer) -1)
             (lambda (x i) (bytevector-s16-native-ref x (ash i 2)))
             (lambda (x i v) (bytevector-s16-native-set! x (ash i 2) v))))
    ((u32)
     (values (ash (bytevector-length buffer) -2)
             (lambda (x i) (bytevector-u32-native-ref x (ash i 2)))
             (lambda (x i v) (bytevector-u32-native-set! x (ash i 2) v))))
    ((s32)
     (values (ash (bytevector-length buffer) -2)
             (lambda (x i) (bytevector-s32-native-ref x (ash i 2)))
             (lambda (x i v) (bytevector-s32-native-set! x (ash i 2) v))))
    ((u64)
     (values (ash (bytevector-length buffer) -3)
             (lambda (x i) (bytevector-u64-native-ref x (ash i 3)))
             (lambda (x i v) (bytevector-u64-native-set! x (ash i 3) v))))
    ((s64)
     (values (ash (bytevector-length buffer) -3)
             (lambda (x i) (bytevector-s64-native-ref x (ash i 3)))
             (lambda (x i v) (bytevector-s64-native-set! x (ash i 3) v))))
    ((f32)
     (values (ash (bytevector-length buffer) -2)
             (lambda (x i) (bytevector-ieee-single-native-ref x (ash i 2)))
             (lambda (x i v) (bytevector-ieee-single-native-set! x (ash i 2) v))))
    ((f64)
     (values (ash (bytevector-length buffer) -3)
             (lambda (x i) (bytevector-ieee-double-native-ref x (ash i 3)))
             (lambda (x i v) (bytevector-ieee-double-native-set! x (ash i 3) v))))
    ((c32)
     (values (ash (bytevector-length buffer) -3)
             (lambda (x i)
               (make-rectangular
                (bytevector-ieee-single-native-ref x (ash i 3))
                (bytevector-ieee-single-native-ref x (+ (ash i 3) 4))))
             (lambda (x i v)
               (bytevector-ieee-single-native-set! x (ash i 3) (real-part v))
               (bytevector-ieee-single-native-set! x (+ (ash i 3) 4) (imag-part v)))))
    ((c64)
     (values (ash (bytevector-length buffer) -4)
             (lambda (x i)
               (make-rectangular
                (bytevector-ieee-single-native-ref x (ash i 4))
                (bytevector-ieee-single-native-ref x (+ (ash i 4) 8))))
             (lambda (x i v)
               (bytevector-ieee-single-native-set! x (ash i 4) (real-part v))
               (bytevector-ieee-single-native-set! x (+ (ash i 3) 8) (imag-part v)))))
    (else (error "unreachable"))))

(define (compute-accessors buffer)
  (cond
   ((string? buffer) (string-accessors buffer))
   ((vector? buffer) (vector-accessors buffer))
   ((bitvector? buffer) (bitvector-accessors buffer))
   ((bytevector? buffer) (bytevector-accessors buffer))
   (else
    (error "bad array buffer"))))

(define (array-shapev a)
  (let ((v (make-vector (array-rank a))))
    (let lp ((i 0)
             (dims (array-dimensions a))
             (incs (shared-array-increments a)))
      (match dims
        (() v)
        (((start end) . dims)
         (match incs
           ((inc . incs)
            (vector-set! v i (vector start (1+ (- end start)) inc))
            (lp (1+ i) dims incs))))
        ((end . dims)
         (match incs
           ((inc . incs)
            (vector-set! v i (vector 0 end inc))
            (lp (1+ i) dims incs))))))))

(define (shapev<=? a b)
  (and (eqv? (vector-length a) (vector-length b))
       (let lp ((i 0))
         (or (eqv? i (vector-length a))
             (match (vector-ref a i)
               (#(abase acount ainc)
                (match (vector-ref b i)
                  (#(bbase bcount binc)
                   (and (<= bbase abase)
                        (<= (+ abase acount) (+ bbase bcount))
                        (lp (1+ i)))))))))))

(define (prepare-reads dst-shape src)
  (define src-shape (array-shapev src))

  (unless (shapev<=? dst-shape src-shape)
    (error "array shape mismatch" dst-shape src))

  (define initial-offset
    (let lp ((dim 0) (offset (shared-array-offset src)))
      (cond
       ((= dim (vector-length dst-shape))
        offset)
       (else
        (match (vector-ref dst-shape dim)
          (#(dst-start _ _)
           (match (vector-ref src-shape dim)
             (#(src-start _ src-inc)
              (lp (+ dim 1)
                  (+ offset (* (- src-start dst-start) src-inc)))))))))))

  (define incs
    (let ((incs (make-vector (vector-length src-shape))))
      (let lp ((dim 0))
        (when (< dim (vector-length dst-shape))
          (match (vector-ref src-shape dim)
            (#(start _ inc)
             (vector-set! incs dim inc)
             (lp (+ dim 1))))))
      incs))

  (define offset initial-offset)  ; Mutable.

  (define read
    (let ((buf (shared-array-root src)))
      (call-with-values (lambda () (compute-accessors buf))
        (lambda (length ref set)
          (lambda () (ref buf offset))))))

  (define (advance! dim)
    (set! offset (+ offset (vector-ref incs dim))))

  (define (restore! dim count)
    (set! offset (- offset (* count (vector-ref incs dim)))))

  (values read advance! restore!))

(define (array-map! dst proc . src*)
  (define dst-buf (shared-array-root dst))
  (define dst-set (call-with-values (lambda () (compute-accessors dst-buf))
                    (lambda (length ref set) set)))
  (define dst-dims (array-shapev dst))

  (define src-count (length src*))
  (define src-advancev (make-vector src-count))
  (define src-restorev (make-vector src-count))
  (define src-readv (make-vector src-count))

  (let lp ((i 0) (src* src*))
    (match src*
      (() #t)
      ((src . src*)
       (call-with-values (lambda () (prepare-reads dst-dims src))
         (lambda (read advance restore)
           (vector-set! src-readv i read)
           (vector-set! src-advancev i advance)
           (vector-set! src-restorev i restore)))
       (lp (1+ i) src*))))

  (define proc*
    (match (vector-length src-readv)
      (0 proc)
      (1 (let ((read0 (vector-ref src-readv 0)))
           (lambda () (proc (read0)))))
      (2 (let ((read0 (vector-ref src-readv 0))
               (read1 (vector-ref src-readv 1)))
           (lambda () (proc (read0) (read1)))))
      (n (let ((read0 (vector-ref src-readv 0))
               (read1 (vector-ref src-readv 1))
               (args (make-list (- n 2))))
           (lambda ()
             (let* ((v0 (read0))
                    (v1 (read1)))
               (let lp ((i 2) (args args))
                 (let ((read (vector-ref src-readv i)))
                   (set-car! args (read))
                   (let ((i (1+ i)))
                     (when (< i n)
                       (lp i (cdr args))))))
               (apply proc v0 v1 args)))))))

  (define (advance-src-offsets! dim)
    (let lp ((i 0))
      (when (< i (vector-length src-advancev))
        (let ((advance! (vector-ref src-advancev i)))
          (advance! dim)
          (lp (1+ i))))))

  (define (restore-src-offsets! dim count)
    (let lp ((i 0))
      (when (< i (vector-length src-restorev))
        (let ((restore! (vector-ref src-restorev i)))
          (restore! dim count)
          (lp (1+ i))))))

  (cond
   ((zero? (vector-length dst-dims))
    (dst-set dst-buf (shared-array-offset dst) (proc*)))
   (else
    (let recur ((dim 0)
                (dst-offset (shared-array-offset dst)))
      (match (vector-ref dst-dims dim)
        (#(start count dst-inc)
         (if (eq? (1+ dim) (vector-length dst-dims))
             (let lp ((n 0) (dst-offset dst-offset))
               (cond
                ((= n count)
                 (restore-src-offsets! dim count))
                (else
                 (dst-set dst-buf dst-offset (proc*))
                 (advance-src-offsets! dim)
                 (lp (1+ n) (+ dst-offset dst-inc)))))
             (let lp ((n 0) (dst-offset dst-offset))
               (cond
                ((= n count)
                 (restore-src-offsets! dim count))
                (else
                 (recur (1+ dim) dst-offset)
                 (advance-src-offsets! dim)
                 (lp (1+ n) (+ dst-offset dst-inc))))))))))))

(define (array-fill! array fill)
  "Store @var{fill} in every element of array @var{array}.  The value
returned is unspecified."
  (array-map! array (lambda () fill)))

;; This is actually defined in boot-9.scm, apparently for backwards
;; compatibility.
;;
;; (define (array-shape a)
;;   (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
;;        (array-dimensions a)))

(define (array-copy! src dst)
  "Copy every element from vector or array @var{src} to the
corresponding element of @var{dst}.  @var{dst} must have the same rank
as @var{src}, and be at least as large in each dimension.  The order is
unspecified."
  ;; Unlike array-map! which can read from larger arrays into a smaller,
  ;; here we can read from a smaller array into a larger.  If src is
  ;; smaller than dst, we need to slice dst.
  (let ((src-shape (array-shapev src))
        (dst-shape (array-shapev dst)))
    (unless (= (vector-length src-shape) (vector-length dst-shape))
      (error "array shape mismatch" dst-shape src))
    (array-map! (if (equal? src-shape dst-shape)
                    dst
                    (if (shapev<=? src-shape dst-shape)
                        (apply make-shared-array dst list (array-shape src))
                        (error "array shape mismatch" dst-shape src)))
                (lambda (v) v)
                src)))

(define (array-copy-in-order! src dst)
  "Like @code{array-copy!}, but guaranteed to proceed in row-major order."
  (array-copy! src dst))

; FIXME writes over the array twice if (array-type) is #t
(define (array-copy a)
  (let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
    (array-copy! a b)
    b))

(define (dim-start dim)
  (match dim ((start end) start) (end 0)))
(define (dim-end dim)
  (match dim ((start end) (1+ end)) (end end)))
       
(define (array-for-each1 proc array)
  (cond
   ((string? array)
    (let lp ((n 0))
      (when (< n (string-length array))
        (proc (string-ref array n))
        (lp (1+ n)))))
   ((vector? array)
    (let lp ((n 0))
      (when (< n (vector-length array))
        (proc (vector-ref array n))
        (lp (1+ n)))))
   ((bitvector? array)
    (let lp ((n 0))
      (when (< n (bitvector-length array))
        (proc (bitvector-bit-set? array n))
        (lp (1+ n)))))
   ((bytevector? array)
    (call-with-values (bytevector-accessors array)
      (lambda (len ref set)
        (let lp ((n 0))
          (when (< n len)
            (proc (ref n))
            (lp (1+ n)))))))
   (else
    (let ((v (shared-array-root array)))
      (define-values (length ref set) (compute-accessors v))
      (match (array-shapev array)
        (#() (proc (ref v (shared-array-offset array))))
        (dims
         (let ((ndims (vector-length dims)))
           (let recur ((dim 0)
                       (offset (shared-array-offset array)))
             (match (vector-ref dims dim)
               (#(first count inc)
                (if (eqv? dim (1- ndims))
                    (let lp ((i 0) (offset offset))
                      (when (< i count)
                        (proc (ref v offset))
                        (lp (1+ i) (+ offset inc))))
                    (let lp ((i 0) (offset offset))
                      (when (< i count)
                        (recur (1+ dim) offset)
                        (lp (1+ i) (+ offset inc)))))))))))))))

(define (array-for-each* proc arrays)
  (define shape (array-shapev (car arrays)))

  (define src-count (length arrays))
  (define src-advancev (make-vector src-count))
  (define src-restorev (make-vector src-count))
  (define src-readv (make-vector src-count))

  (let lp ((i 0) (arrays arrays))
    (match arrays
      (() #t)
      ((src . arrays)
       (call-with-values (lambda () (prepare-reads shape src))
         (lambda (read advance restore)
           (vector-set! src-readv i read)
           (vector-set! src-advancev i advance)
           (vector-set! src-restorev i restore)))
       (lp (1+ i) arrays))))

  (define proc*
    (match (vector-length src-readv)
      (0 proc)
      (1 (let ((read0 (vector-ref src-readv 0)))
           (lambda () (proc (read0)))))
      (2 (let ((read0 (vector-ref src-readv 0))
               (read1 (vector-ref src-readv 1)))
           (lambda () (proc (read0) (read1)))))
      (n (let ((read0 (vector-ref src-readv 0))
               (read1 (vector-ref src-readv 1))
               (args (make-list (- n 2))))
           (lambda ()
             (let* ((v0 (read0))
                    (v1 (read1)))
               (let lp ((i 2) (args args))
                 (let ((read (vector-ref src-readv i)))
                   (set-car! args (read))
                   (let ((i (1+ i)))
                     (when (< i n)
                       (lp i (cdr args))))))
               (apply proc v0 v1 args)))))))

  (define (advance-src-offsets! dim)
    (let lp ((i 0))
      (when (< i (vector-length src-advancev))
        (let ((advance! (vector-ref src-advancev i)))
          (advance! dim)
          (lp (1+ i))))))

  (define (restore-src-offsets! dim count)
    (let lp ((i 0))
      (when (< i (vector-length src-restorev))
        (let ((restore! (vector-ref src-restorev i)))
          (restore! dim count)
          (lp (1+ i))))))

  (cond
   ((zero? (vector-length shape))
    (proc*))
   (else
    (let recur ((dim 0))
      (match (vector-ref shape dim)
        (#(start count dst-inc)
         (if (eq? (1+ dim) (vector-length shape))
             (let lp ((n 0))
               (cond
                ((= n count)
                 (restore-src-offsets! dim count))
                (else
                 (proc*)
                 (advance-src-offsets! dim)
                 (lp (1+ n)))))
             (let lp ((n 0))
               (cond
                ((= n count)
                 (restore-src-offsets! dim count))
                (else
                 (recur (1+ dim))
                 (advance-src-offsets! dim)
                 (lp (1+ n)))))))))))
  *unspecified*)

(define array-for-each
  (case-lambda
   ((proc array)
    (array-for-each1 proc array))
   ((proc array . arrays)
    (array-for-each* proc (cons array arrays)))))

(define (array-index-map! array proc)
  "Apply @var{proc} to the indices of each element of @var{ra} in
turn, storing the result in the corresponding element.  The value
returned and the order of application are unspecified.

One can implement @var{array-indexes} as
@lisp
(define (array-indexes array)
    (let ((ra (apply make-array #f (array-shape array))))
      (array-index-map! ra (lambda x x))
      ra))
@end lisp
Another example:
@lisp
(define (apl:index-generator n)
    (let ((v (make-uniform-vector n 1)))
      (array-index-map! v (lambda (i) i))
      v))
@end lisp"
  (match (array-dimensions array)
    (() (array-set! array (proc)))
    ((dim)
     (let lp ((n (dim-start dim)))
       (unless (eqv? n (dim-end dim))
         (array-set! array (proc n) n)
         (lp (1+ n)))))
    (dims
     (let recur ((head '()) (dims dims))
       (match dims
         ((dim)
          (let lp ((n (dim-start dim)))
            (unless (eqv? n (dim-end dim))
              (let ((idx (append head (list n))))
                (apply array-set! array (apply proc idx) idx))
              (lp (1+ n)))))
         ((dim . dims)
          (let lp ((n (dim-start dim)))
            (unless (eqv? n (dim-end dim))
              (recur (append head (list n)) dims)
              (lp (1+ n))))))))))

(define array-equal?
  (case-lambda
   "Return @code{#t} iff all arguments are arrays with the same
shape, the same type, and have corresponding elements which are either
@code{equal?}  or @code{array-equal?}.  This function differs from
@code{equal?} in that all arguments must be arrays."
   (() #t)
   ((a) #t)
   ((a b)
    (define (slices-equal? a b dims)
      (match dims
        ((dim . dims)
         (define (recur a b)
           (if (null? dims)
               (equal? a b)
               (slices-equal? a b dims)))
         (define (dim-start dim)
           (match dim ((start end) start) (end 0)))
         (define (dim-end dim)
           (match dim ((start end) end) (end end)))
         (let lp ((n (dim-start dim)))
           (or (eqv? n (dim-end dim))
               (and (recur (array-cell-ref a n)
                           (array-cell-ref b n))
                    (lp (1+ n))))))))
    
    (and (equal? (array-dimensions a) (array-dimensions b))
         (match (array-type a)
           ((or 'vu8 'u8)
            ;; R6RS and Guile mostly use #vu8(...) as the literal syntax
            ;; for bytevectors, but R7RS uses #u8.  To allow R7RS users
            ;; to re-use the various routines implemented on bytevectors
            ;; which return vu8-tagged values and to also be able to do
            ;; (equal? #u8(1 2 3) (bytevector 1 2 3)), we allow equality
            ;; comparisons between vu8 and u8.
            (match (array-type b)
              ((or 'vu8 'u8) #t)
              (_ #f)))
           (ta (eq? ta (array-type b))))
         (if (zero? (array-rank a))
             (equal? (array-ref a) (array-ref b))
             (slices-equal? a b (array-dimensions a)))))

   ((a b . rest)
    (and (array-equal? a b)
         (apply array-equal? b rest)))))

(define (array-slice-for-each frame-rank proc . arrays)
  "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}
of the arrays @var{args}, in unspecified order. The first
@var{frame-rank} dimensions of each @var{arg} must match.  Rank-0 cells
are passed as rank-0 arrays.  The value returned is unspecified.

For example:
@lisp
;; Sort the rows of rank-2 array A.
(array-slice-for-each 1 (lambda (x) (sort! x <)) a)

;; Compute the arguments of the (x y) vectors in the rows of rank-2
;; array XYS and store them in rank-1 array ANGLES. Inside OP,
;; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.

(array-slice-for-each 1 
  (lambda (xy angle)
    (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))
  xys angles)
@end lisp"
  (match arrays
    (() (values))
    ((head tail ...)
     (let ((dims (array-dimensions head)))
       (unless (<= frame-rank (length dims))
         (error "frame too large for argument" frame-rank head))
       (define frame-dims (list-head dims frame-rank))
       (for-each (lambda (array)
                   (define dims (array-dimensions array))
                   (unless (<= frame-rank (length dims))
                     (error "frame too large for argument" frame-rank array))
                   (unless (equal? (list-head dims frame-rank) frame-dims)
                     (error "mismatched frames" frame-dims array)))
                 tail)
       (let recur ((arrays arrays)
                   (frame-dims frame-dims))
         (match frame-dims
           (()
            (apply proc arrays))
           ((dim . frame-dims)
            (let slice ((n (dim-start dim)))
              (when (< n (dim-end dim))
                (recur (map (lambda (array) (array-slice array n)) arrays)
                       frame-dims)
                (slice (1+ n))))))))))
  *unspecified*)

(define (array-slice-for-each-in-order frame-rank proc . arrays)
  "Same as array-slice-for-each, but visit the cells sequentially
and in row-major order."
  (apply array-slice-for-each frame-rank proc arrays))

(define (array-cell-ref array . indices)
  "Return the element at the @code{(@var{indices} ...)} position
in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]
if the rank of @var{ra} is larger than the number of indices.

See also @code{array-ref}, @code{array-slice}, @code{array-cell-set!}.

@code{array-cell-ref} never returns a rank 0 array. For example:
@lisp
(array-cell-ref #2((1 2 3) (4 5 6)) 1 1) @result{} 5
(array-cell-ref #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)
(array-cell-ref #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))
(array-cell-ref #0(5) @result{} 5.
@end lisp"
  (if (= (length indices) (array-rank array))
      (apply array-ref array indices)
      (apply array-slice array indices)))

(define (array-cell-set! array val . indices)
  "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}.

Equivalent to @code{(array-copy! @var{b} (apply array-cell-ref @var{ra}
@var{indices}))} if the number of indices is smaller than the rank of
@var{ra}; otherwise equivalent to @code{(apply array-set! @var{ra}
@var{b} @var{indices})}.  This function returns the modified array
@var{ra}.

See also @code{array-ref}, @code{array-cell-ref}, @code{array-slice}.

For example:
@lisp
(define A (list->array 2 '((1 2 3) (4 5 6))))
(array-cell-set! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))
(array-cell-set! A 99 1 1) @result{} #2((1 2 3) (4 99 6))
(array-cell-set! A #(a b c) 0) @result{} #2((a b c) (4 99 6))
(array-cell-set! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))

(define B (make-array 0))
(array-cell-set! B 15) @result{} #0(15)
@end lisp"
  (if (= (length indices) (array-rank array))
      (apply array-set! array val indices)
      (array-copy! val (apply array-slice array indices)))
  array)


;; Printing arrays

;; The dimensions aren't printed out unless they cannot be deduced from
;; the content, which happens only when certain axes are empty. #:dims?
;; can be used to force this printing. An array with all the dimensions
;; printed out is still readable syntax, this can be useful for
;; truncated-print.

(define* (array-print-prefix a port #:key dims?)
  (put-char port #\#)
  (display (array-rank a) port)
  (let ((t (array-type a)))
    (unless (eq? #t t)
      (display t port)))
  (let ((ss (array-shape a)))
    (let loop ((s ss) (slos? #f) (szero? #f) (slens? dims?))
      (define lo caar)
      (define hi cadar)
      (if (null? s)
        (when (or slos? slens?)
          (pair-for-each (lambda (s)
                           (when slos?
                             (put-char port #\@)
                             (display (lo s) port))
                           (when slens?
                             (put-char port #\:)
                             (display (- (hi s) (lo s) -1) port)))
                         ss))
        (let ((zero-size? (zero? (- (hi s) (lo s) -1))))
          (loop (cdr s)
                (or slos? (not (zero? (lo s))))
                (or szero? zero-size?)
                (or slens? (and (not zero-size?) szero?))))))))