;;; -*- Mode:LISP; Package:FILE-SYSTEM; Base:10 -*-
;;;
;;; Extremely raw quarter inch tape drive support
;;;
;;; -dg 5/16/85
;;;

(defmacro maybe-with-real-time (condition &body body)
  `(let ((old-sb-state (si:sb-on)))
     (unwind-protect
       (progn
	 (when ,condition 
	   (si:sb-on '(:keyboard)))
	 . ,body)
       (si:sb-on old-sb-state))))

(defconst *use-real-time* t)

(defun raw-quart-read-array (ary &optional (n-tape-blocks (ceiling (array-length ary) 512.)))
  (assure-quarter-inch-tape-still-allocated)
  (cond (quart-file-mark-detected-on-last-read
	 (setq quart-file-mark-detected-on-last-read nil)
	 0)
	(t
;	 (when (or (not (quart-ready-p))
;		   (not (quart-online-p)))
;	   (ferror 'drive-offline "The quarter inch tape drive is not Online."))
	 (when (not (= *last-quart-cmd* quart-cmd-read))
	   (quart-send-cmd quart-cmd-read nil))
	 (let ((blocks-transfered
		(with-nubus-timeouts-disabled
		  (maybe-with-real-time *use-real-time*
		    (si:page-in-array ary)
		    (cond (quart-use-ucode
			   (compiler:%quart-transfer 0 ary n-tape-blocks))
			  (t
			   (do ((block-number 0 (1+ block-number))
				(block-adr 0 (+ block-adr 512.)))
			       ((progn (quart-wait-for-ready t nil)
				       (or (quart-exception)
					   (>= block-number n-tape-blocks)))
				block-number)
			     (dotimes (i 512.)
			       (aset (read-quart-data) ary (+ block-adr i)))))))))
	       bytes-transfered)
	   (cond ((cond ((eq (handle-quart-exception t)
			     'file-mark-detected)
			 (cond ((not (zerop blocks-transfered))
				(setq quart-file-mark-detected-on-last-read t)
				0)))
			(t
			 (handle-quart-exception))))
		 (t
		  (setq quart-file-mark-detected-on-last-read nil)))
	   (or bytes-transfered (* 512. blocks-transfered))))))

(defun decode-block-mark (thing)
  (if (not (string-equal "BLOK" thing :end2 4))
      (ferror nil "Bad block marker - ~a" thing)
    (do ((num 0)
	 (word (string thing))
	 (count 15 (sub1 count)))
	((= count 3) num)
      (setq num (+ num
		   (* (- (aref word count) 48)
		      (^ 10. (- 15 count))))))))

(defun read-block-mark (instream)
  (let* ((string (make-string 16))
	 (mark (progn (send instream :string-in t string 0 4)
		      (if (string-equal string "EOF " :end1 4)
			  (progn (quart-read-file-mark)
				 (ferror 'fs:end-of-file :format-string "End of file detected on carry tape."))
			(send instream :string-in t string 4)
			string))))
    (if (eq mark :eof)
	:eof
      (decode-block-mark mark))))


(defsubst keyword-read (stream)
  (intern (read stream) pkg-keyword-package))

(defmacro with-open-carry-tape ((var . options) &body body)
  `(let ((,var (lexpr-funcall #'make-instance 'carry-tape-input-stream ,options)))
     (unwind-protect
	 (progn
	   ,@body)
       (close ,var))))

(defun read-carry-file-plist (instream)
  (do ((plist (list "file plist"))
       (prop (keyword-read instream) (keyword-read instream)))
      ((eq prop :end) plist)
    (If (eq prop :carry-tape)
	(read-carry-tape-header instream)
      (putprop plist
	       (case prop
		 ((:record-type :creation-date :author :type :raw-type :name
				:raw-name :pathname :directory :host :dump-group)
		  (readline instream))
		 ((:version :characters :system-type :canonical-type)
		  (read instream)))
	       prop))))

(defun read-carry-tape-header (stream)
  (do ((plist (list :CARRY-TAPE))
       (prop (keyword-read stream) (keyword-read stream)))
      ((eq prop :end)
       (when (get plist :dump-list-follows)
	 (putprop plist
		  (if (and (string-equal (readline stream) "RECORD-TYPE DUMP-LIST")
			   (string-equal (readline stream) "END"))
		      (do ((dump-list)
			   (line (readline stream) (readline stream)))
			  ((zerop (length line)) dump-list)
			(setq dump-list (append dump-list (list line))))
		    (format t "~&Error in header: Bad dump list.~%"))
		  :dump-list))
       (send stream :next-file)
       plist)
    (putprop plist
	     (case prop
	       ((:version :tape-system-version :dump-list-follows)     ;symbols or numbers
		(read stream))
	       ((:time :machine :user-id :tape-host :tape-drive)       ;strings
		(readline stream))
	       (t (ferror nil "unhandled prop - ~A" prop)))
	     prop)))


;------------------------------
;;; raw-carry-tape-stream

(defflavor carry-tape-input-mixin ()
	   (qt-mixin si:buffered-input-stream)
  (:default-init-plist :chunk-size 1024.))

(defmethod (carry-tape-input-mixin :next-input-buffer) (&rest ignore)
  (cond	((eq status :eof)
	 (ferror 'fs:file-mark-detected "End of file on carry tape detected."))
	((eq status ':closed)
	 (ferror 'ferror
		 :format-string "Attempt to get input from ~s, which is closed."
		 :format-args self)))
  (if (null array)
      (setq array (allocate-resource 'quart-array chunk-size)))
  (let ((bytes-transfered (raw-quart-read-array array)))
    (when (< bytes-transfered chunk-size)
      (setq status :eof))
    (cond ((= byte-size 8)
	   (values (quart-array-string array) 0 bytes-transfered))
	  ((= byte-size 16.)
	   (values (quart-array-art-16b array) 0 (ceiling bytes-transfered 2)))
	  (t
	   (ferror 'quart-error :format-args "illegal byte-size")))))

(defmethod (carry-tape-input-mixin :next-file) ()
  (cond ((eq status ':eof)
	 (setq status ':open))
	((not (eq status ':open))
	 (ferror 'quart-error :format-string "bad state in :next-file"))
	(t
	 (cond ((null quart-file-mark-detected-on-last-read)
		(quart-read-file-mark)))
	 (setq quart-file-mark-detected-on-last-read nil)
	 (send self ':clear-input)
	 (setq status :open))))

;;;skip the rest of the blocks in this file, make the status EOF, and
;;;make the next block be the first block in the next file
(defmethod (carry-tape-input-mixin :advance-file) ()
  (cond ((not (memq status '(:eof :closed)))
	 (send self ':clear-input)
	 (cond ((null quart-file-mark-detected-on-last-read)
		(quart-read-file-mark)))
	 (setq quart-file-mark-detected-on-last-read nil)
	 (setq status ':eof))))

(defmethod (carry-tape-input-mixin :discard-input-buffer) (&rest ignore)
  nil)

(defflavor carry-tape-input-stream ()
	   (carry-tape-input-mixin))

;------------------------------
; carry-tape-file-streams

(defflavor carry-tape-file-input-stream ((raw-stream (make-instance 'carry-tape-input-stream))
					 file-plist)
	   (si:buffered-input-stream)
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables
  :special-instance-variables
  )

(defmethod (carry-tape-file-input-stream :discard-input-buffer) (&rest ignore)
  nil)

(defmethod (carry-tape-file-input-stream :next-input-buffer) (&rest ignore)
  (condition-case ()
      (let* ((next-block-size (read-block-mark raw-stream))
	     (string (or si:stream-input-buffer (make-string 4096.))))
	(send raw-stream :string-in nil string 0 next-block-size)
	(setq si:stream-input-buffer string
	      si:stream-input-index 0
	      si:stream-input-limit next-block-size)
	(values si:stream-input-buffer si:stream-input-index si:stream-input-limit))
    (file-mark-detected (values nil 0 nil))))

(defmethod (carry-tape-file-input-stream :init) (&rest ignore)
  (setq file-plist (read-carry-file-plist raw-stream))
  (send self :next-input-buffer))

;--------------------
;
; random support functions 

(defun make-carry-tape-file-stream (&optional (direction :input))
  (case direction
    (:input (make-instance 'carry-tape-file-input-stream))
    (:output (tv:beep)(format t "~&CARRY-TAPE output streams are not yet suppoerted.~%"))))