From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:25 -0800
Subject: Import Upstream version 2a6

---
 obj2str.scm | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 61 insertions(+)
 create mode 100644 obj2str.scm

(limited to 'obj2str.scm')

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)))
-- 
cgit v1.2.3