;;; -*- Mode:LISP; Package:MAC; Base:10; Readtable:ZL -*-
;;;
;;;  Making a stream out of a Mac-file
;;;




(defconst  LOGICAL-EOF-REACHED  -39)

(declare (special mac-file-streams-list))

;
;   MAC-STREAM-MIXIN
;


(defflavor mac-stream-mixin
	(truename)
	(si:property-list-mixin si:file-stream-mixin)
  (:gettable-instance-variables truename)
  (:init-keywords :file :append :truename :if-exists))

(defmethod (mac-stream-mixin :init) (plist)
  (let ((file (get plist :file)))
    (if (not file)
	(setq truename (get plist :truename))
      (setq truename (mac-file-truename file)
	    si:property-list (read-info-blk (file-info-blk file))))))

(defmethod (mac-stream-mixin :qfaslp) ()
  (get (locf si:property-list) :qfaslp))

;; For probes, assume you really mean :LENGTH-IN-BYTES
(defmethod (mac-stream-mixin :length) ()
  (get (locf si:property-list) :length-in-bytes))

(defmethod (mac-stream-mixin :properties) (&optional error-p)
  error-p					; would be quite hard to get an error here
  (values (cons truename si:property-list) mac-unsettable-properties))


;
;   MAC-DATA-STREAM-MIXIN
;


(defflavor mac-data-stream-mixin
	 (file)
	 (mac-stream-mixin)
  (:initable-instance-variables file))


(defmethod (mac-data-stream-mixin :init) (ignore)
  (setq truename (mac-file-truename file)
	si:property-list (read-info-blk (file-info-blk file)))
  (without-interrupts
    (setq mac-file-streams-list
	  (cons self mac-file-streams-list))))


(defmethod (mac-data-stream-mixin :close) (&optional abortp)
  (mac-close-file file abortp)
  (without-interrupts
    (setq mac-file-streams-list (delq self mac-file-streams-list)))
  (setq file nil))

(defmethod (mac-data-stream-mixin :set-buffer-pointer) (where)
  (if ( where 0)
      (ferror "Mac error: You can only set-buffer-pointer to 0.")
    (send-file-cmd-wait (dev-cmd-blk (file-dev-blk file)) CMD-REWIND 0 0)
    0))


(defmethod (mac-data-stream-mixin :geteof) ()
  (get (locf si:property-list) :length-in-bytes))

(defmethod (mac-data-stream-mixin :seteof) (eof-value)
  (send-file-cmd-wait (dev-cmd-blk (file-dev-blk file)) CMD-SETEOF 1 0 eof-value)
  (putprop (locf si:property-list) eof-value :length-in-bytes))

(defmethod (mac-data-stream-mixin :delete) (&optional (error-p t))
  (fs:identify-file-operation :delete
    (fs:handling-errors error-p
      (mac-delete-file file))))

(defmethod (mac-data-stream-mixin :rename) (new-name &optional (error-p t))
  (fs:identify-file-operation :rename
    (fs:handling-errors error-p
      (mac-rename-file file
		       (pathname-directory new-name)
		       (pathname-name new-name)
		       (pathname-type new-name)
		       (pathname-version new-name)))
    (setq truename (mac-file-truename file))))

;;
;; need all properties
(defmethod (mac-data-stream-mixin :change-properties) (error-p &rest properties)
  (fs:identify-file-operation :change-properties
    (fs:handling-errors error-p
      (do ((a-property properties (cddr a-property)))
	  ((null a-property))
	(putprop (locf si:property-list) (cadr a-property) (car a-property)))
      (mac-change-file-properties file si:property-list))))


;
;   MAC-INPUT-STREAM-MIXIN
;


(defflavor mac-input-stream-mixin ()
	   (mac-data-stream-mixin si:input-file-stream-mixin))




;; For input streams, :LENGTH may be different from :LENGTH-IN-BYTES
(defmethod (mac-input-stream-mixin :length) ()
  (get (locf si:property-list) :length-in-bytes))


;
;   MAC-OUTPUT-STREAM-MIXIN
;


(defflavor mac-output-stream-mixin ()
	   (mac-data-stream-mixin si:output-file-stream-mixin))

(defmethod (mac-output-stream-mixin :before :close) (&optional abort-p)
  (unless abort-p
    (send self :finish)))



;;
;;   MAC-INPUT-STREAM
;;
(defflavor mac-input-stream
	   ()
	   (mac-input-stream-mixin)
  (:included-flavors si:buffered-input-stream))


(defmethod (mac-input-stream :next-input-buffer) (&rest ignore)
  (let* ((dev-blk (file-dev-blk file))
	 (current-buffer (dev-current-lisp-buffer dev-blk)))
    (process-wait "File input"
		  #'(lambda (dev-blk iobuffer)
		      (or (= DST-EOF (dev-status dev-blk))
			  (memq (buffer-state iobuffer) (list ST-FILLED ST-ERROR))))
		  dev-blk current-buffer)
    (if (= DST-EOF (dev-status dev-blk))
	nil
      (select (buffer-state current-buffer)
	(ST-FILLED
	 (let* ((start  (buffer-start current-buffer))
		(length (buffer-mac-scan current-buffer))
		(array (buffer-to-array start length)))
	   (setf (dev-current-lisp-buffer dev-blk) (buffer-next-buffer current-buffer))
	   (setf (buffer-state current-buffer) ST-DONE)
	   (values array 0 length)))
	(ST-ERROR (ferror "Error in next-input-buffer" (buffer-error-byte current-buffer)))))))


  
(defmethod (mac-input-stream :discard-input-buffer) (ignore)
  nil)



;;
;;   MAC-OUTPUT-STREAM
;;

;;; The way this works is specific to the Lambda, where we do not have direct access to the
;;; Nubus buffers.

(defflavor mac-output-stream
	()
	(mac-output-stream-mixin)
  (:included-flavors si:buffered-output-stream))


(defmethod (mac-output-stream :new-output-buffer) ()
  (values (make-string *buffer-data-size*) 0 *buffer-data-size*))


(defmethod (mac-output-stream :send-output-buffer) (array ending-index)
  (let* ((dev-blk (file-dev-blk file))
	 (current-buffer (dev-current-lisp-buffer dev-blk)))
    (process-wait "File input"
		  #'(lambda (iobuffer)
		      (memq (buffer-state iobuffer) (list ST-IDLE ST-FILLED ST-ERROR)))
		  current-buffer)
    (select (buffer-state current-buffer)
      ((ST-IDLE ST-FILLED)
       (setf (buffer-state current-buffer) ST-RUN)
       (setf (buffer-falcon-scan current-buffer) ending-index)
       (array-to-buffer array (buffer-start current-buffer) ending-index)
       (setf (buffer-state current-buffer) ST-DONE)
       (setf (dev-current-lisp-buffer dev-blk) (buffer-next-buffer current-buffer)))
      (ST-ERROR (ferror "Error in new-output-buffer" (buffer-error-byte current-buffer))))))



(defmethod (mac-output-stream :discard-output-buffer) (ignore)
  nil)

(defmethod (mac-output-stream :force-output) ()
  (let ((buffer (send self :STREAM-outPUT-BUFFER)))
   (if buffer (send self :send-output-buffer buffer (send self :STREAM-outPUT-INDEX)))))

(defmethod (mac-output-stream :finish) ()
  (let* ((dev-blk (file-dev-blk file))
	 (current-buffer (dev-current-lisp-buffer dev-blk)))
    (process-wait "force output"
		  #'(lambda (dev-blk buffer)
		      (and (equal buffer (dev-current-mac-buffer dev-blk))
			   (memq (buffer-state buffer) (list ST-IDLE ST-FILLED ST-ERROR))))
		  dev-blk current-buffer)
    (if (eq ST-ERROR (buffer-state current-buffer))
	(ferror "Error no: ~a in force-output" (buffer-error-byte current-buffer)))))



;;
;;   MAC-IO-STREAM
;;
;(defflavor mac-io-stream ()
;	   (si:io-stream-input-mixin mac-output-stream))
;


;
;   MAC-CHARACTER-INPUT-STREAM
;


(defflavor mac-character-input-stream ()
  (si:character-stream mac-input-stream si:buffered-tyi-input-stream))

(defmethod (mac-character-input-stream :around :tyi) (cont mt ignore)
  (let ((ch (funcall-with-mapping-table cont mt :tyi)))
    (select ch
      (8   #\BS)
      (9   #\TAB)
      (10  #\LINE)
      (12  #\FF)
      (13  #\CR)
      (127 #\RUBOUT)
      (t   ch))))

(defmethod (mac-character-input-stream :tyi-no-hang) () (send self :tyi))
(defmethod (mac-character-input-stream :tyipeek)     () (send self :tyi))

;
;   MAC-CHARACTER-OUTPUT-STREAM
;


(defflavor mac-character-output-stream ()
	(si:character-stream mac-output-stream si:buffered-tyo-output-stream))


(defmethod (mac-character-output-stream :around :tyo) (cont mt ignore ch)
  (funcall-with-mapping-table
    cont mt :tyo
    (selectq ch
      (#\BS     8)
      (#\TAB    9)
      (#\LINE   10)
      (#\FF     12)
      (#\CR     13)
      (#\RUBOUT 127)
      (t        ch))))


;
;   MAC-CHARACTER-IO-STREAM
;

;(defflavor mac-character-io-stream ()
;	   (si:io-stream-input-mixin mac-character-output-stream))



;
;   MAC-PROBE-STREAM
;


(defflavor mac-probe-stream
	()
	(mac-stream-mixin si:stream)
  ;; kludge so that open can pass this a :byte-size :default
  (:init-keywords :byte-size))

(defmethod (mac-probe-stream :status)    () :closed)
(defmethod (mac-probe-stream :direction) () nil)
(defmethod (mac-probe-stream :byte-size) () (getf si:property-list :byte-size))


(COMPILE-FLAVOR-METHODS MAC-CHARACTER-INPUT-STREAM MAC-CHARACTER-OUTPUT-STREAM
			MAC-PROBE-STREAM)


(defun undefflavor-all ()
  (undefflavor 'mac-stream-mixin)
  (undefflavor 'mac-data-stream-mixin)
  (undefflavor 'mac-input-stream-mixin)
  (undefflavor 'mac-output-stream-mixin)
  (undefflavor 'mac-character-input-stream)
  (undefflavor 'mac-character-output-stream)
  (undefflavor 'mac-probe-stream))



;; change
(defun mac-finish-output (file)
  (send-file-cmd-wait (dev-cmd-blk (file-dev-blk file)) :FINISH-OUTPUT 0 0))



(defun mac-file-truename (file)
  (make-pathname :host      mac-host
		 :device    :unspecific
		 :directory (file-directory file)
		 :name      (file-name      file)
		 :type      (file-type      file)
		 :version   (file-version   file)))



(defun buffer-to-array (start length)
  (let ((array (make-string length)))
    (loop for i from 0 to (1- length)
	  do (aset (read-BC-byte (+ start i)) array i)
	  finally (return array))))


(defun array-to-buffer (array buffer end)
  (loop for i from 0 to (1- end)
	do (write-BC-byte (+ buffer i) (aref array i))
	finally	(return buffer)))