;;; -*-Mode: common-Lisp; Package: SI; Base: 8-*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1984-1989 Texas Instruments Incorporated.  All rights reserved.

;;; hash table  mixin flavors.

;;; The actual hash table is a hash table called the hash-array.
;;; The flavor instance serves only to point to that.
;;; Hash tables are defined in the file HASH.


(defflavor hash-table-mixin (hash-array) ()
           :gettable-instance-variables
	   :inittable-instance-variables
           (:init-keywords :size :area :rehash-function :rehash-size :growth-factor
            :number-of-values :actual-size :rehash-threshold :funcallable-p
            :hash-function :compare-function :test)
           (:default-init-plist :hash-function nil :compare-function 'eq)) 


(defflavor eq-hash-table-mixin () (hash-table-mixin) :alias-flavor) 

(defflavor eq-hash-table () (hash-table-mixin) :alias-flavor)

(defflavor equal-hash-table-mixin () (hash-table-mixin)
           (:default-init-plist :hash-function 'equal-hash :compare-function 'equal)) 


(defmethod (hash-table-mixin :before :init) (plist)
  (unless (variable-boundp hash-array)
    (setq hash-array (apply 'make-hash-array :allow-other-keys t :instance self (cdr plist))))
  (setf (hash-table-instance hash-array) self))


(defmethod (hash-table-mixin :fasd-form) ()
  (let ((array
         (make-array (array-total-size hash-array) ':type art-q-list ':leader-length
                     (array-leader-length hash-array) ':displaced-to hash-array)))
    (%blt-typed (%find-structure-leader hash-array) (%find-structure-leader array)
                (1+ (array-leader-length array)) 1)
    ;; Get rid of circularity.
    (setf (hash-table-instance array) ())
    (make-array-into-named-structure array 'hash-table)
    `(make-instance ',(type-of self) ':hash-array ',array))) 


(defmethod (hash-table-mixin :size) ()
  (hash-table-modulus hash-array)) 


(defmethod (hash-table-mixin :filled-entries) ()
  (hash-table-fullness hash-array)) 


(defmethod (hash-table-mixin :clear-hash) (&optional ignore)
  "Clear out a hash table; leave it with no entries."
  (clrhash hash-array)
  ) 


  


(defmethod (hash-table-mixin :get-hash) (key &optional default-value )
  (declare (values value key-found-flag entry-pointer))
  (gethash key hash-array default-value))



(defmethod (hash-table-mixin :case :set :get-hash) (key &rest values)
  (declare (arglist (key value)))
  ;; use last is to ignore optional default eg from "(push zap (send foo :get-hash bar))"
  (lexpr-send self ':put-hash key (last values)))


(defmethod (hash-table-mixin :put-hash) (key value &rest additional-values)
  (apply 'puthash key value hash-array  additional-values))


(defmethod (hash-table-mixin :rem-hash) (key )
  (remhash key hash-array))

(defmethod (hash-table-mixin :modify-hash) (key function &rest additional-args)
  (apply 'modifyhash key hash-array function additional-args))


(defmethod (hash-table-mixin :swap-hash) (key value &rest additional-values)
  (apply 'swaphash key value hash-array  additional-values))


(defmethod (hash-table-mixin :map-hash) (function &rest extra-args )
  (apply 'maphash function hash-array extra-args))


(defmethod (hash-table-mixin :map-hash-return) (function &optional (return-function 'list))
  (maphash-return function hash-array return-function))

(defmethod (hash-table-mixin :describe) ()
  (format t "~&~S is a hash-table with ~D entries out of a possible ~D (~D%).~%" self
	  (hash-table-fullness hash-array) (hash-table-modulus hash-array)
	  (truncate (* (hash-table-fullness hash-array) 144) (hash-table-modulus hash-array)))
  (if (and (hash-table-lock hash-array) (car (hash-table-lock hash-array)))
    (format t "Locked by ~s~%" (hash-table-lock hash-array)))
  (if (hash-table-funcallable-p hash-array)
    (format t "FUNCALLing it hashes on the first argument to get a function to call.~%"))
  (format t "There are ~D formerly used entries now deleted~%"
	  (hash-table-number-of-deleted-entries hash-array))
  (if (floatp (hash-table-rehash-threshold hash-array))
    (format t "Rehash if table gets more than ~S full~%"
	    (hash-table-rehash-threshold hash-array)))
  (if (/= 1
       (- (hash-table-block-length hash-array) 1 (if (hash-table-hash-function hash-array)
						   1
						   0)))
    (format t "Each key has ~D values associated.~%"
	    (- (hash-table-block-length hash-array) 1
	       (if (hash-table-hash-function hash-array)
		 1
		 0))))
  (or (= (hash-table-gc-generation-number hash-array) %gc-generation-number)
     (format t " rehash is required due to GC.~%"))
  (format t " The rehash function is ~S with increase parameter ~D.~%"
	  (hash-table-rehash-function hash-array) (hash-table-rehash-size hash-array))
  (and (not (zerop (hash-table-fullness hash-array)))
     (y-or-n-p "Do you want to see the contents of the hash table? ")
     (if (not (y-or-n-p "Do you want it sorted? "))
       (send self :map-hash #'(lambda (key &rest values)
				(format t "~& ~S -> ~S~%" key values)))
       (let ((*l* nil))
	 (declare (special *l*))
	 (send self :map-hash
	    #'(lambda (key &rest values)
		(push (list key (copy-list values)) *l*)))
	 (setq *l* (sort *l* #'alphalessp :key #'car))
	 (format t "~&~:{ ~S -> ~S~%~}" *l*)))))