Fix portability issues

This makes the reference implementation pass on Gauche, Chibi and
Guile.

- tindex unexported because it's not implemented (nor documented in the
  SRFI).
- avoid unportable [ ] in the implementation
- correct reverse-rcons name
- add r7rs boilderplate to build with both chibi and gauche (chibi will
  use (rapid test) since (srfi 64) is not available)

Open issues: tflatten, tpartition-all, tindex and possibly the TODO
comment in "reducers" test block (should be fixed before finalizing?)

Author: pclouds

srfi-171.html

@@ -380,14 +380,14 @@ <h3 id="tconcatenate"><code>tconcatenate</code></h3>
 
 
 <h3 id="tappend-map-proc"><code>(tappend-map</code> <em>proc</em><code>)</code></h3>
-<p>The same as <code>(compose (tmap proc) tcat)</code>.</p>
+<p>The same as <code>(compose (tmap proc) tconcatenate)</code>.</p>
 
 
 <h3 id="tflatten"><code>tflatten</code></h3>
 <p><code>tflatten</code> <strong>is</strong> a transducer that flattens an input
     consisting of lists.</p>
 
-<p><code>(list-transduce (tflatten) rcons '((1 2) 3 (4 (5 6) 7 8) 9)</code> =&gt;
+<p><code>(list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7 8) 9)</code> =&gt;
     <code>(1 2 3 4 5 6 7 8 9)</code></p>
 
 

srfi/171-impl.scm

@@ -51,7 +51,7 @@
     ((lst x) (cons x lst))))
 
 
-(define reverse-rconj
+(define reverse-rcons
   (case-lambda
     (() '())
     ((lst) lst)
@@ -183,7 +183,7 @@
             x))))
    ((hash-table? map)
     (lambda (x)
-      (hash-ref map x x)))))
+      (hash-table-ref map x x)))))
 
 
 (define (treplace map)
@@ -304,16 +304,16 @@
     (() (tdelete-duplicates equal?))
     ((equality-pred?)
      (lambda (reducer)
-       (let ([already-seen (make-hash-table equality-pred?)])
+       (let ((already-seen (make-hash-table equality-pred?)))
          (case-lambda
-           [() (reducer)]
-           [(result) (reducer result)]
-           [(result input)
+           (() (reducer))
+           ((result) (reducer result))
+           ((result input)
             (if (hash-table-exists? already-seen input)
                 result
                 (begin
                   (hash-table-set! already-seen input #t)
-                  (reducer result input)))]))))))
+                  (reducer result input))))))))))
 
 ;; Partitions the input into lists of N items. If the input stops it flushes whatever
 ;; it has collected, which may be shorter than n.

srfi/171.sld

@@ -0,0 +1,64 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2019 Linus Björnstam
+;;
+;; You may use this code under either the license in the SRFI document or the
+;; license below.
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define-library (srfi 171)
+  (import (scheme base)
+          (scheme case-lambda)
+          (scheme write)
+          (srfi 9)
+          (only (scheme vector) vector->list)
+          (srfi 69)
+          (srfi 171 meta))
+  (cond-expand
+   (gauche (import (only (gauche base) compose reverse!)))
+   (chibi (import (only (srfi 1) reverse!))))
+  (export rcons reverse-rcons
+          rcount
+          rany
+          revery
+
+          list-transduce
+          vector-transduce
+          string-transduce
+          bytevector-u8-transduce
+          port-transduce
+
+          tmap
+          tfilter
+          tremove
+          treplace
+          tfilter-map
+          tdrop
+          tdrop-while
+          ttake
+          ttake-while
+          tconcatenate
+          tappend-map
+          tdelete-neighbor-dupes
+          tdelete-duplicates
+          tflatten
+          tsegment
+          tpartition
+          tinterpose
+          tlog)
+
+  ;; compose.scm uses fold-left, not available in
+  ;; Chibi. This is all we need for this SRFI
+  (cond-expand
+   (chibi (begin (define compose
+                   (lambda (f g)
+                     (lambda args
+                       (f (apply g args)))))))
+   (else (begin)))
+
+  (include "171-impl.scm"))

srfi/171/meta.sld

@@ -0,0 +1,28 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2019 Linus Björnstam
+;;
+;; You may use this code under either the license in the SRFI document or the
+;; license below.
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-library (srfi 171 meta)
+  (import (scheme base) (srfi 9))
+  (export reduced reduced?
+          unreduce
+          ensure-reduced
+          preserving-reduced
+
+          list-reduce
+          vector-reduce
+          string-reduce
+          bytevector-u8-reduce
+          port-reduce)
+
+  (include "../srfi-171-meta.scm"))
+
+

srfi/srfi-171-meta.scm

@@ -0,0 +1,85 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Copyright 2019 Linus Björnstam
+;;
+;; You may use this code under either the license in the SRFI document or the
+;; license below.
+;;
+;; Permission to use, copy, modify, and/or distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all source copies.
+;; The software is provided "as is", without any express or implied warranties.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A reduced value is stops the transduction.
+(define-record-type <reduced>
+  (reduced val)
+  reduced?
+  (val unreduce))
+
+
+;; helper function which ensures x is reduced.
+(define (ensure-reduced x)
+  (if (reduced? x)
+      x
+      (reduced x)))
+
+
+;; helper function that wraps a reduced value twice since reducing functions (like list-reduce)
+;; unwraps them. tconcatenate is a good example: it re-uses it's reducer on it's input using list-reduce.
+;; If that reduction finishes early and returns a reduced value, list-reduce would "unreduce"
+;; that value and try to continue the transducing process.
+(define (preserving-reduced reducer)
+  (lambda (a b)
+    (let ((return (reducer a b)))
+      (if (reduced? return)
+          (reduced return)
+          return))))
+
+
+;; This is where the magic tofu is cooked
+(define (list-reduce f identity lst)
+  (if (null? lst)
+      identity
+      (let ((v (f identity (car lst))))
+        (if (reduced? v)
+            (unreduce v)
+            (list-reduce f v (cdr lst))))))
+
+(define (vector-reduce f identity vec)
+  (let ((len (vector-length vec)))
+    (let loop ((i 0) (acc identity))
+      (if (= i len)
+          acc
+          (let ((acc (f acc (vector-ref vec i))))
+            (if (reduced? acc)
+                (unreduce acc)
+                (loop (+ i 1) acc)))))))
+
+(define (string-reduce f identity str)
+  (let ((len (string-length str)))
+    (let loop ((i 0) (acc identity))
+      (if (= i len)
+          acc
+          (let ((acc (f acc (string-ref str i))))
+            (if (reduced? acc)
+                (unreduce acc)
+                (loop (+ i 1) acc)))))))
+
+(define (bytevector-u8-reduce f identity vec)
+  (let ((len (bytevector-length vec)))
+    (let loop ((i 0) (acc identity))
+      (if (= i len)
+          acc
+          (let ((acc (f acc (bytevector-u8-ref vec i))))
+            (if (reduced? acc)
+                (unreduce acc)
+                (loop (+ i 1) acc)))))))
+
+(define (port-reduce f identity reader port)
+  (let loop ((val (reader port)) (acc identity))
+    (if (eof-object? val)
+        acc
+        (let ((acc (f acc val)))
+          (if (reduced? acc)
+              (unreduce acc)
+              (loop (reader port) acc))))))

srfi/srfi-171.scm

@@ -41,7 +41,6 @@
                   tsegment
                   tpartition
                   tinterpose
-                  tindex
                   tlog))
 
 (include "171-impl.scm")

srfi/srfi-171/meta.scm

@@ -27,77 +27,5 @@
             bytevector-u8-reduce
             port-reduce))
 
+(include "../srfi-171-meta.scm")
 
-;; A reduced value is stops the transduction.
-(define-record-type <reduced>
-  (reduced val)
-  reduced?
-  (val unreduce))
-
-
-;; helper function which ensures x is reduced.
-(define (ensure-reduced x)
-  (if (reduced? x)
-      x
-      (reduced x)))
-
-
-;; helper function that wraps a reduced value twice since reducing functions (like list-reduce)
-;; unwraps them. tconcatenate is a good example: it re-uses it's reducer on it's input using list-reduce.
-;; If that reduction finishes early and returns a reduced value, list-reduce would "unreduce"
-;; that value and try to continue the transducing process.
-(define (preserving-reduced reducer)
-  (lambda (a b)
-    (let ((return (reducer a b)))
-      (if (reduced? return)
-          (reduced return)
-          return))))
-
-
-;; This is where the magic tofu is cooked
-(define (list-reduce f identity lst)
-  (if (null? lst)
-      identity
-      (let ((v (f identity (car lst))))
-        (if (reduced? v)
-            (unreduce v)
-            (list-reduce f v (cdr lst))))))
-
-(define (vector-reduce f identity vec)
-  (let ((len (vector-length vec)))
-    (let loop ((i 0) (acc identity))
-      (if (= i len)
-          acc
-          (let ((acc (f acc (vector-ref vec i))))
-            (if (reduced? acc)
-                (unreduce acc)
-                (loop (+ i 1) acc)))))))
-
-(define (string-reduce f identity str)
-  (let ((len (string-length str)))
-    (let loop ((i 0) (acc identity))
-      (if (= i len)
-          acc
-          (let ((acc (f acc (string-ref str i))))
-            (if (reduced? acc)
-                (unreduce acc)
-                (loop (+ i 1) acc)))))))
-
-(define (bytevector-u8-reduce f identity vec)
-  (let ((len (bytevector-length vec)))
-    (let loop ((i 0) (acc identity))
-      (if (= i len)
-          acc
-          (let ((acc (f acc (bytevector-u8-ref vec i))))
-            (if (reduced? acc)
-                (unreduce acc)
-                (loop (+ i 1) acc)))))))
-
-(define (port-reduce f identity reader port)
-  (let loop ((val (reader port)) (acc identity))
-    (if (eof-object? val)
-        acc
-        (let ((acc (f acc val)))
-          (if (reduced? acc)
-              (unreduce acc)
-              (loop (reader port) acc))))))

tests-guile.scm

@@ -0,0 +1,7 @@
+;; These are guile-specific tests. They contain guile-specific hash-tables (as are used in the reference implementation)..
+
+
+(use-modules (srfi srfi-64)
+             (srfi srfi-171))
+
+(include "tests.scm")

tests-r7rs.scm

@@ -0,0 +1,21 @@
+;; These are guile-specific tests. They contain guile-specific hash-tables (as are used in the reference implementation)..
+
+
+(import (scheme base)
+        (scheme char)
+        (scheme list)
+        (srfi 171))
+(cond-expand
+ (gauche (import (only (gauche base) compose)
+                 (srfi 64)))
+ (chibi (import (rapid test))))
+
+(cond-expand
+ (chibi (begin
+          (define compose
+            (lambda (f g)
+              (lambda args
+                (f (apply g args)))))))
+ (else (begin)))
+
+(include "tests.scm")