scsh-0.6/scheme/rts/port.scm

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

; Ports and port handlers

; See doc/io.txt for a description of the i/o system, including ports,
; port handlers, and so forth.

;;; This is not the original file, but an adapted version for scsh
;;; Main difference is, that the ports have a steal-field 

(define-record-type port-handler :port-handler
  (really-make-port-handler discloser close buffer-proc steal)
  port-handler?
  (discloser   port-handler-discloser)
  (close       port-handler-close)
  (buffer-proc port-handler-buffer-proc)
  (steal       port-handler-steal))

(define (make-port-handler discloser close buffer-proc . maybe-steal)
  (if (pair? maybe-steal)
      (really-make-port-handler discloser close buffer-proc (car maybe-steal))
      (really-make-port-handler discloser close buffer-proc
				(lambda (port-data owner) #f))))

(define (disclose-port port)
  ((port-handler-discloser (port-handler port)) (port-data port)))

(define-method &disclose ((port :input-port))
  (disclose-port port))

(define-method &disclose ((port :output-port))
  (disclose-port port))

; The PORT-LOCKED? bit is checked by READ-CHAR, PEEK-CHAR, and WRITE-CHAR
; which are too simple-minded to understand real locks.  The three procedures
; below ensure that (PORT-LOCKED? <port>) is #t whenever someone has aquired
; <port>'s lock.

(define (obtain-port-lock port)
  (set-port-locked?! port #t)
  (obtain-lock (port-lock port)))

(define (maybe-obtain-port-lock port)
  (let ((ints (set-enabled-interrupts! 0)))
    (set-port-locked?! port #t)
    (let ((result (if (maybe-obtain-lock (port-lock port))
		      #t
		      (begin
			(set-port-locked?! port #f)
			#f))))
      (set-enabled-interrupts! ints)
      result)))

(define (release-port-lock port)
  (let ((ints (set-enabled-interrupts! 0)))
    (if (release-lock (port-lock port))
	(set-port-locked?! port #f))
    (set-enabled-interrupts! ints)))

; Set up exception handlers for the three unnecessary I/O primitives,
; READ-CHAR, PEEK-CHAR, and WRITE-CHAR.  These do the right thing in
; the case of buffer overflow or underflow.
;
; This is abstracted to avoid a circular module dependency.

(define (initialize-i/o-handlers! define-exception-handler signal-exception)
  (define-exception-handler (enum op read-char)
    (one-arg-proc->handler (read-char-handler #t) signal-exception))
    
  (define-exception-handler (enum op peek-char)
    (one-arg-proc->handler (read-char-handler #f) signal-exception))
  
  (define-exception-handler (enum op write-char)
    (two-arg-proc->handler write-char-handler signal-exception)))

; Check the exception and then lock the port.

(define (one-arg-proc->handler proc signal-exception)
  (lambda (opcode reason port)
    (if (= reason (enum exception buffer-full/empty))
	(begin
	  (obtain-port-lock port)
	  (let ((value (proc port)))
	    (release-port-lock port)
	    value))
	(signal-exception opcode reason port))))

; This could combined with on-arg-... if the port were the first argument.

(define (two-arg-proc->handler proc signal-exception)
  (lambda (opcode reason arg port)
    (if (= reason (enum exception buffer-full/empty))
	(begin
	  (obtain-port-lock port)
	  (let ((value (proc arg port)))
	    (release-port-lock port)
	    value))
	(signal-exception opcode reason arg port))))

; If a character is available, use it; if there is an EOF waiting, use that;
; otherwise fill the buffer and go from there.

(define (read-char-handler read?)
  (lambda (port)
    (cond ((< (port-index port) (port-limit port))
	   (let ((index (port-index port)))
	     (if read?
		 (set-port-index! port (+ 1 index)))
	     (ascii->char (code-vector-ref (port-buffer port) index))))
	  ((port-pending-eof? port)
	   (if read?
	       (set-port-pending-eof?! port #f))
	   (eof-object))
	  (else
	   (let ((got (fill-port-buffer! port 'any)))
	     (cond ((or (eof-object? got)
			(= 0 got))
		    (if (not read?)
			(set-port-pending-eof?! port #t))
		    (eof-object))
		   (else
		    (set-port-index! port (if read? 1 0))
		    (set-port-limit! port got)
		    (ascii->char (code-vector-ref (port-buffer port) 0)))))))))

(define (fill-port-buffer! port needed)
  ((port-handler-buffer-proc (port-handler port))
   (port-data port)
   (port-buffer port)
   0
   needed))

; Write the character if there is room, or call the handler if there is
; no actual buffering.  Otherwise use the handler to empty the buffer.

(define (write-char-handler char port)
  (cond ((< (port-index port) (port-limit port))
	 (code-vector-set! (port-buffer port)
			   (port-index port)
			   (char->ascii char))
	 (set-port-index! port (+ 1 (port-index port))))
	((= 0 (port-limit port))
	 ((port-handler-buffer-proc (port-handler port)) (port-data port) char))
	(else
	 (empty-port-buffer! port)
	 (code-vector-set! (port-buffer port) 0 (char->ascii char))
	 (set-port-index! port 1)))
  (unspecific))

; This may change PORT's buffer.

(define (empty-port-buffer! port)
  ((port-handler-buffer-proc (port-handler port))
   (port-data port)
   (port-buffer port)
   0
   (port-index port))
  (set-port-index! port 0)
  (set-port-flushed?! port #t))

(define port-flushed? port-pending-eof?)
(define set-port-flushed?! set-port-pending-eof?!)

;----------------
; Closing is done with the appropriate handler.
; R4RS says that CLOSE-... is idempotent.

(define (close-input-port port)
  (if (input-port? port)
      (begin
	(obtain-port-lock port)
	(if (open-input-port? port)
	    (begin
	      (make-input-port-closed! port)
	      ((port-handler-close (port-handler port)) (port-data port))))
	(release-port-lock port))
      (call-error "invalid argument" close-input-port port)))
	
(define (close-output-port port)
  (if (output-port? port)
      (begin
	(obtain-port-lock port)
	(if (open-output-port? port)
	    (begin
	      (really-force-output port)
	      (make-output-port-closed! port)
	      ((port-handler-close (port-handler port)) (port-data port))))
	(release-port-lock port))
      (call-error "invalid argument" close-output-port port)))

;----------------
; Port operations that do not have opcodes.  Each of these needs to check its
; arguments and then lock the port.  A macro is used to add the checking and
; locking code.  This has to check that the port is a port before locking it
; and then check that it is open after locking it.

; A macro to handle locking ports and checking that they're open.

(define-syntax define-port-op
  (syntax-rules ()
    ((define-port-op (?id ?args ...) ?port ?predicate ?body)
     (define (?id ?args ...)
       (if ?predicate                         ; if args are okay
	   (begin
	     (obtain-port-lock ?port)         ; lock the port
	     (if (open-port? ?port)           ; check that it's open
		 (let ((value ?body))         ; do the work
		   (release-port-lock ?port)  ; release the lock
		   value)                     ; return
		 (begin
		   (release-port-lock ?port)
		   (call-error "invalid argument" ?id ?args ...))))
	   (call-error "invalid argument" ?id ?args ...))))

    ; ?port defaults to the first argument
    ((define-port-op (?id ?port ?args ...) ?predicate ?body)
     (define-port-op (?id ?port ?args ...) ?port ?predicate ?body))))

;----------------
; See if there is a character available.  CHAR-READY? itself is defined
; in current-ports.scm as it needs CURRENT-INPUT-PORT when called with
; no arguments.

(define (real-char-ready? port)
  (cond ((not (open-input-port? port))
	 (call-error "invalid argument" char-ready? port))
	((not (maybe-obtain-port-lock port))
	 #f)
	((not (open-port? port))  ; have to check again after the lock call
	 (release-port-lock port)
	 (call-error "invalid argument" char-ready? port))
	((or (< (port-index port) (port-limit port))
	     (port-pending-eof? port))
	 (release-port-lock port)
	 #t)
	(else
	 (let ((got (fill-port-buffer! port 'immediate)))
	   (cond ((eof-object? got)
		  (set-port-pending-eof?! port #t)
		  (release-port-lock port)
		  #t)
		 (else
		  (set-port-index! port 0)
		  (set-port-limit! port got)
		  (release-port-lock port)
		  (> got 0)))))))

;----------------
; Check the arguments and the state of the buffer.  Leave any actual work
; up to the next procedure.
;
; The arguments are the same as those for input port handlers: BUFFER is either
; a string or a code vector, START is the initial index, and COUNT is either
; the required number of characters, 'ANY (one or more characters wanted),
; or 'IMMEDIATE (get what's available, but don't block).

(define-port-op (read-block buffer start count port) port
  (and (open-input-port? port)
       (okay-limits? buffer start (if (or (eq? count 'any)
					  (eq? count 'immediate))
				      1
				      count)))
  (cond ((port-pending-eof? port)
	 (set-port-pending-eof?! port #f)
	 (eof-object))
	((eq? count 0)
	 0)
	(else
	 (really-read-block buffer start count port))))

; If nothing is available, call the port's handler procedure.  Otherwise,
; copy any available characters into the buffer.  If more are needed the
; buffer handler is called.

(define (really-read-block buffer start count port)
  (let ((have (- (port-limit port) (port-index port))))
    (if (= have 0)
	((port-handler-buffer-proc (port-handler port))
	   (port-data port)
	   buffer
	   start
	   count)
	(let ((move (min have
			 (if (symbol? count)
			     (- (buffer-length buffer) start)
			     count))))
	  (copy-bytes! (port-buffer port) (port-index port) buffer start move)
	  (set-port-index! port (+ (port-index port) move))
	  (if (or (symbol? count)
		  (= move count))
	      move
	      (read-more buffer start count port move))))))

(define (buffer-length buffer)
  (if (string? buffer)
      (string-length buffer)
      (code-vector-length buffer)))

(define (read-more buffer start count port have)
  (let ((more ((port-handler-buffer-proc (port-handler port))
	         (port-data port)
		 buffer
		 (+ start have)
		 (- count have))))
    (if (eof-object? more)
	(if (= 0 have)
	    (eof-object)
	    (begin
	      (set-port-pending-eof?! port #t)
	      have))
	(+ more have))))
    
; Check that BUFFER contains COUNT characters starting from START.

(define (okay-limits? buffer start count)
  (and (integer? start)
       (exact? start)
       (<= 0 start)
       (integer? count)
       (exact? count)
       (<= 0 count)
       (<= (+ start count)
	   (cond ((string? buffer)
		  (string-length buffer))
		 ((code-vector? buffer)
		  (code-vector-length buffer))
		 (else
		  -1)))))

;----------------
; Write the COUNT bytes beginning at START from BUFFER to PORT.

(define-port-op (write-block buffer start count port) port
  (and (open-output-port? port)
       (okay-limits? buffer start count))
  (if (= 0 (port-limit port))
      (write-unbuffered-block buffer start count port)
      (write-buffered-block buffer start count port)))

; WRITE-STRING is a front for WRITE-BLOCK.

(define (write-string string port)
  (write-block string 0 (string-length string) port))

; Copy the bytes into the buffer if there is room, otherwise write out anything
; in the buffer and then write BUFFER.

(define (write-buffered-block buffer start count port)
  (let ((space (- (port-limit port) (port-index port))))
    (cond ((>= space count)
	   (copy-bytes! buffer start (port-buffer port) (port-index port) count)
	   (set-port-index! port (+ (port-index port) count)))
	  (else
	   (really-force-output port)
	   ((port-handler-buffer-proc (port-handler port))
	    (port-data port) buffer start count)))))

; For unbuffered ports we have to call the handler on each character
; separately.

(define (write-unbuffered-block buffer start count port)
  (let ((proc (port-handler-buffer-proc (port-handler port)))
        (data (port-data port))
        (string? (string? buffer)))
    (do ((i 0 (+ i 1)))
        ((= i count))
      (proc data (if string?
                     (string-ref buffer (+ start i))
                     (ascii->char (code-vector-ref buffer (+ start i))))))))

;----------------
; Empty the buffer if it contains anything.

(define-port-op (force-output port)
  (open-output-port? port)
  (really-force-output port))

(define (really-force-output port)
  (if (< 0 (port-index port))
      (empty-port-buffer! port)))

; Used to avoid race conditions elsewhere.

(define (force-output-if-open port)
  (if (output-port? port)
      (begin
	(obtain-port-lock port)
	(if (open-output-port? port)
	    (really-force-output port))
	(release-port-lock port))
      (call-error "invalid argument" force-output-if-open port)))

;----------------

(define default-buffer-size 4096)  ; should get this from the system

;----------------
; Is PORT open?

(define (open-port? port)
  (not (= 0 (bitwise-and open-port-mask (port-status port)))))

(define open-port-mask
  (bitwise-ior (arithmetic-shift 1 (enum port-status-options open-for-input))
	       (arithmetic-shift 1 (enum port-status-options open-for-output))))

;----------------
; Input ports

(define input-port-mask
  (arithmetic-shift 1 (enum port-status-options input)))

(define open-input-port-mask
  (arithmetic-shift 1 (enum port-status-options open-for-input)))

(define open-input-port-status
  (bitwise-ior input-port-mask open-input-port-mask))

(define (open-input-port? port)
  (not (= 0 (bitwise-and open-input-port-mask (port-status port)))))

(define (make-input-port-closed! port)
  (set-port-status! port (bitwise-and (port-status port)
				      (bitwise-not open-input-port-mask))))

(define (make-input-port handler data buffer index limit)
  (if (and (okay-buffer? buffer index limit)
	   (port-handler? handler))
      (make-port handler
		 (bitwise-ior input-port-mask open-input-port-mask)
		 (make-lock)
		 #f             ; locked?
		 data
		 buffer
		 index
		 limit
		 #f)            ; pending-eof?
      (call-error "invalid argument"
		  make-input-port handler data buffer index limit)))

(define (okay-buffer? buffer index limit)
  (and (code-vector? buffer)
       (let ((length (code-vector-length buffer)))
	 (integer? limit)
	 (<= 0 limit)
	 (<= limit length)
	 (<= index limit)
	 (integer? index)
	 (<= 0 index)
	 (<= index limit))))

;----------------
; Output ports

(define output-port-mask
  (arithmetic-shift 1 (enum port-status-options output)))

(define open-output-port-mask
  (arithmetic-shift 1 (enum port-status-options open-for-output)))

(define open-output-port-status
  (bitwise-ior output-port-mask open-output-port-mask))

(define (open-output-port? port)
  (not (= 0 (bitwise-and open-output-port-mask (port-status port)))))

(define (make-output-port-closed! port)
  (set-port-status! port (bitwise-and (port-status port)
				      (bitwise-not open-output-port-mask))))

(define (make-output-port handler data buffer index limit)
  (if (and (okay-buffer? buffer index limit)
	   (> limit 0)
	   (port-handler? handler))
      (make-port handler
		 open-output-port-status
		 (make-lock)
		 #f             ; locked?
		 data
		 buffer
		 index
		 limit
		 #f)            ; pending-eof?
      (call-error "invalid argument"
		  make-output-port handler data buffer index limit)))

(define (make-unbuffered-output-port handler data)
  (if (port-handler? handler)
      (make-port handler
		 open-output-port-status
		 (make-lock)
		 #f             ; locked?
		 data
		 (make-code-vector 0 0)
		 0
		 0
		 #f)            ; pending-eof?
      (call-error "invalid argument"
		  make-unbuffered-output-port handler data)))

(define null-output-port-handler
  (make-port-handler
   (lambda (ignore)
     (list 'null-output-port))
   (lambda (ignore)
     (unspecific))
   (lambda (channel buffer start need)
     (unspecific))
   (lambda (ignore1 ignore2)
     #f)))

(define (make-null-output-port)
  (make-port null-output-port-handler
	     open-output-port-status
	     (make-lock)    ; wasted
	     #f             ; locked?
	     (unspecific)
	     (make-code-vector 1 0)
	     0
	     1              ; if 0 it would look unbuffered
	     #f))           ; pending-eof?

;----------------
; Code to periodically flush output ports.

(define *flush-these-ports* (cons #f '()))

(define (initialize-output-port-list!)
  (set! *flush-these-ports* (cons #f '())))

(define (periodically-force-output! port)
  (set-cdr! *flush-these-ports*
	    (cons (make-weak-pointer port) (cdr *flush-these-ports*))))

; Return a list of thunks that will flush the buffer of each open, unlocked
; port that contains characters that have been there since the last time
; this was called.  The actual i/o is done using separate threads to keep
; i/o errors from killing anything vital.
; 
; If USE-FLUSHED?-FLAGS? is true this won't flush buffers that have been
; flushed by someone else sinse the last call.  If it is false then flush
; all non-empty buffers, because the system has nothing to do and is going
; to pause while waiting for external events.

(define (output-port-forcers use-flushed?-flags?)
  (let loop ((next (cdr *flush-these-ports*))
             (last *flush-these-ports*)
             (thunks '()))
    (if (null? next)
        thunks
        (let ((port (weak-pointer-ref (car next))))
          (cond ((or (not port)                      ; GCed or closed
                     (not (open-output-port? port))) ;  so drop it from the list
                 (set-cdr! last (cdr next))
                 (loop (cdr next) last thunks))
                ((not (maybe-obtain-port-lock port)) ; locked
                 (loop (cdr next) next thunks))
                ((and use-flushed?-flags?            ; flushed recently
                      (port-flushed? port))
                 (set-port-flushed?! port #f)
                 (release-port-lock port)
                 (loop (cdr next) next thunks))
                ((< 0 (port-index port))              ; non-empty
                 (release-port-lock port)
                 (loop (cdr next) next
		       (cons (make-forcing-thunk port)
			     thunks)))
                (else                                 ; empty
                 (release-port-lock port)
                 (loop (cdr next) next thunks)))))))

; Returns a list of the current ports that are flushed whenever.
; This is used to flush channel ports before forking.

(define (periodically-flushed-ports)
  (let ((ints (set-enabled-interrupts! 0)))
    (let loop ((next (cdr *flush-these-ports*))
	       (last *flush-these-ports*)
	       (ports '()))
      (if (null? next)
	  (begin
	    (set-enabled-interrupts! ints)
	    ports)
	  (let ((port (weak-pointer-ref (car next))))
	    (cond ((or (not port)                      ; GCed or closed
		       (not (open-output-port? port))) ; so drop it from the list
		   (set-cdr! last (cdr next))
		   (loop (cdr next) last ports))
		  (else
		   (loop (cdr next)
			 next
			 (cons port ports)))))))))

; Write out PORT's buffer.  If a problem occurs it is reported and PORT
; is closed.

(define (make-forcing-thunk port)
  (lambda ()
    (if (and (report-errors-as-warnings
	      (lambda ()
		(if (maybe-obtain-port-lock port)
		    (begin
		      (really-force-output port)
		      (release-port-lock port))))
	      "error when flushing buffer; closing port"
	      port)
	     (open-output-port? port))
	(report-errors-as-warnings
	   (lambda ()
	     (make-output-port-closed! port)
	     ((port-handler-close (port-handler port)) (port-data port)))
	   "error when closing port"
	   port))))
	
(define (steal-port! port)
  (begin
    (disable-interrupts!)
    (let ((owner (if (lock-owner-uid (port-lock port))
		     (thread-uid->thread (lock-owner-uid (port-lock port)))
		     #f)))
      (if (and owner
	       (not (running? owner)))
	  (begin
;	    (message (list  (thread-uid owner) " "
;			    (thread-uid (current-thread)) " "))
	    (really-steal-port! port owner)))
      (enable-interrupts!))))

(define (really-steal-port! port owner)
  (let ((lock (port-lock port))
	(buffer (port-buffer port))
	(index (port-index port))
	(limit (port-limit port))
	(eof? (port-pending-eof? port))
	(status ((port-handler-steal (port-handler port))
		 (port-data port) owner)))
    (set-port-buffer! port (make-code-vector (code-vector-length buffer) 0))
    (set-port-index! port 0)
    (set-port-limit! port (if (input-port? port) 0 (code-vector-length buffer)))
    (set-port-pending-eof?! port #f)
    (set-port-locked?! port #f)
    (set-port-lock! port (make-lock))
    (interrupt-thread owner
		      (lambda results
			(obtain-port-lock port)
			(cond ((output-port? port)
			       (really-force-output port))
			      ((< (port-index port)
				  (port-limit port))
			       (warn "dropping input from port" port)))
			(set-port-buffer! port buffer)
			(set-port-index! port index)
			(set-port-limit! port limit)
			(set-port-pending-eof?! port eof?)
			(set-port-lock! port lock)
			(or status (apply values results))))
    ; if we took OWNER off a channel-wait queue we need to make it ready to run
    (if status (make-ready owner))))