;;;; buffer-ports.scm


(declare
  (no-bound-checks)
  (no-procedure-checks))


(module buffer-ports (open-input-buffer
		      open-output-buffer
		      open-memory-mapped-input-file)

  (import scheme chicken)

  (use lolevel posix)
  (import foreign)


; Port-slots:
;
;   Input:
;
;   10: position
;   11: len
;   12: pointer
;   13: close-hook
;
;   Output:
;
;   10: position
;   11: limit
;   12: pointer
;   13: close-hook


(foreign-declare #<<EOF
#define C_get_char_at_pointer(ptr, i)  \
  C_make_character(((C_char *)C_block_item(ptr, 0))[ C_unfix(i) ])
#define C_set_char_at_pointer(ptr, i, c)  \
  ((((C_char *)C_block_item(ptr, 0))[ C_unfix(i) ] = C_character_code(c)), C_SCHEME_UNDEFINED)
#define C_copy_string_to_pointer(str, ptr, start1, end1, start2) \
  (C_memcpy((C_char *)C_block_item(ptr, 0) + C_unfix(start2), \
   (C_char *)C_data_pointer(str) + C_unfix(start1), \
   C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
#define C_copy_pointer_to_string(ptr, str, start1, end1, start2) \
  (C_memcpy((C_char *)C_data_pointer(str) + C_unfix(start2), \
   (C_char *)C_block_item(ptr, 0) + C_unfix(start1), \
   C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
EOF
)

(define-syntax peek
  (syntax-rules ()
    ((_ ptr off)
     (##core#inline "C_get_char_at_pointer" ptr off))))

(define-syntax poke
  (syntax-rules ()
    ((_ ptr off c)
     (##core#inline "C_set_char_at_pointer" ptr off c))))

(define (scan-buffer-line ptr limit pos k)
  (let loop ((pos2 pos))
    (if (fx>= pos2 limit)
	(k pos2 pos2)
	(let ((c (peek ptr pos2)))
	  (cond ((eq? c #\newline) (k pos2 (fx+ pos2 1)))
		((and (eq? c #\return) 
		      (fx> limit (fx+ pos2 1))
		      (eq? (peek ptr (fx+ pos2 1)) #\newline) )
		 (k pos2 (fx+ pos2 2)) )
		(else (loop (fx+ pos2 1))) ) ) ) ) )

(define (check p n)
  (let* ((position (##sys#slot p 10))
	 (limit (##sys#slot p 11))
	 (ptr (##sys#slot p 12))
	 (limit2 (fx+ position n)) )
    (when (fx>= limit2 limit)
      (##sys#error "output buffer full" p) )))

(define buffer-port-class
  (vector
   (lambda (p)				; read-char
     (let ((position (##sys#slot p 10))
	   (ptr (##sys#slot p 12))
	   (len (##sys#slot p 11)) )
       (if (fx>= position len)
	   #!eof
	   (let ((c (peek ptr position)))
	     (##sys#setislot p 10 (fx+ position 1))
	     c) ) ) )
   (lambda (p)				; peek-char
     (let ((position (##sys#slot p 10))
	   (ptr (##sys#slot p 12))
	   (len (##sys#slot p 11)) )
       (if (fx>= position len)
	   #!eof
	   (peek ptr position) ) ) )
   (lambda (p c)			; write-char
     (check p 1)	
     (let ((position (##sys#slot p 10))
	   (ptr (##sys#slot p 12)) )
       (poke ptr position c)
       (##sys#setislot p 10 (fx+ position 1)) ) )
   (lambda (p str)			; write-string
     (let ((len (##sys#size str)))
       (check p len)
       (let ((position (##sys#slot p 10))
	     (ptr (##sys#slot p 12)) )
	 (##core#inline "C_copy_string_to_pointer" str ptr 0 len position)
	 (##sys#setislot p 10 (fx+ position len)) ) ) )
   (lambda (p)				; close
     (##sys#setislot p 10 (##sys#slot p 11))
     ((##sys#slot p 13) p))
   (lambda (p) #f)			; flush-output
   (lambda (p)				; char-ready?
     (fx< (##sys#slot p 10) (##sys#slot p 11)) )
   (lambda (p n dest start)		; read-string!
     (let* ((pos (##sys#slot p 10))
	    (n2 (fx- (##sys#slot p 11) pos) ) )
       (when (or (not n) (fx> n n2)) (set! n n2))
       (##core#inline "C_copy_pointer_to_string"
		      (##sys#slot p 12) dest pos (fx+ pos n) start)
       (##sys#setislot p 10 (fx+ pos n))
       n))
   (lambda (p limit)			; read-line
     (let* ((pos (##sys#slot p 10))
	    (size (##sys#slot p 11)) 
	    (ptr (##sys#slot p 12)) 
	    (end (if limit (fx+ pos limit) size)))
       (if (fx>= pos size)
	   #!eof
	   (scan-buffer-line
	    ptr
	    (if (fx> end size) size end)
	    pos 
	    (lambda (pos2 next)
	      (when (not (eq? pos2 next))
		(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) )
	      (let ((dest (##sys#make-string (fx- pos2 pos))))
		(##core#inline "C_copy_pointer_to_string" ptr dest pos pos2 0)
		(##sys#setislot p 10 next)
		dest) ) ) ) ) )
   (lambda (p)				; read-buffered
     (let ((pos (##sys#slot p 10))
	   (ptr (##sys#slot p 12))
	   (len (##sys#slot p 11)) )
       (if (fx>= pos len)
	   ""
	   (let ((buffered (##sys#make-string len)))
	     (##core#inline "C_copy_pointer_to_string" ptr buffered pos (fx+ pos len) 0)
	     (##sys#setislot p 10 len)
	     buffered))))))

(define (thing->pointer x loc start len port)
  (define (checklimit s)
    (cond (len
	   (##sys#check-exact len loc)
	   (when s
	     (assert (and (positive? len) (< len s))
		     "length exceeds object limit" len s x)))
	  (else
	   (set! len (or s (error loc "no length given" x)))))
    (assert (<= 0 start len) "start exceeds length" start len x)
    (##sys#setslot port 11 len)
    (##sys#setslot port 10 start))
  (##sys#setslot port 13 void)
  (##sys#setislot 
   port 12
   (cond ((##sys#immediate? x)
	  (error loc "bad argument type - not a valid buffer" x))
	 ((blob? x)
	  (checklimit (blob-size x))
	  (if (##sys#permanent? x) 
	      ((foreign-lambda c-pointer "C_data_pointer" scheme-object) x)
	      (make-locative x)))
	 ((or (pointer? x) (locative? x)) 
	  (checklimit #f)
	  x)
	 ((##sys#generic-structure? x)
	  (case (##sys#slot x 0)
	    ((u8vector s8vector u16vector s16vector
		       u32vector s32vector f32vector
		       f64vector)
	     (checklimit (##sys#size (##sys#slot x 1)))
	     (make-locative x))
	    ((mmap) 
	     (checklimit #f)
	     (memory-mapped-file-pointer x))
	    (else (error loc "bad argument type - not a valid buffer" x))))
	 ((string? x)
	  (checklimit (string-length x))
	  (if (##sys#permanent? x)
	      ((foreign-lambda c-pointer "C_data_pointer" scheme-object) x)
	      (make-locative x)))
	 (else
	  (error loc "bad argument type - not a valid buffer" x))))
  port)

(define (open-input-buffer x #!optional length (start 0))
  (##sys#check-exact start 'open-input-buffer)
  (let ((port (##sys#make-port #t buffer-port-class "(buffer)" 'buffer)))
    (thing->pointer x 'open-input-buffer start length port)))

(define (open-output-buffer x #!optional length (start 0))
  (##sys#check-exact start 'open-output-buffer)
  (let ((port (##sys#make-port #f buffer-port-class "(buffer)" 'buffer)))
    (thing->pointer x 'open-output-buffer start length port)))

(define open-memory-mapped-input-file
  (cond-expand
    (windows open-input-file)
    (else
     (lambda (name #!optional (length (file-size name))
		   (start 0))
       (let* ((fd (file-open name open/rdonly))
	      (mmap (map-file-to-memory #f length prot/read map/shared fd))
	      (port (open-input-buffer mmap length start)))
	 (##sys#setslot port 13 (lambda _ (unmap-file-from-memory mmap)))
	 port)))))

)