;; -*- Lisp -*-
#+LISPWORKS
(progn
(defun gc () (mark-and-sweep 3))
t)
#+LISPWORKS
T
(defun weak-ht-fill-initially (tab)
(setf (gethash (copy-seq "foo") tab) 1)
(setf (gethash 1 tab) (copy-seq "bar"))
(setf (gethash (copy-seq "zoo") tab) (copy-seq "zot")))
weak-ht-fill-initially
;; Test that weak hash-tables of kind :KEY work.
(let ((tab (make-hash-table :test #+OpenMCL 'eq #-OpenMCL 'equal
#+ALLEGRO :weak-keys #+ALLEGRO t
#+CMU19 :weak-p #+CMU19 t
#+LISPWORKS :weak-kind #-(or ALLEGRO CMU19 LISPWORKS) :weak
#-(or ALLEGRO CMU19) :key)))
(weak-ht-fill-initially tab)
(gc)
(list (gethash "foo" tab) (gethash 1 tab) (gethash "zoo" tab)))
(NIL "bar" NIL)
;; Test that weak hash-tables of kind :KEY don't suffer from the
;; "key in value" problem.
(let ((tab (make-hash-table :test 'eq
#+ALLEGRO :weak-keys #+ALLEGRO t
#+CMU19 :weak-p #+CMU19 t
#+LISPWORKS :weak-kind #-(or ALLEGRO CMU19 LISPWORKS) :weak
#-(or ALLEGRO CMU19) :key)))
(let ((a (list 'x)))
(let ((b (list 'y)))
(setf (gethash a tab) 'xxx)
(setf (gethash b tab) (cons 'yyy b)))
(gc)
(list (hash-table-count tab)
(gethash a tab)
(let ((l nil)) (maphash #'(lambda (k v) (push k l)) tab) l))))
(1 XXX ((X)))
;; Perform all the WEAK-MAPPING tests, emulating WEAK-MAPPING with
;; weak hash-tables.
(progn
(defun make-freak-mapping (a b)
(let ((tab (make-hash-table :test 'eq
#+ALLEGRO :weak-keys #+ALLEGRO t
#+CMU19 :weak-p #+CMU19 t
#+LISPWORKS :weak-kind #-(or ALLEGRO CMU19 LISPWORKS) :weak
#-(or ALLEGRO CMU19) :key)))
(setf (gethash a tab) b)
tab))
(defun freak-mapping-pair (tab)
(let (a b c)
(maphash #'(lambda (k v) (setq a k b v c t)) tab)
(values a b c)))
(defun freak-mapping-value (tab)
(block nil
(maphash #'(lambda (k v) (return-from nil v)) tab)
nil))
(defun (setf freak-mapping-value) (new-value tab)
(block nil
(maphash #'(lambda (k v) (setf (gethash k tab) new-value) (return-from nil))
tab))
new-value)
t)
T
(let ((a (list 'x))
(b (list 'y)))
(let ((w (make-freak-mapping a b)))
(gc)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
(((x) (y) t) ((y)))
(let ((a (list 'x))
(b (list 'y)))
(let ((w (make-freak-mapping a b)))
(setq b nil)
(gc)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
(((x) (y) t) ((y)))
(let ((a (list 'x))
(b (list 'y)))
(let ((w (make-freak-mapping a b)))
(setq a nil)
(gc)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
((nil nil nil) (nil))
(let ((a (list 'x))
(b (list 'y)))
(let ((w (make-freak-mapping a b)))
(setq a nil b nil)
(gc)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
((nil nil nil) (nil))
(let ((a1 (list 'x1))
(a2 (list 'x2))
(a3 (list 'x3))
(a4 (list 'x4))
(a5 (list 'x5)))
(let ((w1 (make-freak-mapping a3 a4))
(w2 (make-freak-mapping a1 a2))
(w3 (make-freak-mapping a4 a5))
(w4 (make-freak-mapping a2 a3)))
(setq a2 nil a3 nil a4 nil a5 nil)
(gc)
(list (freak-mapping-value w2)
(freak-mapping-value w4)
(freak-mapping-value w1)
(freak-mapping-value w3))))
((x2) (x3) (x4) (x5))
(let ((a1 (list 'x1))
(a2 (list 'x2))
(a3 (list 'x3))
(a4 (list 'x4))
(a5 (list 'x5)))
(let ((w1 (make-freak-mapping a3 a4))
(w2 (make-freak-mapping a1 a2))
(w3 (make-freak-mapping a4 a5))
(w4 (make-freak-mapping a2 a3)))
(setq a1 nil a3 nil a4 nil a5 nil)
(gc)
(list (freak-mapping-value w2)
(freak-mapping-value w4)
(freak-mapping-value w1)
(freak-mapping-value w3))))
(nil (x3) (x4) (x5))
(let ((a1 (list 'x1))
(a2 (list 'x2))
(a3 (list 'x3))
(a4 (list 'x4))
(a5 (list 'x5)))
(let ((w1 (make-freak-mapping a3 a4))
(w2 (make-freak-mapping a1 a2))
(w3 (make-freak-mapping a4 a5))
(w4 (make-freak-mapping a2 a3)))
(setq a1 nil a2 nil a4 nil a5 nil)
(gc)
(list (freak-mapping-value w2)
(freak-mapping-value w4)
(freak-mapping-value w1)
(freak-mapping-value w3))))
(nil nil (x4) (x5))
(let ((a1 (list 'x1))
(a2 (list 'x2))
(a3 (list 'x3))
(a4 (list 'x4))
(a5 (list 'x5)))
(let ((w1 (make-freak-mapping a3 a4))
(w2 (make-freak-mapping a1 a2))
(w3 (make-freak-mapping a4 a5))
(w4 (make-freak-mapping a2 a3)))
(setq a1 nil a2 nil a3 nil a5 nil)
(gc)
(list (freak-mapping-value w2)
(freak-mapping-value w4)
(freak-mapping-value w1)
(freak-mapping-value w3))))
(nil nil nil (x5))
(let ((a1 (list 'x1))
(a2 (list 'x2))
(a3 (list 'x3))
(a4 (list 'x4))
(a5 (list 'x5)))
(let ((w1 (make-freak-mapping a3 a4))
(w2 (make-freak-mapping a1 a2))
(w3 (make-freak-mapping a4 a5))
(w4 (make-freak-mapping a2 a3)))
(setq a1 nil a2 nil a3 nil a4 nil)
(gc)
(list (freak-mapping-value w2)
(freak-mapping-value w4)
(freak-mapping-value w1)
(freak-mapping-value w3))))
(nil nil nil nil)
(let ((a (list 'x))
(b (list 'y))
(c (list 'z)))
(let ((w (make-freak-mapping a b)))
(setf (freak-mapping-value w) c)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
(((x) (z) t) ((z)))
(let ((a (list 'x))
(b (list 'y))
(c (list 'z)))
(let ((w (make-freak-mapping a b)))
(setf (freak-mapping-value w) c)
(gc)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
(((x) (z) t) ((z)))
(let ((a (list 'x))
(b (list 'y))
(c (list 'z)))
(let ((w (make-freak-mapping a b)))
(gc)
(setf (freak-mapping-value w) c)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
(((x) (z) t) ((z)))
(let ((a (list 'x))
(b (list 'y))
(c (list 'z)))
(let ((w (make-freak-mapping a b)))
(setq a nil)
(setf (freak-mapping-value w) c)
(gc)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
((nil nil nil) (nil))
(let ((a (list 'x))
(b (list 'y))
(c (list 'z)))
(let ((w (make-freak-mapping a b)))
(setq a nil)
(gc)
(setf (freak-mapping-value w) c)
(list (multiple-value-list (freak-mapping-pair w))
(multiple-value-list (freak-mapping-value w)))))
((nil nil nil) (nil))
;; Check that the GC can propagate through long chains of WEAK-MAPPINGs,
;; emulating WEAK-MAPPING with weak hash-tables.
(progn
(defun test-weak-mapping-chain (n)
(let (wm0)
(let ((sym (make-array n)))
(dotimes (i n) (setf (aref sym i) (make-symbol (prin1-to-string i))))
;; Build a chain
;; (gethash sym0 wm0) = wm1
;; (gethash sym1 wm1) = wm2
;; ...
(let ((wm (make-array n)))
(dotimes (i n) (setf (aref wm i) (make-freak-mapping 'a 'b)))
(setq wm0 (aref wm 0))
(do ((i 1 (1+ i)))
((>= i n))
(setf (gethash (aref sym (- i 1)) (aref wm (- i 1))) (aref wm i))))
(time (gc))
;; Verify that the chain is still intact.
(do ((i 0 (1+ i))
(w wm0 (gethash (aref sym i) w)))
((>= i n)))
(setq sym nil)
(time (gc))
(gethash 'a wm0))))
(test-weak-mapping-chain 10000))
B
; Likewise with reverse order of allocation of the weak hash tables.
; This test exhibits O(n^2) behaviour in LispWorks 4.3.
(progn
(defun test-weak-mapping-chain-reverse (n)
(let (wm0)
(let ((sym (make-array n)))
(dotimes (i n) (setf (aref sym i) (make-symbol (prin1-to-string i))))
;; Build a chain
;; (gethash sym0 wm0) = wm1
;; (gethash sym1 wm1) = wm2
;; ...
(let ((wm (make-array n)))
(dotimes (i n) (setf (aref wm (- n 1 i)) (make-freak-mapping 'a 'b)))
(setq wm0 (aref wm 0))
(do ((i 1 (1+ i)))
((>= i n))
(setf (gethash (aref sym (- i 1)) (aref wm (- i 1))) (aref wm i))))
(time (gc))
;; Verify that the chain is still intact.
(do ((i 0 (1+ i))
(w wm0 (gethash (aref sym i) w)))
((>= i n)))
(setq sym nil)
(time (gc))
(gethash 'a wm0))))
(test-weak-mapping-chain-reverse 10000))
B
;; Test that weak hash-tables of kind :VALUE work.
#+(or CLISP OpenMCL LISPWORKS)
(let ((tab (make-hash-table :test 'eq
#+LISPWORKS :weak-kind #-LISPWORKS :weak :value)))
(setf (gethash 'foo tab) 1)
(setf (gethash 1 tab) (copy-seq "bar"))
(setf (gethash 'zoo tab) (copy-seq "zot"))
(gc)
(list (gethash 'foo tab) (gethash 1 tab) (gethash 'zoo tab)))
#+(or CLISP OpenMCL LISPWORKS)
(1 NIL NIL)
#+(or CLISP LISPWORKS)
(let ((tab (make-hash-table :test 'equal
#+LISPWORKS :weak-kind #-LISPWORKS :weak :value)))
(weak-ht-fill-initially tab)
(gc)
(list (gethash "foo" tab) (gethash 1 tab) (gethash "zoo" tab)))
#+(or CLISP LISPWORKS)
(1 NIL NIL)
;; Test that weak hash-tables of kind :VALUE don't suffer from the
;; "value in key" problem.
#+(or CLISP OpenMCL LISPWORKS)
(let ((tab (make-hash-table :test 'eq
#+LISPWORKS :weak-kind #-LISPWORKS :weak :value)))
(let ((a (list 'x)))
(let ((b (list 'y)))
(setf (gethash 'xxx tab) a)
(setf (gethash (cons 'yyy b) tab) b))
(gc)
(list (hash-table-count tab)
(eq (gethash 'xxx tab) a)
(let ((l nil)) (maphash #'(lambda (k v) (push v l)) tab) l))))
#+(or CLISP OpenMCL LISPWORKS)
(1 T ((X)))
;; Test that weak hash-tables of kind :KEY-AND-VALUE work.
#+(or CLISP LISPWORKS)
(let ((tab (make-hash-table :test #+OpenMCL 'eq #-OpenMCL 'equal
#+LISPWORKS :weak-kind #+LISPWORKS :both
#-LISPWORKS :weak #-LISPWORKS :key-and-value)))
(weak-ht-fill-initially tab)
(gc)
(list (gethash "foo" tab) (gethash 1 tab) (gethash "zoo" tab)))
#+(or CLISP LISPWORKS)
(NIL NIL NIL)
;; Test that weak hash-tables of kind :KEY-OR-VALUE work.
#+(or CLISP LISPWORKS)
(let ((tab (make-hash-table :test #+OpenMCL 'eq #-OpenMCL 'equal
#+LISPWORKS :weak-kind #+LISPWORKS :either
#-LISPWORKS :weak #-LISPWORKS :key-or-value)))
#+LISPWORKS (set-hash-table-weak tab :either)
(weak-ht-fill-initially tab)
(gc)
(list (gethash "foo" tab) (gethash 1 tab) (gethash "zoo" tab)))
#+(or CLISP LISPWORKS)
(1 "bar" NIL)