From b9e4ebfeeb8d9b16a11effbe49f4a7e826844db8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= Date: Tue, 8 Jan 2019 22:06:10 -0200 Subject: [PATCH 4/5] Reimplemented (RNRS HASHTABLES) using GENERIC-HASH-TABLES --- module/rnrs/hashtables.scm | 212 +++++++++++++------------------------ 1 file changed, 75 insertions(+), 137 deletions(-) diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm index 486452a2a..fd27c54c6 100644 --- a/module/rnrs/hashtables.scm +++ b/module/rnrs/hashtables.scm @@ -43,147 +43,85 @@ string-ci-hash symbol-hash) (import (rename (only (guile) string-hash-ci - string-hash - hashq - hashv - modulo - *unspecified* - @@) + string-hash + hashq + hashv + modulo + *unspecified*) (string-hash-ci string-ci-hash)) (only (ice-9 optargs) define*) - (rename (only (srfi :69) make-hash-table - hash - hash-by-identity - hash-table-size - hash-table-ref/default - hash-table-set! - hash-table-delete! - hash-table-exists? - hash-table-update!/default - hash-table-copy - hash-table-equivalence-function - hash-table-hash-function - hash-table-keys - hash-table-fold) - (hash equal-hash) - (hash-by-identity symbol-hash)) - (only (ice-9 generic-hash-tables) hash-by-value) + (rename (only (ice-9 generic-hash-tables) + make-hash-table + hash-table? + hash-table-mutable? + hash + hash-by-identity + hash-by-value + hash-table-size + hash-table-ref/default + hash-table-set-single! + hash-table-delete-single! + hash-table-contains? + hash-table-update!/default + hash-table-clear! + hash-table-copy + hash-table-entry-vectors + hash-table-equivalence-function + hash-table-hash-function + hash-table-key-vector) + (make-hash-table gen:make-hash-table) + (hash equal-hash)) + (only (srfi srfi-69) hash-table-set! hash-table-delete!) (rnrs base (6)) (rnrs records procedural (6))) + + (define hashtable? hash-table?) + + (define hashtable-mutable? hash-table-mutable?) + + (define symbol-hash hash-by-identity) + + (define* (make-eq-hashtable #:optional capacity) + (if capacity + (gen:make-hash-table eq? #f #:capacity capacity) + (gen:make-hash-table eq? #f))) + + (define* (make-eqv-hashtable #:optional capacity) + (if capacity + (gen:make-hash-table eqv? #f #:capacity capacity) + (gen:make-hash-table eqv? #f))) + + (define* (make-hashtable hash-function equiv #:optional capacity) + (if capacity + (gen:make-hash-table equiv hash-function #:capacity capacity) + (gen:make-hash-table equiv hash-function))) - (define r6rs:hashtable - (make-record-type-descriptor - 'r6rs:hashtable #f #f #t #t - '#((mutable wrapped-table) - (immutable orig-hash-function) - (immutable mutable) - (immutable type)))) - - (define hashtable? (record-predicate r6rs:hashtable)) - (define make-r6rs-hashtable - (record-constructor (make-record-constructor-descriptor - r6rs:hashtable #f #f))) - (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0)) - (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0)) - (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1)) - (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2)) - (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3)) - - (define hashtable-mutable? r6rs:hashtable-mutable?) - - ;; (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv)) - ;; (define (wrap-hash-function proc) - ;; (lambda (key capacity) (modulo (proc key) capacity))) - - (define* (make-eq-hashtable #:optional k) - (make-r6rs-hashtable - (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash)) - symbol-hash - #t - 'eq)) - - (define* (make-eqv-hashtable #:optional k) - (make-r6rs-hashtable - (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value)) - hash-by-value - #t - 'eqv)) - - (define* (make-hashtable hash-function equiv #:optional k) - (make-r6rs-hashtable - (if k - (make-hash-table equiv hash-function k) - (make-hash-table equiv hash-function)) - hash-function - #t - 'custom)) - - (define (hashtable-size hashtable) - (hash-table-size (r6rs:hashtable-wrapped-table hashtable))) - - (define (hashtable-ref hashtable key default) - (hash-table-ref/default - (r6rs:hashtable-wrapped-table hashtable) key default)) - - (define (hashtable-set! hashtable key obj) - (if (r6rs:hashtable-mutable? hashtable) - (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj) - (assertion-violation - 'hashtable-set! "Hashtable is immutable." hashtable))) - - (define (hashtable-delete! hashtable key) - (if (r6rs:hashtable-mutable? hashtable) - (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key)) - *unspecified*) - - (define (hashtable-contains? hashtable key) - (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key)) - - (define (hashtable-update! hashtable key proc default) - (if (r6rs:hashtable-mutable? hashtable) - (hash-table-update!/default - (r6rs:hashtable-wrapped-table hashtable) key proc default)) - *unspecified*) - - (define* (hashtable-copy hashtable #:optional mutable) - (make-r6rs-hashtable - (hash-table-copy (r6rs:hashtable-wrapped-table hashtable)) - (r6rs:hashtable-orig-hash-function hashtable) - (and mutable #t) - (r6rs:hashtable-type hashtable))) - - (define* (hashtable-clear! hashtable #:optional k) - (if (r6rs:hashtable-mutable? hashtable) - (let* ((ht (r6rs:hashtable-wrapped-table hashtable)) - (equiv (hash-table-equivalence-function ht)) - (hash-function (r6rs:hashtable-orig-hash-function hashtable))) - (r6rs:hashtable-set-wrapped-table! - hashtable - (if k - (make-hash-table equiv hash-function k) - (make-hash-table equiv hash-function))))) - *unspecified*) - - (define (hashtable-keys hashtable) - (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable)))) - - (define (hashtable-entries hashtable) - (let* ((ht (r6rs:hashtable-wrapped-table hashtable)) - (size (hash-table-size ht)) - (keys (make-vector size)) - (vals (make-vector size))) - (hash-table-fold (r6rs:hashtable-wrapped-table hashtable) - (lambda (k v i) - (vector-set! keys i k) - (vector-set! vals i v) - (+ i 1)) - 0) - (values keys vals))) - - (define (hashtable-equivalence-function hashtable) - (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable))) + (define hashtable-size hash-table-size) + + (define hashtable-ref hash-table-ref/default) + + (define hashtable-set! hash-table-set!) + + (define hashtable-delete! hash-table-delete!) + + (define hashtable-contains? hash-table-contains?) + + (define hashtable-update! hash-table-update!/default) + + (define* (hashtable-copy ht #:optional mutable) + (hash-table-copy ht #:mutable mutable)) + + (define hashtable-clear! hash-table-clear!) + + (define hashtable-keys hash-table-key-vector) + + (define hashtable-entries hash-table-entry-vectors) + + (define hashtable-equivalence-function hash-table-equivalence-function) (define (hashtable-hash-function hashtable) - (case (r6rs:hashtable-type hashtable) - ((eq eqv) #f) - (else (r6rs:hashtable-orig-hash-function hashtable))))) + (let ((hash-function (hash-table-hash-function hashtable))) + (cond ((or (eq? hash-by-identity hash-function) + (eq? hash-by-value hash-function)) + #f) + (else hash-function))))) -- 2.19.1