source: project/chicken/trunk/ports.scm @ 15583

Last change on this file since 15583 was 15583, checked in by felix winkelmann, 11 years ago

tcp ports allow accessing buffer and buffer size; wrapper for setting port data

File size: 7.7 KB
Line 
1;;; ports.scm - Optional non-standard ports
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11;   Redistributions of source code must retain the above copyright
12;   notice, this list of conditions and the following disclaimer.
13
14;   Redistributions in binary form must reproduce the above copyright
15;   notice, this list of conditions and the following disclaimer in
16;   the documentation and/or other materials provided with the
17;   distribution.
18
19;   Neither the name of the author nor the names of its contributors
20;   may be used to endorse or promote products derived from this
21;   software without specific prior written permission.
22;
23; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
28; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
29; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
30; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
32; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
33; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
34; OF THE POSSIBILITY OF SUCH DAMAGE.
35
36
37(declare
38 (unit ports)
39; (uses data-structures)
40 (usual-integrations)
41 (disable-warning redef) )
42
43(cond-expand
44 [paranoia]
45 [else
46  (declare
47    (no-bound-checks)
48    (no-procedure-checks-for-usual-bindings)
49    (bound-to-procedure
50      ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
51      ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
52      ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
53      ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
54      ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
55      ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
56      ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
57      ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
58      ##sys#flush-output ##sys#write-char-0 ##sys#number->string
59      ##sys#fragments->string ##sys#symbol->qualified-string
60      ##extras#reverse-string-append ##sys#number? ##sys#procedure->string
61      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
62      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
63      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
64      input-port? make-vector list->vector  open-output-string floor 
65      get-output-string current-output-port display write port? list->string
66      call-with-input-string with-input-from-string
67      make-string string newline char-name read 
68      open-input-string call-with-input-file reverse ) ) ] )
69
70(include "unsafe-declarations.scm")
71
72(register-feature! 'ports)
73
74
75;;;; Port-mapping (found in Gauche):
76
77(define (port-for-each fn thunk)
78  (let loop ()
79    (let ((x (thunk)))
80      (unless (eof-object? x)
81        (fn x)
82        (loop) ) ) ) )
83
84(define port-map
85  (let ((reverse reverse))
86    (lambda (fn thunk)
87      (let loop ((xs '()))
88        (let ((x (thunk)))
89          (if (eof-object? x)
90              (reverse xs)
91              (loop (cons (fn x) xs))))))))
92
93(define (port-fold fn acc thunk)
94  (let loop ([acc acc])
95    (let ([x (thunk)])
96      (if (eof-object? x)
97          acc
98          (loop (fn x acc))) ) ) )
99
100;;;; funky-ports
101
102(define (make-broadcast-port . ports)
103  (make-output-port
104   (lambda (s) (for-each (cut write-string s #f <>) ports))
105   noop
106   (lambda () (for-each flush-output ports)) ) )
107
108(define (make-concatenated-port p1 . ports)
109  (let ((ports (cons p1 ports)))
110    (make-input-port
111     (lambda ()
112       (let loop ()
113         (if (null? ports)
114             #!eof
115             (let ((c (read-char (car ports))))
116               (cond ((eof-object? c)
117                      (set! ports (cdr ports))
118                      (loop) )
119                     (else c) ) ) ) ) )
120     (lambda ()
121       (and (not (null? ports))
122            (char-ready? (car ports))))
123     noop
124     (lambda ()
125       (let loop ()
126         (if (null? ports)
127             #!eof
128             (let ((c (peek-char (car ports))))
129               (cond ((eof-object? c)
130                      (set! ports (cdr ports))
131                      (loop) )
132                     (else c))))))
133     (lambda (p n dest start)
134       (let loop ((n n) (c 0))
135         (cond ((null? ports) c)
136               ((fx<= n 0) c)
137               (else
138                (let ((m (read-string! n dest (car ports) (fx+ start c))))
139                  (when (fx< m n)
140                    (set! ports (cdr ports)) )
141                  (loop (fx- n m) (fx+ c m))))))))))
142
143
144;;; Redirect standard ports:
145
146(define (with-input-from-port port thunk)
147  (##sys#check-port port 'with-input-from-port)
148  (fluid-let ([##sys#standard-input port])
149    (thunk) ) )
150
151(define (with-output-to-port port thunk)
152  (##sys#check-port port 'with-output-from-port)
153  (fluid-let ([##sys#standard-output port])
154    (thunk) ) )
155
156(define (with-error-output-to-port port thunk)
157  (##sys#check-port port 'with-error-output-from-port)
158  (fluid-let ([##sys#standard-error port])
159    (thunk) ) )
160
161;;; Extended string-port operations:
162 
163(define call-with-input-string 
164  (let ([open-input-string open-input-string])
165    (lambda (str proc)
166      (let ((in (open-input-string str)))
167        (proc in) ) ) ) )
168
169(define call-with-output-string
170  (let ((open-output-string open-output-string)
171        (get-output-string get-output-string) )
172    (lambda (proc)
173      (let ((out (open-output-string)))
174        (proc out)
175        (get-output-string out) ) ) ) )
176
177(define with-input-from-string
178  (let ((open-input-string open-input-string))
179    (lambda (str thunk)
180      (fluid-let ([##sys#standard-input (open-input-string str)])
181        (thunk) ) ) ) )
182
183(define with-output-to-string
184  (let ([open-output-string open-output-string]
185        [get-output-string get-output-string] )
186    (lambda (thunk)
187      (fluid-let ([##sys#standard-output (open-output-string)])
188        (thunk) 
189        (get-output-string ##sys#standard-output) ) ) ) )
190
191
192;;; Custom ports:
193;
194; - Port-slots:
195;
196;   10: last
197
198(define make-input-port
199  (lambda (read ready? close #!optional peek read-string read-line)
200    (let* ((class
201            (vector
202             (lambda (p)                ; read-char
203               (let ([last (##sys#slot p 10)])
204                 (cond [peek (read)]
205                       [last
206                        (##sys#setislot p 10 #f)
207                        last]
208                       [else (read)] ) ) )
209             (lambda (p)                ; peek-char
210               (let ([last (##sys#slot p 10)])
211                 (cond [peek (peek)]
212                       [last last]
213                       [else
214                        (let ([last (read)])
215                          (##sys#setslot p 10 last)
216                          last) ] ) ) )
217             #f                         ; write-char
218             #f                         ; write-string
219             (lambda (p)                ; close
220               (close)
221               (##sys#setislot p 8 #t) )
222             #f                         ; flush-output
223             (lambda (p)                ; char-ready?
224               (ready?) )
225             read-string                ; read-string!
226             read-line) )               ; read-line
227           (data (vector #f))
228           (port (##sys#make-port #t class "(custom)" 'custom)) )
229      (##sys#set-port-data! port data) 
230      port) ) )
231
232(define make-output-port
233  (let ([string string])
234    (lambda (write close #!optional flush)
235      (let* ((class
236              (vector
237               #f                       ; read-char
238               #f                       ; peek-char
239               (lambda (p c)            ; write-char
240                 (write (string c)) )
241               (lambda (p s)            ; write-string
242                 (write s) )
243               (lambda (p)              ; close
244                 (close)
245                 (##sys#setislot p 8 #t) )
246               (lambda (p)              ; flush-output
247                 (when flush (flush)) )
248               #f                       ; char-ready?
249               #f                       ; read-string!
250               #f) )                    ; read-line
251             (data (vector #f))
252             (port (##sys#make-port #f class "(custom)" 'custom)) )
253        (##sys#set-port-data! port data) 
254        port) ) ) )
Note: See TracBrowser for help on using the repository browser.