~amirouche/guile-babelia

81c7b51180dbb5f296d2a67e9cd76a2c8a92c38e — Amirouche 2 years ago 67dace0 master
demo day is near
M babelia.scm => babelia.scm +1 -1
@@ 104,7 104,7 @@

(match (cddr (program-arguments))
  (`("benchmark" . ,keywords)
   (pk "average in milliseconds" (benchmark directory (string-join keywords " "))))
   (pk "average in milliseconds" (benchmark app (string-join keywords " "))))
  (`("word" "counter")
   (for-each print (fts-word-counter okvs fts)))
  (`("stem" "counter")

M babelia/crawler.scm => babelia/crawler.scm +7 -16
@@ 11,6 11,7 @@
(import (web response))
(import (web uri))
(import (ice-9 match))
(import (ice-9 iconv))
(import (only (sxml xpath) sxpath))

(import (babelia fash))


@@ 115,7 116,6 @@

(define (crawler-run app remote)
  (let loop0 ()
    (pk 'loop0)
    (let ((todos (crawler-todo-ref app)))
      (let loop1 ((todos todos))
        (unless (null? todos)


@@ 125,7 125,6 @@
    (loop0)))

(define-public (subcommand-crawler-run app port remote)
  (pool-init)
  (log-debug "running crawler server on PORT" port)
  (run-server (lambda (request body) (router/guard app request body))
              #:port port


@@ 139,22 138,14 @@

(define (valid? url)
  (let ((response (head url)))
    (and (= (response-code response) 200)
         ;; somekind of html content
         (and=> (assq 'content-type (response-headers response))
                (lambda (content-type)
                  (any (lambda (item)
                         (let ((item (if (symbol? item) (symbol->string item) item)))
                           (string-contains item "text/html")))
                       (cdr content-type))))
         ;; at most 5MB
         (and=> (assq 'content-length (response-headers response))
                (lambda (content-length)
                  (< (cdr content-length) (* 5 1024 1024)))))))
    (= (response-code response)) 200))

(define (get url)
  (call-with-values (lambda () (http-get url))
    (lambda (_ body) body)))
  (call-with-values (lambda () (http-get url #:decode-body? #f))
    (lambda (_ body) (decode body))))

(define (decode bytevector)
  (bytevector->string bytevector "UTF-8" 'substitute))

(define (index remote url document)
  (call-with-values (lambda ()

M babelia/crawler/uri-join.scm => babelia/crawler/uri-join.scm +1 -1
@@ 46,7 46,7 @@
                       ((string-prefix? "http" href) href)
                       ;; same protocol url, prefix the correct protocol
                       ((string-prefix? "//" href)
                        (if (string-prefix? "http://" url)
                        (if (eq? 'http (uri-scheme url))
                            (string-append "http:" href)
                            (string-append "https:" href)))
                       ;; HREF is absolute, suffix domain from URL with HREF

M babelia/okvs/fts.scm => babelia/okvs/fts.scm +1 -4
@@ 184,10 184,7 @@
  (string-truncate (string-single-line string) 280))

(define (valid? title preview)
  (and title
       preview
       (>= (string-length title) 3)
       (>= (string-length preview) 280)))
  #t)

(define-public (fts-index transaction fts html)
  "Index TEXT string with UID as an identifier."

M babelia/stemmer.scm => babelia/stemmer.scm +1 -1
@@ 39,7 39,7 @@
;; bindings

(define snowball-stemmer
  (dynamic-link* "/gnu/store/0x5a6vpkqa3ydxg2s42rpicmsy0fvzrl-stemmer-0.0.0/lib/libstemmer.so"))
  (dynamic-link* "/usr/lib/x86_64-linux-gnu/libstemmer.so.0d"))

(define stemmers
  (let ((proc (snowball-stemmer POINTER "sb_stemmer_list")))

M babelia/wiredtiger.scm => babelia/wiredtiger.scm +2 -0
@@ 153,6 153,7 @@
     (open-cursor ,uintptr_t)
     (alter ,uintptr_t)
     (create ,uintptr_t)
     (import* ,uintptr_t)
     (compact ,uintptr_t)
     (drop ,uintptr_t)
     (join ,uintptr_t)


@@ 170,6 171,7 @@
     (prepare-transaction ,uintptr_t)
     (rollback-transaction ,uintptr_t)
     (timestamp-transaction ,uintptr_t)
     (query-timestamp ,uintptr_t)
     (checkpoint ,uintptr_t)
     (snapshot ,uintptr_t)
     (transaction-pinned-range ,uintptr_t)

M babelia/wiredtiger/config.scm => babelia/wiredtiger/config.scm +1 -1
@@ 1,4 1,4 @@
(define-module (babelia wiredtiger config)
  #:export (%libwiredtiger))

(define %libwiredtiger "/gnu/store/mjsb5rzm72vyrvbrz727mmka7rm1cx19-wiredtiger-3.2.0-0.f08bc4b/lib/libwiredtiger.so")
(define %libwiredtiger "/usr/local/lib/libwiredtiger.so")

M benchmarks.sh => benchmarks.sh +4 -4
@@ 6,16 6,16 @@ guile --version

echo "* search: shepherd"

./babelia.scm benchmark bug-guix/ shepherd
guile -L . babelia.scm bug-guix/ benchmark shepherd

echo "* search: shepherd reboot"

./babelia.scm benchmark bug-guix/ shepherd reboot
guile -L . babelia.scm bug-guix/ benchmark bug-guix/ shepherd reboot

echo "* search: shepherd restart"

./babelia.scm benchmark bug-guix/ shepherd restart
guile -L . babelia.scm bug-guix/ benchmark bug-guix/ shepherd restart

echo "* search: guix"

./babelia.scm benchmark bug-guix/ guix
guile -L . babelia.scm bug-guix/ benchmark bug- guix

A package.scm => package.scm +141 -0
@@ 0,0 1,141 @@
(define-module (gnu packages guile-xyz)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (gnu packages)
  #:use-module (gnu packages algebra)
  #:use-module (gnu packages aspell)
  #:use-module (gnu packages autotools)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages databases)
  #:use-module (gnu packages disk)
  #:use-module (gnu packages emacs)
  #:use-module (gnu packages emacs-xyz)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages gl)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages gperf)
  #:use-module (gnu packages gtk)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages hurd)
  #:use-module (gnu packages image)
  #:use-module (gnu packages imagemagick)
  #:use-module (gnu packages libffi)
  #:use-module (gnu packages libunistring)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages man)
  #:use-module (gnu packages maths)
  #:use-module (gnu packages multiprecision)
  #:use-module (gnu packages ncurses)
  #:use-module (gnu packages networking)
  #:use-module (gnu packages noweb)
  #:use-module (gnu packages nss)
  #:use-module (gnu packages password-utils)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages python)
  #:use-module (gnu packages readline)
  #:use-module (gnu packages sdl)
  #:use-module (gnu packages search)
  #:use-module (gnu packages slang)
  #:use-module (gnu packages sqlite)
  #:use-module (gnu packages swig)
  #:use-module (gnu packages tex)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages version-control)
  #:use-module (gnu packages webkit)
  #:use-module (gnu packages xdisorg)
  #:use-module (gnu packages xorg)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix hg-download)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system guile)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (alist-delete)))

(define-public guile-fibers-fix0
  (let ((commit "e226d477672a9ba86de6e304a6c273cb9c01fc28"))
    (package
     (name "guile-fibers")
     (version "1.0.0-fix0")
     (source (origin
              (method git-fetch)
              (uri (git-reference
                    (url "https://github.com/amirouche/fibers.git")
                    (commit commit)))
              (file-name (string-append name "-" version "-checkout"))
              (sha256
               (base32
                "09xr0r0wmj4imi9z3zcy5dbc617cp4pahb22vbad8jqw49020dlf"))
              (modules '((guix build utils)))
              (snippet
               '(begin
                  ;; Allow builds with Guile 3.0.
                  (substitute* "configure"
                    (("search=\"2\\.2\"")
                     "search=\"3.0 2.2\""))

                  ;; Explicitly include system headers rather than relying on
                  ;; <libguile.h> to do it for us.
                  (substitute* "epoll.c"
                    (("#include.*libguile\\.h.*$" all)
                     (string-append "#include <unistd.h>\n"
                                    "#include <string.h>\n"
                                    all "\n")))

                  ;; Import (ice-9 threads) for 'current-processor-count'.
                  (substitute* "tests/channels.scm"
                    (("#:use-module \\(fibers\\)")
                     (string-append "#:use-module (fibers)\n"
                                    "#:use-module (ice-9 threads)\n")))
                  #t))
              (patches
               ;; fixes a resource leak that causes crashes in the tests
               (search-patches "guile-fibers-destroy-peer-schedulers.patch"))))
    (build-system gnu-build-system)
    (arguments
     '(;; The code uses 'scm_t_uint64' et al., which are deprecated in 3.0.
       #:tests? #f
       #:configure-flags '("CFLAGS=-Wno-error=deprecated-declarations")
       #:phases (modify-phases %standard-phases
                 (add-after 'install 'mode-guile-objects
                    (lambda* (#:key outputs #:allow-other-keys)
                      ;; .go files are installed to "lib/guile/X.Y/cache".
                      ;; This phase moves them to "…/site-ccache".
                      (let* ((out (assoc-ref outputs "out"))
                             (lib (string-append out "/lib/guile"))
                             (old (car (find-files lib "^ccache$"
                                                   #:directories? #t)))
                             (new (string-append (dirname old)
                                                 "/site-ccache")))
                        (rename-file old new)
                        #t))))))
    (native-inputs
     `(("texinfo" ,texinfo)
       ("pkg-config" ,pkg-config)))
    (inputs
     `(("guile" ,guile-3.0)))
    (synopsis "Lightweight concurrency facility for Guile")
    (description
     "Fibers is a Guile library that implements a a lightweight concurrency
facility, inspired by systems like Concurrent ML, Go, and Erlang.  A fiber is
like a \"goroutine\" from the Go language: a lightweight thread-like
abstraction.  Systems built with Fibers can scale up to millions of concurrent
fibers, tens of thousands of concurrent socket connections, and many parallel
cores.  The Fibers library also provides Concurrent ML-like channels for
communication between fibers.

Note that Fibers makes use of some Guile 2.1/2.2-specific features and
is not available for Guile 2.0.")
    (home-page "https://github.com/wingo/fibers")
    (license license:lgpl3+))))


guile-fibers-fix0

M roots.txt => roots.txt +36 -53
@@ 1,53 1,36 @@
http://dynamo.iro.umontreal.ca/
http://git.savannah.gnu.org/cgit/guile.git/tree/
http://git.savannah.gnu.org/cgit/guix.git/tree/
http://ikarus-scheme.org/
http://justinethier.github.io/cyclone/
http://larcenists.org/
http://lists.nongnu.org/archive/html/chicken-announce/
http://lists.nongnu.org/archive/html/chicken-hackers/
http://lists.nongnu.org/archive/html/chicken-users/
http://r7rs.org/
http://sarabander.github.io/sicp/
http://snow-fort.org/
http://sph.mn/
http://synthcode.com/scheme/chibi/
http://www.littlewingpinball.com/doc/en/ypsilon/
http://www.r6rs.org/
http://www.s48.org/
http://www.scheme-reports.org/
http://www.scheme.dk/planet/
https://akkuscm.org/
https://api.call-cc.org/4/doc/
https://bitbucket.org/cowan/r7rs-wg1-infra/
https://bugs.call-cc.org/
https://call-cc.org/
https://cisco.github.io/ChezScheme/
https://cons.io/
https://docs.racket-lang.org/
https://ecraven.github.io/r7rs-benchmarks/
https://ecraven.github.io/r7rs-coverage/
https://eggs.call-cc.org/
https://htdp.org/
https://lists.gnu.org/archive/html/guile-devel/
https://lists.gnu.org/archive/html/guile-user/
https://lists.gnu.org/archive/html/guix-devel/
https://lists.gnu.org/archive/html/help-guix/
https://lists.gnu.org/archive/html/mit-scheme-users/
https://lists.gnu.org/archive/html/bug-guix/
https://lists.gnu.org/archive/html/bug-guile/
https://pkgs.racket-lang.org/
https://practical-scheme.net/
https://racket-lang.org/
https://schemers.org/
https://scsh.net/
https://small.r7rs.org/
https://srfi.schemers.org/
https://wiki.call-cc.org/
https://wiki.call-cc.org/discussion-groups/
https://www-sop.inria.fr/mimosa/fp/Bigloo/
https://www.gnu.org/software/guile
https://www.gnu.org/software/guix
https://www.gnu.org/software/kawa/
https://www.gnu.org/software/mit-scheme/
https://www.scheme.com/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://dynamo.iro.umontreal.ca/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://git.savannah.gnu.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://ikarus-scheme.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://justinethier.github.io/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://larcenists.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://lists.nongnu.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://r7rs.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://snow-fort.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://sph.mn/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://synthcode.com/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://www.littlewingpinball.com/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://www.r6rs.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://www.s48.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://www.scheme-reports.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 http://www.scheme.dk/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://akkuscm.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://api.call-cc.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://bugs.call-cc.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://call-cc.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://scheme.com
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://cons.io/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://docs.racket-lang.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://ecraven.github.io/r7rs-benchmarks/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://ecraven.github.io/r7rs-coverage/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://eggs.call-cc.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://htdp.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://lists.gnu.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://pkgs.racket-lang.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://practical-scheme.net/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://racket-lang.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://schemers.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://scsh.net/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://small.r7rs.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://srfi.schemers.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://wiki.call-cc.org/
guile -L . babelia.scm crawler crawler add http://localhost:8080 https://www.gnu.org/

A snowball-stemmer.scm => snowball-stemmer.scm +92 -0
@@ 0,0 1,92 @@
;; guile-snowball-stemmer
;; Copyright (C) 2019 Amirouche Boubekki <amirouche@hyper.dev>

;; 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 (snowball-stemmer))

(import (system foreign))
(import (only (rnrs bytevectors)
              bytevector-length
              string->utf8
              utf8->string))

(export stemmers make-stemmer stem)

;;; ffi helpers

(define NULL %null-pointer)
(define POINTER '*)

;; XXX: only use that procedure in your project if you don't need to
;; access static variables
(define (dynamic-link* library-name)
  (let ((shared-object (dynamic-link library-name)))
    (lambda (return-value function-name . arguments)
      (let ((function (dynamic-func function-name shared-object)))
        (pointer->procedure return-value function arguments)))))

;; bindings

(define snowball-stemmer
  (dynamic-link* "/usr/lib/x86_64-linux-gnu/libstemmer.so.0d"))

(define stemmers
  (let ((proc (snowball-stemmer POINTER "sb_stemmer_list")))
    (lambda ()
      (let ((array (pointer-address (proc))))
        (let loop ((out '())
                   (index 0))
          (let ((pointer (dereference-pointer (make-pointer (+ array (* 8 index))))))
            (if (eq? pointer NULL)
                out
                (loop (cons (pointer->string pointer) out)
                      (+ index 1)))))))))

(define %stemmer-delete
  (let ((proc (snowball-stemmer void "sb_stemmer_delete" POINTER)))
    (lambda (stemmer)
      (proc stemmer))))

(define stemmers-guardian (make-guardian))

(define make-stemmer
  (let ((proc (snowball-stemmer POINTER "sb_stemmer_new" POINTER POINTER)))
    (lambda (algorithm)
      (let ((out (proc (string->pointer algorithm) NULL)))
        (when (eq? out NULL)
          (error 'snowball-stemmer "Oops! Stemmer not found" algorithm))
        (stemmers-guardian out)
        out))))

(define (reap-stemmers)
  (let loop ()
    (let ((stemmer (stemmers-guardian)))
      (when stemmer
        (%stemmer-delete stemmer)
        (loop)))))

(add-hook! after-gc-hook reap-stemmers)

(define %stemmer-length
  (let ((proc (snowball-stemmer int "sb_stemmer_length" POINTER)))
    (lambda (stemmer)
      (proc stemmer))))

(define stem
  (let ((proc (snowball-stemmer POINTER "sb_stemmer_stem" POINTER POINTER int)))
    (lambda (stemmer word)
      (let ((bv (string->utf8 word)))
        (let ((pointer (proc stemmer (bytevector->pointer bv) (bytevector-length bv))))
          (utf8->string (pointer->bytevector pointer (%stemmer-length stemmer))))))))

A zlib.scm => zlib.scm +201 -0
@@ 0,0 1,201 @@
;;; guile-zlib
;;; Copyright (C) 2013 David Thompson <dthompson2@worcester.edu>
;;;
;;; guile-zlib 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.
;;;
;;; guile-zlib 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 program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; guile-zlib is a Guile wrapper for zlib.
;;
;;; Code:

(define-module (zlib)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 receive)
  #:export (compress
            uncompress
            adler32
            crc32))

(define libz (dynamic-link "/usr/lib/x86_64-linux-gnu/libz.so"))

(define-syntax-rule (define-foreign name ret string-name args)
  (define name
    (pointer->procedure ret (dynamic-func string-name libz) args)))

;;
;; ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen,
;;                                    const Bytef *source, uLong sourceLen));
;;
;; Decompresses the source buffer into the destination
;; buffer. sourceLen is the byte length of the source buffer. Upon
;; entry, destLen is the total size of the destination buffer, which
;; must be large enough to hold the entire uncompressed data. (The
;; size of the uncompressed data must have been saved previously by
;; the compressor and transmitted to the decompressor by some
;; mechanism outside the scope of this compression library.) Upon
;; exit, destLen is the actual size of the compressed buffer.
;;
;; uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
;; enough memory, Z_BUF_ERROR if there was not enough room in the
;; output buffer, or Z_DATA_ERROR if the input data was corrupted or
;; incomplete. In the case where there is not enough room,
;; uncompress() will fill the output buffer with the uncompressed data
;; up to that point.
(define-foreign %uncompress
  int "uncompress" (list '* '* '* unsigned-long))

;;
;; ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen,
;;                                  const Bytef *source, uLong sourceLen));
;;
;; Compresses the source buffer into the destination buffer. sourceLen
;; is the byte length of the source buffer. Upon entry, destLen is the
;; total size of the destination buffer, which must be at least the
;; value returned by compressBound(sourceLen). Upon exit, destLen is
;; the actual size of the compressed buffer.
;;
;; compress returns Z_OK if success, Z_MEM_ERROR if there was not
;; enough memory, Z_BUF_ERROR if there was not enough room in the
;; output buffer.
(define-foreign %compress
  int "compress" (list '* '* '* unsigned-long))

;;
;; ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));
;;
;; compressBound() returns an upper bound on the compressed size after
;; compress() or compress2() on sourceLen bytes. It would be used
;; before a compress() or compress2() call to allocate the destination
;; buffer.
(define-foreign %compress-bound
  unsigned-long "compressBound" (list unsigned-long))

;; Update a running Adler-32 checksum with the bytes buf[0..len-1] and
;; return the updated checksum.  If buf is Z_NULL, this function returns the
;; required initial value for the checksum.
;;
;;   An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
;; much faster.
;;
;; Usage example:
;;
;;   uLong adler = adler32(0L, Z_NULL, 0);
;;
;;   while (read_buffer(buffer, length) != EOF) {
;;     adler = adler32(adler, buffer, length);
;;   }
;;   if (adler != original_adler) error();
(define-foreign %adler32
  unsigned-long "adler32" (list unsigned-long '* unsigned-int))

;; Update a running CRC-32 with the bytes buf[0..len-1] and return the
;; updated CRC-32.  If buf is Z_NULL, this function returns the required
;; initial value for the crc.  Pre- and post-conditioning (one's complement) is
;; performed within this function so it shouldn't be done by the application.
;;
;; Usage example:
;;
;;   uLong crc = crc32(0L, Z_NULL, 0);
;;
;;   while (read_buffer(buffer, length) != EOF) {
;;     crc = crc32(crc, buffer, length);
;;   }
;;   if (crc != original_crc) error();
(define-foreign %crc32
  unsigned-long "crc32" (list unsigned-long '* unsigned-int))

;; There is a bit of guesswork involved when creating the bytevectors
;; to store compressed/uncompressed data in. This procedure provides a
;; convenient way to copy the portion of a bytevector that was
;; actually used.
(define (bytevector-copy-region bv start end)
  (let* ((length (- end start))
         (new-bv (make-bytevector length)))
    (bytevector-copy! bv start new-bv 0 length)
    new-bv))

;; uncompress/compress take a bytevector that zlib writes the size of
;; the returned data to. This procedure saves me a few keystrokes when
;; fetching that value.
(define (buffer-length bv)
  (bytevector-u64-native-ref bv 0))

(define (uncompress bv)
  "Uncompresses bytevector and returns a bytevector containing
the uncompressed data."
  (define (try-uncompress length)
    (let* ((dest (make-bytevector (* (sizeof uint8) length)))
           (dest-length (make-bytevector (sizeof unsigned-long))))
      (bytevector-u64-native-set! dest-length 0 length)
      (values (%uncompress (bytevector->pointer dest)
                   (bytevector->pointer dest-length)
                   (bytevector->pointer bv)
                   length)
              (bytevector-copy-region dest 0 (buffer-length dest-length)))))

  ;; We don't know how much space we need to store the uncompressed
  ;; data. So, we make an initial guess and keep increasing buffer
  ;; size until it works.
  (define (step-buffer-length length)
    (inexact->exact (round (* length 1.5))))

  (let try-again ((tries 1)
                  (length (step-buffer-length (bytevector-length bv))))
    ;; Bail after so many failed attempts. This shouldn't happen, but
    ;; I don't like the idea of a potentially unbounded loop that
    ;; keeps allocating larger and larger chunks of memory.
    (if (> tries 10)
        (throw 'zlib-uncompress-error)
        (receive (ret-code uncompressed-data)
            (try-uncompress length)
          ;; return code -5 means that destination buffer was too small.
          ;; return code  0 means everything went OK.
          (cond ((= ret-code -5)
                 (try-again (1+ tries) (step-buffer-length length)))
                ((= ret-code 0)
                 uncompressed-data)
                (else
                 (throw 'zlib-uncompress-error)))))))

(define (compress bv)
  "Compresses bytevector and returns a bytevector containing the compressed data."
  (let* ((bv-length      (bytevector-length bv))
         (dest-length    (%compress-bound bv-length))
         (dest-bv        (make-bytevector dest-length))
         (dest-length-bv (make-bytevector (sizeof unsigned-long)))
         (ret-code       0))
    (bytevector-u64-native-set! dest-length-bv 0 dest-length)
    (set! ret-code
          (%compress (bytevector->pointer dest-bv)
                     (bytevector->pointer dest-length-bv)
                     (bytevector->pointer bv)
                     bv-length))
    (if (= ret-code 0)
        (bytevector-copy-region dest-bv 0
                                (buffer-length dest-length-bv))
        (throw 'zlib-compress-error))))

(define %default-adler32 (%adler32 0 %null-pointer 0))
(define %default-crc32   (%crc32   0 %null-pointer 0))

(define* (adler32 bv #:optional (value %default-adler32))
  "Computes adler32 checksum with optional starting value."
  (%adler32 value (bytevector->pointer bv) (bytevector-length bv)))

(define* (crc32 bv #:optional (value %default-crc32))
  "Computes crc32 checksum with optional starting value."
  (%crc32 value (bytevector->pointer bv) (bytevector-length bv)))