remhash tests
[jscl.git] / src / hash-table.lisp
1 ;;; hash-table.lisp ---
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16 ;;; Javascript dictionaries are the natural way to implement Common
17 ;;; Lisp hash tables. However, there is a big differences betweent
18 ;;; them which we need to work around. Javascript dictionaries require
19 ;;; the keys to be strings. To solve that, we map Lisp objects to
20 ;;; strings such that "equivalent" values map to the same string,
21 ;;; regarding the equality predicate used (one of `eq', `eql', `equal'
22 ;;; and `equalp').
23 ;;;
24
25
26 ;;; If a hash table has `eq' as test, we need to generate unique
27 ;;; strings for each Lisp object. To do this, we tag the objects with
28 ;;; a `$$jscl_id' property. As a special case, numbers are not
29 ;;; objects, but they can be used for indexin a Javascript dictionary,
30 ;;; we do not need to tag them.
31 (defvar *eq-hash-counter* 0)
32 (defun eq-hash (x)
33   (cond
34     ((numberp x)
35      x)
36     (t
37      (unless (in "$$jscl_id" x)
38        (oset (format nil "$~d" *eq-hash-counter*) x "$$jscl_id")
39        (incf *eq-hash-counter*))
40      (oget x "$$jscl_id"))))
41
42 ;;; We do not have bignums, so eql is equivalent to eq.
43 (defun eql-hash (x)
44   (eq-hash x))
45
46
47 ;;; In the case of equal-based hash tables, we do not store the hash
48 ;;; in the objects, but compute a hash from the elements it contains.
49 (defun equal-hash (x)
50   (typecase x
51     (cons
52      (concat "(" (equal-hash (car x)) (equal-hash (cdr x)) ")"))
53     (string
54      (concat "s" (integer-to-string (length x)) ":" (lisp-to-js x)))
55     (t
56      (eql-hash x))))
57
58 (defun equalp-hash (x)
59   ;; equalp is not implemented as predicate. So I am skipping this one
60   ;; by now.
61   )
62
63
64 (defun make-hash-table (&key (test #'eql))
65   (let* ((test-fn (fdefinition test))
66          (hash-fn
67           (cond
68             ((eq test-fn #'eq)    #'eq-hash)
69             ((eq test-fn #'eql)   #'eql-hash)
70             ((eq test-fn #'equal) #'equal-hash)
71             ((eq test-fn #'equalp) #'equalp-hash))))
72     ;; TODO: Replace list with a storage-vector and tag
73     ;; conveniently to implemnet `hash-table-p'.
74     `(hash-table ,hash-fn ,(new))))
75
76 (defun gethash (key hash-table &optional default)
77   (let ((obj (caddr hash-table))
78         (hash (funcall (cadr hash-table) key)))
79     (values (oget obj hash)
80             (in hash obj))))
81
82 (defun sethash (new-value key hash-table)
83   (let ((obj (caddr hash-table))
84         (hash (funcall (cadr hash-table) key)))
85     (oset new-value obj hash)
86     new-value))
87
88
89 ;;; TODO: Please, implement (DEFUN (SETF foo) ...) syntax!
90 (define-setf-expander gethash (key hash-table &optional defaults)
91   (let ((g!key (gensym))
92         (g!hash-table (gensym))
93         (g!defaults (gensym))
94         (g!new-value (gensym)))
95     (values (list g!key g!hash-table g!defaults)            ; temporary variables
96             (list key hash-table defaults)                  ; value forms
97             (list g!new-value)                              ; store variables
98             `(progn
99                (sethash ,g!new-value ,g!key ,g!hash-table)  ; storing form
100                ,g!new-value)              
101             `(gethash ,g!new-value ,g!key ,g!hash-table)    ; accessing form
102             )))
103
104
105 (defun remhash (key hash-table)
106   (let ((obj (caddr hash-table))
107         (hash (funcall (cadr hash-table) key)))
108     (prog1 (in hash obj)
109       (delete-property hash obj))))