Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-16 17:37:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

SRFI-69 hash-fn defaults to hash-by-identity if the eq-fn is eq?

Browse source
This commit is contained in:
Alex Shinn 2011-11-04 16:51:41 +09:00
parent 5e5c7c6f9a
commit 5e0e1c8c25
3 changed files with 15 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/srfi/69.sld
View file

@ -1,6 +1,6 @@
(define-library (srfi 69) (define-library (srfi 69)
(export (export hash-table-cell
make-hash-table hash-table? alist->hash-table make-hash-table hash-table? alist->hash-table
hash-table-equivalence-function hash-table-hash-function hash-table-equivalence-function hash-table-hash-function
hash-table-ref hash-table-ref/default hash-table-set! hash-table-ref hash-table-ref/default hash-table-set!

19
lib/srfi/69/hash.c
View file

@ -1,5 +1,5 @@
/* hash.c -- type-general hashing */ /* hash.c -- type-general hashing */
/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h> #include <chibi/eval.h>
@ -60,7 +60,7 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t
else else
#endif #endif
if (sexp_pointerp(obj)) { if (sexp_pointerp(obj)) {
if (depth) { if (depth > 0) {
t = sexp_object_type(ctx, obj); t = sexp_object_type(ctx, obj);
p = (sexp*) (((char*)obj) + sexp_type_field_base(t)); p = (sexp*) (((char*)obj) + sexp_type_field_base(t));
p0 = ((char*)obj) + offsetof(struct sexp_struct, value); p0 = ((char*)obj) + offsetof(struct sexp_struct, value);
@ -107,9 +107,9 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) {
sexp_gc_var1(args); sexp_gc_var1(args);
sexp res; sexp res;
sexp_uint_t len = sexp_vector_length(buckets); sexp_uint_t len = sexp_vector_length(buckets);
if (hash_fn == sexp_make_fixnum(1)) if (hash_fn == SEXP_ONE)
res = sexp_hash_by_identity(ctx sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len)); res = sexp_hash_by_identity(ctx sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len));
else if (hash_fn == sexp_make_fixnum(2)) else if (hash_fn == SEXP_TWO)
res = sexp_hash(ctx sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len)); res = sexp_hash(ctx sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len));
else { else {
sexp_gc_preserve1(ctx, args); sexp_gc_preserve1(ctx, args);
@ -118,7 +118,7 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) {
if (sexp_exceptionp(res)) { if (sexp_exceptionp(res)) {
args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx)); args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx));
sexp_print_exception(ctx, res, args); sexp_print_exception(ctx, res, args);
res = sexp_make_fixnum(0); res = SEXP_ZERO;
} else if (sexp_unbox_fixnum(res) >= len) { } else if (sexp_unbox_fixnum(res) >= len) {
res = SEXP_ZERO; res = SEXP_ZERO;
} }
@ -131,8 +131,8 @@ static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
sexp_gc_var1(res); sexp_gc_var1(res);
sexp p; sexp p;
res = SEXP_FALSE; res = SEXP_FALSE;
if ((eq_fn == sexp_make_fixnum(1)) if ((eq_fn == SEXP_ONE)
|| ((eq_fn == sexp_make_fixnum(2)) || ((eq_fn == SEXP_TWO)
&& (sexp_pointerp(obj) ? && (sexp_pointerp(obj) ?
(sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) { (sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) {
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) { for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
@ -141,7 +141,7 @@ static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
break; break;
} }
} }
} else if (eq_fn == sexp_make_fixnum(2)) { } else if (eq_fn == SEXP_TWO) {
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) { for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) { if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) {
res = p; res = p;
@ -220,8 +220,7 @@ static sexp sexp_hash_table_delete (sexp ctx sexp_api_params(self, n), sexp ht,
i = sexp_get_bucket(ctx, buckets, hash_fn, obj); i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn); res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
if (sexp_pairp(res)) { if (sexp_pairp(res)) {
sexp_hash_table_size(ht) sexp_hash_table_size(ht) = sexp_fx_sub(sexp_hash_table_size(ht), SEXP_ONE);
= sexp_fx_sub(sexp_hash_table_size(ht), sexp_make_fixnum(1));
if (res == sexp_vector_ref(buckets, i)) { if (res == sexp_vector_ref(buckets, i)) {
sexp_vector_set(buckets, i, sexp_cdr(res)); sexp_vector_set(buckets, i, sexp_cdr(res));
} else { } else {

8
lib/srfi/69/interface.scm
View file

@ -1,12 +1,14 @@
;; interface.scm -- hash-table interface ;; interface.scm -- hash-table interface
;; Copyright (c) 2009 Alex Shinn. All rights reserved. ;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;; the non-exported hash-table-cell is the heart of the implemenation ;; the non-exported hash-table-cell is the heart of the implemenation
(define (make-hash-table . o) (define (make-hash-table . o)
(let ((eq-fn (if (pair? o) (car o) equal?)) (let* ((eq-fn (if (pair? o) (car o) equal?))
(hash-fn (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) hash))) (hash-fn (if (and (pair? o) (pair? (cdr o)))
(car (cdr o))
(if (eq? eq? eq-fn) hash-by-identity hash))))
(cond (cond
((not (procedure? eq-fn)) ((not (procedure? eq-fn))
(error "make-hash-table: bad equivalence function" eq-fn)) (error "make-hash-table: bad equivalence function" eq-fn))