data.trie - Finish supporting custom tab-empty? proc

Apparantly adding support of custom tab-empty? proc wasn't
completed.
Related: #1174

Author: shirok

ChangeLog

@@ -1,3 +1,9 @@
+2025-09-28  Shiro Kawai  <shiro@acm.org>
+
+	* libsrc/data/trie.scm: Custon tab-empty? procedure hasn't been
+	  fully supported.
+	  https://github.com/shirok/Gauche/issues/1174
+
 2025-09-24  Shiro Kawai  <shiro@acm.org>
 
 	* src/compile.scm (global-syntax=?): Compare two identifiers iff

ext/data/test-trie.scm

@@ -201,6 +201,28 @@
            (let1 h (coerce-to <hash-table> t6)
              (every (cut hash-table-get h <>) strs)))
     )
+
+  ;; customizing tables w/ tag-empty?
+  (let1 t7 (make-trie (cut list 'fooo)
+                      (^[tab elt] (assoc-ref (cdr tab) elt))
+                      (^[tab elt child-node]
+                        (if child-node
+                          (set! (cdr tab) (assoc-set! (cdr tab) elt child-node))
+                          (set! (cdr tab) (alist-delete elt (cdr tab) equal?)))
+                        tab)
+                      (^[tab proc seed]
+                        (fold (^[e s] (proc (car e) (cdr e) s)) seed (cdr tab)))
+                      (^[tab] (null? (cdr tab))))
+    (test* "trie (empty?):" (length strs)
+           (begin
+             (dolist [s strs]
+               (trie-put! t7 s s))
+             (trie-num-entries t7)))
+
+    (test* "trie-partial-key?" #t (trie-partial-key? t7 "kan"))
+    (test* "trie-partial-key?" #t (trie-partial-key? t7 "kana"))
+    (test* "trie-partial-key?" #f (trie-partial-key? t7 "kanaono"))
+    )
   )
 
 (test-end)

libsrc/data/trie.scm

@@ -117,13 +117,14 @@
 ;;;
 
 (define (make-trie :optional (tab-make #f) (tab-get  #f) (tab-put! #f)
-                   (tab-fold #f))
+                   (tab-fold #f) (tab-empty? #f))
     (apply make <trie>
            (cond-list
             (tab-make @ `(:tab-make ,tab-make))
             (tab-get  @ `(:tab-get  ,tab-get))
             (tab-put! @ `(:tab-put! ,tab-put!))
-            (tab-fold @ `(:tab-fold ,tab-fold)))))
+            (tab-fold @ `(:tab-fold ,tab-fold))
+            (tab-empty? @ `(:tab-empty? ,tab-empty?)))))
 
 (define (trie params . keys&vals)
   (rlet1 t (apply make-trie params)
@@ -223,14 +224,15 @@
 
 ;; internal: Trie, Node -> Boolean
 (define (%trie-node-empty? trie node)
-  (cond
-   [(slot-ref trie'tab-empty?) => (^[empty?] (empty? node))]
-   ;; some heuristics
-   [(and (hash-table? (%node-table node))
-         (eq? (slot-ref trie'tab-fold) hash-table-fold))
-    (zero? (hash-table-num-entries (%node-table node)))]
-   [(%node-table node) => (cut (slot-ref trie'tab-fold) <> (^[k n s] #t) #f)]
-   [else #t]))
+  (if-let1 tab (%node-table node)
+    (cond
+     [(slot-ref trie'tab-empty?) => (^[empty?] (empty? tab))]
+     ;; some heuristics
+     [(and (hash-table? tab)
+           (eq? (slot-ref trie'tab-fold) hash-table-fold))
+      (zero? (hash-table-num-entries tab))]
+     [else (slot-ref trie'tab-fold) tab (^[k n s] #t) #f])
+    #t))
 
 ;; Public APIs