home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / NEW-PORT.SCM < prev    next >
Text File  |  1992-06-17  |  10KB  |  281 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Additional port types
  5.  
  6. ; Keeping track of a ports current row and column.
  7.  
  8. (define-record-type port-location
  9.   ()
  10.   ((row 0)
  11.    (column 0)))
  12.  
  13. (define make-port-location port-location-maker)
  14.  
  15. (define (update-row-and-column location char)
  16.   (cond ((char=? char #\newline)
  17.      (set-port-location-row! location (+ 1 (port-location-row location)))
  18.      (set-port-location-column! location 0))
  19.     (else
  20.      (set-port-location-column! location
  21.                     (+ 1 (port-location-column location))))))
  22.  
  23. (define (update-row-and-column-from-string location string)
  24.   (let loop ((i 0)
  25.          (row (port-location-row location))
  26.          (column (port-location-column location)))
  27.     (cond ((>= i (string-length string))
  28.        (set-port-location-row!    location row)
  29.        (set-port-location-column! location column))
  30.       ((char=? #\newline (string-ref string i))
  31.        (loop (+ i 1) (+ row 1) 0))
  32.       (else
  33.        (loop (+ i 1) row (+ column 1))))))
  34.  
  35. ; Input ports that keep track of the current row and column.
  36.  
  37. (define-record-type input-port-data
  38.   (sub-port)
  39.   ((location (make-port-location))))
  40.  
  41. (define input-port-methods
  42.   (make-input-port-methods
  43.    (lambda (data)
  44.      (close-port (input-port-data-sub-port data)))
  45.    (lambda (data)
  46.      (let ((char (read-char (input-port-data-sub-port data))))
  47.        (update-row-and-column (input-port-data-location data) char)))
  48.    (lambda (data)
  49.      (peek-char (input-port-data-sub-port data)))
  50.    (lambda (data)
  51.      (port-location-column (input-port-data-location data)))
  52.    (lambda (data)
  53.      (port-location-row (input-port-data-location data)))))
  54.  
  55. (define (make-tracking-input-port sub-port)
  56.   (make-extensible-input-port (input-port-data-maker sub-port)
  57.                    input-port-methods))
  58.  
  59. ; Output ports that keep track of the current row and column.
  60.  
  61. (define-record-type output-port-data
  62.   (sub-port)
  63.   ((location (make-port-location))))
  64.  
  65. (define output-port-methods
  66.   (make-output-port-methods
  67.    (lambda (data)
  68.      (close-port (output-port-data-sub-port data)))
  69.    (lambda (data char)
  70.      (write-char char (output-port-data-sub-port data))
  71.      (update-row-and-column (output-port-data-location data) char))
  72.    (lambda (data string)
  73.      (write-string string (output-port-data-sub-port data))
  74.      (update-row-and-column-from-string (output-port-data-location data)
  75.                     string))
  76.    (lambda (data)
  77.      (force-output (output-port-data-sub-port data)))
  78.    (lambda (data)
  79.      (let ((location (output-port-data-location data)))
  80.        (cond ((not (= 0 (port-location-column location)))
  81.           (write-char #\newline (output-port-data-sub-port data))
  82.           (set-port-location-column! location 0)
  83.           (set-port-location-row! location
  84.                       (+ 1 (port-location-row location)))))))
  85.    (lambda (data)
  86.      (port-location-column (output-port-data-location data)))
  87.    (lambda (data)
  88.      (port-location-row (output-port-data-location data)))))
  89.  
  90. (define (make-tracking-output-port sub-port)
  91.   (make-extensible-output-port (output-port-data-maker sub-port)
  92.                    output-port-methods))
  93.  
  94. ;------------------------------------------------------------------------------
  95. ; String input ports
  96.  
  97. (define-record-type string-input-port-data
  98.   (string)
  99.   ((location (make-port-location))
  100.    (index 0)))
  101.  
  102. (define (make-string-input-port string)
  103.   (make-extensible-input-port (string-input-port-data-maker string)
  104.                   string-input-port-methods))
  105.  
  106. (define string-input-port-methods
  107.   (make-input-port-methods
  108.    (lambda (data)
  109.      (set-string-input-port-data-index!
  110.       (string-length (string-input-port-data-string data))))
  111.    (lambda (data)
  112.      (let ((string (string-input-port-data-string data))
  113.        (index (string-input-port-data-index data)))
  114.        (cond ((>= index (string-length string))
  115.           eof-object)
  116.          (else
  117.           (let ((char (string-ref string index)))
  118.         (set-string-input-port-data-index! data (+ index 1))
  119.         (update-row-and-column (string-input-port-data-location data)
  120.                        char)
  121.         char)))))
  122.    (lambda (data)
  123.      (let ((string (string-input-port-data-string data))
  124.        (index (string-input-port-data-index data)))
  125.        (if (>= index (string-length string))
  126.        eof-object
  127.        (string-ref string index))))
  128.    (lambda (data)
  129.      (port-location-column (string-input-port-data-location data)))
  130.    (lambda (data)
  131.      (port-location-row (string-input-port-data-location data)))))
  132.  
  133. ;------------------------------------------------------------------------------
  134. ; String output ports
  135.  
  136. (define-record-type string-output-port-data
  137.   ()
  138.   ((location (make-port-location))
  139.    (strings '())
  140.    (index string-port-string-length)
  141.    (open? #t)))
  142.  
  143. (define (make-string-output-port)
  144.   (make-extensible-output-port (string-output-port-data-maker)
  145.                    string-output-port-methods))
  146.  
  147. ; The length of the strings used in STRING-OUTPUT-PORTs.
  148. (define string-port-string-length 80)
  149.  
  150. ; Write a character to a string-output-port.  If there is not room in the
  151. ; current string, make a new one and put the character in that; otherwise put
  152. ; the character in the current string and increment the index.
  153.  
  154. (define (write-char-to-string char data)
  155.   (let ((index   (string-output-port-data-index   data))
  156.     (strings (string-output-port-data-strings data)))
  157.     (cond ((>= index string-port-string-length)
  158.        (let ((new (make-string string-port-string-length #\space)))
  159.          (string-set! new 0 char)
  160.          (set-string-output-port-data-strings! data (cons new strings))
  161.          (set-string-output-port-data-index! data 1)))
  162.       (else
  163.        (string-set! (car strings) index char)
  164.        (set-string-output-port-data-index! data (+ index 1))))))
  165.  
  166. ; UPDATE-ROW-AND-COLUMN-FROM-STRING could be integrated with this.
  167.  
  168. (define (write-string-to-string from data)
  169.   (let ((index   (string-output-port-data-index   data))
  170.     (strings (string-output-port-data-strings data)))
  171.     (let loop ((i 0) (index index) (strings strings))
  172.       (cond ((>= i (string-length from))
  173.          (set-string-output-port-data-index! data index)
  174.          (set-string-output-port-data-strings! data strings))
  175.         ((>= index string-port-string-length)
  176.          (let ((new (make-string string-port-string-length #\space)))
  177.            (string-set! new 0 (string-ref from i))
  178.            (loop (+ i 1) 1 (cons new strings))))
  179.         (else
  180.          (string-set! (car strings) index (string-ref from i))
  181.          (loop (+ i 1) (+ index 1) strings))))))
  182.  
  183. ; Concatenates all of the strings of characters in WRITER into a single
  184. ; string.  Nothing is done if WRITER is not a string-output-port.
  185.  
  186. (define (string-output-port-output port)
  187.   (let* ((data (extensible-output-port-local-data port))
  188.      (strings (string-output-port-data-strings data))
  189.      (index (string-output-port-data-index data))
  190.      (total (+ index (* (length (cdr strings))
  191.                 string-port-string-length)))
  192.      (result (make-string total #\space)))
  193.     (do ((i 0 (+ i string-port-string-length))
  194.      (s (reverse (cdr strings)) (cdr s)))
  195.     ((null? s)
  196.      (string-insert result (car strings) i index))
  197.       (string-insert result (car s) i string-port-string-length))
  198.     result))
  199.  
  200. ; Copy the first COUNT characters from FROM to TO, putting them from START
  201. ; onwards.
  202.  
  203. (define (string-insert to from start count)
  204.   (do ((i 0 (+ i 1)))
  205.       ((>= i count))
  206.     (string-set! to (+ start i) (string-ref from i))))
  207.  
  208. (define string-output-port-methods
  209.   (make-output-port-methods
  210.    (lambda (data)
  211.      (set-string-output-port-data-open?! data #f))
  212.    (lambda (data char)
  213.      (cond ((string-output-port-data-open? data)
  214.         (write-char-to-string char data)
  215.         (update-row-and-column (string-output-port-data-location data)
  216.                    char))
  217.        (else
  218.         (error "writing to closed port" data)))) ; not a great argument
  219.    (lambda (data string)
  220.      (cond ((string-output-port-data-open? data)
  221.         (write-string-to-string string data)
  222.         (update-row-and-column-from-string
  223.          (string-output-port-data-location data)
  224.          string))
  225.        (else
  226.         (error "writing to closed port" data)))) ; not a great argument
  227.    (lambda (data)
  228.      #f)  ; nothing to do on a force-output
  229.    (lambda (data)
  230.      (let ((location (string-output-port-data-location data)))
  231.        (cond ((not (string-output-port-data-open? data))
  232.           (error "writing to closed port" data))  ; not a great argument
  233.          ((not (= 0 (port-location-column location)))
  234.           (write-char-to-string #\newline data)
  235.           (set-port-location-column! location 0)
  236.           (set-port-location-row! location
  237.                       (+ 1 (port-location-row location)))))))
  238.    (lambda (data)
  239.      (port-location-column (string-output-port-data-location data)))
  240.    (lambda (data)
  241.      (port-location-row (string-output-port-data-location data)))))
  242.  
  243. ;------------------------------------------------------------------------------
  244. ; Output ports from a single character writer
  245.  
  246. (define char-at-a-time-output-port-methods
  247.   (make-output-port-methods
  248.    (lambda (data) #f) ; nothing to do on a close
  249.    (lambda (data char)
  250.      (data char))
  251.    (lambda (data string)
  252.      (do ((i 0 (+ i 1)))
  253.      ((>= i (string-length string)))
  254.        (data (string-ref string i))))
  255.    (lambda (data)
  256.      #f)  ; nothing to do on a force-output
  257.    (lambda (data)
  258.      (data #\newline))
  259.    (lambda (data)
  260.      #f)
  261.    (lambda (data)
  262.      #f)))
  263.  
  264. (define (make-char-at-a-time-output-port proc)
  265.   (make-extensible-output-port proc
  266.                    char-at-a-time-output-port-methods))
  267.  
  268. (define (write-one-line port count proc)
  269.   (call-with-current-continuation
  270.     (lambda (quit)
  271.       (proc (make-char-at-a-time-output-port
  272.          (lambda (char)
  273.            (write-char char port)
  274.            (set! count (- count 1))
  275.            (if (<= count 0)
  276.            (quit #f))))))))
  277.  
  278. ; Unix-specific kludge
  279.  
  280. (define eof-object (call-with-input-file "/dev/null" read-char))
  281.