;;; -*- Mode:LISP; Package:LAMBDA; Base:8 -*-

(defvar mini-pkt)
(defvar mini-pkt-string)
(defvar mini-ch-idx)

(defun get-mini-pkt ()
  (let ((array-pointer (qf-virtual-mem-read (+ 1 (qf-symbol 'si:mini-pkt))))
	array-header
	array-data-pointer
	pkt-length
	)
    (if (not (= (qf-data-type array-pointer) dtp-array-pointer))
	(ferror nil "value of SI:MINI-PKT not array pointer"))
    (setq array-header (qf-virtual-mem-read array-pointer))
    (if (not (= (qf-data-type array-header) dtp-array-header))
	(ferror nil "value of SI:MINI-PKT not good array"))
    (if (not (= (ldb %%ARRAY-NUMBER-DIMENSIONS array-header) 1))
	(ferror nil "value of SI:MINI-PKT is not a one dimensional array"))
    (setq array-data-pointer (+ array-pointer 1 (ldb %%ARRAY-LONG-LENGTH-FLAG array-header)))
    (setq pkt-length (ldb (byte 12. 16.) (qf-virtual-mem-read array-data-pointer)))
    (if (not (<= pkt-length 488.))
	(ferror nil "pkt is too big: ~d." pkt-length))
    (incf array-data-pointer 4)			;skip header
    (setq mini-pkt-string
	  (with-output-to-string (s)
	    (do ()
		((< pkt-length 4))
	      (let ((data (qf-virtual-mem-read array-data-pointer)))
		(send s :tyo (ldb (byte 8 0) data))
		(send s :tyo (ldb (byte 8 8) data))
		(send s :tyo (ldb (byte 8 16.) data))
		(send s :tyo (ldb (byte 8 24.) data)))
	      (incf array-data-pointer)
	      (decf pkt-length 4))
	    (let ((data (qf-virtual-mem-read array-data-pointer)))
	      (if (> pkt-length 0)
		  (send s :tyo (ldb (byte 8 0) data)))
	      (if (> pkt-length 1)
		  (send s :tyo (ldb (byte 8 8) data)))
	      (if (> pkt-length 2)
		  (send s :tyo (ldb (byte 8 16.) data))))))
    (setq mini-pkt (make-array (floor (string-length mini-pkt-string) 2)
			       :type :art-16b
			       :displaced-to mini-pkt-string))
    (setq mini-ch-idx (qf-pointer (qf-virtual-mem-read (+ 1 (qf-symbol 'si:mini-ch-idx)))))
    ))

(defun print-mini-pkt (&optional data)
  (if (null data)
      (setq data mini-pkt))
  (if (stringp data)
      (setq data (make-array (floor (array-length data) 2) :type :art-16b :displaced-to data)))
  (do ((x 0 (1+ x)))
      ((>= x (array-length data)))
    (if (zerop (ldb (byte 3 0) x))
	(format t "~&"))
    (format t "~7o~:[ ~;*~] "
	    (aref data x)
	    (= x mini-ch-idx))))


(defun qfasl-to-editor (file ed-buffer)
  (with-open-file (from file :byte-size 8)
    (with-open-file (to ed-buffer :direction :output)
      (do ((c (send from :tyi)
	      (send from :tyi))
	   (phase 0 (1+ phase)))
	  ((null c))
	(when (= phase 488.)
	  (format to "~2&")
	  (setq phase 0))
	(send to :tyo c)))))

(defvar qfasl-to-compare-against)

(defun read-in-qfasl (file)
  (setq qfasl-to-compare-against
	(with-open-file (from file :byte-size 8)
	  (with-output-to-string (s)
	    (stream-copy-until-eof from s))))
  nil)
	
(defun check-mini-server (file-name &aux conn pkt)
  (unwind-protect
      (progn
	(setq conn (chaos:connect "dj" "MINI"))
	(setq pkt (chaos:get-pkt))
	(chaos:set-pkt-string pkt file-name)
	(setf (chaos:pkt-nbytes pkt) (string-length file-name))
	(chaos:send-pkt conn pkt #o201)		;binary open
	(setq pkt (chaos:get-next-pkt conn))
	(if (not (= (chaos:pkt-opcode pkt) #o202))
	    (ferror nil "bad response opcode"))
	(format t "~a" (chaos:pkt-string pkt))
	(chaos:return-pkt pkt)
	(do ((offset 0)
	     this-pkt-size)
	    (())
	  (setq pkt (chaos:get-next-pkt conn))
	  (select (chaos:pkt-opcode pkt)
	    (chaos:eof-op
	     (return nil))
	    (#o300
	     (setq this-pkt-size (chaos:pkt-nbytes pkt))
	     (if (not (string-equal qfasl-to-compare-against
				    (chaos:pkt-string pkt)
				    :start1 offset
				    :end1 (+ offset this-pkt-size)))
		 (check-mini-server-error (chaos:pkt-string pkt)
					  offset this-pkt-size))
	     (incf offset this-pkt-size)
	     )
	    (t
	     (ferror nil "bad opcode")))
	  (chaos:return-pkt pkt)))
    (chaos:close-conn conn)))

(defun check-mini-server-error (bad-pkt-string offset this-pkt-size)
  (format t "~%Mini server error!  Offset of bad pkt ~D, Bad pkt size ~D"
	  offset this-pkt-size)
  (let ((idx 0)
	(ans-list nil))
    (do ()
	((>= idx this-pkt-size))
      (do ((c 0 (1+ c)))
	  ((or (>= idx this-pkt-size)
	       (not (= (aref qfasl-to-compare-against (+ offset idx))
		       (aref bad-pkt-string idx))))
	   (setq ans-list (nconc ans-list (list c))))
	(incf idx))
      (do ((c 0 (1+ c)))
	  ((or (>= idx this-pkt-size)
	       (= (aref qfasl-to-compare-against (+ offset idx))
		  (aref bad-pkt-string idx)))
	   (setq ans-list (nconc ans-list (list c))))
	(incf idx)))
    (format t "~%Correct-incorrect strings: ~D" ans-list)
    (ferror nil "foo")))

(defun check-mini-server-using-real-mini ()
  (stop-chaos-net)
  (si:mini-init)
  (let* ((in (si:mini-open-file "dj:l.sys;qmisc.qfasl" t))
	 (received-array-16 (make-array 100. :type :art-16b))
	 (received-array-8 (make-array 200. :type :art-string :displaced-to received-array-16)))
    (do ((offset 0))
	(())
      (do ((half-word (send in :tyi)
		      (send in :tyi))
	   (count 0))
	  (())
	(when half-word
	  (aset half-word received-array-16 count)
	  (incf count))

	(when (or (null half-word)
		  (= count 100.))
	  (if (not (string-equal qfasl-to-compare-against
				 received-array-8
				 :start1 offset
				 :end1 (+ offset (* 2 count))
				 :end2 (* 2 count)
				 ))
	      (ferror nil "bad compare"))
	  (incf offset (* count 2))
	  (if (null half-word)
	      (return-from check-mini-server-using-real-mini nil))
	  (return nil))))))


(defun print-3com-buffers ()
  (dolist (buffer '(3com-buffer-a 3com-buffer-b))
    (format t "~3&~s --- " buffer)
    (dotimes (i 512.)
      (send standard-output :tyo (%multibus-read-8 (+ (symeval buffer) i))))))