home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / strout.scm < prev    next >
Text File  |  2001-03-21  |  4KB  |  105 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: strout.scm,v 14.15 2001/03/21 05:40:01 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; String Output Ports
  24. ;;; package: (runtime string-output)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (make-accumulator-output-port)
  29.   (make-port accumulator-output-port-type
  30.          (make-accumulator-state (make-string 16) 0)))
  31.  
  32. (define (get-output-from-accumulator port)
  33.   ((port/operation port 'EXTRACT-OUTPUT!) port))
  34.  
  35. (define (with-output-to-string thunk)
  36.   (with-string-output-port (lambda (port) (with-output-to-port port thunk))))
  37.  
  38. (define (with-string-output-port generator)
  39.   (let ((port (make-accumulator-output-port)))
  40.     (generator port)
  41.     (operation/extract-output! port)))
  42.  
  43. (define accumulator-output-port-type)
  44. (define (initialize-package!)
  45.   (set! accumulator-output-port-type
  46.     (make-port-type `((WRITE-SELF ,operation/write-self)
  47.               (WRITE-CHAR ,operation/write-char)
  48.               (WRITE-SUBSTRING ,operation/write-substring)
  49.               (EXTRACT-OUTPUT! ,operation/extract-output!))
  50.             #f))
  51.   unspecific)
  52.  
  53. (define (operation/write-self port output-port)
  54.   port
  55.   (write-string " to string" output-port))
  56.  
  57. (define (operation/write-char port char)
  58.   (without-interrupts
  59.    (lambda ()
  60.      (let* ((state (port/state port))
  61.         (n (accumulator-state-counter state))
  62.         (n* (fix:+ n 1)))
  63.        (if (fix:= n (string-length (accumulator-state-accumulator state)))
  64.        (grow-accumulator! state n*))
  65.        (string-set! (accumulator-state-accumulator state) n char)
  66.        (set-accumulator-state-counter! state n*)))))
  67.  
  68. (define (operation/write-substring port string start end)
  69.   (without-interrupts
  70.    (lambda ()
  71.      (let* ((state (port/state port))
  72.         (n (accumulator-state-counter state))
  73.         (n* (fix:+ n (fix:- end start))))
  74.        (if (fix:> n* (string-length (accumulator-state-accumulator state)))
  75.        (grow-accumulator! state n*))
  76.        (substring-move! string start end
  77.             (accumulator-state-accumulator state) n)
  78.        (set-accumulator-state-counter! state n*)))))
  79.  
  80. (define (operation/extract-output! port)
  81.   (without-interrupts
  82.    (lambda ()
  83.      (let ((state (port/state port)))
  84.        (let ((s (accumulator-state-accumulator state))
  85.          (n (accumulator-state-counter state)))
  86.      (set-accumulator-state-accumulator! state (make-string 16))
  87.      (set-accumulator-state-counter! state 0)
  88.      (set-string-maximum-length! s n)
  89.      s)))))
  90.  
  91. (define-structure (accumulator-state (type vector))
  92.   accumulator
  93.   counter)
  94.  
  95. (define (grow-accumulator! state min-size)
  96.   (let* ((old (accumulator-state-accumulator state))
  97.      (n (string-length old))
  98.      (new
  99.       (make-string
  100.        (let loop ((n (fix:+ n n)))
  101.          (if (fix:>= n min-size)
  102.          n
  103.          (loop (fix:+ n n)))))))
  104.     (substring-move! old 0 n new 0)
  105.     (set-accumulator-state-accumulator! state new)))