mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Merge branch 'master' into ossau-gds-dev

Browse source
This commit is contained in:
Neil Jerram 2009-02-08 22:02:15 +00:00
commit 57692c0742
92 changed files with 94288 additions and 6399 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -76,3 +76,4 @@ cscope.files
*.log
gds-test.debug
gds-test.transcript
INSTALL

237
INSTALL
View file

@ -1,237 +0,0 @@
Installation Instructions
*************************
Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005,
2006, 2007 Free Software Foundation, Inc.
This file is free documentation; the Free Software Foundation gives
unlimited permission to copy, distribute and modify it.
Basic Installation
==================
Briefly, the shell commands `./configure; make; make install' should
configure, build, and install this package. The following
more-detailed instructions are generic; see the `README' file for
instructions specific to this package.
The `configure' shell script attempts to guess correct values for
various system-dependent variables used during compilation. It uses
those values to create a `Makefile' in each directory of the package.
It may also create one or more `.h' files containing system-dependent
definitions. Finally, it creates a shell script `config.status' that
you can run in the future to recreate the current configuration, and a
file `config.log' containing compiler output (useful mainly for
debugging `configure').
It can also use an optional file (typically called `config.cache'
and enabled with `--cache-file=config.cache' or simply `-C') that saves
the results of its tests to speed up reconfiguring. Caching is
disabled by default to prevent problems with accidental use of stale
cache files.
If you need to do unusual things to compile the package, please try
to figure out how `configure' could check whether to do them, and mail
diffs or instructions to the address given in the `README' so they can
be considered for the next release. If you are using the cache, and at
some point `config.cache' contains results you don't want to keep, you
may remove or edit it.
The file `configure.ac' (or `configure.in') is used to create
`configure' by a program called `autoconf'. You need `configure.ac' if
you want to change it or regenerate `configure' using a newer version
of `autoconf'.
The simplest way to compile this package is:
1. `cd' to the directory containing the package's source code and type
`./configure' to configure the package for your system.
Running `configure' might take a while. While running, it prints
some messages telling which features it is checking for.
2. Type `make' to compile the package.
3. Optionally, type `make check' to run any self-tests that come with
the package.
4. Type `make install' to install the programs and any data files and
documentation.
5. You can remove the program binaries and object files from the
source code directory by typing `make clean'. To also remove the
files that `configure' created (so you can compile the package for
a different kind of computer), type `make distclean'. There is
also a `make maintainer-clean' target, but that is intended mainly
for the package's developers. If you use it, you may have to get
all sorts of other programs in order to regenerate files that came
with the distribution.
6. Often, you can also type `make uninstall' to remove the installed
files again.
Compilers and Options
=====================
Some systems require unusual options for compilation or linking that the
`configure' script does not know about. Run `./configure --help' for
details on some of the pertinent environment variables.
You can give `configure' initial values for configuration parameters
by setting variables in the command line or in the environment. Here
is an example:
./configure CC=c99 CFLAGS=-g LIBS=-lposix
*Note Defining Variables::, for more details.
Compiling For Multiple Architectures
====================================
You can compile the package for more than one kind of computer at the
same time, by placing the object files for each architecture in their
own directory. To do this, you can use GNU `make'. `cd' to the
directory where you want the object files and executables to go and run
the `configure' script. `configure' automatically checks for the
source code in the directory that `configure' is in and in `..'.
With a non-GNU `make', it is safer to compile the package for one
architecture at a time in the source code directory. After you have
installed the package for one architecture, use `make distclean' before
reconfiguring for another architecture.
Installation Names
==================
By default, `make install' installs the package's commands under
`/usr/local/bin', include files under `/usr/local/include', etc. You
can specify an installation prefix other than `/usr/local' by giving
`configure' the option `--prefix=PREFIX'.
You can specify separate installation prefixes for
architecture-specific files and architecture-independent files. If you
pass the option `--exec-prefix=PREFIX' to `configure', the package uses
PREFIX as the prefix for installing programs and libraries.
Documentation and other data files still use the regular prefix.
In addition, if you use an unusual directory layout you can give
options like `--bindir=DIR' to specify different values for particular
kinds of files. Run `configure --help' for a list of the directories
you can set and what kinds of files go in them.
If the package supports it, you can cause programs to be installed
with an extra prefix or suffix on their names by giving `configure' the
option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
Optional Features
=================
Some packages pay attention to `--enable-FEATURE' options to
`configure', where FEATURE indicates an optional part of the package.
They may also pay attention to `--with-PACKAGE' options, where PACKAGE
is something like `gnu-as' or `x' (for the X Window System). The
`README' should mention any `--enable-' and `--with-' options that the
package recognizes.
For packages that use the X Window System, `configure' can usually
find the X include and library files automatically, but if it doesn't,
you can use the `configure' options `--x-includes=DIR' and
`--x-libraries=DIR' to specify their locations.
Specifying the System Type
==========================
There may be some features `configure' cannot figure out automatically,
but needs to determine by the type of machine the package will run on.
Usually, assuming the package is built to be run on the _same_
architectures, `configure' can figure that out, but if it prints a
message saying it cannot guess the machine type, give it the
`--build=TYPE' option. TYPE can either be a short name for the system
type, such as `sun4', or a canonical name which has the form:
CPU-COMPANY-SYSTEM
where SYSTEM can have one of these forms:
OS KERNEL-OS
See the file `config.sub' for the possible values of each field. If
`config.sub' isn't included in this package, then this package doesn't
need to know the machine type.
If you are _building_ compiler tools for cross-compiling, you should
use the option `--target=TYPE' to select the type of system they will
produce code for.
If you want to _use_ a cross compiler, that generates code for a
platform different from the build platform, you should specify the
"host" platform (i.e., that on which the generated programs will
eventually be run) with `--host=TYPE'.
Sharing Defaults
================
If you want to set default values for `configure' scripts to share, you
can create a site shell script called `config.site' that gives default
values for variables like `CC', `cache_file', and `prefix'.
`configure' looks for `PREFIX/share/config.site' if it exists, then
`PREFIX/etc/config.site' if it exists. Or, you can set the
`CONFIG_SITE' environment variable to the location of the site script.
A warning: not all `configure' scripts look for a site script.
Defining Variables
==================
Variables not defined in a site shell script can be set in the
environment passed to `configure'. However, some packages may run
configure again during the build, and the customized values of these
variables may be lost. In order to avoid this problem, you should set
them in the `configure' command line, using `VAR=value'. For example:
./configure CC=/usr/local2/bin/gcc
causes the specified `gcc' to be used as the C compiler (unless it is
overridden in the site shell script).
Unfortunately, this technique does not work for `CONFIG_SHELL' due to
an Autoconf bug. Until the bug is fixed you can use this workaround:
CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash
`configure' Invocation
======================
`configure' recognizes the following options to control how it operates.
`--help'
`-h'
Print a summary of the options to `configure', and exit.
`--version'
`-V'
Print the version of Autoconf used to generate the `configure'
script, and exit.
`--cache-file=FILE'
Enable the cache: use and save the results of the tests in FILE,
traditionally `config.cache'. FILE defaults to `/dev/null' to
disable caching.
`--config-cache'
`-C'
Alias for `--cache-file=config.cache'.
`--quiet'
`--silent'
`-q'
Do not print messages saying which checks are being made. To
suppress all normal output, redirect it to `/dev/null' (any error
messages will still be shown).
`--srcdir=DIR'
Look for the package's source code in directory DIR. Usually
`configure' can determine that directory automatically.
`configure' also accepts some other, not widely useful, options. Run
`configure --help' for more details.

16
NEWS
View file

@ -40,6 +40,22 @@ application code.
** Functions for handling `scm_option' now no longer require an argument
indicating length of the `scm_t_option' array.
Changes in 1.8.7 (since 1.8.6)
* Bugs fixed
** Fix %fast-slot-ref/set!, to avoid possible segmentation fault
** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion
** Fix build problem when scm_t_timespec is different from struct timespec
** Fix build when compiled with -Wundef -Werror
** Allow @ macro to work with (ice-9 syncase)
Previously, use of the @ macro in a module whose code is being
transformed by (ice-9 syncase) would cause an "Invalid syntax" error.
Now it works as you would expect (giving the value of the specified
module binding).
Changes in 1.8.6 (since 1.8.5)

4
THANKS
View file

@ -23,6 +23,7 @@ For fixes or providing information which led to a fix:
David Allouche
Martin Baulig
Fabrice Bauzac
Carlo Bramini
Rob Browning
Adrian Bunk
Michael Carmack
@ -36,13 +37,16 @@ For fixes or providing information which led to a fix:
Nils Durner
John W Eaton
Clinton Ebadi
David Fang
Charles Gagnon
Peter Gavin
Eric Gillespie, Jr
Didier Godefroy
Panicz Maciej Godek
John Goerzen
Mike Gran
Szavai Gyula
Roland Haeder
Sven Hartrumpf
Eric Hanchrow
Sam Hocevar

9
autogen.sh
View file

@ -25,13 +25,4 @@ echo ""
autoreconf -i --force --verbose
echo "guile-readline..."
(cd guile-readline && ./autogen.sh)
# Copy versions of config.guess and config.sub from Guile's repository to
# build-aux and guile-readline.
cp -f config.guess config.sub build-aux/
cp -f config.guess config.sub guile-readline/
echo "Now run configure and make."
echo "You must pass the \`--enable-maintainer-mode' option to configure."

1526
config.guess vendored
View file

File diff suppressed because it is too large Load diff

1654
config.sub vendored
View file

File diff suppressed because it is too large Load diff

2
configure.in
View file

@ -1570,6 +1570,8 @@ AC_CONFIG_FILES([libguile/guile-snarf-docs],
[chmod +x libguile/guile-snarf-docs])
AC_CONFIG_FILES([test-suite/standalone/test-use-srfi],
[chmod +x test-suite/standalone/test-use-srfi])
AC_CONFIG_FILES([test-suite/standalone/test-fast-slot-ref],
[chmod +x test-suite/standalone/test-fast-slot-ref])
AC_OUTPUT

8
doc/ref/srfi-modules.texi
View file

@ -29,7 +29,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-8:: receive.
* SRFI-9:: define-record-type.
* SRFI-10:: Hash-Comma Reader Extension.
* SRFI-11:: let-values and let-values*.
* SRFI-11:: let-values and let*-values.
* SRFI-13:: String library.
* SRFI-14:: Character-set library.
* SRFI-16:: case-lambda
@ -1514,9 +1514,9 @@ the anonymous and compact syntax of @nicode{#,()} is much better.
@cindex SRFI-11
@findex let-values
@findex let-values*
@findex let*-values
This module implements the binding forms for multiple values
@code{let-values} and @code{let-values*}. These forms are similar to
@code{let-values} and @code{let*-values}. These forms are similar to
@code{let} and @code{let*} (@pxref{Local Bindings}), but they support
binding of the values returned by multiple-valued expressions.
@ -1533,7 +1533,7 @@ available.
@code{let-values} performs all bindings simultaneously, which means that
no expression in the binding clauses may refer to variables bound in the
same clause list. @code{let-values*}, on the other hand, performs the
same clause list. @code{let*-values}, on the other hand, performs the
bindings sequentially, just like @code{let*} does for single-valued
expressions.

280
gc-benchmarks/gc-profile.scm Executable file
View file

@ -0,0 +1,280 @@
#!/bin/sh
# -*- Scheme -*-
exec ${GUILE-guile} --no-debug -q -l "$0" \
-c '(apply main (cdr (command-line)))' "$@"
!#
;;; 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 General Public License as published by
;;; the Free Software Foundation; either version 2, 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02110-1301 USA
(use-modules (ice-9 format)
(ice-9 rdelim)
(ice-9 regex)
(srfi srfi-1)
(srfi srfi-37)
(srfi srfi-39))
;;;
;;; Memory usage.
;;;
(define (memory-mappings pid)
"Return an list of alists, each of which contains information about a
memory mapping of process @var{pid}. This information is obtained by reading
@file{/proc/PID/smaps} on Linux. See `procs(5)' for details."
(define mapping-line-rx
(make-regexp
"^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$"))
(define rss-line-rx
(make-regexp
"^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
(with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
(lambda ()
(let loop ((line (read-line))
(result '()))
(if (eof-object? line)
(reverse result)
(cond ((regexp-exec mapping-line-rx line)
=>
(lambda (match)
(let ((mapping-start (string->number
(match:substring match 1)
16))
(mapping-end (string->number
(match:substring match 2)
16))
(access-bits (match:substring match 3))
(name (match:substring match 5)))
(loop (read-line)
(cons `((mapping-start . ,mapping-start)
(mapping-end . ,mapping-end)
(access-bits . ,access-bits)
(name . ,(if (string=? name "")
#f
name)))
result)))))
((regexp-exec rss-line-rx line)
=>
(lambda (match)
(let ((section+ (cons (cons 'rss
(string->number
(match:substring match 1)))
(car result))))
(loop (read-line)
(cons section+ (cdr result))))))
(else
(loop (read-line) result))))))))
(define (total-heap-size pid)
"Return the total heap size of process @var{pid}."
(define heap-or-anon-rx
(make-regexp "\\[(heap|anon)\\]"))
(define private-mapping-rx
(make-regexp "^[r-][w-][x-]p$"))
(fold (lambda (heap total+rss)
(let ((name (assoc-ref heap 'name))
(perm (assoc-ref heap 'access-bits)))
;; Include anonymous private mappings.
(if (or (and (not name)
(regexp-exec private-mapping-rx perm))
(and name
(regexp-exec heap-or-anon-rx name)))
(let ((start (assoc-ref heap 'mapping-start))
(end (assoc-ref heap 'mapping-end))
(rss (assoc-ref heap 'rss)))
(cons (+ (car total+rss) (- end start))
(+ (cdr total+rss) rss)))
total+rss)))
'(0 . 0)
(memory-mappings pid)))
(define (display-stats start end)
(define (->usecs sec+usecs)
(+ (* 1000000 (car sec+usecs))
(cdr sec+usecs)))
(let ((usecs (- (->usecs end) (->usecs start)))
(heap-size (total-heap-size (getpid)))
(gc-heap-size (assoc-ref (gc-stats) 'heap-size)))
(format #t "execution time: ~6,3f seconds~%"
(/ usecs 1000000.0))
(and gc-heap-size
(format #t "GC-reported heap size: ~8d B (~1,2f MiB)~%"
gc-heap-size
(/ gc-heap-size 1024.0 1024.0)))
(format #t "heap size: ~8d B (~1,2f MiB)~%"
(car heap-size)
(/ (car heap-size) 1024.0 1024.0))
(format #t "heap RSS: ~8d KiB (~1,2f MiB)~%"
(cdr heap-size)
(/ (cdr heap-size) 1024.0))
;; (system (format #f "cat /proc/~a/smaps" (getpid)))
;; (system (format #f "exmtool procs | grep -E '^(PID|~a)'" (getpid)))
))
;;;
;;; Larceny/Twobit benchmarking compability layer.
;;;
(define *iteration-count*
(make-parameter #f))
(define (run-benchmark name . args)
"A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking
framework. See
@url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for
details."
(define %concise-invocation?
;; This procedure can be called with only two arguments, NAME and
;; RUN-MAKER.
(procedure? (car args)))
(let ((count (or (*iteration-count*)
(if %concise-invocation? 0 (car args))))
(run-maker (if %concise-invocation? (car args) (cadr args)))
(ok? (if %concise-invocation?
(lambda (result) #t)
(caddr args)))
(args (if %concise-invocation? '() (cdddr args))))
(let loop ((i 0))
(and (< i count)
(let ((result (apply run-maker args)))
(if (not (ok? result))
(begin
(format (current-output-port) "invalid result for `~A'~%"
name)
(exit 1)))
(loop (1+ i)))))))
(define (save-directory-excursion directory thunk)
(let ((previous-dir (getcwd)))
(dynamic-wind
(lambda ()
(chdir directory))
thunk
(lambda ()
(chdir previous-dir)))))
(define (load-larceny-benchmark file)
"Load the Larceny benchmark from @var{file}."
(let ((name (let ((base (basename file)))
(substring base 0 (or (string-rindex base #\.)
(string-length base)))))
(module (let ((m (make-module)))
(beautify-user-module! m)
(module-use! m (resolve-interface '(ice-9 syncase)))
m)))
(save-directory-excursion (dirname file)
(lambda ()
(save-module-excursion
(lambda ()
(set-current-module module)
(module-define! module 'run-benchmark run-benchmark)
(load (basename file))
;; Invoke the benchmark's entry point.
(let ((entry (module-ref (current-module)
(symbol-append (string->symbol name)
'-benchmark))))
(entry))))))))
;;;
;;; Option processing.
;;;
(define %options
(list (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\l "larceny") #f #f
(lambda (opt name arg result)
(alist-cons 'larceny? #t result)))
(option '(#\i "iterations") #t #f
(lambda (opt name arg result)
(alist-cons 'iterations (string->number arg) result)))))
(define (show-help)
(format #t "Usage: gc-profile [OPTIONS] FILE.SCM
Load FILE.SCM, a Guile Scheme source file, and report its execution time and
final heap usage.
-h, --help Show this help message
-l, --larceny Provide mechanisms compatible with the Larceny/Twobit
GC benchmark suite.
-i, --iterations=COUNT
Run the given benchmark COUNT times, regardless of the
iteration count passed to `run-benchmark' (for Larceny
benchmarks).
Report bugs to <bug-guile@gnu.org>.~%"))
(define (parse-args args)
(define (leave fmt . args)
(apply format (current-error-port) (string-append fmt "~%") args)
(exit 1))
(args-fold args %options
(lambda (opt name arg result)
(leave "~A: unrecognized option" opt))
(lambda (file result)
(if (pair? (assoc 'input result))
(leave "~a: only one input file at a time" file)
(alist-cons 'input file result)))
'()))
;;;
;;; Main program.
;;;
(define (main . args)
(let* ((options (parse-args args))
(prog (assoc-ref options 'input))
(load (if (assoc-ref options 'larceny?)
load-larceny-benchmark
load)))
(parameterize ((*iteration-count* (assoc-ref options 'iterations)))
(format #t "running `~a' with Guile ~a...~%" prog (version))
(let ((start (gettimeofday)))
(dynamic-wind
(lambda ()
#t)
(lambda ()
(set! quit (lambda args args))
(load prog))
(lambda ()
(let ((end (gettimeofday)))
(format #t "done~%")
(display-stats start end))))))))

210
gc-benchmarks/gcbench.scm Normal file
View file

@ -0,0 +1,210 @@
; This is adapted from a benchmark written by John Ellis and Pete Kovac
; of Post Communications.
; It was modified by Hans Boehm of Silicon Graphics.
; It was translated into Scheme by William D Clinger of Northeastern Univ;
; the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
; Last modified 30 May 1997.
;
; This is no substitute for real applications. No actual application
; is likely to behave in exactly this way. However, this benchmark was
; designed to be more representative of real applications than other
; Java GC benchmarks of which we are aware.
; It attempts to model those properties of allocation requests that
; are important to current GC techniques.
; It is designed to be used either to obtain a single overall performance
; number, or to give a more detailed estimate of how collector
; performance varies with object lifetimes. It prints the time
; required to allocate and collect balanced binary trees of various
; sizes. Smaller trees result in shorter object lifetimes. Each cycle
; allocates roughly the same amount of memory.
; Two data structures are kept around during the entire process, so
; that the measured performance is representative of applications
; that maintain some live in-memory data. One of these is a tree
; containing many pointers. The other is a large array containing
; double precision floating point numbers. Both should be of comparable
; size.
;
; The results are only really meaningful together with a specification
; of how much memory was used. It is possible to trade memory for
; better time performance. This benchmark should be run in a 32 MB
; heap, though we don't currently know how to enforce that uniformly.
; In the Java version, this routine prints the heap size and the amount
; of free memory. There is no portable way to do this in Scheme; each
; implementation needs its own version.
(use-modules (ice-9 syncase))
(define (PrintDiagnostics)
(display " Total memory available= ???????? bytes")
(display " Free memory= ???????? bytes")
(newline))
(define (run-benchmark str thu)
(display str)
(thu))
; Should we implement a Java class as procedures or hygienic macros?
; Take your pick.
(define-syntax let-class
(syntax-rules
()
;; Put this rule first to implement a class using procedures.
((let-class (((method . args) . method-body) ...) . body)
(let () (define (method . args) . method-body) ... . body))
;; Put this rule first to implement a class using hygienic macros.
((let-class (((method . args) . method-body) ...) . body)
(letrec-syntax ((method (syntax-rules () ((method . args) (begin . method-body))))
...)
. body))
))
(define (gcbench kStretchTreeDepth)
; Nodes used by a tree of a given size
(define (TreeSize i)
(- (expt 2 (+ i 1)) 1))
; Number of iterations to use for a given tree depth
(define (NumIters i)
(quotient (* 2 (TreeSize kStretchTreeDepth))
(TreeSize i)))
; Parameters are determined by kStretchTreeDepth.
; In Boehm's version the parameters were fixed as follows:
; public static final int kStretchTreeDepth = 18; // about 16Mb
; public static final int kLongLivedTreeDepth = 16; // about 4Mb
; public static final int kArraySize = 500000; // about 4Mb
; public static final int kMinTreeDepth = 4;
; public static final int kMaxTreeDepth = 16;
; In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
(let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
(kArraySize (* 4 (TreeSize kLongLivedTreeDepth)))
(kMinTreeDepth 4)
(kMaxTreeDepth kLongLivedTreeDepth))
; Elements 3 and 4 of the allocated vectors are useless.
(let-class (((make-node l r)
(let ((v (make-empty-node)))
(vector-set! v 0 l)
(vector-set! v 1 r)
v))
((make-empty-node) (make-vector 4 0))
((node.left node) (vector-ref node 0))
((node.right node) (vector-ref node 1))
((node.left-set! node x) (vector-set! node 0 x))
((node.right-set! node x) (vector-set! node 1 x)))
; Build tree top down, assigning to older objects.
(define (Populate iDepth thisNode)
(if (<= iDepth 0)
#f
(let ((iDepth (- iDepth 1)))
(node.left-set! thisNode (make-empty-node))
(node.right-set! thisNode (make-empty-node))
(Populate iDepth (node.left thisNode))
(Populate iDepth (node.right thisNode)))))
; Build tree bottom-up
(define (MakeTree iDepth)
(if (<= iDepth 0)
(make-empty-node)
(make-node (MakeTree (- iDepth 1))
(MakeTree (- iDepth 1)))))
(define (TimeConstruction depth)
(let ((iNumIters (NumIters depth)))
(display (string-append "Creating "
(number->string iNumIters)
" trees of depth "
(number->string depth)))
(newline)
(run-benchmark "GCBench: Top down construction"
(lambda ()
(do ((i 0 (+ i 1)))
((>= i iNumIters))
(Populate depth (make-empty-node)))))
(run-benchmark "GCBench: Bottom up construction"
(lambda ()
(do ((i 0 (+ i 1)))
((>= i iNumIters))
(MakeTree depth))))))
(define (main)
(display "Garbage Collector Test")
(newline)
(display (string-append
" Stretching memory with a binary tree of depth "
(number->string kStretchTreeDepth)))
(newline)
(run-benchmark "GCBench: Main"
(lambda ()
; Stretch the memory space quickly
(MakeTree kStretchTreeDepth)
; Create a long lived object
(display (string-append
" Creating a long-lived binary tree of depth "
(number->string kLongLivedTreeDepth)))
(newline)
(let ((longLivedTree (make-empty-node)))
(Populate kLongLivedTreeDepth longLivedTree)
; Create long-lived array, filling half of it
(display (string-append
" Creating a long-lived array of "
(number->string kArraySize)
" inexact reals"))
(newline)
(let ((array (make-vector kArraySize 0.0)))
(do ((i 0 (+ i 1)))
((>= i (quotient kArraySize 2)))
(vector-set! array i (/ 1.0 (exact->inexact i))))
(PrintDiagnostics)
(do ((d kMinTreeDepth (+ d 2)))
((> d kMaxTreeDepth))
(TimeConstruction d))
(if (or (eq? longLivedTree '())
(let ((n (min 1000
(- (quotient (vector-length array)
2)
1))))
(not (= (vector-ref array n)
(/ 1.0 (exact->inexact
n))))))
(begin (display "Failed") (newline)))
; fake reference to LongLivedTree
; and array
; to keep them from being optimized away
))))
(PrintDiagnostics))
(main))))
(define (gc-benchmark . rest)
(let ((k (if (null? rest) 18 (car rest))))
(display "The garbage collector should touch about ")
(display (expt 2 (- k 13)))
(display " megabytes of heap storage.")
(newline)
(display "The use of more or less memory will skew the results.")
(newline)
(run-benchmark (string-append "GCBench" (number->string k))
(lambda () (gcbench k)))))
(gc-benchmark )
(display (gc-stats))

9
gc-benchmarks/guile-test.scm Normal file
View file

@ -0,0 +1,9 @@
(set! %load-path (cons (string-append (getenv "HOME") "/src/guile")
%load-path))
(load "../test-suite/guile-test")
(main `("guile-test"
"--test-suite" ,(string-append (getenv "HOME")
"/src/guile/test-suite/tests")
"--log-file" ",,test-suite.log"))

340
gc-benchmarks/larceny/GPL Normal file
View file

@ -0,0 +1,340 @@
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, 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 General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Library General
Public License instead of this License.

92
gc-benchmarks/larceny/README Normal file
View file

@ -0,0 +1,92 @@
Source Code for Selected GC Benchmarks
These benchmarks are derived from the benchmarks that Lars Hansen used for
his thesis on Older-first garbage collection in practice . That thesis
contains storage profiles and detailed discussion for most of these
benchmarks.
Portability
Apart from a run-benchmark procedure, most of these benchmarks are intended
to run in any R5RS-conforming implementation of Scheme. (The softscheme
benchmark is an exception.) Please report any portability problems that you
encounter.
To find the main entry point(s) of a benchmark, search for calls to
run-benchmark, which calculates and reports the run time and any other
relevant statistics. The run-benchmark procedure is
implementation-dependent; see run-benchmark.chez for an example of how to
write it.
GC Benchmarks
To obtain a gzip'ed tar file containing source code for all of the
benchmarks described below, click here .
dummy
Description: A null benchmark for testing the implementation-specific
run-benchmark procedure.
dynamic
Description: Fritz Henglein's algorithm for dynamic type inference.
Three inputs are available for this benchmark. In increasing order of
size, they are:
1. dynamic.sch, the code for the benchmark itself
2. dynamic-input-small.sch, which is macro-expanded code for the
Twobit compiler
3. dynamic-input-large.sch, which is macro-expanded code for the
Twobit compiler and SPARC assembler.
earley
Description: Earley's context-free parsing algorithm, as implemented by
Marc Feeley, given a simple ambiguous grammar, generating all the parse
trees for a short input.
gcbench
Description: A synthetic benchmark originally written in Java by John
Ellis, Pete Kovac, and Hans Boehm.
graphs
Description: Enumeration of directed graphs, possibly written by Jim
Miller. Makes heavy use of higher-order procedures.
lattice
Description: Enumeration of lattices of monotone maps between lattices,
obtained from Andrew Wright, possibly written by Wright or Jim Miller.
nboyer
Description: Bob Boyer's theorem proving benchmark, with a scaling
parameter suggested by Boyer, some bug fixes noted by Henry Baker and
ourselves, and rewritten to use a more reasonable representation for
the database (with constant-time lookups) instead of property lists
(which gave linear-time lookups for the most widely distributed form of
the boyer benchmark in Scheme).
nucleic2
Description: Marc Feeley et al's Pseudoknot benchmark, revised to use
R5RS macros instead of implementation-dependent macro systems.
perm
Description: Zaks's algorithm for generating a list of permutations.
This is a diabolical garbage collection benchmark with four parameters
M, N, K, and L. The MpermNKL benchmark allocates a queue of size K and
then performs M iterations of the following operation: Fill the queue
with individually computed copies of all permutations of a list of size
N, and then remove the oldest L copies from the queue. At the end of
each iteration, the oldest L/K of the live storage becomes garbage, and
object lifetimes are distributed uniformly between two volumes that
depend upon N, K, and L.
sboyer
Description: This is the nboyer benchmark with a small but effective
tweak: shared consing as implemented by Henry Baker.
softscheme
Description: Andrew's Wright's soft type inference for Scheme. This
software is covered by the GNU GENERAL PUBLIC LICENSE. This benchmark
is nonportable because it uses a low-level syntax definition to define
a non-hygienic defmacro construct. Requires an input file; the inputs
used with the dynamic and twobit benchmarks should be suitable.
twobit
Description: A portable version of the Twobit Scheme compiler and
Larceny's SPARC assembler, written by Will Clinger and Lars Hansen. Two
input files are provided:
1. twobit-input-short.sch, the nucleic2 benchmark stripped of
implementation-specific alternatives to its R4RS macros
2. twobit.sch, the twobit benchmark itself
twobit-smaller.sch
Description: The twobit benchmark without the SPARC assembler.
----------------------------------------------------------------------------
Last updated 4 April 2001.

21
gc-benchmarks/larceny/dumb.sch Normal file
View file

@ -0,0 +1,21 @@
; Dumb benchmark to test the reporting of words marked during gc.
; Example: (foo 1000000)
(define (ballast bytes)
(do ((bytes bytes (- bytes 8))
(x '() (cons bytes x)))
((zero? bytes) x)))
(define (words-benchmark bytes0 bytes1)
(let ((x (ballast bytes0)))
(do ((bytes1 bytes1 (- bytes1 8)))
((not (positive? bytes1))
(car (last-pair x)))
(cons (car x) bytes1))))
(define (foo n)
(collect)
(display-memstats (memstats))
(run-benchmark "foo" (lambda () (words-benchmark 1000000 n)) 1)
(display-memstats (memstats)))

19
gc-benchmarks/larceny/dummy.sch Normal file
View file

@ -0,0 +1,19 @@
; Dummy benchmark (for testing)
;
; $Id: dummy.sch,v 1.2 1999/07/12 18:03:37 lth Exp $
(define (dummy-benchmark . args)
(run-benchmark "dummy"
1
(lambda ()
(collect)
(display "This is the dummy benchmark!")
(newline)
(display "My arguments are: ")
(display args)
(newline)
args)
(lambda (result)
(equal? result args))))
; eof

2111
gc-benchmarks/larceny/dynamic-input-large.sch Normal file
View file

File diff suppressed because one or more lines are too long

1201
gc-benchmarks/larceny/dynamic-input-small.sch Normal file
View file

File diff suppressed because one or more lines are too long

2348
gc-benchmarks/larceny/dynamic.sch Normal file
View file

File diff suppressed because it is too large Load diff

658
gc-benchmarks/larceny/earley.sch Normal file
View file

@ -0,0 +1,658 @@
;;; EARLEY -- Earley's parser, written by Marc Feeley.
; $Id: earley.sch,v 1.2 1999/07/12 18:05:19 lth Exp $
; 990708 / lth -- changed 'main' to 'earley-benchmark'.
;
; (make-parser grammar lexer) is used to create a parser from the grammar
; description `grammar' and the lexer function `lexer'.
;
; A grammar is a list of definitions. Each definition defines a non-terminal
; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
; A given non-terminal can only be defined once. The first non-terminal
; defined is the grammar's goal. Each rule is a possibly empty list of
; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
; can be any scheme value. Note that all grammar symbols are treated as
; non-terminals. This is fine though because the lexer will be outputing
; non-terminals.
;
; The lexer defines what a token is and the mapping between tokens and
; the grammar's non-terminals. It is a function of one argument, the input,
; that returns the list of tokens corresponding to the input. Each token is
; represented by a list. The first element is some `user-defined' information
; associated with the token and the rest represents the token's class(es) (as a
; list of non-terminals that this token corresponds to).
;
; The result of `make-parser' is a function that parses the single input it
; is given into the grammar's goal. The result is a `parse' which can be
; manipulated with the procedures: `parse->parsed?', `parse->trees'
; and `parse->nb-trees' (see below).
;
; Let's assume that we want a parser for the grammar
;
; S -> x = E
; E -> E + E | V
; V -> V y |
;
; and that the input to the parser is a string of characters. Also, assume we
; would like to map the characters `x', `y', `+' and `=' into the corresponding
; non-terminals in the grammar. Such a parser could be created with
;
; (make-parser
; '(
; (s (x = e))
; (e (e + e) (v))
; (v (v y) ())
; )
; (lambda (str)
; (map (lambda (char)
; (list char ; user-info = the character itself
; (case char
; ((#\x) 'x)
; ((#\y) 'y)
; ((#\+) '+)
; ((#\=) '=)
; (else (fatal-error "lexer error")))))
; (string->list str)))
; )
;
; An alternative definition (that does not check for lexical errors) is
;
; (make-parser
; '(
; (s (#\x #\= e))
; (e (e #\+ e) (v))
; (v (v #\y) ())
; )
; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
; )
;
; To help with the rest of the discussion, here are a few definitions:
;
; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
; It indicates a point between two input tokens (0 = beginning, `n' = end).
; For example, if `n' = 4, there are 5 input pointers:
;
; input token1 token2 token3 token4
; input pointers 0 1 2 3 4
;
; A configuration indicates the extent to which a given rule is parsed (this
; is the common `dot notation'). For simplicity, a configuration is
; represented as an integer, with successive configurations in the same
; rule associated with successive integers. It is assumed that the grammar
; has been extended with rules to aid scanning. These rules are of the
; form `nt ->', and there is one such rule for every non-terminal. Note
; that these rules are special because they only apply when the corresponding
; non-terminal is returned by the lexer.
;
; A configuration set is a configuration grouped with the set of input pointers
; representing where the head non-terminal of the configuration was predicted.
;
; Here are the rules and configurations for the grammar given above:
;
; S -> . \
; 0 |
; x -> . |
; 1 |
; = -> . |
; 2 |
; E -> . |
; 3 > special rules (for scanning)
; + -> . |
; 4 |
; V -> . |
; 5 |
; y -> . |
; 6 /
; S -> . x . = . E .
; 7 8 9 10
; E -> . E . + . E .
; 11 12 13 14
; E -> . V .
; 15 16
; V -> . V . y .
; 17 18 19
; V -> .
; 20
;
; Starters of the non-terminal `nt' are configurations that are leftmost
; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
; configurations that are rightmost in any rule for `nt'. Predictors of the
; non-terminal `nt' are configurations that are directly to the left of `nt'
; in any rule.
;
; For the grammar given above,
;
; Starters of V = (17 20)
; Enders of V = (5 19 20)
; Predictors of V = (15 17)
(define (make-parser grammar lexer)
(define (non-terminals grammar) ; return vector of non-terminals in grammar
(define (add-nt nt nts)
(if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
(let def-loop ((defs grammar) (nts '()))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def))
(nts (add-nt head nts)))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nts nts))
(if (pair? l)
(let ((nt (car l)))
(loop (cdr l) (add-nt nt nts)))
(rule-loop (cdr rules) nts))))
(def-loop (cdr defs) nts))))
(list->vector (reverse nts))))) ; goal non-terminal must be at index 0
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (nb-configurations grammar) ; return nb of configurations in grammar
(let def-loop ((defs grammar) (nb-confs 0))
(if (pair? defs)
(let ((def (car defs)))
(let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nb-confs nb-confs))
(if (pair? l)
(loop (cdr l) (+ nb-confs 1))
(rule-loop (cdr rules) (+ nb-confs 1)))))
(def-loop (cdr defs) nb-confs))))
nb-confs)))
; First, associate a numeric identifier to every non-terminal in the
; grammar (with the goal non-terminal associated with 0).
;
; So, for the grammar given above we get:
;
; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
(let* ((nts (non-terminals grammar)) ; id map = list of non-terms
(nb-nts (vector-length nts)) ; the number of non-terms
(nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
(starters (make-vector nb-nts '())) ; starters for every non-term
(enders (make-vector nb-nts '())) ; enders for every non-term
(predictors (make-vector nb-nts '())) ; predictors for every non-term
(steps (make-vector nb-confs #f)) ; what to do in a given conf
(names (make-vector nb-confs #f))) ; name of rules
(define (setup-tables grammar nts starters enders predictors steps names)
(define (add-conf conf nt nts class)
(let ((i (ind nt nts)))
(vector-set! class i (cons conf (vector-ref class i)))))
(let ((nb-nts (vector-length nts)))
(let nt-loop ((i (- nb-nts 1)))
(if (>= i 0)
(begin
(vector-set! steps i (- i nb-nts))
(vector-set! names i (list (vector-ref nts i) 0))
(vector-set! enders i (list i))
(nt-loop (- i 1)))))
(let def-loop ((defs grammar) (conf (vector-length nts)))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
(if (pair? rules)
(let ((rule (car rules)))
(vector-set! names conf (list head rule-num))
(add-conf conf head nts starters)
(let loop ((l rule) (conf conf))
(if (pair? l)
(let ((nt (car l)))
(vector-set! steps conf (ind nt nts))
(add-conf conf nt nts predictors)
(loop (cdr l) (+ conf 1)))
(begin
(vector-set! steps conf (- (ind head nts) nb-nts))
(add-conf conf head nts enders)
(rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
(def-loop (cdr defs) conf))))))))
; Now, for each non-terminal, compute the starters, enders and predictors and
; the names and steps tables.
(setup-tables grammar nts starters enders predictors steps names)
; Build the parser description
(let ((parser-descr (vector lexer
nts
starters
enders
predictors
steps
names)))
(lambda (input)
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (comp-tok tok nts) ; transform token to parsing format
(let loop ((l1 (cdr tok)) (l2 '()))
(if (pair? l1)
(let ((i (ind (car l1) nts)))
(if i
(loop (cdr l1) (cons i l2))
(loop (cdr l1) l2)))
(cons (car tok) (reverse l2)))))
(define (input->tokens input lexer nts)
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
(define (make-states nb-toks nb-confs)
(let ((states (make-vector (+ nb-toks 1) #f)))
(let loop ((i nb-toks))
(if (>= i 0)
(let ((v (make-vector (+ nb-confs 1) #f)))
(vector-set! v 0 -1)
(vector-set! states i v)
(loop (- i 1)))
states))))
(define (conf-set-get state conf)
(vector-ref state (+ conf 1)))
(define (conf-set-get* state state-num conf)
(let ((conf-set (conf-set-get state conf)))
(if conf-set
conf-set
(let ((conf-set (make-vector (+ state-num 6) #f)))
(vector-set! conf-set 1 -3) ; old elems tail (points to head)
(vector-set! conf-set 2 -1) ; old elems head
(vector-set! conf-set 3 -1) ; new elems tail (points to head)
(vector-set! conf-set 4 -1) ; new elems head
(vector-set! state (+ conf 1) conf-set)
conf-set))))
(define (conf-set-merge-new! conf-set)
(vector-set! conf-set
(+ (vector-ref conf-set 1) 5)
(vector-ref conf-set 4))
(vector-set! conf-set 1 (vector-ref conf-set 3))
(vector-set! conf-set 3 -1)
(vector-set! conf-set 4 -1))
(define (conf-set-head conf-set)
(vector-ref conf-set 2))
(define (conf-set-next conf-set i)
(vector-ref conf-set (+ i 5)))
(define (conf-set-member? state conf i)
(let ((conf-set (vector-ref state (+ conf 1))))
(if conf-set
(conf-set-next conf-set i)
#f)))
(define (conf-set-adjoin state conf-set conf i)
(let ((tail (vector-ref conf-set 3))) ; put new element at tail
(vector-set! conf-set (+ i 5) -1)
(vector-set! conf-set (+ tail 5) i)
(vector-set! conf-set 3 i)
(if (< tail 0)
(begin
(vector-set! conf-set 0 (vector-ref state 0))
(vector-set! state 0 conf)))))
(define (conf-set-adjoin* states state-num l i)
(let ((state (vector-ref states state-num)))
(let loop ((l1 l))
(if (pair? l1)
(let* ((conf (car l1))
(conf-set (conf-set-get* state state-num conf)))
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (cdr l1)))
(loop (cdr l1))))))))
(define (conf-set-adjoin** states states* state-num conf i)
(let ((state (vector-ref states state-num)))
(if (conf-set-member? state conf i)
(let* ((state* (vector-ref states* state-num))
(conf-set* (conf-set-get* state* state-num conf)))
(if (not (conf-set-next conf-set* i))
(conf-set-adjoin state* conf-set* conf i))
#t)
#f)))
(define (conf-set-union state conf-set conf other-set)
(let loop ((i (conf-set-head other-set)))
(if (>= i 0)
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (conf-set-next other-set i)))
(loop (conf-set-next other-set i))))))
(define (forw states state-num starters enders predictors steps nts)
(define (predict state state-num conf-set conf nt starters enders)
; add configurations which start the non-terminal `nt' to the
; right of the dot
(let loop1 ((l (vector-ref starters nt)))
(if (pair? l)
(let* ((starter (car l))
(starter-set (conf-set-get* state state-num starter)))
(if (not (conf-set-next starter-set state-num))
(begin
(conf-set-adjoin state starter-set starter state-num)
(loop1 (cdr l)))
(loop1 (cdr l))))))
; check for possible completion of the non-terminal `nt' to the
; right of the dot
(let loop2 ((l (vector-ref enders nt)))
(if (pair? l)
(let ((ender (car l)))
(if (conf-set-member? state ender state-num)
(let* ((next (+ conf 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next conf-set)
(loop2 (cdr l)))
(loop2 (cdr l)))))))
(define (reduce states state state-num conf-set head preds)
; a non-terminal is now completed so check for reductions that
; are now possible at the configurations `preds'
(let loop1 ((l preds))
(if (pair? l)
(let ((pred (car l)))
(let loop2 ((i head))
(if (>= i 0)
(let ((pred-set (conf-set-get (vector-ref states i) pred)))
(if pred-set
(let* ((next (+ pred 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next pred-set)))
(loop2 (conf-set-next conf-set i)))
(loop1 (cdr l))))))))
(let ((state (vector-ref states state-num))
(nb-nts (vector-length nts)))
(let loop ()
(let ((conf (vector-ref state 0)))
(if (>= conf 0)
(let* ((step (vector-ref steps conf))
(conf-set (vector-ref state (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(if (>= step 0)
(predict state state-num conf-set conf step starters enders)
(let ((preds (vector-ref predictors (+ step nb-nts))))
(reduce states state state-num conf-set head preds)))
(loop)))))))
(define (forward starters enders predictors steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(states (make-states nb-toks nb-confs))
(goal-starters (vector-ref starters 0)))
(conf-set-adjoin* states 0 goal-starters 0) ; predict goal
(forw states 0 starters enders predictors steps nts)
(let loop ((i 0))
(if (< i nb-toks)
(let ((tok-nts (cdr (vector-ref toks i))))
(conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
(forw states (+ i 1) starters enders predictors steps nts)
(loop (+ i 1)))))
states))
(define (produce conf i j enders steps toks states states* nb-nts)
(let ((prev (- conf 1)))
(if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
(let loop1 ((l (vector-ref enders (vector-ref steps prev))))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)))
(if (>= k 0)
(begin
(and (>= k i)
(conf-set-adjoin** states states* k prev i)
(conf-set-adjoin** states states* j ender k))
(loop2 (conf-set-next ender-set k)))
(loop1 (cdr l))))
(loop1 (cdr l)))))))))
(define (back states states* state-num enders steps nb-nts toks)
(let ((state* (vector-ref states* state-num)))
(let loop1 ()
(let ((conf (vector-ref state* 0)))
(if (>= conf 0)
(let* ((conf-set (vector-ref state* (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state* 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(let loop2 ((i head))
(if (>= i 0)
(begin
(produce conf i state-num enders steps
toks states states* nb-nts)
(loop2 (conf-set-next conf-set i)))
(loop1)))))))))
(define (backward states enders steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(nb-nts (vector-length nts))
(states* (make-states nb-toks nb-confs))
(goal-enders (vector-ref enders 0)))
(let loop1 ((l goal-enders))
(if (pair? l)
(let ((conf (car l)))
(conf-set-adjoin** states states* nb-toks conf 0)
(loop1 (cdr l)))))
(let loop2 ((i nb-toks))
(if (>= i 0)
(begin
(back states states* i enders steps nb-nts toks)
(loop2 (- i 1)))))
states*))
(define (parsed? nt i j nts enders states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
#t
(loop (cdr l))))
#f)))
#f)))
(define (deriv-trees conf i j enders steps names toks states nb-nts)
(let ((name (vector-ref names conf)))
(if name ; `conf' is at the start of a rule (either special or not)
(if (< conf nb-nts)
(list (list name (car (vector-ref toks i))))
(list (list name)))
(let ((prev (- conf 1)))
(let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
(l2 '()))
(if (pair? l1)
(let* ((ender (car l1))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (l2 l2))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((prev-trees
(deriv-trees prev i k enders steps names
toks states nb-nts))
(ender-trees
(deriv-trees ender k j enders steps names
toks states nb-nts)))
(let loop3 ((l3 ender-trees) (l2 l2))
(if (pair? l3)
(let ((ender-tree (list (car l3))))
(let loop4 ((l4 prev-trees) (l2 l2))
(if (pair? l4)
(loop4 (cdr l4)
(cons (append (car l4)
ender-tree)
l2))
(loop3 (cdr l3) l2))))
(loop2 (conf-set-next ender-set k) l2))))
(loop2 (conf-set-next ender-set k) l2))
(loop1 (cdr l1) l2)))
(loop1 (cdr l1) l2)))
l2))))))
(define (deriv-trees* nt i j nts enders steps names toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (trees '()))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(append (deriv-trees conf i j enders steps names
toks states nb-nts)
trees))
(loop (cdr l) trees)))
trees)))
#f)))
(define (nb-deriv-trees conf i j enders steps toks states nb-nts)
(let ((prev (- conf 1)))
(if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
1
(let loop1 ((l (vector-ref enders (vector-ref steps prev)))
(n 0))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (n n))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((nb-prev-trees
(nb-deriv-trees prev i k enders steps
toks states nb-nts))
(nb-ender-trees
(nb-deriv-trees ender k j enders steps
toks states nb-nts)))
(loop2 (conf-set-next ender-set k)
(+ n (* nb-prev-trees nb-ender-trees))))
(loop2 (conf-set-next ender-set k) n))
(loop1 (cdr l) n)))
(loop1 (cdr l) n)))
n)))))
(define (nb-deriv-trees* nt i j nts enders steps toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (nb-trees 0))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(+ (nb-deriv-trees conf i j enders steps
toks states nb-nts)
nb-trees))
(loop (cdr l) nb-trees)))
nb-trees)))
#f)))
(let* ((lexer (vector-ref parser-descr 0))
(nts (vector-ref parser-descr 1))
(starters (vector-ref parser-descr 2))
(enders (vector-ref parser-descr 3))
(predictors (vector-ref parser-descr 4))
(steps (vector-ref parser-descr 5))
(names (vector-ref parser-descr 6))
(toks (input->tokens input lexer nts)))
(vector nts
starters
enders
predictors
steps
names
toks
(backward (forward starters enders predictors steps nts toks)
enders steps nts toks)
parsed?
deriv-trees*
nb-deriv-trees*))))))
(define (parse->parsed? parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(states (vector-ref parse 7))
(parsed? (vector-ref parse 8)))
(parsed? nt i j nts enders states)))
(define (parse->trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(names (vector-ref parse 5))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(deriv-trees* (vector-ref parse 9)))
(deriv-trees* nt i j nts enders steps names toks states)))
(define (parse->nb-trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(nb-deriv-trees* (vector-ref parse 10)))
(nb-deriv-trees* nt i j nts enders steps toks states)))
(define (test k)
(let ((p (make-parser '( (s (a) (s s)) )
(lambda (l) (map (lambda (x) (list x x)) l)))))
(let ((x (p (vector->list (make-vector k 'a)))))
(length (parse->trees x 's 0 k)))))
(define (earley-benchmark . args)
(let ((k (if (null? args) 9 (car args))))
(run-benchmark
"earley"
1
(lambda () (test k))
(lambda (result)
(display result)
(newline)
#t))))

233
gc-benchmarks/larceny/gcbench.sch Normal file
View file

@ -0,0 +1,233 @@
; This is adapted from a benchmark written by John Ellis and Pete Kovac
; of Post Communications.
; It was modified by Hans Boehm of Silicon Graphics.
; It was translated into Scheme by William D Clinger of Northeastern Univ;
; the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
; It was later hacked by Lars T Hansen of Northeastern University;
; this version has a fixed tree height but accepts a number of
; iterations to run.
;
; Modified 2000-02-15 / lth: changed gc-benchmark to only stretch once,
; and to have a different interface (now accepts iteration numbers,
; not tree height)
; Last modified 2000-07-14 / lth -- fixed a buggy comment about storage
; use in Larceny.
;
; This is no substitute for real applications. No actual application
; is likely to behave in exactly this way. However, this benchmark was
; designed to be more representative of real applications than other
; Java GC benchmarks of which we are aware.
; It attempts to model those properties of allocation requests that
; are important to current GC techniques.
; It is designed to be used either to obtain a single overall performance
; number, or to give a more detailed estimate of how collector
; performance varies with object lifetimes. It prints the time
; required to allocate and collect balanced binary trees of various
; sizes. Smaller trees result in shorter object lifetimes. Each cycle
; allocates roughly the same amount of memory.
; Two data structures are kept around during the entire process, so
; that the measured performance is representative of applications
; that maintain some live in-memory data. One of these is a tree
; containing many pointers. The other is a large array containing
; double precision floating point numbers. Both should be of comparable
; size.
;
; The results are only really meaningful together with a specification
; of how much memory was used. It is possible to trade memory for
; better time performance. This benchmark should be run in a 32 MB
; heap, though we don't currently know how to enforce that uniformly.
; In the Java version, this routine prints the heap size and the amount
; of free memory. There is no portable way to do this in Scheme; each
; implementation needs its own version.
(define (PrintDiagnostics)
(display " Total memory available= ???????? bytes")
(display " Free memory= ???????? bytes")
(newline))
(define (yes answer) #t)
; Should we implement a Java class as procedures or hygienic macros?
; Take your pick.
(define-syntax let-class
(syntax-rules
()
; Put this rule first to implement a class using hygienic macros.
((let-class (((method . args) . method-body) ...) . body)
(letrec-syntax ((method (syntax-rules ()
((method . args) (begin . method-body))))
...)
. body))
; Put this rule first to implement a class using procedures.
((let-class (((method . args) . method-body) ...) . body)
(let () (define (method . args) . method-body) ... . body))
))
(define stretch #t) ; Controls whether stretching phase is run
(define (gcbench kStretchTreeDepth)
; Use for inner calls to reduce noise.
(define (run-benchmark name iters thunk test)
(do ((i 0 (+ i 1)))
((= i iters))
(thunk)))
; Nodes used by a tree of a given size
(define (TreeSize i)
(- (expt 2 (+ i 1)) 1))
; Number of iterations to use for a given tree depth
(define (NumIters i)
(quotient (* 2 (TreeSize kStretchTreeDepth))
(TreeSize i)))
; Parameters are determined by kStretchTreeDepth.
; In Boehm's version the parameters were fixed as follows:
; public static final int kStretchTreeDepth = 18; // about 16Mb
; public static final int kLongLivedTreeDepth = 16; // about 4Mb
; public static final int kArraySize = 500000; // about 4Mb
; public static final int kMinTreeDepth = 4;
; public static final int kMaxTreeDepth = 16;
; wdc: In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
; lth: No they would not. A flonum requires 16 bytes, so the size
; of array + flonums would be 500,000*4 + 500,000*16=10 Mby.
(let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
(kArraySize (* 4 (TreeSize kLongLivedTreeDepth)))
(kMinTreeDepth 4)
(kMaxTreeDepth kLongLivedTreeDepth))
; Elements 3 and 4 of the allocated vectors are useless.
(let-class (((make-node l r)
(let ((v (make-empty-node)))
(vector-set! v 0 l)
(vector-set! v 1 r)
v))
((make-empty-node) (make-vector 4 0))
((node.left node) (vector-ref node 0))
((node.right node) (vector-ref node 1))
((node.left-set! node x) (vector-set! node 0 x))
((node.right-set! node x) (vector-set! node 1 x)))
; Build tree top down, assigning to older objects.
(define (Populate iDepth thisNode)
(if (<= iDepth 0)
#f
(let ((iDepth (- iDepth 1)))
(node.left-set! thisNode (make-empty-node))
(node.right-set! thisNode (make-empty-node))
(Populate iDepth (node.left thisNode))
(Populate iDepth (node.right thisNode)))))
; Build tree bottom-up
(define (MakeTree iDepth)
(if (<= iDepth 0)
(make-empty-node)
(make-node (MakeTree (- iDepth 1))
(MakeTree (- iDepth 1)))))
(define (TimeConstruction depth)
(let ((iNumIters (NumIters depth)))
(display (string-append "Creating "
(number->string iNumIters)
" trees of depth "
(number->string depth)))
(newline)
(run-benchmark "GCBench: Top down construction"
1
(lambda ()
(do ((i 0 (+ i 1)))
((>= i iNumIters))
(Populate depth (make-empty-node))))
yes)
(run-benchmark "GCBench: Bottom up construction"
1
(lambda ()
(do ((i 0 (+ i 1)))
((>= i iNumIters))
(MakeTree depth)))
yes)))
(define (main)
(display "Garbage Collector Test")
(newline)
(if stretch
(begin
(display (string-append
" Stretching memory with a binary tree of depth "
(number->string kStretchTreeDepth)))
(newline)))
(PrintDiagnostics)
(run-benchmark "GCBench: Main"
1
(lambda ()
; Stretch the memory space quickly
(if stretch
(MakeTree kStretchTreeDepth))
; Create a long lived object
(display
(string-append
" Creating a long-lived binary tree of depth "
(number->string kLongLivedTreeDepth)))
(newline)
(let ((longLivedTree (make-empty-node)))
(Populate kLongLivedTreeDepth longLivedTree)
; Create long-lived array, filling half of it
(display (string-append
" Creating a long-lived array of "
(number->string kArraySize)
" inexact reals"))
(newline)
(let ((array (make-vector kArraySize 0.0)))
(do ((i 0 (+ i 1)))
((>= i (quotient kArraySize 2)))
(vector-set! array i
(/ 1.0 (exact->inexact i))))
(PrintDiagnostics)
(do ((d kMinTreeDepth (+ d 2)))
((> d kMaxTreeDepth))
(TimeConstruction d))
(if (or (eq? longLivedTree '())
(let ((n (min 1000
(- (quotient (vector-length array)
2)
1))))
(not (= (vector-ref array n)
(/ 1.0 (exact->inexact n))))))
(begin (display "Failed") (newline)))
; fake reference to LongLivedTree
; and array
; to keep them from being optimized away
)))
yes)
(PrintDiagnostics))
(main))))
(define (gc-benchmark . rest)
(let ((k 18)
(n (if (null? rest) 1 (car rest))))
(display "The garbage collector should touch about ")
(display (expt 2 (- k 13)))
(display " megabytes of heap storage.")
(newline)
(display "The use of more or less memory will skew the results.")
(newline)
(set! stretch #t)
(run-benchmark (string-append "GCBench" (number->string k))
n
(lambda ()
(gcbench k)
(set! stretch #f))
yes)
(set! stretch #t)))

386
gc-benchmarks/larceny/gcold.scm Normal file
View file

@ -0,0 +1,386 @@
;
; GCOld.sch x.x 00/08/03
; translated from GCOld.java 2.0a 00/08/23
;
; Copyright 2000 Sun Microsystems, Inc. All rights reserved.
;
;
; Should be good enough for this benchmark.
(define (newRandom)
(letrec ((random14
(lambda (n)
(set! x (remainder (+ (* a x) c) m))
(remainder (quotient x 8) n)))
(a 701)
(x 1)
(c 743483)
(m 524288)
(loop
(lambda (q r n)
(if (zero? q)
(remainder r n)
(loop (quotient q 16384)
(+ (* 16384 r) (random14 16384))
n)))))
(lambda (n)
(if (and (exact? n) (integer? n) (< n 16384))
(random14 n)
(loop n (random14 16384) n)))))
; A TreeNode is a record with three fields: left, right, val.
; The left and right fields contain a TreeNode or 0, and the
; val field will contain the integer height of the tree.
(define-syntax newTreeNode
(syntax-rules ()
((newTreeNode left right val)
(vector left right val))
((newTreeNode)
(vector 0 0 0))))
(define-syntax TreeNode.left
(syntax-rules ()
((TreeNode.left node)
(vector-ref node 0))))
(define-syntax TreeNode.right
(syntax-rules ()
((TreeNode.right node)
(vector-ref node 1))))
(define-syntax TreeNode.val
(syntax-rules ()
((TreeNode.val node)
(vector-ref node 2))))
(define-syntax setf
(syntax-rules (TreeNode.left TreeNode.right TreeNode.val)
((setf (TreeNode.left node) x)
(vector-set! node 0 x))
((setf (TreeNode.right node) x)
(vector-set! node 1 x))
((setf (TreeNode.val node) x)
(vector-set! node 2 x))))
; Args:
; live-data-size: in megabytes.
; work: units of mutator non-allocation work per byte allocated,
; (in unspecified units. This will affect the promotion rate
; printed at the end of the run: more mutator work per step implies
; fewer steps per second implies fewer bytes promoted per second.)
; short/long ratio: ratio of short-lived bytes allocated to long-lived
; bytes allocated.
; pointer mutation rate: number of pointer mutations per step.
; steps: number of steps to do.
;
(define (GCOld size workUnits promoteRate ptrMutRate steps)
(define (println . args)
(for-each display args)
(newline))
; Rounds an inexact real to two decimal places.
(define (round2 x)
(/ (round (* 100.0 x)) 100.0))
; Returns the height of the given tree.
(define (height t)
(if (eqv? t 0)
0
(+ 1 (max (height (TreeNode.left t))
(height (TreeNode.right t))))))
; Returns the length of the shortest path in the given tree.
(define (shortestPath t)
(if (eqv? t 0)
0
(+ 1 (min (shortestPath (TreeNode.left t))
(shortestPath (TreeNode.right t))))))
; Returns the number of nodes in a balanced tree of the given height.
(define (heightToNodes h)
(- (expt 2 h) 1))
; Returns the height of the largest balanced tree
; that has no more than the given number of nodes.
(define (nodesToHeight nodes)
(do ((h 1 (+ h 1))
(n 1 (+ n n)))
((> (+ n n -1) nodes)
(- h 1))))
(let* (
; Constants.
(null 0) ; Java's null
(pathBits 65536) ; to generate 16 random bits
(MEG 1000000)
(INSIGNIFICANT 999) ; this many bytes don't matter
(bytes/word 4)
(bytes/node 20) ; bytes per tree node in typical JVM
(words/dead 100) ; size of young garbage objects
; Returns the number of bytes in a balanced tree of the given height.
(heightToBytes
(lambda (h)
(* bytes/node (heightToNodes h))))
; Returns the height of the largest balanced tree
; that occupies no more than the given number of bytes.
(bytesToHeight
(lambda (bytes)
(nodesToHeight (/ bytes bytes/node))))
(treeHeight 14)
(treeSize (heightToBytes treeHeight))
(msg1 "Usage: java GCOld <size> <work> <ratio> <mutation> <steps>")
(msg2 " where <size> is the live storage in megabytes")
(msg3 " <work> is the mutator work per step (arbitrary units)")
(msg4 " <ratio> is the ratio of short-lived to long-lived allocation")
(msg5 " <mutation> is the mutations per step")
(msg6 " <steps> is the number of steps")
; Counters (and global variables that discourage optimization).
(youngBytes 0)
(nodes 0)
(actuallyMut 0)
(mutatorSum 0)
(aexport '#())
; Global variables.
(trees '#())
(where 0)
(rnd (newRandom))
)
; Returns a newly allocated balanced binary tree of height h.
(define (makeTree h)
(if (zero? h)
null
(let ((res (newTreeNode)))
(set! nodes (+ nodes 1))
(setf (TreeNode.left res) (makeTree (- h 1)))
(setf (TreeNode.right res) (makeTree (- h 1)))
(setf (TreeNode.val res) h)
res)))
; Allocates approximately size megabytes of trees and stores
; them into a global array.
(define (init)
; Each tree will be about a megabyte.
(let ((ntrees (quotient (* size MEG) treeSize)))
(set! trees (make-vector ntrees null))
(println "Allocating " ntrees " trees.")
(println " (" (* ntrees treeSize) " bytes)")
(do ((i 0 (+ i 1)))
((>= i ntrees))
(vector-set! trees i (makeTree treeHeight))
(doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead))
(println " (" nodes " nodes)")))
; Confirms that all trees are balanced and have the correct height.
(define (checkTrees)
(let ((ntrees (vector-length trees)))
(do ((i 0 (+ i 1)))
((>= i ntrees))
(let* ((t (vector-ref trees i))
(h1 (height t))
(h2 (shortestPath t)))
(if (or (not (= h1 treeHeight))
(not (= h2 treeHeight)))
(println "*****BUG: " h1 " " h2))))))
; Called only by replaceTree (below) and by itself.
(define (replaceTreeWork full partial dir)
(let ((canGoLeft (and (not (eq? (TreeNode.left full) null))
(> (TreeNode.val (TreeNode.left full))
(TreeNode.val partial))))
(canGoRight (and (not (eq? (TreeNode.right full) null))
(> (TreeNode.val (TreeNode.right full))
(TreeNode.val partial)))))
(cond ((and canGoLeft canGoRight)
(if dir
(replaceTreeWork (TreeNode.left full)
partial
(not dir))
(replaceTreeWork (TreeNode.right full)
partial
(not dir))))
((and (not canGoLeft) (not canGoRight))
(if dir
(setf (TreeNode.left full) partial)
(setf (TreeNode.right full) partial)))
((not canGoLeft)
(setf (TreeNode.left full) partial))
(else
(setf (TreeNode.right full) partial)))))
; Given a balanced tree full and a smaller balanced tree partial,
; replaces an appropriate subtree of full by partial, taking care
; to preserve the shape of the full tree.
(define (replaceTree full partial)
(let ((dir (zero? (modulo (TreeNode.val partial) 2))))
(set! actuallyMut (+ actuallyMut 1))
(replaceTreeWork full partial dir)))
; Allocates approximately n bytes of long-lived storage,
; replacing oldest existing long-lived storage.
(define (oldGenAlloc n)
(let ((full (quotient n treeSize))
(partial (modulo n treeSize)))
;(println "In oldGenAlloc, doing "
; full
; " full trees and one partial tree of size "
; partial)
(do ((i 0 (+ i 1)))
((>= i full))
(vector-set! trees where (makeTree treeHeight))
(set! where
(modulo (+ where 1) (vector-length trees))))
(let loop ((partial partial))
(if (> partial INSIGNIFICANT)
(let* ((h (bytesToHeight partial))
(newTree (makeTree h)))
(replaceTree (vector-ref trees where) newTree)
(set! where
(modulo (+ where 1) (vector-length trees)))
(loop (- partial (heightToBytes h))))))))
; Interchanges two randomly selected subtrees (of same size and depth).
(define (oldGenSwapSubtrees)
; Randomly pick:
; * two tree indices
; * A depth
; * A path to that depth.
(let* ((index1 (rnd (vector-length trees)))
(index2 (rnd (vector-length trees)))
(depth (rnd treeHeight))
(path (rnd pathBits))
(tn1 (vector-ref trees index1))
(tn2 (vector-ref trees index2)))
(do ((i 0 (+ i 1)))
((>= i depth))
(if (even? path)
(begin (set! tn1 (TreeNode.left tn1))
(set! tn2 (TreeNode.left tn2)))
(begin (set! tn1 (TreeNode.right tn1))
(set! tn2 (TreeNode.right tn2))))
(set! path (quotient path 2)))
(if (even? path)
(let ((tmp (TreeNode.left tn1)))
(setf (TreeNode.left tn1) (TreeNode.left tn2))
(setf (TreeNode.left tn2) tmp))
(let ((tmp (TreeNode.right tn1)))
(setf (TreeNode.right tn1) (TreeNode.right tn2))
(setf (TreeNode.right tn2) tmp)))
(set! actuallyMut (+ actuallyMut 2))))
; Update "n" old-generation pointers.
(define (oldGenMut n)
(do ((i 0 (+ i 1)))
((>= i (quotient n 2)))
(oldGenSwapSubtrees)))
; Does the amount of mutator work appropriate for n bytes of young-gen
; garbage allocation.
(define (doMutWork n)
(let ((limit (quotient (* workUnits n) 10)))
(do ((k 0 (+ k 1))
(sum 0 (+ sum 1)))
((>= k limit)
; We don't want dead code elimination to eliminate this loop.
(set! mutatorSum (+ mutatorSum sum))))))
; Allocate n bytes of young-gen garbage, in units of "nwords"
; words.
(define (doYoungGenAlloc n nwords)
(let ((nbytes (* nwords bytes/word)))
(do ((allocated 0 (+ allocated nbytes)))
((>= allocated n)
(set! youngBytes (+ youngBytes allocated)))
(set! aexport (make-vector nwords 0)))))
; Allocate "n" bytes of young-gen data; and do the
; corresponding amount of old-gen allocation and pointer
; mutation.
; oldGenAlloc may perform some mutations, so this code
; takes those mutations into account.
(define (doStep n)
(let ((mutations actuallyMut))
(doYoungGenAlloc n words/dead)
(doMutWork n)
; Now do old-gen allocation
(oldGenAlloc (quotient n promoteRate))
(oldGenMut (max 0 (- (+ mutations ptrMutRate) actuallyMut)))))
(println size " megabytes")
(println workUnits " work units per step.")
(println "promotion ratio is 1:" promoteRate)
(println "pointer mutation rate is " ptrMutRate)
(println steps " steps")
(init)
(checkTrees)
(set! youngBytes 0)
(set! nodes 0)
(println "Initialization complete...")
(run-benchmark "GCOld"
1
(lambda ()
(lambda ()
(do ((step 0 (+ step 1)))
((>= step steps))
(doStep MEG))))
(lambda (result) #t))
(checkTrees)
(println "Allocated " steps " Mb of young gen garbage")
(println " (actually allocated "
(round2 (/ youngBytes MEG))
" megabytes)")
(println "Promoted " (round2 (/ steps promoteRate)) " Mb")
(println " (actually promoted "
(round2 (/ (* nodes bytes/node) MEG))
" megabytes)")
(if (not (zero? ptrMutRate))
(println "Mutated " actuallyMut " pointers"))
; This output serves mainly to discourage optimization.
(+ mutatorSum (vector-length aexport))))
(define (gcold-benchmark . args)
(define gcold-iters 1)
(GCOld 25 0 10 10 gcold-iters))

644
gc-benchmarks/larceny/graphs.sch Normal file
View file

@ -0,0 +1,644 @@
; Modified 2 March 1997 by Will Clinger to add graphs-benchmark
; and to expand the four macros below.
; Modified 11 June 1997 by Will Clinger to eliminate assertions
; and to replace a use of "recur" with a named let.
;
; Performance note: (graphs-benchmark 7) allocates
; 34509143 pairs
; 389625 vectors with 2551590 elements
; 56653504 closures (not counting top level and known procedures)
(define (graphs-benchmark . rest)
(let ((N (if (null? rest) 7 (car rest))))
(run-benchmark (string-append "graphs" (number->string N))
(lambda ()
(fold-over-rdg N
2
cons
'())))))
; End of new code.
;;; ==== std.ss ====
; (define-syntax assert
; (syntax-rules ()
; ((assert test info-rest ...)
; #F)))
;
; (define-syntax deny
; (syntax-rules ()
; ((deny test info-rest ...)
; #F)))
;
; (define-syntax when
; (syntax-rules ()
; ((when test e-first e-rest ...)
; (if test
; (begin e-first
; e-rest ...)))))
;
; (define-syntax unless
; (syntax-rules ()
; ((unless test e-first e-rest ...)
; (if (not test)
; (begin e-first
; e-rest ...)))))
(define assert
(lambda (test . info)
#f))
;;; ==== util.ss ====
; Fold over list elements, associating to the left.
(define fold
(lambda (lst folder state)
'(assert (list? lst)
lst)
'(assert (procedure? folder)
folder)
(do ((lst lst
(cdr lst))
(state state
(folder (car lst)
state)))
((null? lst)
state))))
; Given the size of a vector and a procedure which
; sends indicies to desired vector elements, create
; and return the vector.
(define proc->vector
(lambda (size f)
'(assert (and (integer? size)
(exact? size)
(>= size 0))
size)
'(assert (procedure? f)
f)
(if (zero? size)
(vector)
(let ((x (make-vector size (f 0))))
(let loop ((i 1))
(if (< i size) (begin ; [wdc - was when]
(vector-set! x i (f i))
(loop (+ i 1)))))
x))))
(define vector-fold
(lambda (vec folder state)
'(assert (vector? vec)
vec)
'(assert (procedure? folder)
folder)
(let ((len
(vector-length vec)))
(do ((i 0
(+ i 1))
(state state
(folder (vector-ref vec i)
state)))
((= i len)
state)))))
(define vector-map
(lambda (vec proc)
(proc->vector (vector-length vec)
(lambda (i)
(proc (vector-ref vec i))))))
; Given limit, return the list 0, 1, ..., limit-1.
(define giota
(lambda (limit)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
(let -*-
((limit
limit)
(res
'()))
(if (zero? limit)
res
(let ((limit
(- limit 1)))
(-*- limit
(cons limit res)))))))
; Fold over the integers [0, limit).
(define gnatural-fold
(lambda (limit folder state)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? folder)
folder)
(do ((i 0
(+ i 1))
(state state
(folder i state)))
((= i limit)
state))))
; Iterate over the integers [0, limit).
(define gnatural-for-each
(lambda (limit proc!)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? proc!)
proc!)
(do ((i 0
(+ i 1)))
((= i limit))
(proc! i))))
(define natural-for-all?
(lambda (limit ok?)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? ok?)
ok?)
(let -*-
((i 0))
(or (= i limit)
(and (ok? i)
(-*- (+ i 1)))))))
(define natural-there-exists?
(lambda (limit ok?)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? ok?)
ok?)
(let -*-
((i 0))
(and (not (= i limit))
(or (ok? i)
(-*- (+ i 1)))))))
(define there-exists?
(lambda (lst ok?)
'(assert (list? lst)
lst)
'(assert (procedure? ok?)
ok?)
(let -*-
((lst lst))
(and (not (null? lst))
(or (ok? (car lst))
(-*- (cdr lst)))))))
;;; ==== ptfold.ss ====
; Fold over the tree of permutations of a universe.
; Each branch (from the root) is a permutation of universe.
; Each node at depth d corresponds to all permutations which pick the
; elements spelled out on the branch from the root to that node as
; the first d elements.
; Their are two components to the state:
; The b-state is only a function of the branch from the root.
; The t-state is a function of all nodes seen so far.
; At each node, b-folder is called via
; (b-folder elem b-state t-state deeper accross)
; where elem is the next element of the universe picked.
; If b-folder can determine the result of the total tree fold at this stage,
; it should simply return the result.
; If b-folder can determine the result of folding over the sub-tree
; rooted at the resulting node, it should call accross via
; (accross new-t-state)
; where new-t-state is that result.
; Otherwise, b-folder should call deeper via
; (deeper new-b-state new-t-state)
; where new-b-state is the b-state for the new node and new-t-state is
; the new folded t-state.
; At the leaves of the tree, t-folder is called via
; (t-folder b-state t-state accross)
; If t-folder can determine the result of the total tree fold at this stage,
; it should simply return that result.
; If not, it should call accross via
; (accross new-t-state)
; Note, fold-over-perm-tree always calls b-folder in depth-first order.
; I.e., when b-folder is called at depth d, the branch leading to that
; node is the most recent calls to b-folder at all the depths less than d.
; This is a gross efficiency hack so that b-folder can use mutation to
; keep the current branch.
(define fold-over-perm-tree
(lambda (universe b-folder b-state t-folder t-state)
'(assert (list? universe)
universe)
'(assert (procedure? b-folder)
b-folder)
'(assert (procedure? t-folder)
t-folder)
(let -*-
((universe
universe)
(b-state
b-state)
(t-state
t-state)
(accross
(lambda (final-t-state)
final-t-state)))
(if (null? universe)
(t-folder b-state t-state accross)
(let -**-
((in
universe)
(out
'())
(t-state
t-state))
(let* ((first
(car in))
(rest
(cdr in))
(accross
(if (null? rest)
accross
(lambda (new-t-state)
(-**- rest
(cons first out)
new-t-state)))))
(b-folder first
b-state
t-state
(lambda (new-b-state new-t-state)
(-*- (fold out cons rest)
new-b-state
new-t-state
accross))
accross)))))))
;;; ==== minimal.ss ====
; A directed graph is stored as a connection matrix (vector-of-vectors)
; where the first index is the `from' vertex and the second is the `to'
; vertex. Each entry is a bool indicating if the edge exists.
; The diagonal of the matrix is never examined.
; Make-minimal? returns a procedure which tests if a labelling
; of the verticies is such that the matrix is minimal.
; If it is, then the procedure returns the result of folding over
; the elements of the automoriphism group. If not, it returns #F.
; The folding is done by calling folder via
; (folder perm state accross)
; If the folder wants to continue, it should call accross via
; (accross new-state)
; If it just wants the entire minimal? procedure to return something,
; it should return that.
; The ordering used is lexicographic (with #T > #F) and entries
; are examined in the following order:
; 1->0, 0->1
;
; 2->0, 0->2
; 2->1, 1->2
;
; 3->0, 0->3
; 3->1, 1->3
; 3->2, 2->3
; ...
(define make-minimal?
(lambda (max-size)
'(assert (and (integer? max-size)
(exact? max-size)
(>= max-size 0))
max-size)
(let ((iotas
(proc->vector (+ max-size 1)
giota))
(perm
(make-vector max-size 0)))
(lambda (size graph folder state)
'(assert (and (integer? size)
(exact? size)
(<= 0 size max-size))
size
max-size)
'(assert (vector? graph)
graph)
'(assert (procedure? folder)
folder)
(fold-over-perm-tree (vector-ref iotas size)
(lambda (perm-x x state deeper accross)
(case (cmp-next-vertex graph perm x perm-x)
((less)
#F)
((equal)
(vector-set! perm x perm-x)
(deeper (+ x 1)
state))
((more)
(accross state))
(else
(assert #F))))
0
(lambda (leaf-depth state accross)
'(assert (eqv? leaf-depth size)
leaf-depth
size)
(folder perm state accross))
state)))))
; Given a graph, a partial permutation vector, the next input and the next
; output, return 'less, 'equal or 'more depending on the lexicographic
; comparison between the permuted and un-permuted graph.
(define cmp-next-vertex
(lambda (graph perm x perm-x)
(let ((from-x
(vector-ref graph x))
(from-perm-x
(vector-ref graph perm-x)))
(let -*-
((y
0))
(if (= x y)
'equal
(let ((x->y?
(vector-ref from-x y))
(perm-y
(vector-ref perm y)))
(cond ((eq? x->y?
(vector-ref from-perm-x perm-y))
(let ((y->x?
(vector-ref (vector-ref graph y)
x)))
(cond ((eq? y->x?
(vector-ref (vector-ref graph perm-y)
perm-x))
(-*- (+ y 1)))
(y->x?
'less)
(else
'more))))
(x->y?
'less)
(else
'more))))))))
;;; ==== rdg.ss ====
; Fold over rooted directed graphs with bounded out-degree.
; Size is the number of verticies (including the root). Max-out is the
; maximum out-degree for any vertex. Folder is called via
; (folder edges state)
; where edges is a list of length size. The ith element of the list is
; a list of the verticies j for which there is an edge from i to j.
; The last vertex is the root.
(define fold-over-rdg
(lambda (size max-out folder state)
'(assert (and (exact? size)
(integer? size)
(> size 0))
size)
'(assert (and (exact? max-out)
(integer? max-out)
(>= max-out 0))
max-out)
'(assert (procedure? folder)
folder)
(let* ((root
(- size 1))
(edge?
(proc->vector size
(lambda (from)
(make-vector size #F))))
(edges
(make-vector size '()))
(out-degrees
(make-vector size 0))
(minimal-folder
(make-minimal? root))
(non-root-minimal?
(let ((cont
(lambda (perm state accross)
'(assert (eq? state #T)
state)
(accross #T))))
(lambda (size)
(minimal-folder size
edge?
cont
#T))))
(root-minimal?
(let ((cont
(lambda (perm state accross)
'(assert (eq? state #T)
state)
(case (cmp-next-vertex edge? perm root root)
((less)
#F)
((equal more)
(accross #T))
(else
(assert #F))))))
(lambda ()
(minimal-folder root
edge?
cont
#T)))))
(let -*-
((vertex
0)
(state
state))
(cond ((not (non-root-minimal? vertex))
state)
((= vertex root)
'(assert
(begin
(gnatural-for-each root
(lambda (v)
'(assert (= (vector-ref out-degrees v)
(length (vector-ref edges v)))
v
(vector-ref out-degrees v)
(vector-ref edges v))))
#T))
(let ((reach?
(make-reach? root edges))
(from-root
(vector-ref edge? root)))
(let -*-
((v
0)
(outs
0)
(efr
'())
(efrr
'())
(state
state))
(cond ((not (or (= v root)
(= outs max-out)))
(vector-set! from-root v #T)
(let ((state
(-*- (+ v 1)
(+ outs 1)
(cons v efr)
(cons (vector-ref reach? v)
efrr)
state)))
(vector-set! from-root v #F)
(-*- (+ v 1)
outs
efr
efrr
state)))
((and (natural-for-all? root
(lambda (v)
(there-exists? efrr
(lambda (r)
(vector-ref r v)))))
(root-minimal?))
(vector-set! edges root efr)
(folder
(proc->vector size
(lambda (i)
(vector-ref edges i)))
state))
(else
state)))))
(else
(let ((from-vertex
(vector-ref edge? vertex)))
(let -**-
((sv
0)
(outs
0)
(state
state))
(if (= sv vertex)
(begin
(vector-set! out-degrees vertex outs)
(-*- (+ vertex 1)
state))
(let* ((state
; no sv->vertex, no vertex->sv
(-**- (+ sv 1)
outs
state))
(from-sv
(vector-ref edge? sv))
(sv-out
(vector-ref out-degrees sv))
(state
(if (= sv-out max-out)
state
(begin
(vector-set! edges
sv
(cons vertex
(vector-ref edges sv)))
(vector-set! from-sv vertex #T)
(vector-set! out-degrees sv (+ sv-out 1))
(let* ((state
; sv->vertex, no vertex->sv
(-**- (+ sv 1)
outs
state))
(state
(if (= outs max-out)
state
(begin
(vector-set! from-vertex sv #T)
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(let ((state
; sv->vertex, vertex->sv
(-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
(vector-set! from-vertex sv #F)
state)))))
(vector-set! out-degrees sv sv-out)
(vector-set! from-sv vertex #F)
(vector-set! edges
sv
(cdr (vector-ref edges sv)))
state)))))
(if (= outs max-out)
state
(begin
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(vector-set! from-vertex sv #T)
(let ((state
; no sv->vertex, vertex->sv
(-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! from-vertex sv #F)
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
state)))))))))))))
; Given a vector which maps vertex to out-going-edge list,
; return a vector which gives reachability.
(define make-reach?
(lambda (size vertex->out)
(let ((res
(proc->vector size
(lambda (v)
(let ((from-v
(make-vector size #F)))
(vector-set! from-v v #T)
(for-each
(lambda (x)
(vector-set! from-v x #T))
(vector-ref vertex->out v))
from-v)))))
(gnatural-for-each size
(lambda (m)
(let ((from-m
(vector-ref res m)))
(gnatural-for-each size
(lambda (f)
(let ((from-f
(vector-ref res f)))
(if (vector-ref from-f m); [wdc - was when]
(begin
(gnatural-for-each size
(lambda (t)
(if (vector-ref from-m t)
(begin ; [wdc - was when]
(vector-set! from-f t #T)))))))))))))
res)))
;;; ==== test input ====
; Produces all directed graphs with N verticies, distinguished root,
; and out-degree bounded by 2, upto isomorphism (there are 44).
;(define go
; (let ((N 7))
; (fold-over-rdg N
; 2
; cons
; '())))

219
gc-benchmarks/larceny/lattice.sch Normal file
View file

@ -0,0 +1,219 @@
; This benchmark was obtained from Andrew Wright.
; 970215 / wdc Added lattice-benchmark.
; Given a comparison routine that returns one of
; less
; more
; equal
; uncomparable
; return a new comparison routine that applies to sequences.
(define lexico
(lambda (base)
(define lex-fixed
(lambda (fixed lhs rhs)
(define check
(lambda (lhs rhs)
(if (null? lhs)
fixed
(let ((probe
(base (car lhs)
(car rhs))))
(if (or (eq? probe 'equal)
(eq? probe fixed))
(check (cdr lhs)
(cdr rhs))
'uncomparable)))))
(check lhs rhs)))
(define lex-first
(lambda (lhs rhs)
(if (null? lhs)
'equal
(let ((probe
(base (car lhs)
(car rhs))))
(case probe
((less more)
(lex-fixed probe
(cdr lhs)
(cdr rhs)))
((equal)
(lex-first (cdr lhs)
(cdr rhs)))
((uncomparable)
'uncomparable))))))
lex-first))
(define (make-lattice elem-list cmp-func)
(cons elem-list cmp-func))
(define lattice->elements car)
(define lattice->cmp cdr)
; Select elements of a list which pass some test.
(define zulu-select
(lambda (test lst)
(define select-a
(lambda (ac lst)
(if (null? lst)
(reverse! ac)
(select-a
(let ((head (car lst)))
(if (test head)
(cons head ac)
ac))
(cdr lst)))))
(select-a '() lst)))
(define reverse!
(letrec ((rotate
(lambda (fo fum)
(let ((next (cdr fo)))
(set-cdr! fo fum)
(if (null? next)
fo
(rotate next fo))))))
(lambda (lst)
(if (null? lst)
'()
(rotate lst '())))))
; Select elements of a list which pass some test and map a function
; over the result. Note, only efficiency prevents this from being the
; composition of select and map.
(define select-map
(lambda (test func lst)
(define select-a
(lambda (ac lst)
(if (null? lst)
(reverse! ac)
(select-a
(let ((head (car lst)))
(if (test head)
(cons (func head)
ac)
ac))
(cdr lst)))))
(select-a '() lst)))
; This version of map-and tail-recurses on the last test.
(define map-and
(lambda (proc lst)
(if (null? lst)
#T
(letrec ((drudge
(lambda (lst)
(let ((rest (cdr lst)))
(if (null? rest)
(proc (car lst))
(and (proc (car lst))
(drudge rest)))))))
(drudge lst)))))
(define (maps-1 source target pas new)
(let ((scmp (lattice->cmp source))
(tcmp (lattice->cmp target)))
(let ((less
(select-map
(lambda (p)
(eq? 'less
(scmp (car p) new)))
cdr
pas))
(more
(select-map
(lambda (p)
(eq? 'more
(scmp (car p) new)))
cdr
pas)))
(zulu-select
(lambda (t)
(and
(map-and
(lambda (t2)
(memq (tcmp t2 t) '(less equal)))
less)
(map-and
(lambda (t2)
(memq (tcmp t2 t) '(more equal)))
more)))
(lattice->elements target)))))
(define (maps-rest source target pas rest to-1 to-collect)
(if (null? rest)
(to-1 pas)
(let ((next (car rest))
(rest (cdr rest)))
(to-collect
(map
(lambda (x)
(maps-rest source target
(cons
(cons next x)
pas)
rest
to-1
to-collect))
(maps-1 source target pas next))))))
(define (maps source target)
(make-lattice
(maps-rest source
target
'()
(lattice->elements source)
(lambda (x) (list (map cdr x)))
(lambda (x) (apply append x)))
(lexico (lattice->cmp target))))
(define print-frequency 10000)
(define (count-maps source target)
(let ((count 0))
(maps-rest source
target
'()
(lattice->elements source)
(lambda (x)
(set! count (+ count 1))
(if (= 0 (remainder count print-frequency))
(begin #f))
1)
(lambda (x) (apply + x)))))
(define (lattice-benchmark)
(run-benchmark "Lattice"
(lambda ()
(let* ((l2
(make-lattice '(low high)
(lambda (lhs rhs)
(case lhs
((low)
(case rhs
((low)
'equal)
((high)
'less)
(else
(error 'make-lattice "base" rhs))))
((high)
(case rhs
((low)
'more)
((high)
'equal)
(else
(error 'make-lattice "base" rhs))))
(else
(error 'make-lattice "base" lhs))))))
(l3 (maps l2 l2))
(l4 (maps l3 l3)))
(count-maps l2 l2)
(count-maps l3 l3)
(count-maps l2 l3)
(count-maps l3 l2)
(count-maps l4 l4)))))

770
gc-benchmarks/larceny/nboyer.sch Normal file
View file

@ -0,0 +1,770 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: nboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024 520,000
; 1 591777 2,085,000
; 2 1813975 5,175,000
; 3 5375678
; 4 16445406
; 5 51507739
; Nboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (nboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark (string-append "nboyer"
(number->string n))
1
(lambda () (test-boyer n))
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t)))))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (sub1 x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (sub1 a)
(zero))
(equal (sub1 b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f)))))

3772
gc-benchmarks/larceny/nucleic2.sch Normal file
View file

File diff suppressed because it is too large Load diff

324
gc-benchmarks/larceny/perm.sch Normal file
View file

@ -0,0 +1,324 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: perm9.sch
; Description: memory system benchmark using Zaks's permutation generator
; Author: Lars Hansen, Will Clinger, and Gene Luks
; Created: 18-Mar-94
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 940720 / lth Added some more benchmarks for the thesis paper.
; 970215 / wdc Increased problem size from 8 to 9; improved tenperm9-benchmark.
; 970531 / wdc Cleaned up for public release.
; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark.
; This benchmark is in four parts. Each tests a different aspect of
; the memory system.
;
; perm storage allocation
; 10perm storage allocation and garbage collection
; sumperms traversal of a large, linked, self-sharing structure
; mergesort! side effects and write barrier
;
; The perm9 benchmark generates a list of all 362880 permutations of
; the first 9 integers, allocating 1349288 pairs (typically 10,794,304
; bytes), all of which goes into the generated list. (That is, the
; perm9 benchmark generates absolutely no garbage.) This represents
; a savings of about 63% over the storage that would be required by
; an unshared list of permutations. The generated permutations are
; in order of a grey code that bears no obvious relationship to a
; lexicographic order.
;
; The 10perm9 benchmark repeats the perm9 benchmark 10 times, so it
; allocates and reclaims 13492880 pairs (typically 107,943,040 bytes).
; The live storage peaks at twice the storage that is allocated by the
; perm9 benchmark. At the end of each iteration, the oldest half of
; the live storage becomes garbage. Object lifetimes are distributed
; uniformly between 10.3 and 20.6 megabytes.
;
; The 10perm9 benchmark is the 10perm9:2:1 special case of the
; MpermNKL benchmark, which allocates a queue of size K and then
; performs M iterations of the following operation: Fill the queue
; with individually computed copies of all permutations of a list of
; size N, and then remove the oldest L copies from the queue. At the
; end of each iteration, the oldest L/K of the live storage becomes
; garbage, and object lifetimes are distributed uniformly between two
; volumes that depend upon N, K, and L.
;
; The sumperms benchmark computes the sum of the permuted integers
; over all permutations.
;
; The mergesort! benchmark destructively sorts the generated permutations
; into lexicographic order, allocating no storage whatsoever.
;
; The benchmarks are run by calling the following procedures:
;
; (perm-benchmark n)
; (tenperm-benchmark n)
; (sumperms-benchmark n)
; (mergesort-benchmark n)
;
; The argument n may be omitted, in which case it defaults to 9.
;
; These benchmarks assume that
;
; (RUN-BENCHMARK <string> <thunk> <count>)
; (RUN-BENCHMARK <string> <count> <thunk> <predicate>)
;
; reports the time required to call <thunk> the number of times
; specified by <count>, and uses <predicate> to test whether the
; result returned by <thunk> is correct.
; Date: Thu, 17 Mar 94 19:43:32 -0800
; From: luks@sisters.cs.uoregon.edu
; To: will
; Subject: Pancake flips
;
; Procedure P_n generates a grey code of all perms of n elements
; on top of stack ending with reversal of starting sequence
;
; F_n is flip of top n elements.
;
;
; procedure P_n
;
; if n>1 then
; begin
; repeat P_{n-1},F_n n-1 times;
; P_{n-1}
; end
;
(define (permutations x)
(let ((x x)
(perms (list x)))
(define (P n)
(if (> n 1)
(do ((j (- n 1) (- j 1)))
((zero? j)
(P (- n 1)))
(P (- n 1))
(F n))))
(define (F n)
(set! x (revloop x n (list-tail x n)))
(set! perms (cons x perms)))
(define (revloop x n y)
(if (zero? n)
y
(revloop (cdr x)
(- n 1)
(cons (car x) y))))
(define (list-tail x n)
(if (zero? n)
x
(list-tail (cdr x) (- n 1))))
(P (length x))
perms))
; Given a list of lists of numbers, returns the sum of the sums
; of those lists.
;
; for (; x != NULL; x = x->rest)
; for (y = x->first; y != NULL; y = y->rest)
; sum = sum + y->first;
(define (sumlists x)
(do ((x x (cdr x))
(sum 0 (do ((y (car x) (cdr y))
(sum sum (+ sum (car y))))
((null? y) sum))))
((null? x) sum)))
; Destructive merge of two sorted lists.
; From Hansen's MS thesis.
(define (merge!! a b less?)
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)) ))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)) )) )
(cond ((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
;; Stable sort procedure which copies the input list and then sorts
;; the new list imperatively. On the systems we have benchmarked,
;; this generic list sort has been at least as fast and usually much
;; faster than the library's sort routine.
;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren.
(define (sort!! seq less?)
(define (step n)
(cond ((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(merge!! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(if (less? y x)
(begin
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else
'())))
(step (length seq)))
(define lexicographically-less?
(lambda (x y)
(define (lexicographically-less? x y)
(cond ((null? x) (not (null? y)))
((null? y) #f)
((< (car x) (car y)) #t)
((= (car x) (car y))
(lexicographically-less? (cdr x) (cdr y)))
(else #f)))
(lexicographically-less? x y)))
; This procedure isn't used by the benchmarks,
; but is provided as a public service.
(define (internally-imperative-mergesort list less?)
(define (list-copy l)
(define (loop l prev)
(if (null? l)
#t
(let ((q (cons (car l) '())))
(set-cdr! prev q)
(loop (cdr l) q))))
(if (null? l)
l
(let ((first (cons (car l) '())))
(loop (cdr l) first)
first)))
(sort!! (list-copy list) less?))
(define *perms* '())
(define (one..n n)
(do ((n n (- n 1))
(p '() (cons n p)))
((zero? n) p)))
(define (perm-benchmark . rest)
(let ((n (if (null? rest) 9 (car rest))))
(set! *perms* '())
(run-benchmark (string-append "Perm" (number->string n))
1
(lambda ()
(set! *perms* (permutations (one..n n)))
#t)
(lambda (x) #t))))
(define (tenperm-benchmark . rest)
(let ((n (if (null? rest) 9 (car rest))))
(set! *perms* '())
(MpermNKL-benchmark 10 n 2 1)))
(define (MpermNKL-benchmark m n k ell)
(if (and (<= 0 m)
(positive? n)
(positive? k)
(<= 0 ell k))
(let ((id (string-append (number->string m)
"perm"
(number->string n)
":"
(number->string k)
":"
(number->string ell)))
(queue (make-vector k '())))
; Fills queue positions [i, j).
(define (fill-queue i j)
(if (< i j)
(begin (vector-set! queue i (permutations (one..n n)))
(fill-queue (+ i 1) j))))
; Removes ell elements from queue.
(define (flush-queue)
(let loop ((i 0))
(if (< i k)
(begin (vector-set! queue
i
(let ((j (+ i ell)))
(if (< j k)
(vector-ref queue j)
'())))
(loop (+ i 1))))))
(fill-queue 0 (- k ell))
(run-benchmark id
m
(lambda ()
(fill-queue (- k ell) k)
(flush-queue)
queue)
(lambda (q)
(let ((q0 (vector-ref q 0))
(qi (vector-ref q (max 0 (- k ell 1)))))
(or (and (null? q0) (null? qi))
(and (pair? q0)
(pair? qi)
(equal? (car q0) (car qi))))))))
(begin (display "Incorrect arguments to MpermNKL-benchmark")
(newline))))
(define (sumperms-benchmark . rest)
(let ((n (if (null? rest) 9 (car rest))))
(if (or (null? *perms*)
(not (= n (length (car *perms*)))))
(set! *perms* (permutations (one..n n))))
(run-benchmark (string-append "Sumperms" (number->string n))
1
(lambda ()
(sumlists *perms*))
(lambda (x) #t))))
(define (mergesort-benchmark . rest)
(let ((n (if (null? rest) 9 (car rest))))
(if (or (null? *perms*)
(not (= n (length (car *perms*)))))
(set! *perms* (permutations (one..n n))))
(run-benchmark (string-append "Mergesort!" (number->string n))
1
(lambda ()
(sort!! *perms* lexicographically-less?)
#t)
(lambda (x) #t))))

50
gc-benchmarks/larceny/run-benchmark.chez Normal file
View file

@ -0,0 +1,50 @@
;;; Gambit-style run-benchmark.
;;;
;;; Invoke this procedure to run a benchmark.
;;; The first argument is a string identifying the benchmark.
;;; The second argument is the number of times to run the benchmark.
;;; The third argument is a thunk that runs the benchmark.
;;; The fourth argument is a unary predicate that warns if the result
;;; returned by the benchmark is incorrect.
;;;
;;; Example:
;;; (run-benchmark "make-vector"
;;; 1
;;; (lambda () (make-vector 1000000))
;;; (lambda (v) (and (vector? v) (= (vector-length v) #e1e6))))
;;; For backward compatibility, this procedure also works with the
;;; arguments that we once used to run benchmarks in Larceny.
(define (run-benchmark name arg2 . rest)
(let* ((old-style (procedure? arg2))
(thunk (if old-style arg2 (car rest)))
(n (if old-style
(if (null? rest) 1 (car rest))
arg2))
(ok? (if (or old-style (null? (cdr rest)))
(lambda (result) #t)
(cadr rest)))
(result '*))
(define (loop n)
(cond ((zero? n) #t)
((= n 1)
(set! result (thunk)))
(else
(thunk)
(loop (- n 1)))))
(if old-style
(begin (newline)
(display "Warning: Using old-style run-benchmark")
(newline)))
(newline)
(display "--------------------------------------------------------")
(newline)
(display name)
(newline)
; time is a macro supplied by Chez Scheme
(time (loop n))
(if (not (ok? result))
(begin (display "Error: Benchmark program returned wrong result: ")
(write result)
(newline)))))

784
gc-benchmarks/larceny/sboyer.sch Normal file
View file

@ -0,0 +1,784 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: sboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
;;; "sharing cons".
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024
; 1 591777
; 2 1813975
; 3 5375678
; 4 16445406
; 5 51507739
; Sboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (sboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark (string-append "sboyer"
(number->string n))
1
(lambda () (test-boyer n))
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t)))))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (sub1 x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (sub1 a)
(zero))
(equal (sub1 b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
; The next procedure is Henry Baker's sharing CONS, which avoids
; allocation if the result is already in hand.
; The REWRITE and REWRITE-ARGS procedures have been modified to
; use SCONS instead of CONS.
(define (scons x y original)
(if (and (eq? x (car original))
(eq? y (cdr original)))
original
(cons x y)))
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (scons (car term)
(rewrite-args (cdr term))
term)
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (scons (rewrite (car lst))
(rewrite-args (cdr lst))
lst))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f)))))

9319
gc-benchmarks/larceny/softscheme.sch Normal file
View file

File diff suppressed because it is too large Load diff

23798
gc-benchmarks/larceny/twobit-input-long.sch Normal file
View file

File diff suppressed because it is too large Load diff

3623
gc-benchmarks/larceny/twobit-input-short.sch Normal file
View file

File diff suppressed because it is too large Load diff

15408
gc-benchmarks/larceny/twobit-smaller.sch Normal file
View file

File diff suppressed because it is too large Load diff

23798
gc-benchmarks/larceny/twobit.sch Normal file
View file

File diff suppressed because it is too large Load diff

4
gc-benchmarks/loop.scm Normal file
View file

@ -0,0 +1,4 @@
(let loop ((i 10000000))
(and (> i 0)
(loop (1- i))))

269
gc-benchmarks/run-benchmark.scm Executable file
View file

@ -0,0 +1,269 @@
#!/bin/sh
# -*- Scheme -*-
exec ${GUILE-guile} -q -l "$0" \
-c '(apply main (cdr (command-line)))' \
--benchmark-dir="$(dirname $0)" "$@"
!#
;;; 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 General Public License as published by
;;; the Free Software Foundation; either version 2, 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02110-1301 USA
(use-modules (ice-9 rdelim)
(ice-9 popen)
(ice-9 regex)
(ice-9 format)
(srfi srfi-1)
(srfi srfi-37))
;;;
;;; Running Guile.
;;;
(define (run-reference-guile env bench-dir profile-opts bench)
"Run the ``mainstream'' Guile, i.e., Guile 1.9 with its own GC."
(open-input-pipe (string-append
env " "
bench-dir "/gc-profile.scm " profile-opts
" \"" bench "\"")))
(define (run-bdwgc-guile env bench-dir profile-opts options bench)
"Run the Guile port to the Boehm-Demers-Weiser GC (BDW-GC)."
(let ((fsd (assoc-ref options 'free-space-divisor)))
(open-input-pipe (string-append env " "
"GC_FREE_SPACE_DIVISOR="
(number->string fsd)
(if (or (assoc-ref options 'incremental?)
(assoc-ref options 'generational?))
" GC_ENABLE_INCREMENTAL=yes"
"")
(if (assoc-ref options 'generational?)
" GC_PAUSE_TIME_TARGET=999999"
"")
(if (assoc-ref options 'parallel?)
"" ;; let it choose the number of procs
" GC_MARKERS=1")
" "
bench-dir "/gc-profile.scm " profile-opts
" \"" bench "\""))))
;;;
;;; Extracting performance results.
;;;
(define (grep regexp input)
"Read line by line from the @var{input} port and return all matches for
@var{regexp}."
(let ((regexp (if (string? regexp) (make-regexp regexp) regexp)))
(with-input-from-port input
(lambda ()
(let loop ((line (read-line))
(result '()))
(format #t "> ~A~%" line)
(if (eof-object? line)
(reverse result)
(cond ((regexp-exec regexp line)
=>
(lambda (match)
(loop (read-line)
(cons match result))))
(else
(loop (read-line) result)))))))))
(define (parse-result benchmark-output)
(let ((result (grep "^(execution time|heap size):[[:blank:]]+([0-9.]+)"
benchmark-output)))
(fold (lambda (match result)
(cond ((equal? (match:substring match 1) "execution time")
(cons (cons 'execution-time
(string->number (match:substring match 2)))
result))
((equal? (match:substring match 1) "heap size")
(cons (cons 'heap-size
(string->number (match:substring match 2)))
result))
(else
result)))
'()
result)))
(define (pretty-print-result benchmark reference bdwgc)
(define (print-line name result ref?)
(let ((name (string-pad-right name 23))
(time (assoc-ref result 'execution-time))
(heap (assoc-ref result 'heap-size))
(ref-heap (assoc-ref reference 'heap-size))
(ref-time (assoc-ref reference 'execution-time)))
(format #t "~a ~1,2f (~,2fx) ~6,3f (~,2fx)~A~%"
name
(/ heap 1000000.0) (/ heap ref-heap 1.0)
time (/ time ref-time 1.0)
(if (and (not ref?)
(<= heap ref-heap) (<= time ref-time))
" !"
""))))
(format #t "benchmark: `~a'~%" benchmark)
(format #t " heap size (MiB) execution time (s.)~%")
(print-line "Guile" reference #t)
(for-each (lambda (bdwgc)
(let ((name (format #f "BDW-GC, FSD=~a~a"
(assoc-ref bdwgc 'free-space-divisor)
(cond ((assoc-ref bdwgc 'incremental?)
" incr.")
((assoc-ref bdwgc 'generational?)
" gene.")
((assoc-ref bdwgc 'parallel?)
" paral.")
(else "")))))
(print-line name bdwgc #f)))
bdwgc))
;;;
;;; Option processing.
;;;
(define %options
(list (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\r "reference") #t #f
(lambda (opt name arg result)
(alist-cons 'reference-environment arg
(alist-delete 'reference-environment result
eq?))))
(option '(#\b "bdw-gc") #t #f
(lambda (opt name arg result)
(alist-cons 'bdwgc-environment arg
(alist-delete 'bdwgc-environment result
eq?))))
(option '(#\d "benchmark-dir") #t #f
(lambda (opt name arg result)
(alist-cons 'benchmark-directory arg
(alist-delete 'benchmark-directory result
eq?))))
(option '(#\p "profile-options") #t #f
(lambda (opt name arg result)
(let ((opts (assoc-ref result 'profile-options)))
(alist-cons 'profile-options
(string-append opts " " arg)
(alist-delete 'profile-options result
eq?)))))
(option '(#\l "log-file") #t #f
(lambda (opt name arg result)
(alist-cons 'log-port (open-output-file arg)
(alist-delete 'log-port result
eq?))))))
(define %default-options
`((reference-environment . "GUILE=guile")
(benchmark-directory . "./gc-benchmarks")
(log-port . ,(current-output-port))
(profile-options . "")
(input . ())))
(define (show-help)
(format #t "Usage: run-benchmark [OPTIONS] BENCHMARKS...
Run BENCHMARKS (a list of Scheme files) and display a performance
comparison of standard Guile (1.9) and the BDW-GC-based Guile.
-h, --help Show this help message
-r, --reference=ENV
-b, --bdw-gc=ENV
Use ENV as the environment necessary to run the
\"reference\" Guile (1.9) or the BDW-GC-based Guile,
respectively. At a minimum, ENV should define the
`GUILE' environment variable. For example:
--reference='GUILE=/foo/bar/guile LD_LIBRARY_PATH=/foo'
-p, --profile-options=OPTS
Pass OPTS as additional options for `gc-profile.scm'.
-l, --log-file=FILE
Save output to FILE instead of the standard output.
-d, --benchmark-dir=DIR
Use DIR as the GC benchmark directory where `gc-profile.scm'
lives (it is automatically determined by default).
Report bugs to <bug-guile@gnu.org>.~%"))
(define (parse-args args)
(define (leave fmt . args)
(apply format (current-error-port) (string-append fmt "~%") args)
(exit 1))
(args-fold args %options
(lambda (opt name arg result)
(leave "~A: unrecognized option" opt))
(lambda (file result)
(let ((files (or (assoc-ref result 'input) '())))
(alist-cons 'input (cons file files)
(alist-delete 'input result eq?))))
%default-options))
;;;
;;; The main program.
;;;
(define (main . args)
(let* ((args (parse-args args))
(benchmark-files (assoc-ref args 'input)))
(let* ((log (assoc-ref args 'log-port))
(bench-dir (assoc-ref args 'benchmark-directory))
(ref-env (assoc-ref args 'reference-environment))
(bdwgc-env (or (assoc-ref args 'bdwgc-environment)
(string-append "GUILE=" bench-dir
"/../pre-inst-guile")))
(prof-opts (assoc-ref args 'profile-options)))
(for-each (lambda (benchmark)
(let ((ref (parse-result (run-reference-guile ref-env
bench-dir
prof-opts
benchmark)))
(bdwgc (map (lambda (fsd incremental?
generational? parallel?)
(let ((opts
(list
(cons 'free-space-divisor fsd)
(cons 'incremental? incremental?)
(cons 'generational? generational?)
(cons 'parallel? parallel?))))
(append opts
(parse-result
(run-bdwgc-guile bdwgc-env
bench-dir
prof-opts
opts
benchmark)))))
'( 3 6 9 3 3)
'(#f #f #f #t #f) ;; incremental
'(#f #f #f #f #t) ;; generational
'(#f #f #f #f #f)))) ;; parallel
;;(format #t "ref=~A~%" ref)
;;(format #t "bdw-gc=~A~%" bdwgc)
(with-output-to-port log
(lambda ()
(pretty-print-result benchmark ref bdwgc)
(newline)
(force-output)))))
benchmark-files))))

25
gc-benchmarks/string.scm Normal file
View file

@ -0,0 +1,25 @@
;;; From from http://www.ccs.neu.edu/home/will/Twobit/KVW/string.txt .
; string test
; (try 100000)
(define s "abcdef")
(define (grow)
(set! s (string-append "123" s "456" s "789"))
(set! s (string-append
(substring s (quotient (string-length s) 2) (string-length s))
(substring s 0 (+ 1 (quotient (string-length s) 2)))))
s)
(define (trial n)
(do ((i 0 (+ i 1)))
((> (string-length s) n) (string-length s))
(grow)))
(define (try n)
(do ((i 0 (+ i 1)))
((>= i 10) (string-length s))
(set! s "abcdef")
(trial n)))
(try 50000000)

67
ice-9/session.scm
View file

@ -20,12 +20,58 @@
:use-module (ice-9 documentation)
:use-module (ice-9 regex)
:use-module (ice-9 rdelim)
:export (help apropos apropos-internal apropos-fold
apropos-fold-accessible apropos-fold-exported apropos-fold-all
source arity system-module))
:export (help
add-value-help-handler! remove-value-help-handler!
add-name-help-handler! remove-name-help-handler!
apropos apropos-internal apropos-fold apropos-fold-accessible
apropos-fold-exported apropos-fold-all source arity
system-module module-commentary))
(define *value-help-handlers*
`(,(lambda (name value)
(object-documentation value))))
(define (add-value-help-handler! proc)
"Adds a handler for performing `help' on a value.
`proc' will be called as (PROC NAME VALUE). `proc' should return #t to
indicate that it has performed help, a string to override the default
object documentation, or #f to try the other handlers, potentially
falling back on the normal behavior for `help'."
(set! *value-help-handlers* (cons proc *value-help-handlers*)))
(define (remove-value-help-handler! proc)
"Removes a handler for performing `help' on a value."
(set! *value-help-handlers* (delete! proc *value-help-handlers*)))
(define (try-value-help name value)
(or-map (lambda (proc) (proc name value)) *value-help-handlers*))
(define *name-help-handlers* '())
(define (add-name-help-handler! proc)
"Adds a handler for performing `help' on a name.
`proc' will be called with the unevaluated name as its argument. That is
to say, when the user calls `(help FOO)', the name is FOO, exactly as
the user types it.
`proc' should return #t to indicate that it has performed help, a string
to override the default object documentation, or #f to try the other
handlers, potentially falling back on the normal behavior for `help'."
(set! *name-help-handlers* (cons proc *name-help-handlers*)))
(define (remove-name-help-handler! proc)
"Removes a handler for performing `help' on a name."
(set! *name-help-handlers* (delete! proc *name-help-handlers*)))
(define (try-name-help name)
(or-map (lambda (proc) (proc name)) *name-help-handlers*))
;;; Documentation
;;;
(define help
@ -45,6 +91,10 @@ You don't seem to have regular expressions installed.\n"))
type x))))
(cond
;; User-specified
((try-name-help name)
=> (lambda (x) (if (not (eq? x #t)) (display x))))
;; SYMBOL
((symbol? name)
(help-doc name
@ -60,10 +110,11 @@ You don't seem to have regular expressions installed.\n"))
((and (list? name)
(= (length name) 2)
(eq? (car name) 'unquote))
(cond ((object-documentation
(local-eval (cadr name) env))
=> write-line)
(else (not-found 'documentation (cadr name)))))
(let ((doc (try-value-help (cadr name)
(local-eval (cadr name) env))))
(cond ((not doc) (not-found 'documentation (cadr name)))
((eq? doc #t)) ;; pass
(else (write-line doc)))))
;; (quote SYMBOL)
((and (list? name)
@ -109,7 +160,7 @@ You don't seem to have regular expressions installed.\n"))
(let ((entries (apropos-fold (lambda (module name object data)
(cons (list module
name
(object-documentation object)
(try-value-help name object)
(cond ((closure? object)
"a procedure")
((procedure? object)

8
ice-9/syncase.scm
View file

@ -146,9 +146,11 @@
(let ((e ((macro-transformer m)
e
(append r (list eval-closure)))))
(if (null? r)
(sc-expand e)
(sc-chi e r w))))))))))
(if (variable? e)
e
(if (null? r)
(sc-expand e)
(sc-chi e r w)))))))))))
(define generated-symbols (make-weak-key-hash-table 1019))

197
lib/Makefile.am
View file

@ -1,6 +1,6 @@
## DO NOT EDIT! GENERATED AUTOMATICALLY!
## Process this file with automake to produce Makefile.in.
# Copyright (C) 2002-2008 Free Software Foundation, Inc.
# Copyright (C) 2002-2009 Free Software Foundation, Inc.
#
# This file is free software, distributed under the terms of the GNU
# General Public License. As a special exception to the GNU General
@ -9,7 +9,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca autobuild count-one-bits extensions full-read full-write strcase strftime
# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions full-read full-write strcase strftime
AUTOMAKE_OPTIONS = 1.5 gnits
@ -36,17 +36,6 @@ libgnu_la_DEPENDENCIES = $(gl_LTLIBOBJS)
EXTRA_libgnu_la_SOURCES =
libgnu_la_LDFLAGS = $(AM_LDFLAGS)
## begin gnulib module alloca
EXTRA_DIST += alloca.c
EXTRA_libgnu_la_SOURCES += alloca.c
libgnu_la_LIBADD += @LTALLOCA@
libgnu_la_DEPENDENCIES += @LTALLOCA@
## end gnulib module alloca
## begin gnulib module alloca-opt
BUILT_SOURCES += $(ALLOCA_H)
@ -64,6 +53,62 @@ EXTRA_DIST += alloca.in.h
## end gnulib module alloca-opt
## begin gnulib module configmake
# Retrieve values of the variables through 'configure' followed by
# 'make', not directly through 'configure', so that a user who
# sets some of these variables consistently on the 'make' command
# line gets correct results.
#
# One advantage of this approach, compared to the classical
# approach of adding -DLIBDIR=\"$(libdir)\" etc. to AM_CPPFLAGS,
# is that it protects against the use of undefined variables.
# If, say, $(libdir) is not set in the Makefile, LIBDIR is not
# defined by this module, and code using LIBDIR gives a
# compilation error.
#
# Another advantage is that 'make' output is shorter.
#
# Listed in the same order as the GNU makefile conventions.
# The Automake-defined pkg* macros are appended, in the order
# listed in the Automake 1.10a+ documentation.
configmake.h: Makefile
rm -f $@-t $@
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
echo '#define PREFIX "$(prefix)"'; \
echo '#define EXEC_PREFIX "$(exec_prefix)"'; \
echo '#define BINDIR "$(bindir)"'; \
echo '#define SBINDIR "$(sbindir)"'; \
echo '#define LIBEXECDIR "$(libexecdir)"'; \
echo '#define DATAROOTDIR "$(datarootdir)"'; \
echo '#define DATADIR "$(datadir)"'; \
echo '#define SYSCONFDIR "$(sysconfdir)"'; \
echo '#define SHAREDSTATEDIR "$(sharedstatedir)"'; \
echo '#define LOCALSTATEDIR "$(localstatedir)"'; \
echo '#define INCLUDEDIR "$(includedir)"'; \
echo '#define OLDINCLUDEDIR "$(oldincludedir)"'; \
echo '#define DOCDIR "$(docdir)"'; \
echo '#define INFODIR "$(infodir)"'; \
echo '#define HTMLDIR "$(htmldir)"'; \
echo '#define DVIDIR "$(dvidir)"'; \
echo '#define PDFDIR "$(pdfdir)"'; \
echo '#define PSDIR "$(psdir)"'; \
echo '#define LIBDIR "$(libdir)"'; \
echo '#define LISPDIR "$(lispdir)"'; \
echo '#define LOCALEDIR "$(localedir)"'; \
echo '#define MANDIR "$(mandir)"'; \
echo '#define MANEXT "$(manext)"'; \
echo '#define PKGDATADIR "$(pkgdatadir)"'; \
echo '#define PKGINCLUDEDIR "$(pkgincludedir)"'; \
echo '#define PKGLIBDIR "$(pkglibdir)"'; \
echo '#define PKGLIBEXECDIR "$(pkglibexecdir)"'; \
} | sed '/""/d' > $@-t
mv $@-t $@
BUILT_SOURCES += configmake.h
CLEANFILES += configmake.h configmake.h-t
## end gnulib module configmake
## begin gnulib module count-one-bits
@ -91,6 +136,91 @@ EXTRA_DIST += $(top_srcdir)/build-aux/link-warning.h
## end gnulib module link-warning
## begin gnulib module localcharset
libgnu_la_SOURCES += localcharset.h localcharset.c
# We need the following in order to install a simple file in $(libdir)
# which is shared with other installed packages. We use a list of referencing
# packages so that "make uninstall" will remove the file if and only if it
# is not used by another installed package.
# On systems with glibc-2.1 or newer, the file is redundant, therefore we
# avoid installing it.
all-local: charset.alias ref-add.sed ref-del.sed
charset_alias = $(DESTDIR)$(libdir)/charset.alias
charset_tmp = $(DESTDIR)$(libdir)/charset.tmp
install-exec-local: all-local
test $(GLIBC21) != no || $(mkinstalldirs) $(DESTDIR)$(libdir)
if test -f $(charset_alias); then \
sed -f ref-add.sed $(charset_alias) > $(charset_tmp) ; \
$(INSTALL_DATA) $(charset_tmp) $(charset_alias) ; \
rm -f $(charset_tmp) ; \
else \
if test $(GLIBC21) = no; then \
sed -f ref-add.sed charset.alias > $(charset_tmp) ; \
$(INSTALL_DATA) $(charset_tmp) $(charset_alias) ; \
rm -f $(charset_tmp) ; \
fi ; \
fi
uninstall-local: all-local
if test -f $(charset_alias); then \
sed -f ref-del.sed $(charset_alias) > $(charset_tmp); \
if grep '^# Packages using this file: $$' $(charset_tmp) \
> /dev/null; then \
rm -f $(charset_alias); \
else \
$(INSTALL_DATA) $(charset_tmp) $(charset_alias); \
fi; \
rm -f $(charset_tmp); \
fi
charset.alias: config.charset
rm -f t-$@ $@
$(SHELL) $(srcdir)/config.charset '$(host)' > t-$@
mv t-$@ $@
SUFFIXES += .sed .sin
.sin.sed:
rm -f t-$@ $@
sed -e '/^#/d' -e 's/@''PACKAGE''@/$(PACKAGE)/g' $< > t-$@
mv t-$@ $@
CLEANFILES += charset.alias ref-add.sed ref-del.sed
EXTRA_DIST += config.charset ref-add.sin ref-del.sin
## end gnulib module localcharset
## begin gnulib module mbrlen
EXTRA_DIST += mbrlen.c
EXTRA_libgnu_la_SOURCES += mbrlen.c
## end gnulib module mbrlen
## begin gnulib module mbrtowc
EXTRA_DIST += mbrtowc.c
EXTRA_libgnu_la_SOURCES += mbrtowc.c
## end gnulib module mbrtowc
## begin gnulib module mbsinit
EXTRA_DIST += mbsinit.c
EXTRA_libgnu_la_SOURCES += mbsinit.c
## end gnulib module mbsinit
## begin gnulib module safe-read
@ -136,6 +266,13 @@ EXTRA_libgnu_la_SOURCES += strcasecmp.c strncasecmp.c
## end gnulib module strcase
## begin gnulib module streq
EXTRA_DIST += streq.h
## end gnulib module streq
## begin gnulib module strftime
@ -291,10 +428,40 @@ wchar.h: wchar.in.h
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''NEXT_WCHAR_H''@|$(NEXT_WCHAR_H)|g' \
-e 's/@''HAVE_WCHAR_H''@/$(HAVE_WCHAR_H)/g' \
-e 's|@''HAVE_WCHAR_H''@|$(HAVE_WCHAR_H)|g' \
-e 's|@''GNULIB_BTOWC''@|$(GNULIB_BTOWC)|g' \
-e 's|@''GNULIB_WCTOB''@|$(GNULIB_WCTOB)|g' \
-e 's|@''GNULIB_MBSINIT''@|$(GNULIB_MBSINIT)|g' \
-e 's|@''GNULIB_MBRTOWC''@|$(GNULIB_MBRTOWC)|g' \
-e 's|@''GNULIB_MBRLEN''@|$(GNULIB_MBRLEN)|g' \
-e 's|@''GNULIB_MBSRTOWCS''@|$(GNULIB_MBSRTOWCS)|g' \
-e 's|@''GNULIB_MBSNRTOWCS''@|$(GNULIB_MBSNRTOWCS)|g' \
-e 's|@''GNULIB_WCRTOMB''@|$(GNULIB_WCRTOMB)|g' \
-e 's|@''GNULIB_WCSRTOMBS''@|$(GNULIB_WCSRTOMBS)|g' \
-e 's|@''GNULIB_WCSNRTOMBS''@|$(GNULIB_WCSNRTOMBS)|g' \
-e 's|@''GNULIB_WCWIDTH''@|$(GNULIB_WCWIDTH)|g' \
-e 's/@''HAVE_WINT_T''@/$(HAVE_WINT_T)/g' \
-e 's|@''HAVE_WINT_T''@|$(HAVE_WINT_T)|g' \
-e 's|@''HAVE_BTOWC''@|$(HAVE_BTOWC)|g' \
-e 's|@''HAVE_MBSINIT''@|$(HAVE_MBSINIT)|g' \
-e 's|@''HAVE_MBRTOWC''@|$(HAVE_MBRTOWC)|g' \
-e 's|@''HAVE_MBRLEN''@|$(HAVE_MBRLEN)|g' \
-e 's|@''HAVE_MBSRTOWCS''@|$(HAVE_MBSRTOWCS)|g' \
-e 's|@''HAVE_MBSNRTOWCS''@|$(HAVE_MBSNRTOWCS)|g' \
-e 's|@''HAVE_WCRTOMB''@|$(HAVE_WCRTOMB)|g' \
-e 's|@''HAVE_WCSRTOMBS''@|$(HAVE_WCSRTOMBS)|g' \
-e 's|@''HAVE_WCSNRTOMBS''@|$(HAVE_WCSNRTOMBS)|g' \
-e 's|@''HAVE_DECL_WCTOB''@|$(HAVE_DECL_WCTOB)|g' \
-e 's|@''HAVE_DECL_WCWIDTH''@|$(HAVE_DECL_WCWIDTH)|g' \
-e 's|@''REPLACE_MBSTATE_T''@|$(REPLACE_MBSTATE_T)|g' \
-e 's|@''REPLACE_BTOWC''@|$(REPLACE_BTOWC)|g' \
-e 's|@''REPLACE_WCTOB''@|$(REPLACE_WCTOB)|g' \
-e 's|@''REPLACE_MBSINIT''@|$(REPLACE_MBSINIT)|g' \
-e 's|@''REPLACE_MBRTOWC''@|$(REPLACE_MBRTOWC)|g' \
-e 's|@''REPLACE_MBRLEN''@|$(REPLACE_MBRLEN)|g' \
-e 's|@''REPLACE_MBSRTOWCS''@|$(REPLACE_MBSRTOWCS)|g' \
-e 's|@''REPLACE_MBSNRTOWCS''@|$(REPLACE_MBSNRTOWCS)|g' \
-e 's|@''REPLACE_WCRTOMB''@|$(REPLACE_WCRTOMB)|g' \
-e 's|@''REPLACE_WCSRTOMBS''@|$(REPLACE_WCSRTOMBS)|g' \
-e 's|@''REPLACE_WCWIDTH''@|$(REPLACE_WCWIDTH)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/wchar.in.h; \

489
lib/alloca.c
View file

@ -1,489 +0,0 @@
/* alloca.c -- allocate automatically reclaimed memory
(Mostly) portable public-domain implementation -- D A Gwyn
This implementation of the PWB library alloca function,
which is used to allocate space off the run-time stack so
that it is automatically reclaimed upon procedure exit,
was inspired by discussions with J. Q. Johnson of Cornell.
J.Otto Tennant <jot@cray.com> contributed the Cray support.
There are some preprocessor constants that can
be defined when compiling for your specific system, for
improved efficiency; however, the defaults should be okay.
The general concept of this implementation is to keep
track of all alloca-allocated blocks, and reclaim any
that are found to be deeper in the stack than the current
invocation. This heuristic does not reclaim storage as
soon as it becomes invalid, but it will do so eventually.
As a special case, alloca(0) reclaims storage without
allocating any. It is a good idea to use alloca(0) in
your main control loop, etc. to force garbage collection. */
#include <config.h>
#include <alloca.h>
#include <string.h>
#include <stdlib.h>
#ifdef emacs
# include "lisp.h"
# include "blockinput.h"
# ifdef EMACS_FREE
# undef free
# define free EMACS_FREE
# endif
#else
# define memory_full() abort ()
#endif
/* If compiling with GCC 2, this file's not needed. */
#if !defined (__GNUC__) || __GNUC__ < 2
/* If someone has defined alloca as a macro,
there must be some other way alloca is supposed to work. */
# ifndef alloca
# ifdef emacs
# ifdef static
/* actually, only want this if static is defined as ""
-- this is for usg, in which emacs must undefine static
in order to make unexec workable
*/
# ifndef STACK_DIRECTION
you
lose
-- must know STACK_DIRECTION at compile-time
/* Using #error here is not wise since this file should work for
old and obscure compilers. */
# endif /* STACK_DIRECTION undefined */
# endif /* static */
# endif /* emacs */
/* If your stack is a linked list of frames, you have to
provide an "address metric" ADDRESS_FUNCTION macro. */
# if defined (CRAY) && defined (CRAY_STACKSEG_END)
long i00afunc ();
# define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
# else
# define ADDRESS_FUNCTION(arg) &(arg)
# endif
/* Define STACK_DIRECTION if you know the direction of stack
growth for your system; otherwise it will be automatically
deduced at run-time.
STACK_DIRECTION > 0 => grows toward higher addresses
STACK_DIRECTION < 0 => grows toward lower addresses
STACK_DIRECTION = 0 => direction of growth unknown */
# ifndef STACK_DIRECTION
# define STACK_DIRECTION 0 /* Direction unknown. */
# endif
# if STACK_DIRECTION != 0
# define STACK_DIR STACK_DIRECTION /* Known at compile-time. */
# else /* STACK_DIRECTION == 0; need run-time code. */
static int stack_dir; /* 1 or -1 once known. */
# define STACK_DIR stack_dir
static void
find_stack_direction (void)
{
static char *addr = NULL; /* Address of first `dummy', once known. */
auto char dummy; /* To get stack address. */
if (addr == NULL)
{ /* Initial entry. */
addr = ADDRESS_FUNCTION (dummy);
find_stack_direction (); /* Recurse once. */
}
else
{
/* Second entry. */
if (ADDRESS_FUNCTION (dummy) > addr)
stack_dir = 1; /* Stack grew upward. */
else
stack_dir = -1; /* Stack grew downward. */
}
}
# endif /* STACK_DIRECTION == 0 */
/* An "alloca header" is used to:
(a) chain together all alloca'ed blocks;
(b) keep track of stack depth.
It is very important that sizeof(header) agree with malloc
alignment chunk size. The following default should work okay. */
# ifndef ALIGN_SIZE
# define ALIGN_SIZE sizeof(double)
# endif
typedef union hdr
{
char align[ALIGN_SIZE]; /* To force sizeof(header). */
struct
{
union hdr *next; /* For chaining headers. */
char *deep; /* For stack depth measure. */
} h;
} header;
static header *last_alloca_header = NULL; /* -> last alloca header. */
/* Return a pointer to at least SIZE bytes of storage,
which will be automatically reclaimed upon exit from
the procedure that called alloca. Originally, this space
was supposed to be taken from the current stack frame of the
caller, but that method cannot be made to work for some
implementations of C, for example under Gould's UTX/32. */
void *
alloca (size_t size)
{
auto char probe; /* Probes stack depth: */
register char *depth = ADDRESS_FUNCTION (probe);
# if STACK_DIRECTION == 0
if (STACK_DIR == 0) /* Unknown growth direction. */
find_stack_direction ();
# endif
/* Reclaim garbage, defined as all alloca'd storage that
was allocated from deeper in the stack than currently. */
{
register header *hp; /* Traverses linked list. */
# ifdef emacs
BLOCK_INPUT;
# endif
for (hp = last_alloca_header; hp != NULL;)
if ((STACK_DIR > 0 && hp->h.deep > depth)
|| (STACK_DIR < 0 && hp->h.deep < depth))
{
register header *np = hp->h.next;
free (hp); /* Collect garbage. */
hp = np; /* -> next header. */
}
else
break; /* Rest are not deeper. */
last_alloca_header = hp; /* -> last valid storage. */
# ifdef emacs
UNBLOCK_INPUT;
# endif
}
if (size == 0)
return NULL; /* No allocation required. */
/* Allocate combined header + user data storage. */
{
/* Address of header. */
register header *new;
size_t combined_size = sizeof (header) + size;
if (combined_size < sizeof (header))
memory_full ();
new = malloc (combined_size);
if (! new)
memory_full ();
new->h.next = last_alloca_header;
new->h.deep = depth;
last_alloca_header = new;
/* User storage begins just after header. */
return (void *) (new + 1);
}
}
# if defined (CRAY) && defined (CRAY_STACKSEG_END)
# ifdef DEBUG_I00AFUNC
# include <stdio.h>
# endif
# ifndef CRAY_STACK
# define CRAY_STACK
# ifndef CRAY2
/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
struct stack_control_header
{
long shgrow:32; /* Number of times stack has grown. */
long shaseg:32; /* Size of increments to stack. */
long shhwm:32; /* High water mark of stack. */
long shsize:32; /* Current size of stack (all segments). */
};
/* The stack segment linkage control information occurs at
the high-address end of a stack segment. (The stack
grows from low addresses to high addresses.) The initial
part of the stack segment linkage control information is
0200 (octal) words. This provides for register storage
for the routine which overflows the stack. */
struct stack_segment_linkage
{
long ss[0200]; /* 0200 overflow words. */
long sssize:32; /* Number of words in this segment. */
long ssbase:32; /* Offset to stack base. */
long:32;
long sspseg:32; /* Offset to linkage control of previous
segment of stack. */
long:32;
long sstcpt:32; /* Pointer to task common address block. */
long sscsnm; /* Private control structure number for
microtasking. */
long ssusr1; /* Reserved for user. */
long ssusr2; /* Reserved for user. */
long sstpid; /* Process ID for pid based multi-tasking. */
long ssgvup; /* Pointer to multitasking thread giveup. */
long sscray[7]; /* Reserved for Cray Research. */
long ssa0;
long ssa1;
long ssa2;
long ssa3;
long ssa4;
long ssa5;
long ssa6;
long ssa7;
long sss0;
long sss1;
long sss2;
long sss3;
long sss4;
long sss5;
long sss6;
long sss7;
};
# else /* CRAY2 */
/* The following structure defines the vector of words
returned by the STKSTAT library routine. */
struct stk_stat
{
long now; /* Current total stack size. */
long maxc; /* Amount of contiguous space which would
be required to satisfy the maximum
stack demand to date. */
long high_water; /* Stack high-water mark. */
long overflows; /* Number of stack overflow ($STKOFEN) calls. */
long hits; /* Number of internal buffer hits. */
long extends; /* Number of block extensions. */
long stko_mallocs; /* Block allocations by $STKOFEN. */
long underflows; /* Number of stack underflow calls ($STKRETN). */
long stko_free; /* Number of deallocations by $STKRETN. */
long stkm_free; /* Number of deallocations by $STKMRET. */
long segments; /* Current number of stack segments. */
long maxs; /* Maximum number of stack segments so far. */
long pad_size; /* Stack pad size. */
long current_address; /* Current stack segment address. */
long current_size; /* Current stack segment size. This
number is actually corrupted by STKSTAT to
include the fifteen word trailer area. */
long initial_address; /* Address of initial segment. */
long initial_size; /* Size of initial segment. */
};
/* The following structure describes the data structure which trails
any stack segment. I think that the description in 'asdef' is
out of date. I only describe the parts that I am sure about. */
struct stk_trailer
{
long this_address; /* Address of this block. */
long this_size; /* Size of this block (does not include
this trailer). */
long unknown2;
long unknown3;
long link; /* Address of trailer block of previous
segment. */
long unknown5;
long unknown6;
long unknown7;
long unknown8;
long unknown9;
long unknown10;
long unknown11;
long unknown12;
long unknown13;
long unknown14;
};
# endif /* CRAY2 */
# endif /* not CRAY_STACK */
# ifdef CRAY2
/* Determine a "stack measure" for an arbitrary ADDRESS.
I doubt that "lint" will like this much. */
static long
i00afunc (long *address)
{
struct stk_stat status;
struct stk_trailer *trailer;
long *block, size;
long result = 0;
/* We want to iterate through all of the segments. The first
step is to get the stack status structure. We could do this
more quickly and more directly, perhaps, by referencing the
$LM00 common block, but I know that this works. */
STKSTAT (&status);
/* Set up the iteration. */
trailer = (struct stk_trailer *) (status.current_address
+ status.current_size
- 15);
/* There must be at least one stack segment. Therefore it is
a fatal error if "trailer" is null. */
if (trailer == 0)
abort ();
/* Discard segments that do not contain our argument address. */
while (trailer != 0)
{
block = (long *) trailer->this_address;
size = trailer->this_size;
if (block == 0 || size == 0)
abort ();
trailer = (struct stk_trailer *) trailer->link;
if ((block <= address) && (address < (block + size)))
break;
}
/* Set the result to the offset in this segment and add the sizes
of all predecessor segments. */
result = address - block;
if (trailer == 0)
{
return result;
}
do
{
if (trailer->this_size <= 0)
abort ();
result += trailer->this_size;
trailer = (struct stk_trailer *) trailer->link;
}
while (trailer != 0);
/* We are done. Note that if you present a bogus address (one
not in any segment), you will get a different number back, formed
from subtracting the address of the first block. This is probably
not what you want. */
return (result);
}
# else /* not CRAY2 */
/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
Determine the number of the cell within the stack,
given the address of the cell. The purpose of this
routine is to linearize, in some sense, stack addresses
for alloca. */
static long
i00afunc (long address)
{
long stkl = 0;
long size, pseg, this_segment, stack;
long result = 0;
struct stack_segment_linkage *ssptr;
/* Register B67 contains the address of the end of the
current stack segment. If you (as a subprogram) store
your registers on the stack and find that you are past
the contents of B67, you have overflowed the segment.
B67 also points to the stack segment linkage control
area, which is what we are really interested in. */
stkl = CRAY_STACKSEG_END ();
ssptr = (struct stack_segment_linkage *) stkl;
/* If one subtracts 'size' from the end of the segment,
one has the address of the first word of the segment.
If this is not the first segment, 'pseg' will be
nonzero. */
pseg = ssptr->sspseg;
size = ssptr->sssize;
this_segment = stkl - size;
/* It is possible that calling this routine itself caused
a stack overflow. Discard stack segments which do not
contain the target address. */
while (!(this_segment <= address && address <= stkl))
{
# ifdef DEBUG_I00AFUNC
fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
# endif
if (pseg == 0)
break;
stkl = stkl - pseg;
ssptr = (struct stack_segment_linkage *) stkl;
size = ssptr->sssize;
pseg = ssptr->sspseg;
this_segment = stkl - size;
}
result = address - this_segment;
/* If you subtract pseg from the current end of the stack,
you get the address of the previous stack segment's end.
This seems a little convoluted to me, but I'll bet you save
a cycle somewhere. */
while (pseg != 0)
{
# ifdef DEBUG_I00AFUNC
fprintf (stderr, "%011o %011o\n", pseg, size);
# endif
stkl = stkl - pseg;
ssptr = (struct stack_segment_linkage *) stkl;
size = ssptr->sssize;
pseg = ssptr->sspseg;
result += size;
}
return (result);
}
# endif /* not CRAY2 */
# endif /* CRAY */
# endif /* no alloca */
#endif /* not GCC version 2 */

649
lib/config.charset Executable file
View file

@ -0,0 +1,649 @@
#! /bin/sh
# Output a system dependent table of character encoding aliases.
#
# Copyright (C) 2000-2004, 2006-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 2, 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 program; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
#
# The table consists of lines of the form
# ALIAS CANONICAL
#
# ALIAS is the (system dependent) result of "nl_langinfo (CODESET)".
# ALIAS is compared in a case sensitive way.
#
# CANONICAL is the GNU canonical name for this character encoding.
# It must be an encoding supported by libiconv. Support by GNU libc is
# also desirable. CANONICAL is case insensitive. Usually an upper case
# MIME charset name is preferred.
# The current list of GNU canonical charset names is as follows.
#
# name MIME? used by which systems
# ASCII, ANSI_X3.4-1968 glibc solaris freebsd netbsd darwin
# ISO-8859-1 Y glibc aix hpux irix osf solaris freebsd netbsd openbsd darwin
# ISO-8859-2 Y glibc aix hpux irix osf solaris freebsd netbsd openbsd darwin
# ISO-8859-3 Y glibc solaris
# ISO-8859-4 Y osf solaris freebsd netbsd openbsd darwin
# ISO-8859-5 Y glibc aix hpux irix osf solaris freebsd netbsd openbsd darwin
# ISO-8859-6 Y glibc aix hpux solaris
# ISO-8859-7 Y glibc aix hpux irix osf solaris netbsd openbsd darwin
# ISO-8859-8 Y glibc aix hpux osf solaris
# ISO-8859-9 Y glibc aix hpux irix osf solaris darwin
# ISO-8859-13 glibc netbsd openbsd darwin
# ISO-8859-14 glibc
# ISO-8859-15 glibc aix osf solaris freebsd netbsd openbsd darwin
# KOI8-R Y glibc solaris freebsd netbsd openbsd darwin
# KOI8-U Y glibc freebsd netbsd openbsd darwin
# KOI8-T glibc
# CP437 dos
# CP775 dos
# CP850 aix osf dos
# CP852 dos
# CP855 dos
# CP856 aix
# CP857 dos
# CP861 dos
# CP862 dos
# CP864 dos
# CP865 dos
# CP866 freebsd netbsd openbsd darwin dos
# CP869 dos
# CP874 woe32 dos
# CP922 aix
# CP932 aix woe32 dos
# CP943 aix
# CP949 osf woe32 dos
# CP950 woe32 dos
# CP1046 aix
# CP1124 aix
# CP1125 dos
# CP1129 aix
# CP1250 woe32
# CP1251 glibc solaris netbsd openbsd darwin woe32
# CP1252 aix woe32
# CP1253 woe32
# CP1254 woe32
# CP1255 glibc woe32
# CP1256 woe32
# CP1257 woe32
# GB2312 Y glibc aix hpux irix solaris freebsd netbsd darwin
# EUC-JP Y glibc aix hpux irix osf solaris freebsd netbsd darwin
# EUC-KR Y glibc aix hpux irix osf solaris freebsd netbsd darwin
# EUC-TW glibc aix hpux irix osf solaris netbsd
# BIG5 Y glibc aix hpux osf solaris freebsd netbsd darwin
# BIG5-HKSCS glibc solaris
# GBK glibc aix osf solaris woe32 dos
# GB18030 glibc solaris netbsd
# SHIFT_JIS Y hpux osf solaris freebsd netbsd darwin
# JOHAB glibc solaris woe32
# TIS-620 glibc aix hpux osf solaris
# VISCII Y glibc
# TCVN5712-1 glibc
# GEORGIAN-PS glibc
# HP-ROMAN8 hpux
# HP-ARABIC8 hpux
# HP-GREEK8 hpux
# HP-HEBREW8 hpux
# HP-TURKISH8 hpux
# HP-KANA8 hpux
# DEC-KANJI osf
# DEC-HANYU osf
# UTF-8 Y glibc aix hpux osf solaris netbsd darwin
#
# Note: Names which are not marked as being a MIME name should not be used in
# Internet protocols for information interchange (mail, news, etc.).
#
# Note: ASCII and ANSI_X3.4-1968 are synonymous canonical names. Applications
# must understand both names and treat them as equivalent.
#
# The first argument passed to this file is the canonical host specification,
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
# or
# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
host="$1"
os=`echo "$host" | sed -e 's/^[^-]*-[^-]*-\(.*\)$/\1/'`
echo "# This file contains a table of character encoding aliases,"
echo "# suitable for operating system '${os}'."
echo "# It was automatically generated from config.charset."
# List of references, updated during installation:
echo "# Packages using this file: "
case "$os" in
linux-gnulibc1*)
# Linux libc5 doesn't have nl_langinfo(CODESET); therefore
# localcharset.c falls back to using the full locale name
# from the environment variables.
echo "C ASCII"
echo "POSIX ASCII"
for l in af af_ZA ca ca_ES da da_DK de de_AT de_BE de_CH de_DE de_LU \
en en_AU en_BW en_CA en_DK en_GB en_IE en_NZ en_US en_ZA \
en_ZW es es_AR es_BO es_CL es_CO es_DO es_EC es_ES es_GT \
es_HN es_MX es_PA es_PE es_PY es_SV es_US es_UY es_VE et \
et_EE eu eu_ES fi fi_FI fo fo_FO fr fr_BE fr_CA fr_CH fr_FR \
fr_LU ga ga_IE gl gl_ES id id_ID in in_ID is is_IS it it_CH \
it_IT kl kl_GL nl nl_BE nl_NL no no_NO pt pt_BR pt_PT sv \
sv_FI sv_SE; do
echo "$l ISO-8859-1"
echo "$l.iso-8859-1 ISO-8859-1"
echo "$l.iso-8859-15 ISO-8859-15"
echo "$l.iso-8859-15@euro ISO-8859-15"
echo "$l@euro ISO-8859-15"
echo "$l.cp-437 CP437"
echo "$l.cp-850 CP850"
echo "$l.cp-1252 CP1252"
echo "$l.cp-1252@euro CP1252"
#echo "$l.atari-st ATARI-ST" # not a commonly used encoding
echo "$l.utf-8 UTF-8"
echo "$l.utf-8@euro UTF-8"
done
for l in cs cs_CZ hr hr_HR hu hu_HU pl pl_PL ro ro_RO sk sk_SK sl \
sl_SI sr sr_CS sr_YU; do
echo "$l ISO-8859-2"
echo "$l.iso-8859-2 ISO-8859-2"
echo "$l.cp-852 CP852"
echo "$l.cp-1250 CP1250"
echo "$l.utf-8 UTF-8"
done
for l in mk mk_MK ru ru_RU; do
echo "$l ISO-8859-5"
echo "$l.iso-8859-5 ISO-8859-5"
echo "$l.koi8-r KOI8-R"
echo "$l.cp-866 CP866"
echo "$l.cp-1251 CP1251"
echo "$l.utf-8 UTF-8"
done
for l in ar ar_SA; do
echo "$l ISO-8859-6"
echo "$l.iso-8859-6 ISO-8859-6"
echo "$l.cp-864 CP864"
#echo "$l.cp-868 CP868" # not a commonly used encoding
echo "$l.cp-1256 CP1256"
echo "$l.utf-8 UTF-8"
done
for l in el el_GR gr gr_GR; do
echo "$l ISO-8859-7"
echo "$l.iso-8859-7 ISO-8859-7"
echo "$l.cp-869 CP869"
echo "$l.cp-1253 CP1253"
echo "$l.cp-1253@euro CP1253"
echo "$l.utf-8 UTF-8"
echo "$l.utf-8@euro UTF-8"
done
for l in he he_IL iw iw_IL; do
echo "$l ISO-8859-8"
echo "$l.iso-8859-8 ISO-8859-8"
echo "$l.cp-862 CP862"
echo "$l.cp-1255 CP1255"
echo "$l.utf-8 UTF-8"
done
for l in tr tr_TR; do
echo "$l ISO-8859-9"
echo "$l.iso-8859-9 ISO-8859-9"
echo "$l.cp-857 CP857"
echo "$l.cp-1254 CP1254"
echo "$l.utf-8 UTF-8"
done
for l in lt lt_LT lv lv_LV; do
#echo "$l BALTIC" # not a commonly used encoding, wrong encoding name
echo "$l ISO-8859-13"
done
for l in ru_UA uk uk_UA; do
echo "$l KOI8-U"
done
for l in zh zh_CN; do
#echo "$l GB_2312-80" # not a commonly used encoding, wrong encoding name
echo "$l GB2312"
done
for l in ja ja_JP ja_JP.EUC; do
echo "$l EUC-JP"
done
for l in ko ko_KR; do
echo "$l EUC-KR"
done
for l in th th_TH; do
echo "$l TIS-620"
done
for l in fa fa_IR; do
#echo "$l ISIRI-3342" # a broken encoding
echo "$l.utf-8 UTF-8"
done
;;
linux* | *-gnu*)
# With glibc-2.1 or newer, we don't need any canonicalization,
# because glibc has iconv and both glibc and libiconv support all
# GNU canonical names directly. Therefore, the Makefile does not
# need to install the alias file at all.
# The following applies only to glibc-2.0.x and older libcs.
echo "ISO_646.IRV:1983 ASCII"
;;
aix*)
echo "ISO8859-1 ISO-8859-1"
echo "ISO8859-2 ISO-8859-2"
echo "ISO8859-5 ISO-8859-5"
echo "ISO8859-6 ISO-8859-6"
echo "ISO8859-7 ISO-8859-7"
echo "ISO8859-8 ISO-8859-8"
echo "ISO8859-9 ISO-8859-9"
echo "ISO8859-15 ISO-8859-15"
echo "IBM-850 CP850"
echo "IBM-856 CP856"
echo "IBM-921 ISO-8859-13"
echo "IBM-922 CP922"
echo "IBM-932 CP932"
echo "IBM-943 CP943"
echo "IBM-1046 CP1046"
echo "IBM-1124 CP1124"
echo "IBM-1129 CP1129"
echo "IBM-1252 CP1252"
echo "IBM-eucCN GB2312"
echo "IBM-eucJP EUC-JP"
echo "IBM-eucKR EUC-KR"
echo "IBM-eucTW EUC-TW"
echo "big5 BIG5"
echo "GBK GBK"
echo "TIS-620 TIS-620"
echo "UTF-8 UTF-8"
;;
hpux*)
echo "iso88591 ISO-8859-1"
echo "iso88592 ISO-8859-2"
echo "iso88595 ISO-8859-5"
echo "iso88596 ISO-8859-6"
echo "iso88597 ISO-8859-7"
echo "iso88598 ISO-8859-8"
echo "iso88599 ISO-8859-9"
echo "iso885915 ISO-8859-15"
echo "roman8 HP-ROMAN8"
echo "arabic8 HP-ARABIC8"
echo "greek8 HP-GREEK8"
echo "hebrew8 HP-HEBREW8"
echo "turkish8 HP-TURKISH8"
echo "kana8 HP-KANA8"
echo "tis620 TIS-620"
echo "big5 BIG5"
echo "eucJP EUC-JP"
echo "eucKR EUC-KR"
echo "eucTW EUC-TW"
echo "hp15CN GB2312"
#echo "ccdc ?" # what is this?
echo "SJIS SHIFT_JIS"
echo "utf8 UTF-8"
;;
irix*)
echo "ISO8859-1 ISO-8859-1"
echo "ISO8859-2 ISO-8859-2"
echo "ISO8859-5 ISO-8859-5"
echo "ISO8859-7 ISO-8859-7"
echo "ISO8859-9 ISO-8859-9"
echo "eucCN GB2312"
echo "eucJP EUC-JP"
echo "eucKR EUC-KR"
echo "eucTW EUC-TW"
;;
osf*)
echo "ISO8859-1 ISO-8859-1"
echo "ISO8859-2 ISO-8859-2"
echo "ISO8859-4 ISO-8859-4"
echo "ISO8859-5 ISO-8859-5"
echo "ISO8859-7 ISO-8859-7"
echo "ISO8859-8 ISO-8859-8"
echo "ISO8859-9 ISO-8859-9"
echo "ISO8859-15 ISO-8859-15"
echo "cp850 CP850"
echo "big5 BIG5"
echo "dechanyu DEC-HANYU"
echo "dechanzi GB2312"
echo "deckanji DEC-KANJI"
echo "deckorean EUC-KR"
echo "eucJP EUC-JP"
echo "eucKR EUC-KR"
echo "eucTW EUC-TW"
echo "GBK GBK"
echo "KSC5601 CP949"
echo "sdeckanji EUC-JP"
echo "SJIS SHIFT_JIS"
echo "TACTIS TIS-620"
echo "UTF-8 UTF-8"
;;
solaris*)
echo "646 ASCII"
echo "ISO8859-1 ISO-8859-1"
echo "ISO8859-2 ISO-8859-2"
echo "ISO8859-3 ISO-8859-3"
echo "ISO8859-4 ISO-8859-4"
echo "ISO8859-5 ISO-8859-5"
echo "ISO8859-6 ISO-8859-6"
echo "ISO8859-7 ISO-8859-7"
echo "ISO8859-8 ISO-8859-8"
echo "ISO8859-9 ISO-8859-9"
echo "ISO8859-15 ISO-8859-15"
echo "koi8-r KOI8-R"
echo "ansi-1251 CP1251"
echo "BIG5 BIG5"
echo "Big5-HKSCS BIG5-HKSCS"
echo "gb2312 GB2312"
echo "GBK GBK"
echo "GB18030 GB18030"
echo "cns11643 EUC-TW"
echo "5601 EUC-KR"
echo "ko_KR.johap92 JOHAB"
echo "eucJP EUC-JP"
echo "PCK SHIFT_JIS"
echo "TIS620.2533 TIS-620"
#echo "sun_eu_greek ?" # what is this?
echo "UTF-8 UTF-8"
;;
freebsd* | os2*)
# FreeBSD 4.2 doesn't have nl_langinfo(CODESET); therefore
# localcharset.c falls back to using the full locale name
# from the environment variables.
# Likewise for OS/2. OS/2 has XFree86 just like FreeBSD. Just
# reuse FreeBSD's locale data for OS/2.
echo "C ASCII"
echo "US-ASCII ASCII"
for l in la_LN lt_LN; do
echo "$l.ASCII ASCII"
done
for l in da_DK de_AT de_CH de_DE en_AU en_CA en_GB en_US es_ES \
fi_FI fr_BE fr_CA fr_CH fr_FR is_IS it_CH it_IT la_LN \
lt_LN nl_BE nl_NL no_NO pt_PT sv_SE; do
echo "$l.ISO_8859-1 ISO-8859-1"
echo "$l.DIS_8859-15 ISO-8859-15"
done
for l in cs_CZ hr_HR hu_HU la_LN lt_LN pl_PL sl_SI; do
echo "$l.ISO_8859-2 ISO-8859-2"
done
for l in la_LN lt_LT; do
echo "$l.ISO_8859-4 ISO-8859-4"
done
for l in ru_RU ru_SU; do
echo "$l.KOI8-R KOI8-R"
echo "$l.ISO_8859-5 ISO-8859-5"
echo "$l.CP866 CP866"
done
echo "uk_UA.KOI8-U KOI8-U"
echo "zh_TW.BIG5 BIG5"
echo "zh_TW.Big5 BIG5"
echo "zh_CN.EUC GB2312"
echo "ja_JP.EUC EUC-JP"
echo "ja_JP.SJIS SHIFT_JIS"
echo "ja_JP.Shift_JIS SHIFT_JIS"
echo "ko_KR.EUC EUC-KR"
;;
netbsd*)
echo "646 ASCII"
echo "ISO8859-1 ISO-8859-1"
echo "ISO8859-2 ISO-8859-2"
echo "ISO8859-4 ISO-8859-4"
echo "ISO8859-5 ISO-8859-5"
echo "ISO8859-7 ISO-8859-7"
echo "ISO8859-13 ISO-8859-13"
echo "ISO8859-15 ISO-8859-15"
echo "eucCN GB2312"
echo "eucJP EUC-JP"
echo "eucKR EUC-KR"
echo "eucTW EUC-TW"
echo "BIG5 BIG5"
echo "SJIS SHIFT_JIS"
;;
openbsd*)
echo "646 ASCII"
echo "ISO8859-1 ISO-8859-1"
echo "ISO8859-2 ISO-8859-2"
echo "ISO8859-4 ISO-8859-4"
echo "ISO8859-5 ISO-8859-5"
echo "ISO8859-7 ISO-8859-7"
echo "ISO8859-13 ISO-8859-13"
echo "ISO8859-15 ISO-8859-15"
;;
darwin[56]*)
# Darwin 6.8 doesn't have nl_langinfo(CODESET); therefore
# localcharset.c falls back to using the full locale name
# from the environment variables.
echo "C ASCII"
for l in en_AU en_CA en_GB en_US la_LN; do
echo "$l.US-ASCII ASCII"
done
for l in da_DK de_AT de_CH de_DE en_AU en_CA en_GB en_US es_ES \
fi_FI fr_BE fr_CA fr_CH fr_FR is_IS it_CH it_IT nl_BE \
nl_NL no_NO pt_PT sv_SE; do
echo "$l ISO-8859-1"
echo "$l.ISO8859-1 ISO-8859-1"
echo "$l.ISO8859-15 ISO-8859-15"
done
for l in la_LN; do
echo "$l.ISO8859-1 ISO-8859-1"
echo "$l.ISO8859-15 ISO-8859-15"
done
for l in cs_CZ hr_HR hu_HU la_LN pl_PL sl_SI; do
echo "$l.ISO8859-2 ISO-8859-2"
done
for l in la_LN lt_LT; do
echo "$l.ISO8859-4 ISO-8859-4"
done
for l in ru_RU; do
echo "$l.KOI8-R KOI8-R"
echo "$l.ISO8859-5 ISO-8859-5"
echo "$l.CP866 CP866"
done
for l in bg_BG; do
echo "$l.CP1251 CP1251"
done
echo "uk_UA.KOI8-U KOI8-U"
echo "zh_TW.BIG5 BIG5"
echo "zh_TW.Big5 BIG5"
echo "zh_CN.EUC GB2312"
echo "ja_JP.EUC EUC-JP"
echo "ja_JP.SJIS SHIFT_JIS"
echo "ko_KR.EUC EUC-KR"
;;
darwin*)
# Darwin 7.5 has nl_langinfo(CODESET), but it is useless:
# - It returns the empty string when LANG is set to a locale of the
# form ll_CC, although ll_CC/LC_CTYPE is a symlink to an UTF-8
# LC_CTYPE file.
# - The environment variables LANG, LC_CTYPE, LC_ALL are not set by
# the system; nl_langinfo(CODESET) returns "US-ASCII" in this case.
# - The documentation says:
# "... all code that calls BSD system routines should ensure
# that the const *char parameters of these routines are in UTF-8
# encoding. All BSD system functions expect their string
# parameters to be in UTF-8 encoding and nothing else."
# It also says
# "An additional caveat is that string parameters for files,
# paths, and other file-system entities must be in canonical
# UTF-8. In a canonical UTF-8 Unicode string, all decomposable
# characters are decomposed ..."
# but this is not true: You can pass non-decomposed UTF-8 strings
# to file system functions, and it is the OS which will convert
# them to decomposed UTF-8 before accessing the file system.
# - The Apple Terminal application displays UTF-8 by default.
# - However, other applications are free to use different encodings:
# - xterm uses ISO-8859-1 by default.
# - TextEdit uses MacRoman by default.
# We prefer UTF-8 over decomposed UTF-8-MAC because one should
# minimize the use of decomposed Unicode. Unfortunately, through the
# Darwin file system, decomposed UTF-8 strings are leaked into user
# space nevertheless.
echo "* UTF-8"
;;
beos* | haiku*)
# BeOS and Haiku have a single locale, and it has UTF-8 encoding.
echo "* UTF-8"
;;
msdosdjgpp*)
# DJGPP 2.03 doesn't have nl_langinfo(CODESET); therefore
# localcharset.c falls back to using the full locale name
# from the environment variables.
echo "#"
echo "# The encodings given here may not all be correct."
echo "# If you find that the encoding given for your language and"
echo "# country is not the one your DOS machine actually uses, just"
echo "# correct it in this file, and send a mail to"
echo "# Juan Manuel Guerrero <juan.guerrero@gmx.de>"
echo "# and Bruno Haible <bruno@clisp.org>."
echo "#"
echo "C ASCII"
# ISO-8859-1 languages
echo "ca CP850"
echo "ca_ES CP850"
echo "da CP865" # not CP850 ??
echo "da_DK CP865" # not CP850 ??
echo "de CP850"
echo "de_AT CP850"
echo "de_CH CP850"
echo "de_DE CP850"
echo "en CP850"
echo "en_AU CP850" # not CP437 ??
echo "en_CA CP850"
echo "en_GB CP850"
echo "en_NZ CP437"
echo "en_US CP437"
echo "en_ZA CP850" # not CP437 ??
echo "es CP850"
echo "es_AR CP850"
echo "es_BO CP850"
echo "es_CL CP850"
echo "es_CO CP850"
echo "es_CR CP850"
echo "es_CU CP850"
echo "es_DO CP850"
echo "es_EC CP850"
echo "es_ES CP850"
echo "es_GT CP850"
echo "es_HN CP850"
echo "es_MX CP850"
echo "es_NI CP850"
echo "es_PA CP850"
echo "es_PY CP850"
echo "es_PE CP850"
echo "es_SV CP850"
echo "es_UY CP850"
echo "es_VE CP850"
echo "et CP850"
echo "et_EE CP850"
echo "eu CP850"
echo "eu_ES CP850"
echo "fi CP850"
echo "fi_FI CP850"
echo "fr CP850"
echo "fr_BE CP850"
echo "fr_CA CP850"
echo "fr_CH CP850"
echo "fr_FR CP850"
echo "ga CP850"
echo "ga_IE CP850"
echo "gd CP850"
echo "gd_GB CP850"
echo "gl CP850"
echo "gl_ES CP850"
echo "id CP850" # not CP437 ??
echo "id_ID CP850" # not CP437 ??
echo "is CP861" # not CP850 ??
echo "is_IS CP861" # not CP850 ??
echo "it CP850"
echo "it_CH CP850"
echo "it_IT CP850"
echo "lt CP775"
echo "lt_LT CP775"
echo "lv CP775"
echo "lv_LV CP775"
echo "nb CP865" # not CP850 ??
echo "nb_NO CP865" # not CP850 ??
echo "nl CP850"
echo "nl_BE CP850"
echo "nl_NL CP850"
echo "nn CP865" # not CP850 ??
echo "nn_NO CP865" # not CP850 ??
echo "no CP865" # not CP850 ??
echo "no_NO CP865" # not CP850 ??
echo "pt CP850"
echo "pt_BR CP850"
echo "pt_PT CP850"
echo "sv CP850"
echo "sv_SE CP850"
# ISO-8859-2 languages
echo "cs CP852"
echo "cs_CZ CP852"
echo "hr CP852"
echo "hr_HR CP852"
echo "hu CP852"
echo "hu_HU CP852"
echo "pl CP852"
echo "pl_PL CP852"
echo "ro CP852"
echo "ro_RO CP852"
echo "sk CP852"
echo "sk_SK CP852"
echo "sl CP852"
echo "sl_SI CP852"
echo "sq CP852"
echo "sq_AL CP852"
echo "sr CP852" # CP852 or CP866 or CP855 ??
echo "sr_CS CP852" # CP852 or CP866 or CP855 ??
echo "sr_YU CP852" # CP852 or CP866 or CP855 ??
# ISO-8859-3 languages
echo "mt CP850"
echo "mt_MT CP850"
# ISO-8859-5 languages
echo "be CP866"
echo "be_BE CP866"
echo "bg CP866" # not CP855 ??
echo "bg_BG CP866" # not CP855 ??
echo "mk CP866" # not CP855 ??
echo "mk_MK CP866" # not CP855 ??
echo "ru CP866"
echo "ru_RU CP866"
echo "uk CP1125"
echo "uk_UA CP1125"
# ISO-8859-6 languages
echo "ar CP864"
echo "ar_AE CP864"
echo "ar_DZ CP864"
echo "ar_EG CP864"
echo "ar_IQ CP864"
echo "ar_IR CP864"
echo "ar_JO CP864"
echo "ar_KW CP864"
echo "ar_MA CP864"
echo "ar_OM CP864"
echo "ar_QA CP864"
echo "ar_SA CP864"
echo "ar_SY CP864"
# ISO-8859-7 languages
echo "el CP869"
echo "el_GR CP869"
# ISO-8859-8 languages
echo "he CP862"
echo "he_IL CP862"
# ISO-8859-9 languages
echo "tr CP857"
echo "tr_TR CP857"
# Japanese
echo "ja CP932"
echo "ja_JP CP932"
# Chinese
echo "zh_CN GBK"
echo "zh_TW CP950" # not CP938 ??
# Korean
echo "kr CP949" # not CP934 ??
echo "kr_KR CP949" # not CP934 ??
# Thai
echo "th CP874"
echo "th_TH CP874"
# Other
echo "eo CP850"
echo "eo_EO CP850"
;;
esac

462
lib/localcharset.c Normal file
View file

@ -0,0 +1,462 @@
/* Determine a canonical name for the current locale's character encoding.
Copyright (C) 2000-2006, 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 2, 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 program; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
/* Written by Bruno Haible <bruno@clisp.org>. */
#include <config.h>
/* Specification. */
#include "localcharset.h"
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#if defined _WIN32 || defined __WIN32__
# define WIN32_NATIVE
#endif
#if defined __EMX__
/* Assume EMX program runs on OS/2, even if compiled under DOS. */
# ifndef OS2
# define OS2
# endif
#endif
#if !defined WIN32_NATIVE
# if HAVE_LANGINFO_CODESET
# include <langinfo.h>
# else
# if 0 /* see comment below */
# include <locale.h>
# endif
# endif
# ifdef __CYGWIN__
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
# endif
#elif defined WIN32_NATIVE
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
#endif
#if defined OS2
# define INCL_DOS
# include <os2.h>
#endif
#if ENABLE_RELOCATABLE
# include "relocatable.h"
#else
# define relocate(pathname) (pathname)
#endif
/* Get LIBDIR. */
#ifndef LIBDIR
# include "configmake.h"
#endif
#if defined _WIN32 || defined __WIN32__ || defined __CYGWIN__ || defined __EMX__ || defined __DJGPP__
/* Win32, Cygwin, OS/2, DOS */
# define ISSLASH(C) ((C) == '/' || (C) == '\\')
#endif
#ifndef DIRECTORY_SEPARATOR
# define DIRECTORY_SEPARATOR '/'
#endif
#ifndef ISSLASH
# define ISSLASH(C) ((C) == DIRECTORY_SEPARATOR)
#endif
#if HAVE_DECL_GETC_UNLOCKED
# undef getc
# define getc getc_unlocked
#endif
/* The following static variable is declared 'volatile' to avoid a
possible multithread problem in the function get_charset_aliases. If we
are running in a threaded environment, and if two threads initialize
'charset_aliases' simultaneously, both will produce the same value,
and everything will be ok if the two assignments to 'charset_aliases'
are atomic. But I don't know what will happen if the two assignments mix. */
#if __STDC__ != 1
# define volatile /* empty */
#endif
/* Pointer to the contents of the charset.alias file, if it has already been
read, else NULL. Its format is:
ALIAS_1 '\0' CANONICAL_1 '\0' ... ALIAS_n '\0' CANONICAL_n '\0' '\0' */
static const char * volatile charset_aliases;
/* Return a pointer to the contents of the charset.alias file. */
static const char *
get_charset_aliases (void)
{
const char *cp;
cp = charset_aliases;
if (cp == NULL)
{
#if !(defined VMS || defined WIN32_NATIVE || defined __CYGWIN__)
FILE *fp;
const char *dir;
const char *base = "charset.alias";
char *file_name;
/* Make it possible to override the charset.alias location. This is
necessary for running the testsuite before "make install". */
dir = getenv ("CHARSETALIASDIR");
if (dir == NULL || dir[0] == '\0')
dir = relocate (LIBDIR);
/* Concatenate dir and base into freshly allocated file_name. */
{
size_t dir_len = strlen (dir);
size_t base_len = strlen (base);
int add_slash = (dir_len > 0 && !ISSLASH (dir[dir_len - 1]));
file_name = (char *) malloc (dir_len + add_slash + base_len + 1);
if (file_name != NULL)
{
memcpy (file_name, dir, dir_len);
if (add_slash)
file_name[dir_len] = DIRECTORY_SEPARATOR;
memcpy (file_name + dir_len + add_slash, base, base_len + 1);
}
}
if (file_name == NULL || (fp = fopen (file_name, "r")) == NULL)
/* Out of memory or file not found, treat it as empty. */
cp = "";
else
{
/* Parse the file's contents. */
char *res_ptr = NULL;
size_t res_size = 0;
for (;;)
{
int c;
char buf1[50+1];
char buf2[50+1];
size_t l1, l2;
char *old_res_ptr;
c = getc (fp);
if (c == EOF)
break;
if (c == '\n' || c == ' ' || c == '\t')
continue;
if (c == '#')
{
/* Skip comment, to end of line. */
do
c = getc (fp);
while (!(c == EOF || c == '\n'));
if (c == EOF)
break;
continue;
}
ungetc (c, fp);
if (fscanf (fp, "%50s %50s", buf1, buf2) < 2)
break;
l1 = strlen (buf1);
l2 = strlen (buf2);
old_res_ptr = res_ptr;
if (res_size == 0)
{
res_size = l1 + 1 + l2 + 1;
res_ptr = (char *) malloc (res_size + 1);
}
else
{
res_size += l1 + 1 + l2 + 1;
res_ptr = (char *) realloc (res_ptr, res_size + 1);
}
if (res_ptr == NULL)
{
/* Out of memory. */
res_size = 0;
if (old_res_ptr != NULL)
free (old_res_ptr);
break;
}
strcpy (res_ptr + res_size - (l2 + 1) - (l1 + 1), buf1);
strcpy (res_ptr + res_size - (l2 + 1), buf2);
}
fclose (fp);
if (res_size == 0)
cp = "";
else
{
*(res_ptr + res_size) = '\0';
cp = res_ptr;
}
}
if (file_name != NULL)
free (file_name);
#else
# if defined VMS
/* To avoid the troubles of an extra file charset.alias_vms in the
sources of many GNU packages, simply inline the aliases here. */
/* The list of encodings is taken from the OpenVMS 7.3-1 documentation
"Compaq C Run-Time Library Reference Manual for OpenVMS systems"
section 10.7 "Handling Different Character Sets". */
cp = "ISO8859-1" "\0" "ISO-8859-1" "\0"
"ISO8859-2" "\0" "ISO-8859-2" "\0"
"ISO8859-5" "\0" "ISO-8859-5" "\0"
"ISO8859-7" "\0" "ISO-8859-7" "\0"
"ISO8859-8" "\0" "ISO-8859-8" "\0"
"ISO8859-9" "\0" "ISO-8859-9" "\0"
/* Japanese */
"eucJP" "\0" "EUC-JP" "\0"
"SJIS" "\0" "SHIFT_JIS" "\0"
"DECKANJI" "\0" "DEC-KANJI" "\0"
"SDECKANJI" "\0" "EUC-JP" "\0"
/* Chinese */
"eucTW" "\0" "EUC-TW" "\0"
"DECHANYU" "\0" "DEC-HANYU" "\0"
"DECHANZI" "\0" "GB2312" "\0"
/* Korean */
"DECKOREAN" "\0" "EUC-KR" "\0";
# endif
# if defined WIN32_NATIVE || defined __CYGWIN__
/* To avoid the troubles of installing a separate file in the same
directory as the DLL and of retrieving the DLL's directory at
runtime, simply inline the aliases here. */
cp = "CP936" "\0" "GBK" "\0"
"CP1361" "\0" "JOHAB" "\0"
"CP20127" "\0" "ASCII" "\0"
"CP20866" "\0" "KOI8-R" "\0"
"CP20936" "\0" "GB2312" "\0"
"CP21866" "\0" "KOI8-RU" "\0"
"CP28591" "\0" "ISO-8859-1" "\0"
"CP28592" "\0" "ISO-8859-2" "\0"
"CP28593" "\0" "ISO-8859-3" "\0"
"CP28594" "\0" "ISO-8859-4" "\0"
"CP28595" "\0" "ISO-8859-5" "\0"
"CP28596" "\0" "ISO-8859-6" "\0"
"CP28597" "\0" "ISO-8859-7" "\0"
"CP28598" "\0" "ISO-8859-8" "\0"
"CP28599" "\0" "ISO-8859-9" "\0"
"CP28605" "\0" "ISO-8859-15" "\0"
"CP38598" "\0" "ISO-8859-8" "\0"
"CP51932" "\0" "EUC-JP" "\0"
"CP51936" "\0" "GB2312" "\0"
"CP51949" "\0" "EUC-KR" "\0"
"CP51950" "\0" "EUC-TW" "\0"
"CP54936" "\0" "GB18030" "\0"
"CP65001" "\0" "UTF-8" "\0";
# endif
#endif
charset_aliases = cp;
}
return cp;
}
/* Determine the current locale's character encoding, and canonicalize it
into one of the canonical names listed in config.charset.
The result must not be freed; it is statically allocated.
If the canonical name cannot be determined, the result is a non-canonical
name. */
#ifdef STATIC
STATIC
#endif
const char *
locale_charset (void)
{
const char *codeset;
const char *aliases;
#if !(defined WIN32_NATIVE || defined OS2)
# if HAVE_LANGINFO_CODESET
/* Most systems support nl_langinfo (CODESET) nowadays. */
codeset = nl_langinfo (CODESET);
# ifdef __CYGWIN__
/* Cygwin 2006 does not have locales. nl_langinfo (CODESET) always
returns "US-ASCII". As long as this is not fixed, return the suffix
of the locale name from the environment variables (if present) or
the codepage as a number. */
if (codeset != NULL && strcmp (codeset, "US-ASCII") == 0)
{
const char *locale;
static char buf[2 + 10 + 1];
locale = getenv ("LC_ALL");
if (locale == NULL || locale[0] == '\0')
{
locale = getenv ("LC_CTYPE");
if (locale == NULL || locale[0] == '\0')
locale = getenv ("LANG");
}
if (locale != NULL && locale[0] != '\0')
{
/* If the locale name contains an encoding after the dot, return
it. */
const char *dot = strchr (locale, '.');
if (dot != NULL)
{
const char *modifier;
dot++;
/* Look for the possible @... trailer and remove it, if any. */
modifier = strchr (dot, '@');
if (modifier == NULL)
return dot;
if (modifier - dot < sizeof (buf))
{
memcpy (buf, dot, modifier - dot);
buf [modifier - dot] = '\0';
return buf;
}
}
}
/* Woe32 has a function returning the locale's codepage as a number. */
sprintf (buf, "CP%u", GetACP ());
codeset = buf;
}
# endif
# else
/* On old systems which lack it, use setlocale or getenv. */
const char *locale = NULL;
/* But most old systems don't have a complete set of locales. Some
(like SunOS 4 or DJGPP) have only the C locale. Therefore we don't
use setlocale here; it would return "C" when it doesn't support the
locale name the user has set. */
# if 0
locale = setlocale (LC_CTYPE, NULL);
# endif
if (locale == NULL || locale[0] == '\0')
{
locale = getenv ("LC_ALL");
if (locale == NULL || locale[0] == '\0')
{
locale = getenv ("LC_CTYPE");
if (locale == NULL || locale[0] == '\0')
locale = getenv ("LANG");
}
}
/* On some old systems, one used to set locale = "iso8859_1". On others,
you set it to "language_COUNTRY.charset". In any case, we resolve it
through the charset.alias file. */
codeset = locale;
# endif
#elif defined WIN32_NATIVE
static char buf[2 + 10 + 1];
/* Woe32 has a function returning the locale's codepage as a number. */
sprintf (buf, "CP%u", GetACP ());
codeset = buf;
#elif defined OS2
const char *locale;
static char buf[2 + 10 + 1];
ULONG cp[3];
ULONG cplen;
/* Allow user to override the codeset, as set in the operating system,
with standard language environment variables. */
locale = getenv ("LC_ALL");
if (locale == NULL || locale[0] == '\0')
{
locale = getenv ("LC_CTYPE");
if (locale == NULL || locale[0] == '\0')
locale = getenv ("LANG");
}
if (locale != NULL && locale[0] != '\0')
{
/* If the locale name contains an encoding after the dot, return it. */
const char *dot = strchr (locale, '.');
if (dot != NULL)
{
const char *modifier;
dot++;
/* Look for the possible @... trailer and remove it, if any. */
modifier = strchr (dot, '@');
if (modifier == NULL)
return dot;
if (modifier - dot < sizeof (buf))
{
memcpy (buf, dot, modifier - dot);
buf [modifier - dot] = '\0';
return buf;
}
}
/* Resolve through the charset.alias file. */
codeset = locale;
}
else
{
/* OS/2 has a function returning the locale's codepage as a number. */
if (DosQueryCp (sizeof (cp), cp, &cplen))
codeset = "";
else
{
sprintf (buf, "CP%u", cp[0]);
codeset = buf;
}
}
#endif
if (codeset == NULL)
/* The canonical name cannot be determined. */
codeset = "";
/* Resolve alias. */
for (aliases = get_charset_aliases ();
*aliases != '\0';
aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
if (strcmp (codeset, aliases) == 0
|| (aliases[0] == '*' && aliases[1] == '\0'))
{
codeset = aliases + strlen (aliases) + 1;
break;
}
/* Don't return an empty string. GNU libc and GNU libiconv interpret
the empty string as denoting "the locale's character encoding",
thus GNU libiconv would call this function a second time. */
if (codeset[0] == '\0')
codeset = "ASCII";
return codeset;
}

41
lib/localcharset.h Normal file
View file

@ -0,0 +1,41 @@
/* Determine a canonical name for the current locale's character encoding.
Copyright (C) 2000-2003 Free Software Foundation, Inc.
This file is part of the GNU CHARSET Library.
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 2, 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 program; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
#ifndef _LOCALCHARSET_H
#define _LOCALCHARSET_H
#ifdef __cplusplus
extern "C" {
#endif
/* Determine the current locale's character encoding, and canonicalize it
into one of the canonical names listed in config.charset.
The result must not be freed; it is statically allocated.
If the canonical name cannot be determined, the result is a non-canonical
name. */
extern const char * locale_charset (void);
#ifdef __cplusplus
}
#endif
#endif /* _LOCALCHARSET_H */

32
lib/mbrlen.c Normal file
View file

@ -0,0 +1,32 @@
/* Recognize multibyte character.
Copyright (C) 1999-2000, 2008 Free Software Foundation, Inc.
Written by Bruno Haible <bruno@clisp.org>, 2008.
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 of the License, 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 program. If not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
/* Specification. */
#include <wchar.h>
static mbstate_t internal_state;
size_t
mbrlen (const char *s, size_t n, mbstate_t *ps)
{
if (ps == NULL)
ps = &internal_state;
return mbrtowc (NULL, s, n, ps);
}

349
lib/mbrtowc.c Normal file
View file

@ -0,0 +1,349 @@
/* Convert multibyte character to wide character.
Copyright (C) 1999-2002, 2005-2008 Free Software Foundation, Inc.
Written by Bruno Haible <bruno@clisp.org>, 2008.
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 of the License, 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 program. If not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
/* Specification. */
#include <wchar.h>
#if GNULIB_defined_mbstate_t
/* Implement mbrtowc() on top of mbtowc(). */
# include <errno.h>
# include <stdlib.h>
# include "localcharset.h"
# include "streq.h"
# include "verify.h"
verify (sizeof (mbstate_t) >= 4);
static char internal_state[4];
size_t
mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps)
{
char *pstate = (char *)ps;
if (pstate == NULL)
pstate = internal_state;
if (s == NULL)
{
pwc = NULL;
s = "";
n = 1;
}
if (n == 0)
return (size_t)(-2);
/* Here n > 0. */
{
size_t nstate = pstate[0];
char buf[4];
const char *p;
size_t m;
switch (nstate)
{
case 0:
p = s;
m = n;
break;
case 3:
buf[2] = pstate[3];
/*FALLTHROUGH*/
case 2:
buf[1] = pstate[2];
/*FALLTHROUGH*/
case 1:
buf[0] = pstate[1];
p = buf;
m = nstate;
buf[m++] = s[0];
if (n >= 2 && m < 4)
{
buf[m++] = s[1];
if (n >= 3 && m < 4)
buf[m++] = s[2];
}
break;
default:
errno = EINVAL;
return (size_t)(-1);
}
/* Here 0 < m ≤ 4. */
# if __GLIBC__
/* Work around bug <http://sourceware.org/bugzilla/show_bug.cgi?id=9674> */
mbtowc (NULL, NULL, 0);
# endif
{
int res = mbtowc (pwc, p, m);
if (res >= 0)
{
if (pwc != NULL && ((*pwc == 0) != (res == 0)))
abort ();
if (nstate >= (res > 0 ? res : 1))
abort ();
res -= nstate;
pstate[0] = 0;
return res;
}
/* mbtowc does not distinguish between invalid and incomplete multibyte
sequences. But mbrtowc needs to make this distinction.
There are two possible approaches:
- Use iconv() and its return value.
- Use built-in knowledge about the possible encodings.
Given the low quality of implementation of iconv() on the systems that
lack mbrtowc(), we use the second approach.
The possible encodings are:
- 8-bit encodings,
- EUC-JP, EUC-KR, GB2312, EUC-TW, BIG5, SJIS,
- UTF-8.
Use specialized code for each. */
if (m >= 4 || m >= MB_CUR_MAX)
goto invalid;
/* Here MB_CUR_MAX > 1 and 0 < m < 4. */
{
const char *encoding = locale_charset ();
if (STREQ (encoding, "UTF-8", 'U', 'T', 'F', '-', '8', 0, 0, 0, 0))
{
/* Cf. unistr/u8-mblen.c. */
unsigned char c = (unsigned char) p[0];
if (c >= 0xc2)
{
if (c < 0xe0)
{
if (m == 1)
goto incomplete;
}
else if (c < 0xf0)
{
if (m == 1)
goto incomplete;
if (m == 2)
{
unsigned char c2 = (unsigned char) p[1];
if ((c2 ^ 0x80) < 0x40
&& (c >= 0xe1 || c2 >= 0xa0)
&& (c != 0xed || c2 < 0xa0))
goto incomplete;
}
}
else if (c <= 0xf4)
{
if (m == 1)
goto incomplete;
else /* m == 2 || m == 3 */
{
unsigned char c2 = (unsigned char) p[1];
if ((c2 ^ 0x80) < 0x40
&& (c >= 0xf1 || c2 >= 0x90)
&& (c < 0xf4 || (c == 0xf4 && c2 < 0x90)))
{
if (m == 2)
goto incomplete;
else /* m == 3 */
{
unsigned char c3 = (unsigned char) p[2];
if ((c3 ^ 0x80) < 0x40)
goto incomplete;
}
}
}
}
}
goto invalid;
}
/* As a reference for this code, you can use the GNU libiconv
implementation. Look for uses of the RET_TOOFEW macro. */
if (STREQ (encoding, "EUC-JP", 'E', 'U', 'C', '-', 'J', 'P', 0, 0, 0))
{
if (m == 1)
{
unsigned char c = (unsigned char) p[0];
if ((c >= 0xa1 && c < 0xff) || c == 0x8e || c == 0x8f)
goto incomplete;
}
if (m == 2)
{
unsigned char c = (unsigned char) p[0];
if (c == 0x8f)
{
unsigned char c2 = (unsigned char) p[1];
if (c2 >= 0xa1 && c2 < 0xff)
goto incomplete;
}
}
goto invalid;
}
if (STREQ (encoding, "EUC-KR", 'E', 'U', 'C', '-', 'K', 'R', 0, 0, 0)
|| STREQ (encoding, "GB2312", 'G', 'B', '2', '3', '1', '2', 0, 0, 0)
|| STREQ (encoding, "BIG5", 'B', 'I', 'G', '5', 0, 0, 0, 0, 0))
{
if (m == 1)
{
unsigned char c = (unsigned char) p[0];
if (c >= 0xa1 && c < 0xff)
goto incomplete;
}
goto invalid;
}
if (STREQ (encoding, "EUC-TW", 'E', 'U', 'C', '-', 'T', 'W', 0, 0, 0))
{
if (m == 1)
{
unsigned char c = (unsigned char) p[0];
if ((c >= 0xa1 && c < 0xff) || c == 0x8e)
goto incomplete;
}
else /* m == 2 || m == 3 */
{
unsigned char c = (unsigned char) p[0];
if (c == 0x8e)
goto incomplete;
}
goto invalid;
}
if (STREQ (encoding, "SJIS", 'S', 'J', 'I', 'S', 0, 0, 0, 0, 0))
{
if (m == 1)
{
unsigned char c = (unsigned char) p[0];
if ((c >= 0x81 && c <= 0x9f) || (c >= 0xe0 && c <= 0xea)
|| (c >= 0xf0 && c <= 0xf9))
goto incomplete;
}
goto invalid;
}
/* An unknown multibyte encoding. */
goto incomplete;
}
incomplete:
{
size_t k = nstate;
/* Here 0 < k < m < 4. */
pstate[++k] = s[0];
if (k < m)
pstate[++k] = s[1];
if (k != m)
abort ();
}
pstate[0] = m;
return (size_t)(-2);
invalid:
errno = EILSEQ;
/* The conversion state is undefined, says POSIX. */
return (size_t)(-1);
}
}
}
#else
/* Override the system's mbrtowc() function. */
# undef mbrtowc
size_t
rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps)
{
# if MBRTOWC_NULL_ARG_BUG || MBRTOWC_RETVAL_BUG
if (s == NULL)
{
pwc = NULL;
s = "";
n = 1;
}
# endif
# if MBRTOWC_RETVAL_BUG
{
static mbstate_t internal_state;
/* Override mbrtowc's internal state. We can not call mbsinit() on the
hidden internal state, but we can call it on our variable. */
if (ps == NULL)
ps = &internal_state;
if (!mbsinit (ps))
{
/* Parse the rest of the multibyte character byte for byte. */
size_t count = 0;
for (; n > 0; s++, n--)
{
wchar_t wc;
size_t ret = mbrtowc (&wc, s, 1, ps);
if (ret == (size_t)(-1))
return (size_t)(-1);
count++;
if (ret != (size_t)(-2))
{
/* The multibyte character has been completed. */
if (pwc != NULL)
*pwc = wc;
return (wc == 0 ? 0 : count);
}
}
return (size_t)(-2);
}
}
# endif
# if MBRTOWC_NUL_RETVAL_BUG
{
wchar_t wc;
size_t ret = mbrtowc (&wc, s, n, ps);
if (ret != (size_t)(-1) && ret != (size_t)(-2))
{
if (pwc != NULL)
*pwc = wc;
if (wc == 0)
ret = 0;
}
return ret;
}
# else
return mbrtowc (pwc, s, n, ps);
# endif
}
#endif

47
lib/mbsinit.c Normal file
View file

@ -0,0 +1,47 @@
/* Test for initial conversion state.
Copyright (C) 2008 Free Software Foundation, Inc.
Written by Bruno Haible <bruno@clisp.org>, 2008.
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 of the License, 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 program. If not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
/* Specification. */
#include <wchar.h>
#include "verify.h"
/* Platforms that lack mbsinit() also lack mbrlen(), mbrtowc(), mbsrtowcs()
and wcrtomb(), wcsrtombs().
We assume that
- sizeof (mbstate_t) >= 4,
- only stateless encodings are supported (such as UTF-8 and EUC-JP, but
not ISO-2022 variants),
- for each encoding, the number of bytes for a wide character is <= 4.
(This maximum is attained for UTF-8, GB18030, EUC-TW.)
We define the meaning of mbstate_t as follows:
- In mb -> wc direction, mbstate_t's first byte contains the number of
buffered bytes (in the range 0..3), followed by up to 3 buffered bytes.
- In wc -> mb direction, mbstate_t contains no information. In other
words, it is always in the initial state. */
verify (sizeof (mbstate_t) >= 4);
int
mbsinit (const mbstate_t *ps)
{
const char *pstate = (const char *)ps;
return pstate[0] == 0;
}

30
lib/ref-add.sin Normal file
View file

@ -0,0 +1,30 @@
# Add this package to a list of references stored in a text file.
#
# Copyright (C) 2000 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 2, 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 program; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
#
# Written by Bruno Haible <haible@clisp.cons.org>.
#
/^# Packages using this file: / {
s/# Packages using this file://
ta
:a
s/ @PACKAGE@ / @PACKAGE@ /
tb
s/ $/ @PACKAGE@ /
:b
s/^/# Packages using this file:/
}

25
lib/ref-del.sin Normal file
View file

@ -0,0 +1,25 @@
# Remove this package from a list of references stored in a text file.
#
# Copyright (C) 2000 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 2, 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 program; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
#
# Written by Bruno Haible <haible@clisp.cons.org>.
#
/^# Packages using this file: / {
s/# Packages using this file://
s/ @PACKAGE@ / /
s/^/# Packages using this file:/
}

176
lib/streq.h Normal file
View file

@ -0,0 +1,176 @@
/* Optimized string comparison.
Copyright (C) 2001-2002, 2007 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 of the License, 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 program. If not, see <http://www.gnu.org/licenses/>. */
/* Written by Bruno Haible <bruno@clisp.org>. */
#ifndef _GL_STREQ_H
#define _GL_STREQ_H
#include <string.h>
/* STREQ allows to optimize string comparison with a small literal string.
STREQ (s, "EUC-KR", 'E', 'U', 'C', '-', 'K', 'R', 0, 0, 0)
is semantically equivalent to
strcmp (s, "EUC-KR") == 0
just faster. */
/* Help GCC to generate good code for string comparisons with
immediate strings. */
#if defined (__GNUC__) && defined (__OPTIMIZE__)
static inline int
streq9 (const char *s1, const char *s2)
{
return strcmp (s1 + 9, s2 + 9) == 0;
}
static inline int
streq8 (const char *s1, const char *s2, char s28)
{
if (s1[8] == s28)
{
if (s28 == 0)
return 1;
else
return streq9 (s1, s2);
}
else
return 0;
}
static inline int
streq7 (const char *s1, const char *s2, char s27, char s28)
{
if (s1[7] == s27)
{
if (s27 == 0)
return 1;
else
return streq8 (s1, s2, s28);
}
else
return 0;
}
static inline int
streq6 (const char *s1, const char *s2, char s26, char s27, char s28)
{
if (s1[6] == s26)
{
if (s26 == 0)
return 1;
else
return streq7 (s1, s2, s27, s28);
}
else
return 0;
}
static inline int
streq5 (const char *s1, const char *s2, char s25, char s26, char s27, char s28)
{
if (s1[5] == s25)
{
if (s25 == 0)
return 1;
else
return streq6 (s1, s2, s26, s27, s28);
}
else
return 0;
}
static inline int
streq4 (const char *s1, const char *s2, char s24, char s25, char s26, char s27, char s28)
{
if (s1[4] == s24)
{
if (s24 == 0)
return 1;
else
return streq5 (s1, s2, s25, s26, s27, s28);
}
else
return 0;
}
static inline int
streq3 (const char *s1, const char *s2, char s23, char s24, char s25, char s26, char s27, char s28)
{
if (s1[3] == s23)
{
if (s23 == 0)
return 1;
else
return streq4 (s1, s2, s24, s25, s26, s27, s28);
}
else
return 0;
}
static inline int
streq2 (const char *s1, const char *s2, char s22, char s23, char s24, char s25, char s26, char s27, char s28)
{
if (s1[2] == s22)
{
if (s22 == 0)
return 1;
else
return streq3 (s1, s2, s23, s24, s25, s26, s27, s28);
}
else
return 0;
}
static inline int
streq1 (const char *s1, const char *s2, char s21, char s22, char s23, char s24, char s25, char s26, char s27, char s28)
{
if (s1[1] == s21)
{
if (s21 == 0)
return 1;
else
return streq2 (s1, s2, s22, s23, s24, s25, s26, s27, s28);
}
else
return 0;
}
static inline int
streq0 (const char *s1, const char *s2, char s20, char s21, char s22, char s23, char s24, char s25, char s26, char s27, char s28)
{
if (s1[0] == s20)
{
if (s20 == 0)
return 1;
else
return streq1 (s1, s2, s21, s22, s23, s24, s25, s26, s27, s28);
}
else
return 0;
}
#define STREQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
streq0 (s1, s2, s20, s21, s22, s23, s24, s25, s26, s27, s28)
#else
#define STREQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
(strcmp (s1, s2) == 0)
#endif
#endif /* _GL_STREQ_H */

9
lib/strftime.c
View file

@ -50,14 +50,7 @@ extern char *tzname[];
#define DO_MULTIBYTE (HAVE_MBLEN && ! MULTIBYTE_IS_FORMAT_SAFE)
#if DO_MULTIBYTE
# if HAVE_MBRLEN
# include <wchar.h>
# else
/* Simulate mbrlen with mblen as best we can. */
# define mbstate_t int
# define mbrlen(s, n, ps) mblen (s, n)
# define mbsinit(ps) (*(ps) == 0)
# endif
# include <wchar.h>
static const mbstate_t mbstate_zero;
#endif

1
lib/unistd.in.h
View file

@ -35,6 +35,7 @@
#endif
/* mingw fails to declare _exit in <unistd.h>. */
/* mingw, BeOS, Haiku declare environ in <stdlib.h>, not in <unistd.h>. */
#include <stdlib.h>
#if @GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@

191
lib/wchar.in.h
View file

@ -68,6 +68,197 @@ extern "C" {
/* Define wint_t. (Also done in wctype.in.h.) */
#if !@HAVE_WINT_T@ && !defined wint_t
# define wint_t int
# ifndef WEOF
# define WEOF -1
# endif
#endif
/* Override mbstate_t if it is too small.
On IRIX 6.5, sizeof (mbstate_t) == 1, which is not sufficient for
implementing mbrtowc for encodings like UTF-8. */
#if !(@HAVE_MBSINIT@ && @HAVE_MBRTOWC@) || @REPLACE_MBSTATE_T@
typedef int rpl_mbstate_t;
# undef mbstate_t
# define mbstate_t rpl_mbstate_t
# define GNULIB_defined_mbstate_t 1
#endif
/* Convert a single-byte character to a wide character. */
#if @GNULIB_BTOWC@
# if @REPLACE_BTOWC@
# undef btowc
# define btowc rpl_btowc
# endif
# if !@HAVE_BTOWC@ || @REPLACE_BTOWC@
extern wint_t btowc (int c);
# endif
#elif defined GNULIB_POSIXCHECK
# undef btowc
# define btowc(c) \
(GL_LINK_WARNING ("btowc is unportable - " \
"use gnulib module btowc for portability"), \
btowc (c))
#endif
/* Convert a wide character to a single-byte character. */
#if @GNULIB_WCTOB@
# if @REPLACE_WCTOB@
# undef wctob
# define wctob rpl_wctob
# endif
# if (!defined wctob && !@HAVE_DECL_WCTOB@) || @REPLACE_WCTOB@
/* wctob is provided by gnulib, or wctob exists but is not declared. */
extern int wctob (wint_t wc);
# endif
#elif defined GNULIB_POSIXCHECK
# undef wctob
# define wctob(w) \
(GL_LINK_WARNING ("wctob is unportable - " \
"use gnulib module wctob for portability"), \
wctob (w))
#endif
/* Test whether *PS is in the initial state. */
#if @GNULIB_MBSINIT@
# if @REPLACE_MBSINIT@
# undef mbsinit
# define mbsinit rpl_mbsinit
# endif
# if !@HAVE_MBSINIT@ || @REPLACE_MBSINIT@
extern int mbsinit (const mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef mbsinit
# define mbsinit(p) \
(GL_LINK_WARNING ("mbsinit is unportable - " \
"use gnulib module mbsinit for portability"), \
mbsinit (p))
#endif
/* Convert a multibyte character to a wide character. */
#if @GNULIB_MBRTOWC@
# if @REPLACE_MBRTOWC@
# undef mbrtowc
# define mbrtowc rpl_mbrtowc
# endif
# if !@HAVE_MBRTOWC@ || @REPLACE_MBRTOWC@
extern size_t mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef mbrtowc
# define mbrtowc(w,s,n,p) \
(GL_LINK_WARNING ("mbrtowc is unportable - " \
"use gnulib module mbrtowc for portability"), \
mbrtowc (w, s, n, p))
#endif
/* Recognize a multibyte character. */
#if @GNULIB_MBRLEN@
# if @REPLACE_MBRLEN@
# undef mbrlen
# define mbrlen rpl_mbrlen
# endif
# if !@HAVE_MBRLEN@ || @REPLACE_MBRLEN@
extern size_t mbrlen (const char *s, size_t n, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef mbrlen
# define mbrlen(s,n,p) \
(GL_LINK_WARNING ("mbrlen is unportable - " \
"use gnulib module mbrlen for portability"), \
mbrlen (s, n, p))
#endif
/* Convert a string to a wide string. */
#if @GNULIB_MBSRTOWCS@
# if @REPLACE_MBSRTOWCS@
# undef mbsrtowcs
# define mbsrtowcs rpl_mbsrtowcs
# endif
# if !@HAVE_MBSRTOWCS@ || @REPLACE_MBSRTOWCS@
extern size_t mbsrtowcs (wchar_t *dest, const char **srcp, size_t len, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef mbsrtowcs
# define mbsrtowcs(d,s,l,p) \
(GL_LINK_WARNING ("mbsrtowcs is unportable - " \
"use gnulib module mbsrtowcs for portability"), \
mbsrtowcs (d, s, l, p))
#endif
/* Convert a string to a wide string. */
#if @GNULIB_MBSNRTOWCS@
# if @REPLACE_MBSNRTOWCS@
# undef mbsnrtowcs
# define mbsnrtowcs rpl_mbsnrtowcs
# endif
# if !@HAVE_MBSNRTOWCS@ || @REPLACE_MBSNRTOWCS@
extern size_t mbsnrtowcs (wchar_t *dest, const char **srcp, size_t srclen, size_t len, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef mbsnrtowcs
# define mbsnrtowcs(d,s,n,l,p) \
(GL_LINK_WARNING ("mbsnrtowcs is unportable - " \
"use gnulib module mbsnrtowcs for portability"), \
mbsnrtowcs (d, s, n, l, p))
#endif
/* Convert a wide character to a multibyte character. */
#if @GNULIB_WCRTOMB@
# if @REPLACE_WCRTOMB@
# undef wcrtomb
# define wcrtomb rpl_wcrtomb
# endif
# if !@HAVE_WCRTOMB@ || @REPLACE_WCRTOMB@
extern size_t wcrtomb (char *s, wchar_t wc, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef wcrtomb
# define wcrtomb(s,w,p) \
(GL_LINK_WARNING ("wcrtomb is unportable - " \
"use gnulib module wcrtomb for portability"), \
wcrtomb (s, w, p))
#endif
/* Convert a wide string to a string. */
#if @GNULIB_WCSRTOMBS@
# if @REPLACE_WCSRTOMBS@
# undef wcsrtombs
# define wcsrtombs rpl_wcsrtombs
# endif
# if !@HAVE_WCSRTOMBS@ || @REPLACE_WCSRTOMBS@
extern size_t wcsrtombs (char *dest, const wchar_t **srcp, size_t len, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef wcsrtombs
# define wcsrtombs(d,s,l,p) \
(GL_LINK_WARNING ("wcsrtombs is unportable - " \
"use gnulib module wcsrtombs for portability"), \
wcsrtombs (d, s, l, p))
#endif
/* Convert a wide string to a string. */
#if @GNULIB_WCSNRTOMBS@
# if !@HAVE_WCSNRTOMBS@
extern size_t wcsnrtombs (char *dest, const wchar_t **srcp, size_t srclen, size_t len, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
# undef wcsnrtombs
# define wcsnrtombs(d,s,n,l,p) \
(GL_LINK_WARNING ("wcsnrtombs is unportable - " \
"use gnulib module wcsnrtombs for portability"), \
wcsnrtombs (d, s, n, l, p))
#endif

19
libguile/_scm.h
View file

@ -38,6 +38,25 @@
# include <config.h>
#endif
/* Undefine HAVE_STRUCT_TIMESPEC, because the libguile C code doesn't
need it anymore, and because on MinGW:
- the definition of struct timespec is provided (if at all) by
pthread.h
- pthread.h will _not_ define struct timespec if
HAVE_STRUCT_TIMESPEC is 1, because then it thinks that it doesn't
need to.
The libguile C code doesn't need HAVE_STRUCT_TIMESPEC anymore,
because the value of HAVE_STRUCT_TIMESPEC has already been
incorporated in how scm_t_timespec is defined (in scmconfig.h), and
the rest of the libguile C code now just uses scm_t_timespec.
*/
#ifdef HAVE_STRUCT_TIMESPEC
#undef HAVE_STRUCT_TIMESPEC
#endif
#include <errno.h>
#include "libguile/__scm.h"

499
libguile/alloca.c
View file

@ -1,499 +0,0 @@
/* alloca.c -- allocate automatically reclaimed memory
(Mostly) portable public-domain implementation -- D A Gwyn
This implementation of the PWB library alloca function,
which is used to allocate space off the run-time stack so
that it is automatically reclaimed upon procedure exit,
was inspired by discussions with J. Q. Johnson of Cornell.
J.Otto Tennant <jot@cray.com> contributed the Cray support.
There are some preprocessor constants that can
be defined when compiling for your specific system, for
improved efficiency; however, the defaults should be okay.
The general concept of this implementation is to keep
track of all alloca-allocated blocks, and reclaim any
that are found to be deeper in the stack than the current
invocation. This heuristic does not reclaim storage as
soon as it becomes invalid, but it will do so eventually.
As a special case, alloca(0) reclaims storage without
allocating any. It is a good idea to use alloca(0) in
your main control loop, etc. to force garbage collection. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/scmconfig.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif
#ifdef emacs
#include "libguile/blockinput.h"
#endif
/* If compiling with GCC 2, this file's not needed. */
#if !defined (__GNUC__) || __GNUC__ < 2
/* If someone has defined alloca as a macro,
there must be some other way alloca is supposed to work. */
#ifndef alloca
#ifdef emacs
#ifdef static
/* actually, only want this if static is defined as ""
-- this is for usg, in which emacs must undefine static
in order to make unexec workable
*/
#ifndef STACK_DIRECTION
you
lose
-- must know STACK_DIRECTION at compile-time
#endif /* STACK_DIRECTION undefined */
#endif /* static */
#endif /* emacs */
/* If your stack is a linked list of frames, you have to
provide an "address metric" ADDRESS_FUNCTION macro. */
#if defined (CRAY) && defined (CRAY_STACKSEG_END)
long i00afunc ();
#define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
#else
#define ADDRESS_FUNCTION(arg) &(arg)
#endif
#if __STDC__
typedef void *pointer;
#else
typedef char *pointer;
#endif
#ifndef NULL
#define NULL 0
#endif
/* Define STACK_DIRECTION if you know the direction of stack
growth for your system; otherwise it will be automatically
deduced at run-time.
STACK_DIRECTION > 0 => grows toward higher addresses
STACK_DIRECTION < 0 => grows toward lower addresses
STACK_DIRECTION = 0 => direction of growth unknown */
#ifndef STACK_DIRECTION
#define STACK_DIRECTION 0 /* Direction unknown. */
#endif
#if STACK_DIRECTION != 0
#define STACK_DIR STACK_DIRECTION /* Known at compile-time. */
#else /* STACK_DIRECTION == 0; need run-time code. */
static int stack_dir; /* 1 or -1 once known. */
#define STACK_DIR stack_dir
static void
find_stack_direction ()
{
static char *addr = NULL; /* Address of first `dummy', once known. */
auto char dummy; /* To get stack address. */
if (addr == NULL)
{ /* Initial entry. */
addr = ADDRESS_FUNCTION (dummy);
find_stack_direction (); /* Recurse once. */
}
else
{
/* Second entry. */
if (ADDRESS_FUNCTION (dummy) > addr)
stack_dir = 1; /* Stack grew upward. */
else
stack_dir = -1; /* Stack grew downward. */
}
}
#endif /* STACK_DIRECTION == 0 */
/* An "alloca header" is used to:
(a) chain together all alloca'ed blocks;
(b) keep track of stack depth.
It is very important that sizeof(header) agree with malloc
alignment chunk size. The following default should work okay. */
#ifndef ALIGN_SIZE
#define ALIGN_SIZE sizeof(double)
#endif
typedef union hdr
{
char align[ALIGN_SIZE]; /* To force sizeof(header). */
struct
{
union hdr *next; /* For chaining headers. */
char *deep; /* For stack depth measure. */
} h;
} header;
static header *last_alloca_header = NULL; /* -> last alloca header. */
/* Return a pointer to at least SIZE bytes of storage,
which will be automatically reclaimed upon exit from
the procedure that called alloca. Originally, this space
was supposed to be taken from the current stack frame of the
caller, but that method cannot be made to work for some
implementations of C, for example under Gould's UTX/32. */
pointer
alloca (unsigned size)
{
auto char probe; /* Probes stack depth: */
register char *depth = ADDRESS_FUNCTION (probe);
#if STACK_DIRECTION == 0
if (STACK_DIR == 0) /* Unknown growth direction. */
find_stack_direction ();
#endif
/* Reclaim garbage, defined as all alloca'd storage that
was allocated from deeper in the stack than currently. */
{
register header *hp; /* Traverses linked list. */
#ifdef emacs
BLOCK_INPUT;
#endif
for (hp = last_alloca_header; hp != NULL;)
if ((STACK_DIR > 0 && hp->h.deep > depth)
|| (STACK_DIR < 0 && hp->h.deep < depth))
{
register header *np = hp->h.next;
free ((pointer) hp); /* Collect garbage. */
hp = np; /* -> next header. */
}
else
break; /* Rest are not deeper. */
last_alloca_header = hp; /* -> last valid storage. */
#ifdef emacs
UNBLOCK_INPUT;
#endif
}
if (size == 0)
return NULL; /* No allocation required. */
/* Allocate combined header + user data storage. */
{
register pointer new = (pointer) scm_malloc (sizeof (header) + size);
/* Address of header. */
if (new == 0)
{
write (2, "alloca emulation: out of memory\n", 32);
abort();
}
((header *) new)->h.next = last_alloca_header;
((header *) new)->h.deep = depth;
last_alloca_header = (header *) new;
/* User storage begins just after header. */
return (pointer) ((char *) new + sizeof (header));
}
}
#if defined (CRAY) && defined (CRAY_STACKSEG_END)
#ifdef DEBUG_I00AFUNC
#include <stdio.h>
#endif
#ifndef CRAY_STACK
#define CRAY_STACK
#ifndef CRAY2
/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
struct stack_control_header
{
long shgrow:32; /* Number of times stack has grown. */
long shaseg:32; /* Size of increments to stack. */
long shhwm:32; /* High water mark of stack. */
long shsize:32; /* Current size of stack (all segments). */
};
/* The stack segment linkage control information occurs at
the high-address end of a stack segment. (The stack
grows from low addresses to high addresses.) The initial
part of the stack segment linkage control information is
0200 (octal) words. This provides for register storage
for the routine which overflows the stack. */
struct stack_segment_linkage
{
long ss[0200]; /* 0200 overflow words. */
long sssize:32; /* Number of words in this segment. */
long ssbase:32; /* Offset to stack base. */
long:32;
long sspseg:32; /* Offset to linkage control of previous
segment of stack. */
long:32;
long sstcpt:32; /* Pointer to task common address block. */
long sscsnm; /* Private control structure number for
microtasking. */
long ssusr1; /* Reserved for user. */
long ssusr2; /* Reserved for user. */
long sstpid; /* Process ID for pid based multi-tasking. */
long ssgvup; /* Pointer to multitasking thread giveup. */
long sscray[7]; /* Reserved for Cray Research. */
long ssa0;
long ssa1;
long ssa2;
long ssa3;
long ssa4;
long ssa5;
long ssa6;
long ssa7;
long sss0;
long sss1;
long sss2;
long sss3;
long sss4;
long sss5;
long sss6;
long sss7;
};
#else /* CRAY2 */
/* The following structure defines the vector of words
returned by the STKSTAT library routine. */
struct stk_stat
{
long now; /* Current total stack size. */
long maxc; /* Amount of contiguous space which would
be required to satisfy the maximum
stack demand to date. */
long high_water; /* Stack high-water mark. */
long overflows; /* Number of stack overflow ($STKOFEN) calls. */
long hits; /* Number of internal buffer hits. */
long extends; /* Number of block extensions. */
long stko_mallocs; /* Block allocations by $STKOFEN. */
long underflows; /* Number of stack underflow calls ($STKRETN). */
long stko_free; /* Number of deallocations by $STKRETN. */
long stkm_free; /* Number of deallocations by $STKMRET. */
long segments; /* Current number of stack segments. */
long maxs; /* Maximum number of stack segments so far. */
long pad_size; /* Stack pad size. */
long current_address; /* Current stack segment address. */
long current_size; /* Current stack segment size. This
number is actually corrupted by STKSTAT to
include the fifteen word trailer area. */
long initial_address; /* Address of initial segment. */
long initial_size; /* Size of initial segment. */
};
/* The following structure describes the data structure which trails
any stack segment. I think that the description in 'asdef' is
out of date. I only describe the parts that I am sure about. */
struct stk_trailer
{
long this_address; /* Address of this block. */
long this_size; /* Size of this block (does not include
this trailer). */
long unknown2;
long unknown3;
long link; /* Address of trailer block of previous
segment. */
long unknown5;
long unknown6;
long unknown7;
long unknown8;
long unknown9;
long unknown10;
long unknown11;
long unknown12;
long unknown13;
long unknown14;
};
#endif /* CRAY2 */
#endif /* not CRAY_STACK */
#ifdef CRAY2
/* Determine a "stack measure" for an arbitrary ADDRESS.
I doubt that "lint" will like this much. */
static long
i00afunc (long *address)
{
struct stk_stat status;
struct stk_trailer *trailer;
long *block, size;
long result = 0;
/* We want to iterate through all of the segments. The first
step is to get the stack status structure. We could do this
more quickly and more directly, perhaps, by referencing the
$LM00 common block, but I know that this works. */
STKSTAT (&status);
/* Set up the iteration. */
trailer = (struct stk_trailer *) (status.current_address
+ status.current_size
- 15);
/* There must be at least one stack segment. Therefore it is
a fatal error if "trailer" is null. */
if (trailer == 0)
abort ();
/* Discard segments that do not contain our argument address. */
while (trailer != 0)
{
block = (long *) trailer->this_address;
size = trailer->this_size;
if (block == 0 || size == 0)
abort ();
trailer = (struct stk_trailer *) trailer->link;
if ((block <= address) && (address < (block + size)))
break;
}
/* Set the result to the offset in this segment and add the sizes
of all predecessor segments. */
result = address - block;
if (trailer == 0)
{
return result;
}
do
{
if (trailer->this_size <= 0)
abort ();
result += trailer->this_size;
trailer = (struct stk_trailer *) trailer->link;
}
while (trailer != 0);
/* We are done. Note that if you present a bogus address (one
not in any segment), you will get a different number back, formed
from subtracting the address of the first block. This is probably
not what you want. */
return (result);
}
#else /* not CRAY2 */
/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
Determine the number of the cell within the stack,
given the address of the cell. The purpose of this
routine is to linearize, in some sense, stack addresses
for alloca. */
static long
i00afunc (long address)
{
long stkl = 0;
long size, pseg, this_segment, stack;
long result = 0;
struct stack_segment_linkage *ssptr;
/* Register B67 contains the address of the end of the
current stack segment. If you (as a subprogram) store
your registers on the stack and find that you are past
the contents of B67, you have overflowed the segment.
B67 also points to the stack segment linkage control
area, which is what we are really interested in. */
stkl = CRAY_STACKSEG_END ();
ssptr = (struct stack_segment_linkage *) stkl;
/* If one subtracts 'size' from the end of the segment,
one has the address of the first word of the segment.
If this is not the first segment, 'pseg' will be
nonzero. */
pseg = ssptr->sspseg;
size = ssptr->sssize;
this_segment = stkl - size;
/* It is possible that calling this routine itself caused
a stack overflow. Discard stack segments which do not
contain the target address. */
while (!(this_segment <= address && address <= stkl))
{
#ifdef DEBUG_I00AFUNC
fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
#endif
if (pseg == 0)
break;
stkl = stkl - pseg;
ssptr = (struct stack_segment_linkage *) stkl;
size = ssptr->sssize;
pseg = ssptr->sspseg;
this_segment = stkl - size;
}
result = address - this_segment;
/* If you subtract pseg from the current end of the stack,
you get the address of the previous stack segment's end.
This seems a little convoluted to me, but I'll bet you save
a cycle somewhere. */
while (pseg != 0)
{
#ifdef DEBUG_I00AFUNC
fprintf (stderr, "%011o %011o\n", pseg, size);
#endif
stkl = stkl - pseg;
ssptr = (struct stack_segment_linkage *) stkl;
size = ssptr->sssize;
pseg = ssptr->sspseg;
result += size;
}
return (result);
}
#endif /* not CRAY2 */
#endif /* CRAY */
#endif /* no alloca */
#endif /* not GCC version 2 */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

1040
libguile/coop-pthreads.c
View file

File diff suppressed because it is too large Load diff

81
libguile/coop-pthreads.h
View file

@ -1,81 +0,0 @@
/* classes: h_files */
#ifndef SCM_COOP_PTHREADS_H
#define SCM_COOP_PTHREADS_H
/* Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 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
*/
/* The coop-pthreads implementation. We use pthreads for the basic
multi threading stuff, but rig it so that only one thread is ever
active inside Guile.
*/
#include <pthread.h>
#include "libguile/iselect.h"
#if (SCM_ENABLE_DEPRECATED == 1)
/* Thread local data support --- generic C API */
typedef pthread_key_t scm_t_key;
#define scm_key_create pthread_key_create
#define scm_setspecific pthread_setspecific
#define scm_getspecific pthread_getspecific
#define scm_key_delete pthread_key_delete
#endif /* SCM_ENABLE_DEPRECATED == 1 */
/* Since only one thread can be active anyway, we don't need to do
anything special around critical sections. In fact, that's the
reason we do only support cooperative threading: Guile's critical
regions have not been completely identified yet. (I think.) */
#define SCM_CRITICAL_SECTION_START
#define SCM_CRITICAL_SECTION_END
#define SCM_I_THREAD_SWITCH_COUNT 50
#define SCM_THREAD_SWITCHING_CODE \
do { \
scm_i_switch_counter--; \
if (scm_i_switch_counter == 0) \
{ \
scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; \
scm_yield(); \
} \
} while (0)
SCM_API int scm_i_switch_counter;
#define SCM_THREAD_LOCAL_DATA (scm_i_copt_thread_data)
#define SCM_SET_THREAD_LOCAL_DATA(ptr) (scm_i_copt_set_thread_data (ptr))
SCM_API void *scm_i_copt_thread_data;
SCM_INTERNAL void scm_i_copt_set_thread_data (void *data);
#endif /* SCM_COOP_PTHREAD_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

761
libguile/coop.c
View file

@ -1,761 +0,0 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 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
*/
/* $Id: coop.c,v 1.39 2006-04-17 00:05:38 kryde Exp $ */
/* Cooperative thread library, based on QuickThreads */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <stdio.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <errno.h>
#include "qt/qt.h"
#include "libguile/eval.h"
/* #define COOP_STKSIZE (0x10000) */
#define COOP_STKSIZE (scm_eval_stack)
/* `alignment' must be a power of 2. */
#define COOP_STKALIGN(sp, alignment) \
((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
/* Queue access functions. */
static void
coop_qinit (coop_q_t *q)
{
q->t.next = q->tail = &q->t;
q->t.all_prev = NULL;
q->t.all_next = NULL;
q->t.nfds = 0;
q->t.readfds = NULL;
q->t.writefds = NULL;
q->t.exceptfds = NULL;
q->t.timeoutp = 0;
}
coop_t *
coop_qget (coop_q_t *q)
{
coop_t *t;
t = q->t.next;
q->t.next = t->next;
if (t->next == &q->t)
{
if (t == &q->t)
{ /* If it was already empty .. */
return NULL; /* .. say so. */
}
q->tail = &q->t; /* Else now it is empty. */
}
return (t);
}
void
coop_qput (coop_q_t *q, coop_t *t)
{
q->tail->next = t;
t->next = &q->t;
q->tail = t;
}
static void
coop_all_qput (coop_q_t *q, coop_t *t)
{
if (q->t.all_next)
q->t.all_next->all_prev = t;
t->all_prev = NULL;
t->all_next = q->t.all_next;
q->t.all_next = t;
}
static void
coop_all_qremove (coop_q_t *q, coop_t *t)
{
if (t->all_prev)
t->all_prev->all_next = t->all_next;
else
q->t.all_next = t->all_next;
if (t->all_next)
t->all_next->all_prev = t->all_prev;
}
/* Insert thread t into the ordered queue q.
q is ordered after wakeup_time. Threads which aren't sleeping but
waiting for I/O go last into the queue. */
void
coop_timeout_qinsert (coop_q_t *q, coop_t *t)
{
coop_t *pred = &q->t;
int sec = t->wakeup_time.tv_sec;
int usec = t->wakeup_time.tv_usec;
while (pred->next != &q->t
&& pred->next->timeoutp
&& (pred->next->wakeup_time.tv_sec < sec
|| (pred->next->wakeup_time.tv_sec == sec
&& pred->next->wakeup_time.tv_usec < usec)))
pred = pred->next;
t->next = pred->next;
pred->next = t;
if (t->next == &q->t)
q->tail = t;
}
/* Thread routines. */
coop_q_t coop_global_runq; /* A queue of runable threads. */
coop_q_t coop_global_sleepq; /* A queue of sleeping threads. */
coop_q_t coop_tmp_queue; /* A temp working queue */
coop_q_t coop_global_allq; /* A queue of all threads. */
static coop_t coop_global_main; /* Thread for the process. */
coop_t *coop_global_curr; /* Currently-executing thread. */
#ifdef GUILE_PTHREAD_COMPAT
static coop_q_t coop_deadq;
static int coop_quitting_p = -1;
static pthread_cond_t coop_cond_quit;
static pthread_cond_t coop_cond_create;
static pthread_mutex_t coop_mutex_create;
static pthread_t coop_mother;
static int mother_awake_p = 0;
static coop_t *coop_child;
#endif
static void *coop_starthelp (qt_t *old, void *ignore0, void *ignore1);
static void coop_only (void *pu, void *pt, qt_userf_t *f);
static void *coop_aborthelp (qt_t *sp, void *old, void *null);
static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq);
/* called on process termination. */
#ifdef HAVE_ATEXIT
static void
coop_finish (void)
#else
#ifdef HAVE_ON_EXIT
extern int on_exit (void (*procp) (), int arg);
static void
coop_finish (int status, void *arg)
#else
#error Dont know how to setup a cleanup handler on your system.
#endif
#endif
{
#ifdef GUILE_PTHREAD_COMPAT
coop_quitting_p = 1;
pthread_cond_signal (&coop_cond_create);
pthread_cond_broadcast (&coop_cond_quit);
#endif
}
void
coop_init ()
{
coop_qinit (&coop_global_runq);
coop_qinit (&coop_global_sleepq);
coop_qinit (&coop_tmp_queue);
coop_qinit (&coop_global_allq);
coop_global_curr = &coop_global_main;
#ifdef GUILE_PTHREAD_COMPAT
coop_qinit (&coop_deadq);
pthread_cond_init (&coop_cond_quit, NULL);
pthread_cond_init (&coop_cond_create, NULL);
pthread_mutex_init (&coop_mutex_create, NULL);
#endif
#ifdef HAVE_ATEXIT
atexit (coop_finish);
#else
#ifdef HAVE_ON_EXIT
on_exit (coop_finish, 0);
#endif
#endif
}
void
coop_start()
{
coop_t *next;
while ((next = coop_qget (&coop_global_runq)) != NULL) {
coop_global_curr = next;
QT_BLOCK (coop_starthelp, 0, 0, next->sp);
}
}
static void *
coop_starthelp (qt_t *old, void *ignore0, void *ignore1)
{
coop_global_main.sp = old;
coop_global_main.joining = NULL;
coop_qput (&coop_global_runq, &coop_global_main);
return NULL; /* not used, but keeps compiler happy */
}
int
coop_mutex_init (coop_m *m)
{
return coop_new_mutex_init (m, NULL);
}
int
coop_new_mutex_init (coop_m *m, coop_mattr *attr)
{
m->owner = NULL;
m->level = 0;
coop_qinit(&(m->waiting));
return 0;
}
int
coop_mutex_trylock (coop_m *m)
{
if (m->owner == NULL)
{
m->owner = coop_global_curr;
return 0;
}
else if (m->owner == coop_global_curr)
{
m->level++;
return 0;
}
else
return EBUSY;
}
int
coop_mutex_lock (coop_m *m)
{
if (m->owner == NULL)
{
m->owner = coop_global_curr;
}
else if (m->owner == coop_global_curr)
{
m->level++;
}
else
{
coop_t *old, *newthread;
/* Record the current top-of-stack before going to sleep */
coop_global_curr->top = &old;
newthread = coop_wait_for_runnable_thread();
if (newthread == coop_global_curr)
coop_abort ();
old = coop_global_curr;
coop_global_curr = newthread;
QT_BLOCK (coop_yieldhelp, old, &(m->waiting), newthread->sp);
}
return 0;
}
int
coop_mutex_unlock (coop_m *m)
{
coop_t *old, *newthread;
if (m->level == 0)
{
newthread = coop_qget (&(m->waiting));
if (newthread != NULL)
{
/* Record the current top-of-stack before going to sleep */
coop_global_curr->top = &old;
old = coop_global_curr;
coop_global_curr = newthread;
/* The new thread came into m->waiting through a lock operation.
It now owns this mutex. */
m->owner = coop_global_curr;
QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
}
else
{
m->owner = NULL;
}
}
else if (m->level > 0)
m->level--;
else
abort (); /* XXX */
return 0;
}
int
coop_mutex_destroy (coop_m *m)
{
return 0;
}
int
coop_condition_variable_init (coop_c *c)
{
return coop_new_condition_variable_init (c, NULL);
}
int
coop_new_condition_variable_init (coop_c *c, coop_cattr *a)
{
coop_qinit(&(c->waiting));
return 0;
}
int
coop_condition_variable_wait_mutex (coop_c *c, coop_m *m)
{
coop_t *old, *newthread;
/* coop_mutex_unlock (m); */
newthread = coop_qget (&(m->waiting));
if (newthread != NULL)
{
m->owner = newthread;
}
else
{
m->owner = NULL;
/*fixme* Should we really wait here? Isn't it OK just to proceed? */
newthread = coop_wait_for_runnable_thread();
if (newthread == coop_global_curr)
coop_abort ();
}
coop_global_curr->top = &old;
old = coop_global_curr;
coop_global_curr = newthread;
QT_BLOCK (coop_yieldhelp, old, &(c->waiting), newthread->sp);
coop_mutex_lock (m);
return 0;
}
int
coop_condition_variable_timed_wait_mutex (coop_c *c,
coop_m *m,
const scm_t_timespec *abstime)
{
coop_t *old, *t;
#ifdef ETIMEDOUT
int res = ETIMEDOUT;
#elif defined (WSAETIMEDOUT)
int res = WSAETIMEDOUT;
#else
int res = 0;
#endif
/* coop_mutex_unlock (m); */
t = coop_qget (&(m->waiting));
if (t != NULL)
{
m->owner = t;
}
else
{
m->owner = NULL;
coop_global_curr->timeoutp = 1;
coop_global_curr->wakeup_time.tv_sec = abstime->tv_sec;
coop_global_curr->wakeup_time.tv_usec = abstime->tv_nsec / 1000;
coop_timeout_qinsert (&coop_global_sleepq, coop_global_curr);
t = coop_wait_for_runnable_thread();
}
if (t != coop_global_curr)
{
coop_global_curr->top = &old;
old = coop_global_curr;
coop_global_curr = t;
QT_BLOCK (coop_yieldhelp, old, &(c->waiting), t->sp);
/* Are we still in the sleep queue? */
old = &coop_global_sleepq.t;
for (t = old->next; t != &coop_global_sleepq.t; old = t, t = t->next)
if (t == coop_global_curr)
{
old->next = t->next; /* unlink */
res = 0;
break;
}
}
coop_mutex_lock (m);
return res;
}
int
coop_condition_variable_broadcast (coop_c *c)
{
coop_t *newthread;
while ((newthread = coop_qget (&(c->waiting))) != NULL)
{
coop_qput (&coop_global_runq, newthread);
}
return 0;
}
int
coop_condition_variable_signal (coop_c *c)
{
return coop_condition_variable_broadcast (c);
}
/* {Keys}
*/
static int n_keys = 0;
static int max_keys = 0;
static void (**destructors) (void *) = 0;
int
coop_key_create (coop_k *keyp, void (*destructor) (void *value))
{
if (n_keys >= max_keys)
{
int i;
max_keys = max_keys ? max_keys * 3 / 2 : 10;
destructors = realloc (destructors, sizeof (void *) * max_keys);
if (destructors == 0)
{
fprintf (stderr, "Virtual memory exceeded in coop_key_create\n");
exit (1);
}
for (i = n_keys; i < max_keys; ++i)
destructors[i] = NULL;
}
destructors[n_keys] = destructor;
*keyp = n_keys++;
return 0;
}
int
coop_setspecific (coop_k key, const void *value)
{
int n_keys = coop_global_curr->n_keys;
if (key >= n_keys)
{
int i;
coop_global_curr->n_keys = max_keys;
coop_global_curr->specific = realloc (n_keys
? coop_global_curr->specific
: NULL,
sizeof (void *) * max_keys);
if (coop_global_curr->specific == 0)
{
fprintf (stderr, "Virtual memory exceeded in coop_setspecific\n");
exit (1);
}
for (i = n_keys; i < max_keys; ++i)
coop_global_curr->specific[i] = NULL;
}
coop_global_curr->specific[key] = (void *) value;
return 0;
}
void *
coop_getspecific (coop_k key)
{
return (key < coop_global_curr->n_keys
? coop_global_curr->specific[key]
: NULL);
}
int
coop_key_delete (coop_k key)
{
return 0;
}
int
coop_condition_variable_destroy (coop_c *c)
{
return 0;
}
#ifdef GUILE_PTHREAD_COMPAT
/* 1K room for the cond wait routine */
#if SCM_STACK_GROWS_UP
# define COOP_STACK_ROOM (256)
#else
# define COOP_STACK_ROOM (-256)
#endif
static void *
dummy_start (void *coop_thread)
{
coop_t *t = (coop_t *) coop_thread;
int res;
t->sp = (qt_t *) (&t + COOP_STACK_ROOM);
pthread_mutex_init (&t->dummy_mutex, NULL);
pthread_mutex_lock (&t->dummy_mutex);
coop_child = 0;
do
res = pthread_cond_wait (&coop_cond_quit, &t->dummy_mutex);
while (res == EINTR);
return 0;
}
static void *
mother (void *dummy)
{
pthread_mutex_lock (&coop_mutex_create);
while (!coop_quitting_p)
{
int res;
pthread_create (&coop_child->dummy_thread,
NULL,
dummy_start,
coop_child);
mother_awake_p = 0;
do
res = pthread_cond_wait (&coop_cond_create, &coop_mutex_create);
while (res == EINTR);
}
return 0;
}
#endif
coop_t *
coop_create (coop_userf_t *f, void *pu)
{
coop_t *t;
#ifndef GUILE_PTHREAD_COMPAT
void *sto;
#endif
#ifdef GUILE_PTHREAD_COMPAT
t = coop_qget (&coop_deadq);
if (t)
{
t->sp = t->base;
t->specific = 0;
t->n_keys = 0;
}
else
#endif
{
t = scm_malloc (sizeof (coop_t));
t->specific = NULL;
t->n_keys = 0;
#ifdef GUILE_PTHREAD_COMPAT
coop_child = t;
mother_awake_p = 1;
if (coop_quitting_p < 0)
{
coop_quitting_p = 0;
/* We can't create threads ourselves since the pthread
* corresponding to this stack might be sleeping.
*/
pthread_create (&coop_mother, NULL, mother, NULL);
}
else
{
pthread_cond_signal (&coop_cond_create);
}
/* We can't use a pthreads condition variable since "this"
* pthread could already be asleep. We can't use a COOP
* condition variable because they are not safe against
* pre-emptive switching.
*/
while (coop_child || mother_awake_p)
usleep (0);
#else
t->sto = scm_malloc (COOP_STKSIZE);
sto = COOP_STKALIGN (t->sto, QT_STKALIGN);
t->sp = QT_SP (sto, COOP_STKSIZE - QT_STKALIGN);
#endif
t->base = t->sp;
}
t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, coop_only);
t->joining = NULL;
coop_qput (&coop_global_runq, t);
coop_all_qput (&coop_global_allq, t);
return t;
}
static void
coop_only (void *pu, void *pt, qt_userf_t *f)
{
coop_global_curr = (coop_t *)pt;
(*(coop_userf_t *)f)(pu);
coop_abort();
/* NOTREACHED */
}
void
coop_abort ()
{
coop_t *old, *newthread;
/* Wake up any threads that are waiting to join this one */
if (coop_global_curr->joining)
{
while ((newthread = coop_qget ((coop_q_t *)(coop_global_curr->joining)))
!= NULL)
{
coop_qput (&coop_global_runq, newthread);
}
free (coop_global_curr->joining);
}
scm_I_am_dead = 1;
do {
newthread = coop_wait_for_runnable_thread();
} while (newthread == coop_global_curr);
scm_I_am_dead = 0;
coop_all_qremove (&coop_global_allq, coop_global_curr);
old = coop_global_curr;
coop_global_curr = newthread;
QT_ABORT (coop_aborthelp, old, (void *) NULL, newthread->sp);
}
static void *
coop_aborthelp (qt_t *sp, void *old, void *null)
{
coop_t *oldthread = (coop_t *) old;
if (oldthread->specific)
free (oldthread->specific);
#ifndef GUILE_PTHREAD_COMPAT
free (oldthread->sto);
free (oldthread);
#else
coop_qput (&coop_deadq, oldthread);
#endif
return NULL;
}
void
coop_join(coop_t *t)
{
coop_t *old, *newthread;
/* Create a join list if necessary */
if (t->joining == NULL)
{
t->joining = scm_malloc(sizeof(coop_q_t));
coop_qinit((coop_q_t *) t->joining);
}
newthread = coop_wait_for_runnable_thread();
if (newthread == coop_global_curr)
return;
old = coop_global_curr;
coop_global_curr = newthread;
QT_BLOCK (coop_yieldhelp, old, (coop_q_t *) t->joining, newthread->sp);
}
void
coop_yield()
{
coop_t *old = NULL;
coop_t *newthread;
newthread = coop_next_runnable_thread();
/* There may be no other runnable threads. Return if this is the
case. */
if (newthread == coop_global_curr)
return;
old = coop_global_curr;
coop_global_curr = newthread;
QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
}
static void *
coop_yieldhelp (qt_t *sp, void *old, void *blockq)
{
((coop_t *)old)->sp = sp;
coop_qput ((coop_q_t *)blockq, (coop_t *)old);
return NULL;
}
/* Replacement for the system's sleep() function. Does the right thing
for the process - but not for the system (it busy-waits) */
void *
coop_sleephelp (qt_t *sp, void *old, void *blockq)
{
((coop_t *)old)->sp = sp;
/* old is already on the sleep queue - so there's no need to
do anything extra here */
return NULL;
}
unsigned long
scm_thread_usleep (unsigned long usec)
{
struct timeval timeout;
timeout.tv_sec = 0;
timeout.tv_usec = usec;
scm_internal_select (0, NULL, NULL, NULL, &timeout);
return 0; /* Maybe we should calculate actual time slept,
but this is faster... :) */
}
unsigned long
scm_thread_sleep (unsigned long sec)
{
time_t now = time (NULL);
struct timeval timeout;
unsigned long slept;
timeout.tv_sec = sec;
timeout.tv_usec = 0;
scm_internal_select (0, NULL, NULL, NULL, &timeout);
slept = time (NULL) - now;
return slept > sec ? 0 : sec - slept;
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

2
libguile/debug-malloc.c
View file

@ -220,7 +220,7 @@ SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
int i;
for (i = 0; i < malloc_type_size + N_SEEK; ++i)
if (malloc_type[i].key)
res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
res = scm_acons (scm_from_locale_string ((char *) malloc_type[i].key),
scm_from_int ((int) malloc_type[i].data),
res);
return res;

26
libguile/goops.c
View file

@ -152,8 +152,13 @@ SCM scm_class_protected_opaque, scm_class_protected_read_only;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
SCM *scm_port_class = 0;
SCM *scm_smob_class = 0;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
offsets. See `SCM_IN_PCLASS_INDEX' et al. */
SCM scm_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT];
/* SMOB classes. */
SCM scm_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
SCM scm_no_applicable_method;
@ -1218,7 +1223,10 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
i = scm_to_unsigned_integer (index, 0,
SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
scm_si_nfields))
- 1);
return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
@ -1232,7 +1240,10 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
i = scm_to_unsigned_integer (index, 0,
SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
scm_si_nfields))
- 1);
SCM_SET_SLOT (obj, i, value);
@ -2688,8 +2699,7 @@ create_smob_classes (void)
{
long i;
scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
for (i = 0; i < 255; ++i)
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
scm_smob_class[i] = 0;
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
@ -2733,10 +2743,6 @@ create_port_classes (void)
{
long i;
scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
for (i = 0; i < 3 * 256; ++i)
scm_port_class[i] = 0;
for (i = 0; i < scm_numptob; ++i)
scm_make_port_classes (i, SCM_PTOBNAME (i));
}

8
libguile/goops.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GOOPS_H
#define SCM_GOOPS_H
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -98,8 +98,6 @@ typedef struct scm_t_method {
/* Also defined in libguile/objects.c */
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]))
#define SCM_NUMBER_OF_SLOTS(x) \
((SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) - scm_struct_n_extra_words)
#define SCM_CLASSP(x) \
(SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS)
@ -170,8 +168,8 @@ SCM_API SCM scm_class_complex;
SCM_API SCM scm_class_integer;
SCM_API SCM scm_class_fraction;
SCM_API SCM scm_class_unknown;
SCM_API SCM *scm_port_class;
SCM_API SCM *scm_smob_class;
SCM_API SCM scm_port_class[];
SCM_API SCM scm_smob_class[];
SCM_API SCM scm_class_top;
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;

2
libguile/inline.h
View file

@ -54,7 +54,7 @@
C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
inline" in that case. */
# if (defined __GNUC__) && (!(__APPLE_CC__ > 5400 && __STDC_VERSION__ >= 199901L))
# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
# define SCM_C_USE_EXTERN_INLINE 1
# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
# define SCM_C_EXTERN_INLINE \

8
libguile/objects.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_OBJECTS_H
#define SCM_OBJECTS_H
/* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -171,9 +171,9 @@ typedef struct scm_effective_slot_definition {
#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
/* Port classes */
#define SCM_IN_PCLASS_INDEX 0x000
#define SCM_OUT_PCLASS_INDEX 0x100
#define SCM_INOUT_PCLASS_INDEX 0x200
#define SCM_IN_PCLASS_INDEX 0
#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
/* Plugin proxy classes for basic types. */
SCM_API SCM scm_metaclass_standard;

6
libguile/ports.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -136,7 +136,7 @@ scm_make_port_type (char *name,
void (*write) (SCM port, const void *data, size_t size))
{
char *tmp;
if (255 <= scm_numptob)
if (SCM_I_MAX_PORT_TYPE_COUNT - 1 <= scm_numptob)
goto ptoberr;
SCM_CRITICAL_SECTION_START;
SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
@ -172,7 +172,7 @@ scm_make_port_type (char *name,
scm_memory_error ("scm_make_port_type");
}
/* Make a class object if Goops is present */
if (scm_port_class)
if (SCM_UNPACK (scm_port_class[0]) != 0)
scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1));
return scm_tc7_port + (scm_numptob - 1) * 256;
}

5
libguile/ports.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_PORTS_H
#define SCM_PORTS_H
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -162,6 +162,9 @@ SCM_INTERNAL SCM scm_i_port_weak_hash;
#define SCM_DECCOL(port) {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;}
#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
/* Maximum number of port types. */
#define SCM_I_MAX_PORT_TYPE_COUNT 256
/* port-type description. */

6
libguile/procs.c
View file

@ -44,14 +44,14 @@ scm_t_subr_entry *scm_subr_table;
/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on
startup, 786 with guile-readline. 'martin */
long scm_subr_table_size = 0;
long scm_subr_table_room = 800;
static unsigned long scm_subr_table_size = 0;
static unsigned long scm_subr_table_room = 800;
SCM
scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
{
register SCM z;
long entry;
unsigned long entry;
if (scm_subr_table_size == scm_subr_table_room)
{

4
libguile/procs.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_PROCS_H
#define SCM_PROCS_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -131,8 +131,6 @@ typedef struct
#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
SCM_API scm_t_subr_entry *scm_subr_table;
SCM_API long scm_subr_table_size;
SCM_API long scm_subr_table_room;

11
libguile/smob.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -45,7 +45,8 @@
* tags for smobjects (if you know a tag you can get an index and conversely).
*/
#define MAX_SMOB_COUNT 256
#define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
@ -308,7 +309,7 @@ scm_make_smob_type (char const *name, size_t size)
}
/* Make a class object if Goops is present. */
if (scm_smob_class)
if (SCM_UNPACK (scm_smob_class[0]) != 0)
scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
return scm_tc7_smob + new_smob * 256;
@ -448,8 +449,8 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
if (scm_smob_class)
if (SCM_UNPACK (scm_smob_class[0]) != 0)
scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}

5
libguile/smob.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_SMOB_H
#define SCM_SMOB_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -112,6 +112,9 @@ do { \
#define SCM_SMOB_APPLY_2(x, a1, a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2)))
#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst)))
/* Maximum number of SMOB types. */
#define SCM_I_MAX_SMOB_TYPE_COUNT 256
SCM_API long scm_numsmob;
SCM_API scm_smob_descriptor scm_smobs[];

18
libguile/threads.c
View file

@ -409,6 +409,7 @@ scm_enter_guile (scm_t_guile_ticket ticket)
if (t)
{
scm_i_pthread_mutex_lock (&t->heap_mutex);
t->heap_mutex_locked_by_self = 1;
resume (t);
}
}
@ -430,7 +431,11 @@ static scm_t_guile_ticket
scm_leave_guile ()
{
scm_i_thread *t = suspend ();
scm_i_pthread_mutex_unlock (&t->heap_mutex);
if (t->heap_mutex_locked_by_self)
{
t->heap_mutex_locked_by_self = 0;
scm_i_pthread_mutex_unlock (&t->heap_mutex);
}
return (scm_t_guile_ticket) t;
}
@ -491,6 +496,7 @@ guilify_self_1 (SCM_STACKITEM *base)
abort ();
scm_i_pthread_mutex_init (&t->heap_mutex, NULL);
t->heap_mutex_locked_by_self = 0;
scm_i_pthread_mutex_init (&t->admin_mutex, NULL);
t->clear_freelists_p = 0;
t->gc_running_p = 0;
@ -505,6 +511,7 @@ guilify_self_1 (SCM_STACKITEM *base)
scm_i_pthread_setspecific (scm_i_thread_key, t);
scm_i_pthread_mutex_lock (&t->heap_mutex);
t->heap_mutex_locked_by_self = 1;
scm_i_pthread_mutex_lock (&thread_admin_mutex);
t->next_thread = all_threads;
@ -1992,9 +1999,14 @@ void
scm_i_thread_sleep_for_gc ()
{
scm_i_thread *t = suspend ();
t->held_mutex = &t->heap_mutex;
/* Don't put t->heap_mutex in t->held_mutex here, because if the
thread is cancelled during the cond wait, the thread's cleanup
function (scm_leave_guile_cleanup) will handle unlocking the
heap_mutex, so we don't need to do that again in on_thread_exit.
*/
scm_i_pthread_cond_wait (&wake_up_cond, &t->heap_mutex);
t->held_mutex = NULL;
resume (t);
}

9
libguile/threads.h
View file

@ -72,6 +72,13 @@ typedef struct scm_i_thread {
*/
scm_i_pthread_mutex_t heap_mutex;
/* Boolean tracking whether the above mutex is currently locked by
this thread. This is equivalent to whether or not the thread is
in "Guile mode". This field doesn't need any protection because
it is only ever set or tested by the owning thread.
*/
int heap_mutex_locked_by_self;
/* The freelists of this thread. Each thread has its own lists so
that they can all allocate concurrently.
*/
@ -225,7 +232,7 @@ SCM_API int scm_pthread_cond_wait (pthread_cond_t *cond,
pthread_mutex_t *mutex);
SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond,
pthread_mutex_t *mutex,
const struct timespec *abstime);
const scm_t_timespec *abstime);
#endif
/* More convenience functions.

21
m4/codeset.m4 Normal file
View file

@ -0,0 +1,21 @@
# codeset.m4 serial 3 (gettext-0.18)
dnl Copyright (C) 2000-2002, 2006, 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
AC_DEFUN([AM_LANGINFO_CODESET],
[
AC_CACHE_CHECK([for nl_langinfo and CODESET], [am_cv_langinfo_codeset],
[AC_TRY_LINK([#include <langinfo.h>],
[char* cs = nl_langinfo(CODESET); return !cs;],
[am_cv_langinfo_codeset=yes],
[am_cv_langinfo_codeset=no])
])
if test $am_cv_langinfo_codeset = yes; then
AC_DEFINE([HAVE_LANGINFO_CODESET], 1,
[Define if you have <langinfo.h> and nl_langinfo(CODESET).])
fi
])

14
m4/extensions.m4
View file

@ -1,4 +1,4 @@
# serial 5 -*- Autoconf -*-
# serial 6 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
# Copyright (C) 2003, 2006-2008 Free Software Foundation, Inc.
@ -24,6 +24,8 @@ AC_DEFUN([AC_USE_SYSTEM_EXTENSIONS],
[AC_BEFORE([$0], [AC_COMPILE_IFELSE])dnl
AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
AC_REQUIRE([AC_CANONICAL_HOST])
AC_CHECK_HEADER([minix/config.h], [MINIX=yes], [MINIX=])
if test "$MINIX" = yes; then
AC_DEFINE([_POSIX_SOURCE], [1],
@ -36,6 +38,16 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
[Define to 1 if on MINIX.])
fi
dnl HP-UX 11.11 defines mbstate_t only if _XOPEN_SOURCE is defined to 500,
dnl regardless of whether the flags -Ae or _D_HPUX_SOURCE=1 are already
dnl provided.
case "$host_os" in
hpux*)
AC_DEFINE([_XOPEN_SOURCE], [500],
[Define to 500 only on HP-UX.])
;;
esac
AH_VERBATIM([__EXTENSIONS__],
[/* Enable extensions on AIX 3, Interix. */
#ifndef _ALL_SOURCE

30
m4/glibc21.m4 Normal file
View file

@ -0,0 +1,30 @@
# glibc21.m4 serial 4
dnl Copyright (C) 2000-2002, 2004, 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
# Test for the GNU C Library, version 2.1 or newer.
# From Bruno Haible.
AC_DEFUN([gl_GLIBC21],
[
AC_CACHE_CHECK([whether we are using the GNU C Library 2.1 or newer],
[ac_cv_gnu_library_2_1],
[AC_EGREP_CPP([Lucky GNU user],
[
#include <features.h>
#ifdef __GNU_LIBRARY__
#if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 1) || (__GLIBC__ > 2)
Lucky GNU user
#endif
#endif
],
[ac_cv_gnu_library_2_1=yes],
[ac_cv_gnu_library_2_1=no])
]
)
AC_SUBST([GLIBC21])
GLIBC21="$ac_cv_gnu_library_2_1"
]
)

7
m4/gnulib-cache.m4
View file

@ -1,4 +1,4 @@
# Copyright (C) 2002-2008 Free Software Foundation, Inc.
# Copyright (C) 2002-2009 Free Software Foundation, Inc.
#
# This file is free software, distributed under the terms of the GNU
# General Public License. As a special exception to the GNU General
@ -15,12 +15,12 @@
# Specification in the form of a command-line invocation:
# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca autobuild count-one-bits extensions full-read full-write strcase strftime
# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions full-read full-write strcase strftime
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([])
gl_MODULES([
alloca
alloca-opt
autobuild
count-one-bits
extensions
@ -41,3 +41,4 @@ gl_MAKEFILE_NAME([])
gl_LIBTOOL
gl_MACRO_PREFIX([gl])
gl_PO_DOMAIN([])
gl_VC_FILES([false])

34
m4/gnulib-comp.m4
View file

@ -1,5 +1,5 @@
# DO NOT EDIT! GENERATED AUTOMATICALLY!
# Copyright (C) 2002-2008 Free Software Foundation, Inc.
# Copyright (C) 2002-2009 Free Software Foundation, Inc.
#
# This file is free software, distributed under the terms of the GNU
# General Public License. As a special exception to the GNU General
@ -42,13 +42,18 @@ AC_DEFUN([gl_INIT],
m4_pushdef([gl_LIBSOURCES_DIR], [])
gl_COMMON
gl_source_base='lib'
changequote(,)dnl
LTALLOCA=`echo "$ALLOCA" | sed 's/\.[^.]* /.lo /g;s/\.[^.]*$/.lo/'`
changequote([, ])dnl
AC_SUBST([LTALLOCA])
gl_FUNC_ALLOCA
gl_COUNT_ONE_BITS
gl_INLINE
gl_LOCALCHARSET
LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\""
AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
gl_FUNC_MBRLEN
gl_WCHAR_MODULE_INDICATOR([mbrlen])
gl_FUNC_MBRTOWC
gl_WCHAR_MODULE_INDICATOR([mbrtowc])
gl_FUNC_MBSINIT
gl_WCHAR_MODULE_INDICATOR([mbsinit])
gl_SAFE_READ
gl_SAFE_WRITE
gt_TYPE_SSIZE_T
@ -191,19 +196,27 @@ AC_DEFUN([gltests_LIBSOURCES], [
# gnulib-tool and may be removed by future gnulib-tool invocations.
AC_DEFUN([gl_FILE_LIST], [
build-aux/link-warning.h
lib/alloca.c
lib/alloca.in.h
lib/config.charset
lib/count-one-bits.h
lib/full-read.c
lib/full-read.h
lib/full-write.c
lib/full-write.h
lib/localcharset.c
lib/localcharset.h
lib/mbrlen.c
lib/mbrtowc.c
lib/mbsinit.c
lib/ref-add.sin
lib/ref-del.sin
lib/safe-read.c
lib/safe-read.h
lib/safe-write.c
lib/safe-write.h
lib/stdbool.in.h
lib/strcasecmp.c
lib/streq.h
lib/strftime.c
lib/strftime.h
lib/strings.in.h
@ -216,11 +229,20 @@ AC_DEFUN([gl_FILE_LIST], [
lib/write.c
m4/alloca.m4
m4/autobuild.m4
m4/codeset.m4
m4/count-one-bits.m4
m4/extensions.m4
m4/glibc21.m4
m4/gnulib-common.m4
m4/include_next.m4
m4/inline.m4
m4/localcharset.m4
m4/locale-fr.m4
m4/locale-ja.m4
m4/locale-zh.m4
m4/mbrlen.m4
m4/mbrtowc.m4
m4/mbsinit.m4
m4/mbstate_t.m4
m4/safe-read.m4
m4/safe-write.m4

16
m4/localcharset.m4 Normal file
View file

@ -0,0 +1,16 @@
# localcharset.m4 serial 5
dnl Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_LOCALCHARSET],
[
dnl Prerequisites of lib/localcharset.c.
AC_REQUIRE([AM_LANGINFO_CODESET])
AC_CHECK_DECLS_ONCE(getc_unlocked)
dnl Prerequisites of the lib/Makefile.am snippet.
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([gl_GLIBC21])
])

204
m4/locale-fr.m4 Normal file
View file

@ -0,0 +1,204 @@
# locale-fr.m4 serial 9
dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
dnl Determine the name of a french locale with traditional encoding.
AC_DEFUN([gt_LOCALE_FR],
[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AM_LANGINFO_CODESET])
AC_CACHE_CHECK([for a traditional french locale], gt_cv_locale_fr, [
macosx=
changequote(,)dnl
case "$host_os" in
darwin[56]*) ;;
darwin*) macosx=yes;;
esac
changequote([,])dnl
if test -n "$macosx"; then
# On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8
# encodings, but the kernel does not support them. The documentation
# says:
# "... all code that calls BSD system routines should ensure
# that the const *char parameters of these routines are in UTF-8
# encoding. All BSD system functions expect their string
# parameters to be in UTF-8 encoding and nothing else."
# See the comments in config.charset. Therefore we bypass the test.
gt_cv_locale_fr=none
else
AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <time.h>
#if HAVE_LANGINFO_CODESET
# include <langinfo.h>
#endif
#include <stdlib.h>
#include <string.h>
struct tm t;
char buf[16];
int main () {
/* Check whether the given locale name is recognized by the system. */
if (setlocale (LC_ALL, "") == NULL) return 1;
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
some unit tests fail. */
#if HAVE_LANGINFO_CODESET
{
const char *cs = nl_langinfo (CODESET);
if (cs[0] == '\0' || strcmp (cs, "ASCII") == 0 || strcmp (cs, "646") == 0)
return 1;
}
#endif
#ifdef __CYGWIN__
/* On Cygwin, avoid locale names without encoding suffix, because the
locale_charset() function relies on the encoding suffix. Note that
LC_ALL is set on the command line. */
if (strchr (getenv ("LC_ALL"), '.') == NULL) return 1;
#endif
/* Check whether in the abbreviation of the second month, the second
character (should be U+00E9: LATIN SMALL LETTER E WITH ACUTE) is only
one byte long. This excludes the UTF-8 encoding. */
t.tm_year = 1975 - 1900; t.tm_mon = 2 - 1; t.tm_mday = 4;
if (strftime (buf, sizeof (buf), "%b", &t) < 3 || buf[2] != 'v') return 1;
/* Check whether the decimal separator is a comma.
On NetBSD 3.0 in the fr_FR.ISO8859-1 locale, localeconv()->decimal_point
are nl_langinfo(RADIXCHAR) are both ".". */
if (localeconv () ->decimal_point[0] != ',') return 1;
return 0;
}
changequote([,])dnl
])])
if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
# Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
# otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
# configure script would override the LC_ALL setting. Likewise for
# LC_CTYPE, which is also set at the beginning of the configure script.
# Test for the usual locale name.
if (LC_ALL=fr_FR LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr=fr_FR
else
# Test for the locale name with explicit encoding suffix.
if (LC_ALL=fr_FR.ISO-8859-1 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr=fr_FR.ISO-8859-1
else
# Test for the AIX, OSF/1, FreeBSD, NetBSD, OpenBSD locale name.
if (LC_ALL=fr_FR.ISO8859-1 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr=fr_FR.ISO8859-1
else
# Test for the HP-UX locale name.
if (LC_ALL=fr_FR.iso88591 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr=fr_FR.iso88591
else
# Test for the Solaris 7 locale name.
if (LC_ALL=fr LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr=fr
else
# None found.
gt_cv_locale_fr=none
fi
fi
fi
fi
fi
fi
rm -fr conftest*
fi
])
LOCALE_FR=$gt_cv_locale_fr
AC_SUBST([LOCALE_FR])
])
dnl Determine the name of a french locale with UTF-8 encoding.
AC_DEFUN([gt_LOCALE_FR_UTF8],
[
AC_REQUIRE([AM_LANGINFO_CODESET])
AC_CACHE_CHECK([for a french Unicode locale], gt_cv_locale_fr_utf8, [
AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <time.h>
#if HAVE_LANGINFO_CODESET
# include <langinfo.h>
#endif
#include <stdlib.h>
#include <string.h>
struct tm t;
char buf[16];
int main () {
/* On BeOS and Haiku, locales are not implemented in libc. Rather, libintl
imitates locale dependent behaviour by looking at the environment
variables, and all locales use the UTF-8 encoding. */
#if !(defined __BEOS__ || defined __HAIKU__)
/* Check whether the given locale name is recognized by the system. */
if (setlocale (LC_ALL, "") == NULL) return 1;
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
some unit tests fail. */
# if HAVE_LANGINFO_CODESET
{
const char *cs = nl_langinfo (CODESET);
if (cs[0] == '\0' || strcmp (cs, "ASCII") == 0 || strcmp (cs, "646") == 0)
return 1;
}
# endif
# ifdef __CYGWIN__
/* On Cygwin, avoid locale names without encoding suffix, because the
locale_charset() function relies on the encoding suffix. Note that
LC_ALL is set on the command line. */
if (strchr (getenv ("LC_ALL"), '.') == NULL) return 1;
# endif
/* Check whether in the abbreviation of the second month, the second
character (should be U+00E9: LATIN SMALL LETTER E WITH ACUTE) is
two bytes long, with UTF-8 encoding. */
t.tm_year = 1975 - 1900; t.tm_mon = 2 - 1; t.tm_mday = 4;
if (strftime (buf, sizeof (buf), "%b", &t) < 4
|| buf[1] != (char) 0xc3 || buf[2] != (char) 0xa9 || buf[3] != 'v')
return 1;
#endif
/* Check whether the decimal separator is a comma.
On NetBSD 3.0 in the fr_FR.ISO8859-1 locale, localeconv()->decimal_point
are nl_langinfo(RADIXCHAR) are both ".". */
if (localeconv () ->decimal_point[0] != ',') return 1;
return 0;
}
changequote([,])dnl
])])
if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
# Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
# otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
# configure script would override the LC_ALL setting. Likewise for
# LC_CTYPE, which is also set at the beginning of the configure script.
# Test for the usual locale name.
if (LC_ALL=fr_FR LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr_utf8=fr_FR
else
# Test for the locale name with explicit encoding suffix.
if (LC_ALL=fr_FR.UTF-8 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr_utf8=fr_FR.UTF-8
else
# Test for the Solaris 7 locale name.
if (LC_ALL=fr.UTF-8 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_fr_utf8=fr.UTF-8
else
# None found.
gt_cv_locale_fr_utf8=none
fi
fi
fi
fi
rm -fr conftest*
])
LOCALE_FR_UTF8=$gt_cv_locale_fr_utf8
AC_SUBST([LOCALE_FR_UTF8])
])

126
m4/locale-ja.m4 Normal file
View file

@ -0,0 +1,126 @@
# locale-ja.m4 serial 5
dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
dnl Determine the name of a japanese locale with EUC-JP encoding.
AC_DEFUN([gt_LOCALE_JA],
[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AM_LANGINFO_CODESET])
AC_CACHE_CHECK([for a traditional japanese locale], gt_cv_locale_ja, [
macosx=
changequote(,)dnl
case "$host_os" in
darwin[56]*) ;;
darwin*) macosx=yes;;
esac
changequote([,])dnl
if test -n "$macosx"; then
# On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8
# encodings, but the kernel does not support them. The documentation
# says:
# "... all code that calls BSD system routines should ensure
# that the const *char parameters of these routines are in UTF-8
# encoding. All BSD system functions expect their string
# parameters to be in UTF-8 encoding and nothing else."
# See the comments in config.charset. Therefore we bypass the test.
gt_cv_locale_ja=none
else
AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <time.h>
#if HAVE_LANGINFO_CODESET
# include <langinfo.h>
#endif
#include <stdlib.h>
#include <string.h>
struct tm t;
char buf[16];
int main ()
{
const char *p;
/* Check whether the given locale name is recognized by the system. */
if (setlocale (LC_ALL, "") == NULL) return 1;
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
some unit tests fail. */
#if HAVE_LANGINFO_CODESET
{
const char *cs = nl_langinfo (CODESET);
if (cs[0] == '\0' || strcmp (cs, "ASCII") == 0 || strcmp (cs, "646") == 0)
return 1;
}
#endif
#ifdef __CYGWIN__
/* On Cygwin, avoid locale names without encoding suffix, because the
locale_charset() function relies on the encoding suffix. Note that
LC_ALL is set on the command line. */
if (strchr (getenv ("LC_ALL"), '.') == NULL) return 1;
#endif
/* Check whether MB_CUR_MAX is > 1. This excludes the dysfunctional locales
on Cygwin 1.5.x. */
if (MB_CUR_MAX == 1)
return 1;
/* Check whether in a month name, no byte in the range 0x80..0x9F occurs.
This excludes the UTF-8 encoding. */
t.tm_year = 1975 - 1900; t.tm_mon = 2 - 1; t.tm_mday = 4;
if (strftime (buf, sizeof (buf), "%B", &t) < 2) return 1;
for (p = buf; *p != '\0'; p++)
if ((unsigned char) *p >= 0x80 && (unsigned char) *p < 0xa0)
return 1;
return 0;
}
changequote([,])dnl
])])
if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
# Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
# otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
# configure script would override the LC_ALL setting. Likewise for
# LC_CTYPE, which is also set at the beginning of the configure script.
# Test for the AIX locale name.
if (LC_ALL=ja_JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_ja=ja_JP
else
# Test for the locale name with explicit encoding suffix.
if (LC_ALL=ja_JP.EUC-JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_ja=ja_JP.EUC-JP
else
# Test for the HP-UX, OSF/1, NetBSD locale name.
if (LC_ALL=ja_JP.eucJP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_ja=ja_JP.eucJP
else
# Test for the IRIX, FreeBSD locale name.
if (LC_ALL=ja_JP.EUC LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_ja=ja_JP.EUC
else
# Test for the Solaris 7 locale name.
if (LC_ALL=ja LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_ja=ja
else
# Special test for NetBSD 1.6.
if test -f /usr/share/locale/ja_JP.eucJP/LC_CTYPE; then
gt_cv_locale_ja=ja_JP.eucJP
else
# None found.
gt_cv_locale_ja=none
fi
fi
fi
fi
fi
fi
fi
rm -fr conftest*
fi
])
LOCALE_JA=$gt_cv_locale_ja
AC_SUBST([LOCALE_JA])
])

111
m4/locale-zh.m4 Normal file
View file

@ -0,0 +1,111 @@
# locale-zh.m4 serial 4
dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
dnl Determine the name of a chinese locale with GB18030 encoding.
AC_DEFUN([gt_LOCALE_ZH_CN],
[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AM_LANGINFO_CODESET])
AC_CACHE_CHECK([for a transitional chinese locale], gt_cv_locale_zh_CN, [
macosx=
changequote(,)dnl
case "$host_os" in
darwin[56]*) ;;
darwin*) macosx=yes;;
esac
changequote([,])dnl
if test -n "$macosx"; then
# On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8
# encodings, but the kernel does not support them. The documentation
# says:
# "... all code that calls BSD system routines should ensure
# that the const *char parameters of these routines are in UTF-8
# encoding. All BSD system functions expect their string
# parameters to be in UTF-8 encoding and nothing else."
# See the comments in config.charset. Therefore we bypass the test.
gt_cv_locale_zh_CN=none
else
AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <stdlib.h>
#include <time.h>
#if HAVE_LANGINFO_CODESET
# include <langinfo.h>
#endif
#include <stdlib.h>
#include <string.h>
struct tm t;
char buf[16];
int main ()
{
const char *p;
/* Check whether the given locale name is recognized by the system. */
if (setlocale (LC_ALL, "") == NULL) return 1;
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
some unit tests fail. */
#if HAVE_LANGINFO_CODESET
{
const char *cs = nl_langinfo (CODESET);
if (cs[0] == '\0' || strcmp (cs, "ASCII") == 0 || strcmp (cs, "646") == 0)
return 1;
}
#endif
#ifdef __CYGWIN__
/* On Cygwin, avoid locale names without encoding suffix, because the
locale_charset() function relies on the encoding suffix. Note that
LC_ALL is set on the command line. */
if (strchr (getenv ("LC_ALL"), '.') == NULL) return 1;
#endif
/* Check whether in a month name, no byte in the range 0x80..0x9F occurs.
This excludes the UTF-8 encoding. */
t.tm_year = 1975 - 1900; t.tm_mon = 2 - 1; t.tm_mday = 4;
if (strftime (buf, sizeof (buf), "%B", &t) < 2) return 1;
for (p = buf; *p != '\0'; p++)
if ((unsigned char) *p >= 0x80 && (unsigned char) *p < 0xa0)
return 1;
/* Check whether a typical GB18030 multibyte sequence is recognized as a
single wide character. This excludes the GB2312 and GBK encodings. */
if (mblen ("\203\062\332\066", 5) != 4)
return 1;
return 0;
}
changequote([,])dnl
])])
if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
# Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
# otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
# configure script would override the LC_ALL setting. Likewise for
# LC_CTYPE, which is also set at the beginning of the configure script.
# Test for the locale name without encoding suffix.
if (LC_ALL=zh_CN LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_zh_CN=zh_CN
else
# Test for the locale name with explicit encoding suffix.
if (LC_ALL=zh_CN.GB18030 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
gt_cv_locale_zh_CN=zh_CN.GB18030
else
# None found.
gt_cv_locale_zh_CN=none
fi
fi
else
# If there was a link error, due to mblen(), the system is so old that
# it certainly doesn't have a chinese locale.
gt_cv_locale_zh_CN=none
fi
rm -fr conftest*
fi
])
LOCALE_ZH_CN=$gt_cv_locale_zh_CN
AC_SUBST([LOCALE_ZH_CN])
])

197
m4/mbrlen.m4 Normal file
View file

@ -0,0 +1,197 @@
# mbrlen.m4 serial 2
dnl Copyright (C) 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_FUNC_MBRLEN],
[
AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
AC_REQUIRE([AC_TYPE_MBSTATE_T])
AC_REQUIRE([gl_FUNC_MBRTOWC])
AC_CHECK_FUNCS_ONCE([mbrlen])
if test $ac_cv_func_mbrlen = no; then
HAVE_MBRLEN=0
else
dnl Most bugs affecting the system's mbrtowc function also affect the
dnl mbrlen function. So override mbrlen whenever mbrtowc is overridden.
dnl We could also run the individual tests below; the results would be
dnl the same.
if test $REPLACE_MBRTOWC = 1; then
REPLACE_MBRLEN=1
fi
fi
if test $HAVE_MBRLEN = 0 || test $REPLACE_MBRLEN = 1; then
gl_REPLACE_WCHAR_H
AC_LIBOBJ([mbrlen])
gl_PREREQ_MBRLEN
fi
])
dnl Test whether mbrlen puts the state into non-initial state when parsing an
dnl incomplete multibyte character.
dnl Result is gl_cv_func_mbrlen_incomplete_state.
AC_DEFUN([gl_MBRLEN_INCOMPLETE_STATE],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_JA])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrlen handles incomplete characters],
[gl_cv_func_mbrlen_incomplete_state],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on AIX and OSF/1.
osf*) gl_cv_func_mbrlen_incomplete_state="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrlen_incomplete_state="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_JA != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
if (setlocale (LC_ALL, "$LOCALE_JA") != NULL)
{
const char input[] = "B\217\253\344\217\251\316er"; /* "Büßer" */
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrlen (input + 1, 1, &state) == (size_t)(-2))
if (mbsinit (&state))
return 1;
}
return 0;
}],
[gl_cv_func_mbrlen_incomplete_state=yes],
[gl_cv_func_mbrlen_incomplete_state=no],
[])
fi
])
])
dnl Test whether mbrlen, when parsing the end of a multibyte character,
dnl correctly returns the number of bytes that were needed to complete the
dnl character (not the total number of bytes of the multibyte character).
dnl Result is gl_cv_func_mbrlen_retval.
AC_DEFUN([gl_MBRLEN_RETVAL],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_FR_UTF8])
AC_REQUIRE([gt_LOCALE_JA])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrlen has a correct return value],
[gl_cv_func_mbrlen_retval],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on HP-UX and Solaris.
hpux* | solaris*) gl_cv_func_mbrlen_retval="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrlen_retval="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_FR_UTF8 != none || test $LOCALE_JA != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
/* This fails on Solaris. */
if (setlocale (LC_ALL, "$LOCALE_FR_UTF8") != NULL)
{
char input[] = "B\303\274\303\237er"; /* "Büßer" */
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrlen (input + 1, 1, &state) == (size_t)(-2))
{
input[1] = '\0';
if (mbrlen (input + 2, 5, &state) != 1)
return 1;
}
}
/* This fails on HP-UX 11.11. */
if (setlocale (LC_ALL, "$LOCALE_JA") != NULL)
{
char input[] = "B\217\253\344\217\251\316er"; /* "Büßer" */
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrlen (input + 1, 1, &state) == (size_t)(-2))
{
input[1] = '\0';
if (mbrlen (input + 2, 5, &state) != 2)
return 1;
}
}
return 0;
}],
[gl_cv_func_mbrlen_retval=yes],
[gl_cv_func_mbrlen_retval=no],
[])
fi
])
])
dnl Test whether mbrlen, when parsing a NUL character, correctly returns 0.
dnl Result is gl_cv_func_mbrlen_nul_retval.
AC_DEFUN([gl_MBRLEN_NUL_RETVAL],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_ZH_CN])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrlen returns 0 when parsing a NUL character],
[gl_cv_func_mbrlen_nul_retval],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on Solaris 9.
solaris2.9) gl_cv_func_mbrlen_nul_retval="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrlen_nul_retval="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_ZH_CN != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
/* This crashes on Solaris 9 inside __mbrtowc_dense_gb18030. */
if (setlocale (LC_ALL, "$LOCALE_ZH_CN") != NULL)
{
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrlen ("", 1, &state) != 0)
return 1;
}
return 0;
}],
[gl_cv_func_mbrlen_nul_retval=yes],
[gl_cv_func_mbrlen_nul_retval=no],
[])
fi
])
])
# Prerequisites of lib/mbrlen.c.
AC_DEFUN([gl_PREREQ_MBRLEN], [
:
])

325
m4/mbrtowc.m4 Normal file
View file

@ -0,0 +1,325 @@
# mbrtowc.m4 serial 12
dnl Copyright (C) 2001-2002, 2004-2005, 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_FUNC_MBRTOWC],
[
AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
AC_REQUIRE([AC_TYPE_MBSTATE_T])
gl_MBSTATE_T_BROKEN
if test $REPLACE_MBSTATE_T = 1; then
REPLACE_MBRTOWC=1
fi
AC_CHECK_FUNCS_ONCE([mbrtowc])
if test $ac_cv_func_mbrtowc = no; then
HAVE_MBRTOWC=0
fi
if test $HAVE_MBRTOWC != 0 && test $REPLACE_MBRTOWC != 1; then
gl_MBRTOWC_NULL_ARG
gl_MBRTOWC_RETVAL
gl_MBRTOWC_NUL_RETVAL
case "$gl_cv_func_mbrtowc_null_arg" in
*yes) ;;
*) AC_DEFINE([MBRTOWC_NULL_ARG_BUG], [1],
[Define if the mbrtowc function has the NULL string argument bug.])
REPLACE_MBRTOWC=1
;;
esac
case "$gl_cv_func_mbrtowc_retval" in
*yes) ;;
*) AC_DEFINE([MBRTOWC_RETVAL_BUG], [1],
[Define if the mbrtowc function returns a wrong return value.])
REPLACE_MBRTOWC=1
;;
esac
case "$gl_cv_func_mbrtowc_nul_retval" in
*yes) ;;
*) AC_DEFINE([MBRTOWC_NUL_RETVAL_BUG], [1],
[Define if the mbrtowc function does not return 0 for a NUL character.])
REPLACE_MBRTOWC=1
;;
esac
fi
if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then
gl_REPLACE_WCHAR_H
AC_LIBOBJ([mbrtowc])
gl_PREREQ_MBRTOWC
fi
])
dnl Test whether mbsinit() and mbrtowc() need to be overridden in a way that
dnl redefines the semantics of the given mbstate_t type.
dnl Result is REPLACE_MBSTATE_T.
dnl When this is set to 1, we replace both mbsinit() and mbrtowc(), in order to
dnl avoid inconsistencies.
AC_DEFUN([gl_MBSTATE_T_BROKEN],
[
AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
AC_REQUIRE([AC_TYPE_MBSTATE_T])
AC_CHECK_FUNCS_ONCE([mbsinit])
AC_CHECK_FUNCS_ONCE([mbrtowc])
if test $ac_cv_func_mbsinit = yes && test $ac_cv_func_mbrtowc = yes; then
gl_MBRTOWC_INCOMPLETE_STATE
case "$gl_cv_func_mbrtowc_incomplete_state" in
*yes) REPLACE_MBSTATE_T=0 ;;
*) REPLACE_MBSTATE_T=1 ;;
esac
else
REPLACE_MBSTATE_T=1
fi
if test $REPLACE_MBSTATE_T = 1; then
gl_REPLACE_WCHAR_H
fi
])
dnl Test whether mbrtowc puts the state into non-initial state when parsing an
dnl incomplete multibyte character.
dnl Result is gl_cv_func_mbrtowc_incomplete_state.
AC_DEFUN([gl_MBRTOWC_INCOMPLETE_STATE],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_JA])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrtowc handles incomplete characters],
[gl_cv_func_mbrtowc_incomplete_state],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on AIX and OSF/1.
osf*) gl_cv_func_mbrtowc_incomplete_state="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrtowc_incomplete_state="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_JA != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
if (setlocale (LC_ALL, "$LOCALE_JA") != NULL)
{
const char input[] = "B\217\253\344\217\251\316er"; /* "Büßer" */
mbstate_t state;
wchar_t wc;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrtowc (&wc, input + 1, 1, &state) == (size_t)(-2))
if (mbsinit (&state))
return 1;
}
return 0;
}],
[gl_cv_func_mbrtowc_incomplete_state=yes],
[gl_cv_func_mbrtowc_incomplete_state=no],
[])
fi
])
])
dnl Test whether mbrtowc supports a NULL string argument correctly.
dnl Result is gl_cv_func_mbrtowc_null_arg.
AC_DEFUN([gl_MBRTOWC_NULL_ARG],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_FR_UTF8])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrtowc handles a NULL string argument],
[gl_cv_func_mbrtowc_null_arg],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on OSF/1.
osf*) gl_cv_func_mbrtowc_null_arg="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrtowc_null_arg="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_FR_UTF8 != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
if (setlocale (LC_ALL, "$LOCALE_FR_UTF8") != NULL)
{
mbstate_t state;
wchar_t wc;
int ret;
memset (&state, '\0', sizeof (mbstate_t));
wc = (wchar_t) 0xBADFACE;
mbrtowc (&wc, NULL, 5, &state);
/* Check that wc was not modified. */
if (wc != (wchar_t) 0xBADFACE)
return 1;
}
return 0;
}], [gl_cv_func_mbrtowc_null_arg=yes], [gl_cv_func_mbrtowc_null_arg=no], [])
fi
])
])
dnl Test whether mbrtowc, when parsing the end of a multibyte character,
dnl correctly returns the number of bytes that were needed to complete the
dnl character (not the total number of bytes of the multibyte character).
dnl Result is gl_cv_func_mbrtowc_retval.
AC_DEFUN([gl_MBRTOWC_RETVAL],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_FR_UTF8])
AC_REQUIRE([gt_LOCALE_JA])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrtowc has a correct return value],
[gl_cv_func_mbrtowc_retval],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on HP-UX and Solaris.
hpux* | solaris*) gl_cv_func_mbrtowc_retval="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrtowc_retval="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_FR_UTF8 != none || test $LOCALE_JA != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
/* This fails on Solaris. */
if (setlocale (LC_ALL, "$LOCALE_FR_UTF8") != NULL)
{
char input[] = "B\303\274\303\237er"; /* "Büßer" */
mbstate_t state;
wchar_t wc;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrtowc (&wc, input + 1, 1, &state) == (size_t)(-2))
{
input[1] = '\0';
if (mbrtowc (&wc, input + 2, 5, &state) != 1)
return 1;
}
}
/* This fails on HP-UX 11.11. */
if (setlocale (LC_ALL, "$LOCALE_JA") != NULL)
{
char input[] = "B\217\253\344\217\251\316er"; /* "Büßer" */
mbstate_t state;
wchar_t wc;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrtowc (&wc, input + 1, 1, &state) == (size_t)(-2))
{
input[1] = '\0';
if (mbrtowc (&wc, input + 2, 5, &state) != 2)
return 1;
}
}
return 0;
}],
[gl_cv_func_mbrtowc_retval=yes],
[gl_cv_func_mbrtowc_retval=no],
[])
fi
])
])
dnl Test whether mbrtowc, when parsing a NUL character, correctly returns 0.
dnl Result is gl_cv_func_mbrtowc_nul_retval.
AC_DEFUN([gl_MBRTOWC_NUL_RETVAL],
[
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([gt_LOCALE_ZH_CN])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether mbrtowc returns 0 when parsing a NUL character],
[gl_cv_func_mbrtowc_nul_retval],
[
dnl Initial guess, used when cross-compiling or when no suitable locale
dnl is present.
changequote(,)dnl
case "$host_os" in
# Guess no on Solaris 9.
solaris2.9) gl_cv_func_mbrtowc_nul_retval="guessing no" ;;
# Guess yes otherwise.
*) gl_cv_func_mbrtowc_nul_retval="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_ZH_CN != none; then
AC_TRY_RUN([
#include <locale.h>
#include <string.h>
#include <wchar.h>
int main ()
{
/* This fails on Solaris 9. */
if (setlocale (LC_ALL, "$LOCALE_ZH_CN") != NULL)
{
mbstate_t state;
wchar_t wc;
memset (&state, '\0', sizeof (mbstate_t));
if (mbrtowc (&wc, "", 1, &state) != 0)
return 1;
}
return 0;
}],
[gl_cv_func_mbrtowc_nul_retval=yes],
[gl_cv_func_mbrtowc_nul_retval=no],
[])
fi
])
])
# Prerequisites of lib/mbrtowc.c.
AC_DEFUN([gl_PREREQ_MBRTOWC], [
:
])
dnl From Paul Eggert
dnl This override of an autoconf macro can be removed when autoconf 2.60 or
dnl newer can be assumed everywhere.
m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.60]),[-1],[
AC_DEFUN([AC_FUNC_MBRTOWC],
[
dnl Same as AC_FUNC_MBRTOWC in autoconf-2.60.
AC_CACHE_CHECK([whether mbrtowc and mbstate_t are properly declared],
gl_cv_func_mbrtowc,
[AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
[[#include <wchar.h>]],
[[wchar_t wc;
char const s[] = "";
size_t n = 1;
mbstate_t state;
return ! (sizeof state && (mbrtowc) (&wc, s, n, &state));]])],
gl_cv_func_mbrtowc=yes,
gl_cv_func_mbrtowc=no)])
if test $gl_cv_func_mbrtowc = yes; then
AC_DEFINE([HAVE_MBRTOWC], 1,
[Define to 1 if mbrtowc and mbstate_t are properly declared.])
fi
])
])

30
m4/mbsinit.m4 Normal file
View file

@ -0,0 +1,30 @@
# mbsinit.m4 serial 3
dnl Copyright (C) 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_FUNC_MBSINIT],
[
AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
AC_REQUIRE([AC_TYPE_MBSTATE_T])
gl_MBSTATE_T_BROKEN
if test $REPLACE_MBSTATE_T = 1; then
REPLACE_MBSINIT=1
fi
AC_CHECK_FUNCS_ONCE([mbsinit])
if test $ac_cv_func_mbsinit = no; then
HAVE_MBSINIT=0
fi
if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then
gl_REPLACE_WCHAR_H
AC_LIBOBJ([mbsinit])
gl_PREREQ_MBSINIT
fi
])
# Prerequisites of lib/mbsinit.c.
AC_DEFUN([gl_PREREQ_MBSINIT], [
:
])

10
m4/mbstate_t.m4
View file

@ -1,4 +1,4 @@
# mbstate_t.m4 serial 10
# mbstate_t.m4 serial 11
dnl Copyright (C) 2000-2002, 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@ -13,7 +13,10 @@ dnl with or without modifications, as long as this notice is preserved.
# AC_TYPE_MBSTATE_T
# -----------------
AC_DEFUN([AC_TYPE_MBSTATE_T],
[AC_CACHE_CHECK([for mbstate_t], ac_cv_type_mbstate_t,
[
AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) dnl for HP-UX 11.11
AC_CACHE_CHECK([for mbstate_t], ac_cv_type_mbstate_t,
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[AC_INCLUDES_DEFAULT[
@ -27,4 +30,5 @@ AC_DEFUN([AC_TYPE_MBSTATE_T],
else
AC_DEFINE([mbstate_t], int,
[Define to a type if <wchar.h> does not define.])
fi])
fi
])

34
m4/wchar.m4
View file

@ -7,7 +7,7 @@ dnl with or without modifications, as long as this notice is preserved.
dnl Written by Eric Blake.
# wchar.m4 serial 6
# wchar.m4 serial 22
AC_DEFUN([gl_WCHAR_H],
[
@ -61,9 +61,39 @@ AC_DEFUN([gl_WCHAR_MODULE_INDICATOR],
AC_DEFUN([gl_WCHAR_H_DEFAULTS],
[
GNULIB_WCWIDTH=0; AC_SUBST([GNULIB_WCWIDTH])
GNULIB_BTOWC=0; AC_SUBST([GNULIB_BTOWC])
GNULIB_WCTOB=0; AC_SUBST([GNULIB_WCTOB])
GNULIB_MBSINIT=0; AC_SUBST([GNULIB_MBSINIT])
GNULIB_MBRTOWC=0; AC_SUBST([GNULIB_MBRTOWC])
GNULIB_MBRLEN=0; AC_SUBST([GNULIB_MBRLEN])
GNULIB_MBSRTOWCS=0; AC_SUBST([GNULIB_MBSRTOWCS])
GNULIB_MBSNRTOWCS=0; AC_SUBST([GNULIB_MBSNRTOWCS])
GNULIB_WCRTOMB=0; AC_SUBST([GNULIB_WCRTOMB])
GNULIB_WCSRTOMBS=0; AC_SUBST([GNULIB_WCSRTOMBS])
GNULIB_WCSNRTOMBS=0; AC_SUBST([GNULIB_WCSNRTOMBS])
GNULIB_WCWIDTH=0; AC_SUBST([GNULIB_WCWIDTH])
dnl Assume proper GNU behavior unless another module says otherwise.
HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC])
HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT])
HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC])
HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN])
HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS])
HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS])
HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB])
HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS])
HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS])
HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB])
HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH])
REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T])
REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC])
REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB])
REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT])
REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC])
REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN])
REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS])
REPLACE_MBSNRTOWCS=0;AC_SUBST([REPLACE_MBSNRTOWCS])
REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB])
REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS])
REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH])
WCHAR_H=''; AC_SUBST([WCHAR_H])
])

10
m4/wint_t.m4
View file

@ -1,5 +1,5 @@
# wint_t.m4 serial 2 (gettext-0.17)
dnl Copyright (C) 2003, 2007 Free Software Foundation, Inc.
# wint_t.m4 serial 3 (gettext-0.18)
dnl Copyright (C) 2003, 2007-2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@ -10,7 +10,7 @@ dnl Prerequisite: AC_PROG_CC
AC_DEFUN([gt_TYPE_WINT_T],
[
AC_CACHE_CHECK([for wint_t], gt_cv_c_wint_t,
AC_CACHE_CHECK([for wint_t], [gt_cv_c_wint_t],
[AC_TRY_COMPILE([
/* Tru64 with Desktop Toolkit C has a bug: <stdio.h> must be included before
<wchar.h>.
@ -21,8 +21,8 @@ AC_DEFUN([gt_TYPE_WINT_T],
#include <time.h>
#include <wchar.h>
wint_t foo = (wchar_t)'\0';], ,
gt_cv_c_wint_t=yes, gt_cv_c_wint_t=no)])
[gt_cv_c_wint_t=yes], [gt_cv_c_wint_t=no])])
if test $gt_cv_c_wint_t = yes; then
AC_DEFINE(HAVE_WINT_T, 1, [Define if you have the 'wint_t' type.])
AC_DEFINE([HAVE_WINT_T], 1, [Define if you have the 'wint_t' type.])
fi
])

6
srfi/srfi-19.scm
View file

@ -937,10 +937,10 @@
(else (loop (+ index 1))))))
(define (priv:locale-abbr-weekday->index string)
(priv:date-reverse-lookup string priv:locale-abbr-weekday 7 string=?))
(priv:date-reverse-lookup string locale-day-short 7 string=?))
(define (priv:locale-long-weekday->index string)
(priv:date-reverse-lookup string priv:locale-long-weekday 7 string=?))
(priv:date-reverse-lookup string locale-day 7 string=?))
(define (priv:locale-abbr-month->index string)
(priv:date-reverse-lookup string priv:locale-abbr-month 12 string=?))
@ -1406,7 +1406,7 @@
(define (priv:string->date date index format-string str-len port template-string)
(define (skip-until port skipper)
(let ((ch (peek-char port)))
(if (eof-object? port)
(if (eof-object? ch)
(priv:time-error 'string->date 'bad-date-format-string template-string)
(if (not (skipper ch))
(begin (read-char port) (skip-until port skipper))))))

1
test-suite/standalone/.gitignore vendored
View file

@ -8,3 +8,4 @@
/test-use-srfi
/test-scm-with-guile
/test-scm-c-read
/test-fast-slot-ref

4
test-suite/standalone/Makefile.am
View file

@ -103,6 +103,10 @@ test_conversion_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-conversion
TESTS += test-conversion
# test-fast-slot-ref
check_SCRIPTS += test-fast-slot-ref
TESTS += test-fast-slot-ref
# test-use-srfi
check_SCRIPTS += test-use-srfi
TESTS += test-use-srfi

39
test-suite/standalone/test-fast-slot-ref.in Normal file
View file

@ -0,0 +1,39 @@
#!/bin/sh
# Copyright (C) 2006 Free Software Foundation, Inc.
#
# This library is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 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
# Test for %fast-slot-ref, which was previously implemented such that
# an out-of-range slot index could escape being properly detected, and
# could then cause a segmentation fault.
#
# Prior to the change in this commit to goops.c, the following
# sequence reliably causes a segmentation fault on my GNU/Linux when
# executing the (%fast-slot-ref i 3) line. For reasons as yet
# unknown, it does not cause a segmentation fault if the same code is
# loaded as a script; that is why we run it here using "guile -q <<EOF".
exec guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm >/dev/null 2>&1 <<EOF
(use-modules (oop goops))
(define-module (oop goops))
(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3))
(define i (make <c>))
(%fast-slot-ref i 1)
(%fast-slot-ref i 0)
(%fast-slot-ref i 3)
(%fast-slot-ref i -1)
(%fast-slot-ref i 2)
(exit 0)
EOF

10
test-suite/tests/srfi-19.test
View file

@ -1,7 +1,7 @@
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@ -166,6 +166,14 @@ incomplete numerical tower implementation.)"
0)))
(date->time-utc
(make-date 0 0 0 0 9 12 2006 0))))
(pass-if "string->date works on Sunday"
;; `string->date' never rests!
(let* ((str "Sun, 05 Jun 2005 18:33:00 +0200")
(date (string->date str "~a, ~d ~b ~Y ~H:~M:~S ~z")))
(equal? "Sun Jun 05 18:33:00+0200 2005"
(date->string date))))
;; check time comparison procedures
(let* ((time1 (make-time time-monotonic 0 0))
(time2 (make-time time-monotonic 0 0))

3
test-suite/tests/syncase.test
View file

@ -34,3 +34,6 @@
(pass-if "basic syncase macro"
(= (plus 1 2 3) (+ 1 2 3)))
(pass-if "@ works with syncase"
(eq? run-test (@ (test-suite lib) run-test)))