;;;
;;; object-table.lisp
;;;
;;; Speakeasy Smalltalk object table
;;;

(cl:in-package :speakeasy)


;;;
;;; The object table
;;;

;; An object table entry

(defstruct ote
  class
  data
  pointers
  words
  odd-length)

;; The object table is an array containing information about every
;; object in the system.  It is indexed by (ash oop -1).
;;
;; Each allocated object is represented by an OTE.  Free entries are
;; integers representing a freelist, or NIL representing the end of
;; the freelist.

(defvar *object-table* (make-array #x8000 :initial-element nil))
(defvar *next-free-oop* 0)

;; Initialize the freelist.

(defun clear-object-memory ()
  (setf *next-free-oop* 0)
  (dotimes (i #x7fff)
    (setf (aref *object-table* i) (ash (1+ i) 1))))


;;;
;;; Object allocation and creation.
;;;

(defun allocate-oop ()
  "Obtain an un-allocated OOP for use."
  (prog1
      *next-free-oop*
    (when (not (setf *next-free-oop* (aref *object-table* (ash *next-free-oop* -1))))
      ;;; Oops: Out of OOPs. We really should GC here, but meanwhile...
      (panic "No free OOPs"))))

(defun make-object (oop type length class)
  "Create an OTE for a given OOP, allocating required data space."
  (when (ote-p (aref *object-table* (ash oop -1)))
    (panic "make-object overwriting existing OTE"))
  (setf (aref *object-table* (ash oop -1))
	(make-ote :class class
		  :pointers (eql type :pointers)
		  :words (eql type :words)
		  :odd-length (and (eql type :bytes)
				   (oddp length))
		  :data (make-array (if (eql type :bytes)
					(ash (1+ length) -1)
					length)
				    :element-type '(unsigned-byte 16)
				    :initial-element (if (eql type :pointers)
							 +nil-oop+
							 0)))))


;;;
;;; Object data access.
;;;

(defmacro with-ote ((var oop) &body body)
  ;; FIXME: Should probably validate that oop isn't a SmallInteger.
  `(let ((,var (aref *object-table* (ash ,oop -1))))
     (unless (ote-p ,var) (panic "Accessing non-allocated object"))
     ,@body))

(defun obj-class (oop)
  (with-ote (ob oop)
    (ote-class ob)))

(defun obj-byte (oop index)
  (with-ote (ob oop)
    (ldb (byte 8 (ash (logand index 1) 3))
	 (aref (ote-data ob) (ash index -1)))))

(defun (setf obj-byte) (value oop index)
  (with-ote (ob oop)
    (setf (aref (ote-data ob) (ash index -1))
	  (dpb value
	       (byte 8 (ash (logand index 1) 3))
	       (aref (ote-data ob) (ash index -1)))))
  value)

(defun obj-word (oop index)
  (with-ote (ob oop)
    (aref (ote-data ob) index)))

(defun (setf obj-word) (value oop index)
  (with-ote (ob oop)
    (setf (aref (ote-data ob) index) value)))

;; These next two are hooks to support refcounting.

(defun obj-oop (oop index)
  (with-ote (ob oop)
    (aref (ote-data ob) index)))

(defun (setf obj-oop) (value oop index)
  (with-ote (ob oop)
    (setf (aref (ote-data ob) index) value)))


;;;
;;; Smalltalk<->Lisp object data conversion.
;;;

(defun box-integer (value)
  ;; FIXME: Only works on SmallIntegers, no error checking.
  (logior 1 (ash value 1)))

(defun intern-string (string)
  (let ((oop (allocate-oop)))
    (make-object oop :bytes (length string) +string-class-oop+)
    (dotimes (i (length string))
      (setf (obj-byte oop i) (char-code (aref string i))))
    oop))

(defun extern-string (oop)
  ;; FIXME: Assert oop class, representation.
  (with-ote (ob oop)
    (let* ((length (+ (ash (length (ote-data ob)) 1)
		      (if (ote-odd-length ob) -1 0)))
	   (string (make-array length :element-type 'character)))
      (dotimes (i length string)
	(setf (aref string i) (code-char (obj-byte oop i)))))))


;;; EOF
