Import Upstream version 2a6upstream/2a6

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