;;;;	-------------------------------
;;;;	Copyright (c) 2000 Roger Corman
;;;;	All rights reserved.
;;;;	-------------------------------
;;;;
;;;;	File:		hash-table.lisp
;;;;	Contents:	Hash-table related functions.
;;;;	History:	11/6/96  RGC  Created.
;;;;				2/17/00  RGC  Implemented WITH-HASH-TABLE-ITERATOR.
;;;;

(defconstant default-initial-hash-table-size 100)

;; all hash-table sizes must be prime integers
(defvar *hash-table-sizes* '(211 307 401 503 613 701 809 907 1009 1201 1301 1511 2003 3001	4001 5003 
					6007 7001 8009 9001 10007
					11003 12007 13001 14009 15013 16001 17011 18013 19001 20011 25013
					30011 35023 40009 50021 60013 70001 80021 90001 100003 150001))

(defconstant hash-table-test-types '(eq eql equal equalp))

(defun calc-hash-table-size (requested-size)
	(dolist (x *hash-table-sizes*)
		(if (>= x requested-size)
			(return-from calc-hash-table-size x)))
	nil)

;; dummy definition to avoid compiler warning, redefine below
(defun hash-table-grow (hash-table resize-amount) 
	(declare (ignore resize-amount))
	hash-table)

(defun rehash-hash-table (hash-table)
	;(format t "Rehashing hash-table~%")
	(hash-table-grow hash-table 0)
	(setf (uref hash-table 2) nil))

;; need to override warning here for HASH-TABLE-COUNT,
;; HASH_TABLE-SIZE not defined yet
(setq *COMPILER-WARN-ON-UNDEFINED-FUNCTION* nil)
(defun print-hash-table (hash-table stream level)
	(declare (ignore level))
	(format stream "#<HASHTABLE ~A/~A>" 
		(hash-table-count hash-table)
		(hash-table-size hash-table)))
(setq *COMPILER-WARN-ON-UNDEFINED-FUNCTION* t)

(defstruct (hash-table 
			(:constructor make-skeleton-hash-table)
			(:print-function print-hash-table))
	(rehash-needed nil)		;; must be first field for garbage collector to mark it
	(size (calc-hash-table-size default-initial-hash-table-size))
	(count 0)
	(rehash-size 2.0)
	(rehash-threshold 0.5)
	(table nil)
	(hash-function 'hash-eql-function)
	(test 'eql)
	(test-function 'eql)
	(sync nil))

;;;;
;;;;	Common Lisp MAKE-HASH-TABLE function
;;;;
(defun make-hash-table (&key (test 'eql) 
							 (size default-initial-hash-table-size) 
							 (rehash-size 2.0)	;; double in size when growing
							 (rehash-threshold 0.5) ;; grow when half full
							 (synchronized nil))
	(cond
		((eq test #'eql) (setq test 'eql))
		((eq test #'eq)  (setq test 'eq))
		((eq test #'equal) (setq test 'equal))
		((eq test #'equalp) (setq test 'equalp)))
	(unless (member test hash-table-test-types)
		(error "Invalid test type for hash-table: ~A" test))
	(let ((hash-func nil))
		(cond 
			((eq test 'eq) (setq hash-func 'hash-eq-function))
			((eq test 'eql) (setq hash-func 'hash-eql-function))
			((eq test 'equal) (setq hash-func 'hash-equal-function))
			((eq test 'equalp) (setq hash-func 'hash-equalp-function)))

		(let* ((ht-size (calc-hash-table-size size))
			   (hash-table (make-skeleton-hash-table 
							:size ht-size
							:rehash-size rehash-size
							:rehash-threshold rehash-threshold
							:table (make-array ht-size :initial-element nil)
							:hash-function hash-func
							:test test
							:test-function test
							:sync (if synchronized (cl::allocate-critical-section)))))
			hash-table)))

(defun hash-table-entry-list (hash-table index)
	(let ((table (hash-table-table hash-table)))
		(elt table index)))

(defun hash-table-entry-list-push (hash-table index key value)
	(let ((table (hash-table-table hash-table)))
		(setf (elt table index) (cons key (cons value (elt table index))))))

(defun hash-table-entry-occupied (hash-table index)
	(not (null (hash-table-entry-list hash-table index))))

(defun delete-key-value (list key test)
	(if (null list)
		list
		(if (funcall test key (car list))
			(cddr list)
			(do* ((x list (cddr x))
				  (y (cddr list) (cddr y)))
				((null y) list)
				(if (funcall test key (car y))
					(rplacd (cdr x) (cddr y)))))))	

;;;;
;;;;	HASH-TABLE-KEY-INDEX
;;;;	Returns the index of the passed key.
;;;;
(defun hash-table-key-index (hash-table key)
 	(let* ((table-size (hash-table-size hash-table)))
		(mod (funcall (hash-table-hash-function hash-table) key) table-size)))

;;;;
;;;;	HASH-TABLE-ADD-ENTRY
;;;;	Adds a new entry and returns the added value.
;;;;
(defun hash-table-add-entry (hash-table key value)
	(let* ((table-size (hash-table-size hash-table))
		   (count (hash-table-count hash-table))
		   (test-func (hash-table-test-function hash-table))
		   index
		   list)

		;; grow if necessary
		(if (> count (/ table-size 2))
			(let ((resize-amount (hash-table-rehash-size hash-table)))
				(if (floatp resize-amount)
					(setq resize-amount (truncate (* resize-amount table-size))))
				(hash-table-grow hash-table resize-amount)		
				(setq table-size (hash-table-size hash-table))
				(setq count (hash-table-count hash-table))))

		(setq index (hash-table-key-index hash-table key))
		(setq list (hash-table-entry-list hash-table index))

		(do* ()
			((null list))
			(if (funcall test-func key (car list))
				(return))
			(setq list (cddr list)))

		(if (null list)
			(progn
				(incf (hash-table-count hash-table))
				(hash-table-entry-list-push hash-table index key value))
			(setf (car (cdr list)) value)) 
		value))

(defmacro declare-synchronized-function (sync-object name lambda-list . body)
	(let ((temp-var (gensym))
		  (decls '()))
		;; gather any DECLARE forms
		(do ((f body (cdr f)))
			((or (null f) (not (consp (car f))) (not (eq (caar f) 'declare)))
			 (setf body f))
			(push (car f) decls))

		`(defun ,name ,lambda-list
			,@(nreverse decls)
			(let ((,temp-var ,sync-object))
				(if ,temp-var
					(with-synchronization ,temp-var ,@body)
					(progn ,@body))))))
					
;;;;
;;;;	Common Lisp GETHASH function
;;;;
(declare-synchronized-function (hash-table-sync hash-table)
	GETHASH (key hash-table &optional default)
		(if (hash-table-rehash-needed hash-table)
			(rehash-hash-table hash-table))
		(let* ((index (hash-table-key-index hash-table key))
			   (entry-list (hash-table-entry-list hash-table index)))
			(do* ((list entry-list (cddr list))
				  (test-func (hash-table-test-function hash-table)))
				((null list) (values default nil))
				(if (funcall test-func key (car list))
					(return (values (cadr list) t))))))

;;;;
;;;;	Common Lisp (SETF GETHASH) function
;;;;
(declare-synchronized-function (hash-table-sync hash-table)
	(SETF GETHASH) (value key hash-table &optional default)
		(declare (ignore default))
		(if (hash-table-rehash-needed hash-table)
			(rehash-hash-table hash-table))
		(prog1
			(hash-table-add-entry hash-table key value)
			(if (hash-table-rehash-needed hash-table)
				(rehash-hash-table hash-table))))


;;;;
;;;;	Common Lisp REMHASH function
;;;;
(declare-synchronized-function (hash-table-sync hash-table)
	REMHASH (key hash-table)
		(if (hash-table-rehash-needed hash-table)
			(rehash-hash-table hash-table))
		(let* ((index (hash-table-key-index hash-table key))
			   (list (hash-table-entry-list	hash-table index)))
			(do* ((test-func (hash-table-test-function hash-table)))
				((null list) nil)
				(if (funcall test-func key (car list))
					(progn
						(setf (elt (hash-table-table hash-table) index)
							(delete-key-value list key test-func))
						(return t)))
				(setq list (cddr list)))))

;;;;
;;;;	Common Lisp MAPHASH function
;;;;
(declare-synchronized-function (hash-table-sync hash-table)
	MAPHASH (function hash-table)
		(if (hash-table-rehash-needed hash-table)
			(rehash-hash-table hash-table))
		(let ((size (hash-table-size hash-table)))
			(dotimes (i size)
				(do* ((list (hash-table-entry-list	hash-table i) (cddr list)))
					((null list))
					(funcall function (car list) (cadr list))))))
		
;;;;
;;;;	Common Lisp WITH-HASH-TABLE-ITERATOR macro
;;;;
(defmacro with-hash-table-iterator ((name hash-table) &rest forms)
	(let ((ht-sym (gensym))
		  (index-sym (gensym))
		  (ht-size-sym (gensym))
		  (ht-list-sym (gensym))
		  (ret-sym (gensym))
		  (ret-val (gensym))
		  (func-name (gensym)))
		`(let* ((,ht-sym ,hash-table)
			    (,index-sym 0)
			    (,ht-size-sym (hash-table-size ,ht-sym))
			    (,ht-list-sym nil)
			    (,ret-sym nil)
			    (,ret-val nil))
			(flet 
				((,func-name ()
						(do ()
							((or ,ht-list-sym (= ,index-sym ,ht-size-sym)))
							(setf ,ht-list-sym (hash-table-entry-list ,ht-sym ,index-sym))
							(incf ,index-sym))
						(when (and (null ,ht-list-sym)(= ,index-sym ,ht-size-sym))
							(return nil))
						(setf ,ret-sym (car ,ht-list-sym) ,ret-val (cadr ,ht-list-sym))
						(setf ,ht-list-sym (cddr ,ht-list-sym))
						(return (values t ,ret-sym ,ret-val))))
				(macrolet ((,name () '(,func-name)))
					,@forms)))))

;;;;
;;;;	Common Lisp CLRHASH function
;;;;
(declare-synchronized-function (hash-table-sync hash-table)
	CLRHASH (hash-table)
		(let ((table (hash-table-table hash-table))
		      (count (hash-table-size hash-table)))
			(dotimes (i count)
				(setf (elt table i) nil))))

;;;;
;;;;	Common Lisp SXHASH function
;;;;
(defun sxhash (object) (hash-equalp-function object))

;; double the package capacity
(defun hash-table-grow (hash-table resize-amount)
	(let* ((current-table (hash-table-table hash-table))
	       (current-size (hash-table-size hash-table))
		   (new-size (calc-hash-table-size (+ current-size resize-amount))))
		(unless new-size (error "Could not grow the hash-table: ~A" hash-table))
		(setf (hash-table-table hash-table) 
				(make-array new-size :initial-element nil))
		(setf (hash-table-size hash-table) new-size)
		(setf (hash-table-count hash-table) 0)

		(dotimes (i current-size)
			(do* ((list (elt current-table i) (cddr list)))
				((null list))
				(hash-table-add-entry hash-table (car list) (cadr list)))))
	hash-table)

(defun hash-obj-id (obj)
	(hash-eq-function obj))

(defun hash-list (obj)
	(let ((hash-val 0))
		(dolist (x obj)
			(setq hash-val (logxor (hash-equal-function x) hash-val)))
		hash-val))

(defun hash-uvector (obj)
	(let ((len (uvector-num-slots obj))
		  (hash-val 0))
		(dotimes (i len)
			(setq hash-val 
				(logxor (hash-obj-id (uref obj i)) hash-val)))
		hash-val))

(defun hash-eql-function (obj)
	(cond 
		((double-float-p obj)(hash-uvector obj))
		((single-float-p obj)(hash-uvector obj))
		((bignump obj) (hash-uvector obj))
		((ratiop obj) (hash-uvector obj))
		((complexp obj)(hash-uvector obj))
		(t (hash-obj-id obj))))

(defun hash-equal-function (obj)
	(cond 
		((consp obj)(hash-list obj))
		((stringp obj) (hash-uvector obj))
		((bit-vector-p obj) (hash-uvector obj))
		((pathnamep obj)(hash-uvector obj))
		(t (hash-eql-function obj))))


(pl::defasm hash-obj-id (x)
	{
		push	ebp
		mov		ebp, esp
		mov		eax, [ebp + ARGS_OFFSET]
		mov		edx, eax
		rol		eax, 9
		xor		edx, eax
		rol		eax, 9
		xor		edx, eax
		rol		eax, 9
		xor		edx, eax
		mov		eax, edx
		and		al,	 #xf8
		pop		ebp
		ret
	})

(pl::defasm hash-list (obj)
	{
		push	ebp
		mov		ebp, esp
		push	0				;; local var at [ebp - 4]
	:loop
		mov		eax, [ebp + ARGS_OFFSET]	;; eax = obj
		mov		edx, eax
		and		edx, 7
		cmp		edx, cons-tag
		jne		:end-loop
		mov		edx, [eax]
		mov		[ebp + ARGS_OFFSET], edx ;; obj = (cdr obj)
		mov		eax, [eax - cons-tag]	 ;; eax = (car eax)
		push	eax
		callf	cl::hash-equal-function
		add		esp, 4
		xor		eax, [ebp - 4]
		mov		[ebp - 4], eax
		jmp 	:loop
	:end-loop
		mov		ecx, 1
		pop		eax
		pop		ebp
		ret
	})

(pl::defasm fixnum-mod (x y)
	{
		push	ebp
		mov		ebp, esp
		mov		eax, [ebp + (+ ARGS_OFFSET 4)]	;; eax = arg1
		mov		ecx, [ebp + ARGS_OFFSET]		;; ecx = arg2
		xor		edx, edx
		idiv	ecx					;; edx contains mod
		mov		eax, edx
		mov		ecx, 1
		pop		ebp
		ret
	})

(defun hash-table-key-index (hash-table key)
 	(let* ((table-size (hash-table-size hash-table)))
		(fixnum-mod (funcall (hash-table-hash-function hash-table) key) table-size)))

;;;
;;; do some SETF patching now that we have hash-tables
;;;
(setf *setf-registry* (make-hash-table))

;; dump all the setf functions loaded so far into the hash-table
(do ((x (symbol-plist '*setf-registry*)(cddr x)))
	((null x))
	(setf (gethash (car x) *setf-registry*) (cadr x)))

;; redefine these to use the hash table
(defun register-setf-function (name setf-func-name)
	(setf (gethash name *setf-registry*) setf-func-name))

(defun get-setf-function (name)
	(gethash name *setf-registry*))

;; now clear the property list
(setf (symbol-plist '*setf-registry*) nil)

;;; done SETF patching

;;;
;;; do some DOCUMENTATION patching now that we have hash-tables
;;;
(setf *documentation-registry* (make-hash-table))

;; dump all the documentation entries loaded so far into the hash-table
(do ((x (symbol-plist '*documentation-registry*)(cddr x)))
	((null x))
	(setf (gethash (car x) *documentation-registry*) (cadr x)))

;; redefine these to use the hash table
(defun documentation (symbol doc-type)
	(getf (gethash symbol *documentation-registry*) doc-type))

(defun |(SETF DOCUMENTATION)| (doc-string symbol doc-type)
	(setf (getf (gethash symbol *documentation-registry*) doc-type) doc-string)
	doc-string)

;; now clear the property list
(setf (symbol-plist '*documentation-registry*) nil)

;;; done DOCUMENTATION patching