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
  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 do not need to
  29 ;;; be tagged, as they can be used to index Javascript objects.
  30 (defvar *eq-hash-counter* 0)
  31 (defun eq-hash (x)
  32   (cond
  33     ((numberp x)
  34      x)
  35     (t
  36      (unless (in "$$jscl_id" x)
  37        (oset (format nil "$~d" *eq-hash-counter*) x "$$jscl_id")
  38        (incf *eq-hash-counter*))
  39      (oget x "$$jscl_id"))))
  40
  41 ;;; We do not have bignums, so eql is equivalent to eq.
  42 (defun eql-hash (x)
  43   (eq-hash x))
  44
  45
  46 ;;; In the case of equal-based hash tables, we do not store the hash
  47 ;;; in the objects, but compute a hash from the elements it contains.
  48 (defun equal-hash (x)
  49   (typecase x
  50     (cons
  51      (concat "(" (equal-hash (car x)) (equal-hash (cdr x)) ")"))
  52     (string
  53      (concat "s" (integer-to-string (length x)) ":" (lisp-to-js x)))
  54     (t
  55      (eql-hash x))))
  56
  57 (defun equalp-hash (x)
  58   ;; equalp is not implemented as predicate. So I am skipping this one
  59   ;; by now.
  60   )
  61
  62
  63 (defun make-hash-table (&key (test #'eql))
  64   (let* ((test-fn (fdefinition test))
  65          (hash-fn
  66           (cond
  67             ((eq test-fn #'eq)    #'eq-hash)
  68             ((eq test-fn #'eql)   #'eql-hash)
  69             ((eq test-fn #'equal) #'equal-hash)
  70             ((eq test-fn #'equalp) #'equalp-hash))))
  71     ;; TODO: Replace list with a storage-vector and tag
  72     ;; conveniently to implemnet `hash-table-p'.
  73     `(hash-table ,hash-fn ,(new))))
  74
  75 (defun gethash (key hash-table &optional default)
  76   (let ((obj (caddr hash-table))
  77         (hash (funcall (cadr hash-table) key)))
  78     (values (oget obj hash)
  79             (in hash obj))))
  80
  81 (defun sethash (new-value key hash-table)
  82   (let ((obj (caddr hash-table))
  83         (hash (funcall (cadr hash-table) key)))
  84     (oset new-value obj hash)
  85     new-value))
  86
  87
  88 ;;; TODO: Please, implement (DEFUN (SETF foo) ...) syntax!
  89 (define-setf-expander gethash (key hash-table &optional defaults)
  90   (let ((g!key (gensym))
  91         (g!hash-table (gensym))
  92         (g!defaults (gensym))
  93         (g!new-value (gensym)))
  94     (values (list g!key g!hash-table g!defaults)            ; temporary variables
  95             (list key hash-table defaults)                  ; value forms
  96             (list g!new-value)                              ; store variables
  97             `(progn
  98                (sethash ,g!new-value ,g!key ,g!hash-table)  ; storing form
  99                ,g!new-value)
 100             `(gethash ,g!new-value ,g!key ,g!hash-table)    ; accessing form
 101             )))