dc4f4180b194b9b25fc224c01eeef887e0c03b22
[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 ;;; Plain Javascript objects 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 objects require the
19 ;;; keys to be strings. To solve that, we map Lisp objects to strings
20 ;;; such that "equivalent" values map to the same string, regarding
21 ;;; the equality predicate used (one of `eq', `eql', `equal' and
22 ;;; `equalp').
23 ;;;
24
25 ;;; Additionally, we want to iterate across the hash table
26 ;;; key-values. So we use a cons (key  . value)
27 ;;; as value in the Javascript object. It implicitly gives the
28 ;;; inverse mapping of strings to our objects.
29
30 ;;; If a hash table has `eq' as test, we need to generate unique
31 ;;; strings for each Lisp object. To do this, we tag the objects with
32 ;;; a `$$jscl_id' property. As a special case, numbers do not need to
33 ;;; be tagged, as they can be used to index Javascript objects.
34 (defvar *eq-hash-counter* 0)
35 (defun eq-hash (x)
36   (cond
37     ((numberp x)
38      x)
39     (t
40      (unless (in "$$jscl_id" x)
41        (oset (format nil "$~d" *eq-hash-counter*) x "$$jscl_id")
42        (incf *eq-hash-counter*))
43      (oget x "$$jscl_id"))))
44
45 ;;; We do not have bignums, so eql is equivalent to eq.
46 (defun eql-hash (x)
47   (eq-hash x))
48
49
50 ;;; In the case of equal-based hash tables, we do not store the hash
51 ;;; in the objects, but compute a hash from the elements it contains.
52 (defun equal-hash (x)
53   (typecase x
54     (cons
55      (concat "(" (equal-hash (car x)) (equal-hash (cdr x)) ")"))
56     (string
57      (concat "s" (integer-to-string (length x)) ":" (lisp-to-js x)))
58     (t
59      (eql-hash x))))
60
61 (defun equalp-hash (x)
62   ;; equalp is not implemented as predicate. So I am skipping this one
63   ;; by now.
64   )
65
66
67 (defun make-hash-table (&key (test #'eql))
68   (let* ((test-fn (fdefinition test))
69          (hash-fn
70           (cond
71             ((eq test-fn #'eq)    #'eq-hash)
72             ((eq test-fn #'eql)   #'eql-hash)
73             ((eq test-fn #'equal) #'equal-hash)
74             ((eq test-fn #'equalp) #'equalp-hash))))
75     ;; TODO: Replace list with a storage-vector and tag
76     ;; conveniently to implemnet `hash-table-p'.
77     `(hash-table ,hash-fn ,(new))))
78
79 (defun gethash (key hash-table &optional default)
80   (let* ((obj (caddr hash-table))
81          (hash (funcall (cadr hash-table) key))
82          (exists (in hash obj)))
83     (if exists
84         (values (cdr (oget obj hash)) t)
85         (values default nil))))
86
87 (defun sethash (new-value key hash-table)
88   (let ((obj (caddr hash-table))
89         (hash (funcall (cadr hash-table) key)))
90     (oset (cons key new-value) obj hash)
91     new-value))
92
93
94 ;;; TODO: Please, implement (DEFUN (SETF foo) ...) syntax!
95 (define-setf-expander gethash (key hash-table &optional defaults)
96   (let ((g!key (gensym))
97         (g!hash-table (gensym))
98         (g!defaults (gensym))
99         (g!new-value (gensym)))
100     (values (list g!key g!hash-table g!defaults)            ; temporary variables
101             (list key hash-table defaults)                  ; value forms
102             (list g!new-value)                              ; store variables
103             `(progn
104                (sethash ,g!new-value ,g!key ,g!hash-table)  ; storing form
105                ,g!new-value)              
106             `(gethash ,g!new-value ,g!key ,g!hash-table)    ; accessing form
107             )))
108
109
110 (defun remhash (key hash-table)
111   (let ((obj (caddr hash-table))
112         (hash (funcall (cadr hash-table) key)))
113     (prog1 (in hash obj)
114       (delete-property hash obj))))
115
116
117 (defun hash-table-count (hash-table)
118   (let ((count 0))
119     (map-for-in (lambda (x)
120                   (declare (ignore x))
121                   (incf count))
122                 (caddr hash-table))
123     count))
124
125
126 (defun maphash (function hash-table)
127   (map-for-in (lambda (x)
128                 (funcall function (car x) (cdr x)))
129               (caddr hash-table))
130   nil)