home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / strport.scm < prev    next >
Encoding:
Text File  |  1994-12-07  |  1.6 KB  |  52 lines
  1. ;;;;"strport.scm" Portable string ports for Scheme
  2. ;;;Copyright 1993 Dorai Sitaram and 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. ;N.B.: This implementation assumes you have tmpnam and
  21. ;delete-file defined in your .init file.  tmpnam generates
  22. ;temp file names.  delete-file may be defined to be a dummy
  23. ;procedure that does nothing.
  24.  
  25. (define (call-with-output-string f)
  26.   (let ((tmpf (tmpnam)))
  27.     (call-with-output-file tmpf f)
  28.     (let ((s "") (buf (make-string 512)))
  29.       (call-with-input-file tmpf
  30.     (lambda (inp)
  31.       (let loop ((i 0))
  32.         (let ((c (read-char inp)))
  33.           (cond ((eof-object? c)
  34.              (set! s (string-append s (substring buf 0 i))))
  35.             ((>= i 512)
  36.              (set! s (string-append s buf))
  37.              (loop 0))
  38.             (else
  39.              (string-set! buf i c)
  40.              (loop (+ i 1))))))))
  41.       (delete-file tmpf)
  42.       s)))
  43.  
  44. (define (call-with-input-string s f)
  45.   (let ((tmpf (tmpnam)))
  46.     (call-with-output-file tmpf
  47.       (lambda (outp)
  48.     (display s outp)))
  49.     (let ((x (call-with-input-file tmpf f)))
  50.       (delete-file tmpf)
  51.       x)))
  52.