-(defun make-hash-table (&rest cl-keys)
- "Make an empty Common Lisp-style hash-table.
-If :test is `eq', `eql', or `equal', this can use XEmacs built-in hash-tables.
-In Emacs 19, or with a different test, this internally uses a-lists.
-Keywords supported: :test :size
-The Common Lisp keywords :rehash-size and :rehash-threshold are ignored."
- (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql))
- (cl-size (or (car (cdr (memq ':size cl-keys))) 20)))
- ;; XEmacs change
- (if (and (memq cl-test '(eq eql equal)) (fboundp 'make-hashtable))
- (funcall 'make-hashtable cl-size cl-test)
- (list 'cl-hash-table-tag cl-test
- (if (> cl-size 1) (make-vector cl-size 0)
- (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym))
- 0))))
-
-(defvar cl-lucid-hash-tag
- (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1)))
- (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--")))
-
-(defun hash-table-p (x)
- "Return t if OBJECT is a hash table."
- (or (and (fboundp 'hashtablep) (funcall 'hashtablep x))
- (eq (car-safe x) 'cl-hash-table-tag)
- (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag))))
-
-(defun cl-not-hash-table (x &optional y &rest z)
- (signal 'wrong-type-argument (list 'hash-table-p (or y x))))
-
-(defun cl-hash-lookup (key table)
- (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table))
- (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym)
- (if (symbolp array) (setq str nil sym (symbol-value array))
- (while (or (consp str) (and (vectorp str) (> (length str) 0)))
- (setq str (elt str 0)))
- (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str))))
- ((symbolp str) (setq str (symbol-name str)))
- ((and (numberp str) (> str -8000000) (< str 8000000))
- (or (integerp str) (setq str (truncate str)))
- (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10"
- "11" "12" "13" "14" "15"] (logand str 15))))
- (t (setq str "*")))
- (setq sym (symbol-value (intern-soft str array))))
- (list (and sym (cond ((or (eq test 'eq)
- (and (eq test 'eql) (not (numberp key))))
- (assq key sym))
- ((memq test '(eql equal)) (assoc key sym))
- (t (assoc* key sym ':test test))))
- sym str)))
-
-(defvar cl-builtin-gethash
- (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash)))
- (symbol-function 'gethash) 'cl-not-hash-table))
-(defvar cl-builtin-remhash
- (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash)))
- (symbol-function 'remhash) 'cl-not-hash-table))
-(defvar cl-builtin-clrhash
- (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash)))
- (symbol-function 'clrhash) 'cl-not-hash-table))
-(defvar cl-builtin-maphash
- (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash)))
- (symbol-function 'maphash) 'cl-not-hash-table))
-
-(defun cl-gethash (key table &optional def)
- "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."
- (if (consp table)
- (let ((found (cl-hash-lookup key table)))
- (if (car found) (cdr (car found)) def))
- (funcall cl-builtin-gethash key table def)))
-(defalias 'gethash 'cl-gethash)
-
-(defun cl-puthash (key val table)
- (if (consp table)
- (let ((found (cl-hash-lookup key table)))
- (if (car found) (setcdr (car found) val)
- (if (nth 2 found)
- (progn
- (if (> (nth 3 table) (* (length (nth 2 table)) 3))
- (let ((new-table (make-vector (nth 3 table) 0)))
- (mapatoms (function
- (lambda (sym)
- (set (intern (symbol-name sym) new-table)
- (symbol-value sym))))
- (nth 2 table))
- (setcar (cdr (cdr table)) new-table)))
- (set (intern (nth 2 found) (nth 2 table))
- (cons (cons key val) (nth 1 found))))
- (set (nth 2 table) (cons (cons key val) (nth 1 found))))
- (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table)))))
- (funcall 'puthash key val table)) val)
-
-(defun cl-remhash (key table)
- "Remove KEY from HASH-TABLE."
- (if (consp table)
- (let ((found (cl-hash-lookup key table)))
- (and (car found)
- (let ((del (delq (car found) (nth 1 found))))
- (setcar (cdr (cdr (cdr table))) (1- (nth 3 table)))
- (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del)
- (set (nth 2 table) del)) t)))
- (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--))
- (funcall cl-builtin-remhash key table))))
-(defalias 'remhash 'cl-remhash)
-
-(defun cl-clrhash (table)
- "Clear HASH-TABLE."
- (if (consp table)
- (progn
- (or (hash-table-p table) (cl-not-hash-table table))
- (if (symbolp (nth 2 table)) (set (nth 2 table) nil)
- (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0)))
- (setcar (cdr (cdr (cdr table))) 0))
- (funcall cl-builtin-clrhash table))
- nil)
-(defalias 'clrhash 'cl-clrhash)
-
-(defun cl-maphash (cl-func cl-table)
- "Call FUNCTION on keys and values from HASH-TABLE."
- (or (hash-table-p cl-table) (cl-not-hash-table cl-table))
- (if (consp cl-table)
- (mapatoms (function (lambda (cl-x)
- (setq cl-x (symbol-value cl-x))
- (while cl-x
- (funcall cl-func (car (car cl-x))
- (cdr (car cl-x)))
- (setq cl-x (cdr cl-x)))))
- (if (symbolp (nth 2 cl-table))
- (vector (nth 2 cl-table)) (nth 2 cl-table)))
- (funcall cl-builtin-maphash cl-func cl-table)))
-(defalias 'maphash 'cl-maphash)
-
-(defun hash-table-count (table)
- "Return the number of entries in HASH-TABLE."
- (or (hash-table-p table) (cl-not-hash-table table))
- (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table)))
-
+;; The `regular' Common Lisp hash-table stuff has been moved into C.
+;; Only backward compatibility stuff remains here.
+(defun make-hashtable (size &optional test)
+ (make-hash-table :test test :size size))
+(defun make-weak-hashtable (size &optional test)
+ (make-hash-table :test test :size size :weakness t))
+(defun make-key-weak-hashtable (size &optional test)
+ (make-hash-table :test test :size size :weakness 'key))
+(defun make-value-weak-hashtable (size &optional test)
+ (make-hash-table :test test :size size :weakness 'value))
+
+(define-obsolete-function-alias 'hashtablep 'hash-table-p)
+(define-obsolete-function-alias 'hashtable-fullness 'hash-table-count)
+(define-obsolete-function-alias 'hashtable-test-function 'hash-table-test)
+(define-obsolete-function-alias 'hashtable-type 'hash-table-type)
+(define-obsolete-function-alias 'hashtable-size 'hash-table-size)
+(define-obsolete-function-alias 'copy-hashtable 'copy-hash-table)
+
+(make-obsolete 'make-hashtable 'make-hash-table)
+(make-obsolete 'make-weak-hashtable 'make-hash-table)
+(make-obsolete 'make-key-weak-hashtable 'make-hash-table)
+(make-obsolete 'make-value-weak-hashtable 'make-hash-table)
+(make-obsolete 'hash-table-type 'hash-table-weakness)
+
+(when (fboundp 'x-keysym-hash-table)
+ (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table))
+
+;; Compatibility stuff for old kludgy cl.el hash table implementation
+(defvar cl-builtin-gethash (symbol-function 'gethash))
+(defvar cl-builtin-remhash (symbol-function 'remhash))
+(defvar cl-builtin-clrhash (symbol-function 'clrhash))
+(defvar cl-builtin-maphash (symbol-function 'maphash))
+
+(defalias 'cl-gethash 'gethash)
+(defalias 'cl-puthash 'puthash)
+(defalias 'cl-remhash 'remhash)
+(defalias 'cl-clrhash 'clrhash)
+(defalias 'cl-maphash 'maphash)