;;;; hash-table-weak-tests-incl.scm

;; Weak References Tests

(cond-expand
  (compiling
    (import (chicken gc))

    (define-constant WEAK-DATA-SIZE 12)
    (assert (zero? (modulo WEAK-DATA-SIZE 4)))

    (define (list-split ls #!optional (n (floor (/ (length ls) 2))))
      (let loop ((n n) (hds '()) (tls ls))
        (if (<= n 0) (values (reverse hds) tls)
            (loop (sub1 n) (cons (car tls) hds) (cdr tls)) ) ) )

    (define (drop ls n) (receive (_ ns) (list-split ls n) ns))

    #|
    (define gensym!)
    (let ((+counter+ -1))
      (set! gensym!
        (lambda (#!optional (pre "g!"))
          (set! +counter+ (fx+ 1 +counter+))
          (string->symbol (string-append (if (symbol? pre) (symbol->string pre) pre)
                                         (number->string +counter+))) ) ) )
    |#

    (define (gensyms n #!optional (seed 'g))
      (let loop ((n n) (l '()))
        (if (not (positive? n)) (reverse l)
            (loop (sub1 n) (cons (gensym seed) l))) ) )

    (define (gen-symkeys-data #!optional (tag 'wks) (siz WEAK-DATA-SIZE))
      (gensyms siz tag) )

    (define (split-size m #!optional (n 2)) (round (/ m n)))
    (define (split-length ls #!optional (n 2)) (split-size (length ls) n))

    (define (symkeys-split ls #!optional (n (split-length ls)))
      (receive (hds tls) (list-split ls n)
        (values (map symbol->string hds) tls) ) )

    (test-group "HT - weak eq? hash-table - keys"
      ;make weak key table , gensym keys , set! table keys ,
      ;convert some keys to strings , gc (converted symbols keys -> bwp) ,
      ;verify the bwp keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #t #:weak-values #f))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data))
             (slen (split-length vals 4)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                     ;drop some keys, but save for resurrection, as strings,
                     ;not symbols
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (symkeys-split keys slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;resurrect for probe
            (for-each
              (lambda (x) (test-assert (not (hash-table-exists? ht (string->symbol x)))))
              bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak eq? hash-table - values"
      ;make weak value table , gensym keys & values , set! table keys & values ,
      ;drop some values (keeping the symbol keys) , gc (dropped values -> bwp) ,
      ;verify the bwp valued keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #f #:weak-values #t))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data))
             (slen (split-length vals)) )
        (test-group "table build"
          (test (length keys) (length vals))
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop some values
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          ;(test (length rst) (split-size WEAK-DATA-SIZE))
          ;(test (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            (hash-table-clean! ht)
            (test (length tls) (hash-table-size ht))
            (test (hash-table-size ht) (length (hash-table->alist ht)))
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht b)))) bwps)
            (for-each (lambda (k) (test-assert (hash-table-exists? ht k))) tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak eq? hash-table - key+values"
      ;make weak value table , gensym keys & values , set! table keys & values ,
      ;drop some values (keeping the symbol keys) , gc (dropped values -> bwp) ,
      ;verify the bwp valued keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #t #:weak-values #t))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data))
             (slen (split-length vals 4)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop 1st 1/4 values (keep keys) & 2nd 1/4 keys (keep values)
        (let*-values (((_ rst) (list-split vals slen))
                      ((hds tls) (list-split keys slen))
                      ((bwps tls) (symkeys-split tls slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! keys tls)
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged"
            (for-each (lambda (h) (test-assert (not (hash-table-exists? ht h)))) hds)
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht (string->symbol b)))))
                      bwps)
          ) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
                    keys (drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - keys"
      ;string keys w/ string values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #f))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data))
             (slen (split-length vals)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop some keys, but save for resurrection
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! bwps (map string->symbol bwps))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;probe remainder
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht (symbol->string b)))))
              bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - values"
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #f #:weak-values #t))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data))
             (slen (split-length vals)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop some values
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          ;(test (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            (hash-table-clean! ht)
            (test (length tls) (hash-table-size ht))
            (test (hash-table-size ht) (length (hash-table->alist ht)))
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht b)))) bwps)
            (for-each (lambda (k) (test-assert (hash-table-exists? ht k))) tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - key+values"
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #t))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data))
             (slen (split-length vals 4)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop 1st 1/3 values & 2nd 1/3 keys
        (let*-values (((_ rst) (list-split vals slen))
                      ((hds tls) (list-split keys slen)) ;hds killed
                      ((bwps tls) (list-split tls slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! keys tls)
          (set! vals rst)
          (set! bwps (map string->symbol bwps)) ;kill keys
          (gc #t)
          (test-group "table scavanged"
            (for-each (lambda (h) (test-assert (not (hash-table-exists? ht h)))) hds)
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht (symbol->string b)))))
                      bwps)
          ) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
                    keys (drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )
  )
  (else) )