;----------------
; Input ports which keep track of the current row, column, and
; filename and allow updating them imperatively.
;
; Derived from the tracking ports in scheme/big/more-ports.scm
;
; 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.
;
; 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 position :position
  (make-position row column filename)
  position?
  (row position-row set-position-row!)
  (column position-column set-position-column!)
  (filename position-filename set-position-filename!))

(define-record-discloser :position
  (lambda (pos)
    (list 'pos (position-filename pos) (position-row pos) (position-column pos))))

(define-record-type port-location :port-location
  (really-make-port-location sub-port index position)
  port-location?
  (sub-port port-location-sub-port)
  (index    port-location-index  set-port-location-index!)
  (position port-location-position))

(define (make-port-location sub-port filename)
  (really-make-port-location sub-port 0 (make-position 1 0 filename)))

; Update the data and return what you get.

(define (row-column-accessor accessor)
  (lambda (port)
    (let ((data (port-data port)))
      (if (port-location? data)
	  (begin
	    (update-row-and-column! port data)
	    (accessor (port-location-position data)))
	  (call-error "not a lexer port" accessor port)))))

(define current-row    (row-column-accessor position-row))
(define current-column (row-column-accessor position-column))
(define (current-filename port)
  (position-filename (port-location-position (port-data port))))
(define (current-position port)
  (make-position (current-row port)
		 (current-column port)
		 (current-filename port)))


(define (row-column-mutator mutator)
  (lambda (port new)
    (let ((data (port-data port)))
      (if (port-location? data)
	  (begin
	    (update-row-and-column! port data)
	    (mutator (port-location-position data) new))
	  (call-error "not a lexer port" mutator port new)))))
(define set-current-row! (row-column-mutator set-position-row!))
(define set-current-column! (row-column-mutator set-position-column!))

(define (set-current-filename! port filename)
  (set-position-filename! (port-location-position (port-data port)) filename))

; Bring LOCATION up to date.
(define (port-location-row port-location)
  (position-row (port-location-position port-location)))
(define (port-location-column port-location)
  (position-column (port-location-position port-location)))

(define (set-port-location-row! port-location row)
  (set-position-row! (port-location-position port-location) row))
(define (set-port-location-column! port-location column)
  (set-position-column! (port-location-position port-location) column))


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

(define (get-row-and-column! buffer 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)
	      (byte-vector-ref buffer 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 (make-lexer-port port filename)
  (if (input-port? port)
      (make-buffered-input-port tracking-input-port-handler
				(make-port-location port filename)
				(make-byte-vector default-buffer-size 0)
				0
				0)
      (call-error "not an input port" make-lexer-port port)))

(define tracking-input-port-handler
  (make-buffered-input-port-handler
   (lambda (location)
     (list 'lexer-port (port-location-sub-port location)))
   (lambda (port)			; close
     (maybe-commit))
   (lambda (port wait?)
     (if (maybe-commit)
	 (let ((location (port-data port)))
	   (update-row-and-column! port location)
	   (let ((got (read-block (port-buffer port)
				  0
				  (byte-vector-length (port-buffer port))
				  (port-location-sub-port location)
				  wait?)))
	     ;(note-buffer-reuse! port)
	     (if (eof-object? got)
		 (set-port-pending-eof?! port #t)
		 (begin
		   (set-port-index! port 0)
		   (set-port-limit! port got)))
	     #t))
	 #f))
   (lambda (port)
     (let ((ready? (char-ready? (port-location-sub-port (port-data port)))))
       (if (maybe-commit)
	   (values #t ready?)
	   (values #f #f))))))