;;;
;;; dictionaries.lisp
;;;
;;; Image dictionary access.
;;;

(cl:in-package :speakeasy)

;;;
;;; IdentityDictionary (method dictionary) access.
;;;

;; An IdentityDictionary is supposed to be a subclass of Set.  It has
;; two fixed fields (a count of the number of methods and an Array of
;; the actual methods) and stores the method selectors in its indexed
;; fields.  This is probably one of the "implementation convenience"
;; nastinesses in the Smalltalk-80 class hierarchy, as I can't see how
;; Set would work given the way the method selectors are arranged
;; within the indexed fields.

;; Complexities here include resizing the dictionary when it gets too
;; full, and a good notion of what "too full" is.

(defun create-method-dictionary (&key (size 16))
  (let ((method-array (allocate-oop))
	(dictionary (allocate-oop)))
    (make-object method-array :pointers size +array-class-oop+)
    (make-object dictionary :pointers (+ size 2) +identity-dictionary-class-oop+)
    (setf (obj-oop dictionary 0) (box-integer 0))
    (setf (obj-oop dictionary 1) method-array)
    dictionary))

;; There's supposed to be some sort of hashing logic based on the
;; message selector OOP for finding the method.  In the interests of
;; getting this working, we'll go with a linear scan for now.

;; XXX: Would these be better as a dictionary-method accessor?

(defun lookup-method-in-dictionary (dictionary selector)
  (with-ote (dict dictionary)
    (let* ((data (ote-data dict))
	   (length (- (length data) 2)))
      (loop for i below length
	    when (= (aref data (+ i 2)) selector)
	    return (obj-oop (aref data 1) i)))))

(defun add-method-to-dictionary (dictionary selector method)
  (with-ote (dict dictionary)
    (let* ((data (ote-data dict))
	   (length (- (length data) 2)))
      (loop for i below length
	    when (= (aref data (+ i 2)) selector)
	    do (setf (obj-oop (aref data 1) i) method)
	       (return)
	    finally
	    ;; FIXME: Check for incipient dictionary overflow.
	    ;;(when )
	    (loop for i below length
		  when (= (aref data (+ i 2)) +nil-oop+)
		  do (setf (obj-oop (aref data 1) i) method)
		     (setf (aref data (+ i 2)) selector)
		     (return)))))
  method)

(defun remove-method-from-dictionary (dictionary selector)
  ;; More for completeness sake than anything else.
  (with-ote (dict dictionary)
    (let* ((data (ote-data dict))
	   (length (- (length data) 2)))
      (loop for i below length
	    when (= (aref data (+ i 2)) selector)
	    do (setf (obj-oop (aref data 1) i) +nil-oop+)
	       (setf (aref data (+ i 2)) +nil-oop+)))))

;;;
;;; Dictionary (system dictionary (Smalltalk) and pool variable) access.
;;;

(defun association-key (oop)
  (obj-oop oop 0))

(defun (setf association-key) (value oop)
  (setf (obj-oop oop 0) value))

(defun association-value (oop)
  (obj-oop oop 1))

(defun (setf association-value) (value oop)
  (setf (obj-oop oop 1) value))

(defun make-association (key value)
  (let ((association (allocate-oop)))
    (make-object association :pointers 2 +association-class-oop+)
    (setf (association-key association) key)
    (setf (association-value association) value)
    association))

;; The accessors for a Dictionary are similar to those for an
;; IdentityDictionary, only the key/value pairs are stored in an
;; Association instead of split over the dictionary and an Array of
;; values.  Similar auto-resizing and hashing rules apply (including
;; the bit about not implementing the hashing yet).

(defun create-dictionary ()
  (let ((dictionary (allocate-oop)))
    (make-object dictionary :pointers 16 +dictionary-class-oop+)
    dictionary))

(defun dictionary-association-at (dictionary key)
  (with-ote (ob dictionary)
    (let ((data (ote-data ob)))
      (loop for entry across data
	    when (and (not (= entry +nil-oop+))
		      (= (association-key entry) key))
	    return entry))))

(defun dictionary-at (dictionary key)
  (association-value (dictionary-association-at dictionary key)))

(defun dictionary-add-association (dictionary association)
  ;; We are adding a new Association.  It has already been built, and
  ;; is not a duplicate of an existing entry.
  (with-ote (ob dictionary)
    (let ((data (ote-data ob)))
      (loop for entry across data
	    for index from 0
	    when (= entry +nil-oop+)
	    return (setf (aref data index) association)
	    finally
	    ;; Grow the Dictionary.  Theoretically, we should rehash here.
	    (let ((new-data (make-array (* 2 (length data))
					:element-type '(unsigned-byte 16)
					:initial-element +nil-oop+)))
	      (setf (ote-data ob) new-data)
	      (setf (subseq new-data 0) data)
	      (setf (aref new-data (length data)) association))))))

(defun dictionary-at-put (dictionary key value)
  (let ((entry (dictionary-association-at dictionary key)))
    (if entry
	(setf (association-key entry) value)
	(dictionary-add-association dictionary (make-association key value)))))

;;; EOF
