summaryrefslogtreecommitdiffstats
path: root/obj2str.scm
diff options
context:
space:
mode:
Diffstat (limited to 'obj2str.scm')
-rw-r--r--obj2str.scm61
1 files changed, 61 insertions, 0 deletions
diff --git a/obj2str.scm b/obj2str.scm
new file mode 100644
index 0000000..19d8464
--- /dev/null
+++ b/obj2str.scm
@@ -0,0 +1,61 @@
+;;; "obj2str.scm", write objects to a string.
+;Copyright (C) 1993, 1994 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'string-port)
+
+(define (object->string obj)
+ (cond ((symbol? obj) (symbol->string obj))
+ ((number? obj) (number->string obj))
+ (else
+ (call-with-output-string
+ (lambda (port) (write obj port))))))
+
+; File: "obj2str.scm" (c) 1991, Marc Feeley
+
+;(require 'generic-write)
+
+; (object->string obj) returns the textual representation of 'obj' as a
+; string.
+;
+; Note: (write obj) = (display (object->string obj))
+
+;(define (object->string obj)
+; (let ((result '()))
+; (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
+; (reverse-string-append result)))
+
+; (object->limited-string obj limit) returns a string containing the first
+; 'limit' characters of the textual representation of 'obj'.
+
+(define (object->limited-string obj limit)
+ (require 'generic-write)
+ (let ((result '()) (left limit))
+ (generic-write obj #f #f
+ (lambda (str)
+ (let ((len (string-length str)))
+ (if (> len left)
+ (begin
+ (set! result (cons (substring str 0 left) result))
+ (set! left 0)
+ #f)
+ (begin
+ (set! result (cons str result))
+ (set! left (- left len))
+ #t)))))
+ (reverse-string-append result)))