Return to the good old working days

1 files changed, 143 insertions, 138 deletions

@@ -1,145 +1,150 @@
-(module (chicanery extras) ( append for-each map
-                             list-append list-for-each list-map
-                             ref copy
-                             atom? defined?
-                             read-port-chunk-size read-port
-                             with-output-to-string with-input-from-string
-                             displayed written print ->string)
-  (import scheme (chicanery base))
-
-  (define list-append append)
-  (define list-for-each for-each)
-  (define list-map map)
-
-  (define (map proc . collections)
-    (let ((first (car collections)))    ; we only need to check the first one
-      (cond
-       ((list? first)
-        (apply list-map proc collections))
-       ((vector? first)
-        (apply vector-map proc collections))
-       ((string? first)
-        (apply string-map proc collections))
-       (else (error "Bad datatype" first)))))
-
-  (define (for-each proc . collections)
-    (let ((first (car collections)))    ; we only need to check the first one
-      (cond
-       ((list? first)
-        (apply list-for-each proc collections))
-       ((vector? first)
-        (apply vector-for-each proc collections))
-       ((string? first)
-        (apply string-for-each proc collections))
-       (else (error "Bad datatype" first)))))
-
-  (define (append . collections)
-    (let ((first (car collections)))    ; we only need to check the first one
-      (cond
-       ((list? first)
-        (apply list-append collections))
-       ((vector? first)
-        (apply vector-append collections))
-       ((string? first)
-        (apply string-append collections))
-       ((bytevector? first)
-        (apply bytevector-append collections))
-       (else (error "Bad datatype" first)))))
+(export list-map list-for-each list-append
+        map for-each append)
 
-;;; 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)
+(define list-map map)
+(define list-for-each for-each)
+(define list-append append)
+
+(define (map proc . collections)
+  (let ((first (car collections)))    ; we only need to check the first one
+    (cond
+     ((list? first)
+      (apply list-map proc collections))
+     ((vector? first)
+      (apply vector-map proc collections))
+     ((string? first)
+      (apply string-map proc collections))
+     (else (error "Bad datatype" first)))))
+
+(define (for-each proc . collections)
+  (let ((first (car collections)))    ; we only need to check the first one
     (cond
-     ((list? collection)
-      (list-ref collection k))
-     ((vector? collection)
-      (vector-ref collection k))
-     ((string? collection)
-      (string-ref collection k))
-     ((bytevector? collection)
-      (bytevector-u8-ref collection k))
-     (else (error "Bad datatype" collection))))
-
-  ;; I'm not going to generalize -copy! because I don't think it's a great idea,
-  ;; really.
-  (define (copy collection)
+     ((list? first)
+      (apply list-for-each proc collections))
+     ((vector? first)
+      (apply vector-for-each proc collections))
+     ((string? first)
+      (apply string-for-each proc collections))
+     (else (error "Bad datatype" first)))))
+
+(define (append . collections)
+  (let ((first (car collections)))    ; we only need to check the first one
     (cond
-     ((list? collection)
-      (list-copy collection))
-     ((vector? collection)
-      (vector-copy collection))
-     ((string? collection)
-      (string-copy collection))
-     ((bytevector? collection)
-      (bytevector-copy collection))
-     (else (error "Bad datatype" collection))))
+     ((list? first)
+      (apply list-append collections))
+     ((vector? first)
+      (apply vector-append collections))
+     ((string? first)
+      (apply string-append collections))
+     ((bytevector? first)
+      (apply bytevector-append collections))
+     (else (error "Bad datatype" first)))))
+
+;;; 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)
+  (cond
+   ((list? collection)
+    (list-ref collection k))
+   ((vector? collection)
+    (vector-ref collection k))
+   ((string? collection)
+    (string-ref collection k))
+   ((bytevector? collection)
+    (bytevector-u8-ref collection k))
+   (else (error "Bad datatype" collection))))
+
+;; I'm not going to generalize -copy! because I don't think it's a great idea,
+;; really.
+(define (copy collection)
+  (cond
+   ((list? collection)
+    (list-copy collection))
+   ((vector? collection)
+    (vector-copy collection))
+   ((string? collection)
+    (string-copy collection))
+   ((bytevector? collection)
+    (bytevector-copy collection))
+   (else (error "Bad datatype" collection))))
 
 ;;; Definitions that should be in scheme
 ;; This sections should be as small as possible
 
-  (define (atom? x)
-    (and (not (pair? x))
-         (not (null? 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))))
-
-  (define (defined? sym)
-    (call-with-current-continuation
-     (lambda (k)
-       (with-exception-handler
-           (lambda (e) (k #f))
-         (lambda ()
-           (eval sym (interaction-environment))
-           #t)))))
-
-  (define (with-output-to-string thunk)
-    (call-with-port (open-output-string)
-      (lambda (port)
-        (parameterize ((current-output-port port))
-          (thunk))
-        (get-output-string port))))
-
-  (define (with-input-from-string s thunk)
-    (call-with-port (open-input-string s)
-      (lambda (port)
-        (parameterize ((current-input-port port))
-          (thunk)))))
-
-  (define (displayed x)
-    (with-output-to-string
-      (lambda () (display x))))
-
-  (define (written x)
-    (with-output-to-string
-      (lambda () (write x))))
-
-  (define (print . xs)
-    (for-each display xs)
-    (newline))
-
-  (define ->string displayed))
+(export read-port
+        read-port-chunk-size)
+
+
+(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-chunk-size
+  (make-parameter 512))
+
+(define read-port
+  (case-lambda
+    (() (%read-port (current-input-port)))
+    ((p) (%read-port p))))
+
+(export atom? defined?)
+
+(define (atom? x)
+  (not (or (null? x)
+           (pair? x))))
+
+(define (defined? sym)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+         (lambda (e) (k #f))
+       (lambda ()
+         (eval sym (interaction-environment))
+         #t)))))
+
+(export with-output-to-string
+        with-input-from-string)
+
+(define (with-output-to-string thunk)
+  (call-with-port (open-output-string)
+    (lambda (port)
+      (parameterize ((current-output-port port))
+        (thunk))
+      (get-output-string port))))
+
+(define (with-input-from-string s thunk)
+  (call-with-port (open-input-string s)
+    (lambda (port)
+      (parameterize ((current-input-port port))
+        (thunk)))))
+
+(export displayed ->string written print)
+
+(define (displayed x)
+  (with-output-to-string
+    (lambda () (display x))))
+
+(define (written x)
+  (with-output-to-string
+    (lambda () (write x))))
+
+(define (print . xs)
+  (for-each display xs)
+  (newline))
+
+(define ->string displayed)