Update extras

2 files changed, 53 insertions, 11 deletions

@@ -1,8 +1,7 @@
 ;;; 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
+        map for-each append)
 
 ;;; Generalized map, for-each, ...
 ;; List versions are renamed `list-<function>'.  Un-prefixed versions work
@@ -81,13 +80,9 @@
 ;;; Functions that should be in scheme
 ;; This sections should be as small as possible
 
-(export atom?
-        read-port
+(export read-port
         read-port-chunk-size)
 
-(define (atom? x)
-  (not (pair? x)))
-
 (define read-port-chunk-size
   (make-parameter 512))
 
@@ -113,3 +108,50 @@
   (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)
@@ -20,7 +20,7 @@
   (import (scheme time))
   (import (scheme write))
   (import utf8)
-  (export * + - / <= < >= = > abs and append apply assoc assq assv begin
+  (export * + - / <= < >= = > abs and #;append apply assoc assq assv begin
           binary-port? boolean? boolean=? bytevector bytevector-append
           bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref
           bytevector-u8-set! bytevector? car cdr caar cadr cdar cddr
@@ -34,13 +34,13 @@
           error-object-message error-object? even? odd? exact inexact
           exact-integer-sqrt exact-integer? exact? inexact? exp expt features
           file-error? floor floor/ floor-quotient floor-remainder
-          flush-output-port for-each gcd lcm get-output-bytevector
+          flush-output-port #;for-each gcd lcm get-output-bytevector
           get-output-string guard if import import-for-syntax include include-ci
           input-port-open? output-port-open? input-port? output-port? integer?
           lambda length let let* letrec letrec* let-values let*-values let-syntax
           letrec-syntax list list-copy list-ref list-set! list-tail list?
           list->vector make-bytevector make-list make-parameter make-string
-          make-vector map max min member memq memv modulo remainder negative?
+          make-vector #;map max min member memq memv modulo remainder negative?
           positive? newline not null? number->string string->number number?
           open-input-bytevector open-output-bytevector open-input-string
           open-output-string or pair? parameterize peek-char peek-u8 port?