;;;-*- Mode:LISP; Package:K2; Readtable:CL; Base:10;  compile-in-roots:("K-GLOBAL") -*-

;;; KBUG streams

(export '(

	  kbug-stream-initialize
	  kbug-stream-peek-byte
	  kbug-stream-peek-character
	  kbug-stream-read-byte
	  kbug-stream-read-character
	  kbug-stream-write-byte
	  kbug-stream-write-character
	  ))



;;; These two functions are used to determine if the debug master
;;; side or the K machine side of a KBUG stream is being used in
;;; the correct direction.

(defun ldb (byte source)
  (select-processor
    (:k (hw:ldb source byte 0.))
    (:lambda (lisp:ldb byte source))))

(defun kbug-input-stream? (kbug-stream)
  "T if this processor is allowed to read from this stream."
  (= (select-processor
       (:lambda   $$kbug-stream-flags-direction-FROM-k)
       (:k        $$kbug-stream-flags-direction-TO-k))
     (ldb %%kbug-stream-flags-direction
	  (kbug-stream-flags kbug-stream))))

(defun kbug-output-stream? (kbug-stream)
  "T if this processor is allowed to write to this stream."
  (= (select-processor
       (:lambda   $$kbug-stream-flags-direction-TO-k)
       (:k        $$kbug-stream-flags-direction-FROM-k))
     (ldb %%kbug-stream-flags-direction
	  (kbug-stream-flags kbug-stream))))

(defun kbug-stream-pointer-1+ (kbug-stream pointer)
  "Given a KBUG stream and the value of one of its pointers, return the next location
that the pointer will point to.  That is, increment it but take into account
any necessary wrapping."
  (let ((new-pointer (1+ pointer)))
    (if (>= new-pointer (kbug-stream-end kbug-stream))
	(kbug-stream-base kbug-stream)
	new-pointer)))

(defun kbug-stream-empty? (kbug-stream)
;  (zerop (kbug-stream-semaphore kbug-stream)))
  (= (kbug-stream-in-pointer kbug-stream)
     (kbug-stream-out-pointer kbug-stream)))

(defun kbug-stream-full? (kbug-stream)
;  (not (zerop (kbug-stream-semaphore kbug-stream)))
  (= (kbug-stream-out-pointer kbug-stream)
     (kbug-stream-pointer-1+ kbug-stream
			     (kbug-stream-in-pointer kbug-stream))))

;(defun acknowledge-read (kbug-stream)
;  (set-kbug-stream-semaphore kbug-stream 0))

;(defun notify-write (kbug-stream)
;  (set-kbug-stream-semaphore kbug-stream 1))

(defun kbug-stream-advance-in-pointer (kbug-stream)
  "Increment the in-pointer of KBUG-STREAM."
  (setf (kbug-stream-in-pointer kbug-stream)
	(kbug-stream-pointer-1+ kbug-stream (kbug-stream-in-pointer kbug-stream))))

(defun kbug-stream-advance-out-pointer (kbug-stream)
  (setf (kbug-stream-out-pointer kbug-stream)
	(kbug-stream-pointer-1+ kbug-stream (kbug-stream-out-pointer kbug-stream))))

;;; Why read byte?  Because we would have to deal with the boxedness issue if we
;;; read a Q.

#|
(defun kbug-stream-read-q (kbug-stream)
  "Read the next Q from KBUG-STREAM.  This is the TYI operation."
;;; The problem here is that kbug-read-stream-p would be in different packages
;;; depending on whether we are on the K or the LAMBDA
;  (when (not (kbug-read-stream-p kbug-stream))
;    (trap::illop "Input requested from a write-only kbug-stream."))
  (do () ((not (kbug-stream-empty? kbug-stream))))
  (prog1
    ;; Does this get an unboxed Q?
    (kbug-stream-datum kbug-stream)
    (acknowledge-read kbug-stream)))
;    (kbug-stream-advance-out-pointer kbug-stream)))

(defun kbug-stream-write-q (kbug-stream q)
  "Write a Q to KBUG-STREAM.  This is the TYO operation."
;  (when (not (kbug-write-stream-p kbug-stream))
;    (trap::illop "Output requested for a read only kbug-stream."))
  (do () ((not (kbug-stream-full? kbug-stream))))
  (setf (kbug-stream-datum kbug-stream) q)
  (notify-write kbug-stream))
;  (kbug-stream-advance-in-pointer kbug-stream))

(defun initialize-stream (stream flags)
  (setf (kbug-stream-flags stream) flags)
  (setf (kbug-stream-semaphore stream) 0))

(defun kbug-stream-peek (kbug-stream)
  (do () ((not (kbug-stream-empty? kbug-stream))))
  (kbug-stream-datum kbug-stream))
|#

(defun initialize-kbug-stream (kbug-stream direction base end)
  (setf (kbug-stream-base kbug-stream) base)
  (setf (kbug-stream-end kbug-stream) end)
  (setf (kbug-stream-flags kbug-stream)
	(hw:dpb direction %%kbug-stream-flags-direction
		(kbug-stream-flags kbug-stream))))

;(defun kbug-stream-read-word (kbug-stream)
;  "Read the next word from KBUG-STREAM.  This is the TYI operation."
;  (unless (kbug-read-stream-p kbug-stream)
;	  (illop "Input requested from write-only KBUG stream."))
;  (do () ((not (kbug-stream-empty kbug-stream))))	;wait for stream.  Should do something more sensible here.
;  (prog1 (kbug-get-comm-word (kbug-stream-out-pointer kbug-stream))
;	 (kbug-stream-advance-out-pointer kbug-stream)))

;(defun kbug-stream-write-word (kbug-stream word)
;  "Write a word to KBUG-STREAM.  This is the TYO operation."
;  (unless (kbug-write-stream-p kbug-stream)
;	  (illop "Output to read-only KBUG stream."))
;  (do () ((not (kbug-stream-full kbug-stream))))	;wait for space to write in
;  (kbug-set-comm-word (kbug-stream-in-pointer kbug-stream)
;		      word)
;  (kbug-stream-advance-in-pointer kbug-stream))

(defun kbug-stream-needs-input (kbug-stream)
  (do () ((not (kbug-stream-empty? kbug-stream))) ))

(defun kbug-stream-needs-output (kbug-stream)
  (do () ((not (kbug-stream-full? kbug-stream))) ))

;(defun kbug-stream-read-character (kbug-stream)
;  (unless (kbug-input-stream? kbug-stream)
;	   (trap::illop "Input requested from write-only KBUG stream"))
;  (kbug-stream-needs-input kbug-stream)
;  (prog1 (hw:dpb (ldb (byte 8 0) (kbug-get-comm-word (kbug-stream-out-pointer kbug-stream)))
;		 (byte 8 0) #.(lisp::int-char 0))
;	 (kbug-stream-advance-out-pointer kbug-stream)))

;;; open code things and eliminate gratuitous memory references
(defun kbug-stream-peek-byte (kbug-stream)
  (unless (kbug-input-stream? kbug-stream)
    (select-processor
      (:K
	(trap::illop "Input requested from write-only KBUG stream"))
      (:lambda (global:ferror nil "Input requested from a write-only KBUG stream"))))
  (let ((out-ptr (kbug-stream-out-pointer kbug-stream)))
    (select-processor
      (:lambda
	(if (= (kbug-stream-in-pointer kbug-stream) out-ptr)
	    (zl:process-wait "Readch" (kbug::make-fancy-wait-function
					#'zl:false
					#'(lambda ()
					    (not (= (kbug-stream-in-pointer kbug-stream)
						    out-ptr)))))))
      (:k (do () ((not
	      ;;;(kbug-stream-empty? kbug-stream)
	      (= (kbug-stream-in-pointer kbug-stream)
		 out-ptr))))))
    (hw:dpb (ldb (byte 8 0) (kbug-get-comm-word out-ptr))
	    (byte 8 0) 0)
    ))

(defun kbug-stream-peek-character (kbug-stream)
  (cons:make-pointer vinc:$$dtp-character (kbug-stream-peek-byte kbug-stream)))

(defun kbug-stream-read-byte (kbug-stream)
  (prog1 (kbug-stream-peek-byte kbug-stream)
	 (setf (kbug-stream-out-pointer kbug-stream)
	       (kbug-stream-pointer-1+ kbug-stream
				       (kbug-stream-out-pointer kbug-stream)))))

; This is how it was before I changed it.  JRR 6-Apr-88
;(defun kbug-stream-read-character (kbug-stream)
;  (cons:make-pointer vinc:$$dtp-character (kbug-stream-read-byte kbug-stream)))

(defun kbug-stream-read-character (kbug-stream)
  (unless (kbug-input-stream? kbug-stream)
    (select-processor
      (:k (trap::illop "Input attempted from write-only KBUG stream"))
      (:lambda (zl::ferror nil "Input attempted from write-only KBUG stream"))))
  (let* ()
    (select-processor
      (:k (cons:make-pointer vinc:$$dtp-character (kbug-stream-read-byte kbug-stream)))
      (:lambda (lisp:code-char (kbug-stream-read-byte kbug-stream))))))

;(defun kbug-stream-write-character (kbug-stream character)
;  (unless (kbug-output-stream? kbug-stream)
;	  (trap::illop "Input requested from write-only KBUG stream"))
;  (kbug-stream-needs-output kbug-stream)
;  (kbug-set-comm-word (kbug-stream-in-pointer kbug-stream) character)
;  (kbug-stream-advance-in-pointer kbug-stream))

;;; open code things and eliminate gratuitous memory references
(defun kbug-stream-write-character (kbug-stream character)
  (unless (kbug-output-stream? kbug-stream)
    (select-processor
      (:k (trap::illop "Output attempted to read-only KBUG stream"))
      (:lambda (zl::ferror nil "Output attempted to read-only KBUG stream"))))
  (let* ((in-ptr (kbug-stream-in-pointer kbug-stream))
	 (in-ptr+1 (kbug-stream-pointer-1+ kbug-stream in-ptr)))
    (select-processor
      (:lambda (when (= (kbug-stream-out-pointer kbug-stream) in-ptr+1)
		 (zl:process-wait "Writech"
				  (kbug::make-fancy-wait-function
				    #'zl:false
				    #'(lambda ()
					(not (= (kbug-stream-out-pointer kbug-stream)
						in-ptr+1)))))))
      (:k (do () ((not
	      ;;;(kbug-stream-full? kbug-stream)
	      (= (kbug-stream-out-pointer kbug-stream)
		 in-ptr+1))))))
    (kbug-set-comm-word in-ptr character)
    ;;; (kbug-stream-advance-in-pointer kbug-stream)
    (setf (kbug-stream-in-pointer kbug-stream)
	  (kbug-stream-pointer-1+ kbug-stream in-ptr))))

(defun kbug-stream-write-byte (kbug-stream byte)
  (unless (kbug-output-stream? kbug-stream)
    (select-processor
      (:k (trap::illop "Output attempted to read-only KBUG stream"))
      (:lambda (zl::ferror nil "Output attempted to read-only KBUG stream"))))
  (let* ((in-ptr (kbug-stream-in-pointer kbug-stream))
	 (in-ptr+1 (kbug-stream-pointer-1+ kbug-stream in-ptr)))
    (select-processor
      (:lambda (when (= (kbug-stream-out-pointer kbug-stream) in-ptr+1)
		 (zl:process-wait "Writech"
				  (kbug::make-fancy-wait-function
				    #'zl:false
				    #'(lambda ()
					(not (= (kbug-stream-out-pointer kbug-stream)
						in-ptr+1)))))))
      (:k (do () ((not
	      ;;;(kbug-stream-full? kbug-stream)
	      (= (kbug-stream-out-pointer kbug-stream)
		 in-ptr+1))))))
    (kbug-set-comm-word in-ptr byte)
    ;;; (kbug-stream-advance-in-pointer kbug-stream)
    (setf (kbug-stream-in-pointer kbug-stream)
	  (kbug-stream-pointer-1+ kbug-stream in-ptr))))



(select-processor
  (:lambda
 (defun kbug-stream-string-out (kbug-stream string)
  (unless (kbug-output-stream? kbug-stream)
    (select-processor
      (:k (trap::illop "Output attempted to read-only KBUG stream"))
      (:lambda (zl:ferror nil "Output attempted to read-only KBUG stream"))))
  (let ((base (kbug-stream-base kbug-stream))
	(end  (kbug-stream-end  kbug-stream))
	(chars-to-send (zl:length string)))
  (labels ((wait-for-space (string-index)
	     (let* ((in-pointer  (kbug-stream-in-pointer  kbug-stream))
		    (in+1        (kbug-stream-pointer-1+  kbug-stream in-pointer)))
	       (select-processor
		 (:lambda
		   (when (= (kbug-stream-out-pointer kbug-stream) in+1)
		     (zl:process-wait "Writest"
				      (kbug::make-fancy-wait-function
					#'zl:false
					#'(lambda ()
					    (not (= (kbug-stream-out-pointer kbug-stream)
						    in+1)))))))
		 (:k (do () ((not (= (kbug-stream-out-pointer kbug-stream) in+1))))))
	       ;; Now we have space, find out how much
	       (let* ((out-pointer (kbug-stream-out-pointer kbug-stream))
		      (space (if (>= in-pointer out-pointer)
				 (1- (+ (- end in-pointer)
				    (- out-pointer base)))
				 (- (- out-pointer in-pointer) 2))))
		 (send-string string-index in-pointer space))))

	   (increment-stream-pointer (pointer)
	     (let ((new (1+ pointer)))
	       (if (>= new end)
		   base
		   new)))

	   (send-string (string-index buffer-index space)
	     (cond ((= string-index chars-to-send) 
		    (setf (kbug-stream-in-pointer kbug-stream) buffer-index))
		   ((lisp:zerop space)
		    (setf (kbug-stream-in-pointer kbug-stream) buffer-index)
		    (wait-for-space string-index))
		   (t 
		    (kbug-set-comm-word buffer-index (lisp::char string string-index))
		      (send-string (1+ string-index)
				   (increment-stream-pointer buffer-index)
				   (1- space))))))
    (wait-for-space 0))))))
				   
(defun kbug-stream-initialize (kbug-stream flags begin end)
  (setf (kbug-stream-base        kbug-stream) begin)
  (setf (kbug-stream-end         kbug-stream) end)
  (setf (kbug-stream-in-pointer  kbug-stream) begin)
  (setf (kbug-stream-out-pointer kbug-stream) begin)
  (setf (kbug-stream-flags       kbug-stream) flags))