;;; -*- Mode:LISP; Package:LAMBDA; Base:10; Lowercase:T; Readtable:ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;


(defun lambda-connect ()
  (let* ((io-buffer (send terminal-io ':io-buffer))
	 (plist (locf (tv:io-buffer-plist io-buffer))))
    (condition-bind
      ((nil #'(lambda (ignore plist) (putprop plist nil ':raw) nil) plist))

      (format t "~%Entering RAW mode - type CALL or use mouse to exit.~%")
      (unwind-protect 
	(progn
	  (without-interrupts
	    (putprop plist t ':raw))
	  (lambda-connect-loop io-buffer))
	
						;protected form
	(without-interrupts
	  (putprop plist nil ':raw)
	  (tv:io-buffer-clear io-buffer))))))

; If this function gets an error, you will have to do something like use the
; inspector to set the io-buffer plist back to NIL before you can use the
; error handler.

(defun get-pointer-from-lambda (adr)
  (%logldb %%q-pointer (phys-mem-read adr)))

(defun store-pointer-in-lambda (adr data)
  (phys-mem-write adr (%logdpb data %%q-pointer (phys-mem-read adr))))

(defun lambda-connect-loop (io-buffer)
  (do* ((char (lam-get-char io-buffer) (lam-get-char io-buffer)))
       ((or (null char)
	    (= (ldb 0010 char) 107)) ;CALL key
	(if (not (null char))
	    (format t "~&~C~&" #\call)
	  (format t "~&Machine halted~&")))
    (let ((soft-char (tv:kbd-convert-to-software-char char)))
      (cond ((null soft-char))
	    ((= soft-char #\rubout)
	     (send terminal-io ':backward-char)
	     (send terminal-io ':clear-char))
	    (t
	     (format t "~C" soft-char))))
    (let* ((current-in-ptr (get-pointer-from-lambda (+ 500 si:%unibus-channel-buffer-in-ptr)))
	   (next-in-ptr (1+ current-in-ptr))
	   (current-out-ptr (+ 500 si:%unibus-channel-buffer-out-ptr)))
      (if (= next-in-ptr (get-pointer-from-lambda (+ 500 si:%unibus-channel-buffer-end)))
	  (setq next-in-ptr
		(get-pointer-from-lambda (+ 500 si:%unibus-channel-buffer-start))))
      (cond ((not (= next-in-ptr current-out-ptr))
	     (phys-mem-write next-in-ptr char)
	     (store-pointer-in-lambda (+ 500 si:%unibus-channel-buffer-in-ptr) next-in-ptr))
	    (t (format t "[Lambda input buffer overflow]"))))))


(defvar *lam-get-char-status* nil)

(defun old-lam-get-char (io-buffer)
  (setq *lam-get-char-status* nil)
  (let ((inhibit-scheduling-flag t))
    (cond ((tv:io-buffer-empty-p io-buffer)
	   (process-wait "Kbd or Lam halt"
			 #'(lambda (buf)
			     (cond ((null (tv:io-buffer-empty-p buf))
				    (setq *lam-get-char-status* 'kbd))
				   (t
				    (condition-case (condition)
					(setq *lam-get-char-status* (read-con-reg))
				      (:no-error
				       (ldb-test halt-request-bit *lam-get-char-status*))
				      (nubus-timeout
				       (setq *lam-get-char-status* condition)
				       t)))))
			 io-buffer))
	  (t
	   (setq *lam-get-char-status* 'kbd))))
  (cond ((errorp *lam-get-char-status*)
	 (ferror nil "error testing for lambda running: ~a"
		 (send *lam-get-char-status* ':report nil)))
	((eq *lam-get-char-status* 'kbd)
	 (tv:io-buffer-get io-buffer))
	(t
	 nil)))

(defun lam-get-char (io-buffer)
  (setq *lam-get-char-status* nil)
  (let ((inhibit-scheduling-flag t))
    (cond ((tv:io-buffer-empty-p io-buffer)
	   (process-wait "Kbd or Lam halt"
			 #'(lambda (buf)
			     (cond ((null (tv:io-buffer-empty-p buf))
				    (setq *lam-get-char-status* 'kbd))
				   (t
				    nil)))
			 io-buffer))
	  (t
	   (setq *lam-get-char-status* 'kbd))))
  (cond ((errorp *lam-get-char-status*)
	 (ferror nil "error testing for lambda running: ~a"
		 (send *lam-get-char-status* ':report nil)))
	((eq *lam-get-char-status* 'kbd)
	 (tv:io-buffer-get io-buffer))
	(t
	 nil)))