code:
Guile-VM NEWS

Guile-VM is a bytecode compiler and virtual machine for Guile.

guile-vm 0.7 -- 2008-05-20
==========================

* Initial release with NEWS.

* Revived from Keisuke Nishida's Guile-VM project from 2000-2001, with
  the help of Ludovic Courtès.

* Meta-level changes
** Updated to compile with Guile 1.8.
** Documentation updated, including documentation on the instructions.
** Added benchmarking and a test harness.

* Changes to the inventory
** Renamed the library from libguilevm to libguile-vm.
** Added new executable script, guile-disasm.

* New features
** Add support for compiling macros, both defmacros and syncase macros.
Primitive macros produced with the procedure->macro family of procedures
are not supported, however.
** Improvements to the REPL
Multiple values support, readline integration, ice-9 history integration
** Add support for eval-case
The compiler recognizes compile-toplevel in addition to load-toplevel
** Completely self-compiling
Almost, anyway: not (system repl describe), because it uses GOOPS

* Internal cleanups
** Internal objects are now based on Guile records.
** Guile-VM's code doesn't use the dot-syntax any more.
** Changed (ice-9 match) for Kiselyov's pmatch.scm
** New instructions: define, link-later, link-now, late-variable-{ref,set}
** Object code now represented as u8vectors instead of strings.
** Remove local import of an old version of slib

* Bugfixes
** The `optimize' procedure is coming out of bitrot
** The Scheme compiler is now more strict about placement of internal
   defines
** set! is now compiled differently from define
** Module-level variables are now bound at first use instead of in the
   program prolog
** Bugfix to load-program (stack misinterpretation)

Copyright (C) 2008 Free Software Foundation, Inc.

Copying and distribution of this file, with or without modification, are
permitted in any medium without royalty provided the copyright notice
and this notice are preserved.

license: mit


code:
!!! This is not a Guile release; it is a source tree retrieved via
Git or as a nightly snapshot at some random time after the
Guile 1.8 release.  If this were a Guile release, you would not see
this message. !!!  [fixme: zonk on release]

This is a 1.9 development version of Guile, Project GNU's extension
language library.  Guile is an interpreter for Scheme, packaged as a
library that you can link into your applications to give them their
own scripting language.  Guile will eventually support other languages
as well, giving users of Guile-based applications a choice of
languages.

Guile versions with an odd middle number, i.e. 1.9.* are unstable
development versions.  Even middle numbers indicate stable versions.
This has been the case since the 1.3.* series.

The next stable release will likely be version 2.0.0.

Please send bug reports to bug-guile@gnu.org.

See the LICENSE file for the specific terms that apply to Guile.

Additional INSTALL instructions ===========================================

Generic instructions for configuring and compiling Guile can be found
in the INSTALL file.  Guile specific information and configure options
can be found below, including instructions for installing SLIB.

Guile depends on the following external libraries.
- libgmp
- libiconv
- libintl
- libltdl
- libunistring
- libgc
- libffi
It will also use the libreadline library if it is available.  For each
of these there is a corresponding --with-XXX-prefix option that you
can use when invoking ./configure, if you have these libraries
installed in a location other than the standard places (/usr and
/usr/local).

These options are provided by the Gnulib `havelib' module, and details
of how they work are documented in `Searching for Libraries' in the
Gnulib manual (http://www.gnu.org/software/gnulib/manual).  The extent
to which they work on a given OS depends on whether that OS supports
encoding full library path names in executables (aka `rpath').  Also
note that using these options, and hence hardcoding full library path
names (where that is supported), makes it impossible to later move the
built executables and libraries to an installation location other than
the one that was specified at build time.

Another possible approach is to set CPPFLAGS and LDFLAGS on the
configure command-line, so that they include -I options for all the
non-standard places where you have installed header files and -L
options for all the non-standard places where you have installed
libraries.  This will allow configure and make to find those headers
and libraries during the build.  E.g.:

  ../configure [...] CPPFLAGS='-I/my/include' LDFLAGS='-L/my/lib'

The locations found will not be hardcoded into the build executables and
libraries, so with this approach you will probably also need to set
LD_LIBRARY_PATH correspondingly, to allow Guile to find the necessary
libraries again at runtime.

Required External Packages ================================================

Guile requires the following external packages:

  - GNU MP, at least version 4.1

    GNU MP is used for bignum arithmetic.  It is available from
    http://gmplib.org/ .

  - libltdl from GNU Libtool, at least version 1.5.6

    libltdl is used for loading extensions at run-time.  It is
    available from http://www.gnu.org/software/libtool/ .

  - GNU libunistring

    libunistring is used for Unicode string operations, such as the
    `utf*->string' procedures.  It is available from
    http://www.gnu.org/software/libunistring/ .

  - libgc, at least version 7.0

    libgc (aka. the Boehm-Demers-Weiser garbage collector) is the
    conservative garbage collector used by Guile.  It is available
    from http://www.hpl.hp.com/personal/Hans_Boehm/gc/ .

  - libffi

    libffi provides a "foreign function interface", used by the
    `(system foreign)' module.  It is available from
    http://sourceware.org/libffi/ .

  - pkg-config

    Guile's ./configure script uses pkg-config to discover the correct
    compile and link options for libgc.  If you don't have pkg-config
    installed, or you have a version of libgc that doesn't provide a
    .pc file, you can work around this by setting some variables as
    part of the configure command-line:

    - PKG_CONFIG=true

    - BDW_GC_CFLAGS=<compile flags for picking up libgc headers>

    - BDW_GC_LIBS=<linker flags for picking up the libgc library>

Special Instructions For Some Systems =====================================

We would like Guile to build on all systems using the simple
instructions above, but it seems that a few systems still need special
treatment.  If you can send us fixes for these problems, we'd be
grateful.

   <none yet listed>

Guile specific flags Accepted by Configure =================================

If you run the configure script with no arguments, it should examine
your system and set things up appropriately.  However, there are a few
switches specific to Guile you may find useful in some circumstances.

--without-threads  ---  Build without thread support

  Build a Guile executable and library that supports multi-threading.

  The default is to enable threading support when your operating
  system offsers 'POSIX threads'.  When you do not want threading, use
  `--without-threads'.

--enable-deprecated=LEVEL

  Guile may contain features that are `deprecated'.  When a feature is
  deprecated, it means that it is still there, but that there is a
  better way of achieving the same thing, and we'd rather have you use
  this better way.  This allows us to eventually remove the old
  implementation and helps to keep Guile reasonably clean of historic
  baggage.

  See the file NEWS for a list of features that are currently
  deprecated.  Each entry will also tell you what you should replace
  your code with.

  To give you some help with this process, and to encourage (OK,
  nudge) people to switch to the newer methods, Guile can emit
  warnings or errors when you use a deprecated feature.  There is
  quite a range of possibilities, from being completely silent to
  giving errors at link time.  What exactly happens is determined both
  by the value of the `--enable-deprecated' configuration option when
  Guile was built, and by the GUILE_WARN_DEPRECATED environment
  variable.

  It works like this:

    When Guile has been configured with `--enable-deprecated=no' (or,
    equivalently, with `--disable-deprecated') then all deprecated
    features are omitted from Guile.  You will get "undefined
    reference", "variable unbound" or similar errors when you try to
    use them.

    When `--enable-deprecated=LEVEL' has been specified (for LEVEL not
    "no"), LEVEL will be used as the default value of the environment
    variable GUILE_WARN_DEPRECATED.  A value of "yes" is changed to
    "summary" and "shutup" is changed to "no", however.

    When GUILE_WARN_DEPRECATED has the value "no", nothing special
    will happen when a deprecated feature is used.

    When GUILE_WARN_DEPRECATED has the value "summary", and a
    deprecated feature has been used, Guile will print this message at
    exit:

      Some deprecated features have been used.  Set the environment
      variable GUILE_WARN_DEPRECATED to "detailed" and rerun the
      program to get more information.  Set it to "no" to suppress
      this message.

    When GUILE_WARN_DEPRECATED has the value "detailed", a detailed
    warning is emitted immediatly for the first use of a deprecated
    feature.

  The default is `--enable-deprecated=yes'.

  In addition to setting GUILE_WARN_DEPRECATED in the environment, you
  can also use (debug-enable 'warn-deprecated) and (debug-disable
  'warn-deprecated) to enable and disable the detailed messaged at run
  time.

  Additionally, if your toolchain is new enough, you will receive
  warnings at link time if you have a Guile extension that uses
  deprecated functions provided by Guile.

--disable-shared  ---  Do not build shared libraries.
--disable-static  ---  Do not build static libraries.

  Normally, both static and shared libraries will be built if your
  system supports them.

--enable-debug-freelist  ---  Enable freelist debugging.

  This enables a debugging version of scm_cell and scm_double_cell,
  and also registers an extra primitive, the setter
  `gc-set-debug-check-freelist!'.

  Configure with the --enable-debug-freelist option to enable the
  gc-set-debug-check-freelist! primitive, and then use:

  (gc-set-debug-check-freelist! #t)  # turn on checking of the freelist
  (gc-set-debug-check-freelist! #f)  # turn off checking

  Checking of the freelist forces a traversal of the freelist and a
  garbage collection before each allocation of a cell.  This can slow
  down the interpreter dramatically, so the setter should be used to
  turn on this extra processing only when necessary.

--enable-debug-malloc  ---  Enable malloc debugging.

  Include code for debugging of calls to scm_malloc, scm_realloc, etc.

  It records the number of allocated objects of each kind.  This is
  useful when searching for memory leaks.

  A Guile compiled with this option provides the primitive
  `malloc-stats' which returns an alist with pairs of kind and the
  number of objects of that kind.

--enable-guile-debug  ---  Include internal debugging functions
--disable-posix       ---  omit posix interfaces
--disable-networking  ---  omit networking interfaces
--disable-regex       ---  omit regular expression interfaces

Cross building Guile  =====================================================

As of guile-1.5.x, the build process uses compiled C files for
snarfing, and (indirectly, through libtool) for linking, and uses the
guile executable for generating documentation.

When cross building guile, you first need to configure, build and
install guile for your build host.

Then, you may configure guile for cross building, eg:

    ./configure --host=i686-pc-cygwin --disable-shared

A C compiler for the build system is required.  The default is
"PATH=/usr/bin:$PATH cc".  If that doesn't suit it can be specified
with the CC_FOR_BUILD variable in the usual way, for instance

    ./configure --host=m68k-unknown-linux-gnu CC_FOR_BUILD=/my/local/gcc

Guile for the build system can be specified similarly with the
GUILE_FOR_BUILD variable, it defaults to just "guile".

Using Guile Without Installing It =========================================

The "meta/" subdirectory of the Guile sources contains a script called
"guile" that can be used to run the Guile that has just been built. Note
that this is not the same "guile" as the one that is installed; this
"guile" is a wrapper script that sets up the environment appropriately,
then invokes the Guile binary.

You may also build external packages against an uninstalled Guile build
tree. The "uninstalled-env" script in the "meta/" subdirectory will set
up an environment with a path including "meta/", a modified dynamic
linker path, a modified PKG_CONFIG_PATH, etc.

For example, you can enter this environment via invoking

    meta/uninstalled-env bash

Within that shell, other packages should be able to build against
uninstalled Guile.

Installing SLIB ===========================================================

In order to use SLIB from Guile you basically only need to put the
`slib' directory _in_ one of the directories on Guile's load path.

The standard installation is:

  1. Obtain slib from http://www-swiss.ai.mit.edu/~jaffer/SLIB.html

  2. Put it in Guile's data directory, that is the directory printed when
     you type

       guile-config info pkgdatadir

     at the shell prompt.  This is normally `/usr/local/share/guile', so the
     directory will normally have full path `/usr/local/share/guile/slib'.

  3. Start guile as a user with write access to the data directory and type

       (use-modules (ice-9 slib))

     at the Guile prompt.  This will generate the slibcat catalog next to
     the slib directory.

SLIB's `require' is provided by the Guile module (ice-9 slib).

Example:

  (use-modules (ice-9 slib))
  (require 'primes)
  (prime? 7)

Guile Documentation ==================================================

If you've never used Scheme before, then the Guile Tutorial
(guile-tut.info) is a good starting point.  The Guile Reference Manual
(guile.info) is the primary documentation for Guile.  A copy of the
R5RS Scheme specification is included too (r5rs.info).

Info format versions of this documentation are installed as part of
the normal build process.  The texinfo sources are under the doc
directory, and other formats like Postscript, PDF, DVI or HTML can be
generated from them with Tex and Texinfo tools.

The doc directory also includes an example-smob subdirectory which has
the example code from the "Defining New Types (Smobs)" chapter of the
reference manual.

The Guile WWW page is at

  http://www.gnu.org/software/guile/guile.html

It contains a link to the Guile FAQ.

About This Distribution ==============================================

Interesting files include:

- LICENSE, which contains the exact terms of the Guile license.
- COPYING.LESSER, which contains the terms of the GNU Lesser General Public License.
- COPYING, which contains the terms of the GNU General Public License.
- INSTALL, which contains general instructions for building/installing Guile.
- NEWS, which describes user-visible changes since the last release of Guile.

Files are usually installed according to the prefix specified to
configure, /usr/local by default.  Building and installing gives you:

Executables, in ${prefix}/bin:

 guile --- a stand-alone interpreter for Guile.  With no arguments, this
 	is a simple interactive Scheme interpreter.  It can also be used
 	as an interpreter for script files; see the NEWS file for details.
 guile-config --- a Guile script which provides the information necessary
 	to link your programs against the Guile library.
 guile-snarf --- a script to parse declarations in your C code for
 	Scheme-visible C functions, Scheme objects to be used by C code,
 	etc.

Libraries, in ${prefix}/lib.  Depending on the platform and options
        given to configure, you may get shared libraries in addition
	to or instead of these static libraries:

 libguile.a --- an object library containing the Guile interpreter,
 	You can use Guile in your own programs by linking against this.
 libguilereadline.a --- an object library containing glue code for the
        GNU readline library.

 libguile-srfi-*.a --- various SRFI support libraries

Header files, in ${prefix}/include:

 libguile.h, guile/gh.h, libguile/*.h --- for libguile.
 guile-readline/readline.h --- for guile-readline.

Support files, in ${prefix}/share/guile/<version>:

 ice-9/* --- run-time support for Guile: the module system,
 	read-eval-print loop, some R4RS code and other infrastructure.
 oop/* --- the Guile Object-Oriented Programming System (GOOPS)
 scripts/* --- executable modules, i.e., scheme programs that can be both
 	called as an executable from the shell, and loaded and used as a
 	module from scheme code.  See scripts/README for more info.
 srfi/* --- SRFI support modules.  See srfi/README for more info.

Automake macros, in ${prefix}/share/aclocal:

 guile.m4

Documentation in Info format, in ${prefix}/info:

 guile --- Guile reference manual.

 guile-tut --- Guile tutorial.

 GOOPS --- GOOPS reference manual.

 r5rs --- Revised(5) Report on the Algorithmic Language Scheme.

The Guile source tree is laid out as follows:

libguile:
	The Guile Scheme interpreter --- both the object library
	for you to link with your programs, and the executable you can run.
ice-9:  Guile's module system, initialization code, and other infrastructure.
guile-config:
	Source for the guile-config script.
guile-readline:
        The glue code for using GNU readline with Guile.  This
        will be build when configure can find a recent enough readline
        library on your system.
doc:	Documentation (see above).

Git Repository Access ================================================

Guile's source code is stored in a Git repository at Savannah.  Anyone
can access it using `git-clone' from one of the following URLs:

  git://git.sv.gnu.org/guile.git
  http://git.sv.gnu.org/r/guile.git

Developers with a Savannah SSH account can also access it from:

  ssh://git.sv.gnu.org/srv/git/guile.git

The repository can also be browsed on-line at the following address:

  http://git.sv.gnu.org/gitweb/?p=guile.git

For more information on Git, please see:

  http://git.or.cz/

Please send problem reports to <bug-guile@gnu.org>.

path: README


code:
This is an attempt to revive the Guile-VM project by Keisuke Nishida
written back in the years 2000 and 2001.  Below are a few pointers to
relevant threads on Guile's development mailing list.

Enjoy!

Ludovic Court�s <ludovic.courtes@laas.fr>, Apr. 2005.

Pointers
--------

Status of the last release, 0.5
  http://lists.gnu.org/archive/html/guile-devel/2001-04/msg00266.html

The very first release, 0.0
  http://sources.redhat.com/ml/guile/2000-07/msg00418.html

Simple benchmark
  http://sources.redhat.com/ml/guile/2000-07/msg00425.html

Performance, portability, GNU Lightning
  http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00132.html

Playing with GNU Lightning
  http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00185.html

On things left to be done
  http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00146.html

---8<---  Original README below.  -----------------------------------------

Installation
------------

1. Install the latest Guile from CVS.

2. Install Guile VM:

  % configure
  % make install
  % ln -s module/{guile,system,language} /usr/local/share/guile/

3. Add the following lines to your ~/.guile:

  (use-modules (system vm core)

  (cond ((string=? (car (command-line)) "guile-vm")
	 (use-modules (system repl repl))
	 (start-repl 'scheme)
	 (quit)))

Example Session
---------------

  % guile-vm
  Guile Scheme interpreter 0.5 on Guile 1.4.1
  Copyright (C) 2001 Free Software Foundation, Inc.

  Enter `,help' for help.
  scheme@guile-user> (+ 1 2)
  3
  scheme@guile-user> ,c -c (+ 1 2)	;; Compile into GLIL
  (@asm (0 1 0 0)
    (module-ref #f +)
    (const 1)
    (const 2)
    (tail-call 2))
  scheme@guile-user> ,c (+ 1 2)		;; Compile into object code
  Disassembly of #<objcode 403c5fb0>:

  nlocs = 0  nexts = 0

     0    link "+"                        ;; (+ . ???)
     3    variable-ref
     4    make-int8:1                     ;; 1
     5    make-int8 2                     ;; 2
     7    tail-call 2

  scheme@guile-user> (define (add x y) (+ x y))
  scheme@guile-user> (add 1 2)
  3
  scheme@guile-user> ,x add		;; Disassemble
  Disassembly of #<program add>:

  nargs = 2  nrest = 0  nlocs = 0  nexts = 0

  Bytecode:

     0    object-ref 0                    ;; (+ . #<primitive-procedure +>)
     2    variable-ref
     3    local-ref 0
     5    local-ref 1
     7    tail-call 2

  Objects:

     0    (+ . #<primitive-procedure +>)

  scheme@guile-user>

Compile Modules
---------------

Use `guilec' to compile your modules:

  % cat fib.scm
  (define-module (fib) :export (fib))
  (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))

  % guilec fib.scm
  Wrote fib.go
  % guile
  guile> (use-modules (fib))
  guile> (fib 8)
  34


code:
Contributors since the last release:

	    Jim Bender
	    Rob Browning
        Ludovic Courtès
         Julian Graham
	   Mike Gran
         Stefan Jahn
           Neil Jerram
        Gregory Marton
        Antoine Mathys
      Thien-Thi Nguyen
        Han-Wen Nienhuys
         Jose A Ortega Ruiz
	  Kevin Ryde
	   Bill Schottstaedt
	   Alex Shinn
        Richard Todd
           Andy Wingo

For fixes or providing information which led to a fix:

          David Allouche
         Andrew Bagdanov
	 Martin Baulig
        Fabrice Bauzac
        Sylvain Beucler
          Carlo Bramini
            Rob Browning
         Adrian Bunk
        Michael Carmack
              R Clayton
        Tristan Colgate
        Stephen Compall
          Brian Crowder
    Christopher Cramer
          David Diffenbaugh
          Hyper Division
      Alexandre Duret-Lutz
           Nils Durner
         John W Eaton
	Clinton Ebadi
          David Fang
          Barry Fishman
        Charles Gagnon
          Peter Gavin
           Eric Gillespie, Jr
         Didier Godefroy
  Panicz Maciej Godek
           John Goerzen
	 Volker Grabsch
           Mike Gran
         Raimon Grau
         Szavai Gyula
         Roland Haeder
	   Sven Hartrumpf
	   Eric Hanchrow
	   Judy Hawkins
	    Jon Herron
            Sam Hocevar
	Patrick Horgan
           Ales Hvezda
         Stefan Israelsson Tampe
          Peter Ivanyi
       Wolfgang Jaehrling
         Aubrey Jaffer
           Paul Jarc
          Steve Juranich
        Richard Kim
          Bruce Korb
           René Köcher
       Matthias Köppe
           Matt Kraai
         Daniel Kraft
       Miroslav Lichvar
         Daniel Llorens del Río
           Jeff Long
	  Marco Maggi
        Gregory Marton
      Kjetil S. Matheussen
        Antoine Mathys
        Patrick McCarty
            Dan McMahill
          Roger Mc Murtrie
          Scott McPeak
         Andrew Milkowski
            Tim Mooney
        Han-Wen Nienhuys
            Jan Nieuwenhuizen
         Hrvoje Nikšić
         Stefan Nordhausen
         Roland Orre
	  Peter O'Gorman
         Pieter Pareit
           Jack Pavlovsky
          Derek Peschel
           Arno Peters
	    Ron Peterson
          David Pirotte
         Carlos Pita
         Sergey Poznyakoff
            Ken Raeburn
         Juhani Rantanen
        Andreas Rottmann
           Hugh Sasse
         Werner Scheinast
	   Bill Schottstaedt
	  Frank Schwidom
    John Steele Scott
         Thiemo Seufer
           Ivan Shcherbakov
          Scott Shedden
           Alex Shinn
         Daniel Skarda
           Dale Smith
          Cesar Strauss
         Rainer Tammer
        Richard Todd
          Issac Trotts
           Greg Troxel
       Aaron M. Ucko
        Stephen Uitti
        Momchil Velikov
	  Linas Vepstas
     Panagiotis Vossos
        Neil W. Van Dyke
          Aaron VanDevender
	Andreas Vögele
        Michael Talbot-Wilson
        Michael Tuexen
         Thomas Wawrzinek
        Mark H. Weaver
            Jon Wilson
           Andy Wingo
          Keith Wright
        William Xu

;; Local Variables:
;; coding: utf-8
;; End:

path: THANKS


code: Guile VM was inspired by QScheme, librep, and Objective Caml.


code:
dnl -*- Autoconf -*-

dnl Copyright (C) 1997, 1999, 2000, 2001, 2002, 2004, 2006,
dnl   2007, 2008, 2009, 2010 Free Software Foundation, Inc.
dnl
dnl This file is part of GUILE
dnl
dnl GUILE is free software; you can redistribute it and/or modify it under
dnl the terms of the GNU Lesser General Public License as published by the
dnl Free Software Foundation; either version 3, or (at your option) any
dnl later version.
dnl
dnl GUILE is distributed in the hope that it will be useful, but WITHOUT
dnl ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
dnl FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
dnl License for more details.
dnl
dnl You should have received a copy of the GNU Lesser General Public
dnl License along with GUILE; see the file COPYING.LESSER.  If not, write
dnl to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
dnl Floor, Boston, MA 02110-1301, USA.

dnl  On the NeXT, #including <utime.h> doesn't give you a definition for
dnl  struct utime, unless you #define _POSIX_SOURCE.

AC_DEFUN([GUILE_STRUCT_UTIMBUF], [
  AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf],
    guile_cv_struct_utimbuf_needs_posix,
    [AC_TRY_CPP([
#ifdef __EMX__
#include <sys/utime.h>
#else
#include <utime.h>
#endif
struct utime blah;
],
                guile_cv_struct_utimbuf_needs_posix=no,
		guile_cv_struct_utimbuf_needs_posix=yes)])
  if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
     AC_DEFINE([UTIMBUF_NEEDS_POSIX], 1,
       [Define this if <utime.h> doesn't define struct utimbuf unless
        _POSIX_SOURCE is defined.  See GUILE_STRUCT_UTIMBUF in aclocal.m4.])
  fi])

dnl
dnl Apparently, at CMU they have a weird version of libc.h that is
dnl installed in /usr/local/include and conflicts with unistd.h.
dnl In these situations, we should not #include libc.h.
dnl This test arranges to #define LIBC_H_WITH_UNISTD_H iff libc.h is
dnl present on the system, and is safe to #include.
dnl
AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD],
  [
    AC_CHECK_HEADERS(libc.h unistd.h)
    AC_CACHE_CHECK(
      [whether libc.h and unistd.h can be included together],
      guile_cv_header_libc_with_unistd,
      [
        if test "$ac_cv_header_libc_h" = "no"; then
          guile_cv_header_libc_with_unistd="no"
        elif test "$ac_cv_header_unistd_h" = "no"; then
          guile_cv_header_libc_with_unistd="yes"
        else
          AC_TRY_COMPILE(
	    [
#             include <libc.h>
#             include <unistd.h>
	    ],
	    [],
	    [guile_cv_header_libc_with_unistd=yes],
	    [guile_cv_header_libc_with_unistd=no]
          )
        fi
      ]
    )
    if test "$guile_cv_header_libc_with_unistd" = yes; then
      AC_DEFINE([LIBC_H_WITH_UNISTD_H], 1,
        [Define this if we should include <libc.h> when we've already
         included <unistd.h>.  On some systems, they conflict, and libc.h
         should be omitted.  See GUILE_HEADER_LIBC_WITH_UNISTD in
         aclocal.m4.])
    fi
  ]
)

dnl This is needed when we want to check for the same function repeatedly
dnl with other parameters, such as libraries, varying.
dnl
dnl GUILE_NAMED_CHECK_FUNC(FUNCTION, TESTNAME,
dnl                        [ACTION-IF-FOUND [, ACTION-IF-NOT-FOUND]])
AC_DEFUN([GUILE_NAMED_CHECK_FUNC],
[AC_MSG_CHECKING([for $1])
AC_CACHE_VAL(ac_cv_func_$1_$2,
[AC_TRY_LINK(
dnl Don't include <ctype.h> because on OSF/1 3.0 it includes <sys/types.h>
dnl which includes <sys/select.h> which contains a prototype for
dnl select.  Similarly for bzero.
[/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $1(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
#ifdef __cplusplus
extern "C"
#endif
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char $1();
], [
/* The GNU C library defines this for functions which it implements
    to always fail with ENOSYS.  Some functions are actually named
    something starting with __ and the normal name is an alias.  */
#if defined (__stub_$1) || defined (__stub___$1)
choke me
#else
$1();
#endif
], eval "ac_cv_func_$1_$2=yes", eval "ac_cv_func_$1_$2=no")])
if eval "test \"`echo '$ac_cv_func_'$1'_'$2`\" = yes"; then
  AC_MSG_RESULT(yes)
  ifelse([$3], , :, [$3])
else
  AC_MSG_RESULT(no)
ifelse([$4], , , [$4
])dnl
fi
])

dnl Available from the Autoconf Macro Archive at:
dnl http://autoconf-archive.cryp.to/acx_pthread.html
dnl
AC_DEFUN([ACX_PTHREAD], [
AC_REQUIRE([AC_CANONICAL_HOST])
AC_LANG_SAVE
AC_LANG_C
acx_pthread_ok=no

# We used to check for pthread.h first, but this fails if pthread.h
# requires special compiler flags (e.g. on True64 or Sequent).
# It gets checked for in the link test anyway.

# First of all, check if the user has set any of the PTHREAD_LIBS,
# etcetera environment variables, and if threads linking works using
# them:
if test x"$PTHREAD_LIBS$PTHREAD_CFLAGS" != x; then
        save_CFLAGS="$CFLAGS"
        CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
        save_LIBS="$LIBS"
        LIBS="$PTHREAD_LIBS $LIBS"
        AC_MSG_CHECKING([for pthread_join in LIBS=$PTHREAD_LIBS with CFLAGS=$PTHREAD_CFLAGS])
        AC_TRY_LINK_FUNC(pthread_join, acx_pthread_ok=yes)
        AC_MSG_RESULT($acx_pthread_ok)
        if test x"$acx_pthread_ok" = xno; then
                PTHREAD_LIBS=""
                PTHREAD_CFLAGS=""
        fi
        LIBS="$save_LIBS"
        CFLAGS="$save_CFLAGS"
fi

# We must check for the threads library under a number of different
# names; the ordering is very important because some systems
# (e.g. DEC) have both -lpthread and -lpthreads, where one of the
# libraries is broken (non-POSIX).

# Create a list of thread flags to try.  Items starting with a "-" are
# C compiler flags, and other items are library names, except for "none"
# which indicates that we try without any flags at all, and "pthread-config"
# which is a program returning the flags for the Pth emulation library.

acx_pthread_flags="pthreads none -Kthread -kthread lthread -pthread -pthreads -mthreads pthread --thread-safe -mt pthread-config"

# The ordering *is* (sometimes) important.  Some notes on the
# individual items follow:

# pthreads: AIX (must check this before -lpthread)
# none: in case threads are in libc; should be tried before -Kthread and
#       other compiler flags to prevent continual compiler warnings
# -Kthread: Sequent (threads in libc, but -Kthread needed for pthread.h)
# -kthread: FreeBSD kernel threads (preferred to -pthread since SMP-able)
# lthread: LinuxThreads port on FreeBSD (also preferred to -pthread)
# -pthread: Linux/gcc (kernel threads), BSD/gcc (userland threads)
# -pthreads: Solaris/gcc
# -mthreads: Mingw32/gcc, Lynx/gcc
# -mt: Sun Workshop C (may only link SunOS threads [-lthread], but it
#      doesn't hurt to check since this sometimes defines pthreads too;
#      also defines -D_REENTRANT)
#      ... -mt is also the pthreads flag for HP/aCC
# pthread: Linux, etcetera
# --thread-safe: KAI C++
# pthread-config: use pthread-config program (for GNU Pth library)

case "${host_cpu}-${host_os}" in
        *solaris*)

        # On Solaris (at least, for some versions), libc contains stubbed
        # (non-functional) versions of the pthreads routines, so link-based
        # tests will erroneously succeed.  (We need to link with -pthreads/-mt/
        # -lpthread.)  (The stubs are missing pthread_cleanup_push, or rather
        # a function called by this macro, so we could check for that, but
        # who knows whether they'll stub that too in a future libc.)  So,
        # we'll just look for -pthreads and -lpthread first:

        acx_pthread_flags="-pthreads pthread -mt -pthread $acx_pthread_flags"
        ;;
esac

if test x"$acx_pthread_ok" = xno; then
for flag in $acx_pthread_flags; do

        case $flag in
                none)
                AC_MSG_CHECKING([whether pthreads work without any flags])
                ;;

                -*)
                AC_MSG_CHECKING([whether pthreads work with $flag])
                PTHREAD_CFLAGS="$flag"
                ;;

                pthread-config)
                AC_CHECK_PROG(acx_pthread_config, pthread-config, yes, no)
                if test x"$acx_pthread_config" = xno; then continue; fi
                PTHREAD_CFLAGS="`pthread-config --cflags`"
                PTHREAD_LIBS="`pthread-config --ldflags` `pthread-config --libs`"
                ;;

                *)
                AC_MSG_CHECKING([for the pthreads library -l$flag])
                PTHREAD_LIBS="-l$flag"
                ;;
        esac

        save_LIBS="$LIBS"
        save_CFLAGS="$CFLAGS"
        LIBS="$PTHREAD_LIBS $LIBS"
        CFLAGS="$CFLAGS $PTHREAD_CFLAGS"

        # Check for various functions.  We must include pthread.h,
        # since some functions may be macros.  (On the Sequent, we
        # need a special flag -Kthread to make this header compile.)
        # We check for pthread_join because it is in -lpthread on IRIX
        # while pthread_create is in libc.  We check for pthread_attr_init
        # due to DEC craziness with -lpthreads.  We check for
        # pthread_cleanup_push because it is one of the few pthread
        # functions on Solaris that doesn't have a non-functional libc stub.
        # We try pthread_create on general principles.
        AC_TRY_LINK([#include <pthread.h>],
                    [pthread_t th; pthread_join(th, 0);
                     pthread_attr_init(0); pthread_cleanup_push(0, 0);
                     pthread_create(0,0,0,0); pthread_cleanup_pop(0); ],
                    [acx_pthread_ok=yes])

        LIBS="$save_LIBS"
        CFLAGS="$save_CFLAGS"

        AC_MSG_RESULT($acx_pthread_ok)
        if test "x$acx_pthread_ok" = xyes; then
                break;
        fi

        PTHREAD_LIBS=""
        PTHREAD_CFLAGS=""
done
fi

# Various other checks:
if test "x$acx_pthread_ok" = xyes; then
        save_LIBS="$LIBS"
        LIBS="$PTHREAD_LIBS $LIBS"
        save_CFLAGS="$CFLAGS"
        CFLAGS="$CFLAGS $PTHREAD_CFLAGS"

        # Detect AIX lossage: JOINABLE attribute is called UNDETACHED.
        AC_MSG_CHECKING([for joinable pthread attribute])
        attr_name=unknown
        for attr in PTHREAD_CREATE_JOINABLE PTHREAD_CREATE_UNDETACHED; do
            AC_TRY_LINK([#include <pthread.h>], [int attr=$attr; return attr;],
                        [attr_name=$attr; break])
        done
        AC_MSG_RESULT($attr_name)
        if test "$attr_name" != PTHREAD_CREATE_JOINABLE; then
            AC_DEFINE_UNQUOTED([PTHREAD_CREATE_JOINABLE], $attr_name,
                               [Define to necessary symbol if this constant
                                uses a non-standard name on your system.])
        fi

        AC_MSG_CHECKING([if more special flags are required for pthreads])
        flag=no
        case "${host_cpu}-${host_os}" in
            *-aix* | *-freebsd* | *-darwin*) flag="-D_THREAD_SAFE";;
            *solaris* | *-osf* | *-hpux*) flag="-D_REENTRANT";;
        esac
        AC_MSG_RESULT(${flag})
        if test "x$flag" != xno; then
            PTHREAD_CFLAGS="$flag $PTHREAD_CFLAGS"
        fi

        LIBS="$save_LIBS"
        CFLAGS="$save_CFLAGS"

        # More AIX lossage: must compile with xlc_r or cc_r
        if test x"$GCC" != xyes; then
          AC_CHECK_PROGS(PTHREAD_CC, xlc_r cc_r, ${CC})
        else
          PTHREAD_CC=$CC
        fi
else
        PTHREAD_CC="$CC"
fi

AC_SUBST(PTHREAD_LIBS)
AC_SUBST(PTHREAD_CFLAGS)
AC_SUBST(PTHREAD_CC)

# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND:
if test x"$acx_pthread_ok" = xyes; then
        ifelse([$1],,AC_DEFINE([HAVE_PTHREAD],1,[Define if you have POSIX threads libraries and header files.]),[$1])
        :
else
        acx_pthread_ok=no
        $2
fi
AC_LANG_RESTORE
])dnl ACX_PTHREAD

dnl GUILE_GNU_LD_RELRO
dnl
dnl Check whether GNU ld's read-only relocations (the `PT_GNU_RELRO'
dnl ELF segment header) are supported.  This allows things like
dnl statically allocated cells (1) to eventually be remapped read-only
dnl by the loader, and (2) to be identified as pointerless by the
dnl garbage collector.  Substitute `GNU_LD_FLAGS' with the relevant
dnl flags.
AC_DEFUN([GUILE_GNU_LD_RELRO], [
  AC_MSG_CHECKING([whether the linker understands `-z relro'])

  GNU_LD_FLAGS="-Wl,-z -Wl,relro"

  save_LDFLAGS="$LDFLAGS"
  LDFLAGS="$LDFLAGS $GNU_LD_FLAGS"
  AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
    [AC_MSG_RESULT([yes])],
    [AC_MSG_RESULT([no])
     GNU_LD_FLAGS=""])
  LDFLAGS="$save_LDFLAGS"

  AC_SUBST([GNU_LD_FLAGS])
])

dnl GUILE_THREAD_LOCAL_STORAGE
dnl
dnl Check for compiler thread-local storage (TLS) support.
AC_DEFUN([GUILE_THREAD_LOCAL_STORAGE], [
  AC_CACHE_CHECK([whether the `__thread' storage class is available],
    [ac_cv_have_thread_storage_class],
    [dnl On some systems, e.g., NetBSD 5.0 with GCC 4.1, `__thread' is
     dnl properly compiled but fails to link due to the lack of TLS
     dnl support in the C library.  Thus we try to link, not just
     dnl compile.  Unfortunately, this test is not enough, so we
     dnl explicitly check for known-broken systems.  See
     dnl http://lists.gnu.org/archive/html/guile-devel/2009-10/msg00138.html
     dnl for details.
     dnl
     dnl Known broken systems includes:
     dnl   - x86_64-unknown-netbsd5.0.
     dnl   - sparc-sun-solaris2.8
     case "x$enable_shared--$host" in
       xyes--*netbsd[0-5].[0-9].|xyes--*solaris2.8)
         ac_cv_have_thread_storage_class="no"
	 ;;
       *)
	 AC_LINK_IFELSE([AC_LANG_PROGRAM([__thread int tls_integer;],
			  [tls_integer = 123;])],
	   [ac_cv_have_thread_storage_class="yes"],
	   [ac_cv_have_thread_storage_class="no"])
	 ;;
     esac])

  if test "x$ac_cv_have_thread_storage_class" = "xyes"; then
     SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=1
  else
     SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=0
  fi

  AC_SUBST([SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS])
])

dnl GUILE_READLINE
dnl
dnl Check all the things needed by `guile-readline', the Readline
dnl bindings.
AC_DEFUN([GUILE_READLINE], [
  for termlib in ncurses curses termcap terminfo termlib pdcurses ; do
     AC_CHECK_LIB(${termlib}, [tgoto],
       [READLINE_LIBS="-l${termlib} $READLINE_LIBS"; break])
  done

  AC_LIB_LINKFLAGS([readline])

  if test "x$LTLIBREADLINE" = "x"; then
    AC_MSG_WARN([GNU Readline was not found on your system.])
  else
    rl_save_LIBS="$LIBS"
    LIBS="$LIBREADLINE $READLINE_LIBS $LIBS"

    AC_CHECK_FUNCS([siginterrupt rl_clear_signals rl_cleanup_after_signal])

    dnl Check for modern readline naming
    AC_CHECK_FUNCS([rl_filename_completion_function])
    AC_CHECK_DECLS([rl_catch_signals, rl_catch_sigwinch], [], [],
                   [[#include <stdio.h>]
                    [#include <readline/readline.h>]])

    dnl Check for rl_get_keymap.  We only use this for deciding whether to
    dnl install paren matching on the Guile command line (when using
    dnl readline for input), so it's completely optional.
    AC_CHECK_FUNCS([rl_get_keymap])

    AC_CACHE_CHECK([for rl_getc_function pointer in readline],
		     ac_cv_var_rl_getc_function,
		     [AC_TRY_LINK([
    #include <stdio.h>
    #include <readline/readline.h>],
				  [printf ("%ld", (long) rl_getc_function)],
				  [ac_cv_var_rl_getc_function=yes],
				  [ac_cv_var_rl_getc_function=no])])
    if test "${ac_cv_var_rl_getc_function}" = "yes"; then
      AC_DEFINE([HAVE_RL_GETC_FUNCTION], 1,
	[Define if your readline library has the rl_getc_function variable.])
    fi

    if test $ac_cv_var_rl_getc_function = no; then
      AC_MSG_WARN([*** GNU Readline is too old on your system.])
      AC_MSG_WARN([*** You need readline version 2.1 or later.])
      LTLIBREADLINE=""
      LIBREADLINE=""
    fi

    LIBS="$rl_save_LIBS"

    READLINE_LIBS="$LTLIBREADLINE $READLINE_LIBS"
  fi

  AM_CONDITIONAL([HAVE_READLINE], [test "x$LTLIBREADLINE" != "x"])

  AC_CHECK_FUNCS([strdup])

  AC_SUBST([READLINE_LIBS])

  . $srcdir/guile-readline/LIBGUILEREADLINE-VERSION
  AC_SUBST(LIBGUILEREADLINE_MAJOR)
  AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
  AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
  AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
  AC_SUBST(LIBGUILEREADLINE_INTERFACE)
])

dnl Declare file $1 to be a script that needs configuring,
dnl and arrange to make it executable in the process.
AC_DEFUN([GUILE_CONFIG_SCRIPT],[AC_CONFIG_FILES([$1],[chmod +x $1])])


code:
2002-04-10  Rob Browning  <rlb@defaultvalue.org>

	* .cvsignore: add Makefile and Makefile.in.

2002-04-01  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* maintainer-dirs: Remove "if MAINTAINER_MODE" conditional.

2002-03-30  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* maintainer-dirs: New file.

	* Makefile.am (am_frags): Add "maintainer-dirs".

2002-02-26  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* pre-inst-guile, Makefile.am, README: New files.


code:
## Process this file with Automake to create Makefile.in
##
##  	Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE 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.
##
##   GUILE 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 GUILE; see the file COPYING.LESSER.  If not,
##   write to the Free Software Foundation, Inc., 51 Franklin Street,
##   Fifth Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

am_frags = pre-inst-guile maintainer-dirs guilec

EXTRA_DIST = $(am_frags) ChangeLog-2008

## Makefile.am ends here


code:
data directory: automake frags

do not name files using extension ".am", as automake is overzealous sometimes.

path: am/README


code:
# -*- makefile -*-
GOBJECTS = $(SOURCES:%.scm=%.go)

GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch

moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath)
nobase_ccache_DATA = $(GOBJECTS)
EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)

CLEANFILES = $(GOBJECTS)

# Make sure source files are installed first, so that the mtime of
# installed compiled files is greater than that of installed source
# files.  See
# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
# for details.
guile_install_go_files = install-nobase_ccacheDATA
$(guile_install_go_files): install-nobase_modDATA

AM_V_GUILEC = $(AM_V_GUILEC_$(V))
AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY))
AM_V_GUILEC_0 = @echo "  GUILEC" $@;

SUFFIXES = .scm .go
.scm.go:
	$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0				\
	$(top_builddir)/meta/uninstalled-env			\
	guile-tools compile $(GUILE_WARNINGS) -o "$@" "$<"

path: am/guilec


code:
## am/maintainer-dirs --- define workbook and mscripts vars

##	Copyright (C) 2002, 2006 Free Software Foundation
##
##   This file is part of GUILE.
##
##   GUILE 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.
##
##   GUILE 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 GUILE; see the file COPYING.LESSER.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

## Commentary:

## This fragment defines two variables: workbook and mscripts.
## It can be included in any Makefile.am by adding the line:
##   include $(top_srcdir)/am/maintainer-dirs
## See $(workbook)/build/maintainer-dirs.text for more info.

## Code:

workbook	= $(top_srcdir_absolute)/../workbook
mscripts	= $(top_srcdir_absolute)/../scripts

## am/maintainer-dirs ends here

path: am/maintainer-dirs


code:
## am/pre-inst-guile --- define preinstguile and preinstguiletool vars

##	Copyright (C) 2002, 2006 Free Software Foundation
##
##   This file is part of GUILE.
##
##   GUILE 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.
##
##   GUILE 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 GUILE; see the file COPYING.LESSER.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

## Commentary:

## This fragment defines two variables: preinstguile, preinstguiletool.
## It can be included in any Makefile.am by adding the line:
##   include $(top_srcdir)/am/pre-inst-guile
## See devel/build/pre-inst-guile.text (CVS only) for more info.

## Code:

preinstguile     = $(top_builddir_absolute)/meta/guile
preinstguiletool = GUILE="$(preinstguile)" $(top_srcdir)/scripts

## am/pre-inst-guile ends here

path: am/pre-inst-guile


code:
# -*- makefile -*-

GUILE_SNARF = $(top_builddir)/libguile/guile-snarf

AM_V_SNARF = $(AM_V_SNARF_$(V))
AM_V_SNARF_ = $(AM_V_SNARF_$(AM_DEFAULT_VERBOSITY))
AM_V_SNARF_0 = @echo "  SNARF " $@;

path: am/snarf


code:
#!/bin/sh
# Usage: sh -x ./autogen.sh

set -e

[ -f GUILE-VERSION ] || {
  echo "autogen.sh: run this command only at the top of guile-core."
  exit 1
}

######################################################################
### announce build tool versions
echo ""
autoconf --version
echo ""
automake --version
echo ""
if test "`uname -s`" = Darwin; then
  glibtool --version
else
  libtool --version
fi
echo ""
${M4:-m4} --version
echo ""

######################################################################
### update infrastructure

autoreconf -i --force --verbose

echo "Now run configure and make."


code:
#! /bin/sh
# Usage: benchmark-guile [-i GUILE-INTERPRETER] [GUILE-BENCHMARK-ARGS]
# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/meta/guile.
# See ${top_srcdir}/benchmark-suite/guile-benchmark for documentation on GUILE-BENCHMARK-ARGS.
#
# Example invocations:
# ./benchmark-guile
# ./benchmark-guile numbers.bm
# ./benchmark-guile -i /usr/local/bin/guile
# ./benchmark-guile -i /usr/local/bin/guile numbers.bm

set -e

top_builddir=@top_builddir_absolute@
top_srcdir=@top_srcdir_absolute@

BENCHMARK_SUITE_DIR=${top_srcdir}/benchmark-suite

if [ x"$1" = x-i ] ; then
    guile=$2
    shift
    shift
else
    guile=${top_builddir}/meta/guile
fi

GUILE_LOAD_PATH="$BENCHMARK_SUITE_DIR${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
export GUILE_LOAD_PATH

if [ -f "$guile" -a -x "$guile" ] ; then
    echo Benchmarking $guile ... "$@"
    echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH
else
    echo ERROR: Cannot execute $guile
    exit 1
fi

# documentation searching ignores GUILE_LOAD_PATH.
if [ ! -f guile-procedures.txt ] ; then
   @LN_S@ libguile/guile-procedures.txt .
fi

exec $guile \
    -e main -s "$BENCHMARK_SUITE_DIR/guile-benchmark" \
    --benchmark-suite "$BENCHMARK_SUITE_DIR/benchmarks" \
    --log-file benchmark-guile.log "$@"

# benchmark-guile ends here


code:
2008-04-17  Ludovic Courtès  <ludo@gnu.org>

	* Makefile.am (SCM_BENCHMARKS): Add `benchmarks/read.bm'.
	* benchmarks/read.bm: New file.

2008-01-22  Neil Jerram  <neil@ossau.uklinux.net>

	* COPYING: Removed.

2006-11-17  Neil Jerram  <neil@ossau.uklinux.net>

	* README: Note need for subscription to bug-guile@gnu.org.

2006-05-02  Marius Vollmer  <mvo@zagadka.de>

	* Makefile.am (SCM_BENCHMARKS_DIRS, dist-hook): Removed, they are
	no longer needed and lead to unclean tarballs.

2004-01-23  Dirk Herrmann  <dirk@dirk-herrmanns-seiten.de>

	* lib.scm: Extracted '/i' to toplevel.  Print the guile version
	number before the benchmarks are run.  Print the framework-time
	per iteration as an inexact number.

2004-01-06  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* lib.scm (print-result, print-user-result): Handle exact
	fractions.

2003-05-27  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* lib.scm: Fix some typos in the documentation.

2002-09-14  Rob Browning  <rlb@defaultvalue.org>

	* .cvsignore: new file.

2002-07-26  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* Makefile.am (SCM_BENCHMARKS): List the real benchmarks, not foo
	and bar.
	(SCM_BENCHMARKS_DIRS): Uncommented, with an empty value.
	(dist-hook): Use quotes so that an empty SCM_BENCHMARKS_DIRS works.

2002-07-21  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* lib.scm (print-result, print-user-result): Changed the
	reporter's outputs to use symbols rather than strings to document
	the individual values.  Thanks to Neil Jerram for the suggestion.

2002-07-21  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* benchmarks/0-reference.bm:  Added as a reference benchmark to be
	used to calibrate iteration counts.

	* lib.scm: Added documentation.  Added some initialization
	messages.

	(benchmark-time-base, benchmark-total-time, benchmark-user-time,
	benchmark-system-time, benchmark-frame-time, benchmark-core-time,
	benchmark-user-time\interpreter, benchmark-core-time\interpreter):
	Exported.

	(benchmark-time-base, time-base): Renamed time-base to
	benchmark-time-base and introduced new time-base as a short-cut.

	(total-time, benchmark-total-time, user-time, benchmark-user-time,
	system-time, benchmark-system-time, frame-time,
	benchmark-frame-time, benchmark-time, benchmark-core-time,
	user-time\interpreter, benchmark-user-time\interpreter,
	benchmark-time\interpreter, benchmark-core-time\interpreter,
	print-result, print-user-result):  Renamed <foo>-time to
	benchmark-<foo>-time.  Exceptions: benchmark-time and
	benchmark-time\interpreter were renamed to benchmark-core-time and
	benchmark-core-time\interpreter, respectively.

2002-07-20  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* COPYING, README, Makefile.am, lib.scm, guile-benchmark:  Copied
	from the test-suite directory, renamed and adapted for use with
	benchmarks.

	* benchmarks/logand.bm, benchmarks/continuations.bm,
	benchmarks/if.bm:  Added as initial fairly stupid examples for
	benchmarks.

2002-07-20  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* Log begins.


code:
SCM_BENCHMARKS = benchmarks/0-reference.bm		\
		 benchmarks/bytevectors.bm		\
		 benchmarks/chars.bm			\
		 benchmarks/continuations.bm		\
                 benchmarks/if.bm			\
                 benchmarks/logand.bm			\
		 benchmarks/read.bm			\
		 benchmarks/srfi-1.bm			\
		 benchmarks/srfi-13.bm			\
		 benchmarks/structs.bm			\
		 benchmarks/subr.bm			\
		 benchmarks/uniform-vector-read.bm	\
		 benchmarks/vectors.bm			\
		 benchmarks/vlists.bm

EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS)	\
	     ChangeLog-2008


code:
This directory contains some benchmarks for Guile, and some generic
benchmarking support code.

To run these benchmarks, you will need a version of Guile more recent
than 15 Feb 1999 --- the benchmarks use the (ice-9 and-let*) and
(ice-9 getopt-long) modules, which were added to Guile around then.

For information about how to run the benchmark suite, read the usage
instructions in the comments at the top of the guile-benchmark script.

You can reference the file `lib.scm' from your own code as the module
(benchmark-suite lib); it also has comments at the top and before each
function explaining what's going on.

Please write more Guile benchmarks, and send them to bug-guile@gnu.org.
We'll merge them into the distribution.  All benchmark suites must be
licensed for our use under the GPL, but I don't think we're going to
collect assignment papers for them.

path: benchmark-suite/README


code:
(define-module (benchmarks 0-reference)
  :use-module (benchmark-suite lib))

(benchmark "reference benchmark for iteration counts" 330000
  #t)


code:
;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; R6RS Byte Vectors.
;;;
;;; Copyright 2009, 2010 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 bytevector)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-4)
  #:use-module (benchmark-suite lib))

(define bv (make-bytevector 16384))

(define %native-endianness
  (native-endianness))

(define %foreign-endianness
  (if (eq? (native-endianness) (endianness little))
      (endianness big)
      (endianness little)))

(define u8v  (make-u8vector 16384))
(define u16v (make-u16vector 8192))
(define u32v (make-u32vector 4196))
(define u64v (make-u64vector 2048))

(with-benchmark-prefix "ref/set!"

  (benchmark "bytevector-u8-ref" 1000000
    (bytevector-u8-ref bv 0))

  (benchmark "bytevector-u16-ref (foreign)" 1000000
    (bytevector-u16-ref bv 0 %foreign-endianness))

  (benchmark "bytevector-u16-ref (native)" 1000000
    (bytevector-u16-ref bv 0 %native-endianness))

  (benchmark "bytevector-u16-native-ref" 1000000
    (bytevector-u16-native-ref bv 0))

  (benchmark "bytevector-u32-ref (foreign)" 1000000
    (bytevector-u32-ref bv 0 %foreign-endianness))

  (benchmark "bytevector-u32-ref (native)" 1000000
    (bytevector-u32-ref bv 0 %native-endianness))

  (benchmark "bytevector-u32-native-ref" 1000000
    (bytevector-u32-native-ref bv 0))

  (benchmark "bytevector-u64-ref (foreign)" 1000000
    (bytevector-u64-ref bv 0 %foreign-endianness))

  (benchmark "bytevector-u64-ref (native)" 1000000
    (bytevector-u64-ref bv 0 %native-endianness))

  (benchmark "bytevector-u64-native-ref" 1000000
    (bytevector-u16-native-ref bv 0)))

(with-benchmark-prefix "lists"

  (benchmark "bytevector->u8-list" 2000
    (bytevector->u8-list bv))

  (benchmark "bytevector->uint-list 16-bit" 2000
    (bytevector->uint-list bv (native-endianness) 2))

  (benchmark "bytevector->uint-list 64-bit" 2000
    (bytevector->uint-list bv (native-endianness) 8)))

(with-benchmark-prefix "SRFI-4" ;; for comparison

  (benchmark "u8vector-ref" 1000000
    (u8vector-ref u8v 0))

  (benchmark "u16vector-ref" 1000000
    (u16vector-ref u16v 0))

  (benchmark "u32vector-ref" 1000000
    (u32vector-ref u32v 0))

  (benchmark "u64vector-ref" 1000000
    (u64vector-ref u64v 0)))


code:
;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; chars.bm
;;;
;;; Copyright (C) 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 chars)
  :use-module (benchmark-suite lib))

(with-benchmark-prefix "chars"

  (benchmark "char" 1000000
     #\a)

  (benchmark "octal" 1000000
     #\123)

  (benchmark "char? eq" 1000000
    (char? #\a))

  (benchmark "char=?" 1000000
    (char=? #\a #\a))

  (benchmark "char<?" 1000000
    (char=? #\a #\a))

  (benchmark "char-ci=?" 1000000
    (char=? #\a #\a))

  (benchmark "char-ci<? " 1000000
    (char=? #\a #\a))

  (benchmark "char->integer" 1000000
    (char->integer #\a))

  (benchmark "char-alphabetic?" 1000000
    (char-upcase #\a))

  (benchmark "char-numeric?" 1000000
    (char-upcase #\a)))


code:
(define-module (benchmarks continuations)
  :use-module (benchmark-suite lib))

(define (callee continuation)
  (continuation #t))

(benchmark "call/cc" 12000
  (call-with-current-continuation callee))


code:
(define-module (benchmarks if)
  :use-module (benchmark-suite lib))

(with-benchmark-prefix "if-<expr>-then-else"

  (benchmark "executing then" 330000
    (if (quote #t) #t #f))

  (benchmark "executing else" 330000
    (if (quote #f) #t #f)))

(with-benchmark-prefix "if-<expr>-then"

  (benchmark "executing then" 330000
    (if (quote #t) #t))

  (benchmark "executing else" 330000
    (if (quote #f) #t)))

(with-benchmark-prefix "if-<iloc>-then-else"

  (let ((x #t))
    (benchmark "executing then" 330000
      (if x #t #f)))

  (let ((x #f))
    (benchmark "executing else" 330000
      (if x #t #f))))

(with-benchmark-prefix "if-<iloc>-then"

  (let ((x #t))
    (benchmark "executing then" 330000
      (if x #t)))

  (let ((x #f))
    (benchmark "executing else" 330000
      (if x #t))))

(with-benchmark-prefix "if-<bool>-then-else"

  (benchmark "executing then" 330000
    (if #t #t #f))

  (benchmark "executing else" 330000
    (if #f #t #f)))

(with-benchmark-prefix "if-<bool>-then"

  (benchmark "executing then" 330000
    (if #t #t))

  (benchmark "executing else" 330000
    (if #f #t)))


code:
(define-module (benchmarks logand)
  :use-module (benchmark-suite lib))

(define bignum (1- (expt 2 128)))

(let* ((i 0))
  (benchmark "bignum" 130000
    (logand i bignum)
    (set! i (+ i 1))))


code:
;;; read.bm --- Exercise the reader.               -*- Scheme -*-
;;;
;;; Copyright (C) 2008, 2010 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 read)
  :use-module (benchmark-suite lib))

(define %files-to-load
  ;; Various large Scheme files.
  (map %search-load-path
       '("ice-9/boot-9.scm"  "ice-9/common-list.scm"
	 "ice-9/format.scm"  "ice-9/optargs.scm"
	 "ice-9/session.scm" "ice-9/getopt-long.scm"
         "ice-9/psyntax-pp.scm")))

(define (load-file-with-reader file-name reader buffering)
  (with-input-from-file file-name
    (lambda ()
      (apply setvbuf (current-input-port) buffering)
      (let loop ((sexp (reader)))
        (if (eof-object? sexp)
            #t
	    (loop (reader)))))))

(define (exercise-read buffering)
  (for-each (lambda (file)
		      (load-file-with-reader file read buffering))
            %files-to-load))

(with-benchmark-prefix "read"

  (benchmark "_IONBF" 5  ;; this one is very slow
    (exercise-read (list _IONBF)))

  (benchmark "_IOLBF" 10
    (exercise-read (list _IOLBF)))

  (benchmark "_IOFBF 4096" 10
    (exercise-read (list _IOFBF 4096)))

  (benchmark "_IOFBF 8192" 10
    (exercise-read (list _IOFBF 8192)))

  (benchmark "_IOFBF 16384" 10
    (exercise-read (list _IOFBF 16384))))


code:
;;; -*- mode: scheme; coding: utf-8; -*-
;;; SRFI-1.
;;;
;;; Copyright 2010 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 srfi-1)
  #:use-module (srfi srfi-1)
  #:use-module (benchmark-suite lib))

(define %big-list
  (iota 1000000))

(define %small-list
  (iota 10))

(with-benchmark-prefix "fold"

  (benchmark "fold" 30
    (fold (lambda (x y) y) #f %big-list))

  (benchmark "fold" 2000000
    (fold (lambda (x y) y) #f %small-list)))


code:
;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; srfi-13.bm
;;;
;;; Copyright (C) 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 strings)
  :use-module (benchmark-suite lib))

(seed->random-state 1)

(define short-string "Hi")
(define medium-string
"ARMA virumque cano, Troiae qui primus ab oris
Italiam, fato profugus, Laviniaque venit")
(define long-string
  (string-tabulate
   (lambda (n) (integer->char (+ 32 (random 90))))
   1000))

(define short-chlist (string->list short-string))
(define medium-chlist (string->list medium-string))
(define long-chlist (string->list long-string))

(define str1 (string-copy short-string))
(define str2 (string-copy medium-string))
(define str3 (string-copy long-string))

(with-benchmark-prefix "strings"

  (with-benchmark-prefix "predicates"

    (benchmark "string?" 1190000
      (string? short-string)
      (string? medium-string)
      (string? long-string))

    (benchmark "null?" 969000
      (string-null? short-string)
      (string-null? medium-string)
      (string-null? long-string))

    (benchmark "any" 94000
      (string-any #\a short-string)
      (string-any #\a medium-string)
      (string-any #\a long-string))

    (benchmark "every" 94000
      (string-every #\a short-string)
      (string-every #\a medium-string)
      (string-every #\a long-string)))

  (with-benchmark-prefix "constructors"

    (benchmark "string" 5000
      (apply string short-chlist)
      (apply string medium-chlist)
      (apply string long-chlist))

    (benchmark "list->" 4500
      (list->string short-chlist)
      (list->string medium-chlist)
      (list->string long-chlist))

    (benchmark "reverse-list->" 5000
      (reverse-list->string short-chlist)
      (reverse-list->string medium-chlist)
      (reverse-list->string long-chlist))

    (benchmark "make" 22000
      (make-string 250 #\x))

    (benchmark "tabulate" 17000
      (string-tabulate integer->char 250))

    (benchmark "join" 5500
      (string-join (list short-string medium-string long-string) "|" 'suffix)))

  (with-benchmark-prefix "list/string"
    (benchmark "->list" 7300
      (string->list short-string)
      (string->list medium-string)
      (string->list long-string))

    (benchmark "split" 60000
      (string-split short-string #\a)
      (string-split medium-string #\a)
      (string-split long-string #\a)))

  (with-benchmark-prefix "selection"

    (benchmark "ref" 660
      (let loop ((k 0))
        (if (< k (string-length short-string))
            (begin
              (string-ref short-string k)
              (loop (+ k 1)))))
      (let loop ((k 0))
        (if (< k (string-length medium-string))
            (begin
              (string-ref medium-string k)
              (loop (+ k 1)))))
      (let loop ((k 0))
        (if (< k (string-length long-string))
            (begin
              (string-ref long-string k)
              (loop (+ k 1))))))

    (benchmark "copy" 20000
      (string-copy short-string)
      (string-copy medium-string)
      (string-copy long-string)
      (substring/copy short-string 0 1)
      (substring/copy medium-string 10 20)
      (substring/copy long-string 100 200))

    (benchmark "pad" 34000
      (string-pad short-string 100)
      (string-pad medium-string 100)
      (string-pad long-string 100))

    (benchmark "trim trim-right trim-both" 60000
      (string-trim short-string char-alphabetic?)
      (string-trim medium-string char-alphabetic?)
      (string-trim long-string char-alphabetic?)
      (string-trim-right short-string char-alphabetic?)
      (string-trim-right medium-string char-alphabetic?)
      (string-trim-right long-string char-alphabetic?)
      (string-trim-both short-string char-alphabetic?)
      (string-trim-both medium-string char-alphabetic?)
      (string-trim-both long-string char-alphabetic?)))

  (with-benchmark-prefix "modification"

    (set! str1 (string-copy short-string))
    (set! str2 (string-copy medium-string))
    (set! str3 (string-copy long-string))

    (benchmark "set!" 3000
      (let loop ((k 1))
        (if (< k (string-length short-string))
            (begin
              (string-set! str1 k #\x)
              (loop (+ k 1)))))
      (let loop ((k 20))
        (if (< k (string-length medium-string))
            (begin
              (string-set! str2 k #\x)
              (loop (+ k 1)))))
      (let loop ((k 900))
        (if (< k (string-length long-string))
            (begin
              (string-set! str3 k #\x)
              (loop (+ k 1))))))

    (set! str1 (string-copy short-string))
    (set! str2 (string-copy medium-string))
    (set! str3 (string-copy long-string))

    (benchmark "sub-move!" 230000
      (substring-move! short-string 0 2 str2 10)
      (substring-move! medium-string 10 20 str3 20))

    (set! str1 (string-copy short-string))
    (set! str2 (string-copy medium-string))
    (set! str3 (string-copy long-string))

    (benchmark "fill!" 230000
      (string-fill! str1 #\y 0 1)
      (string-fill! str2 #\y 10 20)
      (string-fill! str3 #\y 20 30))

  (with-benchmark-prefix "comparison"

    (benchmark "compare compare-ci" 140000
      (string-compare short-string medium-string string<? string=? string>?)
      (string-compare long-string medium-string string<? string=? string>?)
      (string-compare-ci short-string medium-string string<? string=? string>?)
      (string-compare-ci long-string medium-string string<? string=? string>?))

    (benchmark "hash hash-ci" 1000
      (string-hash short-string)
      (string-hash medium-string)
      (string-hash long-string)
      (string-hash-ci short-string)
      (string-hash-ci medium-string)
      (string-hash-ci long-string))))

  (with-benchmark-prefix "searching" 20000

    (benchmark "prefix-length suffix-length" 270
      (string-prefix-length short-string
                            (string-append short-string medium-string))
      (string-prefix-length long-string
                            (string-append long-string medium-string))
      (string-suffix-length short-string
                            (string-append medium-string short-string))
      (string-suffix-length long-string
                            (string-append medium-string long-string))
      (string-prefix-length-ci short-string
                            (string-append short-string medium-string))
      (string-prefix-length-ci long-string
                            (string-append long-string medium-string))
      (string-suffix-length-ci short-string
                            (string-append medium-string short-string))
      (string-suffix-length-ci long-string
                            (string-append medium-string long-string)))

    (benchmark "prefix? suffix?" 270
      (string-prefix? short-string
                            (string-append short-string medium-string))
      (string-prefix? long-string
                            (string-append long-string medium-string))
      (string-suffix? short-string
                            (string-append medium-string short-string))
      (string-suffix? long-string
                            (string-append medium-string long-string))
      (string-prefix-ci? short-string
                            (string-append short-string medium-string))
      (string-prefix-ci? long-string
                            (string-append long-string medium-string))
      (string-suffix-ci? short-string
                            (string-append medium-string short-string))
      (string-suffix-ci? long-string
                            (string-append medium-string long-string)))

    (benchmark "index index-right rindex" 100000
      (string-index short-string #\T)
      (string-index medium-string #\T)
      (string-index long-string #\T)
      (string-index-right short-string #\T)
      (string-index-right medium-string #\T)
      (string-index-right long-string #\T)
      (string-rindex short-string #\T)
      (string-rindex medium-string #\T)
      (string-rindex long-string #\T))

    (benchmark "skip skip-right?" 100000
      (string-skip short-string char-alphabetic?)
      (string-skip medium-string char-alphabetic?)
      (string-skip long-string char-alphabetic?)
      (string-skip-right short-string char-alphabetic?)
      (string-skip-right medium-string char-alphabetic?)
      (string-skip-right long-string char-alphabetic?))

    (benchmark "count" 10000
      (string-count short-string char-alphabetic?)
      (string-count medium-string char-alphabetic?)
      (string-count long-string char-alphabetic?))

    (benchmark "contains contains-ci" 34000
      (string-contains short-string short-string)
      (string-contains medium-string (substring medium-string 10 15))
      (string-contains long-string (substring long-string 100 130))
      (string-contains-ci short-string short-string)
      (string-contains-ci medium-string (substring medium-string 10 15))
      (string-contains-ci long-string (substring long-string 100 130)))

    (set! str1 (string-copy short-string))
    (set! str2 (string-copy medium-string))
    (set! str3 (string-copy long-string))

    (benchmark "upcase downcase upcase! downcase!" 600
      (string-upcase short-string)
      (string-upcase medium-string)
      (string-upcase long-string)
      (string-downcase short-string)
      (string-downcase medium-string)
      (string-downcase long-string)
      (string-upcase! str1 0 1)
      (string-upcase! str2 10 20)
      (string-upcase! str3 100 130)
      (string-downcase! str1 0 1)
      (string-downcase! str2 10 20)
      (string-downcase! str3 100 130)))

  (with-benchmark-prefix "readers"

    (benchmark "read token, method 1" 1200
      (let ((buf (make-string 512)))
        (let loop ((i 0))
          (if (< i 512)
              (begin
                (string-set! buf i #\x)
                (loop (+ i 1)))
              buf))))

    (benchmark "read token, method 2" 1200
      (let ((lst '()))
        (let loop ((i 0))
          (set! lst (append! lst (list #\x)))
          (if (< i 512)
              (loop (+ i 1))
              (list->string lst)))))))


code:
;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; Structs.
;;;
;;; 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 structs)
  :use-module (benchmark-suite lib))

;; Note: Use `--iteration-factor' to change this.
(define iterations 2000000)

(define vtable2
  (make-vtable "prpr"))

(define vtable7
  (make-vtable (string-concatenate (make-list 7 "pr"))))

(with-benchmark-prefix "constructors"

  (benchmark "make-struct2 (opcode)" iterations
    (make-struct vtable2 0 1 2))

  (benchmark "make-struct2 (procedure)" iterations
    (let ((s make-struct))
      (s vtable2 0 1 2)))

  (benchmark "make-struct7 (opcode)" iterations
    (make-struct vtable7 0 1 2 3 4 5 6 7))

  (benchmark "make-struct7 (procedure)" iterations
    (let ((s make-struct))
      (s vtable7 0 1 2 3 4 5 6 7))))

(with-benchmark-prefix "pairs" ;; for comparison

  (benchmark "cons (opcode)" iterations
    (cons 1 2))

  (benchmark "cons (procedure)" iterations
    (let ((c cons))
      (c 1 2)))

  (benchmark "list (opcode)" iterations
    (list 1 2 3 4 5 6 7))

  (benchmark "list (procedure)" iterations
    (let ((l list))
      (l 1 2 3 4 5 6 7)))

  (benchmark "make-list" iterations
    (make-list 7)))


code:
;;; subr.bm --- Measure the subr invocation cost.     -*- Scheme -*-
;;;
;;; Copyright (C) 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 subrs)
  :use-module (benchmark-suite lib))

(define hook1 (make-hook 1))
(define hook3 (make-hook 3))

(with-benchmark-prefix "subr invocation"

  (benchmark "simple subr" 700000
    ;; 1 required argument, 0 optional arguments, no rest.
    (1+ 0))

  (benchmark "generic subr" 700000
    ;; 2 required arguments, 4 optional arguments, no rest.

    ;; In Guile 1.8 and earlier, such subrs are implemented as "compiled
    ;; closures" (cclos).  There, when a cclo/gsubr is called, the evaluator
    ;; goes through `SCM_APPLY ()' and conses the arguments, which is more
    ;; costly than the invocation of a "simple subr".
    (string= "foo" "bar"))

  (benchmark "generic subr with rest arg" 700000
    ;; 1 required argument, 0 optional arguments, 1 rest.
    (run-hook hook1 1))

  (benchmark "generic subr with rest arg and 3+ parameters" 700000
    ;; 1 required argument, 0 optional arguments, 1 rest.

    ;; The evaluator considers calls with 3 and more parameters as a general
    ;; form and always stores the arguments into a list.
    (run-hook hook3 1 2 3)))

(with-benchmark-prefix "subr application"

  (benchmark "simple subr" 700000
    (apply 1+ '(0)))

  (benchmark "generic subr" 700000
    (apply string= "foo" '("bar")))

  (benchmark "generic subr with rest arg" 700000
    (apply run-hook hook1 '(1)))

  (benchmark "generic subr with rest arg and 3+ parameters" 700000
    (run-hook hook3 1 2 '(3))))


code:
;;; uniform-vector-read.bm --- Exercise binary I/O primitives.  -*- Scheme -*-
;;;
;;; Copyright (C) 2008 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 uniform-vector-read)
  :use-module (benchmark-suite lib)
  :use-module (srfi srfi-4))

(define file-name
  (tmpnam))

(define %buffer-size
  7777)

(define buf
  (make-u8vector %buffer-size))

(define str
  (make-string %buffer-size))

(with-benchmark-prefix "uniform-vector-read!"

  (benchmark "uniform-vector-write" 4000
    (let ((output (open-output-file file-name)))
      (uniform-vector-write buf output)
      (close output)))

  (benchmark "uniform-vector-read!" 20000
    (let ((input (open-input-file file-name)))
      (setvbuf input _IONBF)
      (uniform-vector-read! buf input)
      (close input)))

  (benchmark "string port" 5000
    (let ((input (open-input-string str)))
      (uniform-vector-read! buf input)
      (close input))))


code:
;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; Vectors.
;;;
;;; 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 vectors)
  :use-module (benchmark-suite lib))

;; Note: Use `--iteration-factor' to change this.
(define iterations 1000000)

(with-benchmark-prefix "constructors"

  (benchmark "vector (opcode)" iterations
    (vector 1 2 3 4 5 6 7))

  (benchmark "vector (procedure)" iterations
    (let ((v vector))
      (v 1 2 3 4 5 6 7)))

  (benchmark "make-vector" iterations
    (make-vector 7)))

(with-benchmark-prefix "pairs" ;; for comparison

  (benchmark "list (opcode)" iterations
    (list 1 2 3 4 5 6 7))

  (benchmark "list (procedure)" iterations
    (let ((l list))
      (l 1 2 3 4 5 6 7)))

  (benchmark "make-list" iterations
    (make-list 7)))


code:
;;; -*- 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)))))))


code:
#!../libguile/guile \
-e main -s
!#

;;;; guile-benchmark --- run the Guile benchmark suite
;;;; Adapted from code by Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;; Copyright (C) 2002, 2006, 2010 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

;;;; Usage: [guile -e main -s] guile-benchmark [OPTIONS] [BENCHMARK ...]
;;;;
;;;; Run benchmarks from the Guile benchmark suite.  Report timing
;;;; results to the standard output, along with a summary of all
;;;; the results.  Record each reported benchmark outcome in the log
;;;; file, `benchmarks.log'.
;;;;
;;;; Normally, guile-benchmark scans the benchmark directory, and
;;;; executes all files whose names end in `.bm'.  (It assumes they contain
;;;; Scheme code.)  However, you can have it execute specific benchmarks by
;;;; listing their filenames on the command line.
;;;;
;;;; The option `--benchmark-suite' can be given to specify the benchmark
;;;; directory.  If no such option is given, the benchmark directory is
;;;; taken from the environment variable BENCHMARK_SUITE_DIR (if defined),
;;;; otherwise a default directory that is hardcoded in this file is
;;;; used (see "Installation" below).
;;;;
;;;; If present, the `--iteration-factor FACTOR' option tells
;;;; `guile-benchmark' to multiply the number of iterations given with
;;;; each single benchmark by the value of FACTOR.  This allows to
;;;; reduce or increase the total time for benchmarking.
;;;;
;;;; If present, the `--log-file LOG' option tells `guile-benchmark' to put
;;;; the log output in a file named LOG.
;;;;
;;;; If present, the `--debug' option will enable a debugging mode.
;;;;
;;;;
;;;; Installation:
;;;;
;;;; If you change the #! line at the top of this script to point at
;;;; the Guile interpreter you want to run, you can call this script
;;;; as an executable instead of having to pass it as a parameter to
;;;; guile via "guile -e main -s guile-benchmark".  Further, you can edit
;;;; the definition of default-benchmark-suite to point to the parent
;;;; directory of the `benchmarks' tree, which makes it unnecessary to set
;;;; the environment variable `BENCHMARK_SUITE_DIR'.
;;;;
;;;;
;;;; Shortcomings:
;;;;
;;;; At the moment, due to a simple-minded implementation, benchmark files
;;;; must live in the benchmark directory, and you must specify their names
;;;; relative to the top of the benchmark directory.  If you want to send
;;;; me a patch that fixes this, but still leaves sane benchmark names in
;;;; the log file, that would be great.  At the moment, all the benchmarks
;;;; I care about are in the benchmark directory, though.
;;;;
;;;; It would be nice if you could specify the Guile interpreter you
;;;; want to benchmark on the command line.  As it stands, if you want to
;;;; change which Guile interpreter you're benchmarking, you need to edit
;;;; the #! line at the top of this file, which is stupid.

;;; User configurable settings:
(define default-benchmark-suite
  (string-append (getenv "HOME") "/bogus-path/benchmark-suite"))

(use-modules (benchmark-suite lib)
	     (ice-9 getopt-long)
	     (ice-9 and-let-star)
	     (ice-9 rdelim))

;;; Variables that will receive their actual values later.
(define benchmark-suite default-benchmark-suite)

(define tmp-dir #f)

;;; General utilities, that probably should be in a library somewhere.

;;; Enable debugging
(define (enable-debug-mode)
  (write-line %load-path)
  (set! %load-verbosely #t)
  (debug-enable 'backtrace 'debug))

;;; Traverse the directory tree at ROOT, applying F to the name of
;;; each file in the tree, including ROOT itself.  For a subdirectory
;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
;;; symlinks.
(define (for-each-file f root)

  ;; A "hard directory" is a path that denotes a directory and is not a
  ;; symlink.
  (define (file-is-hard-directory? filename)
    (eq? (stat:type (lstat filename)) 'directory))

  (let visit ((root root))
    (let ((should-recur (f root)))
      (if (and should-recur (file-is-hard-directory? root))
	  (let ((dir (opendir root)))
	    (let loop ()
	      (let ((entry (readdir dir)))
		(cond
		 ((eof-object? entry) #f)
		 ((or (string=? entry ".")
		      (string=? entry "..")
                      (string=? entry "CVS")
                      (string=? entry "RCS"))
		  (loop))
		 (else
		  (visit (string-append root "/" entry))
		  (loop))))))))))

;;; The benchmark driver.

;;; Localizing benchmark files and temporary data files.

(define (data-file-name filename)
  (in-vicinity tmp-dir filename))

(define (benchmark-file-name benchmark)
  (in-vicinity benchmark-suite benchmark))

;;; Return a list of all the benchmark files in the benchmark tree.
(define (enumerate-benchmarks benchmark-dir)
  (let ((root-len (+ 1 (string-length benchmark-dir)))
	(benchmarks '()))
    (for-each-file (lambda (file)
		     (if (string-suffix? ".bm" file)
			 (let ((short-name
				(substring file root-len)))
			   (set! benchmarks (cons short-name benchmarks))))
		     #t)
		   benchmark-dir)

    ;; for-each-file presents the files in whatever order it finds
    ;; them in the directory.  We sort them here, so they'll always
    ;; appear in the same order.  This makes it easier to compare benchmark
    ;; log files mechanically.
    (sort benchmarks string<?)))

(define (main args)
  (let ((options (getopt-long args
			      `((benchmark-suite
				 (single-char #\t)
				 (value #t))
                                (iteration-factor
                                 (single-char #\t)
                                 (value #t))
				(log-file
				 (single-char #\l)
				 (value #t))
				(debug
				 (single-char #\d))))))
    (define (opt tag default)
      (let ((pair (assq tag options)))
	(if pair (cdr pair) default)))

    (if (opt 'debug #f)
	(enable-debug-mode))

    (set! benchmark-suite
	  (or (opt 'benchmark-suite #f)
	      (getenv "BENCHMARK_SUITE_DIR")
	      default-benchmark-suite))

    (set! iteration-factor
          (string->number (opt 'iteration-factor "1")))

    ;; directory where temporary files are created.
    (set! tmp-dir (getcwd))

    (let* ((benchmarks
	    (let ((foo (opt '() '())))
	      (if (null? foo)
		  (enumerate-benchmarks benchmark-suite)
		  foo)))
	   (log-file
	    (opt 'log-file "benchmarks.log")))

      ;; Open the log file.
      (let ((log-port (open-output-file log-file)))

	;; Register some reporters.
	(register-reporter (make-log-reporter log-port))
	(register-reporter user-reporter)

	;; Run the benchmarks.
	(for-each (lambda (benchmark)
		    (with-benchmark-prefix benchmark
		      (load (benchmark-file-name benchmark))))
		  benchmarks)
	(close-port log-port)))))

;;; Local Variables:
;;; mode: scheme
;;; End:

path: benchmark-suite/guile-benchmark