home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / output.scm < prev    next >
Text File  |  2001-03-21  |  5KB  |  162 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: output.scm,v 14.23 2001/03/21 05:40:40 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Output
  24. ;;; package: (runtime output-port)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. ;;;; Output Ports
  29.  
  30. (define (output-port/write-char port char)
  31.   ((output-port/operation/write-char port) port char))
  32.  
  33. (define (output-port/write-string port string)
  34.   (output-port/write-substring port string 0 (xstring-length string)))
  35.  
  36. (define (output-port/write-substring port string start end)
  37.   ((output-port/operation/write-substring port) port string start end))
  38.  
  39. (define (output-port/write-object port object)
  40.   (unparse-object/top-level object port #t (current-unparser-table)))
  41.  
  42. (define (output-port/fresh-line port)
  43.   ((output-port/operation/fresh-line port) port))
  44.  
  45. (define (output-port/flush-output port)
  46.   ((output-port/operation/flush-output port) port))
  47.  
  48. (define (output-port/discretionary-flush port)
  49.   ((output-port/operation/discretionary-flush port) port))
  50.  
  51. (define (output-port/x-size port)
  52.   (or (let ((operation (port/operation port 'X-SIZE)))
  53.     (and operation
  54.          (operation port)))
  55.       80))
  56.  
  57. (define (output-port/y-size port)
  58.   (let ((operation (port/operation port 'Y-SIZE)))
  59.     (and operation
  60.      (operation port))))
  61.  
  62. ;;;; Output Procedures
  63.  
  64. (define (newline #!optional port)
  65.   (let ((port
  66.      (if (default-object? port)
  67.          (current-output-port)
  68.          (guarantee-output-port port))))
  69.     (output-port/write-char port #\newline)
  70.     (output-port/discretionary-flush port)))
  71.  
  72. (define (fresh-line #!optional port)
  73.   (let ((port
  74.      (if (default-object? port)
  75.          (current-output-port)
  76.          (guarantee-output-port port))))
  77.     (output-port/fresh-line port)
  78.     (output-port/discretionary-flush port)))
  79.  
  80. (define (write-char char #!optional port)
  81.   (let ((port
  82.      (if (default-object? port)
  83.          (current-output-port)
  84.          (guarantee-output-port port))))
  85.     (output-port/write-char port char)
  86.     (output-port/discretionary-flush port)))
  87.  
  88. (define (write-string string #!optional port)
  89.   (let ((port
  90.      (if (default-object? port)
  91.          (current-output-port)
  92.          (guarantee-output-port port))))
  93.     (output-port/write-string port string)
  94.     (output-port/discretionary-flush port)))
  95.  
  96. (define (write-substring string start end #!optional port)
  97.   (let ((port
  98.      (if (default-object? port)
  99.          (current-output-port)
  100.          (guarantee-output-port port))))
  101.     (output-port/write-substring port string start end)
  102.     (output-port/discretionary-flush port)))
  103.  
  104. (define (wrap-custom-operation-0 operation-name)
  105.   (lambda (#!optional port)
  106.     (let ((port
  107.        (if (default-object? port)
  108.            (current-output-port)
  109.            (guarantee-output-port port))))
  110.       (let ((operation (port/operation port operation-name)))
  111.     (if operation
  112.         (begin
  113.           (operation port)
  114.           (output-port/discretionary-flush port)))))))
  115.  
  116. (define beep (wrap-custom-operation-0 'BEEP))
  117. (define clear (wrap-custom-operation-0 'CLEAR))
  118.  
  119. (define (display object #!optional port unparser-table)
  120.   (let ((port
  121.      (if (default-object? port)
  122.          (current-output-port)
  123.          (guarantee-output-port port)))
  124.     (unparser-table
  125.      (if (default-object? unparser-table)
  126.          (current-unparser-table)
  127.          (guarantee-unparser-table unparser-table 'DISPLAY))))
  128.     (if (string? object)
  129.     (output-port/write-string port object)
  130.     (unparse-object/top-level object port #f unparser-table))
  131.     (output-port/discretionary-flush port)))
  132.  
  133. (define (write object #!optional port unparser-table)
  134.   (let ((port
  135.      (if (default-object? port)
  136.          (current-output-port)
  137.          (guarantee-output-port port)))
  138.     (unparser-table
  139.      (if (default-object? unparser-table)
  140.          (current-unparser-table)
  141.          (guarantee-unparser-table unparser-table 'WRITE))))
  142.     (unparse-object/top-level object port #t unparser-table)
  143.     (output-port/discretionary-flush port)))
  144.  
  145. (define (write-line object #!optional port unparser-table)
  146.   (let ((port
  147.      (if (default-object? port)
  148.          (current-output-port)
  149.          (guarantee-output-port port)))
  150.     (unparser-table
  151.      (if (default-object? unparser-table)
  152.          (current-unparser-table)
  153.          (guarantee-unparser-table unparser-table 'WRITE-LINE))))
  154.     (unparse-object/top-level object port #t unparser-table)
  155.     (output-port/write-char port #\newline)
  156.     (output-port/discretionary-flush port)))
  157.  
  158. (define (flush-output #!optional port)
  159.   (output-port/flush-output
  160.    (if (default-object? port)
  161.        (current-output-port)
  162.        (guarantee-output-port port))))