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(-)
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