← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/runtime/genio.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2010-03-10 02:00:45 UTC
  • mfrom: (1.1.7 upstream) (3.1.6 sid)
  • Revision ID: james.westby@ubuntu.com-20100310020045-4np1y3ro6sk2oz92
Tags: 9.0.1-1
* New upstream.
* debian/watch: Fix, previous version was broken.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/genio.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: genio.scm,v 1.70 2008/09/17 06:24:32 cph Exp $
4
 
 
5
3
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
6
4
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
7
 
    2006, 2007, 2008 Massachusetts Institute of Technology
 
5
    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
8
6
 
9
7
This file is part of MIT/GNU Scheme.
10
8
 
28
26
;;;; Generic I/O Ports
29
27
;;; package: (runtime generic-i/o-port)
30
28
 
31
 
(declare (usual-integrations))
 
29
(declare (usual-integrations)
 
30
         (integrate-external "port"))
32
31
 
33
32
(define (make-generic-i/o-port source sink #!optional type . extra-state)
34
33
  (if (not (or source sink))
96
95
                (list->vector extra)))
97
96
 
98
97
(define-integrable (port-input-buffer port)
99
 
  (gstate-input-buffer (port/state port)))
 
98
  (gstate-input-buffer (port/%state port)))
100
99
 
101
100
(define-integrable (port-output-buffer port)
102
 
  (gstate-output-buffer (port/state port)))
 
101
  (gstate-output-buffer (port/%state port)))
103
102
 
104
103
(define (generic-i/o-port-accessor index)
105
104
  (guarantee-index-fixnum index 'GENERIC-I/O-PORT-ACCESSOR)
106
105
  (lambda (port)
107
 
    (let ((extra (gstate-extra (port/state port))))
 
106
    (let ((extra (gstate-extra (port/%state port))))
108
107
      (if (not (fix:< index (vector-length extra)))
109
108
          (error "Accessor index out of range:" index))
110
109
      (vector-ref extra index))))
112
111
(define (generic-i/o-port-modifier index)
113
112
  (guarantee-index-fixnum index 'GENERIC-I/O-PORT-MODIFIER)
114
113
  (lambda (port object)
115
 
    (let ((extra (gstate-extra (port/state port))))
 
114
    (let ((extra (gstate-extra (port/%state port))))
116
115
      (if (not (fix:< index (vector-length extra)))
117
116
          (error "Accessor index out of range:" index))
118
117
      (vector-set! extra index object))))
147
146
           (OUTPUT-CHANNEL ,generic-io/output-channel)
148
147
           (OUTPUT-TERMINAL-MODE ,generic-io/output-terminal-mode)
149
148
           (SET-OUTPUT-BLOCKING-MODE ,generic-io/set-output-blocking-mode)
150
 
           (SET-OUTPUT-TERMINAL-MODE ,generic-io/set-output-terminal-mode)))
 
149
           (SET-OUTPUT-TERMINAL-MODE ,generic-io/set-output-terminal-mode)
 
150
           (SYNCHRONIZE-OUTPUT ,generic-io/synchronize-output)))
151
151
        (other-operations
152
152
         `((CLOSE ,generic-io/close)
153
153
           (CODING ,generic-io/coding)
317
317
          ((#F) unspecific)
318
318
          (else (error:wrong-type-datum mode "terminal mode"))))))
319
319
 
 
320
(define (generic-io/synchronize-output port)
 
321
  (let ((channel (generic-io/output-channel port)))
 
322
    (if channel
 
323
        (channel-synchronize channel))))
 
324
 
320
325
(define (generic-io/buffered-output-bytes port)
321
326
  (output-buffer-start (port-output-buffer port)))
322
327
 
401
406
  #t)
402
407
 
403
408
(define (generic-io/coding port)
404
 
  (gstate-coding (port/state port)))
 
409
  (gstate-coding (port/%state port)))
405
410
 
406
411
(define (generic-io/set-coding port name)
407
 
  (let ((state (port/state port)))
 
412
  (let ((state (port/%state port)))
408
413
    (let ((ib (gstate-input-buffer state)))
409
414
      (if ib
410
415
          (set-input-buffer-coding! ib name)))
426
431
        (else '())))
427
432
 
428
433
(define (generic-io/line-ending port)
429
 
  (gstate-line-ending (port/state port)))
 
434
  (gstate-line-ending (port/%state port)))
430
435
 
431
436
(define (generic-io/set-line-ending port name)
432
 
  (let ((state (port/state port)))
 
437
  (let ((state (port/%state port)))
433
438
    (let ((ib (gstate-input-buffer state)))
434
439
      (if ib
435
440
          (set-input-buffer-line-ending!
551
556
(define (initialize-name-maps!)
552
557
  (let ((convert-reverse
553
558
         (lambda (alist)
554
 
           (let ((table (make-eq-hash-table)))
 
559
           (let ((table (make-strong-eq-hash-table)))
555
560
             (for-each (lambda (n.d)
556
561
                         (hash-table/put! table (cdr n.d) (car n.d)))
557
562
                       alist)
558
563
             table)))
559
564
        (convert-forward
560
565
         (lambda (alist)
561
 
           (let ((table (make-eq-hash-table)))
 
566
           (let ((table (make-strong-eq-hash-table)))
562
567
             (for-each (lambda (n.d)
563
568
                         (hash-table/put! table (car n.d) (cdr n.d)))
564
569
                       alist)
1026
1031
                    ob
1027
1032
                    (cond ((char=? char #\tab)
1028
1033
                           (fix:+ column (fix:- 8 (fix:remainder column 8))))
1029
 
                          ((<= #x20 (char->integer char) #x7E)
 
1034
                          ((and (fix:<= #x20 (char->integer char))
 
1035
                                (fix:<= (char->integer char) #x7E))
1030
1036
                           (fix:+ column 1))
1031
1037
                          (else #f))))))
1032
1038
         #t)))
1853
1859
                     (* (get-byte bv bs 1) #x10000)
1854
1860
                     (* (get-byte bv bs 2) #x100)
1855
1861
                     (get-byte bv bs 3))))
1856
 
             (if (unicode-code-point? cp)
 
1862
             (if (unicode-scalar-value? cp)
1857
1863
                 (begin
1858
1864
                   (set-input-buffer-start! ib (fix:+ bs 4))
1859
1865
                   cp)
1869
1875
                     (* (get-byte bv bs 2) #x10000)
1870
1876
                     (* (get-byte bv bs 1) #x100)
1871
1877
                     (get-byte bv bs 0))))
1872
 
             (if (unicode-code-point? cp)
 
1878
             (if (unicode-scalar-value? cp)
1873
1879
                 (begin
1874
1880
                   (set-input-buffer-start! ib (fix:+ bs 4))
1875
1881
                   cp)