;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Readtable:CL; Lowercase:YES; Base:10 -*-


(defvar *my-area*)
	(make-area :name '*my-area* :gc :fixed))

(defstruct communications
  (area *my-area*)
  (address)
  (limit)
  (allocation-pointer))

(defvar *communications*)

(defun init-my-area ()
  (when (minusp (%area-region-list *my-area*))
    (%make-region *my-area* (area-region-bits *my-area*) #o40000))
  (let ((region (area-region-list *my-area*)))
    (%use-up-region region)
    (%wire-area *my-area* t)
    (multiple-value-bind (start end)
	(area-bounds *my-area*)
      (setf *communications*
	    (make-communications
	      :address start
	      :limit end
	      :allocation-pointer start)))))

(defun area-bounds (area)
  (let ((region (%area-region-list area)))
    (or (minusp (%region-list-thread region)) ;last region in area
	(ferror "area ~a has more than one region" (area-name area)))
    (let ((start (%region-origin region)))
      (values start (+ start (%region-length region))))))

(defun allocate-mac-page ()
  (when ( (communications-allocation-pointer *communications*)
	   (communications-limit *communications*))
    (error "Out of Mac Pages..."))
  (let ((page (communications-allocation-pointer *communications*)))
    (incf (communications-allocation-pointer *communications*) sys:page-size)
    (values page (+ page sys:page-size))))

(defvar *my-area-start* (area-bounds *my-area*))

(defun virtual-address (pointer)
  (error "We cannot determine the local physical address #o~O."
	 pointer))

(defun store-nubus-address (pointer vadr)
  (let* ((padr (%physical-address vadr))
	 (nubus (%nubus-physical-address (ldb (byte 22. 8) padr)))
	 (tag (ldb (byte 7 15) nubus))
	 (bottom1 (ldb (byte 15 0) nubus))
	 (bottom2 (ldb (byte 8 0) padr))
	 (bottom (%logdpb bottom1 (byte 15 10)
			  (%logdpb bottom2 (byte 8 2) 0))))
    (%p-store-tag-and-pointer pointer tag bottom)))

(defsetf virtual-address store-nubus-address)

(defvar *screen-pointer* (...))

(defstruct (local-master-table (:conc-name lmt-))
  (physical-master-table)
  (major-command-block)
  (mac-command-block)
  (screen-table)
  (devices)
  ...)

(defvar *master-table*)

(defun setup-master-table ()
  (init-my-area)
  (let ((physical-table (area-bounds *my-area*)))
    (store-nubus-address *shared-memory-location* physical-table)
    (setq *master-table*
	  (make-master-table
	    :physical-master-table physical-table))
    (let ((screen-table (allocate-screen-table)))
      (setf (lmt-screen-table *master-table*) screen-table)
      ;; Macrofy this next...
      ;; We only store a physical nubus address when we're storing into a structure
      ;; for the Macintosh, like this.
      (setf (virtual-address (+ (lmt-physical-master-table *master-table*)
				*mt-screen-table*))
	    (screen-table-physical-table screen-table)))))

(defstruct screen-table
  (physical-table)
  (array (make-array 500)))

(defun allocate-screen-table ()
  (let ((st (make-screen-table))
	(next-page (allocate-mac-page)))
    (setf (screen-table-physical-table st) next-page)
    st))

(defmacro master-table-screen (pointer)
  (virtual-address (%pointer-plus pointer 4)))

(setf (master-table-screen *master-table-pointer*) *screen-pointer*)

(defstruct device
  (physcial-device)
  (buffer-chain)				;Logical, not physical structures
  (type)
  )

(defvar *unusued-devices* nil)

(defun allocate-device (type)
  (let ((device (without-interrupts (pop *unused-devices*))))
    (when device
      (setf (device-buffer-chain device) nil
	    (device-type device) nil)
      (return-from allocate-device device))
    (make-device :physical-device (allocate-mac-page)
		 :type type)))

(defun create-device (type)
  (let ((device (allocate-device type)))
	(device-table (find-device-table type)))
    (enter-device-in-device-table device device-table)
    device)

(defun find-device-table (type)
  (let ((device-tables (lmt-devices *master-table*)))
    (loop for dev-tab in device-tables
	  when (eq (device-table-type dev-tab) type)
	  return dev-tab
	  finally (error "No device type ~S." type))))

(defun enter-device-in-device-table (device device-table)
  (array-push-extend device (device-table-array device-table))
  (setf (virtual-address (+ (device-table-devices device-table)
			    (device-table-fill-pointer device-table)))
	(device-physical-device device))
  (incf (device-table-fill-pointer device-table)))

(defstruct buffer
  (physical-buffer)
  (physical-data-start-address)			;Displace the array to hear
  (status-address)				;Read status from here
  (next-buffer)					;Next buffer in the chain
  (device))