Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
0cf37702
Commit
0cf37702
authored
32 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Rewrote most everything. MAKE-HASH-TABLE now conforms to the X3J13 spec.
parent
a8aa96f0
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/hash.lisp
+363
-360
363 additions, 360 deletions
code/hash.lisp
with
363 additions
and
360 deletions
code/hash.lisp
+
363
−
360
View file @
0cf37702
;;; -*-
Log: code.log;
Package: L
isp
-*-
;;; -*- Package:
C
L -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
...
...
@@ -7,80 +7,118 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.1
2
1992/0
4/23 14:11
:0
6
wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.1
3
1992/0
5/07 08:48
:0
8
wlott Exp $"
)
;;;
;;; **********************************************************************
;;;
;;; Hashing and hash table functions for Spice Lisp.
;;; Written by Skef Wholey.
;;; Originally written by Skef Wholey.
;;; Everything except SXHASH rewritten by William Lott.
;;;
(
in-package
'lisp
)
(
in-package
:common-lisp
)
(
export
'
(
hash-table
hash-table-p
make-hash-table
gethash
remhash
maphash
clrhash
hash-table-count
sxhash
with-hash-table-iterator
))
;;; Vector subtype codes.
(
defconstant
valid-hashing
2
)
(
defconstant
must-rehash
3
)
hash-table-count
with-hash-table-iterator
hash-table-rehash-size
hash-table-rehash-threshold
hash-table-size
hash-table-test
sxhash
))
;;; What a hash-table is:
;;;; The hash-table structure.
(
defstruct
(
hash-table
(
:constructor
make-hash-table-structure
)
(
:con
c-name
hash-table
-
)
(
:print-function
%print-hash-table
)
(
:make-load-form-fun
make-hash-table-load-form
))
(
defstruct
(
hash-table
(
:con
structor
%make-
hash-table
)
(
:print-function
%print-hash-table
)
(
:make-load-form-fun
make-hash-table-load-form
))
"Structure used to implement hash tables."
(
kind
'eq
)
(
size
65
:type
fixnum
)
(
rehash-size
101
)
; might be a float
(
rehash-threshold
57
:type
fixnum
)
(
number-entries
0
:type
fixnum
)
;;
;; The type of hash table this is. Only used for printing and as part of
;; the exported interface.
(
test
(
required-argument
)
:type
symbol
:read-only
t
)
;;
;; The function used to compare two keys. Returns T if they are the same
;; and NIL if not.
(
test-fun
(
required-argument
)
:type
function
:read-only
t
)
;;
;; The function used to compute the hashing of a key. Returns two values:
;; the index hashing and T if that might change with the next GC.
(
hash-fun
(
required-argument
)
:type
function
:read-only
t
)
;;
;; How much to grow the hash table by when it fills up. If an index, then
;; add that amount. If a floating point number, then multiple it by that.
(
rehash-size
(
required-argument
)
:type
(
or
index
(
float
(
1.0
)))
:read-only
t
)
;;
;; How full the hash table has to get before we rehash.
(
rehash-threshold
(
required-argument
)
:type
(
real
0
1
)
:read-only
t
)
;;
;; (* rehash-threshold (length table)), saved here so we don't have to keep
;; recomputing it.
(
rehash-trigger
(
required-argument
)
:type
index
)
;;
;; The current number of entries in the table.
(
number-entries
0
:type
index
)
;;
;; Vector of ht-buckets.
(
table
(
required-argument
)
:type
simple-vector
))
;;;
(
defun
%print-hash-table
(
ht
stream
depth
)
(
declare
(
ignore
depth
))
(
print-unreadable-object
(
ht
stream
:identity
t
)
(
format
stream
"~A hash table, ~D entries"
(
symbol-name
(
hash-table-test
ht
))
(
hash-table-number-entries
ht
))))
;;; A hash-table-table is a vector of association lists. When an
;;; entry is made in a hash table, a pair of (key . value) is consed onto
;;; the element in the vector arrived at by hashing.
(
defconstant
max-hash
most-positive-fixnum
)
;;; How to print one:
(
deftype
hash
()
`
(
integer
0
,
max-hash
))
(
defun
%print-hash-table
(
structure
stream
depth
)
(
declare
(
ignore
depth
))
(
format
stream
"#<~A Hash Table {~X}>"
(
symbol-name
(
hash-table-kind
structure
))
(
system:%primitive
make-fixnum
structure
)))
(
defstruct
hash-table-bucket
;;
;; The hashing associated with key, kept around so we don't have to recompute
;; it each time. When NIL, then just use %primitive make-fixnum. We don't
;; cache the results of make-fixnum, because it can change with a GC.
(
hash
nil
:type
(
or
hash
null
))
;;
;; The key and value, originally supplied by the user.
(
key
nil
:type
t
)
(
value
nil
:type
t
)
;;
;; The next bucket, or NIL if there are no more.
(
next
nil
:type
(
or
hash-table-bucket
null
)))
;;;
Hashing
functions
for the three kinds of hash tables:
;;;
; Utility
functions
.
(
eval-when
(
compile
)
(
declaim
(
inline
pointer-hash
))
(
defun
pointer-hash
(
key
)
(
declare
(
values
hash
))
(
truly-the
hash
(
%primitive
make-fixnum
key
)))
(
defmacro
eq-hash
(
object
)
"Gives us a hashing of an object such that (eq a b) implies
(= (eq-hash a) (eq-hash b))"
`
(
truly-the
(
unsigned-byte
24
)
(
%primitive
make-fixnum
,
object
)))
(
declaim
(
inline
eq-hash
))
(
defun
eq-hash
(
key
)
(
declare
(
values
hash
(
member
t
nil
)))
(
values
(
pointer-hash
key
)
(
oddp
(
get-lisp-obj-address
key
))))
(
de
fmacro
eql-hash
(
object
)
"Gives us a hashing of an object such that (eql a b) implies
(= (eql-hash a) (eql-hash b
))
"
`
(
if
(
numberp
,
object
)
(
logand
(
truncate
,
object
)
most-positive-fixnum
)
(
truly-the
fixnum
(
%primitive
make-fixnum
,
object
)
)))
(
de
claim
(
inline
eql-hash
)
)
(
defun
eql-hash
(
key
)
(
declare
(
values
hash
(
member
t
nil
))
)
(
if
(
numberp
key
)
(
equal-hash
key
)
(
eq-hash
key
)))
(
de
fmacro
equal-hash
(
object
)
"Gives us a hashing of an object such that (equal a b) implies
(= (equal-hash a) (equal-hash b
))
"
`
(
sxhash
,
object
))
(
de
claim
(
inline
equal-hash
)
)
(
defun
equal-hash
(
key
)
(
declare
(
values
hash
(
member
t
nil
))
)
(
values
(
sxhash
key
)
nil
))
)
;;; Rehashing functions:
(
defun
almost-primify
(
num
)
(
declare
(
fixnum
num
))
(
declare
(
type
index
num
))
"Almost-Primify returns an almost prime number greater than or equal
to NUM."
(
if
(
=
(
rem
num
2
)
0
)
...
...
@@ -91,287 +129,289 @@
(
setq
num
(
+
4
num
)))
num
)
(
eval-when
(
compile
)
(
defmacro
grow-size
(
table
)
"Returns a fixnum for the next size of a growing hash-table."
`
(
let
((
rehash-size
(
hash-table-rehash-size
,
table
)))
(
if
(
floatp
rehash-size
)
(
ceiling
(
*
rehash-size
(
hash-table-size
,
table
)))
(
+
rehash-size
(
hash-table-size
,
table
)))))
(
defmacro
grow-rehash-threshold
(
table
new-length
)
"Returns the next rehash threshold for the table."
table
`,
new-length
; `(ceiling (* (hash-table-rehash-threshold ,table)
; (/ ,new-length (hash-table-size ,table))))
)
(
defmacro
hash-set
(
vector
key
value
length
hashing-function
)
"Used for rehashing. Enters the value for the key into the vector
by hashing. Never grows the vector. Assumes the key is not yet
entered."
`
(
let
((
index
(
rem
(
the
fixnum
(
funcall
,
hashing-function
,
key
))
(
the
fixnum
,
length
))))
(
declare
(
fixnum
index
))
(
setf
(
aref
(
the
simple-vector
,
vector
)
index
)
(
cons
(
cons
,
key
,
value
)
(
aref
(
the
simple-vector
,
vector
)
index
)))))
)
(
defun
rehash
(
structure
hash-vector
new-length
)
(
declare
(
simple-vector
hash-vector
))
(
declare
(
fixnum
new-length
))
"Rehashes a hash table and replaces the TABLE entry in the structure if
someone hasn't done so already. New vector is of NEW-LENGTH."
(
do
((
new-vector
(
make-array
new-length
:initial-element
nil
))
(
i
0
(
1+
i
))
(
size
(
hash-table-size
structure
))
(
hashing-function
(
case
(
hash-table-kind
structure
)
(
eq
#'
(
lambda
(
x
)
(
eq-hash
x
)))
(
eql
#'
(
lambda
(
x
)
(
eql-hash
x
)))
(
equal
#'
(
lambda
(
x
)
(
equal-hash
x
))))))
((
=
i
size
)
(
cond
((
eq
hash-vector
(
hash-table-table
structure
))
(
cond
((
>
new-length
size
)
(
setf
(
hash-table-table
structure
)
new-vector
)
(
setf
(
hash-table-rehash-threshold
structure
)
(
grow-rehash-threshold
structure
new-length
))
(
setf
(
hash-table-size
structure
)
new-length
))
(
t
(
setf
(
hash-table-table
structure
)
new-vector
)))
(
if
(
not
(
eq
(
hash-table-kind
structure
)
'equal
))
(
%primitive
set-vector-subtype
new-vector
valid-hashing
)))))
(
declare
(
fixnum
i
size
))
(
do
((
bucket
(
aref
hash-vector
i
)
(
cdr
bucket
)))
((
null
bucket
))
(
hash-set
new-vector
(
caar
bucket
)
(
cdar
bucket
)
new-length
hashing-function
))
(
setf
(
aref
hash-vector
i
)
nil
)))
;;; Macros for Gethash, %Puthash, and Remhash:
(
eval-when
(
compile
)
;;; Hashop dispatches on the kind of hash table we've got, rehashes if
;;; necessary, and binds Vector to the hash vector, Index to the index
;;; into that vector that the Key points to, and Size to the size of the
;;; hash vector. Since Equal hash tables only need to be maybe rehashed
;;; sometimes, one can tell it if it's one of those times with the
;;; Equal-Needs-To-Rehash-P argument.
(
defmacro
hashop
(
equal-needs-to-rehash-p
eq-body
eql-body
equal-body
)
`
(
let*
((
vector
(
hash-table-table
hash-table
))
(
size
(
length
vector
)))
(
declare
(
simple-vector
vector
)
(
fixnum
size
)
(
inline
assoc
))
(
case
(
hash-table-kind
hash-table
)
(
equal
,@
(
if
equal-needs-to-rehash-p
`
((
equal-rehash-if-needed
)))
(
let
((
index
(
rem
(
the
fixnum
(
equal-hash
key
))
size
)))
(
declare
(
fixnum
index
))
,
equal-body
))
(
eq
(
without-gcing
(
eq-rehash-if-needed
)
(
let
((
index
(
rem
(
the
fixnum
(
eq-hash
key
))
size
)))
(
declare
(
fixnum
index
))
,
eq-body
)))
(
eql
(
without-gcing
(
eq-rehash-if-needed
)
(
let
((
index
(
rem
(
the
fixnum
(
eql-hash
key
))
size
)))
(
declare
(
fixnum
index
))
,
eql-body
))))))
(
defmacro
eq-rehash-if-needed
()
`
(
let
((
subtype
(
truly-the
(
unsigned-byte
24
)
(
%primitive
get-vector-subtype
vector
))))
(
declare
(
type
(
unsigned-byte
24
)
subtype
))
(
cond
((
/=
subtype
valid-hashing
)
(
rehash
hash-table
vector
size
)
(
setq
vector
(
hash-table-table
hash-table
)))
((
>
(
hash-table-number-entries
hash-table
)
(
hash-table-rehash-threshold
hash-table
))
(
rehash
hash-table
vector
(
grow-size
hash-table
))
(
setq
vector
(
hash-table-table
hash-table
))
(
setq
size
(
length
vector
))))))
(
defmacro
equal-rehash-if-needed
()
`
(
cond
((
>
(
hash-table-number-entries
hash-table
)
(
hash-table-rehash-threshold
hash-table
))
(
rehash
hash-table
vector
(
grow-size
hash-table
))
(
setq
vector
(
hash-table-table
hash-table
))
(
setq
size
(
length
vector
)))))
(
defmacro
rehash-if-needed
()
`
(
let
((
subtype
(
truly-the
(
unsigned-byte
24
)
(
%primitive
get-vector-subtype
vector
)))
(
size
(
length
vector
)))
(
declare
(
type
(
unsigned-byte
24
)
subtype
)
(
fixnum
size
))
(
cond
((
and
(
not
(
eq
(
hash-table-kind
hash-table
)
'equal
))
(
/=
subtype
valid-hashing
))
(
rehash
hash-table
vector
size
)
(
setq
vector
(
hash-table-table
hash-table
))
(
setq
size
(
length
vector
)))
((
>
(
hash-table-number-entries
hash-table
)
(
hash-table-rehash-threshold
hash-table
))
(
rehash
hash-table
vector
(
grow-size
hash-table
))
(
setq
vector
(
hash-table-table
hash-table
))
(
setq
size
(
length
vector
))))))
)
;;; Making hash tables:
(
defun
make-hash-table
(
&key
(
test
'eql
)
(
size
65
)
(
rehash-size
101
)
(
rehash-threshold
size
))
"Creates and returns a hash table. See manual for details."
;;;; Construction and simple accessors.
;;; MAKE-HASH-TABLE -- public.
;;;
(
defun
make-hash-table
(
&key
(
test
'eql
)
(
size
65
)
(
rehash-size
1.5
)
(
rehash-threshold
1
))
"Creates and returns a new hash table. The keywords are as follows:
:TEST -- Indicates what kind of test to use. Only EQ, EQL, and EQUAL
are currently supported.
:SIZE -- A hint as to how many elements will be put in this hash
table.
:REHASH-SIZE -- Indicates how to expand the table when it fills up.
If an integer, add space for that many elements. If a floating
point number (which must be greater than 1.0), multiple the size
by that amount.
:REHASH-THRESHOLD -- Indicates how dense the table can become before
forcing a rehash. Can be any real number between 0 and 1 (inclusive)."
(
declare
(
type
(
or
function
(
member
eq
eql
equal
))
test
)
(
type
index
size
rehash-size
)
(
type
(
or
(
float
0.0
1.0
)
index
)
rehash-threshold
))
(
let*
((
test
(
cond
((
or
(
eq
test
#'
eq
)
(
eq
test
'eq
))
'eq
)
((
or
(
eq
test
#'
eql
)
(
eq
test
'eql
))
'eql
)
((
or
(
eq
test
#'
equal
)
(
eq
test
'equal
))
'equal
)
(
t
(
error
"~S is an illegal :Test for hash tables."
test
))))
(
size
(
if
(
<=
size
37
)
37
(
almost-primify
size
)))
(
rehash-threshold
(
cond
((
and
(
fixnump
rehash-threshold
)
(
<=
0
rehash-threshold
size
))
rehash-threshold
)
((
and
(
floatp
rehash-threshold
)
(
<=
0.0
rehash-threshold
1.0
))
(
ceiling
(
*
rehash-threshold
size
)))
(
t
(
error
"Invalid rehash-threshold: ~S.~%Must be either a float ~
between 0.0 and 1.0 ~%or an integer between 0 and ~D."
rehash-threshold
size
))))
(
table
(
make-array
size
:initial-element
nil
)))
(
make-hash-table-structure
:size
size
:rehash-size
rehash-size
:rehash-threshold
rehash-threshold
:table
(
if
(
eq
test
'equal
)
table
(
%primitive
set-vector-subtype
table
valid-hashing
))
:kind
test
)))
(
type
index
size
)
(
type
(
or
index
(
float
(
1.0
)))
rehash-size
)
(
type
(
real
0
1
)
rehash-threshold
))
(
multiple-value-bind
(
test
test-fun
hash-fun
)
(
cond
((
or
(
eq
test
#'
eq
)
(
eq
test
'eq
))
(
values
'eq
#'
eq
#'
eq-hash
))
((
or
(
eq
test
#'
eql
)
(
eq
test
'eql
))
(
values
'eql
#'
eql
#'
eql-hash
))
((
or
(
eq
test
#'
equal
)
(
eq
test
'equal
))
(
values
'equal
#'
equal
#'
equal-hash
))
(
t
(
error
"Unknown :TEST for MAKE-HASH-TABLE: ~S"
test
)))
(
let*
((
size
(
ceiling
size
rehash-threshold
))
(
length
(
if
(
<=
size
37
)
37
(
almost-primify
size
)))
(
vector
(
make-array
length
:initial-element
nil
)))
(
make-hash-table-structure
:test
test
:test-fun
test-fun
:hash-fun
hash-fun
:rehash-size
rehash-size
:rehash-threshold
rehash-threshold
:rehash-trigger
(
*
size
rehash-threshold
)
:table
vector
))))
(
defun
hash-table-count
(
hash-table
)
"Returns the number of entries in the given HASH-TABLE."
(
declare
(
type
hash-table
hash-table
)
(
values
index
))
(
hash-table-number-entries
hash-table
))
(
setf
(
documentation
'hash-table-rehash-size
'function
)
"Return the rehash-size HASH-TABLE was created with."
)
(
setf
(
documentation
'hash-table-rehash-threshold
'function
)
"Return the rehash-threshold HASH-TABLE was created with."
)
(
defun
hash-table-size
(
hash-table
)
"Return a size that can be used with MAKE-HASH-TABLE to create a hash
table that can hold however many entries HASH-TABLE can hold without
having to be grown."
(
hash-table-rehash-trigger
hash-table
))
(
setf
(
documentation
'hash-table-test
'function
)
"Return the test HASH-TABLE was created with."
)
;;;
Manipulating hash tables:
;;;
; Accessing functions.
;;; REHASH -- internal.
;;;
;;; Make a new vector for TABLE. If GROW is NIL, use the same size as before,
;;; otherwise extend the table based on the rehash-size.
;;;
(
defun
rehash
(
table
grow
)
(
declare
(
type
hash-table
table
))
(
let*
((
old-vector
(
hash-table-table
table
))
(
old-length
(
length
old-vector
))
(
new-length
(
if
grow
(
let
((
rehash-size
(
hash-table-rehash-size
table
)))
(
etypecase
rehash-size
(
fixnum
(
+
rehash-size
old-length
))
(
float
(
ceiling
(
*
rehash-size
old-length
)))))
old-length
))
(
new-vector
(
make-array
new-length
:initial-element
nil
)))
(
dotimes
(
i
old-length
)
(
do
((
bucket
(
svref
old-vector
i
)
next
)
(
next
nil
))
((
null
bucket
))
(
setf
next
(
hash-table-bucket-next
bucket
))
(
let*
((
old-hashing
(
hash-table-bucket-hash
bucket
))
(
hashing
(
cond
(
old-hashing
old-hashing
)
(
t
(
set-header-data
new-vector
vm:vector-valid-hashing-subtype
)
(
pointer-hash
(
hash-table-bucket-key
bucket
)))))
(
index
(
rem
hashing
new-length
)))
(
setf
(
hash-table-bucket-next
bucket
)
(
svref
new-vector
index
))
(
setf
(
svref
new-vector
index
)
bucket
)))
;; We clobber the old vector contents so that if it is living in
;; static space it won't keep ahold of pointers into dynamic space.
(
setf
(
svref
old-vector
i
)
nil
))
(
setf
(
hash-table-table
table
)
new-vector
)
(
unless
(
=
new-length
old-length
)
(
setf
(
hash-table-rehash-trigger
table
)
(
let
((
threshold
(
hash-table-rehash-threshold
table
)))
;; Optimize the threshold=1 case so we don't have to use
;; generic arithmetic in the most common case.
(
if
(
eql
threshold
1
)
new-length
(
truncate
(
*
threshold
new-length
)))))))
(
undefined-value
))
;;; GETHASH -- Public.
;;;
(
defun
gethash
(
key
hash-table
&optional
default
)
"Finds the entry in Hash-Table whose key is Key and returns the associated
value and T as multiple values, or returns Default and Nil if there is no
such entry."
(
macrolet
((
lookup
(
test
)
`
(
let
((
cons
(
assoc
key
(
aref
vector
index
)
:test
#'
,
test
)))
(
declare
(
list
cons
))
(
if
cons
(
values
(
cdr
cons
)
t
)
(
values
default
nil
)))))
(
hashop
nil
(
lookup
eq
)
(
lookup
eql
)
(
lookup
equal
))))
"Finds the entry in HASH-TABLE whose key is KEY and returns the associated
value and T as multiple values, or returns DEFAULT and NIL if there is no
such entry. Entries can be added using SETF."
(
declare
(
type
hash-table
hash-table
)
(
values
t
(
member
t
nil
)))
(
without-gcing
(
when
(
=
(
get-header-data
(
hash-table-table
hash-table
))
vm:vector-must-rehash-subtype
)
(
rehash
hash-table
nil
))
(
let*
((
vector
(
hash-table-table
hash-table
))
(
length
(
length
vector
))
(
hashing
(
funcall
(
hash-table-hash-fun
hash-table
)
key
))
(
index
(
rem
hashing
length
))
(
test-fun
(
hash-table-test-fun
hash-table
)))
(
do
((
bucket
(
svref
vector
index
)
(
hash-table-bucket-next
bucket
)))
((
null
bucket
)
(
values
default
nil
))
(
let
((
bucket-hashing
(
hash-table-bucket-hash
bucket
)))
(
when
(
if
bucket-hashing
(
and
(
=
bucket-hashing
hashing
)
(
funcall
test-fun
key
(
hash-table-bucket-key
bucket
)))
(
eq
key
(
hash-table-bucket-key
bucket
)))
(
return
(
values
(
hash-table-bucket-value
bucket
)
t
))))))))
;;; %PUTHASH -- public setf method.
;;;
(
defun
%puthash
(
key
hash-table
value
)
"Create an entry in HASH-TABLE associating KEY with VALUE; if there already
is an entry for KEY, replace it. Returns VALUE."
(
macrolet
((
store
(
test
)
`
(
let
((
cons
(
assoc
key
(
aref
vector
index
)
:test
#'
,
test
)))
(
declare
(
list
cons
))
(
cond
(
cons
(
setf
(
cdr
cons
)
value
))
(
t
(
push
(
cons
key
value
)
(
aref
vector
index
))
(
incf
(
hash-table-number-entries
hash-table
))
value
)))))
(
hashop
t
(
store
eq
)
(
store
eql
)
(
store
equal
))))
(
declare
(
type
hash-table
hash-table
))
(
without-gcing
(
let
((
entries
(
1+
(
hash-table-number-entries
hash-table
))))
(
setf
(
hash-table-number-entries
hash-table
)
entries
)
(
cond
((
>
entries
(
hash-table-rehash-trigger
hash-table
))
(
rehash
hash-table
t
))
((
=
(
get-header-data
(
hash-table-table
hash-table
))
vm:vector-must-rehash-subtype
)
(
rehash
hash-table
nil
))))
(
multiple-value-bind
(
hashing
eq-based
)
(
funcall
(
hash-table-hash-fun
hash-table
)
key
)
(
let*
((
vector
(
hash-table-table
hash-table
))
(
length
(
length
vector
))
(
index
(
rem
hashing
length
))
(
first-bucket
(
svref
vector
index
))
(
test-fun
(
hash-table-test-fun
hash-table
)))
(
do
((
bucket
first-bucket
(
hash-table-bucket-next
bucket
)))
((
null
bucket
)
(
setf
(
svref
vector
index
)
(
make-hash-table-bucket
:hash
(
unless
eq-based
hashing
)
:key
key
:value
value
:next
first-bucket
)))
(
let
((
bucket-hashing
(
hash-table-bucket-hash
bucket
)))
(
when
(
if
bucket-hashing
(
and
(
=
bucket-hashing
hashing
)
(
funcall
test-fun
key
(
hash-table-bucket-key
bucket
)))
(
eq
key
(
hash-table-bucket-key
bucket
)))
(
setf
(
hash-table-bucket-value
bucket
)
value
)
(
decf
(
hash-table-number-entries
hash-table
))
(
return
)))))))
value
)
;;; REMHASH -- public.
;;;
(
defun
remhash
(
key
hash-table
)
"Remove any entry for KEY in HASH-TABLE. Returns T if such an entry
existed; () otherwise."
(
hashop
nil
(
let
((
bucket
(
aref
vector
index
)))
; EQ case
(
cond
((
and
bucket
(
eq
(
caar
bucket
)
key
))
(
pop
(
aref
vector
index
))
(
decf
(
hash-table-number-entries
hash-table
))
t
)
(
t
(
do
((
last
bucket
bucket
)
(
bucket
(
cdr
bucket
)
(
cdr
bucket
)))
((
null
bucket
)
())
(
when
(
eq
(
caar
bucket
)
key
)
(
rplacd
last
(
cdr
bucket
))
(
decf
(
hash-table-number-entries
hash-table
))
(
return
t
))))))
(
let
((
bucket
(
aref
vector
index
)))
; EQL case
(
cond
((
and
bucket
(
eql
(
caar
bucket
)
key
))
(
pop
(
aref
vector
index
))
(
decf
(
hash-table-number-entries
hash-table
))
t
)
(
t
(
do
((
last
bucket
bucket
)
(
bucket
(
cdr
bucket
)
(
cdr
bucket
)))
((
null
bucket
)
())
(
when
(
eql
(
caar
bucket
)
key
)
(
rplacd
last
(
cdr
bucket
))
(
decf
(
hash-table-number-entries
hash-table
))
(
return
t
))))))
(
let
((
bucket
(
aref
vector
index
)))
; EQUAL case
(
cond
((
and
bucket
(
equal
(
caar
bucket
)
key
))
(
pop
(
aref
vector
index
))
(
decf
(
hash-table-number-entries
hash-table
))
t
)
(
t
(
do
((
last
bucket
bucket
)
(
bucket
(
cdr
bucket
)
(
cdr
bucket
)))
((
null
bucket
)
())
(
when
(
equal
(
caar
bucket
)
key
)
(
rplacd
last
(
cdr
bucket
))
(
decf
(
hash-table-number-entries
hash-table
))
(
return
t
))))))))
"Remove the entry in HASH-TABLE associated with KEY. Returns T if there
was such an entry, and NIL if not."
(
declare
(
type
hash-table
hash-table
)
(
values
(
member
t
nil
)))
(
without-gcing
(
when
(
=
(
get-header-data
(
hash-table-table
hash-table
))
vm:vector-must-rehash-subtype
)
(
rehash
hash-table
nil
))
(
let*
((
vector
(
hash-table-table
hash-table
))
(
length
(
length
vector
))
(
hashing
(
funcall
(
hash-table-hash-fun
hash-table
)
key
))
(
index
(
rem
hashing
length
))
(
test-fun
(
hash-table-test-fun
hash-table
)))
(
do
((
prev
nil
bucket
)
(
bucket
(
svref
vector
index
)
(
hash-table-bucket-next
bucket
)))
((
null
bucket
)
nil
)
(
let
((
bucket-hashing
(
hash-table-bucket-hash
bucket
)))
(
when
(
if
bucket-hashing
(
and
(
=
bucket-hashing
hashing
)
(
funcall
test-fun
key
(
hash-table-bucket-key
bucket
)))
(
eq
key
(
hash-table-bucket-key
bucket
)))
(
if
prev
(
setf
(
hash-table-bucket-next
prev
)
(
hash-table-bucket-next
bucket
))
(
setf
(
svref
vector
index
)
(
hash-table-bucket-next
bucket
)))
(
return
t
)))))))
;;; CLRHASH -- public.
;;;
(
defun
clrhash
(
hash-table
)
"This removes all the entries from HASH-TABLE and returns the hash table
itself."
(
let
((
vector
(
hash-table-table
hash-table
)))
(
dotimes
(
i
(
length
vector
))
(
setf
(
aref
vector
i
)
nil
))
(
setf
(
hash-table-number-entries
hash-table
)
0
)
(
set-header-data
vector
vm:vector-normal-subtype
))
hash-table
)
;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
(
declaim
(
maybe-inline
maphash
))
(
defun
maphash
(
map-function
hash-table
)
"For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
of the entry; returns NIL."
(
let
((
vector
(
hash-table-table
hash-table
)))
(
declare
(
simple-vector
vector
))
(
rehash-if-needed
)
(
do
((
i
0
(
1+
i
))
(
size
(
hash-table-size
hash-table
)))
((
=
i
size
))
(
declare
(
fixnum
i
size
))
(
do
((
bucket
(
aref
vector
i
)
(
cdr
bucket
)))
of the entry; returns NIL."
(
declare
(
type
(
or
function
symbol
)
map-function
)
(
type
hash-table
hash-table
))
(
let
((
fun
(
etypecase
map-function
(
function
map-function
)
(
symbol
(
symbol-function
map-function
))))
(
vector
(
hash-table-table
hash-table
)))
(
dotimes
(
i
(
length
vector
))
(
do
((
bucket
(
svref
vector
i
)
(
hash-table-bucket-next
bucket
)))
((
null
bucket
))
(
funcall
map-function
(
caar
bucket
)
(
cdar
bucket
))))))
(
funcall
fun
(
hash-table-bucket-key
bucket
)
(
hash-table-bucket-value
bucket
))))))
(
defmacro
with-hash-table-iterator
((
function
hash-table
)
&body
body
)
"WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
provides a method of manually looping over the elements of a hash-table.
function is bound to a generator-macro that, withing the scope of the
invocation, returns three values. First, whether there are any more objects
in the hash-table, second, the key, and third, the value."
(
let
((
n-function
(
gensym
"WITH-HASH-TABLE-ITERRATOR-"
)))
`
(
let
((
,
n-function
(
let*
((
table
,
hash-table
)
(
vector
(
hash-table-table
table
))
(
length
(
length
vector
))
(
index
0
)
(
bucket
(
svref
vector
0
)))
(
labels
((
,
function
()
(
cond
(
bucket
(
multiple-value-prog1
(
values
t
(
hash-table-bucket-key
bucket
)
(
hash-table-bucket-value
bucket
))
(
setf
bucket
(
hash-table-bucket-next
bucket
))))
((
=
(
incf
index
)
length
)
(
values
nil
))
(
t
(
setf
bucket
(
svref
vector
index
))
(
,
function
)))))
#'
,
function
))))
(
macrolet
((
,
function
()
(
funcall
,
n-function
)))
,@
body
))))
(
defun
clrhash
(
hash-table
)
"Removes all entries of HASH-TABLE and returns the hash table itself."
(
let
((
vector
(
hash-table-table
hash-table
)))
(
declare
(
simple-vector
vector
))
(
setf
(
hash-table-number-entries
hash-table
)
0
)
(
do
((
i
0
(
1+
i
))
(
size
(
hash-table-size
hash-table
)))
((
=
i
size
)
hash-table
)
(
declare
(
fixnum
i
size
))
(
setf
(
aref
vector
i
)
nil
))))
(
defun
hash-table-count
(
hash-table
)
"Returns the number of entries in the given Hash-Table."
(
hash-table-number-entries
hash-table
))
;;;
Primitive Hash F
unction
;;;
; SXHASH and support f
unction
s
;;; The maximum length and depth to which we hash lists.
(
defconstant
sxhash-max-len
7
)
...
...
@@ -469,57 +509,20 @@
(
t
42
)))
;;;; WITH-HASH-TABLE-ITERATOR
(
defmacro
with-hash-table-iterator
((
function
hash-table
)
&body
body
)
"WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
provides a method of manually looping over the elements of a hash-table.
function is bound to a generator-macro that, withing the scope of the
invocation, returns three values. First, whether there are any more objects
in the hash-table, second, the key, and third, the value."
(
let
((
counter
(
gensym
))
(
pointer
(
gensym
))
(
table
(
gensym
))
(
size
(
gensym
))
(
the-table
(
gensym
)))
`
(
let*
((
,
the-table
,
hash-table
)
(
,
table
(
hash-table-table
,
the-table
))
(
,
size
(
hash-table-size
,
the-table
))
(
,
counter
0
)
(
,
pointer
nil
))
(
macrolet
((
,
function
()
`
(
loop
(
when
(
=
,
',counter
,
',size
)
(
return
))
(
let
((
bucket
(
or
,
',pointer
(
aref
,
',table
,
',counter
))))
(
when
bucket
(
cond
((
cdr
bucket
)
(
setf
,
',pointer
(
cdr
bucket
)))
(
t
(
setf
,
',pointer
nil
)
(
incf
,
',counter
)))
(
return
(
values
t
(
caar
bucket
)
(
cdar
bucket
)))))
(
incf
,
',counter
))))
,@
body
))))
;;;; Dumping one as a constant.
(
defun
make-hash-table-load-form
(
table
)
(
values
`
(
make-hash-table
:test
',
(
hash-table-
kind
table
)
:size
',
(
hash-table-size
table
)
:test
',
(
hash-table-
test
table
)
:size
',
(
hash-table-size
table
)
:hash-table-rehash-size
',
(
hash-table-rehash-size
table
)
:hash-table-rehash-threshold
',
(
hash-table-rehash-threshold
table
))
(
let
((
sets
nil
))
(
with-hash-table-iterator
(
next
table
)
(
loop
(
multiple-value-bind
(
more
key
value
)
(
next
)
(
if
more
(
setf
sets
(
list*
`
(
gethash
',key
,
table
)
`
',value
sets
))
(
return
)))))
(
declare
(
inline
maphash
))
(
maphash
#'
(
lambda
(
key
value
)
(
setf
sets
(
list*
`
(
gethash
',key
,
table
)
`
',value
sets
)))
table
)
(
if
sets
`
(
setf
,@
sets
)
nil
))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment