;;; -*- Mode:LISP; Package:MAC; Readtable:T; Base:10 -*-
;;;
;;; By Renaud Nadeau October 1988
;;;



;;;
;;;  Constants, variables and functions used by the BC share-memory
;;;


(defconst Falcon-version-number 1)
(defconst BC-base-adr #xfb000000)


;
; All transition state for the KMAC communications
;
(defconst  ST-IDLE    0)
(defconst  ST-FILLING 1)
(defconst  ST-FILLED  2)
(defconst  ST-RUN     3)
(defconst  ST-DONE    4)
(defconst  ST-ERROR   5)
(defconst  ST-FAULT   6)


;
; All device Status Codes for the buffered stream
;
(defconst DST-CLOSED            0)
(defconst DST-OPEN              1)
(defconst DST-EOF               2)
(defconst DST-ERROR             3)
(defconst DST-CONTINUABLE-ERROR 4)







(defconst CMD-QUIT               1)
(defconst CMD-REBOOT             2)
(defconst CMD-SHUTDOWN           3)
(defconst CMD-CREATE-DEVICE      4)
(defconst CMD-DELETE-DEVICE      5)
(defconst CMD-OPEN               6)		      
(defconst CMD-CLOSE              7)			 
(defconst CMD-RENAME             8)
(defconst CMD-DELETE             9)
(defconst CMD-CHANGE-PROPERTIES 10)
(defconst CMD-DIRECTORY-LIST    11)
(defconst CMD-EXPUNGE-DIRECTORY 12)
(defconst CMD-CREATE-DIR        13)
(defconst CMD-COMPLETE-STRING   14)
(defconst CMD-REWIND            15)
(defconst CMD-SETEOF            16)
(defconst CMD-PRINt             17)

;(defconst CMD-READ              101)
;(defconst CMD-WRITE             102)
;(defconst CMD-NEXT-DIRECTORY    113)
;(defconst CMD-FINISH-OUTPUT     114)
;(defconst CMD-PAGEIN             3)
;(defconst CMD-PAGEOUT            4)



(declare (special *BC-memory-available*  header-table))

;;;
;;; Definition of the methods to allocate the Bus-Coupler memory
;;;

(defun alloc-BC-memory (size &optional (init-list nil))
  (let* ((struct *BC-memory-available*)(adr struct))
    (setq *BC-memory-available* (+ (* 4 size) *BC-memory-available*))
    (loop for each in init-list do
	  (write-BC-long adr (if each each 0))
	  (decf size)
	  (incf adr 4))
    (loop repeat size do
	  (write-BC-long adr 0)
	  (incf adr 4))
    struct))



;;;
;;; Definition of the structure :bc-struct
;;;

(eval-when (compile load)
  (defun make-ascii-number (ignore stream)
    (loop with char = (character (readch stream)) and n = 0 
	  until (or (char-lessp char #/A)
		    (char-greaterp char #/Z)) do
	  (setq n (+ (character char) (ash n 8)))
	  (setq char (character (readch stream)))
	  finally (return n)))
  
  (set-syntax-#-macro-char #/& 'make-ascii-number)
  
  
  (si:defstruct-define-type :bc-struct
    (:cons-keywords :size )
    (:cons (init description keywords)
	   :list
	   description
	   `(alloc-bc-memory ,(* 4 (or (cdr (assq :size keywords))
				       (length init)))
			     (list ,@init)))
    (:ref (number description address offset)
	  description
	  `(read-bc-long (+ ,(* 4 number) ,address ,offset))))
  
  
  (defsetf read-bc-long write-bc-long))

;;;
;;; All structure use in the communication between Mac <-> Falcon
;;;
; The organisation of the file for each structure look like
;
; Declaration of the constants related to the specific structure
; Declaration of the variables    "     "  "     "         "
; Declaration of the structure    "     "  "     "         "
; Declaration of the functions    "     "  "     "         "
;;;

(defconst kmac-header-CMD-number       #X52010064)
(defconst kmac-header-Mac-CMD-number   #x52100064)
(defconst *command-struct-var-size* 36)

(defstruct (command :conc-name
		    (:type (:bc-struct))
		    (:default-pointer 0))
  header
  (state ST-IDLE)
  command
  arg-count
  val-count
  err-code
  err-string
  stream
  args)


(defun send-cmd-wait (struct cmd narg nval &rest args)
  (setf (Command-state struct) ST-FILLED)
  (setf (Command-command struct) cmd)
  (setf (Command-arg-count struct) narg)
  (setf (Command-val-count struct) nval)
  (setf (Command-err-code struct) 0)
  (setf (Command-err-string struct) 0)
  (setf (Command-stream struct) 0)
  (loop with offset = 0
	for each in args do
	(setf (Command-args struct offset)each)
	(incf offset 4))
  (setf   (Command-state struct) ST-FILLED)
  (process-wait "BC" #'(lambda () (let ((state (Command-state struct)))
				    (or (= state ST-DONE)
					(= state ST-ERROR)
					(= state ST-FAULT)))))
  (if (eq ST-FAULT (Command-state struct))
      (ferror "Protocol fault no: ~a in command no: ~a" (Command-err-code struct) cmd)))


;;;
;;; The keyboard and mouse is a fixe structure
;;;
(defconst kmac-header-KBD-number       #x5207001c)
(defconst *kbd-ring-buffer-item-size* 8)
(defconst *kbd-ring-buffer-length* 128)
(defconst *kbd-ring-buffer-size* (* *kbd-ring-buffer-item-size* *kbd-ring-buffer-length*))

(defstruct (KBD  :conc-name
		 (:type :bc-struct)
		 (:default-pointer 0))
  (header  kmac-header-KBD-number)
  buffer-start
  buffer-end
  buffer-input
  buffer-output
  mouse-x
  mouse-y)

(defstruct (kbd-entry :conc-name
		 (:type :bc-struct)
		 (:default-pointer 0))
  type-modifiers
  char-or-mouse)

;;;
;;; cold-stream buffer
;;;

(defconst kmac-header-cold-stream #X52200014)
(defconst *cold-ring-buffer-item-size* 8)
(defconst *cold-ring-buffer-length* 128)
(defconst *cold-ring-buffer-size* (* *cold-ring-buffer-item-size* *cold-ring-buffer-length*))

(defstruct (cold-str  :conc-name
		 (:type :bc-struct)
		 (:default-pointer 0))
  (header  kmac-header-cold-stream)
  buffer-start
  buffer-end
  buffer-input
  buffer-output)


;;;
;;; The device table is create by the Falcon but
;;; it is maintains by the Mac aplication
;;;
(defconst kmac-header-Dev-Table-number #x520200c8)

(defstruct (Dev-Tab  :conc-name
		    (:type (:bc-struct))
		    (:default-pointer 0))
  (header kmac-header-Dev-table-number)
  name
  blks)

;;;
;;; Allocation for the Screen Descriptor
;;;
(defconst kmac-header-Screen-number    #x52030024)

(defstruct (SD  :conc-name
		(:type :bc-struct)
		(:default-pointer 0))
  (header  kmac-header-Screen-number)
  Falcon-addr
  Falcon-depth
  Falcon-words-per-row
  Falcon-width
  Falcon-height
  Priority-CMD-blk
  CMD-blk
  Mac-window)

;;;
;;; Allocation of pathname free-list
;;;
(defconst kmac-header-pathname         #x5211012c)    ;75 -> 300
(defconst *nb-pre-allocated-pathname* 15)
(defconst *pathname-struct-var-size* 28 )
(defvar *pathname-free-list*)


(defstruct (path  :conc-name
		  (:type (:bc-struct))
		  (:default-pointer 0))
  (header kmac-header-pathname)
  host
  device
  name
  type
  version
  nb-dirs
  dirs)


(defun write-pathname-blk (struct directory name type version)
  (let* ((offset 0)
	 (length 0)
	 (ndirs 1)
	 (string-adr 0))
    (setf (path-header struct) kmac-header-pathname)
    (setf (path-host struct) 0)
    (setf (path-device struct) 0)
    (if (not (listp directory))
	(setq directory (list directory))
      (setq ndirs (length directory)))
    (setq string-adr (+ *pathname-struct-var-size* (* 4 ndirs)))
    (setf (path-nb-dirs struct) ndirs)
    (loop for each-name in directory do
	  (if (not (stringp each-name))
	      (setf (path-dirs struct offset) (expr->num each-name))
	    (setq length (string-length each-name))
	    (setf (path-dirs struct offset) (dpb ISA-STRING (byte 8 24.) string-adr))
	    (write-BC-mac-string  (+ struct string-adr) each-name length)
	    (incf string-adr (1+  length)))
	  (incf offset 4))
    (if (not (stringp name))
	(setf (path-name struct) (expr->num name))
	    (setq length (string-length name))
	    (setf (path-name struct) (dpb ISA-STRING (byte 8 24.) string-adr))
	    (write-BC-mac-string  (+ struct string-adr) name length)
	    (incf string-adr (1+ length)))
    (if (not (stringp type))
	(setf (path-type struct) (expr->num type))
	    (setq length (string-length type))
	    (setf (path-type struct) (dpb ISA-STRING (byte 8 24.) string-adr))
	    (write-BC-mac-string  (+ struct string-adr) type length))
    (setf (path-version struct) (expr->num version))))


(defun read-pathname-blk (struct)
  (let* (name type version
	 (offset 0)
	 (directory nil)
	 (ndirs (path-nb-dirs struct)))
    (loop repeat ndirs do
	  (setq directory (cons (num->expr (path-dirs struct offset) struct) directory))
	  (incf offset 4))
    (setq directory (reverse directory)
	  name    (num->expr (path-name struct) struct)
	  type    (num->expr (path-type struct) struct)
	  version (num->expr (path-version struct)))
    (if (= 1(length directory))
	(setq directory (car directory)))
    (values directory name type version)))

      
(defun init-pathname-free-list ()
  (setq *pathname-free-list* 
	(loop repeat *nb-pre-allocated-pathname* 
	      collect (make-path :size 75))))

(defun new-pathname-blk ()
  (process-wait "Wait free pathname"
		#'(lambda () (not (null *pathname-free-list*))))
  (pop *pathname-free-list*))

(defun release-pathname-blk (blk)
  (push blk *pathname-free-list*))


;;;
;;; Allocation of device free-list
;;;
;;;
(defconst kmac-header-Paging-number    #x52040000)
(defconst kmac-header-Device-number    #x52050028)
(defconst kmac-header-Network-number   #x52080000)
(defconst *nb-pre-allocated-dev-blk* 15)
(defvar *device-free-list*)


(defstruct (Dev  :conc-name
		 (:type :bc-struct)
		 (:default-pointer 0))
  (header kmac-header-Device-number)
  (status DST-CLOSED)
  flags
  Buffer-chain
  Current-Mac-buffer
  Current-Lisp-buffer
  Mac-state
  Owing-Process
  pathname
  cmd-blk)

(defun init-device-free-list ()
  (setq *device-free-list* 
	(loop repeat *nb-pre-allocated-dev-blk* 
	      collect (make-dev :cmd-blk (make-command :size 25 :header kmac-header-CMD-number)))))

(defun new-device-blk ()
  (process-wait "Wait free Dev"
		#'(lambda () (not (null *device-free-list*))))
  (pop *device-free-list*))

(defun release-device-blk (blk)
  (without-interrupts (push blk *device-free-list*)))


;;;
;;; Allocation for the file information
;;;

(defconst kmac-header-info  #X52120320)
(defconst *info-struct-var-size* 80)
(defconst *nb-pre-allocated-info-blk* 15)

(defvar *info-free-list*)
(defvar  mac-properties  '(:author
			   :byte-size
			   :characters
			   :deleted
			   :dont-delete
			   :dont-reap
			   :qfasl
			   :creation-date
			   :modification-date
			   :not-backup
			   :length-in-bytes
			   :length-in-blocks
			   :mac-type
			   :directory))
(defvar  mac-unsettable-properties  '(:byte-size
				      :characters
				      :dont-reap
				      :qfasl
				      :not-backup
				      :length-in-bytes
				      :length-in-blocks
				      :directory)
  "Unsettable properties are those which are uniquely determined by the text of the file.")

(defvar  mac-settable-properties  (reverse (set-difference mac-properties mac-unsettable-properties)))


(defstruct (info  :conc-name
		  (:type (:bc-struct))
		  (:default-pointer 0))
  (header kmac-header-info)
  author
  byte-size
  characters
  deleted
  dont-delete
  dont-reap
  qfasl
  creation-date
  modification-date
  not-backup
  length-in-bytes
  length-in-blocks
  mac-type
  directory
  name  
  type 
  version
  user-plist-size
  user-plist)

(defun init-info-free-list ()
  (setq *info-free-list* 
	(loop repeat *nb-pre-allocated-info-blk* 
	      collect (make-info :size 200))))

(defun new-info-blk ()
  (process-wait "Wait free info blk"
		#'(lambda () (not (null *info-free-list*))))
  (pop *info-free-list*))

(defun release-info-blk (blk)
  (without-interrupts (push blk *info-free-list*)))

(defun read-info-blk (struct)
  (let* ((plist-size (info-user-plist-size struct))
	 (plist-addr (ldb (byte 24. 0) (info-user-plist struct))))
    (append (list ':author            (num->expr (info-author      struct) struct)
		  ':characters        (num->expr (info-characters  struct))
		  ':deleted           (num->expr (info-deleted     struct))
		  ':dont-delete       (num->expr (info-dont-delete struct))
		  ':dont-reap         (num->expr (info-dont-reap   struct))
		  ':qfasl             (num->expr (info-qfasl       struct))
		  ':not-backup        (num->expr (info-not-backup  struct))
		  ':directory         (num->expr (info-directory   struct))
	          ':byte-size         (info-byte-size         struct)
		  ':creation-date     (info-creation-date     struct)
		  ':modification-date (info-modification-date struct)
		  ':length-in-bytes   (info-length-in-bytes   struct)
		  ':length-in-blocks  (info-length-in-blocks  struct)
		  ':mac-type          (info-mac-type          struct))
	    (if (> plist-size 0)
		(let ((string (make-string plist-size)))
		    (read-BC-in-string (+ struct plist-addr) string plist-size)
		    (with-input-from-string (stream string)
		      (fs:read-property-list stream)))))))

(defun dissect-property-list (property-list)
  "Separates a plist into file properties and user properties,
   and verifies if the properties are settable."
  (let ((plist (copy-list property-list))
	file-plist user-plist)
    (do ((prop plist (cddr prop)))
	((null prop)
	 (values file-plist user-plist))
      (cond ((memq (car prop) mac-settable-properties)
	     (push (cadr prop) file-plist)
	     (push (car  prop) file-plist))
	    ((not (memq (car prop) mac-unsettable-properties))
	     (push (cadr prop) user-plist)
	     (push (car  prop) user-plist))))))


(defun write-info-blk (struct plist)
  (let ((string-adr  *info-struct-var-size*))
    (multiple-value-bind (file-plist user-plist)
	(dissect-property-list plist)
      (loop for (prop value) on file-plist by 'cddr do
	    (selectq prop
	      (:author
	       (let (length)
		 (if (or (not (stringp value))
			 (> (setq length (string-length value)) 15))
		     (ferror "MAC error: Maximum length of author string is 15"))
		 (setf (info-author struct) (dpb ISA-STRING (byte 8 24.) string-adr))
		 (write-BC-mac-string  (+ struct string-adr) value length)
		 (incf string-adr (1+ length))))
	      (:deleted           (setf (info-deleted struct) (expr->num value)))
	      (:dont-delete       (setf (info-dont-delete struct) (expr->num value)))
	      (:mac-type          (setf (info-mac-type struct) value))
	      (:creation-date     (setf (info-creation-date struct) value))
	      (:modification-date (setf (info-modification-date struct) value))))
      (when user-plist
	(let* ((string (with-output-to-string (stream)
		       (fs:write-property-list stream user-plist)))
	       (length (string-length string)))
	  (setf (info-user-plist-size struct) length)
	  (setf (info-user-plist struct) (dpb ISA-TEXT (byte 8 24.) string-adr))
	  (write-BC-from-string string (+ struct string-adr) length))))))


;;;
;;;  Allocation and manipulation of the Chained IObuffers
;;;

(defconst kmac-header-Buffer-number    #x52060028)
(defconst *buffer-descriptor-size* 40)
(defconst *buffer-data-size* 512)
(defconst *nb-pre-allocated-buffers* 15)
(defconst *buffer-size* (+ *buffer-descriptor-size* *buffer-data-size*))

(defvar *free-buffer-list*)
(defvar *nb-input-IObuffer*  2)
(defvar *nb-output-IObuffer* 2)

(defstruct (Buffer  :conc-name
		    (:type (:bc-struct))
		    (:default-pointer 0))
  (header kmac-header-Buffer-number)
  (state ST-IDLE)
  next-buffer
  alloc-start
  alloc-end
  start
  end
  Falcon-scan
  Mac-scan
  Error-byte)

(defun allocate-buffers ()
  (setq *free-buffer-list*
	(loop with buffer
	      repeat *nb-pre-allocated-buffers* do
	      (setq buffer (make-buffer :size 138))
	      (setf (buffer-alloc-start buffer) buffer)
	      (setf (buffer-alloc-end buffer) (+ buffer *buffer-size*))
	      (setf (buffer-start buffer) (+ buffer *buffer-descriptor-size*))
	      (setf (buffer-end buffer) (+ (buffer-start buffer) *buffer-data-size*))
	      collect buffer)))

(defun get-buffer (direction)
  (let (buffer)
    (process-wait "Wait free buffer"
		  #'(lambda () (not (null *free-buffer-list*))))
    (without-interrupts
      (setq buffer (pop *free-buffer-list*))
      (select direction
	(:input  (setf (Buffer-state buffer) ST-DONE))
	(:output (setf (Buffer-state buffer) ST-IDLE)))
    buffer)))
		 
(defun release-buffer (buffer)
  (without-interrupts (push buffer *free-buffer-list*)))


(defun get-chained-iobuffers (how-many direction)
  (loop with first-buffer = (get-buffer direction)
	with next-buffer  = first-buffer
	repeat (1- how-many)
	do (setf (Buffer-next-buffer next-buffer) (get-buffer direction))
	   (setq next-buffer (Buffer-next-buffer next-buffer))
	finally (setf (Buffer-next-buffer next-buffer) first-buffer)
                (return first-buffer)))

(defun release-chained-iobuffers (first-buffer)
  (when (> first-buffer 0)
    (loop with next   = (Buffer-next-buffer first-buffer)
	  until (= next first-buffer)
	  do (release-buffer next)
	  (setq next   (Buffer-next-buffer next))
	  finally (release-buffer first-buffer))))


;(defun how-many-chained-iobuffers (first-buffer)
;  (loop with buffer = first-buffer
;	summing 1
;	do (setq buffer (Buffer-next-buffer buffer))
;	until (= buffer first-buffer)))


;;;
;;; 
;;;



(defconst kmac-header-header-number    #x52000050)


(defstruct (Header-Table (:type (:bc-struct))
			 (:default-pointer 0))
  (kmac-header-header  kmac-header-header-number)
  falcon-protocol-version
  mac-protocol-version
  Major-CMD-blk
  major-Mac-CMD-blk
  paging-CMD-blk
  KBD-mouse-descriptor
  Screen-table
  File-stream-table
  Network-table
  Serial-table
  printer-table
  cold-stream)


(defun allocate-communication-root()
  (let (KBD-buffer cold-buffer)
    (setq Header-Table (make-header-table :size 20))
    (setf (Major-CMD-blk        Header-Table) (make-command :size 25 :header  kmac-header-CMD-number))
    (setf (major-Mac-CMD-blk    Header-Table) (make-command :size 25 :header  kmac-header-Mac-CMD-number))
    (setf (paging-CMD-blk       Header-Table) (make-command :size 25 :header  kmac-header-Paging-number))
    (setq KBD-buffer (alloc-BC-memory (// *Kbd-ring-buffer-size* 4)))
    (setf (KBD-mouse-descriptor Header-Table) (make-KBD :buffer-start   KBD-buffer
							:buffer-end     (+ KBD-buffer *kbd-ring-buffer-size*)
							:buffer-input   KBD-buffer
							:buffer-output  KBD-buffer))
    (setf (File-stream-table    Header-Table) (make-Dev-tab :size 50 :name #&FILE ))
    (setf (Network-table        Header-Table) (make-Dev-tab :size 50 :name #&ETHR ))
    (setf (Serial-table         Header-Table) (make-Dev-tab :size 50 :name #&SERD ))
    (setf (printer-table        Header-Table) (make-Dev-tab :size 50 :name #&PRNT ))
    (setf (Screen-table         Header-Table) (make-Dev-tab :size 50 :name #&SCRN ))
    (setq cold-buffer (alloc-BC-memory (// *cold-ring-buffer-size* 4)))
    (setf (cold-stream          Header-Table) (make-cold-str :buffer-start   cold-buffer
						             :buffer-end     (+ cold-buffer *cold-ring-buffer-size*)
							     :buffer-input   cold-buffer
							     :buffer-output  cold-buffer))
    (setf (Dev-tab-blks (Screen-table Header-Table)) (make-sd))
    (setf (Dev-tab-blks (Screen-table Header-Table) 4) (make-sd))))