mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +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/structs.bm \
benchmarks/subr.bm \ benchmarks/subr.bm \
benchmarks/uniform-vector-read.bm \ benchmarks/uniform-vector-read.bm \
benchmarks/vectors.bm benchmarks/vectors.bm \
benchmarks/vlists.bm
EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \ EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
ChangeLog-2008 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. * Bit Vectors:: Vectors of bits.
* Generalized Vectors:: Treating all vector-like things uniformly. * Generalized Vectors:: Treating all vector-like things uniformly.
* Arrays:: Matrices, etc. * Arrays:: Matrices, etc.
* VLists:: Vector-like lists.
* Records:: * Records::
* Structures:: * Structures::
* Dictionary Types:: About dictionary types in general. * Dictionary Types:: About dictionary types in general.
* Association Lists:: List-based dictionaries. * Association Lists:: List-based dictionaries.
* VHashes:: VList-based dictionaries.
* Hash Tables:: Table-based dictionaries. * Hash Tables:: Table-based dictionaries.
@end menu @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. the allowed index range of the array, even for contiguous arrays.
@end deftypefn @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 @node Records
@subsection Records @subsection Records
@ -3030,6 +3198,118 @@ capitals
("Florida" . "Tallahassee")) ("Florida" . "Tallahassee"))
@end lisp @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 @node Hash Tables
@subsection Hash Tables @subsection Hash Tables
@tpindex Hash Tables @tpindex Hash Tables

3
module/Makefile.am
View file

@ -225,7 +225,8 @@ ICE_9_SOURCES = \
ice-9/deprecated.scm \ ice-9/deprecated.scm \
ice-9/list.scm \ ice-9/list.scm \
ice-9/serialize.scm \ ice-9/serialize.scm \
ice-9/gds-server.scm ice-9/gds-server.scm \
ice-9/vlist.scm
SRFI_SOURCES = \ SRFI_SOURCES = \
srfi/srfi-1.scm \ 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/tree-il.test \
tests/unif.test \ tests/unif.test \
tests/version.test \ tests/version.test \
tests/vlist.test \
tests/weaks.test tests/weaks.test
EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) ChangeLog-2008 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)))))