; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; Additional port types

(define close-port (structure-ref primitives close-port))
(define write-string (structure-ref ports write-string))

; Keeping track of a port's current row and column.

(define-record-type port-location
  ()
  ((row 0)
   (column 0)))

(define make-port-location port-location-maker)

(define (update-row-and-column location char)
  (cond ((eof-object? char) (values))
	((char=? char #\newline)
	 (set-port-location-row! location (+ 1 (port-location-row location)))
	 (set-port-location-column! location 0))
	(else
	 (set-port-location-column! location
				    (+ 1 (port-location-column location))))))

(define (update-row-and-column-from-string location string)
  (let loop ((i 0)
	     (row (port-location-row location))
	     (column (port-location-column location)))
    (cond ((>= i (string-length string))
	   (set-port-location-row!    location row)
	   (set-port-location-column! location column))
	  ((char=? #\newline (string-ref string i))
	   (loop (+ i 1) (+ row 1) 0))
	  (else
	   (loop (+ i 1) row (+ column 1))))))

; Input ports that keep track of the current row and column.

(define-record-type input-port-data
  (sub-port)
  ((location (make-port-location))))

(define input-port-methods
  (make-input-port-methods
   (lambda (data)
     (close-port (input-port-data-sub-port data)))
   (lambda (data)
     (let ((char (read-char (input-port-data-sub-port data))))
       (update-row-and-column (input-port-data-location data) char)
       char))
   (lambda (data)
     (peek-char (input-port-data-sub-port data)))
   (lambda (data)
     (char-ready? (input-port-data-sub-port data)))
   (lambda (data)
     (port-location-column (input-port-data-location data)))
   (lambda (data)
     (port-location-row (input-port-data-location data)))))

(define (make-tracking-input-port sub-port)
  (make-extensible-input-port (input-port-data-maker sub-port)
			       input-port-methods))

; Output ports that keep track of the current row and column.

(define-record-type output-port-data
  (sub-port)
  ((location (make-port-location))))

(define output-port-methods
  (make-output-port-methods
   (lambda (data)
     (close-port (output-port-data-sub-port data)))
   (lambda (data char)
     (write-char char (output-port-data-sub-port data))
     (update-row-and-column (output-port-data-location data) char))
   (lambda (data string)
     (write-string string (output-port-data-sub-port data))
     (update-row-and-column-from-string (output-port-data-location data)
					string))
   (lambda (data)
     (force-output (output-port-data-sub-port data)))
   (lambda (data)
     (let ((location (output-port-data-location data)))
       (cond ((not (= 0 (port-location-column location)))
	      (write-char #\newline (output-port-data-sub-port data))
	      (set-port-location-column! location 0)
	      (set-port-location-row! location
				      (+ 1 (port-location-row location)))))))
   (lambda (data)
     (port-location-column (output-port-data-location data)))
   (lambda (data)
     (port-location-row (output-port-data-location data)))))

(define (make-tracking-output-port sub-port)
  (make-extensible-output-port (output-port-data-maker sub-port)
			       output-port-methods))

;------------------------------------------------------------------------------
; String input ports

(define-record-type string-input-port-data
  (string)
  ((location (make-port-location))
   (index 0)))

(define (make-string-input-port string)
  (make-extensible-input-port (string-input-port-data-maker string)
			      string-input-port-methods))

(define string-input-port-methods
  (make-input-port-methods
   (lambda (data)
     (set-string-input-port-data-index!
      (string-length (string-input-port-data-string data))))
   (lambda (data)
     (let ((string (string-input-port-data-string data))
	   (index (string-input-port-data-index data)))
       (cond ((>= index (string-length string))
	      eof-object)
	     (else
	      (let ((char (string-ref string index)))
		(set-string-input-port-data-index! data (+ index 1))
		(update-row-and-column (string-input-port-data-location data)
				       char)
		char)))))
   (lambda (data)
     (let ((string (string-input-port-data-string data))
	   (index (string-input-port-data-index data)))
       (if (>= index (string-length string))
	   eof-object
	   (string-ref string index))))
   (lambda (data)
     (let ((string (string-input-port-data-string data))
	   (index (string-input-port-data-index data)))
       (< index (string-length string))))
   (lambda (data)
     (port-location-column (string-input-port-data-location data)))
   (lambda (data)
     (port-location-row (string-input-port-data-location data)))))

;------------------------------------------------------------------------------
; String output ports

(define-record-type string-output-port-data
  ()
  ((location (make-port-location))
   (strings '())
   (index string-port-string-length)
   (open? #t)))

(define (make-string-output-port)
  (make-extensible-output-port (string-output-port-data-maker)
			       string-output-port-methods))

; The length of the strings used in STRING-OUTPUT-PORTs.
(define string-port-string-length 80)

; Write a character to a string-output-port.  If there is not room in the
; current string, make a new one and put the character in that; otherwise put
; the character in the current string and increment the index.

(define (write-char-to-string char data)
  (let ((index   (string-output-port-data-index   data))
	(strings (string-output-port-data-strings data)))
    (cond ((>= index string-port-string-length)
	   (let ((new (make-string string-port-string-length #\space)))
	     (string-set! new 0 char)
	     (set-string-output-port-data-strings! data (cons new strings))
	     (set-string-output-port-data-index! data 1)))
	  (else
	   (string-set! (car strings) index char)
	   (set-string-output-port-data-index! data (+ index 1))))))

; UPDATE-ROW-AND-COLUMN-FROM-STRING could be integrated with this.

(define (write-string-to-string from data)
  (let ((index   (string-output-port-data-index   data))
	(strings (string-output-port-data-strings data)))
    (let loop ((i 0) (index index) (strings strings))
      (cond ((>= i (string-length from))
	     (set-string-output-port-data-index! data index)
	     (set-string-output-port-data-strings! data strings))
	    ((>= index string-port-string-length)
	     (let ((new (make-string string-port-string-length #\space)))
	       (string-set! new 0 (string-ref from i))
	       (loop (+ i 1) 1 (cons new strings))))
	    (else
	     (string-set! (car strings) index (string-ref from i))
	     (loop (+ i 1) (+ index 1) strings))))))

; Concatenates all of the strings of characters in WRITER into a single
; string.  Nothing is done if WRITER is not a string-output-port.

(define (string-output-port-output port)
  (let* ((data (extensible-output-port-local-data port))
	 (strings (string-output-port-data-strings data))
	 (index (string-output-port-data-index data)))
    (if (null? strings)
	""
	(let* ((total (+ index (* (length (cdr strings))
				  string-port-string-length)))
	       (result (make-string total #\space)))
	  (do ((i 0 (+ i string-port-string-length))
	       (s (reverse (cdr strings)) (cdr s)))
	      ((null? s)
	       (string-insert result (car strings) i index))
	    (string-insert result (car s) i string-port-string-length))
	  result))))

; Copy the first COUNT characters from FROM to TO, putting them from START
; onwards.

(define (string-insert to from start count)
  (do ((i 0 (+ i 1)))
      ((>= i count))
    (string-set! to (+ start i) (string-ref from i))))

(define string-output-port-methods
  (make-output-port-methods
   (lambda (data)
     (set-string-output-port-data-open?! data #f))
   (lambda (data char)
     (cond ((string-output-port-data-open? data)
	    (write-char-to-string char data)
	    (update-row-and-column (string-output-port-data-location data)
				   char))
	   (else
	    (error "writing to closed port" data)))) ; not a great argument
   (lambda (data string)
     (cond ((string-output-port-data-open? data)
	    (write-string-to-string string data)
	    (update-row-and-column-from-string
	     (string-output-port-data-location data)
	     string))
	   (else
	    (error "writing to closed port" data)))) ; not a great argument
   (lambda (data)
     #f)  ; nothing to do on a force-output
   (lambda (data)
     (let ((location (string-output-port-data-location data)))
       (cond ((not (string-output-port-data-open? data))
	      (error "writing to closed port" data))  ; not a great argument
	     ((not (= 0 (port-location-column location)))
	      (write-char-to-string #\newline data)
	      (set-port-location-column! location 0)
	      (set-port-location-row! location
				      (+ 1 (port-location-row location)))))))
   (lambda (data)
     (port-location-column (string-output-port-data-location data)))
   (lambda (data)
     (port-location-row (string-output-port-data-location data)))))

(define (call-with-string-output-port proc)
  (let ((port (make-string-output-port)))
    (proc port)
    (string-output-port-output port)))

;------------------------------------------------------------------------------
; Output ports from a single character writer

(define char-at-a-time-output-port-methods
  (make-output-port-methods
   (lambda (data) #f) ; nothing to do on a close
   (lambda (data char)
     (data char))
   (lambda (data string)
     (do ((i 0 (+ i 1)))
	 ((>= i (string-length string)))
       (data (string-ref string i))))
   (lambda (data)
     #f)  ; nothing to do on a force-output
   (lambda (data)
     (data #\newline))
   (lambda (data)
     #f)
   (lambda (data)
     #f)))

(define (make-char-at-a-time-output-port proc)
  (make-extensible-output-port proc
			       char-at-a-time-output-port-methods))

(define (write-one-line port count proc)
  (call-with-current-continuation
    (lambda (quit)
      (proc (make-char-at-a-time-output-port
	     (lambda (char)
	       (write-char char port)
	       (set! count (- count 1))
	       (if (<= count 0)
		   (quit #f))))))))

; Unix-specific kludge

(define eof-object (call-with-input-file "/dev/null" read-char))