;;; -*- 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)
  ...)

(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...
      (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*)