mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add `(ice-9 vlist)'.

Browse source 
* module/ice-9/vlist.scm, test-suite/tests/vlist.test,
  benchmark-suite/benchmarks/vlists.bm: New files.

* module/Makefile.am (ICE_9_SOURCES): Add `vlist.scm'.

* test-suite/Makefile.am (SCM_TESTS): Add `tests/vlist.test'.

* benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add
  `benchmarks/vlists.bm'.

* doc/ref/api-compound.texi (VLists, VHashes): New nodes.
This commit is contained in:
Ludovic Courtès 2010-02-02 23:57:02 +01:00
parent 30a700c8c1
commit 22ec6a31ed
7 changed files with 1183 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

3
benchmark-suite/Makefile.am
View file

@ -7,7 +7,8 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/structs.bm \
benchmarks/subr.bm \
benchmarks/uniform-vector-read.bm \
benchmarks/vectors.bm
benchmarks/vectors.bm \
benchmarks/vlists.bm
EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
ChangeLog-2008

103
benchmark-suite/benchmarks/vlists.bm Normal file
View file

@ -0,0 +1,103 @@
;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; VLists.
;;;
;;; Copyright 2009 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 3, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this software; see the file COPYING.LESSER. If
;;; not, write to the Free Software Foundation, Inc., 51 Franklin
;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmarks vlists)
:use-module (srfi srfi-1)
:use-module (ice-9 vlist)
:use-module (benchmark-suite lib))
;; Note: Use `--iteration-factor' to change this.
(define iterations 2000000)
;; The size of large lists.
(define %list-size 700000)
(define %big-list (make-list %list-size))
(define %big-vlist (list->vlist %big-list))
(define-syntax comparative-benchmark
(syntax-rules ()
((_ benchmark-name iterations
((api ((name value) ...)))
body ...)
(benchmark (format #f "~A (~A)" benchmark-name 'api)
iterations
(let ((name value) ...)
body ...)))
((_ benchmark-name iterations
((api bindings) apis ...)
body ...)
(begin
(comparative-benchmark benchmark-name iterations
((api bindings))
body ...)
(comparative-benchmark benchmark-name iterations
(apis ...)
body ...)))))
(with-benchmark-prefix "constructors"
(comparative-benchmark "cons" 2
((srfi-1 ((cons cons) (null '())))
(vlist ((cons vlist-cons) (null vlist-null))))
(let loop ((i %list-size)
(r null))
(and (> i 0)
(loop (1- i) (cons #t r)))))
(comparative-benchmark "acons" 2
((srfi-1 ((acons alist-cons) (null '())))
(vlist ((acons vhash-cons) (null vlist-null))))
(let loop ((i %list-size)
(r null))
(if (zero? i)
r
(loop (1- i) (acons i i r))))))
(define %big-alist
(let loop ((i %list-size) (res '()))
(if (zero? i)
res
(loop (1- i) (alist-cons i i res)))))
(define %big-vhash
(let loop ((i %list-size) (res vlist-null))
(if (zero? i)
res
(loop (1- i) (vhash-cons i i res)))))
(with-benchmark-prefix "iteration"
(comparative-benchmark "fold" 2
((srfi-1 ((fold fold) (lst %big-list)))
(vlist ((fold vlist-fold) (lst %big-vlist))))
(fold (lambda (x y) y) #t lst))
(comparative-benchmark "assoc" 70
((srfi-1 ((assoc assoc) (alst %big-alist)))
(vhash ((assoc vhash-assoc) (alst %big-vhash))))
(let loop ((i (quotient %list-size 3)))
(and (> i 0)
(begin
(assoc i alst)
(loop (- i 5000)))))))

280
doc/ref/api-compound.texi
View file

@ -25,10 +25,12 @@ values can be looked up within them.
* Bit Vectors:: Vectors of bits.
* Generalized Vectors:: Treating all vector-like things uniformly.
* Arrays:: Matrices, etc.
* VLists:: Vector-like lists.
* Records::
* Structures::
* Dictionary Types:: About dictionary types in general.
* Association Lists:: List-based dictionaries.
* VHashes:: VList-based dictionaries.
* Hash Tables:: Table-based dictionaries.
@end menu
@ -2086,6 +2088,172 @@ reading and writing. You must take care not to modify bits outside of
the allowed index range of the array, even for contiguous arrays.
@end deftypefn
@node VLists
@subsection VLists
@cindex vlist
The @code{(ice-9 vlist)} module provides an implementation of the @dfn{VList}
data structure designed by Phil Bagwell in 2002. VLists are immutable lists,
which can contain any Scheme object. They improve on standard Scheme linked
lists in several areas:
@itemize
@item
Random access has typically constant-time complexity.
@item
Computing the length of a VList has time complexity logarithmic in the number of
elements.
@item
VLists use less storage space than standard lists.
@item
VList elements are stored in contiguous regions, which improves memory locality
and leads to more efficient use of hardware caches.
@end itemize
The idea behind VLists is to store vlist elements in increasingly large
contiguous blocks (implemented as vectors here). These blocks are linked to one
another using a pointer to the next block and an offset within that block. The
size of these blocks form a geometric series with ratio
@code{block-growth-factor} (2 by default).
The VList structure also serves as the basis for the @dfn{VList-based hash
lists} or ``vhashes'', an immutable dictionary type (@pxref{VHashes}).
However, the current implementation in @code{(ice-9 vlist)} has several
noteworthy shortcomings:
@itemize
@item
It is @emph{not} thread-safe. Although operations on vlists are all
@dfn{referentially transparent} (i.e., purely functional), adding elements to a
vlist with @code{vlist-cons} mutates part of its internal structure, which makes
it non-thread-safe. This could be fixed, but it would slow down
@code{vlist-cons}.
@item
@code{vlist-cons} always allocates at least as much memory as @code{cons}.
Again, Phil Bagwell describes how to fix it, but that would require tuning the
garbage collector in a way that may not be generally beneficial.
@item
@code{vlist-cons} is a Scheme procedure compiled to bytecode, and it does not
compete with the straightforward C implementation of @code{cons}, and with the
fact that the VM has a special @code{cons} instruction.
@end itemize
We hope to address these in the future.
The programming interface exported by @code{(ice-9 vlist)} is defined below.
Most of it is the same as SRFI-1 with an added @code{vlist-} prefix to function
names.
@deffn {Scheme Procedure} vlist? obj
Return true if @var{obj} is a VList.
@end deffn
@defvr {Scheme Variable} vlist-null
The empty VList. Note that it's possible to create an empty VList not
@code{eq?} to @code{vlist-null}; thus, callers should always use
@code{vlist-null?} when testing whether a VList is empty.
@end defvr
@deffn {Scheme Procedure} vlist-null? vlist
Return true if @var{vlist} is empty.
@end deffn
@deffn {Scheme Procedure} vlist-cons item vlist
Return a new vlist with @var{item} as its head and @var{vlist} as its tail.
@end deffn
@deffn {Scheme Procedure} vlist-head vlist
Return the head of @var{vlist}.
@end deffn
@deffn {Scheme Procedure} vlist-tail vlist
Return the tail of @var{vlist}.
@end deffn
@defvr {Scheme Variable} block-growth-factor
A fluid that defines the growth factor of VList blocks, 2 by default.
@end defvr
The functions below provide the usual set of higher-level list operations.
@deffn {Scheme Procedure} vlist-fold proc init vlist
@deffnx {Scheme Procedure} vlist-fold-right proc init vlist
Fold over @var{vlist}, calling @var{proc} for each element, as for SRFI-1
@code{fold} and @code{fold-right} (@pxref{SRFI-1, @code{fold}}).
@end deffn
@deffn {Scheme Procedure} vlist-ref vlist index
Return the element at index @var{index} in @var{vlist}. This is typically a
constant-time operation.
@end deffn
@deffn {Scheme Procedure} vlist-length vlist
Return the length of @var{vlist}. This is typically logarithmic in the number
of elements in @var{vlist}.
@end deffn
@deffn {Scheme Procedure} vlist-reverse vlist
Return a new @var{vlist} whose content are those of @var{vlist} in reverse
order.
@end deffn
@deffn {Scheme Procedure} vlist-map proc vlist
Map @var{proc} over the elements of @var{vlist} and return a new vlist.
@end deffn
@deffn {Scheme Procedure} vlist-for-each proc vlist
Call @var{proc} on each element of @var{vlist}. The result is unspecified.
@end deffn
@deffn {Scheme Procedure} vlist-drop vlist count
Return a new vlist that does not contain the @var{count} first elements of
@var{vlist}. This is typically a constant-time operation.
@end deffn
@deffn {Scheme Procedure} vlist-take vlist count
Return a new vlist that contains only the @var{count} first elements of
@var{vlist}.
@end deffn
@deffn {Scheme Procedure} vlist-filter pred vlist
Return a new vlist containing all the elements from @var{vlist} that satisfy
@var{pred}.
@end deffn
@deffn {Scheme Procedure} vlist-delete x vlist [equal?]
Return a new vlist corresponding to @var{vlist} without the elements
@var{equal?} to @var{x}.
@end deffn
@deffn {Scheme Procedure} vlist-unfold p f g seed [tail-gen]
@deffnx {Scheme Procedure} vlist-unfold-right p f g seed [tail]
Return a new vlist, as for SRFI-1 @code{unfold} and @code{unfold-right}
(@pxref{SRFI-1, @code{unfold}}).
@end deffn
@deffn {Scheme Procedure} vlist-append vlists ...
Append the given vlists and return the resulting vlist.
@end deffn
@deffn {Scheme Procedure} list->vlist lst
Return a new vlist whose contents correspond to @var{lst}.
@end deffn
@deffn {Scheme Procedure} vlist->list vlist
Return a new list whose contents match those of @var{vlist}.
@end deffn
@node Records
@subsection Records
@ -3030,6 +3198,118 @@ capitals
("Florida" . "Tallahassee"))
@end lisp
@node VHashes
@subsection VList-Based Hash Lists or ``VHashes''
@cindex VList-based hash lists
@cindex VHash
The @code{(ice-9 vlist)} module provides an implementation of @dfn{VList-based
hash lists} (@pxref{VLists}). VList-based hash lists, or @dfn{vhashes}, are an
immutable dictionary type similar to association lists that maps @dfn{keys} to
@dfn{values}. However, unlike association lists, accessing a value given its
key is typically a constant-time operation.
The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as
that of association lists found in SRFI-1, with procedure names prefixed by
@code{vhash-} instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
In addition, vhashes can be manipulated using VList operations:
@example
(vlist-head (vhash-consq 'a 1 vlist-null))
@result{} (a . 1)
(define vh1 (vhash-consq 'b 2 (vhash-consq 'a 1 vlist-null)))
(define vh2 (vhash-consq 'c 3 (vlist-tail vh1)))
(vhash-assq 'a vh2)
@result{} (a . 1)
(vhash-assq 'b vh2)
@result{} #f
(vhash-assq 'c vh2)
@result{} (c . 3)
(vlist->list vh2)
@result{} ((c . 3) (a . 1))
@end example
However, keep in mind that procedures that construct new VLists
(@code{vlist-map}, @code{vlist-filter}, etc.) return raw VLists, not vhashes:
@example
(define vh (alist->vhash '((a . 1) (b . 2) (c . 3)) hashq))
(vhash-assq 'a vh)
@result{} (a . 1)
(define vl
;; This will create a raw vlist.
(vlist-filter (lambda (key+value) (odd? (cdr key+value))) vh))
(vhash-assq 'a vl)
@result{} ERROR: Wrong type argument in position 2
(vlist->list vl)
@result{} ((a . 1) (c . 3))
@end example
@deffn {Scheme Procedure} vhash? obj
Return true if @var{obj} is a vhash.
@end deffn
@deffn {Scheme Procedure} vhash-cons key value vhash [hash-proc]
@deffnx {Scheme Procedure} vhash-consq key value vhash
@deffnx {Scheme Procedure} vhash-consv key value vhash
Return a new hash list based on @var{vhash} where @var{key} is associated with
@var{value}, using @var{hash-proc} to compute the hash of @var{key}.
@var{vhash} must be either @code{vlist-null} or a vhash returned by a previous
call to @code{vhash-cons}. @var{hash-proc} defaults to @code{hash} (@pxref{Hash
Table Reference, @code{hash} procedure}). With @code{vhash-consq}, the
@code{hashq} hash function is used; with @code{vhash-consv} the @code{hashv}
hash function is used.
All @code{vhash-cons} calls made to construct a vhash should use the same
@var{hash-proc}. Failing to do that, the result is undefined.
@end deffn
@deffn {Scheme Procedure} vhash-assoc key vhash [equal? [hash-proc]]
@deffnx {Scheme Procedure} vhash-assq key vhash
@deffnx {Scheme Procedure} vhash-assv key vhash
Return the first key/value pair from @var{vhash} whose key is equal to @var{key}
according to the @var{equal?} equality predicate (which defaults to
@code{equal?}), and using @var{hash-proc} (which defaults to @code{hash}) to
compute the hash of @var{key}. The second form uses @code{eq?} as the equality
predicate and @code{hashq} as the hash function; the last form uses @code{eqv?}
and @code{hashv}.
Note that it is important to consistently use the same hash function for
@var{hash-proc} as was passed to @code{vhash-cons}. Failing to do that, the
result is unpredictable.
@end deffn
@deffn {Scheme Procedure} vhash-delete key vhash [equal? [hash-proc]]
@deffnx {Scheme Procedure} vhash-delq key vhash
@deffnx {Scheme Procedure} vhash-delv key vhash
Remove all associations from @var{vhash} with @var{key}, comparing keys with
@var{equal?} (which defaults to @code{equal?}), and computing the hash of
@var{key} using @var{hash-proc} (which defaults to @code{hash}). The second
form uses @code{eq?} as the equality predicate and @code{hashq} as the hash
function; the last one uses @code{eqv?} and @code{hashv}.
Again the choice of @var{hash-proc} must be consistent with previous calls to
@code{vhash-cons}.
@end deffn
@deffn {Scheme Procedure} vhash-fold proc vhash
Fold over the key/pair elements of @var{vhash}. For each pair call @var{proc}
as @code{(@var{proc} key value result)}.
@end deffn
@deffn {Scheme Procedure} alist->vhash alist [hash-proc]
Return the vhash corresponding to @var{alist}, an association list, using
@var{hash-proc} to compute key hashes. When omitted, @var{hash-proc} defaults
to @code{hash}.
@end deffn
@node Hash Tables
@subsection Hash Tables
@tpindex Hash Tables

3
module/Makefile.am
View file

@ -225,7 +225,8 @@ ICE_9_SOURCES = \
ice-9/deprecated.scm \
ice-9/list.scm \
ice-9/serialize.scm \
ice-9/gds-server.scm
ice-9/gds-server.scm \
ice-9/vlist.scm
SRFI_SOURCES = \
srfi/srfi-1.scm \

492
module/ice-9/vlist.scm Normal file
View file

@ -0,0 +1,492 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
vlist-null list->vlist vlist-ref vlist-drop vlist-take
vlist-length vlist-fold vlist-fold-right vlist-map
vlist-unfold vlist-unfold-right vlist-append
vlist-reverse vlist-filter vlist-delete vlist->list
vlist-for-each
block-growth-factor
vhash? vhash-cons vhash-consq vhash-consv
vhash-assoc vhash-assq vhash-assv
vhash-delete vhash-fold alist->vhash))
;;; Author: Ludovic Courtès <ludo@gnu.org>
;;;
;;; Commentary:
;;;
;;; This module provides an implementations of vlists, a functional list-like
;;; data structure described by Phil Bagwell in "Fast Functional Lists,
;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report,
;;; 2002.
;;;
;;; The idea is to store vlist elements in increasingly large contiguous blocks
;;; (implemented as vectors here). These blocks are linked to one another using
;;; a pointer to the next block (called `block-base' here) and an offset within
;;; that block (`block-offset' here). The size of these blocks form a geometric
;;; series with ratio `block-growth-factor'.
;;;
;;; In the best case (e.g., using a vlist returned by `list->vlist'),
;;; elements from the first half of an N-element vlist are accessed in O(1)
;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only
;;; O(ln(N)). Furthermore, the data structure improves data locality since
;;; vlist elements are adjacent, which plays well with caches.
;;;
;;; Code:
;;;
;;; VList Blocks and Block Descriptors.
;;;
(define block-growth-factor
(let ((f (make-fluid)))
(fluid-set! f 2)
f))
(define-syntax define-inline
;; Work around the lack of an inliner.
(syntax-rules ()
((_ (name formals ...) body ...)
(define-syntax name
(syntax-rules ()
((_ formals ...)
body ...))))))
(define-inline (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE
;; at OFFSET. If HASH-TAB? is true, a "hash table" is also added.
;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
;; XXX: We could improve locality here by having a single vector but currently
;; the extra arithmetic outweighs the benefits (!).
(vector (make-vector size)
base offset size 0
(and hash-tab? (make-vector size #f))))
(define-syntax define-block-accessor
(syntax-rules ()
((_ name index)
(define-inline (name block)
(vector-ref block index)))))
(define-block-accessor block-content 0)
(define-block-accessor block-base 1)
(define-block-accessor block-offset 2)
(define-block-accessor block-size 3)
(define-block-accessor block-next-free 4)
(define-block-accessor block-hash-table 5)
(define-inline (increment-block-next-free! block)
(vector-set! block 4
(+ (block-next-free block) 1)))
(define-inline (block-append! block value)
;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
(let ((offset (block-next-free block)))
(increment-block-next-free! block)
(vector-set! (block-content block) offset value)
#t))
(define-inline (block-ref block offset)
(vector-ref (block-content block) offset))
(define-inline (block-ref* block offset)
(let ((v (block-ref block offset)))
(if (block-hash-table block)
(car v) ;; hide the vhash link
v)))
(define-inline (block-hash-table-ref block offset)
(vector-ref (block-hash-table block) offset))
(define-inline (block-hash-table-set! block offset value)
(vector-set! (block-hash-table block) offset value))
(define block-null
;; The null block.
(make-block #f 0 0 #f))
;;;
;;; VLists.
;;;
(define-record-type <vlist>
;; A vlist is just a base+offset pair pointing to a block.
;; XXX: Allocating a <vlist> record in addition to the block at each
;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it
;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
;; performance hit for everyone.
(make-vlist base offset)
vlist?
(base vlist-base)
(offset vlist-offset))
(define vlist-null
;; The empty vlist.
(make-vlist block-null 0))
(define-inline (block-cons item vlist hash-tab?)
(let loop ((base (vlist-base vlist))
(offset (+ 1 (vlist-offset vlist))))
(if (and (< offset (block-size base))
(= offset (block-next-free base))
(block-append! base item))
(make-vlist base offset)
(let ((size (cond ((eq? base block-null) 1)
((< offset (block-size base))
;; new vlist head
1)
(else
(* (fluid-ref block-growth-factor)
(block-size base))))))
;; Prepend a new block pointing to BASE.
(loop (make-block base (- offset 1) size hash-tab?)
0)))))
(define (vlist-cons item vlist)
"Return a new vlist with @var{item} as its head and @var{vlist} as its
tail."
;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
;; doesn't box ITEM so that it can have the hidden "next" link used by
;; vhash items, and it passes `#f' as the HASH-TAB? argument to
;; `block-cons'. However, inserting all the checks here has an important
;; performance penalty, hence this choice.
(block-cons item vlist #f))
(define (vlist-head vlist)
"Return the head of @var{vlist}."
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(block-ref* base offset)))
(define (vlist-tail vlist)
"Return the tail of @var{vlist}."
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (> offset 0)
(make-vlist base (- offset 1))
(make-vlist (block-base base)
(block-offset base)))))
(define (vlist-null? vlist)
"Return true if @var{vlist} is empty."
(let ((base (vlist-base vlist)))
(and (not (block-base base))
(= 0 (block-size base)))))
;;;
;;; VList Utilities.
;;;
(define (list->vlist lst)
"Return a new vlist whose contents correspond to @var{lst}."
(vlist-reverse (fold vlist-cons vlist-null lst)))
(define (vlist-fold proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element."
;; FIXME: Handle multiple lists.
(let loop ((base (vlist-base vlist))
(offset (vlist-offset vlist))
(result init))
(if (eq? base block-null)
result
(let* ((next (- offset 1))
(done? (< next 0)))
(loop (if done? (block-base base) base)
(if done? (block-offset base) next)
(proc (block-ref* base offset) result))))))
(define (vlist-fold-right proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element, starting from
the last element."
(vlist-fold proc init (vlist-reverse vlist)))
(define (vlist-reverse vlist)
"Return a new @var{vlist} whose content are those of @var{vlist} in reverse
order."
(vlist-fold vlist-cons vlist-null vlist))
(define (vlist-map proc vlist)
"Map @var{proc} over the elements of @var{vlist} and return a new vlist."
(vlist-fold (lambda (item result)
(vlist-cons (proc item) result))
vlist-null
(vlist-reverse vlist)))
(define (vlist->list vlist)
"Return a new list whose contents match those of @var{vlist}."
(vlist-fold-right cons '() vlist))
(define (vlist-ref vlist index)
"Return the element at index @var{index} in @var{vlist}."
(let loop ((index index)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= index offset)
(block-ref* base (- offset index))
(loop (- index offset 1)
(block-base base)
(block-offset base)))))
(define (vlist-drop vlist count)
"Return a new vlist that does not contain the @var{count} first elements of
@var{vlist}."
(let loop ((count count)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= count offset)
(make-vlist base (- offset count))
(loop (- count offset 1)
(block-base base)
(block-offset base)))))
(define (vlist-take vlist count)
"Return a new vlist that contains only the @var{count} first elements of
@var{vlist}."
(let loop ((count count)
(vlist vlist)
(result vlist-null))
(if (= 0 count)
(vlist-reverse result)
(loop (- count 1)
(vlist-tail vlist)
(vlist-cons (vlist-head vlist) result)))))
(define (vlist-filter pred vlist)
"Return a new vlist containing all the elements from @var{vlist} that
satisfy @var{pred}."
(vlist-fold-right (lambda (e v)
(if (pred e)
(vlist-cons e v)
v))
vlist-null
vlist))
(define* (vlist-delete x vlist #:optional (equal? equal?))
"Return a new vlist corresponding to @var{vlist} without the elements
@var{equal?} to @var{x}."
(vlist-filter (lambda (e)
(not (equal? e x)))
vlist))
(define (vlist-length vlist)
"Return the length of @var{vlist}."
(let loop ((base (vlist-base vlist))
(len (vlist-offset vlist)))
(if (eq? base block-null)
len
(loop (block-base base)
(+ len 1 (block-offset base))))))
(define* (vlist-unfold p f g seed
#:optional (tail-gen (lambda (x) vlist-null)))
"Return a new vlist. See the description of SRFI-1 `unfold' for details."
(let uf ((seed seed))
(if (p seed)
(tail-gen seed)
(vlist-cons (f seed)
(uf (g seed))))))
(define* (vlist-unfold-right p f g seed #:optional (tail vlist-null))
"Return a new vlist. See the description of SRFI-1 `unfold-right' for
details."
(let uf ((seed seed) (lis tail))
(if (p seed)
lis
(uf (g seed) (vlist-cons (f seed) lis)))))
(define (vlist-append . vlists)
"Append the given lists."
(if (null? vlists)
vlist-null
(fold-right (lambda (vlist result)
(vlist-fold-right (lambda (e v)
(vlist-cons e v))
result
vlist))
vlist-null
vlists)))
(define (vlist-for-each proc vlist)
"Call @var{proc} on each element of @var{vlist}. The result is unspecified."
(vlist-fold (lambda (item x)
(proc item))
(if #f #f)
vlist))
;;;
;;; Hash Lists, aka. `VHash'.
;;;
;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2
;; associated with K1 and K2, respectively. The resulting layout is a
;; follows:
;;
;; ,--------------------.
;; | ,-> (K1 . V1) ---. |
;; | | | |
;; | | (K2 . V2) <--' |
;; | | |
;; +-|------------------+
;; | | |
;; | | |
;; | `-- O <---------------H
;; | |
;; `--------------------'
;;
;; The bottom part is the "hash table" part of the vhash, as returned by
;; `block-hash-table'; the other half is the data part. O is the offset of
;; the first value associated with a key that hashes to H in the data part.
;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
;; link is handled by `block-ref'.
;; This API potentially requires users to repeat which hash function and which
;; equality predicate to use. This can lead to unpredictable results if they
;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 . OTOH, two
;; arguments can be made in favor of this API:
;;
;; - It's consistent with how alists are handled in SRFI-1.
;;
;; - In practice, users will probably consistenly use either the `q', the `v',
;; or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
;; argument), i.e., they will rarely explicitly pass a hash function or
;; equality predicate.
(define (vhash? obj)
"Return true if @var{obj} is a hash list."
(and (vlist? obj)
(let ((base (vlist-base obj)))
(and base
(vector? (block-hash-table base))))))
(define* (vhash-cons key value vhash #:optional (hash hash))
"Return a new hash list based on @var{vhash} where @var{key} is associated
with @var{value}. Use @var{hash} to compute @var{key}'s hash."
(let* ((key+value (cons key value))
(entry (cons key+value #f))
(vlist (block-cons entry vhash #t))
(base (vlist-base vlist))
(khash (hash key (block-size base))))
(let ((o (block-hash-table-ref base khash)))
(if o (set-cdr! entry o)))
(block-hash-table-set! base khash
(vlist-offset vlist))
vlist))
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
(define-syntax make-vhash-assoc
;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction
;; instead of calling the `eq?' subr.
(syntax-rules ()
((_ key vhash equal? hash)
(begin
(define khash
(let ((size (block-size (vlist-base vhash))))
(and (> size 0) (hash key size))))
(let loop ((base (vlist-base vhash))
(khash khash)
(offset (and khash
(block-hash-table-ref (vlist-base vhash)
khash)))
(max-offset (vlist-offset vhash)))
(let ((answer (and offset (block-ref base offset))))
(cond ((and (pair? answer)
(<= offset max-offset)
(let ((answer-key (caar answer)))
(equal? key answer-key)))
(car answer))
((and (pair? answer) (cdr answer))
=>
(lambda (next-offset)
(loop base khash next-offset max-offset)))
(else
(let ((next-base (block-base base)))
(and next-base
(> (block-size next-base) 0)
(let* ((khash (hash key (block-size next-base)))
(offset (block-hash-table-ref next-base khash)))
(loop next-base khash offset
(block-offset base)))))))))))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to
@var{key} according to the @var{equal?} equality predicate."
(make-vhash-assoc key vhash equal? hash))
(define (vhash-assq key vhash)
"Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
@var{key}."
(make-vhash-assoc key vhash eq? hashq))
(define (vhash-assv key vhash)
"Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
@var{key}."
(make-vhash-assoc key vhash eqv? hashv))
(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
"Remove all associations from @var{vhash} with @var{key}, comparing keys
with @var{equal?}."
(vlist-fold (lambda (k+v result)
(let ((k (car k+v))
(v (cdr k+v)))
(if (equal? k key)
result
(vhash-cons k v result))))
vlist-null
vhash))
(define vhash-delq (cut vhash-delete <> <> eq? hashq))
(define vhash-delv (cut vhash-delete <> <> eqv? hashv))
(define (vhash-fold proc seed vhash)
"Fold over the key/pair elements of @var{vhash}. For each pair call
@var{proc} as @code{(@var{proc} key value result)}."
(vlist-fold (lambda (key+value result)
(proc (car key+value) (cdr key+value)
result))
seed
vhash))
(define* (alist->vhash alist #:optional (hash hash))
"Return the vhash corresponding to @var{alist}, an association list."
(fold-right (lambda (pair result)
(vhash-cons (car pair) (cdr pair) result hash))
vlist-null
alist))
;;; vlist.scm ends here

1
test-suite/Makefile.am
View file

@ -112,6 +112,7 @@ SCM_TESTS = tests/alist.test \
tests/tree-il.test \
tests/unif.test \
tests/version.test \
tests/vlist.test \
tests/weaks.test
EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) ChangeLog-2008

303
test-suite/tests/vlist.test Normal file
View file

@ -0,0 +1,303 @@
;;;; vlist.test --- VLists. -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-vlist)
:use-module (test-suite lib)
:use-module (ice-9 vlist)
:use-module (srfi srfi-1))
;;;
;;; VLists.
;;;
(with-test-prefix "vlist"
(pass-if "vlist?"
(and (vlist? vlist-null)
(vlist? (vlist-cons 'a vlist-null))))
(pass-if "vlist-null?"
(vlist-null? vlist-null))
(pass-if "vlist-cons"
(let* ((v1 (vlist-cons 1 vlist-null))
(v2 (vlist-cons 2 v1))
(v3 (vlist-cons 3 v2))
(v4 (vlist-cons 4 v3)))
(every vlist? (list v1 v2 v3 v4))))
(pass-if "vlist-head"
(let* ((v1 (vlist-cons 1 vlist-null))
(v2 (vlist-cons 2 v1))
(v3 (vlist-cons 3 v2))
(v4 (vlist-cons 4 v3)))
(equal? (map vlist-head (list v1 v2 v3 v4))
'(1 2 3 4))))
(pass-if "vlist-tail"
(let* ((v1 (vlist-cons 1 vlist-null))
(v2 (vlist-cons 2 v1))
(v3 (vlist-cons 3 v2))
(v4 (vlist-cons 4 v3)))
(equal? (map vlist-head
(map vlist-tail (list v2 v3 v4)))
'(1 2 3))))
(pass-if "vlist->list"
(let* ((v1 (vlist-cons 1 vlist-null))
(v2 (vlist-cons 2 v1))
(v3 (vlist-cons 3 v2))
(v4 (vlist-cons 4 v3)))
(equal? '(4 3 2 1)
(vlist->list v4))))
(pass-if "list->vlist"
(equal? (vlist->list (list->vlist '(1 2 3 4 5)))
'(1 2 3 4 5)))
(pass-if "vlist-drop"
(equal? (vlist->list (vlist-drop (list->vlist (iota 77)) 7))
(drop (iota 77) 7)))
(pass-if "vlist-cons2"
;; Example from Bagwell's paper, Figure 2.
(let* ((top (list->vlist '(8 7 6 5 4 3)))
(part (vlist-tail (vlist-tail top)))
(test (vlist-cons 9 part)))
(equal? (vlist->list test)
'(9 6 5 4 3))))
(pass-if "vlist-cons3"
(let ((vlst (vlist-cons 'a
(vlist-cons 'b
(vlist-drop (list->vlist (iota 5))
3)))))
(equal? (vlist->list vlst)
'(a b 3 4))))
(pass-if "vlist-map"
(equal? (vlist->list (vlist-map 1+ (list->vlist '(1 2 3 4 5))))
'(2 3 4 5 6)))
(pass-if "vlist-length"
(= (vlist-length (list->vlist (iota 77)))
77))
(pass-if "vlist-length complex"
(= (vlist-length (fold vlist-cons
(vlist-drop (list->vlist (iota 77)) 33)
(iota (- 33 7))))
70))
(pass-if "vlist-ref"
(let* ((indices (iota 111))
(vlst (list->vlist indices)))
(equal? (map (lambda (i)
(vlist-ref vlst i))
indices)
indices)))
(pass-if "vlist-ref degenerate"
;; Degenerate case where VLST contains only 1-element blocks.
(let* ((indices (iota 111))
(vlst (fold (lambda (i vl)
(let ((vl (vlist-cons 'x vl)))
(vlist-cons i (vlist-tail vl))))
vlist-null
indices)))
(equal? (map (lambda (i)
(vlist-ref vlst i))
(reverse indices))
indices)))
(pass-if "vlist-filter"
(let* ((lst (iota 33))
(vlst (fold-right vlist-cons vlist-null lst)))
(equal? (vlist->list (vlist-filter even? vlst))
(filter even? lst))))
(pass-if "vlist-delete"
(let* ((lst '(a b c d e))
(vlst (fold-right vlist-cons vlist-null lst)))
(equal? (vlist->list (vlist-delete 'c vlst))
(delete 'c lst))))
(pass-if "vlist-take"
(let* ((lst (iota 77))
(vlst (fold-right vlist-cons vlist-null lst)))
(equal? (vlist->list (vlist-take vlst 44))
(take lst 44))))
(pass-if "vlist-unfold"
(let ((results (map (lambda (unfold)
(unfold (lambda (i) (> i 100))
(lambda (i) i)
(lambda (i) (+ i 1))
0))
(list unfold vlist-unfold))))
(equal? (car results)
(vlist->list (cadr results)))))
(pass-if "vlist-append"
(let* ((lists '((a) (b c) (d e f) (g)))
(vlst (apply vlist-append (map list->vlist lists)))
(lst (apply append lists)))
(equal? lst (vlist->list vlst)))))
;;;
;;; VHash.
;;;
(with-test-prefix "vhash"
(pass-if "vhash?"
(vhash? (vhash-cons "hello" "world" vlist-null)))
(pass-if "vhash-assoc vlist-null"
(not (vhash-assq 'a vlist-null)))
(pass-if "vhash-assoc simple"
(let ((vh (vhash-cons "hello" "world" vlist-null)))
(equal? (cons "hello" "world")
(vhash-assoc "hello" vh))))
(pass-if "vhash-assoc regular"
(let* ((keys '(a b c d e f g h i))
(values '(1 2 3 4 5 6 7 8 9))
(vh (fold vhash-cons vlist-null keys values)))
(fold (lambda (k v result)
(and result
(equal? (cons k v)
(vhash-assoc k vh eq?))))
#t
keys
values)))
(pass-if "vhash-assoc tail"
(let* ((keys '(a b c d e f g h i))
(values '(1 2 3 4 5 6 7 8 9))
(vh1 (fold vhash-consq vlist-null keys values))
(vh2 (vhash-consq 'x 'x (vlist-tail vh1))))
(and (fold (lambda (k v result)
(and result
(equal? (cons k v)
(vhash-assq k vh2))))
#t
(cons 'x (delq 'i keys))
(cons 'x (delv 9 values)))
(not (vhash-assq 'i vh2)))))
(pass-if "vhash-assoc degenerate"
(let* ((keys '(a b c d e f g h i))
(values '(1 2 3 4 5 6 7 8 9))
(vh (fold (lambda (k v vh)
;; Degenerate case where VH2 contains only
;; 1-element blocks.
(let* ((vh1 (vhash-cons 'x 'x vh))
(vh2 (vlist-tail vh1)))
(vhash-cons k v vh2)))
vlist-null keys values)))
(and (fold (lambda (k v result)
(and result
(equal? (cons k v)
(vhash-assq k vh))))
#t
keys
values)
(not (vhash-assq 'x vh)))))
(pass-if "vhash as vlist"
(let* ((keys '(a b c d e f g h i))
(values '(1 2 3 4 5 6 7 8 9))
(vh (fold vhash-cons vlist-null keys values))
(alist (fold alist-cons '() keys values)))
(and (equal? (vlist->list vh) alist)
(= (length alist) (vlist-length vh))
(fold (lambda (i result)
(and result
(equal? (list-ref alist i)
(vlist-ref vh i))))
#t
(iota (vlist-length vh))))))
(pass-if "vhash entry shadowed"
(let* ((a (vhash-consq 'a 1 vlist-null))
(b (vhash-consq 'a 2 a)))
(and (= 1 (cdr (vhash-assq 'a a)))
(= 2 (cdr (vhash-assq 'a b)))
(= 1 (cdr (vhash-assq 'a (vlist-tail b)))))))
(pass-if "vlist-filter"
(let* ((keys '(a b c d e f g h i))
(values '(1 2 3 4 5 6 7 8 9))
(vh (fold vhash-cons vlist-null keys values))
(alist (fold alist-cons '() keys values))
(pred (lambda (k+v)
(case (car k+v)
((c f) #f)
(else #t)))))
(let ((vh (vlist-filter pred vh))
(alist (filter pred alist)))
(and (equal? (vlist->list vh) alist)
(= (length alist) (vlist-length vh))
(fold (lambda (i result)
(and result
(equal? (list-ref alist i)
(vlist-ref vh i))))
#t
(iota (vlist-length vh)))))))
(pass-if "vhash-delete"
(let* ((keys '(a b c d e f g d h i))
(values '(1 2 3 4 5 6 7 0 8 9))
(vh (fold vhash-cons vlist-null keys values))
(alist (fold alist-cons '() keys values)))
(let ((vh (vhash-delete 'd vh))
(alist (alist-delete 'd alist)))
(and (= (length alist) (vlist-length vh))
(fold (lambda (k result)
(and result
(equal? (assq k alist)
(vhash-assoc k vh eq?))))
#t
keys)))))
(pass-if "vhash-fold"
(let* ((keys '(a b c d e f g d h i))
(values '(1 2 3 4 5 6 7 0 8 9))
(vh (fold vhash-cons vlist-null keys values))
(alist (fold alist-cons '() keys values)))
(equal? alist (reverse (vhash-fold alist-cons '() vh)))))
(pass-if "alist->vhash"
(let* ((keys '(a b c d e f g d h i))
(values '(1 2 3 4 5 6 7 0 8 9))
(alist (fold alist-cons '() keys values))
(vh (alist->vhash alist))
(alist2 (vlist-fold cons '() vh)))
(and (equal? alist (reverse alist2))
(fold (lambda (k result)
(and result
(equal? (assq k alist)
(vhash-assoc k vh eq?))))
#t
keys)))))