From 13bccf6b0d0b4c6ed4161e0f0dab2f7c9f92e161 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Wed, 26 Jul 2023 09:16:49 -0500
Subject: Add a few more extras

---
 chicanery.extras.scm | 47 ++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 42 insertions(+), 5 deletions(-)

(limited to 'chicanery.extras.scm')

diff --git a/chicanery.extras.scm b/chicanery.extras.scm
index 24cdff9..27968df 100644
--- a/chicanery.extras.scm
+++ b/chicanery.extras.scm
@@ -1,8 +1,10 @@
 ;;; chicanery extras --- extra stuff from ur old pal acdw
 
-(export list-map list-for-each list-append)
+(export list-map
+        list-for-each
+        list-append)
 
-;; Generalized map, for-each, ...
+;;; Generalized map, for-each, ...
 ;; List versions are renamed `list-<function>'.  Un-prefixed versions work
 ;; with any (default) datatype.  TODO: generalize?
 (define list-map map)
@@ -44,9 +46,10 @@
       (apply bytevector-append collections))
      (else (error "Bad datatype" first)))))
 
-(export ref copy)
+(export ref
+        copy)
 
-;; Extended generic functions.
+;;; Extended generic functions.
 ;; These functions already have a list- version defined, but no non-prefixed
 ;; one.  So I'm fixing that.
 (define (ref collection k)
@@ -75,4 +78,38 @@
     (bytevector-copy collection))
    (else (error "Bad datatype" collection))))
 
-;; TODO: look at set! semantics -- generalizable?
+;;; Functions that should be in scheme
+;; This sections should be as small as possible
+
+(export atom?
+        read-port
+        read-port-chunk-size)
+
+(define (atom? x)
+  (not (pair? x)))
+
+(define read-port-chunk-size
+  (make-parameter 512))
+
+(define (%read-port port)
+  (let ((chunk-size (read-port-chunk-size)))
+    (let loop ((next (read-string chunk-size port))
+               (blank? #f)
+               (acc '()))
+      (cond
+       ((or (eof-object? next)
+            (and blank? (equal? next "")))
+        (apply string-append (reverse acc)))
+       ((equal? next "")
+        (loop (read-string chunk-size port)
+              #t
+              (cons next acc)))
+       (else
+        (loop (read-string chunk-size port)
+              blank?
+              (cons next acc)))))))
+
+(define read-port
+  (case-lambda
+    (() (%read-port (current-input-port)))
+    ((p) (%read-port p))))
-- 
cgit 1.4.1-21-gabe81