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

Last change on this file since 13140 was 13140, checked in by Kon Lovett, 12 years ago

Renamed not proper list error per ##sys#error- for all error type procs, deprecated '##sys#not-a-proper-list-error'.

File size: 7.8 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 (foreign-declare #<<EOF
43#define C_mem_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
44EOF
45) )
46
47(cond-expand
48 [paranoia]
49 [else
50  (declare
51    (no-bound-checks)
52    (no-procedure-checks-for-usual-bindings)
53    (bound-to-procedure
54      ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
55      ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
56      ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
57      ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
58      ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
59      ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
60      ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
61      ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
62      ##sys#flush-output ##sys#write-char-0 ##sys#number->string
63      ##sys#fragments->string ##sys#symbol->qualified-string
64      ##extras#reverse-string-append ##sys#number? ##sys#procedure->string
65      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
66      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
67      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
68      input-port? make-vector list->vector  open-output-string floor 
69      get-output-string current-output-port display write port? list->string
70      call-with-input-string with-input-from-string
71      make-string string newline char-name read 
72      open-input-string call-with-input-file reverse ) ) ] )
73
74(include "unsafe-declarations.scm")
75
76(register-feature! 'ports)
77
78
79;;;; Port-mapping (found in Gauche):
80
81(define (port-for-each fn thunk)
82  (let loop ()
83    (let ((x (thunk)))
84      (unless (eq? x #!eof)
85        (fn x)
86        (loop) ) ) ) )
87
88(define port-map
89  (let ((reverse reverse))
90    (lambda (fn thunk)
91      (let loop ((xs '()))
92        (let ((x (thunk)))
93          (if (eq? x #!eof)
94              (reverse xs)
95              (loop (cons (fn x) xs))))))))
96
97(define (port-fold fn acc thunk)
98  (let loop ([acc acc])
99    (let ([x (thunk)])
100      (if (eq? x #!eof)
101        acc
102        (loop (fn x acc))) ) ) )
103
104;;;; funky-ports
105
106(define (make-broadcast-port . ports)
107  (make-output-port
108   (lambda (s) (for-each (cut write-string s #f <>) ports))
109   noop
110   (lambda () (for-each flush-output ports)) ) )
111
112(define (make-concatenated-port p1 . ports)
113  (let ((ports (cons p1 ports)))
114    (make-input-port
115     (lambda ()
116       (let loop ()
117         (if (null? ports)
118             #!eof
119             (let ((c (read-char (car ports))))
120               (cond ((eof-object? c)
121                      (set! ports (cdr ports))
122                      (loop) )
123                     (else c) ) ) ) ) )
124     (lambda ()
125       (and (not (null? ports))
126            (char-ready? (car ports))))
127     noop
128     (lambda ()
129       (let loop ()
130         (if (null? ports)
131             #!eof
132             (let ((c (peek-char (car ports))))
133               (cond ((eof-object? c)
134                      (set! ports (cdr ports))
135                      (loop) )
136                     (else c))))))
137     (lambda (p n dest start)
138       (let loop ((n n) (c 0))
139         (cond ((null? ports) c)
140               ((fx<= n 0) c)
141               (else
142                (let ((m (read-string! n dest (car ports) (fx+ start c))))
143                  (when (fx< m n)
144                    (set! ports (cdr ports)) )
145                  (loop (fx- n m) (fx+ c m))))))))))
146
147
148;;; Redirect standard ports:
149
150(define (with-input-from-port port thunk)
151  (##sys#check-port port 'with-input-from-port)
152  (fluid-let ([##sys#standard-input port])
153    (thunk) ) )
154
155(define (with-output-to-port port thunk)
156  (##sys#check-port port 'with-output-from-port)
157  (fluid-let ([##sys#standard-output port])
158    (thunk) ) )
159
160(define (with-error-output-to-port port thunk)
161  (##sys#check-port port 'with-error-output-from-port)
162  (fluid-let ([##sys#standard-error port])
163    (thunk) ) )
164
165;;; Extended string-port operations:
166 
167(define call-with-input-string 
168  (let ([open-input-string open-input-string])
169    (lambda (str proc)
170      (let ((in (open-input-string str)))
171        (proc in) ) ) ) )
172
173(define call-with-output-string
174  (let ((open-output-string open-output-string)
175        (get-output-string get-output-string) )
176    (lambda (proc)
177      (let ((out (open-output-string)))
178        (proc out)
179        (get-output-string out) ) ) ) )
180
181(define with-input-from-string
182  (let ((open-input-string open-input-string))
183    (lambda (str thunk)
184      (fluid-let ([##sys#standard-input (open-input-string str)])
185        (thunk) ) ) ) )
186
187(define with-output-to-string
188  (let ([open-output-string open-output-string]
189        [get-output-string get-output-string] )
190    (lambda (thunk)
191      (fluid-let ([##sys#standard-output (open-output-string)])
192        (thunk) 
193        (get-output-string ##sys#standard-output) ) ) ) )
194
195
196;;; Custom ports:
197;
198; - Port-slots:
199;
200;   10: last
201
202(define make-input-port
203  (lambda (read ready? close #!optional peek read-string read-line)
204    (let* ((class
205            (vector
206             (lambda (p)                ; read-char
207               (let ([last (##sys#slot p 10)])
208                 (cond [peek (read)]
209                       [last
210                        (##sys#setislot p 10 #f)
211                        last]
212                       [else (read)] ) ) )
213             (lambda (p)                ; peek-char
214               (let ([last (##sys#slot p 10)])
215                 (cond [peek (peek)]
216                       [last last]
217                       [else
218                        (let ([last (read)])
219                          (##sys#setslot p 10 last)
220                          last) ] ) ) )
221             #f                         ; write-char
222             #f                         ; write-string
223             (lambda (p)                ; close
224               (close)
225               (##sys#setislot p 8 #t) )
226             #f                         ; flush-output
227             (lambda (p)                ; char-ready?
228               (ready?) )
229             read-string                ; read-string!
230             read-line) )               ; read-line
231           (data (vector #f))
232           (port (##sys#make-port #t class "(custom)" 'custom)) )
233      (##sys#setslot port 9 data) 
234      port) ) )
235
236(define make-output-port
237  (let ([string string])
238    (lambda (write close #!optional flush)
239      (let* ((class
240              (vector
241               #f                       ; read-char
242               #f                       ; peek-char
243               (lambda (p c)            ; write-char
244                 (write (string c)) )
245               (lambda (p s)            ; write-string
246                 (write s) )
247               (lambda (p)              ; close
248                 (close)
249                 (##sys#setislot p 8 #t) )
250               (lambda (p)              ; flush-output
251                 (when flush (flush)) )
252               #f                       ; char-ready?
253               #f                       ; read-string!
254               #f) )                    ; read-line
255             (data (vector #f))
256             (port (##sys#make-port #f class "(custom)" 'custom)) )
257        (##sys#setslot port 9 data) 
258        port) ) ) )
Note: See TracBrowser for help on using the repository browser.