module/slib/obj2str.scm

   1 ;;; "obj2str.scm", write objects to a string.
   2 ;Copyright (C) 1993, 1994 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'string-port)
  21
  22 ;;@body Returns the textual representation of @1 as a string.
  23 (define (object->string obj)
  24   (cond ((symbol? obj) (symbol->string obj))
  25         ((number? obj) (number->string obj))
  26         (else
  27          (call-with-output-string
  28           (lambda (port) (write obj port))))))
  29
  30 ; File: "obj2str.scm"   (c) 1991, Marc Feeley
  31
  32 ;(require 'generic-write)
  33
  34 ; (object->string obj) returns the textual representation of 'obj' as a
  35 ; string.
  36 ;
  37 ; Note: (write obj) = (display (object->string obj))
  38
  39 ;(define (object->string obj)
  40 ;  (let ((result '()))
  41 ;    (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
  42 ;    (reverse-string-append result)))
  43
  44 ; (object->limited-string obj limit) returns a string containing the first
  45 ; 'limit' characters of the textual representation of 'obj'.
  46
  47 ;;@body Returns the textual representation of @1 as a string of length
  48 ;;at most @2.
  49 (define (object->limited-string obj limit)
  50   (require 'generic-write)
  51   (let ((result '()) (left limit))
  52     (generic-write obj #f #f
  53                    (lambda (str)
  54                      (let ((len (string-length str)))
  55                        (cond ((> len left)
  56                               (set! result (cons (substring str 0 left) result))
  57                               (set! left 0)
  58                               #f)
  59                              (else
  60                               (set! result (cons str result))
  61                               (set! left (- left len))
  62                               #t)))))
  63     (reverse-string-append result)))