scsh-0.6/scheme/big/more-port.scm

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Additional port types

;----------------
; Ports which keep track of the current row and column.
;
; When the row or column data is requested we need to process the characters
; between the port's current index and the index at the time of the previous
; check.
;
; When a buffer operation is requested we need to process any remaining
; characters in the old buffer.  If the operation is a block read or write
; we also need to process whatever is read or written.
;
; port:        the tracking port - needed for its buffer and indicies
; sub-port:    port being tracked
; index:       the index of the next character to be processed
; row, column: position of the character at BUFFER[INDEX - 1] 

(define-record-type port-location :port-location
  (really-make-port-location sub-port index row column)
  port-location?
  (port     port-location-port set-port-location-port!) ; setter for circularity
  (sub-port port-location-sub-port)
  (index    port-location-index  set-port-location-index!)
  (row      port-location-row    set-port-location-row!)
  (column   port-location-column set-port-location-column!))

(define (make-port-location sub-port)
  (really-make-port-location sub-port (port-index sub-port) 0 0))

; Update the data and return what you get.

(define (current-row port)
  (let ((data (port-data port)))
    (if (port-location? data)
	(begin
	  (obtain-port-lock port)
	  (update-row-and-column! data)
	  (let ((row (port-location-row data)))
	    (release-port-lock port)
	    row))
	#f)))

(define (current-column port)
  (let ((data (port-data port)))
    (if (port-location? data)
	(begin
	  (obtain-port-lock port)
	  (update-row-and-column! data)
	  (let ((column (port-location-column data)))
	    (release-port-lock port)
	    column))
	#f)))

; Bring LOCATION up to date.

(define (update-row-and-column! location)
  (let ((at (port-index (port-location-port location)))
	(checked-to (port-location-index location))
	(buffer (port-buffer (port-location-port location))))
    (if (< checked-to at)
	(begin
	  (update-row-and-column-from-bytes! buffer checked-to at location)
	  (set-port-location-index! location at)))))

; Two nearly identical procedures to deal with code-vectors and strings.

(define (update-row-and-column-from-bytes! code-vec start end location)
  (let loop ((i start)
	     (row (port-location-row location))
	     (column (port-location-column location)))
    (cond ((= i end)
	   (set-port-location-row! location row)
	   (set-port-location-column! location column))
	  ((= (char->ascii #\newline) (code-vector-ref code-vec i))
	   (loop (+ i 1) (+ row 1) 0))
	  (else
	   (loop (+ i 1) row (+ column 1))))))

(define (update-row-and-column-from-chars! string start count location)
  (let loop ((i start)
	     (row (port-location-row location))
	     (column (port-location-column location)))
    (cond ((= i (+ start count))
	   (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 tracking-input-port-handler
  (make-buffered-input-port-handler
   (lambda (location)
     (list 'tracking-port (port-location-sub-port location)))
   (lambda (location)  ; nothing to do
     (values))
   (lambda (location buffer start needed)
     (update-row-and-column! location)  ; finish off old buffer
     (let ((res (read-block buffer start needed
			    (port-location-sub-port location))))
       (cond ((eof-object? res))
	     ((eq? buffer (port-buffer (port-location-port location)))
	      (set-port-location-index! location 0))
	     ((code-vector? buffer)
	      (update-row-and-column-from-bytes! buffer start res location))
	     (else
	      (update-row-and-column-from-chars! buffer start res location)))
       res))
   (lambda (port)
     (char-ready? (port-location-sub-port (port-data port))))))

(define (make-tracking-input-port port)
  (if (input-port? port)
      (let ((new-port 
	     (make-buffered-input-port tracking-input-port-handler
				       (make-port-location port)
				       (make-code-vector default-buffer-size 0)
				       0
				       0)))
	; make the circular link
	(set-port-location-port! (port-data new-port) new-port)
	new-port)
      (call-error "not an input port" make-tracking-input-port port)))

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

(define tracking-output-port-handler
  (make-buffered-output-port-handler
   (lambda (location)
     (list 'tracking-port (port-location-sub-port location)))
   ; flush the buffer when closing
   (lambda (location)
     (let ((port (port-location-port location)))
       (if (< 0 (port-index port))
	   (write-block (port-buffer port) 0 (port-index port)
			(port-location-sub-port location)))))
   ; Finish off the old buffer, send the characters to the child port, and
   ; then update the row and column if necessary.
   (lambda (location buffer start count)
     (update-row-and-column! location)
     (write-block buffer start count (port-location-sub-port location))
     (cond ((eq? buffer (port-buffer (port-location-port location)))
	    (set-port-location-index! location 0))
	   ((code-vector? buffer)
	    (update-row-and-column-from-bytes! buffer start count location))
	   (else
	    (update-row-and-column-from-chars! buffer start count location))))
   (lambda (port)
     (output-port-ready? (port-location-sub-port (port-data port))))))

(define (make-tracking-output-port port)
  (if (output-port? port)
      (let ((new-port (make-output-port tracking-output-port-handler
					(make-port-location port)
					(make-code-vector default-buffer-size 0)
					0
					default-buffer-size)))
	; make the circular link
	(set-port-location-port! (port-data new-port) new-port)
	new-port)
      (call-error "not an output port" make-tracking-output-port port)))

(define (fresh-line port)
  (let ((column (current-column port)))
    (if (and column (< 0 column))
	(newline port))))

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

; All the work is done by the port code.

(define string-input-port-handler
  (make-buffered-input-port-handler
   (lambda (ignore)
     (list 'string-input-port))
   (lambda (ignore)
     (values))
   (lambda (ignore buffer start needed)
     (eof-object))
   (lambda (port) #f)))

(define (make-string-input-port string)
  (let ((buffer (make-code-vector (string-length string) 0)))
    (copy-bytes! string 0 buffer 0 (string-length string))
    (make-buffered-input-port string-input-port-handler
			      #f                 ; no additional state needed
			      buffer
			      0
		     (string-length string))))   ; number of bytes available

(define copy-bytes! (structure-ref primitives copy-bytes!))

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

; The data field of the port is a list of (<buffer> . <char-count>) pairs
; (the car is the port itself).  When the output is wanted the buffers are
; concatenated together to get the final string.

(define buffer-size 1024)

; Concatenates all of the buffers into single string.

(define (string-output-port-output port)
  (let* ((full (cdr (port-data port)))
	 (last (port-buffer port))
	 (index (port-index port))
	 (count (apply + index (map cdr full)))  ; Scheme is a trip
	 (out (make-string count)))
    (let loop ((full (reverse full)) (i 0))
      (if (null? full)
	  (copy-bytes! last 0 out i index)
	  (let ((buffer (caar full))
		(count (cdar full)))
	    (copy-bytes! buffer 0 out i count)
	    (loop (cdr full) (+ i count)))))
    out))

(define string-output-port-handler
  (make-buffered-output-port-handler
   (lambda (port)
     '(string-output-port))
   (lambda (port)
     (values))
   (lambda (data thing start count)
     (let ((port (car data)))
       (set-cdr! (port-data port)
		 (cons (cons (full-buffer port thing start count)
			     count)
		       (cdr (port-data port))))))
   (lambda (port) #f)))

(define (full-buffer port thing start count)
  (cond ((eq? thing (port-buffer port))
	 (set-port-buffer! port (make-code-vector default-buffer-size 0))
	 thing)
	(else
	 (let ((b (make-code-vector count 0)))
	   (copy-bytes! thing start b 0 count)
	   b))))

(define (make-string-output-port)
  (let ((port (make-buffered-output-port 
	       string-output-port-handler
	       (list #f)
	       (make-code-vector default-buffer-size 0)
	       0
	       default-buffer-size)))
    (set-car! (port-data port) port)
    port))

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

;----------------
; Output ports from single character consumers

(define char-sink-output-port-handler
  (make-port-handler
   (lambda (proc)
     (list 'char-sink-output-port))
   (lambda (proc)
     (values))
   (lambda (proc char)
     (proc char))
   (lambda (port) #t)))

(define (char-sink->output-port proc)
  (make-unbuffered-output-port char-sink-output-port-handler
			       proc))

; Call PROC on a port that will transfer COUNT characters to PORT and
; then quit.

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

;----------------
; Input ports from single character producers
; The producer is passed #T if a character is needed and #F if not.
; If #F is passed and no character is ready, then #F is returned.

(define char-source-input-port-handler
  (make-port-handler
   (lambda (proc)
     (list 'char-source-input-port))
   (lambda (proc)			; nothing to do
     (values))
   (lambda (proc buffer start needed)
     (if (integer? needed)
	 (let loop ((got 0))
	   (if (= got needed)
	       got
	       (let ((next (proc #t)))
		 (cond ((char? next)
			(buffer-set! buffer (+ start got) next)
			(loop (+ got 1)))
		       ((= got 0)
			(eof-object))
		       (else
			got)))))
	 (let ((next (proc (eq? needed 'any))))
	   (cond ((not next)
		  0)
		 ((eof-object? next)
		  (eof-object))
		 (else
		  (buffer-set! buffer start next)
		  1)))))
   (lambda (port)
     (error "Peek on char-source is not implemented. Complain to the scsh implementors"))))
             

(define (buffer-set! buffer index char)
  (if (string? buffer)
      (string-set! buffer index char)
      (code-vector-set! buffer index (char->ascii char))))

(define (char-source->input-port proc)
  (make-input-port char-source-input-port-handler
		   proc
		   (make-code-vector 1 0)
		   0
		   0))