;;; -*- Mode:LISP; Package:SUPDUP; Base:8; Readtable:ZL -*-


;;; This is a flavor definition generated by the window maker.

(DEFFLAVOR supdup-server-debug-frame
	 ()
	 (TV:CONSTRAINT-FRAME)
  (:DEFAULT-INIT-PLIST 
    :PANES '((ZMACS ZWEI:ZMACS-FRAME
		    :SAVE-BITS T)
	     (SUPDUP SUPDUP
		     :SAVE-BITS T)
	     (SERVER TV:WINDOW
		     :SAVE-BITS T))
    :CONSTRAINTS '((SERVER-DEBUG (WHOLE)
				 ((WHOLE :HORIZONTAL
					 (:EVEN)
					 (ZMACS right-side)
					 ((ZMACS 0.75s0))
					 ((right-side :VERTICAL
						      (:EVEN)
						      (SERVER SUPDUP)
						      ((SERVER 0.33s0))
						      ((SUPDUP :EVEN)))
					  ))
				  ))))
  :SETTABLE-INSTANCE-VARIABLES)


(DEFMETHOD (supdup-server-debug-frame :AFTER :INIT) (&REST IGNORE)
  (FUNCALL-SELF :SET-SELECTION-SUBSTITUTE (FUNCALL-SELF :GET-PANE 'ZMACS)))

(tv:add-system-key #\roman-iv 'supdup-server-debug-frame "Supdup Server")

(delete-initialization "SUPDUP" nil 'chaos:server-alist)

(add-initialization "SUPDUP"
                    '(process-run-function "SUPDUP Server" 'supdup-server)
                    NIL
                    'chaos:server-alist)

(defflavor serial-terminal-io
	 (input-io-buffer
	  output-io-buffer)
	 (si:bidirectional-stream)
  :settable-instance-variables)

(defmethod (serial-terminal-io :after :init) (ignore)
  (setq input-io-buffer (tv:make-io-buffer 1024.))
  (setq output-io-buffer (tv:make-io-buffer 1024.))
  )

(defmethod (serial-terminal-io :tyi) (&optional no-hang-p)
  (tv:io-buffer-get input-io-buffer no-hang-p))

(defmethod (serial-terminal-io :untyi) (char)
  (tv:io-buffer-unget input-io-buffer char))

(defmethod (serial-terminal-io :tyo) (char)
  (tv:io-buffer-put output-io-buffer char))

(defvar supdup-server-lisp nil)

(defun supdup-server ()
  (let ((conn (chaos:listen "SUPDUP"))
	window)
    (do ((w (send tv:main-screen :inferiors) (cdr w)))
	((null w)
	 (chaos:reject conn "No debug window")
	 (return-from supdup-server nil))
      (when (and (typep (car w) 'supdup-server-debug-frame)
		 (send (send (car w) :get-pane 'server) :exposed-p))
	(setq window (send (car w) :get-pane 'server))
	(return)))
    (send window :clear-screen)
    (chaos:accept conn)
    (let ((net-stream (chaos:make-stream conn))
	  (term-stream (make-instance 'serial-terminal-io))
	  child error-instance)
      (setq child (make-process "SUPDUP Server Input"))
      (send child :preset 'supdup-server-input term-stream net-stream window)
      (process-enable child)
      (setq supdup-server-lisp (make-process "SUPDUP Server Lisp"))
      (send supdup-server-lisp :preset 'supdup-server-lisp term-stream)
      (process-enable supdup-server-lisp)
      (unwind-protect
	  (condition-case (instance)
	      (supdup-server-output term-stream net-stream window)
	    (error (setq error-instance instance)))
	(send net-stream :eof)
	(chaos:close-conn conn (if error-instance (send error-instance :report nil) ""))
	(without-interrupts
	  (if (send child :active-p)
	      (send child :kill))
	  (when (send supdup-server-lisp :active-p)
	    (send supdup-server-lisp :kill)
	    (setq supdup-server-lisp nil)))
	))))

(defun supdup-server-lisp (stream)
  (let ((*terminal-io* stream)
	(*read-base* 8)
	(*print-base* 8)
	(*readtable* (copy-readtable si:standard-readtable))
	(*package* (find-package "USER")))
    (si:lisp-top-level1 stream)))

(defun supdup-server-output (term-stream net-stream *terminal-io*)
  (let ((*read-base* 8)
	(*print-base* 8)
	(*readtable* (copy-readtable si:standard-readtable)))	
    (do ((char (tv:io-buffer-get (send term-stream :output-io-buffer))
	       (tv:io-buffer-get (send term-stream :output-io-buffer))))
	(())
      (send net-stream :tyo char)
      (send net-stream :force-output))))

(defun supdup-server-input (term-stream net-stream *terminal-io*)
  (let ((*read-base* 8)
	(*print-base* 8)
	(*readtable* (copy-readtable si:standard-readtable)))
    (let ((nwords (dpb (get-18-bits net-stream) (byte 18. 0) -1)))
      (if (or (< nwords -20)
	      (> nwords 0))
	  (ferror nil "bad number of words"))
      (get-18-bits net-stream)
      (when (not (zerop nwords))
	(get-18-bits net-stream)
	(if (not (= (get-18-bits net-stream) 7))
	    (ferror nil "not TCTYP 7"))
	(incf nwords))
      (when (not (zerop nwords))
	;;lots of flags
	(get-18-bits net-stream)
	(get-18-bits net-stream)
	(incf nwords))
      (when (not (zerop nwords))
	(get-18-bits net-stream)
	;;height in lines
	(get-18-bits net-stream)
	(incf nwords))
      (when (not (zerop nwords))
	(get-18-bits net-stream)
	;;width in chars
	(get-18-bits net-stream)
	(incf nwords))
      (when (not (zerop nwords))
	;;scroll glitch
	(get-18-bits net-stream)
	(get-18-bits net-stream)
	(incf nwords))
      (when (not (zerop nwords))
	;;TTYSMT
	(get-18-bits net-stream)
	(get-18-bits net-stream)
	(incf nwords))
      (do (())
	  ((zerop nwords))
	(get-18-bits net-stream)
	(get-18-bits net-stream)
	(incf nwords)))
      
    (do ((char (send net-stream :tyi)
	       (send net-stream :tyi)))
	(())
      (tv:io-buffer-put (send term-stream :input-io-buffer) char)
      )))

(defun get-18-bits (stream)
  (let* ((b2 (send stream :tyi))
	 (b1 (send stream :tyi))
	 (b0 (send stream :tyi)))
    (dpb b2
	 (byte 6 12.)
	 (dpb b1
	      (byte 6 6)
	      b0))))