← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/runtime/strott.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2005-09-12 21:36:33 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050912213633-shybia1ie66exjvl
Tags: 7.7.90+20050912-1
http://bugs.debian.org/323739
* Acknowledge NMU (thanks Matej!).  (closes: Bug#323739)
* New upstream snapshot.
* Bump standards version to 3.6.2 (no changes).
* Drop texi2html from build dependencies; no longer used.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/strott.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: strott.scm,v 14.11 2003/02/14 18:28:34 cph Exp $
 
3
$Id: strott.scm,v 14.12 2004/02/16 05:38:42 cph Exp $
4
4
 
5
 
Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
5
Copyright 1988,1993,1999,2004 Massachusetts Institute of Technology
6
6
 
7
7
This file is part of MIT/GNU Scheme.
8
8
 
28
28
 
29
29
(declare (usual-integrations))
30
30
 
31
 
(define (initialize-package!)
32
 
  (set! output-string-port-type
33
 
        (make-port-type `((WRITE-SELF ,operation/write-self)
34
 
                          (WRITE-CHAR ,operation/write-char)
35
 
                          (WRITE-SUBSTRING ,operation/write-substring))
36
 
                        #f)))
37
 
 
38
31
(define (with-output-to-truncated-string max thunk)
39
32
  (call-with-current-continuation
40
 
   (lambda (return)
41
 
     (cons #f
42
 
           (apply string-append
43
 
                  (reverse!
44
 
                   (let ((state
45
 
                          (make-output-string-state return max '() max)))
46
 
                     (with-output-to-port
47
 
                         (make-port output-string-port-type state)
48
 
                       thunk)
49
 
                     (output-string-state/accumulator state))))))))
 
33
   (lambda (k)
 
34
     (let ((state (make-astate k max (make-string (fix:min max 128)) 0)))
 
35
       (with-output-to-port (make-port output-string-port-type state)
 
36
         thunk)
 
37
       (cons #f
 
38
             (without-interrupts
 
39
              (lambda ()
 
40
                (string-head (astate-chars state)
 
41
                             (astate-index state)))))))))
50
42
 
51
43
(define output-string-port-type)
 
44
(define (initialize-package!)
 
45
  (set! output-string-port-type
 
46
        (make-port-type
 
47
         `((WRITE-CHAR
 
48
            ,(lambda (port char)
 
49
               (guarantee-8-bit-char char)
 
50
               (let ((state (port/state port)))
 
51
                 (without-interrupts
 
52
                  (lambda ()
 
53
                    (let* ((n (astate-index state)))
 
54
                      (if (fix:< n (astate-max-length state))
 
55
                          (let ((n* (fix:+ n 1)))
 
56
                            (if (fix:= n (string-length (astate-chars state)))
 
57
                                (grow-accumulator! state n*))
 
58
                            (string-set! (astate-chars state) n char)
 
59
                            (set-astate-index! state n*))
 
60
                          ((astate-return state)
 
61
                           (cons #t (string-copy (astate-chars state)))))))))
 
62
               1))
 
63
           (WRITE-SELF
 
64
            ,(lambda (port output-port)
 
65
               port
 
66
               (write-string " to string (truncating)" output-port))))
 
67
         #f))
 
68
  unspecific)
52
69
 
53
 
(define-structure (output-string-state (type vector)
54
 
                                       (conc-name output-string-state/))
 
70
(define-structure (astate (type vector))
55
71
  (return #f read-only #t)
56
72
  (max-length #f read-only #t)
57
 
  accumulator
58
 
  counter)
59
 
 
60
 
(define (operation/write-char port char)
61
 
  (let ((state (port/state port)))
62
 
    (let ((accumulator (output-string-state/accumulator state))
63
 
          (counter (output-string-state/counter state)))
64
 
      (if (zero? counter)
65
 
          ((output-string-state/return state)
66
 
           (cons #t (apply string-append (reverse! accumulator))))
67
 
          (begin
68
 
            (set-output-string-state/accumulator!
69
 
             state
70
 
             (cons (string char) accumulator))
71
 
            (set-output-string-state/counter! state (-1+ counter)))))))
72
 
 
73
 
(define (operation/write-substring port string start end)
74
 
  (let ((state (port/state port)))
75
 
    (let ((accumulator
76
 
           (cons (substring string start end)
77
 
                 (output-string-state/accumulator state)))
78
 
          (counter (- (output-string-state/counter state) (- end start))))
79
 
      (if (negative? counter)
80
 
          ((output-string-state/return state)
81
 
           (cons #t
82
 
                 (substring (apply string-append (reverse! accumulator))
83
 
                            0
84
 
                            (output-string-state/max-length state))))
85
 
          (begin
86
 
            (set-output-string-state/accumulator! state accumulator)
87
 
            (set-output-string-state/counter! state counter))))))
88
 
 
89
 
(define (operation/write-self port output-port)
90
 
  port
91
 
  (write-string " to string (truncating)" output-port))
 
 
b'\\ No newline at end of file'
 
73
  chars
 
74
  index)
 
75
 
 
76
(define (grow-accumulator! state min-size)
 
77
  (let* ((old (astate-chars state))
 
78
         (n (string-length old))
 
79
         (new
 
80
          (make-string
 
81
           (let loop ((n (fix:+ n n)))
 
82
             (if (fix:>= n min-size)
 
83
                 (fix:min n (astate-max-length state))
 
84
                 (loop (fix:+ n n)))))))
 
85
    (substring-move! old 0 n new 0)
 
86
    (set-astate-chars! state new)))
 
 
b'\\ No newline at end of file'