home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / obj2str < prev    next >
Text File  |  1994-05-25  |  2KB  |  61 lines
  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. (define (object->string obj)
  23.   (cond ((symbol? obj) (symbol->string obj))
  24.     ((number? obj) (number->string obj))
  25.     (else
  26.      (call-with-output-string
  27.       (lambda (port) (write obj port))))))
  28.  
  29. ; File: "obj2str.scm"   (c) 1991, Marc Feeley
  30.  
  31. ;(require 'generic-write)
  32.  
  33. ; (object->string obj) returns the textual representation of 'obj' as a
  34. ; string.
  35. ;
  36. ; Note: (write obj) = (display (object->string obj))
  37.  
  38. ;(define (object->string obj)
  39. ;  (let ((result '()))
  40. ;    (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
  41. ;    (reverse-string-append result)))
  42.  
  43. ; (object->limited-string obj limit) returns a string containing the first
  44. ; 'limit' characters of the textual representation of 'obj'.
  45.  
  46. ;(define (object->limited-string obj limit)
  47. ;  (let ((result '()) (left limit))
  48. ;    (generic-write obj #f #f
  49. ;      (lambda (str)
  50. ;        (let ((len (string-length str)))
  51. ;          (if (> len left)
  52. ;            (begin
  53. ;              (set! result (cons (substring str 0 left) result))
  54. ;              (set! left 0)
  55. ;              #f)
  56. ;            (begin
  57. ;              (set! result (cons str result))
  58. ;              (set! left (- left len))
  59. ;              #t)))))
  60. ;    (reverse-string-append result)))
  61.