;;;-*- Mode:LISP; Package:SERIAL; Fonts:(CPTFONT TR12I); Base:8 -*-

;1;; LMODEM driver for Lisp Machines*

;1;; This file contains all stuff specific to the LMODEM protocol.*
;1;; This conforms to the LMODEM protocol as used on MIT-ITS and*
;1;; as described in MC:AR60:CPM;MODEM2 PROTOC*

(defun morrow-send-file (file)
  (lmodem-send-file
    file
    (si:make-serial-stream ':baud 2000.
			   ':number-of-data-bits 8.
			   ':number-of-stop-bits 1
			   ':parity nil
			   ':ascii-characters nil)))

(defun morrow-receive-file (file)
  (lmodem-receive-file
    file
    (si:make-serial-stream ':baud 1200.
			   ':number-of-data-bits 8.
			   ':number-of-stop-bits 1
			   ':parity nil
			   ':ascii-characters nil)))

(defun lmodem-send-file (file stream)
  (send (make-instance 'lmodem-connection ':modem-stream stream)
	':send-file file))

(defun lmodem-receive-file (file stream)
  (send (make-instance 'lmodem-connection ':modem-stream stream)
	':get-file file))

(defflavor lmodem-connection ()
	   (modem-connection)
  :initable-instance-variables)

(defmethod (lmodem-connection :get-file) (file remote-file)
  (condition-case ()
      (with-open-file (file-stream file ':direction ':output)
	(*catch ':close-transfer
	  (send modem-stream ':STRING-OUT
		(string-append tmodem-pathname " -st " remote-file))
	  (send modem-stream ':tyo #Return)
	  (send self ':receive-file file-stream))
	(tv:notify nil "Transfer of file ~A complete." file))
    (sys:abort (tv:notify nil "File transfer aborted."))))

(defmethod (lmodem-connection :send-file) (file remote-file)
  (condition-case ()
      (with-open-file (file-stream file ':direction ':input)
	(send modem-stream ':STRING-OUT
	      (string-append tmodem-pathname " -rt " remote-file))
	(send modem-stream ':TYO #Return)
	(send self ':transmit-file file-stream)
	(tv:notify nil "Transfer of file ~A complete." file))
    (sys:abort (tv:notify nil "File transfer aborted."))))

(defmethod (lmodem-connection :read-packet) ()
  (or
    (dotimes (count 10)				;Master recount
      (*catch ':master-retry
	(let ((soh-maybe))
	  (loop with time = (time:get-universal-time)
		for current-time = (time:get-universal-time)
		until (or (> (- current-time time) receive-timeout)
			  (memq soh-maybe '(#soh #can #eot)))
		do (setq soh-maybe (send self ':tyi-with-timeout receive-timeout)))
	  (when (equal soh-maybe #eot)
	    (send modem-stream ':tyo #ack)
	    (*throw ':EOF ':SUCCESS))
	  (unless (equal soh-maybe #soh)
	    (send self ':nak "Bad Char for SOH, ~A~%" soh-maybe))
	  (when (equal soh-maybe #can)
	    (tv:notify nil "CAN received]%")
	    (ferror eh:abort-object))
	  (cond
	    ((not soh-maybe) nil)
	    (t (let (block not-block
		     (packet (allocate-resource 'SERIAL-PACKET))
		     cksum temp (real-check 0))
		 (unless (setq block (send self ':tyi-with-timeout char-timeout))
		   (send self ':nak "Timeout on BLOCK")
		   (*throw ':master-retry nil))
		 (unless (setq not-block (send self ':tyi-with-timeout char-timeout))
		   (send self ':nak "Timeout on NOT-BLOCK")
		   (*throw ':master-retry nil))
		 (dotimes (count1 128.)
		   (unless (setq temp (send self ':tyi-with-timeout char-timeout))
		     (send self ':NAK "Character timeout on character ~A" count1)
		     (*throw ':MASTER-RETRY nil))
		   (array-push packet temp)
		   (setq real-check (+ temp real-check)))
		 (setq real-check (logand real-check 377))
		 (unless (setq cksum (send self ':tyi-with-timeout char-timeout))
		   (send self ':nak "Timeout on checksum")
		   (*throw ':master-retry nil))
		 (cond ((and (equal not-block (- 255. block))
			     (equal block block-number)
			     (equal cksum real-check))
			(send modem-stream ':TYO #ACK)
			(setf (modem-block packet) block)
			(return packet))
		       (t (send self ':nak
				"Check ~A, Real Check ~A, Block ~A, Not-Block ~A, RB ~A"
				cksum real-check block not-block block-number)
			  nil))))))))
    (progn
      (send modem-stream ':tyo #can)
      (*Throw ':CLOSE-TRANSFER NIL)
      (ferror eh:abort-object))))

(defmethod (lmodem-connection :send-packet-from-file-and-wait) (file-stream)
  (let ((packet (allocate-resource 'SERIAL-PACKET)) (check 0))
    (unwind-protect
	(progn
	  (dotimes (count 128.)
	    (cond (carryover
		   (aset carryover packet count)
		   (setq check (+ check carryover)
			 carryover nil))
		  (t (cond ((not eof-flag)
			    (aset #Control-Z packet count)
			    (setq check (+ check #Control-Z)))
			   (t (let* ((char (send file-stream ':TYI))
				     (char1 (and char (translate-lispm-to-ascii char))))
				(when (equal char #\Return)
				  (setq char1 #Return)
				  (setq carryover #Linefeed))
				(when char1
				  (setq check (+ check char1))
				  (aset char1 packet count))
				(unless char
				  (setq eof-flag nil)
				  (setq check (+ check #Control-Z))
				  (aset #Control-Z packet count))))))))
	  (dotimes (count 10.)
	    (send modem-stream ':TYO #SOH)
	    (send modem-stream ':TYO (logand block-number #o377))
	    (send modem-stream ':TYO (logxor #o377 (logand block-number #o377)))
	    (send modem-stream ':STRING-OUT packet)
	    (send modem-stream ':CLEAR-INPUT)
	    (send modem-stream ':TYO (logand #o377 check))
	    (let ((char (send self ':TYI-WITH-TIMEOUT receive-timeout)))
	      (cond ((and char (= char #ack))
		     (*throw ':GOOD-SEND T))
		    (t (when (equal char #can) (ferror eh:abort-object)))))))
      (deallocate-resource 'SERIAL-PACKET packet)))
  (ferror eh:abort-object))

(compile-flavor-methods lmodem-connection)