← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/runtime/output.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/output.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: output.scm,v 14.44 2008/07/26 07:01:34 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
;;;; Output
29
27
;;; package: (runtime output-port)
30
28
 
31
 
(declare (usual-integrations))
 
29
(declare (usual-integrations)
 
30
         (integrate-external "port"))
32
31
 
33
32
;;;; Low level
34
33
 
 
34
(define-integrable (output-port/%write-char port char)
 
35
  ((port/%operation/write-char port) port char))
 
36
 
35
37
(define (output-port/write-char port char)
36
38
  ((port/operation/write-char port) port char))
37
39
 
50
52
(define (output-port/flush-output port)
51
53
  ((port/operation/flush-output port) port))
52
54
 
 
55
(define-integrable (output-port/%discretionary-flush port)
 
56
  ((port/%operation/discretionary-flush-output port) port))
 
57
 
53
58
(define (output-port/discretionary-flush port)
54
59
  ((port/operation/discretionary-flush-output port) port))
55
60
 
76
81
  (let ((operation (port/operation port 'BYTES-WRITTEN)))
77
82
    (and operation
78
83
         (operation port))))
 
84
 
 
85
(define (output-port/synchronize-output port)
 
86
  (let ((operation (port/operation port 'SYNCHRONIZE-OUTPUT)))
 
87
    (if operation
 
88
        (operation port))))
79
89
 
80
90
;;;; High level
81
91
 
 
92
(define (%write-char char port)
 
93
  (if (let ((n (output-port/%write-char port char)))
 
94
        (and n
 
95
             (fix:> n 0)))
 
96
      (output-port/%discretionary-flush port)))
 
97
 
82
98
(define (write-char char #!optional port)
83
 
  (let ((port (optional-output-port port 'WRITE-CHAR)))
84
 
    (if (let ((n (output-port/write-char port char)))
85
 
          (and n
86
 
               (fix:> n 0)))
87
 
        (output-port/discretionary-flush port))))
 
99
  (%write-char char (optional-output-port port 'WRITE-CHAR)))
88
100
 
89
101
(define (write-string string #!optional port)
90
102
  (let ((port (optional-output-port port 'WRITE-STRING)))
102
114
 
103
115
(define (newline #!optional port)
104
116
  (let ((port (optional-output-port port 'NEWLINE)))
105
 
    (if (let ((n (output-port/write-char port #\newline)))
 
117
    (if (let ((n (output-port/%write-char port #\newline)))
106
118
          (and n
107
119
               (fix:> n 0)))
108
 
        (output-port/discretionary-flush port))))
 
120
        (output-port/%discretionary-flush port))))
109
121
 
110
122
(define (fresh-line #!optional port)
111
123
  (let ((port (optional-output-port port 'FRESH-LINE)))
112
124
    (if (let ((n (output-port/fresh-line port)))
113
125
          (and n
114
126
               (fix:> n 0)))
115
 
        (output-port/discretionary-flush port))))
 
127
        (output-port/%discretionary-flush port))))
116
128
 
117
129
(define (display object #!optional port environment)
118
130
  (let ((port (optional-output-port port 'DISPLAY)))
119
131
    (unparse-object/top-level object port #f environment)
120
 
    (output-port/discretionary-flush port)))
 
132
    (output-port/%discretionary-flush port)))
121
133
 
122
134
(define (write object #!optional port environment)
123
135
  (let ((port (optional-output-port port 'WRITE)))
124
136
    (output-port/write-object port object environment)
125
 
    (output-port/discretionary-flush port)))
 
137
    (output-port/%discretionary-flush port)))
126
138
 
127
139
(define (write-line object #!optional port environment)
128
140
  (let ((port (optional-output-port port 'WRITE-LINE)))
129
141
    (output-port/write-object port object environment)
130
 
    (output-port/write-char port #\newline)
131
 
    (output-port/discretionary-flush port)))
 
142
    (output-port/%write-char port #\newline)
 
143
    (output-port/%discretionary-flush port)))
132
144
 
133
145
(define (flush-output #!optional port)
134
146
  (output-port/flush-output (optional-output-port port 'FLUSH-OUTPUT)))
136
148
(define (wrap-custom-operation-0 operation-name)
137
149
  (lambda (#!optional port)
138
150
    (let ((port (optional-output-port port operation-name)))
139
 
      (let ((operation (port/operation port operation-name)))
 
151
      (let ((operation (port/%operation port operation-name)))
140
152
        (if operation
141
153
            (begin
142
154
              (operation port)
143
 
              (output-port/discretionary-flush port)))))))
 
155
              (output-port/%discretionary-flush port)))))))
144
156
 
145
157
(define beep (wrap-custom-operation-0 'BEEP))
146
158
(define clear (wrap-custom-operation-0 'CLEAR))