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

Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp

Browse source
This commit is contained in:
Daniel Kraft 2009-08-27 19:26:04 +02:00
commit ff81007918
234 changed files with 27595 additions and 14913 deletions
Download patch file Download diff file Expand all files Collapse all files

11
.gitignore vendored
View file

@ -12,7 +12,6 @@ config.guess
config.status
config.log
config.h
guile-readline-config.h
*.doc
*.x
*.lo
@ -65,11 +64,10 @@ pre-inst-guile-env
stamp-h1
guile-procedures.txt
guile-config/guile-config
guile-readline/guile-readline-config.h
guile-readline/guile-readline-config.h.in
*.go
TAGS
guile-1.8.pc
/meta/guile-2.0.pc
/meta/guile-2.0-uninstalled.pc
gdb-pre-inst-guile
cscope.out
cscope.files
@ -108,3 +106,8 @@ INSTALL
/lib/time.h
/lib/unistd.h
/lib/unistr/.dirstamp
/GPATH
/GRTAGS
/GSYMS
/GTAGS
/meta/guile-tools

2
GUILE-VERSION
View file

@ -2,7 +2,7 @@
GUILE_MAJOR_VERSION=1
GUILE_MINOR_VERSION=9
GUILE_MICRO_VERSION=1
GUILE_MICRO_VERSION=2
GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}
GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}

3
Makefile.am
View file

@ -42,6 +42,9 @@ DISTCLEANFILES = check-guile.log
dist-hook: gen-ChangeLog
clean-local:
rm -rf cache/
gen_start_rev = 61db429e251bfd2f75cb4632972e0238056eb24b
.PHONY: gen-ChangeLog
gen-ChangeLog:

158
NEWS
View file

@ -8,89 +8,31 @@ Please send Guile bug reports to bug-guile@gnu.org.
(During the 1.9 series, we will keep an incremental NEWS for the latest
prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
Changes in 1.9.2 (since the 1.9.1 prerelease):
Changes in 1.9.3 (since the 1.9.2 prerelease):
** Global variables `scm_charnames' and `scm_charnums' are removed.
** Removed deprecated uniform array procedures: scm_make_uve,
scm_array_prototype, scm_list_to_uniform_array,
scm_dimensions_to_uniform_array, scm_make_ra, scm_shap2ra, scm_cvref,
scm_ra_set_contp, scm_aind, scm_raprin1
These variables contained the names of control characters and were
used when writing characters. While these were global, they were
never intended to be public API. They have been replaced with private
functions.
These functions have been deprecated since early 2005.
** EBCDIC support is removed.
** scm_array_p has one argument, not two
There was an EBCDIC compile flag that altered some of the character
processing. It appeared that full EBCDIC support was never completed
and was unmaintained.
Use of the second argument produced a deprecation warning, so it is
unlikely that any code out there actually used this functionality.
Changes in 1.9.1 (since the 1.9.0 prerelease):
** Removed deprecated uniform array procedures:
dimensions->uniform-array, list->uniform-array, array-prototype
** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type
Previously they would use the `off_t' type, which is fragile since its
definition depends on the application's value for `_FILE_OFFSET_BITS'.
** Automatically compiled files will be placed in ~/.cache, not ~/.guile-ccache.
Actually, they will be placed in $XDG_CACHE_HOME/guile/ccache/1.9,
defaulting to XDG_CACHE_HOME=~/.cache. Users may remove their
~/.guile-ccache directories.
** New language: Brainfuck.
Brainfuck is a toy language that closely models Turing machines. Guile's
brainfuck compiler is meant to be an example of implementing other
languages. See the manual for details, or
http://en.wikipedia.org/wiki/Brainfuck for more information about the
Brainfuck language itself.
** A number of Scheme files were corrected to be LGPLv3+.
Some Scheme files imported for the compiler were erroneously labeled as
being LGPLv2+ or GPLv2+. This oversight has been fixed.
** Bytevectors may now be accessed with a C-friendly API.
New functions: `scm_is_bytevector ()', `scm_c_bytevector_length ()',
`scm_c_bytevector_length ()', and `scm_c_bytevector_set_x ()'. See the
manual for details.
** Bytevectors are now accessible using the generalized-vector API.
As a side effect, this change allows compilation of literal bytevectors
(`#vu8(...)').
** Meta-commands to the REPL work better with strange languages.
Specifically, meta-commands that take expressions as arguments will use
the current language's reader to read those expressions, which may span
multiple lines, with readline integration if the user has that enabled.
** The object code file format has changed.
The objcode loader will complain about a "bad header cookie" if it
happens to find an old file. The workaround for that is currently to
find all stale .go files and remove them. This is likely to affect users
who have checked out Guile's git repository, not those that build from
tarballs.
** Vector access has been sped up considerably.
Guile's virtual machine now has vector and bytevector operations. Using
Guile to process large amounts of data is now easier. This is because
`vector-ref' and `vector-set!' now have fast opcodes. In addition, there
are opcodes for `ref' and `set' operations on bytevectors for everything
from 8-bit integers to 64-bit floating-point values.
In the next release, we hope to extend this speedup to other kinds of
uniform vectors.
** The `long_long' C type, deprecated in 1.8, has been removed.
** And of course, the usual collection of bugfixes.
Instead, use make-typed-array, list->typed-array, or array-type,
respectively.
** And of course, the usual collection of bugfixes
Interested users should see the ChangeLog for more information.
Changes in 1.9.x (since the 1.8.x series):
* New modules (see the manual for details)
@ -538,6 +480,35 @@ This decision may be revisited before the 2.0 release. Feedback welcome
to guile-devel@gnu.org (subscription required) or bug-guile@gnu.org (no
subscription required).
** Unicode characters
Unicode characters may be entered in octal format via e.g. `#\454', or
created via (integer->char 300). A hex external representation will
probably be introduced at some point.
** Unicode strings
Internally, strings are now represented either in the `latin-1'
encoding, one byte per character, or in UTF-32, with four bytes per
character. Strings manage their own allocation, switching if needed.
Currently no locale conversion is performed. Extended characters may be
written in a string using the hexadecimal escapes `\xXX', `\uXXXX', or
`\UXXXXXX', for 8-bit, 16-bit, or 24-bit codepoints, respectively.
** Global variables `scm_charnames' and `scm_charnums' are removed
These variables contained the names of control characters and were
used when writing characters. While these were global, they were
never intended to be public API. They have been replaced with private
functions.
** EBCDIC support is removed
There was an EBCDIC compile flag that altered some of the character
processing. It appeared that full EBCDIC support was never completed
and was unmaintained.
** New macro type: syncase-macro
XXX Need to decide whether to document this for 2.0, probably should:
@ -571,6 +542,10 @@ These are analogous to %load-path and %load-extensions.
`(make-promise (lambda () foo))' is equivalent to `(delay foo)'.
** `defined?' may accept a module as its second argument
Previously it only accepted internal structures from the evaluator.
** New entry into %guile-build-info: `ccachedir'
** Fix bug in `module-bound?'.
@ -584,6 +559,12 @@ the variable. This was an error, and was fixed.
As syntax-case is available by default, importing `(ice-9 syncase)' has
no effect, and will trigger a deprecation warning.
** Removed deprecated uniform array procedures:
dimensions->uniform-array, list->uniform-array, array-prototype
Instead, use make-typed-array, list->typed-array, or array-type,
respectively.
* Changes to the C interface
** The GH interface (deprecated in version 1.6, 2001) was removed.
@ -612,6 +593,18 @@ definition depends on the application's value for `_FILE_OFFSET_BITS'.
** The `long_long' C type, deprecated in 1.8, has been removed
** Removed deprecated uniform array procedures: scm_make_uve,
scm_array_prototype, scm_list_to_uniform_array,
scm_dimensions_to_uniform_array, scm_make_ra, scm_shap2ra, scm_cvref,
scm_ra_set_contp, scm_aind, scm_raprin1
These functions have been deprecated since early 2005.
** scm_array_p has one argument, not two
Use of the second argument produced a deprecation warning, so it is
unlikely that any code out there actually used this functionality.
* Changes to the distribution
** Guile's license is now LGPLv3+
@ -627,6 +620,11 @@ part of Guile).
guile.m4 has yet to be modified to call pkg-config instead of
guile-config.
** Guile now provides `guile-2.0.pc' instead of `guile-1.8.pc'
Programs that use `pkg-config' to find Guile or one of its Autoconf
macros should now require `guile-2.0' instead of `guile-1.8'.
** New installation directory: $(pkglibdir)/1.9/ccache
If $(libdir) is /usr/lib, for example, Guile will install its .go files
@ -634,10 +632,18 @@ to /usr/lib/guile/1.9/ccache. These files are architecture-specific.
** New dependency: GNU libunistring.
See http://www.gnu.org/software/libunistring/. We hope to merge in
Unicode support in the next prerelease.
See http://www.gnu.org/software/libunistring/, for more information. Our
unicode support uses routines from libunistring.
Changes in 1.8.8 (since 1.8.7)
* Bugs fixed
** Fix possible buffer overruns when parsing numbers
** Avoid clash with system setjmp/longjmp on IA64
Changes in 1.8.7 (since 1.8.6)

5
README
View file

@ -299,9 +299,8 @@ Guile Documentation ==================================================
If you've never used Scheme before, then the Guile Tutorial
(guile-tut.info) is a good starting point. The Guile Reference Manual
(guile.info) is the primary documentation for Guile. The Goops object
system is documented separately (goops.info). A copy of the R5RS
Scheme specification is included too (r5rs.info).
(guile.info) is the primary documentation for Guile. A copy of the
R5RS Scheme specification is included too (r5rs.info).
Info format versions of this documentation are installed as part of
the normal build process. The texinfo sources are under the doc

2
THANKS
View file

@ -3,6 +3,7 @@ Contributors since the last release:
Rob Browning
Ludovic Courtès
Julian Graham
Mike Gran
Stefan Jahn
Neil Jerram
Gregory Marton
@ -69,6 +70,7 @@ For fixes or providing information which led to a fix:
Jeff Long
Marco Maggi
Gregory Marton
Kjetil S. Matheussen
Antoine Mathys
Dan McMahill
Roger Mc Murtrie

69
acinclude.m4
View file

@ -1,3 +1,5 @@
dnl -*- Autoconf -*-
dnl On the NeXT, #including <utime.h> doesn't give you a definition for
dnl struct utime, unless you #define _POSIX_SOURCE.
@ -308,3 +310,70 @@ else
fi
AC_LANG_RESTORE
])dnl ACX_PTHREAD
dnl GUILE_READLINE
dnl
dnl Check all the things needed by `guile-readline', the Readline
dnl bindings.
AC_DEFUN([GUILE_READLINE], [
for termlib in ncurses curses termcap terminfo termlib ; do
AC_CHECK_LIB(${termlib}, [tgoto],
[READLINE_LIBS="-l${termlib} $READLINE_LIBS"; break])
done
AC_LIB_LINKFLAGS([readline])
if test "x$LTLIBREADLINE" = "x"; then
AC_MSG_WARN([GNU Readline was not found on your system.])
else
rl_save_LIBS="$LIBS"
LIBS="$LIBREADLINE $READLINE_LIBS $LIBS"
AC_CHECK_FUNCS([siginterrupt rl_clear_signals rl_cleanup_after_signal])
dnl Check for modern readline naming
AC_CHECK_FUNCS([rl_filename_completion_function])
dnl Check for rl_get_keymap. We only use this for deciding whether to
dnl install paren matching on the Guile command line (when using
dnl readline for input), so it's completely optional.
AC_CHECK_FUNCS([rl_get_keymap])
AC_CACHE_CHECK([for rl_getc_function pointer in readline],
ac_cv_var_rl_getc_function,
[AC_TRY_LINK([
#include <stdio.h>
#include <readline/readline.h>],
[printf ("%ld", (long) rl_getc_function)],
[ac_cv_var_rl_getc_function=yes],
[ac_cv_var_rl_getc_function=no])])
if test "${ac_cv_var_rl_getc_function}" = "yes"; then
AC_DEFINE([HAVE_RL_GETC_FUNCTION], 1,
[Define if your readline library has the rl_getc_function variable.])
fi
if test $ac_cv_var_rl_getc_function = no; then
AC_MSG_WARN([*** GNU Readline is too old on your system.])
AC_MSG_WARN([*** You need readline version 2.1 or later.])
LTLIBREADLINE=""
LIBREADLINE=""
fi
LIBS="$rl_save_LIBS"
READLINE_LIBS="$LTLIBREADLINE $READLINE_LIBS"
fi
AM_CONDITIONAL([HAVE_READLINE], [test "x$LTLIBREADLINE" != "x"])
AC_CHECK_FUNCS([strdup])
AC_SUBST([READLINE_LIBS])
. $srcdir/guile-readline/LIBGUILEREADLINE-VERSION
AC_SUBST(LIBGUILEREADLINE_MAJOR)
AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
AC_SUBST(LIBGUILEREADLINE_INTERFACE)
])

57
benchmark-suite/benchmarks/chars.bm Normal file
View file

@ -0,0 +1,57 @@
;;; -*- mode: scheme; coding: latin-1; -*-
;;; chars.bm
;;;
;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 3, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this software; see the file COPYING.LESSER. If
;;; not, write to the Free Software Foundation, Inc., 51 Franklin
;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmarks chars)
:use-module (benchmark-suite lib))
(with-benchmark-prefix "chars"
(benchmark "char" 1000000
#\a)
(benchmark "octal" 1000000
#\123)
(benchmark "char? eq" 1000000
(char? #\a))
(benchmark "char=?" 1000000
(char=? #\a #\a))
(benchmark "char<?" 1000000
(char=? #\a #\a))
(benchmark "char-ci=?" 1000000
(char=? #\a #\a))
(benchmark "char-ci<? " 1000000
(char=? #\a #\a))
(benchmark "char->integer" 1000000
(char->integer #\a))
(benchmark "char-alphabetic?" 1000000
(char-upcase #\a))
(benchmark "char-numeric?" 1000000
(char-upcase #\a)))

310
benchmark-suite/benchmarks/srfi-13.bm Normal file
View file

@ -0,0 +1,310 @@
;;; -*- mode: scheme; coding: latin-1; -*-
;;; srfi-13.bm
;;;
;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 3, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this software; see the file COPYING.LESSER. If
;;; not, write to the Free Software Foundation, Inc., 51 Franklin
;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmarks strings)
:use-module (benchmark-suite lib))
(seed->random-state 1)
(define short-string "Hi")
(define medium-string
"ARMA virumque cano, Troiae qui primus ab oris
Italiam, fato profugus, Laviniaque venit")
(define long-string
(string-tabulate
(lambda (n) (integer->char (+ 32 (random 90))))
1000))
(define short-chlist (string->list short-string))
(define medium-chlist (string->list medium-string))
(define long-chlist (string->list long-string))
(define str1 (string-copy short-string))
(define str2 (string-copy medium-string))
(define str3 (string-copy long-string))
(with-benchmark-prefix "strings"
(with-benchmark-prefix "predicates"
(benchmark "string?" 1190000
(string? short-string)
(string? medium-string)
(string? long-string))
(benchmark "null?" 969000
(string-null? short-string)
(string-null? medium-string)
(string-null? long-string))
(benchmark "any" 94000
(string-any #\a short-string)
(string-any #\a medium-string)
(string-any #\a long-string))
(benchmark "every" 94000
(string-every #\a short-string)
(string-every #\a medium-string)
(string-every #\a long-string)))
(with-benchmark-prefix "constructors"
(benchmark "string" 5000
(apply string short-chlist)
(apply string medium-chlist)
(apply string long-chlist))
(benchmark "list->" 4500
(list->string short-chlist)
(list->string medium-chlist)
(list->string long-chlist))
(benchmark "reverse-list->" 5000
(reverse-list->string short-chlist)
(reverse-list->string medium-chlist)
(reverse-list->string long-chlist))
(benchmark "make" 22000
(make-string 250 #\x))
(benchmark "tabulate" 17000
(string-tabulate integer->char 250))
(benchmark "join" 5500
(string-join (list short-string medium-string long-string) "|" 'suffix)))
(with-benchmark-prefix "list/string"
(benchmark "->list" 7300
(string->list short-string)
(string->list medium-string)
(string->list long-string))
(benchmark "split" 60000
(string-split short-string #\a)
(string-split medium-string #\a)
(string-split long-string #\a)))
(with-benchmark-prefix "selection"
(benchmark "ref" 660
(let loop ((k 0))
(if (< k (string-length short-string))
(begin
(string-ref short-string k)
(loop (+ k 1)))))
(let loop ((k 0))
(if (< k (string-length medium-string))
(begin
(string-ref medium-string k)
(loop (+ k 1)))))
(let loop ((k 0))
(if (< k (string-length long-string))
(begin
(string-ref long-string k)
(loop (+ k 1))))))
(benchmark "copy" 1100
(string-copy short-string)
(string-copy medium-string)
(string-copy long-string)
(substring/copy short-string 0 1)
(substring/copy medium-string 10 20)
(substring/copy long-string 100 200))
(benchmark "pad" 6800
(string-pad short-string 100)
(string-pad medium-string 100)
(string-pad long-string 100))
(benchmark "trim trim-right trim-both" 60000
(string-trim short-string char-alphabetic?)
(string-trim medium-string char-alphabetic?)
(string-trim long-string char-alphabetic?)
(string-trim-right short-string char-alphabetic?)
(string-trim-right medium-string char-alphabetic?)
(string-trim-right long-string char-alphabetic?)
(string-trim-both short-string char-alphabetic?)
(string-trim-both medium-string char-alphabetic?)
(string-trim-both long-string char-alphabetic?)))
(with-benchmark-prefix "modification"
(set! str1 (string-copy short-string))
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
(benchmark "set!" 3000
(let loop ((k 1))
(if (< k (string-length short-string))
(begin
(string-set! str1 k #\x)
(loop (+ k 1)))))
(let loop ((k 20))
(if (< k (string-length medium-string))
(begin
(string-set! str2 k #\x)
(loop (+ k 1)))))
(let loop ((k 900))
(if (< k (string-length long-string))
(begin
(string-set! str3 k #\x)
(loop (+ k 1))))))
(set! str1 (string-copy short-string))
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
(benchmark "sub-move!" 230000
(substring-move! short-string 0 2 str2 10)
(substring-move! medium-string 10 20 str3 20))
(set! str1 (string-copy short-string))
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
(benchmark "fill!" 230000
(string-fill! str1 #\y 0 1)
(string-fill! str2 #\y 10 20)
(string-fill! str3 #\y 20 30))
(with-benchmark-prefix "comparison"
(benchmark "compare compare-ci" 140000
(string-compare short-string medium-string string<? string=? string>?)
(string-compare long-string medium-string string<? string=? string>?)
(string-compare-ci short-string medium-string string<? string=? string>?)
(string-compare-ci long-string medium-string string<? string=? string>?))
(benchmark "hash hash-ci" 1000
(string-hash short-string)
(string-hash medium-string)
(string-hash long-string)
(string-hash-ci short-string)
(string-hash-ci medium-string)
(string-hash-ci long-string))))
(with-benchmark-prefix "searching" 20000
(benchmark "prefix-length suffix-length" 270
(string-prefix-length short-string
(string-append short-string medium-string))
(string-prefix-length long-string
(string-append long-string medium-string))
(string-suffix-length short-string
(string-append medium-string short-string))
(string-suffix-length long-string
(string-append medium-string long-string))
(string-prefix-length-ci short-string
(string-append short-string medium-string))
(string-prefix-length-ci long-string
(string-append long-string medium-string))
(string-suffix-length-ci short-string
(string-append medium-string short-string))
(string-suffix-length-ci long-string
(string-append medium-string long-string)))
(benchmark "prefix? suffix?" 270
(string-prefix? short-string
(string-append short-string medium-string))
(string-prefix? long-string
(string-append long-string medium-string))
(string-suffix? short-string
(string-append medium-string short-string))
(string-suffix? long-string
(string-append medium-string long-string))
(string-prefix-ci? short-string
(string-append short-string medium-string))
(string-prefix-ci? long-string
(string-append long-string medium-string))
(string-suffix-ci? short-string
(string-append medium-string short-string))
(string-suffix-ci? long-string
(string-append medium-string long-string)))
(benchmark "index index-right rindex" 100000
(string-index short-string #\T)
(string-index medium-string #\T)
(string-index long-string #\T)
(string-index-right short-string #\T)
(string-index-right medium-string #\T)
(string-index-right long-string #\T)
(string-rindex short-string #\T)
(string-rindex medium-string #\T)
(string-rindex long-string #\T))
(benchmark "skip skip-right?" 100000
(string-skip short-string char-alphabetic?)
(string-skip medium-string char-alphabetic?)
(string-skip long-string char-alphabetic?)
(string-skip-right short-string char-alphabetic?)
(string-skip-right medium-string char-alphabetic?)
(string-skip-right long-string char-alphabetic?))
(benchmark "count" 10000
(string-count short-string char-alphabetic?)
(string-count medium-string char-alphabetic?)
(string-count long-string char-alphabetic?))
(benchmark "contains contains-ci" 34000
(string-contains short-string short-string)
(string-contains medium-string (substring medium-string 10 15))
(string-contains long-string (substring long-string 100 130))
(string-contains-ci short-string short-string)
(string-contains-ci medium-string (substring medium-string 10 15))
(string-contains-ci long-string (substring long-string 100 130)))
(set! str1 (string-copy short-string))
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
(benchmark "upcase downcase upcase! downcase!" 600
(string-upcase short-string)
(string-upcase medium-string)
(string-upcase long-string)
(string-downcase short-string)
(string-downcase medium-string)
(string-downcase long-string)
(string-upcase! str1 0 1)
(string-upcase! str2 10 20)
(string-upcase! str3 100 130)
(string-downcase! str1 0 1)
(string-downcase! str2 10 20)
(string-downcase! str3 100 130)))
(with-benchmark-prefix "readers"
(benchmark "read token, method 1" 1200
(let ((buf (make-string 512)))
(let loop ((i 0))
(if (< i 512)
(begin
(string-set! buf i #\x)
(loop (+ i 1)))
buf))))
(benchmark "read token, method 2" 1200
(let ((lst '()))
(let loop ((i 0))
(set! lst (append! lst (list #\x)))
(if (< i 512)
(loop (+ i 1))
(list->string lst)))))))

2
check-guile.in
View file

@ -41,7 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
fi
exec $guile \
-e main -s "$TEST_SUITE_DIR/guile-test" \
--no-autocompile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"

38
configure.in → configure.ac
View file

@ -51,14 +51,6 @@ AC_CONFIG_SRCDIR([GUILE-VERSION])
AC_CONFIG_HEADERS([config.h])
AH_TOP(/*GUILE_CONFIGURE_COPYRIGHT*/)
#--------------------------------------------------------------------
#
# Independent Subdirectories
#
#--------------------------------------------------------------------
AC_CONFIG_SUBDIRS(guile-readline)
#--------------------------------------------------------------------
AC_LANG([C])
@ -827,22 +819,13 @@ fi
dnl GMP tests
AC_LIB_LINKFLAGS(gmp)
AC_CHECK_LIB([gmp], [__gmpz_init], ,
[AC_MSG_ERROR([GNU MP not found, see README])])
# mpz_import is a macro so we need to include <gmp.h>
AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
[[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])],
AC_LIB_HAVE_LINKFLAGS(gmp,
[],
[AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])])
[#include <gmp.h>],
[mpz_import (0, 0, 0, 0, 0, 0, 0);],
AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
dnl GNU libunistring tests.
if test "x$LTLIBUNISTRING" != "x"; then
LIBS="$LTLIBUNISTRING $LIBS"
else
AC_MSG_ERROR([GNU libunistring is required, please install it.])
fi
dnl GNU libunistring is checked for by Gnulib's `libunistring' module.
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
@ -1446,6 +1429,9 @@ LIBLOBJS="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.lo ,g;s,\.[[^.]]*$,.lo,'`"
EXTRA_DOT_DOC_FILES="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.doc ,g;s,\.[[^.]]*$,.doc,'`"
EXTRA_DOT_X_FILES="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.x ,g;s,\.[[^.]]*$,.x,'`"
# GNU Readline bindings.
GUILE_READLINE
AC_SUBST(GUILE_MAJOR_VERSION)
AC_SUBST(GUILE_MINOR_VERSION)
AC_SUBST(GUILE_MICRO_VERSION)
@ -1532,7 +1518,6 @@ AC_CONFIG_FILES([
lib/Makefile
benchmark-suite/Makefile
doc/Makefile
doc/goops/Makefile
doc/r5rs/Makefile
doc/ref/Makefile
doc/tutorial/Makefile
@ -1541,6 +1526,7 @@ AC_CONFIG_FILES([
lang/Makefile
libguile/Makefile
srfi/Makefile
guile-readline/Makefile
test-suite/Makefile
test-suite/standalone/Makefile
meta/Makefile
@ -1548,13 +1534,14 @@ AC_CONFIG_FILES([
testsuite/Makefile
])
AC_CONFIG_FILES([meta/guile-1.8.pc])
AC_CONFIG_FILES([meta/guile-1.8-uninstalled.pc])
AC_CONFIG_FILES([meta/guile-2.0.pc])
AC_CONFIG_FILES([meta/guile-2.0-uninstalled.pc])
AC_CONFIG_FILES([check-guile], [chmod +x check-guile])
AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile])
AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile])
AC_CONFIG_FILES([meta/uninstalled-env], [chmod +x meta/uninstalled-env])
AC_CONFIG_FILES([meta/gdb-uninstalled-guile], [chmod +x meta/gdb-uninstalled-guile])
AC_CONFIG_FILES([meta/guile-tools], [chmod +x meta/guile-tools])
AC_CONFIG_FILES([libguile/guile-snarf],
[chmod +x libguile/guile-snarf])
AC_CONFIG_FILES([libguile/guile-doc-snarf],
@ -1567,6 +1554,7 @@ 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_CONFIG_FILES([doc/ref/effective-version.texi])
AC_OUTPUT

2
doc/Makefile.am
View file

@ -21,7 +21,7 @@
AUTOMAKE_OPTIONS = gnu
SUBDIRS = ref tutorial goops r5rs
SUBDIRS = ref tutorial r5rs
dist_man1_MANS = guile.1

4
doc/README
View file

@ -8,10 +8,6 @@ The documentation consists of the following manuals.
- The Guile Reference Manual (guile.texi) contains (or is intended to
contain) reference documentation on all aspects of Guile.
- The GOOPS Manual (goops.texi) contains both tutorial-style and
reference documentation for using GOOPS, Guile's Object Oriented
Programming System.
- The Revised^5 Report on the Algorithmic Language Scheme (r5rs.texi).
Please be aware that this is all very much work in progress (apart

29
doc/goops/Makefile.am
View file

@ -1,29 +0,0 @@
## Process this file with Automake to create Makefile.in
##
## Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify it
## under the terms of the GNU Lesser General Public License as
## published by the Free Software Foundation; either version 3, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU Lesser General Public License for more details.
##
## You should have received a copy of the GNU Lesser General Public
## License along with GUILE; see the file COPYING.LESSER. If not,
## write to the Free Software Foundation, Inc., 51 Franklin Street,
## Fifth Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
info_TEXINFOS = goops.texi
goops_TEXINFOS = goops-tutorial.texi \
hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf
EXTRA_DIST = ChangeLog-2008

1
doc/ref/.gitignore vendored
View file

@ -1,2 +1,3 @@
autoconf-macros.texi
lib-version.texi
effective-version.texi

0
doc/goops/ChangeLog-2008 → doc/ref/ChangeLog-goops-2008
View file

13
doc/ref/Makefile.am
View file

@ -78,11 +78,20 @@ guile_TEXINFOS = preface.texi \
libguile-linking.texi \
libguile-extensions.texi \
api-init.texi \
mod-getopt-long.texi
mod-getopt-long.texi \
goops.texi \
goops-tutorial.texi \
effective-version.texi
ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS)
EXTRA_DIST = ChangeLog-2008
PICTURES = hierarchy.eps \
hierarchy.pdf \
hierarchy.png \
hierarchy.txt \
mop.text
EXTRA_DIST = ChangeLog-2008 $(PICTURES)
include $(top_srcdir)/am/pre-inst-guile

16
doc/ref/api-binding.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -271,10 +271,16 @@ with duplicate bindings.
Guile provides a procedure for checking whether a symbol is bound in the
top level environment.
@c NJFIXME explain [env]
@deffn {Scheme Procedure} defined? sym [env]
@deffnx {C Function} scm_defined_p (sym, env)
Return @code{#t} if @var{sym} is defined in the lexical environment @var{env}. When @var{env} is not specified, look in the top-level environment as defined by the current module.
@deffn {Scheme Procedure} defined? sym [module]
@deffnx {C Function} scm_defined_p (sym, module)
Return @code{#t} if @var{sym} is defined in the module @var{module} or
the current module when @var{module} is not specified; otherwise return
@code{#f}.
Up to Guile 1.8, the second optional argument had to be @dfn{lexical
environment} as returned by @code{the-environment}, for example. The
behavior of this function remains unchanged when the second argument is
omitted.
@end deffn

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

@ -1344,9 +1344,9 @@ otherwise.
@deftypefn {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s8vector (const scm_t_int8 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s168vector (const scm_t_int16 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s16vector (const scm_t_int16 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s328vector (const scm_t_int32 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s32vector (const scm_t_int32 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s64vector (const scm_t_int64 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_f32vector (const float *data, size_t len)
@ -2001,13 +2001,24 @@ enclosed array is unspecified.
For example,
@lisp
(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1)
(enclose-array '#3(((a b c)
(d e f))
((1 2 3)
(4 5 6)))
1)
@result{}
#<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>
#<enclosed-array (#1(a d) #1(b e) #1(c f))
(#1(1 4) #1(2 5) #1(3 6))>
(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0)
(enclose-array '#3(((a b c)
(d e f))
((1 2 3)
(4 5 6)))
1 0)
@result{}
#<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>
#<enclosed-array #2((a 1) (d 4))
#2((b 2) (e 5))
#2((c 3) (f 6))>
@end lisp
@end deffn
@ -3083,8 +3094,10 @@ which can be changed.
(color ball)
(owner ball)))
ball-color))
(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
(define (owner ball) (struct-ref ball 0))
(define (color ball)
(struct-ref (struct-vtable ball) vtable-offset-user))
(define (owner ball)
(struct-ref ball 0))
(define red (make-ball-type 'red))
(define green (make-ball-type 'green))
@ -3460,7 +3473,8 @@ whole is not a proper list:
(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame"))
@result{}
ERROR: In procedure assoc in expression (assoc "mary" (quote #)):
ERROR: Wrong type argument in position 2 (expecting association list): ((1 . 2) ("key" . "door") . "open sesame")
ERROR: Wrong type argument in position 2 (expecting
association list): ((1 . 2) ("key" . "door") . "open sesame")
(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame"))
@result{}
@ -3474,7 +3488,8 @@ Secondly, if one of the entries in the specified alist is not a pair:
(assoc 2 '((1 . 1) 2 (3 . 9)))
@result{}
ERROR: In procedure assoc in expression (assoc 2 (quote #)):
ERROR: Wrong type argument in position 2 (expecting association list): ((1 . 1) 2 (3 . 9))
ERROR: Wrong type argument in position 2 (expecting
association list): ((1 . 1) 2 (3 . 9))
(sloppy-assoc 2 '((1 . 1) 2 (3 . 9)))
@result{}

28
doc/ref/api-control.texi
View file

@ -22,6 +22,7 @@ flow of Scheme affects C code.
* Error Reporting:: Procedures for signaling errors.
* Dynamic Wind:: Dealing with non-local entrance/exit.
* Handling Errors:: How to handle errors in C code.
* Continuation Barriers:: Protection from non-local control flow.
@end menu
@node begin
@ -1501,6 +1502,33 @@ which is the name of the procedure incorrectly invoked.
@end deftypefn
@node Continuation Barriers
@subsection Continuation Barriers
The non-local flow of control caused by continuations might sometimes
not be wanted. You can use @code{with-continuation-barrier} etc to
errect fences that continuations can not pass.
@deffn {Scheme Procedure} with-continuation-barrier proc
@deffnx {C Function} scm_with_continuation_barrier (proc)
Call @var{proc} and return its result. Do not allow the invocation of
continuations that would leave or enter the dynamic extent of the call
to @code{with-continuation-barrier}. Such an attempt causes an error
to be signaled.
Throws (such as errors) that are not caught from within @var{proc} are
caught by @code{with-continuation-barrier}. In that case, a short
message is printed to the current error port and @code{#f} is returned.
Thus, @code{with-continuation-barrier} returns exactly once.
@end deffn
@deftypefn {C Function} {void *} scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
Like @code{scm_with_continuation_barrier} but call @var{func} on
@var{data}. When an error is caught, @code{NULL} is returned.
@end deftypefn
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:

25
doc/ref/api-data.texi
View file

@ -3477,9 +3477,9 @@ allocated string.
@deffnx {C Function} scm_string_concatenate_reverse (ls, final_string, end)
Without optional arguments, this procedure is equivalent to
@smalllisp
@lisp
(string-concatenate (reverse ls))
@end smalllisp
@end lisp
If the optional argument @var{final_string} is specified, it is
consed onto the beginning to @var{ls} before performing the
@ -3535,11 +3535,12 @@ For example, to change characters to alternately upper and lower case,
@example
(define str (string-copy "studly"))
(string-for-each-index (lambda (i)
(string-set! str i
((if (even? i) char-upcase char-downcase)
(string-ref str i))))
str)
(string-for-each-index
(lambda (i)
(string-set! str i
((if (even? i) char-upcase char-downcase)
(string-ref str i))))
str)
str @result{} "StUdLy"
@end example
@end deffn
@ -4447,7 +4448,8 @@ Or matching a @sc{yyyymmdd} format date such as @samp{20020828} and
re-ordering and hyphenating the fields.
@lisp
(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
(define date-regex
"([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
(define s "Date 20020429 12am.")
(regexp-substitute #f (string-match date-regex s)
'pre 2 "-" 3 "-" 1 'post " (" 0 ")")
@ -4507,7 +4509,8 @@ example the following is the date example from
@code{string-match} call.
@lisp
(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
(define date-regex
"([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
(define s "Date 20020429 12am.")
(regexp-substitute/global #f date-regex s
'pre 2 "-" 3 "-" 1 'post " (" 0 ")")
@ -5502,7 +5505,7 @@ the @code{read-set!} procedure documented in @ref{User level options
interfaces} and @ref{Reader options}. Note that the @code{prefix} and
@code{postfix} syntax are mutually exclusive.
@smalllisp
@lisp
(read-set! keywords 'prefix)
#:type
@ -5534,7 +5537,7 @@ type:
ERROR: In expression :type:
ERROR: Unbound variable: :type
ABORT: (unbound-variable)
@end smalllisp
@end lisp
@node Keyword Procedures
@subsubsection Keyword Procedures

56
doc/ref/api-debug.texi
View file

@ -283,9 +283,9 @@ runs a script non-interactively.
The following procedures can be used to access and set the source
properties of read expressions.
@deffn {Scheme Procedure} set-source-properties! obj plist
@deffnx {C Function} scm_set_source_properties_x (obj, plist)
Install the association list @var{plist} as the source property
@deffn {Scheme Procedure} set-source-properties! obj alist
@deffnx {C Function} scm_set_source_properties_x (obj, alist)
Install the association list @var{alist} as the source property
list for @var{obj}.
@end deffn
@ -302,12 +302,12 @@ Return the source property association list of @var{obj}.
@deffn {Scheme Procedure} source-property obj key
@deffnx {C Function} scm_source_property (obj, key)
Return the source property specified by @var{key} from
@var{obj}'s source property list.
Return the property specified by @var{key} from @var{obj}'s source
properties.
@end deffn
In practice there are only two ways that you should use the ability to
set an expression's source breakpoints.
set an expression's source properties.
@itemize
@item
@ -330,9 +330,9 @@ involved in a backtrace or error report.
If you are looking for a way to attach arbitrary information to an
expression other than these properties, you should use
@code{make-object-property} instead (@pxref{Object Properties}), because
that will avoid bloating the source property hash table, which is really
only intended for the specific purposes described in this section.
@code{make-object-property} instead (@pxref{Object Properties}). That
will avoid bloating the source property hash table, which is really
only intended for the debugging purposes just described.
@node Decoding Memoized Source Expressions
@ -1732,16 +1732,16 @@ Frame 2 at matrix.scm:8:3
[mkmatrix]
debug> next
Frame 3 at matrix.scm:4:3
(let ((x 1)) (quote this-is-a-matric))
(let ((x 1)) (quote hi!))
debug> info frame
Stack frame: 3
This frame is an evaluation.
The expression being evaluated is:
matrix.scm:4:3:
(let ((x 1)) (quote this-is-a-matric))
(let ((x 1)) (quote hi!))
debug> next
Frame 3 at matrix.scm:5:21
(quote this-is-a-matric)
(quote hi!)
debug> bt
In unknown file:
?: 0* [primitive-eval (do-main 4)]
@ -1750,9 +1750,9 @@ In standard input:
In matrix.scm:
8: 2 [mkmatrix]
...
5: 3 (quote this-is-a-matric)
5: 3 (quote hi!)
debug> quit
this-is-a-matric
hi!
guile>
@end lisp
@ -1813,7 +1813,7 @@ guile> (do-main 4)
| 5: (memq sym bindings)
| 5: [memq let (debug)]
| 5: =>#f
| 2: (letrec ((yy 23)) (let ((x 1)) (quote this-is-a-matric)))
| 2: (letrec ((yy 23)) (let ((x 1)) (quote hi!)))
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 4: (and (memq sym bindings) (let ...))
@ -1832,7 +1832,7 @@ guile> (do-main 4)
| 5: (memq sym bindings)
| 5: [memq let (debug)]
| 5: =>#f
| 2: (let ((x 1)) (quote this-is-a-matric))
| 2: (let ((x 1)) (quote hi!))
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 4: (and (memq sym bindings) (let ...))
@ -1841,15 +1841,15 @@ guile> (do-main 4)
| 5: =>#f
| 2: [let (let # #) (# # #)]
| 2: [let (let # #) (# # #)]
| 2: =>(#@@let* (x 1) #@@let (quote this-is-a-matric))
this-is-a-matric
| 2: =>(#@@let* (x 1) #@@let (quote hi!))
hi!
guile> (do-main 4)
| 2: [mkmatrix]
| 2: (letrec ((yy 23)) (let* ((x 1)) (quote this-is-a-matric)))
| 2: (let* ((x 1)) (quote this-is-a-matric))
| 2: (quote this-is-a-matric)
| 2: =>this-is-a-matric
this-is-a-matric
| 2: (letrec ((yy 23)) (let* ((x 1)) (quote hi!)))
| 2: (let* ((x 1)) (quote hi!))
| 2: (quote hi!)
| 2: =>hi!
hi!
guile>
@end lisp
@ -1881,11 +1881,11 @@ each trace line instead of the stack depth.
guile> (set-trace-layout "|~16@@a: ~a\n" trace/source trace/info)
guile> (do-main 4)
| matrix.scm:7:2: [mkmatrix]
| : (letrec ((yy 23)) (let* ((x 1)) (quote this-is-a-matric)))
| matrix.scm:3:2: (let* ((x 1)) (quote this-is-a-matric))
| matrix.scm:4:4: (quote this-is-a-matric)
| matrix.scm:4:4: =>this-is-a-matric
this-is-a-matric
| : (letrec ((yy 23)) (let* ((x 1)) (quote hi!)))
| matrix.scm:3:2: (let* ((x 1)) (quote hi!))
| matrix.scm:4:4: (quote hi!)
| matrix.scm:4:4: =>hi!
hi!
guile>
@end lisp

16
doc/ref/api-io.texi
View file

@ -424,9 +424,9 @@ the current size, but this is not mandatory in the POSIX standard.
The delimited-I/O module can be accessed with:
@smalllisp
@lisp
(use-modules (ice-9 rdelim))
@end smalllisp
@end lisp
It can be used to read or write lines of text, or read text delimited by
a specified set of characters. It's similar to the @code{(scsh rdelim)}
@ -536,9 +536,9 @@ delimiter may be either a newline or the @var{eof-object}; if
The Block-string-I/O module can be accessed with:
@smalllisp
@lisp
(use-modules (ice-9 rw))
@end smalllisp
@end lisp
It currently contains procedures that help to implement the
@code{(scsh rw)} module in guile-scsh.
@ -795,17 +795,17 @@ current interfaces.
@rnindex open-input-file
@deffn {Scheme Procedure} open-input-file filename
Open @var{filename} for input. Equivalent to
@smalllisp
@lisp
(open-file @var{filename} "r")
@end smalllisp
@end lisp
@end deffn
@rnindex open-output-file
@deffn {Scheme Procedure} open-output-file filename
Open @var{filename} for output. Equivalent to
@smalllisp
@lisp
(open-file @var{filename} "w")
@end smalllisp
@end lisp
@end deffn
@deffn {Scheme Procedure} call-with-input-file filename proc

44
doc/ref/api-modules.texi
View file

@ -60,15 +60,15 @@ Library files in SLIB @emph{provide} a feature, and when user programs
For example, the file @file{random.scm} in the SLIB package contains the
line
@smalllisp
@lisp
(provide 'random)
@end smalllisp
@end lisp
so to use its procedures, a user would type
@smalllisp
@lisp
(require 'random)
@end smalllisp
@end lisp
and they would magically become available, @emph{but still have the same
names!} So this method is nice, but not as good as a full-featured
@ -99,9 +99,9 @@ i.e., passed as the second argument to @code{eval}.
Note: the following two procedures are available only when the
@code{(ice-9 r5rs)} module is loaded:
@smalllisp
@lisp
(use-modules (ice-9 r5rs))
@end smalllisp
@end lisp
@deffn {Scheme Procedure} scheme-report-environment version
@deffnx {Scheme Procedure} null-environment version
@ -224,9 +224,9 @@ An @dfn{interface specification} has one of two forms. The first
variation is simply to name the module, in which case its public
interface is the one accessed. For example:
@smalllisp
@lisp
(use-modules (ice-9 popen))
@end smalllisp
@end lisp
Here, the interface specification is @code{(ice-9 popen)}, and the
result is that the current module now has access to @code{open-pipe},
@ -241,11 +241,11 @@ module to be accessed, but also selects bindings from it and renames
them to suit the current module's needs. For example:
@cindex binding renamer
@smalllisp
@lisp
(use-modules ((ice-9 popen)
:select ((open-pipe . pipe-open) close-pipe)
:renamer (symbol-prefix-proc 'unixy:)))
@end smalllisp
#:select ((open-pipe . pipe-open) close-pipe)
#:renamer (symbol-prefix-proc 'unixy:)))
@end lisp
Here, the interface specification is more complex than before, and the
result is that a custom interface with only two bindings is created and
@ -270,10 +270,10 @@ You can also directly refer to bindings in a module by using the
open-pipe)}. Thus an alternative to the complete @code{use-modules}
statement would be
@smalllisp
@lisp
(define unixy:pipe-open (@@ (ice-9 popen) open-pipe))
(define unixy:close-pipe (@@ (ice-9 popen) close-pipe))
@end smalllisp
@end lisp
There is also @code{@@@@}, which can be used like @code{@@}, but does
not check whether the variable that is being accessed is actually
@ -307,9 +307,9 @@ whose public interface is found and used.
@var{spec} can also be of the form:
@cindex binding renamer
@smalllisp
@lisp
(MODULE-NAME [:select SELECTION] [:renamer RENAMER])
@end smalllisp
@end lisp
in which case a custom interface is newly created and used.
@var{module-name} is a list of symbols, as above; @var{selection} is a
@ -373,9 +373,9 @@ by using @code{define-public} or @code{export} (both documented below).
@var{module-name} is of the form @code{(hierarchy file)}. One
example of this is
@smalllisp
@lisp
(define-module (ice-9 popen))
@end smalllisp
@end lisp
@code{define-module} makes this module available to Guile programs under
the given @var{module-name}.
@ -541,9 +541,9 @@ duplication to the next handler in @var{list}.
The default duplicate binding resolution policy is given by the
@code{default-duplicate-binding-handler} procedure, and is
@smalllisp
@lisp
(replace warn-override-core warn last)
@end smalllisp
@end lisp
@item #:no-backtrace
@cindex no backtrace
@ -1138,12 +1138,12 @@ gcc -shared -o libbessel.so -fPIC bessel.c
Now fire up Guile:
@smalllisp
@lisp
(define bessel-lib (dynamic-link "./libbessel.so"))
(dynamic-call "init_math_bessel" bessel-lib)
(j0 2)
@result{} 0.223890779141236
@end smalllisp
@end lisp
The filename @file{./libbessel.so} should be pointing to the shared
library produced with the @code{gcc} command above, of course. The

15
doc/ref/api-options.texi
View file

@ -82,10 +82,11 @@ general are stored. On Unix-like systems, this is usually
@deffnx {C Function} scm_sys_library_dir ()
Return the name of the directory where the Guile Scheme files that
belong to the core Guile installation (as opposed to files from a 3rd
party package) are installed. On Unix-like systems, this is usually
party package) are installed. On Unix-like systems this is usually
@file{/usr/local/share/guile/<GUILE_EFFECTIVE_VERSION>} or
@file{/usr/share/guile/<GUILE_EFFECTIVE_VERSION>}, for example:
@file{/usr/local/share/guile/1.6}.
@file{/usr/share/guile/<GUILE_EFFECTIVE_VERSION>};
@noindent for example @file{/usr/local/share/guile/1.6}.
@end deffn
@deffn {Scheme Procedure} %site-dir
@ -503,9 +504,9 @@ Guile is case-sensitive by default.
To make Guile case insensitive, you can type
@smalllisp
@lisp
(read-enable 'case-insensitive)
@end smalllisp
@end lisp
@node Printing options
@subsubsection Printing options
@ -680,7 +681,8 @@ the maximum stack size, use @code{debug-set!}, for example:
@lisp
(debug-set! stack 200000)
@result{}
(show-file-name #t stack 200000 debug backtrace depth 20 maxdepth 1000 frames 3 indent 10 width 79 procnames cheap)
(show-file-name #t stack 200000 debug backtrace depth 20
maxdepth 1000 frames 3 indent 10 width 79 procnames cheap)
(non-tail-recursive-factorial 500)
@result{}
@ -717,7 +719,6 @@ backtrace. Need to give a better example, possibly putting debugging
option examples in a separate session.]
@end enumerate
@smalllisp
guile> (define abc "hello")
guile> abc

63
doc/ref/api-scheduling.texi
View file

@ -8,14 +8,9 @@
@node Scheduling
@section Threads, Mutexes, Asyncs and Dynamic Roots
[FIXME: This is pasted in from Tom Lord's original guile.texi chapter
plus the Cygnus programmer's manual; it should be *very* carefully
reviewed and largely reorganized.]
@menu
* Arbiters:: Synchronization primitives.
* Asyncs:: Asynchronous procedure invocation.
* Continuation Barriers:: Protection from non-local control flow.
* Threads:: Multiple threads of execution.
* Mutexes and Condition Variables:: Synchronization primitives.
* Blocking:: How to block properly in guile mode.
@ -47,7 +42,6 @@ process synchronization.
@deffn {Scheme Procedure} try-arbiter arb
@deffnx {C Function} scm_try_arbiter (arb)
@deffnx {C Function} scm_try_arbiter (arb)
If @var{arb} is unlocked, then lock it and return @code{#t}.
If @var{arb} is already locked, then do nothing and return
@code{#f}.
@ -70,7 +64,7 @@ release it, but that's not required, any thread can release it.
@cindex user asyncs
@cindex system asyncs
Asyncs are a means of deferring the excution of Scheme code until it is
Asyncs are a means of deferring the execution of Scheme code until it is
safe to do so.
Guile provides two kinds of asyncs that share the basic concept but are
@ -132,43 +126,42 @@ This procedure is not safe to be called from signal handlers. Use
signal handlers.
@end deffn
@c FIXME: The use of @deffnx for scm_c_call_with_blocked_asyncs and
@c scm_c_call_with_unblocked_asyncs puts "void" into the function
@c index. Would prefer to use @deftypefnx if makeinfo allowed that,
@c or a @deftypefn with an empty return type argument if it didn't
@c introduce an extra space.
@deffn {Scheme Procedure} call-with-blocked-asyncs proc
@deffnx {C Function} scm_call_with_blocked_asyncs (proc)
@deffnx {C Function} {void *} scm_c_call_with_blocked_asyncs (void * (*proc) (void *data), void *data)
@findex scm_c_call_with_blocked_asyncs
Call @var{proc} and block the execution of system asyncs by one level
for the current thread while it is running. Return the value returned
by @var{proc}. For the first two variants, call @var{proc} with no
arguments; for the third, call it with @var{data}.
@end deffn
@deftypefn {C Function} {void *} scm_c_call_with_blocked_asyncs (void * (*proc) (void *data), void *data)
The same but with a C function @var{proc} instead of a Scheme thunk.
@end deftypefn
@deffn {Scheme Procedure} call-with-unblocked-asyncs proc
@deffnx {C Function} scm_call_with_unblocked_asyncs (proc)
@deffnx {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d)
@findex scm_c_call_with_unblocked_asyncs
Call @var{proc} and unblock the execution of system asyncs by one
level for the current thread while it is running. Return the value
returned by @var{proc}. For the first two variants, call @var{proc}
with no arguments; for the third, call it with @var{data}.
@end deffn
@deftypefn {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
The same but with a C function @var{proc} instead of a Scheme thunk.
@end deftypefn
@deftypefn {C Function} void scm_dynwind_block_asyncs ()
This function must be used inside a pair of calls to
During the current dynwind context, increase the blocking of asyncs by
one level. This function must be used inside a pair of calls to
@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
Wind}). During the dynwind context, asyncs are blocked by one level.
Wind}).
@end deftypefn
@deftypefn {C Function} void scm_dynwind_unblock_asyncs ()
This function must be used inside a pair of calls to
During the current dynwind context, decrease the blocking of asyncs by
one level. This function must be used inside a pair of calls to
@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
Wind}). During the dynwind context, asyncs are unblocked by one
level.
Wind}).
@end deftypefn
@node User asyncs
@ -197,32 +190,6 @@ Mark the user async @var{a} for future execution.
Execute all thunks from the marked asyncs of the list @var{list_of_a}.
@end deffn
@node Continuation Barriers
@subsection Continuation Barriers
The non-local flow of control caused by continuations might sometimes
not be wanted. You can use @code{with-continuation-barrier} etc to
errect fences that continuations can not pass.
@deffn {Scheme Procedure} with-continuation-barrier proc
@deffnx {C Function} scm_with_continuation_barrier (proc)
Call @var{proc} and return its result. Do not allow the invocation of
continuations that would leave or enter the dynamic extent of the call
to @code{with-continuation-barrier}. Such an attempt causes an error
to be signaled.
Throws (such as errors) that are not caught from within @var{proc} are
caught by @code{with-continuation-barrier}. In that case, a short
message is printed to the current error port and @code{#f} is returned.
Thus, @code{with-continuation-barrier} returns exactly once.
@end deffn
@deftypefn {C Function} {void *} scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
Like @code{scm_with_continuation_barrier} but call @var{func} on
@var{data}. When an error is caught, @code{NULL} is returned.
@end deftypefn
@node Threads
@subsection Threads
@cindex threads

19
doc/ref/autoconf.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -48,19 +48,18 @@ checks.
@cindex pkg-config
@cindex autoconf
GNU Guile provides a @dfn{pkg-config} description file, installed as
@file{@var{prefix}/lib/pkgconfig/guile-1.8.pc}, which contains all the
information necessary to compile and link C applications that use Guile.
The @code{pkg-config} program is able to read this file and provide this
information to application programmers; it can be obtained at
@url{http://pkg-config.freedesktop.org/}.
GNU Guile provides a @dfn{pkg-config} description file, which contains
all the information necessary to compile and link C applications that
use Guile. The @code{pkg-config} program is able to read this file
and provide this information to application programmers; it can be
obtained at @url{http://pkg-config.freedesktop.org/}.
The following command lines give respectively the C compilation and link
flags needed to build Guile-using programs:
@example
pkg-config guile-1.8 --cflags
pkg-config guile-1.8 --libs
pkg-config guile-@value{EFFECTIVE-VERSION} --cflags
pkg-config guile-@value{EFFECTIVE-VERSION} --libs
@end example
To ease use of pkg-config with Autoconf, pkg-config comes with a
@ -71,7 +70,7 @@ accordingly, or prints an error and exits if Guile was not found:
@findex PKG_CHECK_MODULES
@example
PKG_CHECK_MODULES([GUILE], [guile-1.8])
PKG_CHECK_MODULES([GUILE], [guile-@value{EFFECTIVE-VERSION}])
@end example
Guile comes with additional Autoconf macros providing more information,

168
doc/ref/compiler.texi
View file

@ -17,7 +17,7 @@ This section aims to pay attention to the small man behind the
curtain.
@xref{Read/Load/Eval/Compile}, if you're lost and you just wanted to
know how to compile your .scm file.
know how to compile your @code{.scm} file.
@menu
* Compiler Tower::
@ -67,8 +67,7 @@ for Scheme:
#:title "Guile Scheme"
#:version "0.5"
#:reader read
#:compilers `((tree-il . ,compile-tree-il)
(ghil . ,compile-ghil))
#:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write)
@ -220,13 +219,13 @@ Note however that @code{sc-expand} does not have the same signature as
around @code{sc-expand}, to make it conform to the general form of
compiler procedures in Guile's language tower.
Compiler procedures take two arguments, an expression and an
environment. They return three values: the compiled expression, the
corresponding environment for the target language, and a
``continuation environment''. The compiled expression and environment
will serve as input to the next language's compiler. The
``continuation environment'' can be used to compile another expression
from the same source language within the same module.
Compiler procedures take three arguments: an expression, an
environment, and a keyword list of options. They return three values:
the compiled expression, the corresponding environment for the target
language, and a ``continuation environment''. The compiled expression
and environment will serve as input to the next language's compiler.
The ``continuation environment'' can be used to compile another
expression from the same source language within the same module.
For example, you might compile the expression, @code{(define-module
(foo))}. This will result in a Tree-IL expression and environment. But
@ -292,6 +291,14 @@ tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10))
The @code{src} fields are left out of the external representation.
One may create Tree-IL objects from their external representations via
calling @code{parse-tree-il}, the reader for Tree-IL. If any source
information is attached to the input S-expression, it will be
propagated to the resulting Tree-IL expressions. This is probably the
easiest way to compile to Tree-IL: just make the appropriate external
representations in S-expression format, and let @code{parse-tree-il}
take care of the rest.
@deftp {Scheme Variable} <void> src
@deftpx {External Representation} (void)
An empty expression. In practice, equivalent to Scheme's @code{(if #f
@ -384,12 +391,29 @@ A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}.
@end deftp
@c FIXME -- need to revive this one
@c @deftp {Scheme Variable} <ghil-mv-bind> src vars rest producer . body
@c Like Scheme's @code{receive} -- binds the values returned by
@c applying @code{producer}, which should be a thunk, to the
@c @code{lambda}-like bindings described by @var{vars} and @var{rest}.
@c @end deftp
There are two Tree-IL constructs that are not normally produced by
higher-level compilers, but instead are generated during the
source-to-source optimization and analysis passes that the Tree-IL
compiler does. Users should not generate these expressions directly,
unless they feel very clever, as the default analysis pass will
generate them as necessary.
@deftp {Scheme Variable} <let-values> src names vars exp body
@deftpx {External Representation} (let-values @var{names} @var{vars} @var{exp} @var{body})
Like Scheme's @code{receive} -- binds the values returned by
evaluating @code{exp} to the @code{lambda}-like bindings described by
@var{vars}. That is to say, @var{vars} may be an improper list.
@code{<let-values>} is an optimization of @code{<application>} of the
primitive, @code{call-with-values}.
@end deftp
@deftp {Scheme Variable} <fix> src names vars vals body
@deftpx {External Representation} (fix @var{names} @var{vars} @var{vals} @var{body})
Like @code{<letrec>}, but only for @var{vals} that are unset
@code{lambda} expressions.
@code{fix} is an optimization of @code{letrec} (and @code{let}).
@end deftp
Tree-IL implements a compiler to GLIL that recursively traverses
Tree-IL expressions, writing out GLIL expressions into a linear list.
@ -399,9 +423,9 @@ future computations. This state allows the compiler not to emit code
for constant expressions that will not be used (e.g. docstrings), and
to perform tail calls when in tail position.
In the future, there will be a pass at the beginning of the
Tree-IL->GLIL compilation step to perform inlining, copy propagation,
dead code elimination, and constant folding.
Most optimization, such as it currently is, is performed on Tree-IL
expressions as source-to-source transformations. There will be more
optimizations added in the future.
Interested readers are encouraged to read the implementation in
@code{(language tree-il compile-glil)} for more details.
@ -411,18 +435,16 @@ Interested readers are encouraged to read the implementation in
Guile Low Intermediate Language (GLIL) is a structured intermediate
language whose expressions more closely approximate Guile's VM
instruction set.
instruction set. Its expression types are defined in @code{(language
glil)}.
Its expression types are defined in @code{(language glil)}, and as
with GHIL, some of its fields parse as rest arguments.
@deftp {Scheme Variable} <glil-program> nargs nrest nlocs nexts meta . body
@deftp {Scheme Variable} <glil-program> nargs nrest nlocs meta . body
A unit of code that at run-time will correspond to a compiled
procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts}
collectively define the program's arity; see @ref{Compiled
Procedures}, for more information. @var{meta} should be an alist of
properties, as in Tree IL's @code{<lambda>}. @var{body} is a list of
GLIL expressions.
procedure. @var{nargs} @var{nrest} and @var{nlocs} collectively define
the program's arity; see @ref{Compiled Procedures}, for more
information. @var{meta} should be an alist of properties, as in
Tree-IL's @code{<lambda>}. @var{body} is an ordered list of GLIL
expressions.
@end deftp
@deftp {Scheme Variable} <glil-bind> . vars
An advisory expression that notes a liveness extent for a set of
@ -461,23 +483,21 @@ and @code{filename} keys, e.g. as returned by
@code{source-properties}.
@end deftp
@deftp {Scheme Variable} <glil-void>
Pushes the unspecified value on the stack.
Pushes ``the unspecified value'' on the stack.
@end deftp
@deftp {Scheme Variable} <glil-const> obj
Pushes a constant value onto the stack. @var{obj} must be a number,
string, symbol, keyword, boolean, character, the empty list, or a pair
or vector of constants.
string, symbol, keyword, boolean, character, uniform array, the empty
list, or a pair or vector of constants.
@end deftp
@deftp {Scheme Variable} <glil-local> op index
Accesses a lexically bound variable from the stack. If @var{op} is
@code{ref}, the value is pushed onto the stack; if it is @code{set},
the variable is set from the top value on the stack, which is popped
off. @xref{Stack Layout}, for more information.
@end deftp
@deftp {Scheme Variable} <glil-external> op depth index
Accesses a heap-allocated variable, addressed by @var{depth}, the nth
enclosing environment, and @var{index}, the variable's position within
the environment. @var{op} is @code{ref} or @code{set}.
@deftp {Scheme Variable} <glil-lexical> local? boxed? op index
Accesses a lexically bound variable. If the variable is not
@var{local?} it is free. All variables may have @code{ref} and
@code{set} as their @var{op}. Boxed variables may also have the
@var{op}s @code{box}, @code{empty-box}, and @code{fix}, which
correspond in semantics to the VM instructions @code{box},
@code{empty-box}, and @code{fix-closure}. @xref{Stack Layout}, for
more information.
@end deftp
@deftp {Scheme Variable} <glil-toplevel> op name
Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set},
@ -516,11 +536,12 @@ be wrapped in a thunk that declares the arity of the expression:
@example
scheme@@(guile-user)> ,language glil
Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on Guile 1.9.0
Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on
Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
glil@@(guile-user)> (program 0 0 0 0 () (const 3) (call return 0))
glil@@(guile-user)> (program 0 0 0 () (const 3) (call return 1))
@result{} 3
@end example
@ -542,12 +563,12 @@ differs from GLIL in four main ways:
@itemize
@item Labels have been resolved to byte offsets in the program.
@item Constants inside procedures have either been expressed as inline
instructions, and possibly cached in object arrays.
instructions or cached in object arrays.
@item Procedures with metadata (source location information, liveness
extents, procedure names, generic properties, etc) have had their
metadata serialized out to thunks.
@item All expressions correspond directly to VM instructions -- i.e.,
there is no @code{<glil-local>} which can be a ref or a set.
there is no @code{<glil-lexical>} which can be a ref or a set.
@end itemize
Assembly is isomorphic to the bytecode that it compiles to. You can
@ -567,10 +588,11 @@ example:
@example
scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
(load-program 0 0 0 0
(load-program 0 0 0
() ; Labels
60 ; Length
70 ; Length
#f ; Metadata
(make-false)
(make-false) ; object table for the returned lambda
(nop)
(nop) ; Alignment. Since assembly has already resolved its labels
@ -578,11 +600,12 @@ scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
(nop) ; object code is mmap'd directly to structures, assembly
(nop) ; has to have the alignment embedded in it.
(nop)
(load-program 1 0 0 0
(load-program
1
0
()
6
; This is the metadata thunk for the returned procedure.
(load-program 0 0 0 0 () 21 #f
8
(load-program 0 0 0 () 21 #f
(load-symbol "x") ; Name and liveness extent for @code{x}.
(make-false)
(make-int8:0) ; Some instruction+arg combinations
@ -597,7 +620,9 @@ scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
(local-ref 0)
(local-ref 0)
(add)
(return))
(return)
(nop)
(nop))
; Return our new procedure.
(return))
@end example
@ -618,10 +643,10 @@ the next step down from assembly:
@example
scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly)
@result{} (load-program 0 0 0 0 () 6 #f
@result{} (load-program 0 0 0 () 6 #f
(make-int8 32) (make-int8 10) (add) (return))
scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48)
@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 10 32 10 10 120 52)
@end example
``Objcode'' is bytecode, but mapped directly to a C structure,
@ -631,8 +656,7 @@ scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
struct scm_objcode @{
scm_t_uint8 nargs;
scm_t_uint8 nrest;
scm_t_uint8 nlocs;
scm_t_uint8 nexts;
scm_t_uint16 nlocs;
scm_t_uint32 len;
scm_t_uint32 metalen;
scm_t_uint8 base[0];
@ -642,7 +666,7 @@ struct scm_objcode @{
As one might imagine, objcode imposes a minimum length on the
bytecode. Also, the multibyte fields are in native endianness, which
makes objcode (and bytecode) system-dependent. Indeed, in the short
example above, all but the last 5 bytes were the program's header.
example above, all but the last 6 bytes were the program's header.
Objcode also has a couple of important efficiency hacks. First,
objcode may be mapped directly from disk, allowing compiled code to be
@ -672,7 +696,7 @@ Makes a bytecode object from @var{bytecode}, which should be a
Load object code from a file named @var{file}. The file will be mapped
into memory via @code{mmap}, so this is a very fast operation.
On disk, object code has an eight-byte cookie prepended to it, to
On disk, object code has an sixteen-byte cookie prepended to it, to
prevent accidental loading of arbitrary garbage.
@end deffn
@ -689,11 +713,11 @@ Copy object code out to a @code{u8vector} for analysis by Scheme.
The following procedure is actually in @code{(system vm program)}, but
we'll mention it here:
@deffn {Scheme Variable} make-program objcode objtable [external='()]
@deffnx {C Function} scm_make_program (objcode, objtable, external)
@deffn {Scheme Variable} make-program objcode objtable [free-vars=#f]
@deffnx {C Function} scm_make_program (objcode, objtable, free_vars)
Load up object code into a Scheme program. The resulting program will
have @var{objtable} as its object table, which should be a vector or
@code{#f}, and will capture the closure variables from @var{external}.
@code{#f}, and will capture the free variables from @var{free-vars}.
@end deffn
Object code from a file may be disassembled at the REPL via the
@ -707,9 +731,9 @@ respect to the compilation environment. Normally the environment
propagates through the compiler transparently, but users may specify
the compilation environment manually as well:
@deffn {Scheme Procedure} make-objcode-env module externals
@deffn {Scheme Procedure} make-objcode-env module free-vars
Make an object code environment. @var{module} should be a Scheme
module, and @var{externals} should be a list of external variables.
module, and @var{free-vars} should be a vector of free variables.
@code{#f} is also a valid object code environment.
@end deffn
@ -748,12 +772,14 @@ procedure is called a certain number of times.
The name of the game is a profiling-based harvest of the low-hanging
fruit, running programs of interest under a system-level profiler and
determining which improvements would give the most bang for the buck.
There are many well-known efficiency hacks in the literature: Dybvig's
letrec optimization, individual boxing of heap-allocated values (and
then store the boxes on the stack directly), optimized case-lambda
expressions, stack underflow and overflow handlers, etc. Highly
recommended papers: Dybvig's HOCS, Ghuloum's compiler paper.
It's really getting to the point though that native compilation is the
next step.
The compiler also needs help at the top end, enhancing the Scheme that
it knows to also understand R6RS, and adding new high-level compilers:
Emacs Lisp, Lua, JavaScript...
it knows to also understand R6RS, and adding new high-level compilers.
We have JavaScript and Emacs Lisp mostly complete, but they could use
some love; Lua would be nice as well, butq whatever language it is
that strikes your fancy would be welcome too.
Compilers are for hacking, not for admiring or for complaining about.
Get to it!

1
doc/ref/effective-version.texi.in Normal file
View file

@ -0,0 +1 @@
@set EFFECTIVE-VERSION @GUILE_EFFECTIVE_VERSION@

16
doc/ref/expect.texi
View file

@ -10,9 +10,9 @@
The macros in this section are made available with:
@smalllisp
@lisp
(use-modules (ice-9 expect))
@end smalllisp
@end lisp
@code{expect} is a macro for selecting actions based on the output from
a port. The name comes from a tool of similar functionality by Don Libes.
@ -30,14 +30,14 @@ which is matched against each of the patterns. When a
pattern matches, the remaining expression(s) in
the clause are evaluated and the value of the last is returned. For example:
@smalllisp
@lisp
(with-input-from-file "/etc/passwd"
(lambda ()
(expect-strings
("^nobody" (display "Got a nobody user.\n")
(display "That's no problem.\n"))
("^daemon" (display "Got a daemon user.\n")))))
@end smalllisp
@end lisp
The regular expression is compiled with the @code{REG_NEWLINE} flag, so
that the ^ and $ anchors will match at any newline, not just at the start
@ -54,13 +54,13 @@ The symbol @code{=>} can be used to indicate that the expression is a
procedure which will accept the result of a successful regular expression
match. E.g.,
@smalllisp
@lisp
("^daemon" => write)
("^d(aemon)" => (lambda args (for-each write args)))
("^da(em)on" => (lambda (all sub)
(write all) (newline)
(write sub) (newline)))
@end smalllisp
@end lisp
The order of the substrings corresponds to the order in which the
opening brackets occur.
@ -135,12 +135,12 @@ expression.
In the following example, a string will only be matched at the beginning
of the file:
@smalllisp
@lisp
(let ((expect-port (open-input-file "/etc/passwd")))
(expect
((lambda (s eof?) (string=? s "fnord!"))
(display "Got a nobody user!\n"))))
@end smalllisp
@end lisp
The control variables described for @code{expect-strings} also
influence the behaviour of @code{expect}, with the exception of

396
doc/goops/goops-tutorial.texi → doc/ref/goops-tutorial.texi
View file

@ -1,3 +1,9 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@c Original attribution:
@c
@ -24,19 +30,33 @@
@c Guile
@c @end macro
This is chapter was originally written by Erick Gallesio as an appendix
for the STk reference manual, and subsequently adapted to @goops{}.
This section introduces the @goops{} package in more detail. It was
originally written by Erick Gallesio as an appendix for the STk
reference manual, and subsequently adapted to @goops{}.
The procedures and syntax described in this tutorial are provided by
Guile modules that may need to be imported before being available.
The main @goops{} module is imported by evaluating:
@lisp
(use-modules (oop goops))
@end lisp
@findex (oop goops)
@cindex main module
@cindex loading
@cindex preparing
@menu
* Copyright::
* Intro::
* Class definition and instantiation::
* Class definition::
* Instance creation and slot access::
* Slot description::
* Inheritance::
* Generic functions::
@end menu
@node Copyright, Intro, Tutorial, Tutorial
@section Copyright
@node Copyright
@subsection Copyright
Original attribution:
@ -52,52 +72,13 @@ required for any of the authorized uses.
This software is provided ``AS IS'' without express or implied
warranty.
Adapted for use in Guile with the authors permission
Adapted for use in Guile with the author's permission
@node Intro, Class definition and instantiation, Copyright, Tutorial
@section Introduction
@goops{} is the object oriented extension to @guile{}. Its
implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
version 1.3 of the Gregor Kiczales @cite{Tiny-Clos}. It is very close
to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is adapted for
the Scheme language.
Briefly stated, the @goops{} extension gives the user a full object
oriented system with multiple inheritance and generic functions with
multi-method dispatch. Furthermore, the implementation relies on a true
meta object protocol, in the spirit of the one defined for CLOS
(@cite{Gregor Kiczales: A Metaobject Protocol}).
The purpose of this tutorial is to introduce briefly the @goops{}
package and in no case will it replace the @goops{} reference manual
(which needs to be urgently written now@ @dots{}).
Note that the operations described in this tutorial resides in modules
that may need to be imported before being available. The main module is
imported by evaluating:
@lisp
(use-modules (oop goops))
@end lisp
@findex (oop goops)
@cindex main module
@cindex loading
@cindex preparing
@node Class definition and instantiation, Inheritance, Intro, Tutorial
@section Class definition and instantiation
@menu
* Class definition::
@end menu
@node Class definition, , Class definition and instantiation, Class definition and instantiation
@node Class definition
@subsection Class definition
A new class is defined with the @code{define-class}@footnote{Don't
forget to import the @code{(oop goops)} module} macro. The syntax of
@code{define-class} is close to CLOS @code{defclass}:
A new class is defined with the @code{define-class} macro. The syntax
of @code{define-class} is close to CLOS @code{defclass}:
@findex define-class
@cindex class
@ -107,105 +88,36 @@ forget to import the @code{(oop goops)} module} macro. The syntax of
@var{class-option} @dots{})
@end lisp
Class options will not be discussed in this tutorial. The list of
@var{superclass}es specifies which classes to inherit properties from
@var{class} (see @ref{Inheritance} for more details). A
@var{slot-description} gives the name of a slot and, eventually, some
``properties'' of this slot (such as its initial value, the function
which permit to access its value, @dots{}). Slot descriptions will be
discussed in @ref{Slot description}.
@var{class} is the class being defined. The list of
@var{superclass}es specifies which existing classes, if any, to
inherit slots and properties from. Each @var{slot-description} gives
the name of a slot and optionally some ``properties'' of this slot;
for example its initial value, the name of a function which will
access its value, and so on. Slot descriptions and inheritance are
discussed more below. For class options, see @ref{Class Options}.
@cindex slot
As an example, let us define a type for representation of complex
numbers in terms of real numbers. This can be done with the following
class definition:
As an example, let us define a type for representing a complex number
in terms of two real numbers.@footnote{Of course Guile already
provides complex numbers, and @code{<complex>} is in fact a predefined
class in GOOPS; but the definition here is still useful as an
example.} This can be done with the following class definition:
@lisp
(define-class <complex> (<number>)
(define-class <my-complex> (<number>)
r i)
@end lisp
This binds the variable @code{<complex>}@footnote{@code{<complex>} is in
fact a builtin class in GOOPS. Because of this, GOOPS will create a new
class. The old class will still serve as the type for Guile's native
complex numbers.} to a new class whose instances contain two
slots. These slots are called @code{r} an @code{i} and we suppose here
that they contain respectively the real part and the imaginary part of a
complex number. Note that this class inherits from @code{<number>} which
is a pre-defined class. (@code{<number>} is the direct super class of
the pre-defined class @code{<complex>} which, in turn, is the super
class of @code{<real>} which is the super of
@code{<integer>}.)@footnote{With the new definition of @code{<complex>},
a @code{<real>} is not a @code{<complex>} since @code{<real>} inherits
from @code{ <number>} rather than @code{<complex>}. In practice,
inheritance could be modified @emph{a posteriori}, if needed. However,
this necessitates some knowledge of the meta object protocol and it will
not be shown in this document}.
This binds the variable @code{<my-complex>} to a new class whose
instances will contain two slots. These slots are called @code{r} and
@code{i} and will hold the real and imaginary parts of a complex
number. Note that this class inherits from @code{<number>}, which is a
predefined class.@footnote{@code{<number>} is the direct superclass of
the predefined class @code{<complex>}; @code{<complex>} is the
superclass of @code{<real>}, and @code{<real>} is the superclass of
@code{<integer>}.}
@node Inheritance, Generic functions, Class definition and instantiation, Tutorial
@section Inheritance
@c \label{inheritance}
@menu
* Class hierarchy and inheritance of slots::
* Instance creation and slot access::
* Slot description::
* Class precedence list::
@end menu
@node Class hierarchy and inheritance of slots, Instance creation and slot access, Inheritance, Inheritance
@subsection Class hierarchy and inheritance of slots
Inheritance is specified upon class definition. As said in the
introduction, @goops{} supports multiple inheritance. Here are some
class definitions:
@lisp
(define-class A () a)
(define-class B () b)
(define-class C () c)
(define-class D (A B) d a)
(define-class E (A C) e c)
(define-class F (D E) f)
@end lisp
@code{A}, @code{B}, @code{C} have a null list of super classes. In this
case, the system will replace it by the list which only contains
@code{<object>}, the root of all the classes defined by
@code{define-class}. @code{D}, @code{E}, @code{F} use multiple
inheritance: each class inherits from two previously defined classes.
Those class definitions define a hierarchy which is shown in Figure@ 1.
In this figure, the class @code{<top>} is also shown; this class is the
super class of all Scheme objects. In particular, @code{<top>} is the
super class of all standard Scheme types.
@example
@group
@image{hierarchy}
@center @emph{Fig 1: A class hierarchy}
@iftex
@emph{(@code{<complex>} which is the direct subclass of @code{<number>}
and the direct superclass of @code{<real>} has been omitted in this
figure.)}
@end iftex
@end group
@end example
The set of slots of a given class is calculated by taking the union of the
slots of all its super class. For instance, each instance of the class
D, defined before will have three slots (@code{a}, @code{b} and
@code{d}). The slots of a class can be obtained by the @code{class-slots}
primitive. For instance,
@lisp
(class-slots A) @result{} ((a))
(class-slots E) @result{} ((a) (e) (c))
(class-slots F) @result{} ((e) (c) (b) (d) (a) (f))
@c used to be ((d) (a) (b) (c) (f))
@end lisp
@emph{Note: } The order of slots is not significant.
@node Instance creation and slot access, Slot description, Class hierarchy and inheritance of slots, Inheritance
@node Instance creation and slot access
@subsection Instance creation and slot access
Creation of an instance of a previously defined
@ -218,16 +130,16 @@ slots of the newly created instance. For instance, the following form
@findex make
@cindex instance
@lisp
(define c (make <complex>))
(define c (make <my-complex>))
@end lisp
will create a new @code{<complex>} object and will bind it to the @code{c}
@noindent
will create a new @code{<my-complex>} object and will bind it to the @code{c}
Scheme variable.
Accessing the slots of the new complex number can be done with the
@code{slot-ref} and the @code{slot-set!} primitives. @code{Slot-set!}
primitive permits to set the value of an object slot and @code{slot-ref}
permits to get its value.
@code{slot-ref} and the @code{slot-set!} primitives. @code{slot-set!}
sets the value of an object slot and @code{slot-ref} retrieves it.
@findex slot-set!
@findex slot-ref
@ -250,52 +162,60 @@ First load the module @code{(oop goops describe)}:
@code{(use-modules (oop goops describe))}
@end example
The expression
@smalllisp
(describe c)
@end smalllisp
will now print the following information on the standard output:
@noindent
Then the expression
@lisp
#<<complex> 401d8638> is an instance of class <complex>
(describe c)
@end lisp
@noindent
will print the following information on the standard output:
@smalllisp
#<<my-complex> 401d8638> is an instance of class <my-complex>
Slots are:
r = 10
i = 3
@end lisp
@end smalllisp
@node Slot description, Class precedence list, Instance creation and slot access, Inheritance
@node Slot description
@subsection Slot description
@c \label{slot-description}
When specifying a slot, a set of options can be given to the
system. Each option is specified with a keyword. The list of authorized
keywords is given below:
When specifying a slot (in a @code{(define-class @dots{})} form),
various options can be specified in addition to the slot's name. Each
option is specified by a keyword. The list of authorized keywords is
given below:
@cindex keyword
@itemize @bullet
@item
@code{#:init-value} permits to supply a default value for the slot. This
default value is obtained by evaluating the form given after the
@code{#:init-form} in the global environment, at class definition time.
@code{#:init-value} permits to supply a constant default value for the
slot. The value is obtained by evaluating the form given after the
@code{#:init-value} at class definition time.
@cindex default slot value
@findex #:init-value
@cindex top level environment
@item
@code{#:init-form} specifies a form that, when evaluated, will return
an initial value for the slot. The form is evaluated each time that
an instance of the class is created, in the lexical environment of the
containing @code{define-class} expression.
@cindex default slot value
@findex #:init-form
@item
@code{#:init-thunk} permits to supply a thunk that will provide a
default value for the slot. The value is obtained by evaluating the
thunk a instance creation time.
@c CHECKME: in the global environment?
default value for the slot. The value is obtained by invoking the
thunk at instance creation time.
@findex default slot value
@findex #:init-thunk
@cindex top level environment
@item
@code{#:init-keyword} permits to specify the keyword for initializing a
slot. The init-keyword may be provided during instance creation (i.e. in
the @code{make} optional parameter list). Specifying such a keyword
@code{#:init-keyword} permits to specify a keyword for initializing the
slot. The init-keyword may be provided during instance creation (i.e. in
the @code{make} optional parameter list). Specifying such a keyword
during instance initialization will supersede the default slot
initialization possibly given with @code{#:init-form}.
@findex #:init-keyword
@ -361,11 +281,11 @@ and @code{#:slot-set!} options. See the example below.
@end itemize
@end itemize
To illustrate slot description, we shall redefine the @code{<complex>} class
To illustrate slot description, we shall redefine the @code{<my-complex>} class
seen before. A definition could be:
@lisp
(define-class <complex> (<number>)
(define-class <my-complex> (<number>)
(r #:init-value 0 #:getter get-r #:setter set-r! #:init-keyword #:r)
(i #:init-value 0 #:getter get-i #:setter set-i! #:init-keyword #:i))
@end lisp
@ -378,11 +298,11 @@ functions @code{get-r} and @code{set-r!} (resp. @code{get-i} and
the @code{r} (resp. @code{i}) slot.
@lisp
(define c1 (make <complex> #:r 1 #:i 2))
(define c1 (make <my-complex> #:r 1 #:i 2))
(get-r c1) @result{} 1
(set-r! c1 12)
(get-r c1) @result{} 12
(define c2 (make <complex> #:r 2))
(define c2 (make <my-complex> #:r 2))
(get-r c2) @result{} 2
(get-i c2) @result{} 0
@end lisp
@ -390,12 +310,12 @@ the @code{r} (resp. @code{i}) slot.
Accessors provide an uniform access for reading and writing an object
slot. Writing a slot is done with an extended form of @code{set!}
which is close to the Common Lisp @code{setf} macro. So, another
definition of the previous @code{<complex>} class, using the
definition of the previous @code{<my-complex>} class, using the
@code{#:accessor} option, could be:
@findex set!
@lisp
(define-class <complex> (<number>)
(define-class <my-complex> (<number>)
(r #:init-value 0 #:accessor real-part #:init-keyword #:r)
(i #:init-value 0 #:accessor imag-part #:init-keyword #:i))
@end lisp
@ -416,13 +336,13 @@ coordinates as well as with polar coordinates. One solution could be to
have a definition of complex numbers which uses one particular
representation and some conversion functions to pass from one
representation to the other. A better solution uses virtual slots. A
complete definition of the @code{<complex>} class using virtual slots is
complete definition of the @code{<my-complex>} class using virtual slots is
given in Figure@ 2.
@example
@group
@lisp
(define-class <complex> (<number>)
(define-class <my-complex> (<number>)
;; True slots use rectangular coordinates
(r #:init-value 0 #:accessor real-part #:init-keyword #:r)
(i #:init-value 0 #:accessor imag-part #:init-keyword #:i)
@ -446,7 +366,7 @@ given in Figure@ 2.
(slot-set! o 'i (* m (sin a)))))))
@end lisp
@center @emph{Fig 2: A @code{<complex>} number class definition using virtual slots}
@center @emph{Fig 2: A @code{<my-complex>} number class definition using virtual slots}
@end group
@end example
@ -480,20 +400,21 @@ A more complete example is given below:
@example
@group
@lisp
(define c (make <complex> #:r 12 #:i 20))
@smalllisp
(define c (make <my-complex> #:r 12 #:i 20))
(real-part c) @result{} 12
(angle c) @result{} 1.03037682652431
(slot-set! c 'i 10)
(set! (real-part c) 1)
(describe c) @result{}
#<<complex> 401e9b58> is an instance of class <complex>
Slots are:
r = 1
i = 10
m = 10.0498756211209
a = 1.47112767430373
@end lisp
(describe c)
@print{}
#<<my-complex> 401e9b58> is an instance of class <my-complex>
Slots are:
r = 1
i = 10
m = 10.0498756211209
a = 1.47112767430373
@end smalllisp
@end group
@end example
@ -503,14 +424,75 @@ Scheme primitives.
@lisp
(define make-rectangular
(lambda (x y) (make <complex> #:r x #:i y)))
(lambda (x y) (make <my-complex> #:r x #:i y)))
(define make-polar
(lambda (x y) (make <complex> #:magn x #:angle y)))
(lambda (x y) (make <my-complex> #:magn x #:angle y)))
@end lisp
@node Class precedence list, , Slot description, Inheritance
@subsection Class precedence list
@node Inheritance
@subsection Inheritance
@c \label{inheritance}
@menu
* Class hierarchy and inheritance of slots::
* Class precedence list::
@end menu
@node Class hierarchy and inheritance of slots
@subsubsection Class hierarchy and inheritance of slots
Inheritance is specified upon class definition. As said in the
introduction, @goops{} supports multiple inheritance. Here are some
class definitions:
@lisp
(define-class A () a)
(define-class B () b)
(define-class C () c)
(define-class D (A B) d a)
(define-class E (A C) e c)
(define-class F (D E) f)
@end lisp
@code{A}, @code{B}, @code{C} have a null list of super classes. In this
case, the system will replace it by the list which only contains
@code{<object>}, the root of all the classes defined by
@code{define-class}. @code{D}, @code{E}, @code{F} use multiple
inheritance: each class inherits from two previously defined classes.
Those class definitions define a hierarchy which is shown in Figure@ 1.
In this figure, the class @code{<top>} is also shown; this class is the
super class of all Scheme objects. In particular, @code{<top>} is the
super class of all standard Scheme types.
@example
@group
@image{hierarchy}
@center @emph{Fig 1: A class hierarchy}
@iftex
@emph{(@code{<complex>} which is the direct subclass of @code{<number>}
and the direct superclass of @code{<real>} has been omitted in this
figure.)}
@end iftex
@end group
@end example
The set of slots of a given class is calculated by taking the union of the
slots of all its super class. For instance, each instance of the class
D, defined before will have three slots (@code{a}, @code{b} and
@code{d}). The slots of a class can be obtained by the @code{class-slots}
primitive. For instance,
@lisp
(class-slots A) @result{} ((a))
(class-slots E) @result{} ((a) (e) (c))
(class-slots F) @result{} ((e) (c) (b) (d) (a) (f))
@c used to be ((d) (a) (b) (c) (f))
@end lisp
@emph{Note: } The order of slots is not significant.
@node Class precedence list
@subsubsection Class precedence list
A class may have more than one superclass. @footnote{This section is an
adaptation of Jeff Dalton's (J.Dalton@@ed.ac.uk) @cite{Brief
@ -587,8 +569,8 @@ However, this result is not too much readable; using the function
(map class-name (class-precedence-list B)) @result{} (B <object> <top>)
@end lisp
@node Generic functions, , Inheritance, Tutorial
@section Generic functions
@node Generic functions
@subsection Generic functions
@menu
* Generic functions and methods::
@ -596,8 +578,8 @@ However, this result is not too much readable; using the function
* Example::
@end menu
@node Generic functions and methods, Next-method, Generic functions, Generic functions
@subsection Generic functions and methods
@node Generic functions and methods
@subsubsection Generic functions and methods
@c \label{gf-n-methods}
Neither @goops{} nor CLOS use the message mechanism for methods as most
@ -687,8 +669,8 @@ In this case,
(G 'a 1) @result{} top-number
@end lisp
@node Next-method, Example, Generic functions and methods, Generic functions
@subsection Next-method
@node Next-method
@subsubsection Next-method
When you call a generic function, with a particular set of arguments,
GOOPS builds a list of all the methods that are applicable to those
@ -737,16 +719,16 @@ Number is in range
lead to an infinite recursion, but this consideration is just the same
as in Scheme code in general.)
@node Example, , Next-method, Generic functions
@subsection Example
@node Example
@subsubsection Example
In this section we shall continue to define operations on the @code{<complex>}
In this section we shall continue to define operations on the @code{<my-complex>}
class defined in Figure@ 2. Suppose that we want to use it to implement
complex numbers completely. For instance a definition for the addition of
two complexes could be
@lisp
(define-method (new-+ (a <complex>) (b <complex>))
(define-method (new-+ (a <my-complex>) (b <my-complex>))
(make-rectangular (+ (real-part a) (real-part b))
(+ (imag-part a) (imag-part b))))
@end lisp
@ -758,7 +740,7 @@ addition we can do:
(define-generic new-+)
(let ((+ +))
(define-method (new-+ (a <complex>) (b <complex>))
(define-method (new-+ (a <my-complex>) (b <my-complex>))
(make-rectangular (+ (real-part a) (real-part b))
(+ (imag-part a) (imag-part b)))))
@end lisp
@ -778,13 +760,13 @@ Figure@ 3.
(define-method (new-+ (a <real>) (b <real>)) (+ a b))
(define-method (new-+ (a <real>) (b <complex>))
(define-method (new-+ (a <real>) (b <my-complex>))
(make-rectangular (+ a (real-part b)) (imag-part b)))
(define-method (new-+ (a <complex>) (b <real>))
(define-method (new-+ (a <my-complex>) (b <real>))
(make-rectangular (+ (real-part a) b) (imag-part a)))
(define-method (new-+ (a <complex>) (b <complex>))
(define-method (new-+ (a <my-complex>) (b <my-complex>))
(make-rectangular (+ (real-part a) (real-part b))
(+ (imag-part a) (imag-part b))))
@ -823,7 +805,7 @@ To terminate our implementation (integration?) of complex numbers, we can
redefine standard Scheme predicates in the following manner:
@lisp
(define-method (complex? c <complex>) #t)
(define-method (complex? c <my-complex>) #t)
(define-method (complex? c) #f)
(define-method (number? n <number>) #t)

391
doc/goops/goops.texi → doc/ref/goops.texi
View file

@ -1,19 +1,8 @@
\input texinfo
@c -*-texinfo-*-
@c %**start of header
@setfilename goops.info
@settitle Goops Manual
@set goops
@setchapternewpage odd
@paragraphindent 0
@c %**end of header
@set VERSION 0.3
@dircategory The Algorithmic Language Scheme
@direntry
* GOOPS: (goops). The GOOPS reference manual.
@end direntry
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@macro goops
GOOPS
@ -23,77 +12,8 @@ GOOPS
Guile
@end macro
@ifinfo
This file documents GOOPS, an object oriented extension for Guile.
Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation
Permission is granted to make and distribute verbatim copies of
this manual provided the copyright notice and this permission notice
are preserved on all copies.
@end ifinfo
@c This title page illustrates only one of the
@c two methods of forming a title page.
@titlepage
@title Goops Manual
@subtitle For use with GOOPS @value{VERSION}
@c AUTHORS
@c The GOOPS tutorial was written by Christian Lynbech and Mikael
@c Djurfeldt, who also wrote GOOPS itself. The GOOPS reference manual
@c and MOP documentation were written by Neil Jerram and reviewed by
@c Mikael Djurfeldt.
@author Christian Lynbech
@author @email{chl@@tbit.dk}
@author
@author Mikael Djurfeldt
@author @email{djurfeldt@@nada.kth.se}
@author
@author Neil Jerram
@author @email{neil@@ossau.uklinux.net}
@c The following two commands
@c start the copyright page.
@page
@vskip 0pt plus 1filll
Copyright @copyright{} 1999, 2006 Free Software Foundation
Permission is granted to make and distribute verbatim copies of
this manual provided the copyright notice and this permission notice
are preserved on all copies.
@end titlepage
@node Top, Introduction, (dir), (dir)
@menu
* Introduction::
* Getting Started::
* Reference Manual::
* MOP Specification::
* Tutorial::
* Concept Index::
* Function and Variable Index::
@end menu
@iftex
@chapter Preliminaries
@end iftex
@node Introduction, Getting Started, Top, Top
@iftex
@section Introduction
@end iftex
@ifnottex
@chapter Introduction
@end ifnottex
@node GOOPS
@chapter GOOPS
@goops{} is the object oriented extension to @guile{}. Its
implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
@ -109,71 +29,58 @@ multi-method dispatch. Furthermore, the implementation relies on a true
meta object protocol, in the spirit of the one defined for CLOS
(@cite{Gregor Kiczales: A Metaobject Protocol}).
@node Getting Started, Reference Manual, Introduction, Top
@iftex
@section Getting Started
@end iftex
@ifnottex
@chapter Getting Started
@end ifnottex
@menu
* Running GOOPS::
Examples of some basic GOOPS functionality.
* Methods::
* User-defined types::
* Asking for the type of an object::
See further in the GOOPS tutorial available in this distribution in
info (goops.info) and texinfo format.
* Quick Start::
* Tutorial::
* Reference Manual::
* MOP Specification::
@end menu
@node Running GOOPS, Methods, Getting Started, Getting Started
@subsection Running GOOPS
@node Quick Start
@section Quick Start
@enumerate
@item
Type
To give an immediate flavour of what GOOPS can do, here is a very
brief introduction to its main operations.
@smalllisp
guile-oops
@end smalllisp
To start using GOOPS, load the @code{(oop goops)} module:
You should now be at the Guile prompt ("guile> ").
@item
Type
@smalllisp
@lisp
(use-modules (oop goops))
@end smalllisp
to load GOOPS. (If your system supports dynamic loading, you
should be able to do this not only from `guile-oops' but from an
arbitrary Guile interpreter.)
@end enumerate
@end lisp
We're now ready to try some basic GOOPS functionality.
@node Methods, User-defined types, Running GOOPS, Getting Started
@menu
* Methods::
* User-defined types::
* Asking for the type of an object::
@end menu
@node Methods
@subsection Methods
@smalllisp
@group
A GOOPS method is like a Scheme procedure except that it is
specialized for a particular set of argument types.
@lisp
(define-method (+ (x <string>) (y <string>))
(string-append x y))
(+ 1 2) --> 3
(+ "abc" "de") --> "abcde"
@end group
@end smalllisp
(+ "abc" "de") @result{} "abcde"
@end lisp
@node User-defined types, Asking for the type of an object, Methods, Getting Started
If @code{+} is used with arguments that do not match the method's
types, Guile falls back to using the normal Scheme @code{+} procedure.
@lisp
(+ 1 2) @result{} 3
@end lisp
@node User-defined types
@subsection User-defined types
@smalllisp
@lisp
(define-class <2D-vector> ()
(x #:init-value 0 #:accessor x-component #:init-keyword #:x)
(y #:init-value 0 #:accessor y-component #:init-keyword #:y))
@ -182,12 +89,11 @@ We're now ready to try some basic GOOPS functionality.
(use-modules (ice-9 format))
(define-method (write (obj <2D-vector>) port)
(display (format #f "<~S, ~S>" (x-component obj) (y-component obj))
port))
(format port "<~S, ~S>" (x-component obj) (y-component obj)))
(define v (make <2D-vector> #:x 3 #:y 4))
v --> <3, 4>
v @result{} <3, 4>
@end group
@group
@ -196,24 +102,28 @@ v --> <3, 4>
#:x (+ (x-component x) (x-component y))
#:y (+ (y-component x) (y-component y))))
(+ v v) --> <6, 8>
(+ v v) @result{} <6, 8>
@end group
@end smalllisp
@end lisp
@node Asking for the type of an object, , User-defined types, Getting Started
@node Asking for the type of an object
@subsection Types
@example
(class-of v) --> #<<class> <2D-vector> 40241ac0>
<2D-vector> --> #<<class> <2D-vector> 40241ac0>
(class-of 1) --> #<<class> <integer> 401b2a98>
<integer> --> #<<class> <integer> 401b2a98>
(class-of v) @result{} #<<class> <2D-vector> 40241ac0>
<2D-vector> @result{} #<<class> <2D-vector> 40241ac0>
(class-of 1) @result{} #<<class> <integer> 401b2a98>
<integer> @result{} #<<class> <integer> 401b2a98>
(is-a? v <2D-vector>) --> #t
(is-a? v <2D-vector>) @result{} #t
@end example
@node Reference Manual, MOP Specification, Getting Started, Top
@chapter Reference Manual
@node Tutorial
@section Tutorial
@include goops-tutorial.texi
@node Reference Manual
@section Reference Manual
This chapter is the GOOPS reference manual. It aims to describe all the
syntax, procedures, options and associated concepts that a typical
@ -241,7 +151,7 @@ For a detailed specification of the GOOPS metaobject protocol, see
@end menu
@node Introductory Remarks
@section Introductory Remarks
@subsection Introductory Remarks
GOOPS is an object-oriented programming system based on a ``metaobject
protocol'' derived from the ones used in CLOS (the Common Lisp Object
@ -261,19 +171,19 @@ GOOPS' power, by customizing the behaviour of GOOPS itself.
Each of the following sections of the reference manual is arranged
such that the most basic usage is introduced first, and then subsequent
subsections discuss the related internal functions and metaobject
subsubsections discuss the related internal functions and metaobject
protocols, finishing with a description of how to customize that area of
functionality.
These introductory remarks continue with a few words about metaobjects
and the MOP. Readers who do not want to be bothered yet with the MOP
and customization could safely skip this subsection on a first reading,
and should correspondingly skip subsequent subsections that are
and customization could safely skip this subsubsection on a first reading,
and should correspondingly skip subsequent subsubsections that are
concerned with internals and customization.
In general, this reference manual assumes familiarity with standard
object oriented concepts and terminology. However, some of the terms
used in GOOPS are less well known, so the Terminology subsection
used in GOOPS are less well known, so the Terminology subsubsection
provides definitions for these terms.
@menu
@ -282,7 +192,7 @@ provides definitions for these terms.
@end menu
@node Metaobjects and the Metaobject Protocol
@subsection Metaobjects and the Metaobject Protocol
@subsubsection Metaobjects and the Metaobject Protocol
The conceptual building blocks of GOOPS are classes, slot definitions,
instances, generic functions and methods. A class is a grouping of
@ -377,7 +287,7 @@ Each subsequent section of the reference manual covers a particular area
of GOOPS functionality, and describes the generic functions that are
relevant for customization of that area.
We conclude this subsection by emphasizing a point that may seem
We conclude this subsubsection by emphasizing a point that may seem
obvious, but contrasts with the corresponding situation in some other
MOP implementations, such as CLOS. The point is simply that an
identifier which represents a GOOPS class or generic function is a
@ -392,7 +302,7 @@ class names), but it is worth noting that GOOPS conforms fully to this
Schemely principle.
@node Terminology
@subsection Terminology
@subsubsection Terminology
It is assumed that the reader is already familiar with standard object
orientation concepts such as classes, objects/instances,
@ -403,14 +313,7 @@ This section explains some of the less well known concepts and
terminology that GOOPS uses, which are assumed by the following sections
of the reference manual.
@menu
* Metaclass::
* Class Precedence List::
* Accessor::
@end menu
@node Metaclass
@subsubsection Metaclass
@subsubheading Metaclass
A @dfn{metaclass} is the class of an object which represents a GOOPS
class. Put more succinctly, a metaclass is a class's class.
@ -517,8 +420,7 @@ The metaclass of @code{<my-metaclass>} is @code{<class>}.
@code{<class>}.
@end itemize
@node Class Precedence List
@subsubsection Class Precedence List
@subsubheading Class Precedence List
The @dfn{class precedence list} of a class is the list of all direct and
indirect superclasses of that class, including the class itself.
@ -548,8 +450,7 @@ precedence list}.
``Class precedence list'' is often abbreviated, in documentation and
Scheme variable names, to @dfn{cpl}.
@node Accessor
@subsubsection Accessor
@subsubheading Accessor
An @dfn{accessor} is a generic function with both reference and setter
methods.
@ -583,7 +484,7 @@ be invoked using the generalized @code{set!} syntax, as in:
@end example
@node Defining New Classes
@section Defining New Classes
@subsection Defining New Classes
[ *fixme* Somewhere in this manual there needs to be an introductory
discussion about GOOPS classes, generic functions and methods, covering
@ -622,7 +523,7 @@ the discussion there. ]
@end menu
@node Basic Class Definition
@subsection Basic Class Definition
@subsubsection Basic Class Definition
New classes are defined using the @code{define-class} syntax, with
arguments that specify the classes that the new class should inherit
@ -651,7 +552,7 @@ keywords and corresponding values.
@end deffn
The standard GOOPS class and slot options are described in the following
subsections: see @ref{Class Options} and @ref{Slot Options}.
subsubsections: see @ref{Class Options} and @ref{Slot Options}.
Example 1. Define a class that combines two pre-existing classes by
inheritance but adds no new slots.
@ -681,13 +582,13 @@ customized via an application-defined metaclass.
@end example
@node Class Options
@subsection Class Options
@subsubsection Class Options
@deffn {class option} #:metaclass metaclass
The @code{#:metaclass} class option specifies the metaclass of the class
being defined. @var{metaclass} must be a class that inherits from
@code{<class>}. For an introduction to the use of metaclasses, see
@ref{Metaobjects and the Metaobject Protocol} and @ref{Metaclass}.
@ref{Metaobjects and the Metaobject Protocol} and @ref{Terminology}.
If the @code{#:metaclass} option is absent, GOOPS reuses or constructs a
metaclass for the new class by calling @code{ensure-metaclass}
@ -714,7 +615,7 @@ environment defaults to the top-level environment in which the
@end deffn
@node Slot Options
@subsection Slot Options
@subsubsection Slot Options
@deffn {slot option} #:allocation allocation
The @code{#:allocation} option tells GOOPS how to allocate storage for
@ -917,7 +818,7 @@ classes.
@end deffn
@node Class Definition Internals
@subsection Class Definition Internals
@subsubsection Class Definition Internals
Implementation notes: @code{define-class} expands to an expression which
@ -1030,7 +931,7 @@ class object, are described in @ref{Customizing Instance Creation},
which covers the creation and initialization of instances in general.
@node Customizing Class Definition
@subsection Customizing Class Definition
@subsubsection Customizing Class Definition
During the initialization of a new class, GOOPS calls a number of generic
functions with the newly allocated class instance as the first
@ -1124,7 +1025,8 @@ allocation to do this.
(let ((batch-allocation-count 0)
(batch-get-n-set #f))
(define-method (compute-get-n-set (class <batched-allocation-metaclass>) s)
(define-method (compute-get-n-set
(class <batched-allocation-metaclass>) s)
(case (slot-definition-allocation s)
((#:batched)
;; If we've already used the same slot storage for 10 instances,
@ -1165,7 +1067,7 @@ typically it would perform additional class initialization steps before
and/or after calling @code{(next-method)} for the standard behaviour.
@node STKlos Compatibility
@subsection STKlos Compatibility
@subsubsection STKlos Compatibility
If the STKlos compatibility module is loaded, @code{define-class} is
overwritten by a STKlos-specific definition; the standard GOOPS
@ -1178,7 +1080,7 @@ definition of @code{define-class} remains available in
@end deffn
@node Creating Instances
@section Creating Instances
@subsection Creating Instances
@menu
* Basic Instance Creation::
@ -1186,7 +1088,7 @@ definition of @code{define-class} remains available in
@end menu
@node Basic Instance Creation
@subsection Basic Instance Creation
@subsubsection Basic Instance Creation
To create a new instance of any GOOPS class, use the generic function
@code{make} or @code{make-instance}, passing the required class and any
@ -1223,7 +1125,7 @@ instance's class. Any unprocessed keyword value pairs are ignored.
@end deffn
@node Customizing Instance Creation
@subsection Customizing Instance Creation
@subsubsection Customizing Instance Creation
@code{make} itself is a generic function. Hence the @code{make}
invocation itself can be customized in the case where the new instance's
@ -1290,7 +1192,7 @@ and closures in the slot definitions, it is neater to write an
and initializes all the dependent slot values according to the results.
@node Accessing Slots
@section Accessing Slots
@subsection Accessing Slots
The definition of a slot contains at the very least a slot name, and may
also contain various slot options, including getter, setter and/or
@ -1298,7 +1200,7 @@ accessor functions for the slot.
It is always possible to access slots by name, using the various
``slot-ref'' and ``slot-set!'' procedures described in the following
subsections. For example,
subsubsections. For example,
@example
(define-class <my-class> () ;; Define a class with slots
@ -1354,7 +1256,7 @@ closures, see @ref{Customizing Class Definition,, compute-get-n-set}.)
@end menu
@node Instance Slots
@subsection Instance Slots
@subsubsection Instance Slots
Any slot, regardless of its allocation, can be queried, referenced and
set using the following four primitive procedures.
@ -1451,7 +1353,7 @@ slot-missing}).
@end deffn
@node Class Slots
@subsection Class Slots
@subsubsection Class Slots
Slots whose allocation is per-class rather than per-instance can be
referenced and set without needing to specify any particular instance.
@ -1479,7 +1381,7 @@ function with arguments @var{class} and @var{slot-name}.
@end deffn
@node Handling Slot Access Errors
@subsection Handling Slot Access Errors
@subsubsection Handling Slot Access Errors
GOOPS calls one of the following generic functions when a ``slot-ref''
or ``slot-set!'' call specifies a non-existent slot name, or tries to
@ -1510,7 +1412,7 @@ message.
@end deffn
@node Creating Generic Functions
@section Creating Generic Functions
@subsection Creating Generic Functions
A generic function is a collection of methods, with rules for
determining which of the methods should be applied for any given
@ -1526,7 +1428,7 @@ GOOPS represents generic functions as metaobjects of the class
@end menu
@node Basic Generic Function Creation
@subsection Basic Generic Function Creation
@subsubsection Basic Generic Function Creation
The following forms may be used to bind a variable to a generic
function. Depending on that variable's pre-existing value, the generic
@ -1586,20 +1488,20 @@ This can be resolved automagically with the duplicates handler
@code{merge-generics} which gives the module system license to merge
all generic functions sharing a common name:
@smalllisp
@lisp
(define-module (math 2D-vectors)
:use-module (oop goops)
:export (x y ...))
#:use-module (oop goops)
#:export (x y ...))
(define-module (math 3D-vectors)
:use-module (oop goops)
:export (x y z ...))
#:use-module (oop goops)
#:export (x y z ...))
(define-module (my-module)
:use-module (math 2D-vectors)
:use-module (math 3D-vectors)
:duplicates merge-generics)
@end smalllisp
#:use-module (math 2D-vectors)
#:use-module (math 3D-vectors)
#:duplicates merge-generics)
@end lisp
The generic function @code{x} in @code{(my-module)} will now share
methods with @code{x} in both imported modules.
@ -1629,14 +1531,14 @@ Sharing is dynamic, so that adding new methods to a descendant implies
adding it to the ancestor.
If duplicates checking is desired in the above example, the following
form of the @code{:duplicates} option can be used instead:
form of the @code{#:duplicates} option can be used instead:
@smalllisp
:duplicates (merge-generics check)
@end smalllisp
@lisp
#:duplicates (merge-generics check)
@end lisp
@node Generic Function Internals
@subsection Generic Function Internals
@subsubsection Generic Function Internals
@code{define-generic} calls @code{ensure-generic} to upgrade a
pre-existing procedure value, or @code{make} with metaclass
@ -1705,7 +1607,7 @@ accessor, passing the setter generic function as the value of the
@code{#:setter} keyword.
@node Extending Guiles Primitives
@subsection Extending Guile's Primitives
@subsubsection Extending Guile's Primitives
When GOOPS is loaded, many of Guile's primitive procedures can be
extended by giving them a generic function definition that operates
@ -1752,7 +1654,7 @@ integrated into the core of Guile. Consequently, the
procedures described in this section may disappear as well.
@node Adding Methods to Generic Functions
@section Adding Methods to Generic Functions
@subsection Adding Methods to Generic Functions
@menu
* Basic Method Definition::
@ -1760,7 +1662,7 @@ procedures described in this section may disappear as well.
@end menu
@node Basic Method Definition
@subsection Basic Method Definition
@subsubsection Basic Method Definition
To add a method to a generic function, use the @code{define-method} form.
@ -1819,7 +1721,7 @@ invocation error handling, and generic function invocation in general,
see @ref{Invoking Generic Functions}.
@node Method Definition Internals
@subsection Method Definition Internals
@subsubsection Method Definition Internals
@code{define-method}
@ -1906,7 +1808,7 @@ function.
@end deffn
@node Invoking Generic Functions
@section Invoking Generic Functions
@subsection Invoking Generic Functions
When a variable with a generic function definition appears as the first
element of a list that is being evaluated, the Guile evaluator tries
@ -1928,7 +1830,7 @@ may be applied subsequently if a method that is being applied calls
@end menu
@node Determining Which Methods to Apply
@subsection Determining Which Methods to Apply
@subsubsection Determining Which Methods to Apply
[ *fixme* Sorry - this is the area of GOOPS that I understand least of
all, so I'm afraid I have to pass on this section. Would some other
@ -1959,7 +1861,7 @@ kind person consider filling it in? ]
@end deffn
@node Handling Invocation Errors
@subsection Handling Invocation Errors
@subsubsection Handling Invocation Errors
@deffn generic no-method
@deffnx method no-method (gf <generic>) args
@ -1987,7 +1889,7 @@ default method calls @code{goops-error} with an appropriate message.
@end deffn
@node Redefining a Class
@section Redefining a Class
@subsection Redefining a Class
Suppose that a class @code{<my-class>} is defined using @code{define-class}
(@pxref{Basic Class Definition,, define-class}), with slots that have
@ -2002,7 +1904,7 @@ make}). What then happens if @code{<my-class>} is redefined by calling
@end menu
@node Default Class Redefinition Behaviour
@subsection Default Class Redefinition Behaviour
@subsubsection Default Class Redefinition Behaviour
GOOPS' default answer to this question is as follows.
@ -2055,7 +1957,7 @@ Also bear in mind that, like most of GOOPS' default behaviour, it can
be customized@dots{}
@node Customizing Class Redefinition
@subsection Customizing Class Redefinition
@subsubsection Customizing Class Redefinition
When @code{define-class} notices that a class is being redefined,
it constructs the new class metaobject as usual, and then invokes the
@ -2092,7 +1994,8 @@ is specialized for this metaclass:
@example
(define-class <can-be-nameless> (<class>))
(define-method (class-redefinition (old <can-be-nameless>) (new <class>))
(define-method (class-redefinition (old <can-be-nameless>)
(new <class>))
new)
@end example
@ -2119,7 +2022,7 @@ generic functions, and so on@dots{} The detailed protocol for all of these
is described in @ref{MOP Specification}.
@node Changing the Class of an Instance
@section Changing the Class of an Instance
@subsection Changing the Class of an Instance
You can change the class of an existing instance by invoking the
generic function @code{change-class} with two arguments: the instance
@ -2158,7 +2061,7 @@ invokes the @code{change-class} generic function for each existing
instance of the redefined class.
@node Introspection
@section Introspection
@subsection Introspection
@dfn{Introspection}, also known as @dfn{reflection}, is the name given
to the ability to obtain information dynamically about GOOPS metaobjects.
@ -2197,7 +2100,7 @@ GOOPS equivalents --- to be obtained dynamically, at run time.
@end menu
@node Classes
@subsection Classes
@subsubsection Classes
@deffn {primitive procedure} class-name class
Return the name of class @var{class}.
@ -2257,7 +2160,7 @@ Return a list of all methods that use @var{class} or a subclass of
@end deffn
@node Slots
@subsection Slots
@subsubsection Slots
@deffn procedure class-slot-definition class slot-name
Return the slot definition for the slot named @var{slot-name} in class
@ -2338,7 +2241,7 @@ see @ref{Slot Options,, init-value}.
@end deffn
@node Instances
@subsection Instances
@subsubsection Instances
@deffn {primitive procedure} class-of value
Return the GOOPS class of any Scheme @var{value}.
@ -2359,7 +2262,7 @@ Implementation notes: @code{is-a?} uses @code{class-of} and
@var{object}.
@node Generic Functions
@subsection Generic Functions
@subsubsection Generic Functions
@deffn {primitive procedure} generic-function-name gf
Return the name of generic function @var{gf}.
@ -2371,7 +2274,7 @@ This is the value of the @var{gf} metaobject's @code{methods} slot.
@end deffn
@node Generic Function Methods
@subsection Generic Function Methods
@subsubsection Generic Function Methods
@deffn {primitive procedure} method-generic-function method
Return the generic function that @var{method} belongs to.
@ -2409,18 +2312,18 @@ Return an expression that prints to show the definition of method
@end deffn
@node Miscellaneous Functions
@section Miscellaneous Functions
@subsection Miscellaneous Functions
@menu
* Administrative Functions::
* Error Handling::
* GOOPS Error Handling::
* Object Comparisons::
* Cloning Objects::
* Write and Display::
@end menu
@node Administrative Functions
@subsection Administration Functions
@subsubsection Administration Functions
This section describes administrative, non-technical GOOPS functions.
@ -2428,8 +2331,8 @@ This section describes administrative, non-technical GOOPS functions.
Return the current GOOPS version as a string, for example ``0.2''.
@end deffn
@node Error Handling
@subsection Error Handling
@node GOOPS Error Handling
@subsubsection Error Handling
The procedure @code{goops-error} is called to raise an appropriate error
by the default methods of the following generic functions:
@ -2464,7 +2367,7 @@ as done by @code{scm-error}.
@end deffn
@node Object Comparisons
@subsection Object Comparisons
@subsubsection Object Comparisons
@deffn generic eqv?
@deffnx method eqv? ((x <top>) (y <top>))
@ -2493,7 +2396,7 @@ and the Guile reference manual.
@end deffn
@node Cloning Objects
@subsection Cloning Objects
@subsubsection Cloning Objects
@deffn generic shallow-clone
@deffnx method shallow-clone (self <object>)
@ -2514,7 +2417,7 @@ or by reference.
@end deffn
@node Write and Display
@subsection Write and Display
@subsubsection Write and Display
@deffn {primitive generic} write object port
@deffnx {primitive generic} display object port
@ -2542,8 +2445,8 @@ methods - instances of the class @code{<method>}.
as the Guile primitive @code{write} and @code{display} functions.
@end deffn
@node MOP Specification, Tutorial, Reference Manual, Top
@chapter MOP Specification
@node MOP Specification
@section MOP Specification
For an introduction to metaobjects and the metaobject protocol,
see @ref{Metaobjects and the Metaobject Protocol}.
@ -2598,7 +2501,7 @@ what the caller expects to get as the applied method's return value.
@end menu
@node Class Definition
@section Class Definition
@subsection Class Definition
@code{define-class} (syntax)
@ -2731,7 +2634,7 @@ or @code{#:accessor} option.
@end itemize
@node Instance Creation
@section Instance Creation
@subsection Instance Creation
@code{make <class> . @var{initargs}} (method)
@ -2752,13 +2655,13 @@ return value is ignored.
@end itemize
@node Class Redefinition
@section Class Redefinition
@subsection Class Redefinition
The default @code{class-redefinition} method, specialized for classes
with the default metaclass @code{<class>}, has the following internal
protocol.
@code{class-redefinition @var{(old <class>)} @var{(new <class>)}}
@code{class-redefinition (@var{old <class>}) (@var{new <class>})}
(method)
@itemize @bullet
@ -2797,7 +2700,7 @@ to the modified instance, and initializes new slots, as described in
generic function invocation that can be used to customize the instance
update algorithm.
@code{change-class @var{(old-instance <object>)} @var{(new <class>)}} (method)
@code{change-class (@var{old-instance <object>}) (@var{new <class>})} (method)
@itemize @bullet
@item
@ -2814,7 +2717,7 @@ nothing.
@end itemize
@node Method Definition
@section Method Definition
@subsection Method Definition
@code{define-method} (syntax)
@ -2842,7 +2745,7 @@ theoretically handle adding methods to further types of target.
@end itemize
@node Generic Function Invocation
@section Generic Function Invocation
@subsection Generic Function Invocation
[ *fixme* Description required here. ]
@ -2885,21 +2788,3 @@ theoretically handle adding methods to further types of target.
@item
@code{no-next-method}
@end itemize
@node Tutorial, Concept Index, MOP Specification, Top
@chapter Tutorial
@include goops-tutorial.texi
@node Concept Index, Function and Variable Index, Tutorial, Top
@unnumberedsec Concept Index
@printindex cp
@node Function and Variable Index, , Concept Index, Top
@unnumberedsec Function and Variable Index
@printindex fn
@summarycontents
@contents
@bye

17
doc/ref/guile.texi
View file

@ -4,22 +4,21 @@
@setfilename guile.info
@settitle Guile Reference Manual
@set guile
@set MANUAL-EDITION 1.1
@set MANUAL-REVISION 1
@c %**end of header
@include version.texi
@include lib-version.texi
@include effective-version.texi
@copying
This reference manual documents Guile, GNU's Ubiquitous Intelligent
Language for Extensions. This is edition @value{MANUAL-EDITION}
corresponding to Guile @value{VERSION}.
This manual documents Guile version @value{VERSION}.
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005 Free
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009 Free
Software Foundation.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.2 or
any later version published by the Free Software Foundation; with the
any later version published by the Free Software Foundation; with
no Invariant Sections, with the Front-Cover Texts being ``A GNU
Manual,'' and with the Back-Cover Text ``You are free to copy and
modify this GNU Manual.''. A copy of the license is included in the
@ -137,7 +136,7 @@ x
@sp 10
@comment The title is printed in a large font.
@title Guile Reference Manual
@subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION}
@subtitle Edition @value{EDITION}, revision @value{MANUAL-REVISION}, for use with Guile @value{VERSION}
@c @subtitle $Id: guile.texi,v 1.49 2008-03-19 22:51:23 ossau Exp $
@c See preface.texi for the list of authors
@ -177,6 +176,8 @@ x
* Guile Modules::
* GOOPS::
* Guile Implementation::
* Autoconf Support::
@ -365,6 +366,8 @@ available through both Scheme and C interfaces.
@include scsh.texi
@include scheme-debugging.texi
@include goops.texi
@node Guile Implementation
@chapter Guile Implementation

0
doc/goops/hierarchy.eps → doc/ref/hierarchy.eps
View file

0
doc/goops/hierarchy.pdf → doc/ref/hierarchy.pdf
View file

0
doc/goops/hierarchy.png → doc/ref/hierarchy.png
View file

Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 6.1 KiB

After

Width:  |  Height:  |  Size: 6.1 KiB

Before After
Before After

0
doc/goops/hierarchy.txt → doc/ref/hierarchy.txt
View file

18
doc/ref/intro.texi
View file

@ -80,6 +80,7 @@ To unbundle Guile use the instruction
zcat guile-@value{VERSION}.tar.gz | tar xvf -
@end example
@noindent
which will create a directory called @file{guile-@value{VERSION}} with
all the sources. You can look at the file @file{INSTALL} for detailed
instructions on how to build and install Guile, but you should be able
@ -93,7 +94,7 @@ make install
@end example
This will install the Guile executable @file{guile}, the Guile library
@file{-lguile} and various associated header files and support
@file{libguile} and various associated header files and support
libraries. It will also install the Guile tutorial and reference
manual.
@ -101,14 +102,14 @@ manual.
Since this manual frequently refers to the Scheme ``standard'', also
known as R5RS, or the
@iftex
@tex
``Revised$^5$ Report on the Algorithmic Language Scheme'',
@end iftex
@end tex
@ifnottex
``Revised^5 Report on the Algorithmic Language Scheme'',
@end ifnottex
we have included the report in the Guile distribution;
@xref{Top, , Introduction, r5rs, Revised(5) Report on the Algorithmic
we have included the report in the Guile distribution; see
@ref{Top, , Introduction, r5rs, Revised(5) Report on the Algorithmic
Language Scheme}.
This will also be installed in your info directory.
@ -471,11 +472,12 @@ You can get the version number by invoking the command
@example
$ guile --version
Guile 1.9.0
Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation
Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
2005, 2006, 2007, 2008, 2009 Free Software Foundation
Guile may be distributed under the terms of the GNU Lesser General
Public Licence. For details, see the files `COPYING.LESSER' and
`COPYING', which are included in the Guile distribution. There is no
warranty, to the extent permitted by law.
`COPYING', which are included in the Guile distribution. There is
no warranty, to the extent permitted by law.
@end example
@item

4
doc/ref/libguile-extensions.texi
View file

@ -94,11 +94,11 @@ we are going to call the function @code{init_bessel} which will make
@file{.so} when invoking @code{load-extension}. The right extension for
the host platform will be provided automatically.
@smalllisp
@lisp
(load-extension "libguile-bessel" "init_bessel")
(j0 2)
@result{} 0.223890779141236
@end smalllisp
@end lisp
For this to work, @code{load-extension} must be able to find
@file{libguile-bessel}, of course. It will look in the places that

3
doc/ref/libguile-linking.texi
View file

@ -173,7 +173,8 @@ creating ./config.status
creating Makefile
$ make
gcc -c -I/usr/local/include simple-guile.c
gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm -o simple-guile
gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm
-o simple-guile
$ ./simple-guile
guile> (+ 1 2 3)
6

26
doc/ref/libguile-smobs.texi
View file

@ -28,7 +28,7 @@ datatypes described here.)
@menu
* Describing a New Type::
* Creating Instances::
* Creating Smob Instances::
* Type checking::
* Garbage Collecting Smobs::
* Garbage Collecting Simple Smobs::
@ -132,8 +132,8 @@ init_image_type (void)
@end example
@node Creating Instances
@subsection Creating Instances
@node Creating Smob Instances
@subsection Creating Smob Instances
Normally, smobs can have one @emph{immediate} word of data. This word
stores either a pointer to an additional memory block that holds the
@ -211,7 +211,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 1: Allocate the memory block.
*/
image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
image = (struct image *)
scm_gc_malloc (sizeof (struct image), "image");
/* Step 2: Initialize it with straight code.
*/
@ -228,7 +229,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 4: Finish the initialization.
*/
image->name = name;
image->pixels = scm_gc_malloc (width * height, "image pixels");
image->pixels =
scm_gc_malloc (width * height, "image pixels");
return smob;
@}
@ -404,7 +406,9 @@ free_image (SCM image_smob)
@{
struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
scm_gc_free (image->pixels, image->width * image->height, "image pixels");
scm_gc_free (image->pixels,
image->width * image->height,
"image pixels");
scm_gc_free (image, sizeof (struct image), "image");
return 0;
@ -583,7 +587,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 1: Allocate the memory block.
*/
image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
image = (struct image *)
scm_gc_malloc (sizeof (struct image), "image");
/* Step 2: Initialize it with straight code.
*/
@ -600,7 +605,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 4: Finish the initialization.
*/
image->name = name;
image->pixels = scm_gc_malloc (width * height, "image pixels");
image->pixels =
scm_gc_malloc (width * height, "image pixels");
return smob;
@}
@ -642,7 +648,9 @@ free_image (SCM image_smob)
@{
struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
scm_gc_free (image->pixels, image->width * image->height, "image pixels");
scm_gc_free (image->pixels,
image->width * image->height,
"image pixels");
scm_gc_free (image, sizeof (struct image), "image");
return 0;

0
doc/goops/mop.text → doc/ref/mop.text
View file

4
doc/ref/posix.texi
View file

@ -2072,9 +2072,9 @@ The following procedures are similar to the @code{popen} and
@code{pclose} system routines. The code is in a separate ``popen''
module:
@smalllisp
@lisp
(use-modules (ice-9 popen))
@end smalllisp
@end lisp
@findex popen
@deffn {Scheme Procedure} open-pipe command mode

24
doc/ref/preface.texi
View file

@ -7,12 +7,9 @@
@node Preface
@chapter Preface
This reference manual documents Guile, GNU's Ubiquitous Intelligent
Language for Extensions. It describes how to use Guile in many useful
and interesting ways.
This is edition @value{MANUAL-EDITION} of the reference manual, and
corresponds to Guile version @value{VERSION}.
This manual documents version @value{VERSION} of Guile, GNU's
Ubiquitous Intelligent Language for Extensions. It describes how to
use Guile in many useful and interesting ways.
@menu
* Manual Layout::
@ -25,7 +22,7 @@ corresponds to Guile version @value{VERSION}.
@node Manual Layout
@section Layout of this Manual
The manual is divided into five chapters.
The manual is divided into the following chapters.
@table @strong
@item Chapter 1: Introduction to Guile
@ -38,7 +35,7 @@ the later parts of the manual. This part also explains how to obtain
and install new versions of Guile, and how to report bugs effectively.
@item Chapter 2: Programming in Scheme
This part provides an overview over programming in Scheme with Guile.
This part provides an overview of programming in Scheme with Guile.
It covers how to invoke the @code{guile} program from the command-line
and how to write scripts in Scheme. It also gives an introduction
into the basic ideas of Scheme itself and to the various extensions
@ -61,6 +58,10 @@ Describes some important modules, distributed as part of the Guile
distribution, that extend the functionality provided by the Guile
Scheme core.
@item Chapter 6: GOOPS
Describes GOOPS, an object oriented extension to Guile that provides
classes, multiple inheritance and generic functions.
@end table
@ -72,7 +73,7 @@ We use some conventions in this manual.
@itemize @bullet
@item
For some procedures, notably type predicates, we use @dfn{iff} to mean
For some procedures, notably type predicates, we use ``iff'' to mean
``if and only if''. The construct is usually something like: `Return
@var{val} iff @var{condition}', where @var{val} is usually
``@nicode{#t}'' or ``non-@nicode{#f}''. This typically means that
@ -144,6 +145,9 @@ filling out a lot of the documentation of Scheme data types, control
mechanisms and procedures. In addition, he wrote the documentation
for Guile's SRFI modules and modules associated with the Guile REPL.
The chapter on GOOPS was written by Christian Lynbech, Mikael
Djurfeldt and Neil Jerram.
@node Guile License
@section The Guile License
@cindex copying
@ -179,7 +183,7 @@ C code linking to the Guile readline module is subject to the terms of
that module. Basically such code must be published on Free terms.
Scheme level code written to be run by Guile (but not derived from
Guile itself) is not resticted in any way, and may be published on any
Guile itself) is not restricted in any way, and may be published on any
terms. We encourage authors to publish on Free terms.
You must be aware there is no warranty whatsoever for Guile. This is

12
doc/ref/scheme-debugging.texi
View file

@ -14,9 +14,9 @@ call to that procedure is reported to the user during a program run.
The idea is that you can mark a collection of procedures for tracing,
and Guile will subsequently print out a line of the form
@smalllisp
@lisp
| | [@var{procedure} @var{args} @dots{}]
@end smalllisp
@end lisp
whenever a marked procedure is about to be applied to its arguments.
This can help a programmer determine whether a function is being called
@ -27,7 +27,7 @@ how the traced applications are or are not tail recursive with respect
to each other. Thus, a trace of a non-tail recursive factorial
implementation looks like this:
@smalllisp
@lisp
[fact1 4]
| [fact1 3]
| | [fact1 2]
@ -38,11 +38,11 @@ implementation looks like this:
| | 2
| 6
24
@end smalllisp
@end lisp
While a typical tail recursive implementation would look more like this:
@smalllisp
@lisp
[fact2 4]
[facti 1 4]
[facti 4 3]
@ -50,7 +50,7 @@ While a typical tail recursive implementation would look more like this:
[facti 24 1]
[facti 24 0]
24
@end smalllisp
@end lisp
@deffn {Scheme Procedure} trace procedure
Enable tracing for @code{procedure}. While a program is being run,

6
doc/ref/scheme-ideas.texi
View file

@ -390,7 +390,11 @@ this:
@noindent
This is a valid procedure invocation expression, and its result is the
string @code{"Name=FSF:Address=Cambridge"}.
string:
@lisp
"Name=FSF:Address=Cambridge"
@end lisp
It is more common, though, to store the procedure value in a variable ---

4
doc/ref/scsh.texi
View file

@ -19,8 +19,8 @@ For information about scsh see
The closest emulation of scsh can be obtained by running:
@smalllisp
@lisp
(load-from-path "scsh/init")
@end smalllisp
@end lisp
See the USAGE file supplied with guile-scsh for more details.

13
doc/ref/slib.texi
View file

@ -4,7 +4,6 @@
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@page
@node SLIB
@section SLIB
@cindex SLIB
@ -12,9 +11,9 @@
Before the SLIB facilities can be used, the following Scheme expression
must be executed:
@smalllisp
@lisp
(use-modules (ice-9 slib))
@end smalllisp
@end lisp
@findex require
@code{require} can then be used in the usual way (@pxref{Require,,,
@ -64,7 +63,7 @@ Alternatively, you can create a symlink in the Guile directory to SLIB,
e.g.:
@example
ln -s /usr/local/lib/slib /usr/local/share/guile/1.8/slib
ln -s /usr/local/lib/slib /usr/local/share/guile/@value{EFFECTIVE-VERSION}/slib
@end example
@item
@ -78,7 +77,7 @@ guile> (quit)
@end example
The catalog data should now be in
@file{/usr/local/share/guile/1.8/slibcat}.
@file{/usr/local/share/guile/@value{EFFECTIVE-VERSION}/slibcat}.
If instead you get an error such as:
@ -104,11 +103,11 @@ It is usually installed as an extra package in SLIB.
You can use Guile's interface to SLIB to invoke Jacal:
@smalllisp
@lisp
(use-modules (ice-9 slib))
(slib:load "math")
(math)
@end smalllisp
@end lisp
@noindent
For complete documentation on Jacal, please read the Jacal manual. If

6
doc/ref/tools.texi
View file

@ -232,8 +232,8 @@ is a expression suitable for initializing a new variable.
For procedures, you can use @code{SCM_DEFINE} for most purposes. Use
@code{SCM_PROC} along with @code{SCM_REGISTER_PROC} when you don't
want to be bothered with docstrings. Use @code{SCM_GPROC} for generic
functions (@pxref{Creating Generic Functions,,, goops, GOOPS}). All
procedures are declared with return type @code{SCM}.
functions (@pxref{Creating Generic Functions}). All procedures are
declared with return type @code{SCM}.
For everything else, use the appropriate macro (@code{SCM_SYMBOL} for
symbols, and so on). Without "_GLOBAL_", the declarations are
@ -364,7 +364,7 @@ of the form:
@example
(define-module (scripts PROGRAM)
:export (PROGRAM))
#:export (PROGRAM))
@end example
Feel free to export other definitions useful in the module context.

431
doc/ref/vm.texi
View file

@ -13,8 +13,8 @@ procedures can call each other as they please.
The difference is that the compiler creates and interprets bytecode
for a custom virtual machine, instead of interpreting the
S-expressions directly. Running compiled code is faster than running
interpreted code.
S-expressions directly. Loading and running compiled code is faster
than loading and running source code.
The virtual machine that does the bytecode interpretation is a part of
Guile itself. This section describes the nature of Guile's virtual
@ -134,7 +134,7 @@ compiled to object code, one might never leave the virtual machine.
@subsection Stack Layout
While not strictly necessary to understand how to work with the VM, it
is instructive and sometimes entertaining to consider the struture of
is instructive and sometimes entertaining to consider the structure of
the VM stack.
Logically speaking, a VM stack is composed of ``frames''. Each frame
@ -159,18 +159,19 @@ The structure of the fixed part of an application frame is as follows:
@example
Stack
| | <- fp + bp->nargs + bp->nlocs + 4
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| MV return address|
| Dynamic link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| ... |
| Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
+==================+
| Local variable 1 |
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+------------------+
| Return address |
| MV return address|
| Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
| |
@end example
@ -201,25 +202,17 @@ values being returned.
@item Dynamic link
This is the @code{fp} in effect before this program was applied. In
effect, this and the return address are the registers that are always
``saved''.
@item External link
This field is a reference to the list of heap-allocated variables
associated with this frame. For a discussion of heap versus stack
allocation, @xref{Variables and the VM}.
``saved''. The dynamic link links the current frame to the previous
frame; computing a stack trace involves traversing these frames.
@item Local variable @var{n}
Lambda-local variables that are allocated on the stack are all
allocated as part of the frame. This makes access to non-captured,
non-mutated variables very cheap.
Lambda-local variables that are all allocated as part of the frame.
This makes access to variables very cheap.
@item Argument @var{n}
The calling convention of the VM requires arguments of a function
application to be pushed on the stack, and here they are. Normally
references to arguments dispatch to these locations on the stack.
However if an argument has to be stored on the heap, it will be copied
from its initial value here onto a location in the heap, and
thereafter only referenced on the heap.
application to be pushed on the stack, and here they are. References
to arguments dispatch to these locations on the stack.
@item Program
This is the program being applied. For more information on how
@ -236,26 +229,44 @@ Consider the following Scheme code as an example:
(lambda (b) (list foo a b)))
@end example
Within the lambda expression, "foo" is a top-level variable, "a" is a
lexically captured variable, and "b" is a local variable.
Within the lambda expression, @code{foo} is a top-level variable, @code{a} is a
lexically captured variable, and @code{b} is a local variable.
@code{b} may safely be allocated on the stack, as there is no enclosed
procedure that references it, nor is it ever mutated.
Another way to refer to @code{a} and @code{b} is to say that @code{a}
is a ``free'' variable, since it is not defined within the lambda, and
@code{b} is a ``bound'' variable. These are the terms used in the
@dfn{lambda calculus}, a mathematical notation for describing
functions. The lambda calculus is useful because it allows one to
prove statements about functions. It is especially good at describing
scope relations, and it is for that reason that we mention it here.
@code{a}, on the other hand, is referenced by an enclosed procedure,
that of the lambda. Thus it must be allocated on the heap, as it may
(and will) outlive the dynamic extent of the invocation of @code{foo}.
Guile allocates all variables on the stack. When a lexically enclosed
procedure with free variables---a @dfn{closure}---is created, it
copies those variables its free variable vector. References to free
variables are then redirected through the free variable vector.
@code{foo} is a top-level variable, because it names the procedure
@code{foo}, which is here defined at the top-level.
If a variable is ever @code{set!}, however, it will need to be
heap-allocated instead of stack-allocated, so that different closures
that capture the same variable can see the same value. Also, this
allows continuations to capture a reference to the variable, instead
of to its value at one point in time. For these reasons, @code{set!}
variables are allocated in ``boxes''---actually, in variable cells.
@xref{Variables}, for more information. References to @code{set!}
variables are indirected through the boxes.
Note that variables that are mutated (via @code{set!}) must be
allocated on the heap, even if they are local variables. This is
because any called subprocedure might capture the continuation, which
would need to capture locations instead of values. Thus perhaps
counterintuitively, what would seem ``closer to the metal'', viz
@code{set!}, actually forces heap allocation instead of stack
allocation.
Thus perhaps counterintuitively, what would seem ``closer to the
metal'', viz @code{set!}, actually forces an extra memory allocation
and indirection.
Going back to our example, @code{b} may be allocated on the stack, as
it is never mutated.
@code{a} may also be allocated on the stack, as it too is never
mutated. Within the enclosed lambda, its value will be copied into
(and referenced from) the free variables vector.
@code{foo} is a top-level variable, because @code{foo} is not
lexically bound in this example.
@node VM Programs
@subsection Compiled Procedures are VM Programs
@ -297,27 +308,26 @@ scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
scheme@@(guile-user)> ,x foo
Disassembly of #<program foo (a)>:
0 (local-ref 0) ;; `a' (arg)
2 (external-set 0) ;; `a' (arg)
4 (object-ref 1) ;; #<program b70d2910 at <unknown port>:0:16 (b)>
6 (make-closure)
7 (return)
0 (object-ref 1) ;; #<program b7e478b0 at <unknown port>:0:16 (b)>
2 (local-ref 0) ;; `a' (arg)
4 (vector 0 1) ;; 1 element
7 (make-closure)
8 (return)
----------------------------------------
Disassembly of #<program b70d2910 at <unknown port>:0:16 (b)>:
Disassembly of #<program b7e478b0 at <unknown port>:0:16 (b)>:
0 (toplevel-ref 1) ;; `foo'
2 (external-ref 0) ;; (closure variable)
4 (local-ref 0) ;; `b' (arg)
6 (list 0 3) ;; 3 elements at (unknown file):0:28
0 (toplevel-ref 1) ;; `foo'
2 (free-ref 0) ;; (closure variable)
4 (local-ref 0) ;; `b' (arg)
6 (list 0 3) ;; 3 elements at (unknown file):0:28
9 (return)
@end smallexample
At @code{ip} 0 and 2, we do the copy from argument to heap for
@code{a}. @code{Ip} 4 loads up the compiled lambda, and then at
@code{ip} 6 we make a closure---binding code (from the compiled
lambda) with data (the heap-allocated variables). Finally we return
the closure.
At @code{ip} 0, we load up the compiled lambda. @code{Ip} 2 and 4
create the free variables vector, and @code{ip} 7 makes the
closure---binding code (from the compiled lambda) with data (the
free-variable vector). Finally we return the closure.
The second stanza disassembles the compiled lambda. Toplevel variables
are resolved relative to the module that was current when the
@ -336,7 +346,7 @@ routine.
@node Instruction Set
@subsection Instruction Set
There are about 100 instructions in Guile's virtual machine. These
There are about 150 instructions in Guile's virtual machine. These
instructions represent atomic units of a program's execution. Ideally,
they perform one task without conditional branches, then dispatch to
the next instruction in the stream.
@ -376,16 +386,22 @@ instructions. More instructions may be added over time.
* Miscellaneous Instructions::
* Inlined Scheme Instructions::
* Inlined Mathematical Instructions::
* Inlined Bytevector Instructions::
@end menu
@node Environment Control Instructions
@subsubsection Environment Control Instructions
These instructions access and mutate the environment of a compiled
procedure---the local bindings, the ``external'' bindings, and the
procedure---the local bindings, the free (captured) bindings, and the
toplevel bindings.
Some of these instructions have @code{long-} variants, the difference
being that they take 16-bit arguments, encoded in big-endianness,
instead of the normal 8-bit range.
@deffn Instruction local-ref index
@deffnx Instruction long-local-ref index
Push onto the stack the value of the local variable located at
@var{index} within the current stack frame.
@ -395,26 +411,62 @@ arguments.
@end deffn
@deffn Instruction local-set index
@deffnx Instruction long-local-ref index
Pop the Scheme object located on top of the stack and make it the new
value of the local variable located at @var{index} within the current
stack frame.
@end deffn
@deffn Instruction external-ref index
Push the value of the closure variable located at position
@var{index} within the program's list of external variables.
@deffn Instruction free-ref index
Push the value of the captured variable located at position
@var{index} within the program's vector of captured variables.
@end deffn
@deffn Instruction external-set index
Pop the Scheme object located on top of the stack and make it the new
value of the closure variable located at @var{index} within the
program's list of external variables.
@deffn Instruction free-boxed-ref index
@deffnx Instruction free-boxed-set index
Get or set a boxed free variable. Note that there is no free-set
instruction, as variables that are @code{set!} must be boxed.
These instructions assume that the value at position @var{index} in
the free variables vector is a variable.
@end deffn
The external variable lookup algorithm should probably be made more
efficient in the future via addressing by frame and index. Currently,
external variables are all consed onto a list, which results in O(N)
lookup time.
@deffn Instruction make-closure
Pop a vector and a program object off the stack, in that order, and
push a new program object with the given free variables vector. The
new program object shares state with the original program.
At the time of this writing, the space overhead of closures is 4 words
per closure.
@end deffn
@deffn Instruction fix-closure index
Pop a vector off the stack, and set it as the @var{index}th local
variable's free variable vector. The @var{index}th local variable is
assumed to be a procedure.
This instruction is part of a hack for allocating mutually recursive
procedures. The hack is to first perform a @code{local-set} for all of
the recursive procedures, then fix up the procedures' free variable
bindings in place. This allows most @code{letrec}-bound procedures to
be allocated unboxed on the stack.
One could of course do a @code{local-ref}, then @code{make-closure},
then @code{local-set}, but this macroinstruction helps to speed up the
common case.
@end deffn
@deffn Instruction box index
Pop a value off the stack, and set the @var{index}nth local variable
to a box containing that value. A shortcut for @code{make-variable}
then @code{local-set}, used when binding boxed variables.
@end deffn
@deffn Instruction empty-box index
Set the @var{indext}h local variable to a box containing a variable
whose value is unbound. Used when compiling some @code{letrec}
expressions.
@end deffn
@deffn Instruction toplevel-ref index
@deffnx Instruction long-toplevel-ref index
@ -442,9 +494,6 @@ in-place mutation of the object table. This mechanism provides for
lazy variable resolution, and an important cached fast-path once the
variable has been successfully resolved.
The ``long'' variant has a 16-bit index instead of an 8-bit index,
with the most significant byte first.
This instruction pushes the value of the variable onto the stack.
@end deffn
@ -453,8 +502,13 @@ This instruction pushes the value of the variable onto the stack.
Pop a value off the stack, and set it as the value of the toplevel
variable stored at @var{index} in the object table. If the variable
has not yet been looked up, we do the lookup as in
@code{toplevel-ref}. The ``long'' variant has a 16-bit index instead
of an 8-bit index.
@code{toplevel-ref}.
@end deffn
@deffn Instruction define
Pop a symbol and a value from the stack, in that order. Look up its
binding in the current toplevel environment, creating the binding if
necessary. Set the variable to the value.
@end deffn
@deffn Instruction link-now
@ -476,6 +530,11 @@ Pop off two objects from the stack, a variable and a value, and set
the variable to the value.
@end deffn
@deffn Instruction make-variable
Replace the top object on the stack with a variable containing it.
Used in some circumstances when compiling @code{letrec} expressions.
@end deffn
@deffn Instruction object-ref n
@deffnx Instruction long-object-ref n
Push @var{n}th value from the current program's object vector. The
@ -499,7 +558,10 @@ the one to which the instruction pointer points).
@end itemize
Note that the offset passed to the instruction is encoded on two 8-bit
integers which are then combined by the VM as one 16-bit integer.
integers which are then combined by the VM as one 16-bit integer. Note
also that jump targets in Guile are aligned on 8-byte boundaries, and
that the offset refers to the @var{n}th 8-byte boundary, effectively
giving Guile a 19-bit relative address space.
@deffn Instruction br offset
Jump to @var{offset}.
@ -550,19 +612,21 @@ Load an arbitrary number from the instruction stream. The number is
embedded in the stream as a string.
@end deffn
@deffn Instruction load-string length
Load a string from the instruction stream.
Load a string from the instruction stream. The string is assumed to be
encoded in the ``latin1'' locale.
@end deffn
@deffn Instruction load-wide-string length
Load a UTF-32 string from the instruction stream. @var{length} is the
length in bytes, not in codepoints
@end deffn
@deffn Instruction load-symbol length
Load a symbol from the instruction stream.
Load a symbol from the instruction stream. The symbol is assumed to be
encoded in the ``latin1'' locale. Symbols backed by wide strings may
be loaded via @code{load-wide-string} then @code{make-symbol}.
@end deffn
@deffn Instruction load-keyword length
Load a keyword from the instruction stream.
@end deffn
@deffn Instruction define length
Load a symbol from the instruction stream, and look up its binding in
the current toplevel environment, creating the binding if necessary.
Push the variable corresponding to the binding.
@deffn Instruction load-array length
Load a uniform array from the instruction stream. The shape and type
of the array are popped off the stack, in that order.
@end deffn
@deffn Instruction load-program
@ -579,54 +643,38 @@ because instead of parsing its data, it directly maps the instruction
stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode
and Objcode}, for more information.
The resulting compiled procedure will not have any ``external''
variables captured, so it may be loaded only once but used many times
to create closures.
@end deffn
Finally, while this instruction is not strictly a ``loading''
instruction, it's useful to wind up the @code{load-program} discussion
here:
@deffn Instruction make-closure
Pop the program object from the stack, capture the current set of
``external'' variables, and assign those external variables to a copy
of the program. Push the new program object, which shares state with
the original program.
At the time of this writing, the space overhead of closures is 4 words
per closure.
The resulting compiled procedure will not have any free variables
captured, so it may be loaded only once but used many times to create
closures.
@end deffn
@node Procedural Instructions
@subsubsection Procedural Instructions
@deffn Instruction return
Free the program's frame, returning the top value from the stack to
the current continuation. (The stack should have exactly one value on
it.)
Specifically, the @code{sp} is decremented to one below the current
@code{fp}, the @code{ip} is reset to the current return address, the
@code{fp} is reset to the value of the current dynamic link, and then
the top item on the stack (formerly the procedure being applied) is
set to the returned value.
@deffn Instructions new-frame
Push a new frame on the stack, reserving space for the dynamic link,
return address, and the multiple-values return address. The frame
pointer is not yet updated, because the frame is not yet active -- it
has to be patched by a @code{call} instruction to get the return
address.
@end deffn
@deffn Instruction call nargs
Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}.
For compiled procedures, this instruction sets up a new stack frame,
as described in @ref{Stack Layout}, and then dispatches to the first
instruction in the called procedure, relying on the called procedure
to return one value to the newly-created continuation. Because the new
frame pointer will point to sp[-nargs + 1], the arguments don't have
to be shuffled around -- they are already in place.
This instruction requires that a new frame be pushed on the stack
before the procedure, via @code{new-frame}. @xref{Stack Layout}, for
more information. It patches up that frame with the current @code{ip}
as the return address, then dispatches to the first instruction in the
called procedure, relying on the called procedure to return one value
to the newly-created continuation. Because the new frame pointer will
point to sp[-nargs + 1], the arguments don't have to be shuffled
around -- they are already in place.
For non-compiled procedures (continuations, primitives, and
interpreted procedures), @code{call} will pop the procedure and
arguments off the stack, and push the result of calling
interpreted procedures), @code{call} will pop the frame, procedure,
and arguments off the stack, and push the result of calling
@code{scm_apply}.
@end deffn
@ -634,10 +682,10 @@ arguments off the stack, and push the result of calling
Like @code{call}, but reusing the current continuation. This
instruction implements tail calls as required by RnRS.
For compiled procedures, that means that @code{goto/args} reuses the
current frame instead of building a new one. The @code{goto/*}
instruction family is named as it is because tail calls are equivalent
to @code{goto}, along with relabeled variables.
For compiled procedures, that means that @code{goto/args} simply
shuffles down the procedure and arguments to the current stack frame.
The @code{goto/*} instruction family is named as it is because tail
calls are equivalent to @code{goto}, along with relabeled variables.
For non-VM procedures, the result is the same, but the current VM
invocation remains on the C stack. True tail calls are not currently
@ -660,15 +708,6 @@ These instructions are used in the implementation of multiple value
returns, where the actual number of values is pushed on the stack.
@end deffn
@deffn Instruction call/cc
@deffnx Instruction goto/cc
Capture the current continuation, and then call (or tail-call) the
procedure on the top of the stack, with the continuation as the
argument.
Both the VM continuation and the C continuation are captured.
@end deffn
@deffn Instruction mv-call nargs offset
Like @code{call}, except that a multiple-value continuation is created
in addition to a single-value continuation.
@ -681,6 +720,18 @@ the stack to be the number of values, and below that values
themselves, pushed separately.
@end deffn
@deffn Instruction return
Free the program's frame, returning the top value from the stack to
the current continuation. (The stack should have exactly one value on
it.)
Specifically, the @code{sp} is decremented to one below the current
@code{fp}, the @code{ip} is reset to the current return address, the
@code{fp} is reset to the value of the current dynamic link, and then
the top item on the stack (formerly the procedure being applied) is
set to the returned value.
@end deffn
@deffn Instruction return/values nvalues
Return the top @var{nvalues} to the current continuation.
@ -715,6 +766,19 @@ be 1 (to indicate that one of the bindings was a rest argument).
Signals an error if there is an insufficient number of values.
@end deffn
@deffn Instruction call/cc
@deffnx Instruction goto/cc
Capture the current continuation, and then call (or tail-call) the
procedure on the top of the stack, with the continuation as the
argument.
@code{call/cc} does not require a @code{new-frame} to be pushed on the
stack, as @code{call} does, because it needs to capture the stack
before the frame is pushed.
Both the VM continuation and the C continuation are captured.
@end deffn
@node Data Control Instructions
@subsubsection Data Control Instructions
@ -768,6 +832,19 @@ Push @code{'()} onto the stack.
Push @var{value}, an 8-bit character, onto the stack.
@end deffn
@deffn Instruction make-char32 value
Push @var{value}, an 32-bit character, onto the stack. The value is
encoded in big-endian order.
@end deffn
@deffn Instruction make-symbol
Pops a string off the stack, and pushes a symbol.
@end deffn
@deffn Instruction make-keyword value
Pops a symbol off the stack, and pushes a keyword.
@end deffn
@deffn Instruction list n
Pops off the top @var{n} values off of the stack, consing them up into
a list, then pushes that list on the stack. What was the topmost value
@ -781,37 +858,12 @@ popping off those values and pushing on the resulting vector. @var{n}
is a two-byte value, like in @code{vector}.
@end deffn
@deffn Instruction mark
Pushes a special value onto the stack that other stack instructions
like @code{list-mark} can use.
@end deffn
@deffn Instruction list-mark
Create a list from values from the stack, as in @code{list}, but
instead of knowing beforehand how many there will be, keep going until
we see a @code{mark} value.
@end deffn
@deffn Instruction cons-mark
As the scheme procedure @code{cons*} is to the scheme procedure
@code{list}, so the instruction @code{cons-mark} is to the instruction
@code{list-mark}.
@end deffn
@deffn Instruction vector-mark
Like @code{list-mark}, but makes a vector instead of a list.
@end deffn
@deffn Instruction list-break
The opposite of @code{list}: pops a value, which should be a list, and
pushes its elements on the stack.
@end deffn
@node Miscellaneous Instructions
@subsubsection Miscellaneous Instructions
@deffn Instruction nop
Does nothing!
Does nothing! Used for padding other instructions to certain
alignments.
@end deffn
@deffn Instruction halt
@ -877,6 +929,8 @@ stream.
@deffnx Instruction cons x y
@deffnx Instruction car x
@deffnx Instruction cdr x
@deffnx Instruction vector-ref x y
@deffnx Instruction vector-set x n y
Inlined implementations of their Scheme equivalents.
@end deffn
@ -897,7 +951,9 @@ As in the previous section, the definitions below show stack
parameters instead of instruction stream parameters.
@deffn Instruction add x y
@deffnx Instruction add1 x
@deffnx Instruction sub x y
@deffnx Instruction sub1 x
@deffnx Instruction mul x y
@deffnx Instruction div x y
@deffnx Instruction quo x y
@ -910,3 +966,58 @@ parameters instead of instruction stream parameters.
@deffnx Instruction ge? x y
Inlined implementations of the corresponding mathematical operations.
@end deffn
@node Inlined Bytevector Instructions
@subsubsection Inlined Bytevector Instructions
Bytevector operations correspond closely to what the current hardware
can do, so it makes sense to inline them to VM instructions, providing
a clear path for eventual native compilation. Without this, Scheme
programs would need other primitives for accessing raw bytes -- but
these primitives are as good as any.
As in the previous section, the definitions below show stack
parameters instead of instruction stream parameters.
The multibyte formats (@code{u16}, @code{f64}, etc) take an extra
endianness argument. Only aligned native accesses are currently
fast-pathed in Guile's VM.
@deffn Instruction bv-u8-ref bv n
@deffnx Instruction bv-s8-ref bv n
@deffnx Instruction bv-u16-native-ref bv n
@deffnx Instruction bv-s16-native-ref bv n
@deffnx Instruction bv-u32-native-ref bv n
@deffnx Instruction bv-s32-native-ref bv n
@deffnx Instruction bv-u64-native-ref bv n
@deffnx Instruction bv-s64-native-ref bv n
@deffnx Instruction bv-f32-native-ref bv n
@deffnx Instruction bv-f64-native-ref bv n
@deffnx Instruction bv-u16-ref bv n endianness
@deffnx Instruction bv-s16-ref bv n endianness
@deffnx Instruction bv-u32-ref bv n endianness
@deffnx Instruction bv-s32-ref bv n endianness
@deffnx Instruction bv-u64-ref bv n endianness
@deffnx Instruction bv-s64-ref bv n endianness
@deffnx Instruction bv-f32-ref bv n endianness
@deffnx Instruction bv-f64-ref bv n endianness
@deffnx Instruction bv-u8-set bv n val
@deffnx Instruction bv-s8-set bv n val
@deffnx Instruction bv-u16-native-set bv n val
@deffnx Instruction bv-s16-native-set bv n val
@deffnx Instruction bv-u32-native-set bv n val
@deffnx Instruction bv-s32-native-set bv n val
@deffnx Instruction bv-u64-native-set bv n val
@deffnx Instruction bv-s64-native-set bv n val
@deffnx Instruction bv-f32-native-set bv n val
@deffnx Instruction bv-f64-native-set bv n val
@deffnx Instruction bv-u16-set bv n val endianness
@deffnx Instruction bv-s16-set bv n val endianness
@deffnx Instruction bv-u32-set bv n val endianness
@deffnx Instruction bv-s32-set bv n val endianness
@deffnx Instruction bv-u64-set bv n val endianness
@deffnx Instruction bv-s64-set bv n val endianness
@deffnx Instruction bv-f32-set bv n val endianness
@deffnx Instruction bv-f64-set bv n val endianness
Inlined implementations of the corresponding bytevector operations.
@end deffn

37
guile-readline/Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of guile-readline.
##
@ -19,15 +19,24 @@
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
SUBDIRS = ice-9
## Prevent automake from adding extra -I options
DEFS = @DEFS@ @EXTRA_DEFS@
if HAVE_READLINE
# `ice-9' subdirectory.
ice9dir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
nobase_ice9_DATA = ice-9/readline.scm
EXTRA_DIST = $(nobase_ice9_DATA)
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
INCLUDES = -I. -I.. -I$(srcdir)/.. \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
AM_CPPFLAGS = -I. -I.. -I$(srcdir)/.. \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
AM_CFLAGS = $(GCC_CFLAGS)
GUILE_SNARF = ../libguile/guile-snarf
@ -35,25 +44,33 @@ lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = \
../libguile/libguile.la ../lib/libgnu.la
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic -no-undefined
$(READLINE_LIBS) \
../libguile/libguile.la ../lib/libgnu.la
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = \
-version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic \
-no-undefined
BUILT_SOURCES = readline.x
pkginclude_HEADERS = readline.h
snarfcppopts = $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
snarfcppopts = $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
SUFFIXES = .x
.c.x:
$(GUILE_SNARF) -o $@ $< $(snarfcppopts)
EXTRA_DIST = LIBGUILEREADLINE-VERSION ChangeLog-2008
EXTRA_DIST += LIBGUILEREADLINE-VERSION ChangeLog-2008
MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
ETAGS_ARGS = \
$(nobase_ice9_DATA) \
$(libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES)
CLEANFILES = *.x
endif HAVE_READLINE
dist-hook:
(temp="/tmp/mangle-deps.$$$$"; \
trap "rm -f $$temp" 0 1 2 15; \

8
guile-readline/autogen.sh
View file

@ -1,8 +0,0 @@
#!/bin/sh
[ -f readline-activator.scm ] || {
echo "autogen.sh: run this command only in the guile-readline directory."
exit 1
}
autoreconf -i --force

88
guile-readline/configure.in
View file

@ -1,88 +0,0 @@
AC_PREREQ(2.50)
dnl Don't use "echo -n", which is not portable (e.g., not available on
dnl MacOS X). Instead, use `patsubst' to remove the newline.
AC_INIT(guile-readline,
patsubst(m4_esyscmd(. ../GUILE-VERSION && echo ${GUILE_VERSION}), [
]),
[bug-guile@gnu.org])
AC_CONFIG_AUX_DIR([../build-aux])
AC_CONFIG_SRCDIR(readline.c)
AM_CONFIG_HEADER([guile-readline-config.h])
AM_INIT_AUTOMAKE([foreign no-define])
. $srcdir/../GUILE-VERSION
AC_PROG_INSTALL
AC_PROG_CC
AM_PROG_CC_STDC
AC_LIBTOOL_WIN32_DLL
AC_PROG_LIBTOOL
dnl
dnl Check for Winsock and other functionality on Win32 (*not* CygWin)
dnl
AC_CYGWIN
AC_MINGW32
EXTRA_DEFS=""
if test "$MINGW32" = "yes" ; then
if test $enable_shared = yes ; then
EXTRA_DEFS="-DSCM_IMPORT"
fi
fi
AC_SUBST(EXTRA_DEFS)
for termlib in ncurses curses termcap terminfo termlib ; do
AC_CHECK_LIB(${termlib}, tgoto,
[LIBS="-l${termlib} $LIBS"; break])
done
AC_LIB_LINKFLAGS(readline)
AC_CHECK_LIB(readline, readline)
if test $ac_cv_lib_readline_readline = no; then
AC_MSG_WARN([libreadline was not found on your system.])
fi
AC_CHECK_FUNCS(siginterrupt rl_clear_signals rl_cleanup_after_signal)
dnl Check for modern readline naming
AC_CHECK_FUNCS(rl_filename_completion_function)
dnl Check for rl_get_keymap. We only use this for deciding whether to
dnl install paren matching on the Guile command line (when using
dnl readline for input), so it's completely optional.
AC_CHECK_FUNCS(rl_get_keymap)
AC_CACHE_CHECK([for rl_getc_function pointer in readline],
ac_cv_var_rl_getc_function,
[AC_TRY_LINK([
#include <stdio.h>
#include <readline/readline.h>],
[printf ("%ld", (long) rl_getc_function)],
[ac_cv_var_rl_getc_function=yes],
[ac_cv_var_rl_getc_function=no])])
if test "${ac_cv_var_rl_getc_function}" = "yes"; then
AC_DEFINE(HAVE_RL_GETC_FUNCTION, 1,
[Define if your readline library has the rl_getc_function variable.])
fi
if test $ac_cv_lib_readline_readline = yes \
-a $ac_cv_var_rl_getc_function = no; then
AC_MSG_WARN([*** libreadline is too old on your system.])
AC_MSG_WARN([*** You need readline version 2.1 or later.])
fi
AC_CHECK_FUNCS(strdup)
. $srcdir/LIBGUILEREADLINE-VERSION
AC_SUBST(LIBGUILEREADLINE_MAJOR)
AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
AC_SUBST(LIBGUILEREADLINE_INTERFACE)
AC_SUBST(GUILE_EFFECTIVE_VERSION)
AC_CONFIG_FILES(Makefile ice-9/Makefile)
AC_OUTPUT

28
guile-readline/ice-9/Makefile.am
View file

@ -1,28 +0,0 @@
## Process this file with Automake to create Makefile.in
##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
##
## This file is part of guile-readline.
##
## guile-readline 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 3, or
## (at your option) any later version.
##
## guile-readline 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 guile-readline; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
# Guile's `pkgdatadir'.
guile_pdd = $(datadir)/guile
ice9dir = $(guile_pdd)/$(GUILE_EFFECTIVE_VERSION)/ice-9
ice9_DATA = readline.scm
ETAGS_ARGS = $(ice9_DATA)
EXTRA_DIST = $(ice9_DATA)

8
guile-readline/readline.c
View file

@ -1,6 +1,6 @@
/* readline.c --- line editing support for Guile */
/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009 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
@ -21,9 +21,9 @@
/* Include private, configure generated header (i.e. config.h). */
#include "guile-readline-config.h"
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#ifdef HAVE_RL_GETC_FUNCTION
#include "libguile.h"

5
lang/elisp/interface.scm
View file

@ -20,7 +20,10 @@
(define (eval-elisp x)
"Evaluate the Elisp expression @var{x}."
(eval x the-elisp-module))
(save-module-excursion
(lambda ()
(set-current-module the-elisp-module)
(primitive-eval x))))
(define (translate-elisp x)
"Translate the Elisp expression @var{x} to equivalent Scheme code."

4
lib/Makefile.am
View file

@ -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 --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
# 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 byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
@ -896,6 +896,7 @@ time.h: time.in.h
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@NEXT_TIME_H''@|$(NEXT_TIME_H)|g' \
-e 's|@REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \
-e 's|@REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \
-e 's|@REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \
-e 's|@REPLACE_STRPTIME''@|$(REPLACE_STRPTIME)|g' \
-e 's|@REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
@ -972,6 +973,7 @@ unistd.h: unistd.in.h
-e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \
-e 's|@''REPLACE_CHOWN''@|$(REPLACE_CHOWN)|g' \
-e 's|@''REPLACE_CLOSE''@|$(REPLACE_CLOSE)|g' \
-e 's|@''REPLACE_DUP2''@|$(REPLACE_DUP2)|g' \
-e 's|@''REPLACE_FCHDIR''@|$(REPLACE_FCHDIR)|g' \
-e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \
-e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \

2
lib/iconv_open-aix.h
View file

@ -229,7 +229,7 @@ static const struct mapping mappings[] =
#ifdef __GNUC__
__inline
#ifdef __GNUC_STDC_INLINE__
#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__
__attribute__ ((__gnu_inline__))
#endif
#endif

8
lib/time.in.h
View file

@ -1,6 +1,6 @@
/* A more-standard <time.h>.
Copyright (C) 2007-2008 Free Software Foundation, Inc.
Copyright (C) 2007-2009 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -66,6 +66,12 @@ struct timespec
int nanosleep (struct timespec const *__rqtp, struct timespec *__rmtp);
# endif
/* Return the 'time_t' representation of TP and normalize TP. */
# if @REPLACE_MKTIME@
# define mktime rpl_mktime
extern time_t mktime (struct tm *__tp);
# endif
/* Convert TIMER to RESULT, assuming local time and UTC respectively. See
<http://www.opengroup.org/susv3xsh/localtime_r.html> and
<http://www.opengroup.org/susv3xsh/gmtime_r.html>. */

13
lib/unistd.in.h
View file

@ -150,10 +150,13 @@ extern int close (int);
#if @GNULIB_DUP2@
# if !@HAVE_DUP2@
# if @REPLACE_DUP2@
# define dup2 rpl_dup2
# endif
# if !@HAVE_DUP2@ || @REPLACE_DUP2@
/* Copy the file descriptor OLDFD into file descriptor NEWFD. Do nothing if
NEWFD = OLDFD, otherwise close NEWFD first if it is open.
Return 0 if successful, otherwise -1 and errno set.
Return newfd if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/dup2.html>. */
extern int dup2 (int oldfd, int newfd);
@ -214,7 +217,11 @@ extern int fchdir (int /*fd*/);
# define dup rpl_dup
extern int dup (int);
# define dup2 rpl_dup2
# if @REPLACE_DUP2@
# undef dup2
# endif
# define dup2 rpl_dup2_fchdir
extern int dup2 (int, int);
# endif

9
libguile.h
View file

@ -31,8 +31,12 @@ extern "C" {
#include "libguile/__scm.h"
#include "libguile/alist.h"
#include "libguile/arbiters.h"
#include "libguile/array-handle.h"
#include "libguile/array-map.h"
#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/boolean.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
@ -50,6 +54,8 @@ extern "C" {
#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/guardians.h"
@ -78,7 +84,6 @@ extern "C" {
#include "libguile/properties.h"
#include "libguile/procs.h"
#include "libguile/r6rs-ports.h"
#include "libguile/ramap.h"
#include "libguile/random.h"
#include "libguile/read.h"
#include "libguile/root.h"
@ -101,7 +106,7 @@ extern "C" {
#include "libguile/symbols.h"
#include "libguile/tags.h"
#include "libguile/throw.h"
#include "libguile/unif.h"
#include "libguile/uniform.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/variable.h"

501
libguile/Makefile.am
View file

@ -105,27 +105,109 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
bytevectors.c chars.c continuations.c \
convert.c debug.c deprecation.c \
deprecated.c discouraged.c dynwind.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
gc-freelist.c gc_os_dep.c gdbint.c gettext.c gc-segment-table.c \
goops.c gsubr.c \
guardians.c hash.c hashtab.c hooks.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
print.c procprop.c procs.c properties.c \
r6rs-ports.c random.c rdelim.c read.c \
root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \
stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \
strorder.c strports.c struct.c symbols.c threads.c null-threads.c \
throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
ramap.c unif.c
# vm-related sources
libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c
libguile_la_SOURCES = \
alist.c \
arbiters.c \
array-handle.c \
array-map.c \
arrays.c \
async.c \
backtrace.c \
boolean.c \
bitvectors.c \
bytevectors.c \
chars.c \
continuations.c \
debug.c \
deprecated.c \
deprecation.c \
discouraged.c \
dynwind.c \
eq.c \
error.c \
eval.c \
evalext.c \
extensions.c \
feature.c \
fluids.c \
fports.c \
frames.c \
futures.c \
gc-card.c \
gc-freelist.c \
gc-malloc.c \
gc-mark.c \
gc-segment-table.c \
gc-segment.c \
gc.c \
gc_os_dep.c \
gdbint.c \
gettext.c \
generalized-arrays.c \
generalized-vectors.c \
goops.c \
gsubr.c \
guardians.c \
hash.c \
hashtab.c \
hooks.c \
init.c \
inline.c \
instructions.c \
ioext.c \
keywords.c \
lang.c \
list.c \
load.c \
macros.c \
mallocs.c \
modules.c \
null-threads.c \
numbers.c \
objcodes.c \
objects.c \
objprop.c \
options.c \
pairs.c \
ports.c \
print.c \
procprop.c \
procs.c \
programs.c \
properties.c \
r6rs-ports.c \
random.c \
rdelim.c \
read.c \
root.c \
rw.c \
scmsigs.c \
script.c \
simpos.c \
smob.c \
sort.c \
srcprop.c \
srfi-13.c \
srfi-14.c \
srfi-4.c \
stackchk.c \
stacks.c \
stime.c \
strings.c \
strorder.c \
strports.c \
struct.c \
symbols.c \
threads.c \
throw.c \
uniform.c \
values.c \
variable.c \
vectors.c \
version.c \
vm.c \
vports.c \
weaks.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
@ -136,48 +218,202 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \
bytevectors.x chars.x \
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
dynl.x dynwind.x eq.x error.x eval.x evalext.x \
extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \
gc-segment.x gc-malloc.x gc-card.x gettext.x goops.x \
gsubr.x guardians.x gc-segment-table.x \
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
properties.x r6rs-ports.x random.x rdelim.x \
read.x root.x rw.x scmsigs.x \
script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \
stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \
strports.x struct.x symbols.x threads.x throw.x values.x \
variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x
DOT_X_FILES = \
alist.x \
arbiters.x \
array-handle.x \
array-map.x \
arrays.x \
async.x \
backtrace.x \
boolean.x \
bitvectors.x \
bytevectors.x \
chars.x \
continuations.x \
debug.x \
deprecated.x \
deprecation.x \
discouraged.x \
dynl.x \
dynwind.x \
eq.x \
error.x \
eval.x \
evalext.x \
extensions.x \
feature.x \
fluids.x \
fports.x \
futures.x \
gc-card.x \
gc-malloc.x \
gc-mark.x \
gc-segment-table.x \
gc-segment.x \
gc.x \
gettext.x \
generalized-arrays.x \
generalized-vectors.x \
goops.x \
gsubr.x \
guardians.x \
hash.x \
hashtab.x \
hooks.x \
i18n.x \
init.x \
ioext.x \
keywords.x \
lang.x \
list.x \
load.x \
macros.x \
mallocs.x \
modules.x \
numbers.x \
objects.x \
objprop.x \
options.x \
pairs.x \
ports.x \
print.x \
procprop.x \
procs.x \
properties.x \
r6rs-ports.x \
random.x \
rdelim.x \
read.x \
root.x \
rw.x \
scmsigs.x \
script.x \
simpos.x \
smob.x \
sort.x \
srcprop.x \
srfi-13.x \
srfi-14.x \
srfi-4.x \
stackchk.x \
stacks.x \
stime.x \
strings.x \
strorder.x \
strports.x \
struct.x \
symbols.x \
threads.x \
throw.x \
uniform.x \
values.x \
variable.x \
vectors.x \
version.x \
vports.x \
weaks.x
# vm-related snarfs
DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
boolean.doc bytevectors.doc chars.doc \
continuations.doc debug.doc deprecation.doc \
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \
gc-malloc.doc gc-card.doc gettext.doc gc-segment-table.doc \
guardians.doc hash.doc hashtab.doc \
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
procprop.doc procs.doc properties.doc r6rs-ports.doc \
random.doc rdelim.doc \
read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \
smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \
strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \
strports.doc struct.doc symbols.doc threads.doc throw.doc \
values.doc variable.doc vectors.doc version.doc vports.doc \
weaks.doc ramap.doc unif.doc
DOT_DOC_FILES = \
alist.doc \
arbiters.doc \
array-handle.doc \
array-map.doc \
arrays.doc \
async.doc \
backtrace.doc \
boolean.doc \
bitvectors.doc \
bytevectors.doc \
chars.doc \
continuations.doc \
debug.doc \
deprecated.doc \
deprecation.doc \
discouraged.doc \
dynl.doc \
dynwind.doc \
eq.doc \
error.doc \
eval.doc \
evalext.doc \
extensions.doc \
feature.doc \
fluids.doc \
fports.doc \
futures.doc \
gc-card.doc \
gc-malloc.doc \
gc-mark.doc \
gc-segment-table.doc \
gc-segment.doc \
gc.doc \
gettext.doc \
generalized-arrays.doc \
generalized-vectors.doc \
goops.doc \
gsubr.doc \
guardians.doc \
hash.doc \
hashtab.doc \
hooks.doc \
i18n.doc \
init.doc \
ioext.doc \
keywords.doc \
lang.doc \
list.doc \
load.doc \
macros.doc \
mallocs.doc \
modules.doc \
numbers.doc \
objects.doc \
objprop.doc \
options.doc \
pairs.doc \
ports.doc \
print.doc \
procprop.doc \
procs.doc \
properties.doc \
r6rs-ports.doc \
random.doc \
rdelim.doc \
read.doc \
root.doc \
rw.doc \
scmsigs.doc \
script.doc \
simpos.doc \
smob.doc \
sort.doc \
srcprop.doc \
srfi-13.doc \
srfi-14.doc \
srfi-4.doc \
stackchk.doc \
stacks.doc \
stime.doc \
strings.doc \
strorder.doc \
strports.doc \
struct.doc \
symbols.doc \
threads.doc \
throw.doc \
uniform.doc \
values.doc \
variable.doc \
vectors.doc \
version.doc \
vports.doc \
weaks.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
@ -208,10 +444,9 @@ install-exec-hook:
## compile, since they are #included. So instead we list them here.
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
eval.i.c ieee-754.h \
srfi-4.i.c \
srfi-4.i.c srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
private-gc.h private-options.h
@ -220,36 +455,134 @@ noinst_HEADERS = convert.i.c \
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
if HAVE_LD_VERSION_SCRIPT
libguile_la_LDFLAGS += -Wl,--version-script="$(srcdir)/libguile.map"
endif HAVE_LD_VERSION_SCRIPT
# These are headers visible as <guile/mumble.h>
pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
boolean.h bytevectors.h chars.h continuations.h convert.h \
debug.h debug-malloc.h \
deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \
eq.h error.h eval.h evalext.h extensions.h \
feature.h filesys.h fluids.h fports.h futures.h gc.h \
gdb_interface.h gdbint.h gettext.h goops.h \
gsubr.h guardians.h hash.h \
hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \
keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \
posix.h r6rs-ports.h regex-posix.h print.h \
procprop.h procs.h properties.h \
random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \
script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \
stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \
strorder.h strports.h struct.h symbols.h tags.h threads.h \
pthread-threads.h null-threads.h throw.h unif.h values.h \
variable.h vectors.h vports.h weaks.h
modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h \
programs.h vm.h vm-engine.h vm-expand.h
modinclude_HEADERS = \
__scm.h \
alist.h \
arbiters.h \
array-handle.h \
array-map.h \
arrays.h \
async.h \
backtrace.h \
boolean.h \
bitvectors.h \
bytevectors.h \
chars.h \
continuations.h \
debug-malloc.h \
debug.h \
deprecated.h \
deprecation.h \
discouraged.h \
dynl.h \
dynwind.h \
eq.h \
error.h \
eval.h \
evalext.h \
extensions.h \
feature.h \
filesys.h \
fluids.h \
fports.h \
frames.h \
futures.h \
gc.h \
gdb_interface.h \
gdbint.h \
gettext.h \
generalized-arrays.h \
generalized-vectors.h \
goops.h \
gsubr.h \
guardians.h \
hash.h \
hashtab.h \
hooks.h \
i18n.h \
init.h \
inline.h \
instructions.h \
ioext.h \
iselect.h \
keywords.h \
lang.h \
list.h \
load.h \
macros.h \
mallocs.h \
modules.h \
net_db.h \
null-threads.h \
numbers.h \
objcodes.h \
objects.h \
objprop.h \
options.h \
pairs.h \
ports.h \
posix.h \
print.h \
procprop.h \
procs.h \
programs.h \
properties.h \
pthread-threads.h \
r6rs-ports.h \
random.h \
rdelim.h \
read.h \
regex-posix.h \
root.h \
rw.h \
scmsigs.h \
script.h \
simpos.h \
smob.h \
snarf.h \
socket.h \
sort.h \
srcprop.h \
srfi-13.h \
srfi-14.h \
srfi-4.h \
stackchk.h \
stacks.h \
stime.h \
strings.h \
strorder.h \
strports.h \
struct.h \
symbols.h \
tags.h \
threads.h \
throw.h \
validate.h \
uniform.h \
values.h \
variable.h \
vectors.h \
vm-bootstrap.h \
vm-engine.h \
vm-expand.h \
vm.h \
vports.h \
weaks.h
nodist_modinclude_HEADERS = version.h scmconfig.h
@ -264,7 +597,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
c-tokenize.lex version.h.in \
scmconfig.h.top libgettext.h
scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi

24
libguile/__scm.h
View file

@ -423,19 +423,28 @@
typedef struct {
ucontext_t ctx;
int fresh;
} jmp_buf;
# define setjmp(JB) \
} scm_i_jmp_buf;
# define SCM_I_SETJMP(JB) \
( (JB).fresh = 1, \
getcontext (&((JB).ctx)), \
((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
# define longjmp(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
void scm_ia64_longjmp (jmp_buf *, int);
# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
void scm_ia64_longjmp (scm_i_jmp_buf *, int);
# else /* ndef __ia64__ */
# include <setjmp.h>
# endif /* ndef __ia64__ */
# endif /* ndef _CRAY1 */
#endif /* ndef vms */
/* For any platform where SCM_I_SETJMP hasn't been defined in some
special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and
scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */
#ifndef SCM_I_SETJMP
#define scm_i_jmp_buf jmp_buf
#define SCM_I_SETJMP setjmp
#define SCM_I_LONGJMP longjmp
#endif
/* James Clark came up with this neat one instruction fix for
* continuations on the SPARC. It flushes the register windows so
* that all the state of the process is contained in the stack.
@ -556,6 +565,13 @@ SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
return (SCM_UNPACK (gf) \
? scm_call_generic_1 ((gf), (a1)) \
: (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
/* This form is for dispatching a subroutine. */
#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
: (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
if (SCM_UNLIKELY (!(cond))) \
SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))

33
libguile/_scm.h
View file

@ -3,7 +3,7 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,2000,2001, 2002, 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 License
@ -59,6 +59,7 @@
#endif
#include <errno.h>
#include <verify.h>
#include "libguile/__scm.h"
/* Include headers for those files central to the implementation. The
@ -156,6 +157,36 @@
#define scm_from_off64_t scm_from_int64
/* The endianness marker in objcode. */
#ifdef WORDS_BIGENDIAN
# define SCM_OBJCODE_ENDIANNESS "BE"
#else
# define SCM_OBJCODE_ENDIANNESS "LE"
#endif
#define _SCM_CPP_STRINGIFY(x) # x
#define SCM_CPP_STRINGIFY(x) _SCM_CPP_STRINGIFY (x)
/* The word size marker in objcode. */
#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
#define SCM_OBJCODE_MINOR_VERSION D
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MINOR_VERSION)
#define SCM_OBJCODE_VERSION_STRING \
SCM_OBJCODE_MAJOR_VERSION_STRING "." SCM_OBJCODE_MINOR_VERSION_STRING
#define SCM_OBJCODE_MACHINE_VERSION_STRING \
SCM_OBJCODE_VERSION_STRING "-" SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE
/* The objcode magic header. */
#define SCM_OBJCODE_COOKIE \
"GOOF-" SCM_OBJCODE_MACHINE_VERSION_STRING "---"
#endif /* SCM__SCM_H */
/*

162
libguile/array-handle.c Normal file
View file

@ -0,0 +1,162 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/array-handle.h"
SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
#define ARRAY_IMPLS_N_STATIC_ALLOC 7
static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC];
static int num_array_impls_registered = 0;
void
scm_i_register_array_implementation (scm_t_array_implementation *impl)
{
if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
/* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
abort ();
else
array_impls[num_array_impls_registered++] = *impl;
}
scm_t_array_implementation*
scm_i_array_implementation_for_obj (SCM obj)
{
int i;
for (i = 0; i < num_array_impls_registered; i++)
if (SCM_NIMP (obj)
&& (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
return &array_impls[i];
return NULL;
}
void
scm_array_get_handle (SCM array, scm_t_array_handle *h)
{
scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
if (!impl)
scm_wrong_type_arg_msg (NULL, 0, array, "array");
h->array = array;
h->impl = impl;
h->base = 0;
h->ndims = 0;
h->dims = NULL;
h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
something... */
h->elements = NULL;
h->writable_elements = NULL;
h->impl->get_handle (array, h);
}
ssize_t
scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
{
scm_t_array_dim *s = scm_array_handle_dims (h);
ssize_t pos = 0, i;
size_t k = scm_array_handle_rank (h);
while (k > 0 && scm_is_pair (indices))
{
i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
pos += (i - s->lbnd) * s->inc;
k--;
s++;
indices = SCM_CDR (indices);
}
if (k > 0 || !scm_is_null (indices))
scm_misc_error (NULL, "wrong number of indices, expecting ~a",
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
return pos;
}
SCM
scm_array_handle_element_type (scm_t_array_handle *h)
{
if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
abort (); /* guile programming error */
return scm_i_array_element_types[h->element_type];
}
void
scm_array_handle_release (scm_t_array_handle *h)
{
/* Nothing to do here until arrays need to be reserved for real.
*/
}
const SCM *
scm_array_handle_elements (scm_t_array_handle *h)
{
if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
return ((const SCM*)h->elements) + h->base;
}
SCM *
scm_array_handle_writable_elements (scm_t_array_handle *h)
{
if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
return ((SCM*)h->elements) + h->base;
}
void
scm_init_array_handle (void)
{
#define DEFINE_ARRAY_TYPE(tag, TAG) \
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \
= (scm_permanent_object (scm_from_locale_symbol (#tag)))
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
DEFINE_ARRAY_TYPE (a, CHAR);
DEFINE_ARRAY_TYPE (b, BIT);
DEFINE_ARRAY_TYPE (vu8, VU8);
DEFINE_ARRAY_TYPE (u8, U8);
DEFINE_ARRAY_TYPE (s8, S8);
DEFINE_ARRAY_TYPE (u16, U16);
DEFINE_ARRAY_TYPE (s16, S16);
DEFINE_ARRAY_TYPE (u32, U32);
DEFINE_ARRAY_TYPE (s32, S32);
DEFINE_ARRAY_TYPE (u64, U64);
DEFINE_ARRAY_TYPE (s64, S64);
DEFINE_ARRAY_TYPE (f32, F32);
DEFINE_ARRAY_TYPE (f64, F64);
DEFINE_ARRAY_TYPE (c32, C32);
DEFINE_ARRAY_TYPE (c64, C64);
#include "libguile/array-handle.x"
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

129
libguile/array-handle.h Normal file
View file

@ -0,0 +1,129 @@
/* classes: h_files */
#ifndef SCM_ARRAY_HANDLE_H
#define SCM_ARRAY_HANDLE_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
struct scm_t_array_handle;
typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t);
typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM);
typedef struct
{
scm_t_bits tag;
scm_t_bits mask;
scm_i_t_array_ref vref;
scm_i_t_array_set vset;
void (*get_handle)(SCM, struct scm_t_array_handle*);
} scm_t_array_implementation;
#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \
SCM_SNARF_INIT ({ \
scm_t_array_implementation impl; \
impl.tag = tag_; impl.mask = mask_; \
impl.vref = vref_; impl.vset = vset_; \
impl.get_handle = handle_; \
scm_i_register_array_implementation (&impl); \
})
SCM_INTERNAL void scm_i_register_array_implementation (scm_t_array_implementation *impl);
SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj (SCM obj);
typedef struct scm_t_array_dim
{
ssize_t lbnd;
ssize_t ubnd;
ssize_t inc;
} scm_t_array_dim;
typedef enum {
SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */
SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */
SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */
SCM_ARRAY_ELEMENT_TYPE_VU8 = 3,
SCM_ARRAY_ELEMENT_TYPE_U8 = 4,
SCM_ARRAY_ELEMENT_TYPE_S8 = 5,
SCM_ARRAY_ELEMENT_TYPE_U16 = 6,
SCM_ARRAY_ELEMENT_TYPE_S16 = 7,
SCM_ARRAY_ELEMENT_TYPE_U32 = 8,
SCM_ARRAY_ELEMENT_TYPE_S32 = 9,
SCM_ARRAY_ELEMENT_TYPE_U64 = 10,
SCM_ARRAY_ELEMENT_TYPE_S64 = 11,
SCM_ARRAY_ELEMENT_TYPE_F32 = 12,
SCM_ARRAY_ELEMENT_TYPE_F64 = 13,
SCM_ARRAY_ELEMENT_TYPE_C32 = 14,
SCM_ARRAY_ELEMENT_TYPE_C64 = 15,
SCM_ARRAY_ELEMENT_TYPE_LAST = 15,
} scm_t_array_element_type;
SCM_INTERNAL SCM scm_i_array_element_types[];
typedef struct scm_t_array_handle {
SCM array;
scm_t_array_implementation *impl;
/* `Base' is an offset into elements or writable_elements, corresponding to
the first element in the array. It would be nicer just to adjust the
elements/writable_elements pointer, but we can't because that element might
not even be byte-addressable, as is the case with bitvectors. A nicer
solution would be, well, nice.
*/
size_t base;
size_t ndims; /* ndims == the rank of the array */
scm_t_array_dim *dims;
scm_t_array_dim dim0;
scm_t_array_element_type element_type;
const void *elements;
void *writable_elements;
} scm_t_array_handle;
#define scm_array_handle_rank(h) ((h)->ndims)
#define scm_array_handle_dims(h) ((h)->dims)
SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h);
SCM_API void scm_array_handle_release (scm_t_array_handle *h);
SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h);
SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h);
/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
SCM_INTERNAL void scm_init_array_handle (void);
#endif /* SCM_ARRAY_HANDLE_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

25
libguile/ramap.c → libguile/array-map.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 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 License
@ -17,10 +17,6 @@
*/
/*
HWN:FIXME::
Someone should rename this to arraymap.c; that would reflect the
contents better. */
@ -31,7 +27,7 @@
#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/unif.h"
#include "libguile/arrays.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
#include "libguile/eq.h"
@ -39,11 +35,14 @@
#include "libguile/feature.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h"
#include "libguile/dynwind.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
#include "libguile/ramap.h"
#include "libguile/array-map.h"
typedef struct
@ -223,7 +222,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
if (!SCM_I_ARRAYP (vra0))
{
size_t length = scm_c_generalized_vector_length (vra0);
vra1 = scm_i_make_ra (1, 0);
vra1 = scm_i_make_array (1);
SCM_I_ARRAY_BASE (vra1) = 0;
SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
@ -236,7 +235,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_ra (1, 0);
vra1 = scm_i_make_array (1);
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
if (!SCM_I_ARRAYP (ra1))
@ -259,7 +258,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
case 1:
gencase: /* Have to loop over all dimensions. */
vra0 = scm_i_make_ra (1, 0);
vra0 = scm_i_make_array (1);
if (SCM_I_ARRAYP (ra0))
{
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
@ -294,7 +293,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_ra (1, 0);
vra1 = scm_i_make_array (1);
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
if (SCM_I_ARRAYP (ra1))
@ -1222,13 +1221,13 @@ init_raprocs (ra_iproc *subra)
void
scm_init_ramap ()
scm_init_array_map (void)
{
init_raprocs (ra_rpsubrs);
init_raprocs (ra_asubrs);
scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/ramap.x"
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
}

10
libguile/ramap.h → libguile/array-map.h
View file

@ -1,9 +1,9 @@
/* classes: h_files */
#ifndef SCM_RAMAP_H
#define SCM_RAMAP_H
#ifndef SCM_ARRAY_MAP_H
#define SCM_ARRAY_MAP_H
/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,2000, 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 License
@ -48,9 +48,9 @@ SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_raequal (SCM ra0, SCM ra1);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_ramap (void);
SCM_INTERNAL void scm_init_array_map (void);
#endif /* SCM_RAMAP_H */
#endif /* SCM_ARRAY_MAP_H */
/*
Local Variables:

1156
libguile/arrays.c Normal file
View file

File diff suppressed because it is too large Load diff

91
libguile/arrays.h Normal file
View file

@ -0,0 +1,91 @@
/* classes: h_files */
#ifndef SCM_ARRAY_H
#define SCM_ARRAY_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
#include "libguile/print.h"
/* Multidimensional arrays. Woo hoo!
Also see ....
*/
/** Arrays */
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
const void *bytes,
size_t byte_len);
SCM_API SCM scm_shared_array_root (SCM ra);
SCM_API SCM scm_shared_array_offset (SCM ra);
SCM_API SCM scm_shared_array_increments (SCM ra);
SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict);
SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
SCM start, SCM end);
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
SCM_API SCM scm_ra2contig (SCM ra, int copy);
/* internal. */
typedef struct scm_i_t_array
{
SCM v; /* the contents of the array, e.g., a vector or uniform vector. */
unsigned long base;
} scm_i_t_array;
SCM_API scm_t_bits scm_i_tc16_array;
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
#define SCM_I_ARRAY_DIMS(a) \
((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
SCM_INTERNAL SCM scm_i_make_array (int ndim);
SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
SCM_INTERNAL void scm_init_arrays (void);
#endif /* SCM_ARRAYS_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

910
libguile/bitvectors.c Normal file
View file

@ -0,0 +1,910 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/smob.h"
#include "libguile/strings.h"
#include "libguile/array-handle.h"
#include "libguile/bitvectors.h"
#include "libguile/arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/srfi-4.h"
/* Bit vectors. Would be nice if they were implemented on top of bytevectors,
* but alack, all we have is this crufty C.
*/
static scm_t_bits scm_tc16_bitvector;
#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
static size_t
bitvector_free (SCM vec)
{
scm_gc_free (BITVECTOR_BITS (vec),
sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
"bitvector");
return 0;
}
static int
bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
{
size_t bit_len = BITVECTOR_LENGTH (vec);
size_t word_len = (bit_len+31)/32;
scm_t_uint32 *bits = BITVECTOR_BITS (vec);
size_t i, j;
scm_puts ("#*", port);
for (i = 0; i < word_len; i++, bit_len -= 32)
{
scm_t_uint32 mask = 1;
for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
scm_putc ((bits[i] & mask)? '1' : '0', port);
}
return 1;
}
static SCM
bitvector_equalp (SCM vec1, SCM vec2)
{
size_t bit_len = BITVECTOR_LENGTH (vec1);
size_t word_len = (bit_len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
/* compare lengths */
if (BITVECTOR_LENGTH (vec2) != bit_len)
return SCM_BOOL_F;
/* avoid underflow in word_len-1 below. */
if (bit_len == 0)
return SCM_BOOL_T;
/* compare full words */
if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
return SCM_BOOL_F;
/* compare partial last words */
if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
return SCM_BOOL_F;
return SCM_BOOL_T;
}
int
scm_is_bitvector (SCM vec)
{
return IS_BITVECTOR (vec);
}
SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
(SCM obj),
"Return @code{#t} when @var{obj} is a bitvector, else\n"
"return @code{#f}.")
#define FUNC_NAME s_scm_bitvector_p
{
return scm_from_bool (scm_is_bitvector (obj));
}
#undef FUNC_NAME
SCM
scm_c_make_bitvector (size_t len, SCM fill)
{
size_t word_len = (len + 31) / 32;
scm_t_uint32 *bits;
SCM res;
bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
"bitvector");
SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
if (!SCM_UNBNDP (fill))
scm_bitvector_fill_x (res, fill);
return res;
}
SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
(SCM len, SCM fill),
"Create a new bitvector of length @var{len} and\n"
"optionally initialize all elements to @var{fill}.")
#define FUNC_NAME s_scm_make_bitvector
{
return scm_c_make_bitvector (scm_to_size_t (len), fill);
}
#undef FUNC_NAME
SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
(SCM bits),
"Create a new bitvector with the arguments as elements.")
#define FUNC_NAME s_scm_bitvector
{
return scm_list_to_bitvector (bits);
}
#undef FUNC_NAME
size_t
scm_c_bitvector_length (SCM vec)
{
scm_assert_smob_type (scm_tc16_bitvector, vec);
return BITVECTOR_LENGTH (vec);
}
SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
(SCM vec),
"Return the length of the bitvector @var{vec}.")
#define FUNC_NAME s_scm_bitvector_length
{
return scm_from_size_t (scm_c_bitvector_length (vec));
}
#undef FUNC_NAME
const scm_t_uint32 *
scm_array_handle_bit_elements (scm_t_array_handle *h)
{
return scm_array_handle_bit_writable_elements (h);
}
scm_t_uint32 *
scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
{
SCM vec = h->array;
if (SCM_I_ARRAYP (vec))
vec = SCM_I_ARRAY_V (vec);
if (IS_BITVECTOR (vec))
return BITVECTOR_BITS (vec) + h->base/32;
scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
}
size_t
scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
{
return h->base % 32;
}
const scm_t_uint32 *
scm_bitvector_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp)
{
return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
}
scm_t_uint32 *
scm_bitvector_writable_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp)
{
scm_generalized_vector_get_handle (vec, h);
if (offp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*offp = scm_array_handle_bit_elements_offset (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_bit_writable_elements (h);
}
SCM
scm_c_bitvector_ref (SCM vec, size_t idx)
{
scm_t_array_handle handle;
const scm_t_uint32 *bits;
if (IS_BITVECTOR (vec))
{
if (idx >= BITVECTOR_LENGTH (vec))
scm_out_of_range (NULL, scm_from_size_t (idx));
bits = BITVECTOR_BITS(vec);
return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
}
else
{
SCM res;
size_t len, off;
ssize_t inc;
bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
if (idx >= len)
scm_out_of_range (NULL, scm_from_size_t (idx));
idx = idx*inc + off;
res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
scm_array_handle_release (&handle);
return res;
}
}
SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
(SCM vec, SCM idx),
"Return the element at index @var{idx} of the bitvector\n"
"@var{vec}.")
#define FUNC_NAME s_scm_bitvector_ref
{
return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
}
#undef FUNC_NAME
void
scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
{
scm_t_array_handle handle;
scm_t_uint32 *bits, mask;
if (IS_BITVECTOR (vec))
{
if (idx >= BITVECTOR_LENGTH (vec))
scm_out_of_range (NULL, scm_from_size_t (idx));
bits = BITVECTOR_BITS(vec);
}
else
{
size_t len, off;
ssize_t inc;
bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
if (idx >= len)
scm_out_of_range (NULL, scm_from_size_t (idx));
idx = idx*inc + off;
}
mask = 1L << (idx%32);
if (scm_is_true (val))
bits[idx/32] |= mask;
else
bits[idx/32] &= ~mask;
if (!IS_BITVECTOR (vec))
scm_array_handle_release (&handle);
}
SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
(SCM vec, SCM idx, SCM val),
"Set the element at index @var{idx} of the bitvector\n"
"@var{vec} when @var{val} is true, else clear it.")
#define FUNC_NAME s_scm_bitvector_set_x
{
scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
(SCM vec, SCM val),
"Set all elements of the bitvector\n"
"@var{vec} when @var{val} is true, else clear them.")
#define FUNC_NAME s_scm_bitvector_fill_x
{
scm_t_array_handle handle;
size_t off, len;
ssize_t inc;
scm_t_uint32 *bits;
bits = scm_bitvector_writable_elements (vec, &handle,
&off, &len, &inc);
if (off == 0 && inc == 1 && len > 0)
{
/* the usual case
*/
size_t word_len = (len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
if (scm_is_true (val))
{
memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
bits[word_len-1] |= last_mask;
}
else
{
memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
bits[word_len-1] &= ~last_mask;
}
}
else
{
size_t i;
for (i = 0; i < len; i++)
scm_array_handle_set (&handle, i*inc, val);
}
scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
(SCM list),
"Return a new bitvector initialized with the elements\n"
"of @var{list}.")
#define FUNC_NAME s_scm_list_to_bitvector
{
size_t bit_len = scm_to_size_t (scm_length (list));
SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
size_t word_len = (bit_len+31)/32;
scm_t_array_handle handle;
scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
NULL, NULL, NULL);
size_t i, j;
for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
{
scm_t_uint32 mask = 1;
bits[i] = 0;
for (j = 0; j < 32 && j < bit_len;
j++, mask <<= 1, list = SCM_CDR (list))
if (scm_is_true (SCM_CAR (list)))
bits[i] |= mask;
}
scm_array_handle_release (&handle);
return vec;
}
#undef FUNC_NAME
SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
(SCM vec),
"Return a new list initialized with the elements\n"
"of the bitvector @var{vec}.")
#define FUNC_NAME s_scm_bitvector_to_list
{
scm_t_array_handle handle;
size_t off, len;
ssize_t inc;
scm_t_uint32 *bits;
SCM res = SCM_EOL;
bits = scm_bitvector_writable_elements (vec, &handle,
&off, &len, &inc);
if (off == 0 && inc == 1)
{
/* the usual case
*/
size_t word_len = (len + 31) / 32;
size_t i, j;
for (i = 0; i < word_len; i++, len -= 32)
{
scm_t_uint32 mask = 1;
for (j = 0; j < 32 && j < len; j++, mask <<= 1)
res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
}
}
else
{
size_t i;
for (i = 0; i < len; i++)
res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
}
scm_array_handle_release (&handle);
return scm_reverse_x (res, SCM_EOL);
}
#undef FUNC_NAME
/* From mmix-arith.w by Knuth.
Here's a fun way to count the number of bits in a tetrabyte.
[This classical trick is called the ``Gillies--Miller method for
sideways addition'' in {\sl The Preparation of Programs for an
Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
the tricks used here were suggested by Balbir Singh, Peter
Rossmanith, and Stefan Schwoon.]
*/
static size_t
count_ones (scm_t_uint32 x)
{
x=x-((x>>1)&0x55555555);
x=(x&0x33333333)+((x>>2)&0x33333333);
x=(x+(x>>4))&0x0f0f0f0f;
x=x+(x>>8);
return (x+(x>>16)) & 0xff;
}
SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
(SCM b, SCM bitvector),
"Return the number of occurrences of the boolean @var{b} in\n"
"@var{bitvector}.")
#define FUNC_NAME s_scm_bit_count
{
scm_t_array_handle handle;
size_t off, len;
ssize_t inc;
scm_t_uint32 *bits;
int bit = scm_to_bool (b);
size_t count = 0;
bits = scm_bitvector_writable_elements (bitvector, &handle,
&off, &len, &inc);
if (off == 0 && inc == 1 && len > 0)
{
/* the usual case
*/
size_t word_len = (len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
size_t i;
for (i = 0; i < word_len-1; i++)
count += count_ones (bits[i]);
count += count_ones (bits[i] & last_mask);
}
else
{
size_t i;
for (i = 0; i < len; i++)
if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
count++;
}
scm_array_handle_release (&handle);
return scm_from_size_t (bit? count : len-count);
}
#undef FUNC_NAME
/* returns 32 for x == 0.
*/
static size_t
find_first_one (scm_t_uint32 x)
{
size_t pos = 0;
/* do a binary search in x. */
if ((x & 0xFFFF) == 0)
x >>= 16, pos += 16;
if ((x & 0xFF) == 0)
x >>= 8, pos += 8;
if ((x & 0xF) == 0)
x >>= 4, pos += 4;
if ((x & 0x3) == 0)
x >>= 2, pos += 2;
if ((x & 0x1) == 0)
pos += 1;
return pos;
}
SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
(SCM item, SCM v, SCM k),
"Return the index of the first occurrance of @var{item} in bit\n"
"vector @var{v}, starting from @var{k}. If there is no\n"
"@var{item} entry between @var{k} and the end of\n"
"@var{bitvector}, then return @code{#f}. For example,\n"
"\n"
"@example\n"
"(bit-position #t #*000101 0) @result{} 3\n"
"(bit-position #f #*0001111 3) @result{} #f\n"
"@end example")
#define FUNC_NAME s_scm_bit_position
{
scm_t_array_handle handle;
size_t off, len, first_bit;
ssize_t inc;
const scm_t_uint32 *bits;
int bit = scm_to_bool (item);
SCM res = SCM_BOOL_F;
bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
first_bit = scm_to_unsigned_integer (k, 0, len);
if (off == 0 && inc == 1 && len > 0)
{
size_t i, word_len = (len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
size_t first_word = first_bit / 32;
scm_t_uint32 first_mask =
((scm_t_uint32)-1) << (first_bit - 32*first_word);
scm_t_uint32 w;
for (i = first_word; i < word_len; i++)
{
w = (bit? bits[i] : ~bits[i]);
if (i == first_word)
w &= first_mask;
if (i == word_len-1)
w &= last_mask;
if (w)
{
res = scm_from_size_t (32*i + find_first_one (w));
break;
}
}
}
else
{
size_t i;
for (i = first_bit; i < len; i++)
{
SCM elt = scm_array_handle_ref (&handle, i*inc);
if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
{
res = scm_from_size_t (i);
break;
}
}
}
scm_array_handle_release (&handle);
return res;
}
#undef FUNC_NAME
SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
(SCM v, SCM kv, SCM obj),
"Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
"selecting the entries to change. The return value is\n"
"unspecified.\n"
"\n"
"If @var{kv} is a bit vector, then those entries where it has\n"
"@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
"@var{kv} and @var{v} must be the same length. When @var{obj}\n"
"is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
"@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
"\n"
"@example\n"
"(define bv #*01000010)\n"
"(bit-set*! bv #*10010001 #t)\n"
"bv\n"
"@result{} #*11010011\n"
"@end example\n"
"\n"
"If @var{kv} is a u32vector, then its elements are\n"
"indices into @var{v} which are set to @var{obj}.\n"
"\n"
"@example\n"
"(define bv #*01000010)\n"
"(bit-set*! bv #u32(5 2 7) #t)\n"
"bv\n"
"@result{} #*01100111\n"
"@end example")
#define FUNC_NAME s_scm_bit_set_star_x
{
scm_t_array_handle v_handle;
size_t v_off, v_len;
ssize_t v_inc;
scm_t_uint32 *v_bits;
int bit;
/* Validate that OBJ is a boolean so this is done even if we don't
need BIT.
*/
bit = scm_to_bool (obj);
v_bits = scm_bitvector_writable_elements (v, &v_handle,
&v_off, &v_len, &v_inc);
if (scm_is_bitvector (kv))
{
scm_t_array_handle kv_handle;
size_t kv_off, kv_len;
ssize_t kv_inc;
const scm_t_uint32 *kv_bits;
kv_bits = scm_bitvector_elements (v, &kv_handle,
&kv_off, &kv_len, &kv_inc);
if (v_len != kv_len)
scm_misc_error (NULL,
"bit vectors must have equal length",
SCM_EOL);
if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
{
size_t word_len = (kv_len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
size_t i;
if (bit == 0)
{
for (i = 0; i < word_len-1; i++)
v_bits[i] &= ~kv_bits[i];
v_bits[i] &= ~(kv_bits[i] & last_mask);
}
else
{
for (i = 0; i < word_len-1; i++)
v_bits[i] |= kv_bits[i];
v_bits[i] |= kv_bits[i] & last_mask;
}
}
else
{
size_t i;
for (i = 0; i < kv_len; i++)
if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
scm_array_handle_set (&v_handle, i*v_inc, obj);
}
scm_array_handle_release (&kv_handle);
}
else if (scm_is_true (scm_u32vector_p (kv)))
{
scm_t_array_handle kv_handle;
size_t i, kv_len;
ssize_t kv_inc;
const scm_t_uint32 *kv_elts;
kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
scm_array_handle_release (&kv_handle);
}
else
scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
scm_array_handle_release (&v_handle);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
(SCM v, SCM kv, SCM obj),
"Return a count of how many entries in bit vector @var{v} are\n"
"equal to @var{obj}, with @var{kv} selecting the entries to\n"
"consider.\n"
"\n"
"If @var{kv} is a bit vector, then those entries where it has\n"
"@code{#t} are the ones in @var{v} which are considered.\n"
"@var{kv} and @var{v} must be the same length.\n"
"\n"
"If @var{kv} is a u32vector, then it contains\n"
"the indexes in @var{v} to consider.\n"
"\n"
"For example,\n"
"\n"
"@example\n"
"(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
"(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
"@end example")
#define FUNC_NAME s_scm_bit_count_star
{
scm_t_array_handle v_handle;
size_t v_off, v_len;
ssize_t v_inc;
const scm_t_uint32 *v_bits;
size_t count = 0;
int bit;
/* Validate that OBJ is a boolean so this is done even if we don't
need BIT.
*/
bit = scm_to_bool (obj);
v_bits = scm_bitvector_elements (v, &v_handle,
&v_off, &v_len, &v_inc);
if (scm_is_bitvector (kv))
{
scm_t_array_handle kv_handle;
size_t kv_off, kv_len;
ssize_t kv_inc;
const scm_t_uint32 *kv_bits;
kv_bits = scm_bitvector_elements (v, &kv_handle,
&kv_off, &kv_len, &kv_inc);
if (v_len != kv_len)
scm_misc_error (NULL,
"bit vectors must have equal length",
SCM_EOL);
if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
{
size_t i, word_len = (kv_len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
for (i = 0; i < word_len-1; i++)
count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
}
else
{
size_t i;
for (i = 0; i < kv_len; i++)
if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
{
SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
count++;
}
}
scm_array_handle_release (&kv_handle);
}
else if (scm_is_true (scm_u32vector_p (kv)))
{
scm_t_array_handle kv_handle;
size_t i, kv_len;
ssize_t kv_inc;
const scm_t_uint32 *kv_elts;
kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
{
SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
count++;
}
scm_array_handle_release (&kv_handle);
}
else
scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
scm_array_handle_release (&v_handle);
return scm_from_size_t (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
(SCM v),
"Modify the bit vector @var{v} by replacing each element with\n"
"its negation.")
#define FUNC_NAME s_scm_bit_invert_x
{
scm_t_array_handle handle;
size_t off, len;
ssize_t inc;
scm_t_uint32 *bits;
bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
if (off == 0 && inc == 1 && len > 0)
{
size_t word_len = (len + 31) / 32;
scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
size_t i;
for (i = 0; i < word_len-1; i++)
bits[i] = ~bits[i];
bits[i] = bits[i] ^ last_mask;
}
else
{
size_t i;
for (i = 0; i < len; i++)
scm_array_handle_set (&handle, i*inc,
scm_not (scm_array_handle_ref (&handle, i*inc)));
}
scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM
scm_istr2bve (SCM str)
{
scm_t_array_handle handle;
size_t len = scm_i_string_length (str);
SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
SCM res = vec;
scm_t_uint32 mask;
size_t k, j;
const char *c_str;
scm_t_uint32 *data;
data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
c_str = scm_i_string_chars (str);
for (k = 0; k < (len + 31) / 32; k++)
{
data[k] = 0L;
j = len - k * 32;
if (j > 32)
j = 32;
for (mask = 1L; j--; mask <<= 1)
switch (*c_str++)
{
case '0':
break;
case '1':
data[k] |= mask;
break;
default:
res = SCM_BOOL_F;
goto exit;
}
}
exit:
scm_array_handle_release (&handle);
scm_remember_upto_here_1 (str);
return res;
}
/* FIXME: h->array should be h->vector */
static SCM
bitvector_handle_ref (scm_t_array_handle *h, size_t pos)
{
return scm_c_bitvector_ref (h->array, pos);
}
static void
bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
{
scm_c_bitvector_set_x (h->array, pos, val);
}
static void
bitvector_get_handle (SCM bv, scm_t_array_handle *h)
{
h->array = bv;
h->ndims = 1;
h->dims = &h->dim0;
h->dim0.lbnd = 0;
h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1;
h->dim0.inc = 1;
h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT;
h->elements = h->writable_elements = BITVECTOR_BITS (bv);
}
SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff,
bitvector_handle_ref, bitvector_handle_set,
bitvector_get_handle);
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector);
void
scm_init_bitvectors ()
{
scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
#include "libguile/bitvectors.x"
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

81
libguile/bitvectors.h Normal file
View file

@ -0,0 +1,81 @@
/* classes: h_files */
#ifndef SCM_BITVECTORS_H
#define SCM_BITVECTORS_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 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 License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
#include "libguile/array-handle.h"
/* Bitvectors. Exciting stuff, maybe!
*/
/** Bit vectors */
SCM_API SCM scm_bitvector_p (SCM vec);
SCM_API SCM scm_bitvector (SCM bits);
SCM_API SCM scm_make_bitvector (SCM len, SCM fill);
SCM_API SCM scm_bitvector_length (SCM vec);
SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx);
SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val);
SCM_API SCM scm_list_to_bitvector (SCM list);
SCM_API SCM scm_bitvector_to_list (SCM vec);
SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val);
SCM_API SCM scm_bit_count (SCM item, SCM seq);
SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k);
SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
SCM_API SCM scm_bit_invert_x (SCM v);
SCM_API SCM scm_istr2bve (SCM str);
SCM_API int scm_is_bitvector (SCM obj);
SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill);
SCM_API size_t scm_c_bitvector_length (SCM vec);
SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx);
SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val);
SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h);
SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h);
SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h);
SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp);
SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
scm_t_array_handle *h,
size_t *offp,
size_t *lenp,
ssize_t *incp);
SCM_INTERNAL void scm_init_bitvectors (void);
#endif /* SCM_BITVECTORS_H */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

318
libguile/bytevectors.c
View file

@ -31,7 +31,9 @@
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/ieee-754.h"
#include "libguile/unif.h"
#include "libguile/arrays.h"
#include "libguile/array-handle.h"
#include "libguile/uniform.h"
#include "libguile/srfi-4.h"
#include <byteswap.h>
@ -175,47 +177,99 @@
scm_t_bits scm_tc16_bytevector;
#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
#define SCM_BYTEVECTOR_SET_INLINE(bv) \
SCM_SET_SMOB_FLAGS (bv, SCM_SMOB_FLAGS (bv) | SCM_F_BYTEVECTOR_INLINE)
#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
SCM_SET_SMOB_FLAGS (bv, (SCM_SMOB_FLAGS (bv) & 0xFF) | (hint << 8))
#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
(scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var)
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
static inline SCM
make_bytevector_from_buffer (size_t len, signed char *contents)
make_bytevector_from_buffer (size_t len, void *contents,
scm_t_array_element_type element_type)
{
/* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
SCM ret;
size_t c_len;
if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
|| scm_i_array_element_type_sizes[element_type] < 8
|| len >= (SCM_I_SIZE_MAX
/ (scm_i_array_element_type_sizes[element_type]/8))))
/* This would be an internal Guile programming error */
abort ();
c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, contents);
else
{
SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
SCM_BYTEVECTOR_SET_INLINE (ret);
if (contents)
{
memcpy (SCM_BYTEVECTOR_CONTENTS (ret), contents, c_len);
scm_gc_free (contents, c_len, SCM_GC_BYTEVECTOR);
}
}
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
return ret;
}
static inline SCM
make_bytevector (size_t len)
make_bytevector (size_t len, scm_t_array_element_type element_type)
{
SCM bv;
size_t c_len;
if (SCM_UNLIKELY (len == 0))
bv = scm_null_bytevector;
if (SCM_UNLIKELY (len == 0 && element_type == 0))
return scm_null_bytevector;
else if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
|| scm_i_array_element_type_sizes[element_type] < 8
|| len >= (SCM_I_SIZE_MAX
/ (scm_i_array_element_type_sizes[element_type]/8))))
/* This would be an internal Guile programming error */
abort ();
c_len = len * (scm_i_array_element_type_sizes[element_type]/8);
if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
{
SCM ret;
SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
SCM_BYTEVECTOR_SET_INLINE (ret);
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
return ret;
}
else
{
signed char *contents = NULL;
if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
bv = make_bytevector_from_buffer (len, contents);
void *buf = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
return make_bytevector_from_buffer (len, buf, element_type);
}
return bv;
}
/* Return a new bytevector of size LEN octets. */
SCM
scm_c_make_bytevector (size_t len)
{
return (make_bytevector (len));
return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
/* Return a new bytevector of size LEN elements. */
SCM
scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
{
return make_bytevector (len, element_type);
}
/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
@ -223,22 +277,14 @@ scm_c_make_bytevector (size_t len)
SCM
scm_c_take_bytevector (signed char *contents, size_t len)
{
SCM bv;
return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
{
/* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
signed char *c_bv;
bv = make_bytevector (len);
c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
memcpy (c_bv, contents, len);
scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
}
else
bv = make_bytevector_from_buffer (len, contents);
return bv;
SCM
scm_c_take_typed_bytevector (signed char *contents, size_t len,
scm_t_array_element_type element_type)
{
return make_bytevector_from_buffer (len, contents, element_type);
}
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
@ -246,6 +292,10 @@ scm_c_take_bytevector (signed char *contents, size_t len)
SCM
scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
{
if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
/* This would be an internal Guile programming error */
abort ();
if (!SCM_BYTEVECTOR_INLINE_P (bv))
{
size_t c_len;
@ -259,6 +309,7 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
{
/* Copy to the in-line buffer and free the current buffer. */
SCM_BYTEVECTOR_SET_INLINE (bv);
c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
memcpy (c_new_bv, c_bv, c_new_len);
scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
@ -271,6 +322,8 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
}
}
else
SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
return bv;
}
@ -329,38 +382,30 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
}
#undef FUNC_NAME
/* This procedure is used by `scm_c_generalized_vector_set_x ()'. */
void
scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value)
#define FUNC_NAME "scm_i_bytevector_generalized_set_x"
{
scm_c_bytevector_set_x (bv, index, scm_to_uint8 (value));
}
#undef FUNC_NAME
static int
print_bytevector (SCM bv, SCM port, scm_print_state *pstate)
print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
unsigned c_len, i;
unsigned char *c_bv;
ssize_t ubnd, inc, i;
scm_t_array_handle h;
scm_array_get_handle (bv, &h);
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
scm_puts ("#vu8(", port);
for (i = 0; i < c_len; i++)
scm_putc ('#', port);
scm_write (scm_array_handle_element_type (&h), port);
scm_putc ('(', port);
for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
i <= ubnd; i += inc)
{
if (i > 0)
scm_putc (' ', port);
scm_uintprint (c_bv[i], 10, port);
scm_write (scm_array_handle_ref (&h, i), port);
}
scm_putc (')', port);
/* Make GCC think we use it. */
scm_remember_upto_here ((SCM) pstate);
return 1;
}
@ -448,7 +493,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
c_fill = (signed char) value;
}
bv = make_bytevector (c_len);
bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
if (fill != SCM_UNDEFINED)
{
unsigned i;
@ -574,7 +619,7 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
copy = make_bytevector (c_len);
copy = make_bytevector (c_len, SCM_BYTEVECTOR_ELEMENT_TYPE (bv));
c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
memcpy (c_copy, c_bv, c_len);
@ -604,7 +649,7 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
sz = scm_array_handle_uniform_element_size (&h);
ret = make_bytevector (len * sz);
ret = make_bytevector (len * sz, SCM_ARRAY_ELEMENT_TYPE_VU8);
memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
scm_array_handle_release (&h);
@ -693,7 +738,7 @@ SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
bv = make_bytevector (c_len);
bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
@ -1130,7 +1175,7 @@ SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
scm_out_of_range (FUNC_NAME, size); \
\
bv = make_bytevector (c_len * c_size); \
bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
\
for (c_bv_ptr = c_bv; \
@ -1629,6 +1674,12 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_c_type ## _to_foreign_endianness
/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
#define VALIDATE_REAL(pos, v) \
do { \
SCM_ASSERT_TYPE (scm_is_true (scm_rational_p (v)), v, pos, FUNC_NAME, "real"); \
} while (0)
/* Templace getters and setters. */
#define IEEE754_ACCESSOR_PROLOGUE(_type) \
@ -1665,7 +1716,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
SCM_VALIDATE_REAL (3, value); \
VALIDATE_REAL (3, value); \
SCM_VALIDATE_SYMBOL (4, endianness); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
@ -1685,7 +1736,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
SCM_VALIDATE_REAL (3, value); \
VALIDATE_REAL (3, value); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
@ -1896,8 +1947,7 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness)
scm_list_1 (str), err); \
else \
/* C_UTF is null-terminated. */ \
utf = scm_c_take_bytevector ((signed char *) c_utf, \
c_utf_len); \
utf = scm_c_take_bytevector ((signed char *) c_utf, c_utf_len); \
\
return (utf);
@ -2058,6 +2108,127 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
#undef FUNC_NAME
/* Bytevectors as generalized vectors & arrays. */
static SCM
bytevector_ref_c32 (SCM bv, SCM idx)
{ /* FIXME add some checks */
const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
}
static SCM
bytevector_ref_c64 (SCM bv, SCM idx)
{ /* FIXME add some checks */
const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
return scm_c_make_rectangular (contents[i/16], contents[i/16 + 1]);
}
typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
{
NULL, /* SCM */
NULL, /* CHAR */
NULL, /* BIT */
scm_bytevector_u8_ref, /* VU8 */
scm_bytevector_u8_ref, /* U8 */
scm_bytevector_s8_ref,
scm_bytevector_u16_native_ref,
scm_bytevector_s16_native_ref,
scm_bytevector_u32_native_ref,
scm_bytevector_s32_native_ref,
scm_bytevector_u64_native_ref,
scm_bytevector_s64_native_ref,
scm_bytevector_ieee_single_native_ref,
scm_bytevector_ieee_double_native_ref,
bytevector_ref_c32,
bytevector_ref_c64
};
static SCM
bv_handle_ref (scm_t_array_handle *h, size_t index)
{
SCM byte_index;
scm_t_bytevector_ref_fn ref_fn;
ref_fn = bytevector_ref_fns[h->element_type];
byte_index =
scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
return ref_fn (h->array, byte_index);
}
static SCM
bytevector_set_c32 (SCM bv, SCM idx, SCM val)
{ /* checks are unnecessary here */
float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
contents[i/8] = scm_c_real_part (val);
contents[i/8 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
static SCM
bytevector_set_c64 (SCM bv, SCM idx, SCM val)
{ /* checks are unnecessary here */
double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
contents[i/16] = scm_c_real_part (val);
contents[i/16 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
{
NULL, /* SCM */
NULL, /* CHAR */
NULL, /* BIT */
scm_bytevector_u8_set_x, /* VU8 */
scm_bytevector_u8_set_x, /* U8 */
scm_bytevector_s8_set_x,
scm_bytevector_u16_native_set_x,
scm_bytevector_s16_native_set_x,
scm_bytevector_u32_native_set_x,
scm_bytevector_s32_native_set_x,
scm_bytevector_u64_native_set_x,
scm_bytevector_s64_native_set_x,
scm_bytevector_ieee_single_native_set_x,
scm_bytevector_ieee_double_native_set_x,
bytevector_set_c32,
bytevector_set_c64
};
static void
bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
{
SCM byte_index;
scm_t_bytevector_set_fn set_fn;
set_fn = bytevector_set_fns[h->element_type];
byte_index =
scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
set_fn (h->array, byte_index, val);
}
static void
bytevector_get_handle (SCM v, scm_t_array_handle *h)
{
h->array = v;
h->ndims = 1;
h->dims = &h->dim0;
h->dim0.lbnd = 0;
h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
h->dim0.inc = 1;
h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
}
/* Initialization. */
@ -2073,7 +2244,8 @@ scm_bootstrap_bytevectors (void)
scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p);
scm_null_bytevector =
scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
scm_gc_protect_object
(make_bytevector_from_buffer (0, NULL, SCM_ARRAY_ELEMENT_TYPE_VU8));
#ifdef WORDS_BIGENDIAN
scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big"));
@ -2084,6 +2256,20 @@ scm_bootstrap_bytevectors (void)
scm_c_register_extension ("libguile", "scm_init_bytevectors",
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
{
scm_t_array_implementation impl;
impl.tag = scm_tc16_bytevector;
impl.mask = 0xffff;
impl.vref = bv_handle_ref;
impl.vset = bv_handle_set_x;
impl.get_handle = bytevector_get_handle;
scm_i_register_array_implementation (&impl);
scm_i_register_vector_constructor
(scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
scm_make_bytevector);
}
}
void

16
libguile/bytevectors.h
View file

@ -116,17 +116,21 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
i.e., without allocating memory beside the SMOB itself (a double cell).
This optimization is necessary since small bytevectors are expected to be
common. */
#define SCM_BYTEVECTOR_P(_bv) \
#define SCM_BYTEVECTOR_P(_bv) \
SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv)
#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
#define SCM_BYTEVECTOR_INLINE_P(_bv) \
(SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv)))
#define SCM_F_BYTEVECTOR_INLINE 0x1
#define SCM_BYTEVECTOR_INLINE_P(_bv) \
(SCM_SMOB_FLAGS (_bv) & SCM_F_BYTEVECTOR_INLINE)
#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \
(SCM_SMOB_FLAGS (_bv) >> 8)
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t, scm_t_array_element_type);
SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t,
scm_t_array_element_type);
SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);

8
libguile/chars.c
View file

@ -296,14 +296,14 @@ TODO: change name to scm_i_.. ? --hwn
scm_t_wchar
scm_c_upcase (scm_t_wchar c)
{
return uc_toupper (c);
return uc_toupper ((int) c);
}
scm_t_wchar
scm_c_downcase (scm_t_wchar c)
{
return uc_tolower (c);
return uc_tolower ((int) c);
}
@ -357,7 +357,7 @@ static const scm_t_uint32 const scm_alt_charnums[] = {
const char *
scm_i_charname (SCM chr)
{
int c;
size_t c;
scm_t_uint32 i = SCM_CHAR (chr);
for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
@ -379,7 +379,7 @@ scm_i_charname (SCM chr)
SCM
scm_i_charname_to_char (const char *charname, size_t charname_len)
{
int c;
size_t c;
/* The R5RS charnames. These are supposed to be case
insensitive. */

20
libguile/chars.h
View file

@ -24,7 +24,11 @@
#include "libguile/__scm.h"
#include "libguile/numbers.h"
#ifndef SCM_T_WCHAR_DEFINED
typedef scm_t_int32 scm_t_wchar;
#define SCM_T_WCHAR_DEFINED
#endif /* SCM_T_WCHAR_DEFINED */
/* Immediate Characters
@ -32,10 +36,16 @@
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
#define SCM_MAKE_CHAR(x) \
(x < 0 \
? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) x, scm_tc8_char) \
: SCM_MAKE_ITAG8 ((scm_t_bits) x, scm_tc8_char))
/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars (0
to 255) to Latin-1 codepoints (0 to 255) while allowing higher
codepoints (256 to 1114111) to pass through unchanged.
This macro evaluates x twice, which may lead to side effects if not
used properly. */
#define SCM_MAKE_CHAR(x) \
((x) <= 1 \
? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \
: SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char))
#define SCM_CODEPOINT_MAX (0x10ffff)
#define SCM_IS_UNICODE_CHAR(c) \

6
libguile/continuations.c
View file

@ -131,7 +131,7 @@ scm_make_continuation (int *first)
SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
*first = !setjmp (continuation->jmpbuf);
*first = !SCM_I_SETJMP (continuation->jmpbuf);
if (*first)
{
#ifdef __ia64__
@ -229,12 +229,12 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
scm_i_set_last_debug_frame (continuation->dframe);
continuation->throw_value = val;
longjmp (continuation->jmpbuf, 1);
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
#ifdef __ia64__
void
scm_ia64_longjmp (jmp_buf *JB, int VAL)
scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;

2
libguile/continuations.h
View file

@ -44,7 +44,7 @@ SCM_API scm_t_bits scm_tc16_continuation;
typedef struct
{
SCM throw_value;
jmp_buf jmpbuf;
scm_i_jmp_buf jmpbuf;
SCM dynenv;
#ifdef __ia64__
void *backing_store;

25
libguile/conv-uinteger.i.c
View file

@ -53,10 +53,17 @@ SCM_TO_TYPE_PROTO (SCM val)
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
return n;
#else
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
else
goto out_of_range;
#if TYPE_MIN == 0
if (n <= TYPE_MAX)
return n;
#else /* TYPE_MIN != 0 */
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
#endif /* TYPE_MIN != 0 */
else
goto out_of_range;
#endif
}
else
@ -76,10 +83,16 @@ SCM_TO_TYPE_PROTO (SCM val)
mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val));
#if TYPE_MIN == 0
if (n <= TYPE_MAX)
return n;
#else /* TYPE_MIN != 0 */
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
else
goto out_of_range;
#endif /* TYPE_MIN != 0 */
else
goto out_of_range;
}
}
else

147
libguile/convert.c
View file

@ -1,147 +0,0 @@
/* Copyright (C) 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 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/_scm.h"
#include "libguile/validate.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/pairs.h"
#include "libguile/unif.h"
#include "libguile/srfi-4.h"
#include "libguile/convert.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
/* char *scm_c_scm2chars (SCM obj, char *dst);
SCM scm_c_chars2scm (const char *src, long n);
SCM scm_c_chars2byvect (const char *src, long n);
*/
#define CTYPE char
#define FROM_CTYPE scm_from_char
#define SCM2CTYPES scm_c_scm2chars
#define CTYPES2SCM scm_c_chars2scm
#define CTYPES2UVECT scm_c_chars2byvect
#if CHAR_MIN == 0
/* 'char' is unsigned. */
#define UVEC_TAG u8
#define UVEC_CTYPE scm_t_uint8
#else
/* 'char' is signed. */
#define UVEC_TAG s8
#define UVEC_CTYPE scm_t_int8
#endif
#include "libguile/convert.i.c"
/* short *scm_c_scm2shorts (SCM obj, short *dst);
SCM scm_c_shorts2scm (const short *src, long n);
SCM scm_c_shorts2svect (const short *src, long n);
*/
#define CTYPE short
#define FROM_CTYPE scm_from_short
#define SCM2CTYPES scm_c_scm2shorts
#define CTYPES2SCM scm_c_shorts2scm
#define CTYPES2UVECT scm_c_shorts2svect
#define UVEC_TAG s16
#define UVEC_CTYPE scm_t_int16
#include "libguile/convert.i.c"
/* int *scm_c_scm2ints (SCM obj, int *dst);
SCM scm_c_ints2scm (const int *src, long n);
SCM scm_c_ints2ivect (const int *src, long n);
SCM scm_c_uints2uvect (const unsigned int *src, long n);
*/
#define CTYPE int
#define FROM_CTYPE scm_from_int
#define SCM2CTYPES scm_c_scm2ints
#define CTYPES2SCM scm_c_ints2scm
#define CTYPES2UVECT scm_c_ints2ivect
#define UVEC_TAG s32
#define UVEC_CTYPE scm_t_int32
#define CTYPES2UVECT_2 scm_c_uints2uvect
#define CTYPE_2 unsigned int
#define UVEC_TAG_2 u32
#define UVEC_CTYPE_2 scm_t_uint32
#include "libguile/convert.i.c"
/* long *scm_c_scm2longs (SCM obj, long *dst);
SCM scm_c_longs2scm (const long *src, long n);
SCM scm_c_longs2ivect (const long *src, long n);
SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
*/
#define CTYPE long
#define FROM_CTYPE scm_from_long
#define SCM2CTYPES scm_c_scm2longs
#define CTYPES2SCM scm_c_longs2scm
#define CTYPES2UVECT scm_c_longs2ivect
#define UVEC_TAG s32
#define UVEC_CTYPE scm_t_int32
#define CTYPES2UVECT_2 scm_c_ulongs2uvect
#define CTYPE_2 unsigned int
#define UVEC_TAG_2 u32
#define UVEC_CTYPE_2 scm_t_uint32
#include "libguile/convert.i.c"
/* float *scm_c_scm2floats (SCM obj, float *dst);
SCM scm_c_floats2scm (const float *src, long n);
SCM scm_c_floats2fvect (const float *src, long n);
*/
#define CTYPE float
#define FROM_CTYPE scm_from_double
#define SCM2CTYPES scm_c_scm2floats
#define CTYPES2SCM scm_c_floats2scm
#define CTYPES2UVECT scm_c_floats2fvect
#define UVEC_TAG f32
#define UVEC_CTYPE float
#include "libguile/convert.i.c"
/* double *scm_c_scm2doubles (SCM obj, double *dst);
SCM scm_c_doubles2scm (const double *src, long n);
SCM scm_c_doubles2dvect (const double *src, long n);
*/
#define CTYPE double
#define FROM_CTYPE scm_from_double
#define SCM2CTYPES scm_c_scm2doubles
#define CTYPES2SCM scm_c_doubles2scm
#define CTYPES2UVECT scm_c_doubles2dvect
#define UVEC_TAG f64
#define UVEC_CTYPE double
#include "libguile/convert.i.c"
/*
Local Variables:
c-file-style: "gnu"
End:
*/

51
libguile/convert.h
View file

@ -1,51 +0,0 @@
/* classes: h_files */
#ifndef SCM_CONVERT_H
#define SCM_CONVERT_H
/* Copyright (C) 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 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#include "libguile/__scm.h"
SCM_API char *scm_c_scm2chars (SCM obj, char *dst);
SCM_API short *scm_c_scm2shorts (SCM obj, short *dst);
SCM_API int *scm_c_scm2ints (SCM obj, int *dst);
SCM_API long *scm_c_scm2longs (SCM obj, long *dst);
SCM_API float *scm_c_scm2floats (SCM obj, float *dst);
SCM_API double *scm_c_scm2doubles (SCM obj, double *dst);
SCM_API SCM scm_c_chars2scm (const char *src, long n);
SCM_API SCM scm_c_shorts2scm (const short *src, long n);
SCM_API SCM scm_c_ints2scm (const int *src, long n);
SCM_API SCM scm_c_longs2scm (const long *src, long n);
SCM_API SCM scm_c_floats2scm (const float *src, long n);
SCM_API SCM scm_c_doubles2scm (const double *src, long n);
SCM_API SCM scm_c_chars2byvect (const char *src, long n);
SCM_API SCM scm_c_shorts2svect (const short *src, long n);
SCM_API SCM scm_c_ints2ivect (const int *src, long n);
SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n);
SCM_API SCM scm_c_longs2ivect (const long *src, long n);
SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
SCM_API SCM scm_c_floats2fvect (const float *src, long n);
SCM_API SCM scm_c_doubles2dvect (const double *src, long n);
#endif /* SCM_CONVERT_H */

171
libguile/convert.i.c
View file

@ -1,171 +0,0 @@
/* this file is #include'd (x times) by convert.c */
/* You need to define the following macros before including this
template. They are undefined at the end of this file to give a
clean slate for the next inclusion.
- CTYPE
The type of an element of the C array, for example 'char'.
- FROM_CTYPE
The function that converts a CTYPE to a SCM, for example
scm_from_char.
- UVEC_TAG
The tag of a suitable uniform vector that can hold the CTYPE, for
example 's8'.
- UVEC_CTYPE
The C type of an element of the uniform vector, for example
scm_t_int8.
- SCM2CTYPES
The name of the 'SCM-to-C' function, for example scm_c_scm2chars.
- CTYPES2SCM
The name of the 'C-to-SCM' function, for example, scm_c_chars2scm.
- CTYPES2UVECT
The name of the 'C-to-uniform-vector' function, for example
scm_c_chars2byvect. It will create a uniform vector of kind
UVEC_TAG.
- CTYPES2UVECT_2
The name of a second 'C-to-uniform-vector' function. Leave
undefined if you want only one such function.
- CTYPE_2
- UVEC_TAG_2
- UVEC_CTYPE_2
The tag and C type of the second kind of uniform vector, for use
with the function described above.
*/
/* The first level does not expand macros in the arguments. */
#define paste(a1,a2,a3) a1##a2##a3
#define stringify(a) #a
/* But the second level does. */
#define F(pre,T,suf) paste(pre,T,suf)
#define S(T) stringify(T)
/* Convert a vector, list or uniform vector into a C array. If the
result array in argument 2 is NULL, malloc() a new one.
*/
CTYPE *
SCM2CTYPES (SCM obj, CTYPE *data)
{
scm_t_array_handle handle;
size_t i, len;
ssize_t inc;
const UVEC_CTYPE *uvec_elements;
obj = F(scm_any_to_,UVEC_TAG,vector) (obj);
uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj, &handle, &len, &inc);
if (data == NULL)
data = scm_malloc (len * sizeof (CTYPE));
for (i = 0; i < len; i++, uvec_elements += inc)
data[i] = uvec_elements[i];
scm_array_handle_release (&handle);
return data;
}
/* Converts a C array into a vector. */
SCM
CTYPES2SCM (const CTYPE *data, long n)
{
long i;
SCM v;
v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for (i = 0; i < n; i++)
SCM_SIMPLE_VECTOR_SET (v, i, FROM_CTYPE (data[i]));
return v;
}
/* Converts a C array into a uniform vector. */
SCM
CTYPES2UVECT (const CTYPE *data, long n)
{
scm_t_array_handle handle;
long i;
SCM uvec;
UVEC_CTYPE *uvec_elements;
uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED);
uvec_elements = F(scm_,UVEC_TAG,vector_writable_elements) (uvec, &handle,
NULL, NULL);
for (i = 0; i < n; i++)
uvec_elements[i] = data[i];
scm_array_handle_release (&handle);
return uvec;
}
#ifdef CTYPE2UVECT_2
SCM
CTYPES2UVECT_2 (const CTYPE_2 *data, long n)
{
scm_t_array_handle handle;
long i;
SCM uvec;
UVEC_CTYPE_2 *uvec_elements;
uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED);
uvec_elements = F(scm_,UVEC_TAG_2,vector_writable_elements) (uvec, &handle,
NULL, NULL);
for (i = 0; i < n; i++)
uvec_elements[i] = data[i];
scm_array_handle_release (&handle);
return uvec;
}
#endif
#undef paste
#undef stringify
#undef F
#undef S
#undef CTYPE
#undef FROM_CTYPE
#undef UVEC_TAG
#undef UVEC_CTYPE
#undef SCM2CTYPES
#undef CTYPES2SCM
#undef CTYPES2UVECT
#ifdef CTYPES2UVECT_2
#undef CTYPES2UVECT_2
#undef CTYPE_2
#undef UVEC_TAG_2
#undef UVEC_CTYPE_2
#endif
/*
Local Variables:
c-file-style: "gnu"
End:
*/

1
libguile/debug.c
View file

@ -363,6 +363,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
break;
case scm_tcs_subrs:
case scm_tc7_program:
procprop:
/* It would indeed be a nice thing if we supplied source even for
built in procedures! */

38
libguile/deprecated.c
View file

@ -34,6 +34,7 @@
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/modules.h"
#include "libguile/generalized-arrays.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/procprop.h"
@ -749,17 +750,13 @@ scm_sym2ovcell (SCM sym, SCM obarray)
return (SYMBOL . SCM_UNDEFINED). */
SCM
scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness)
static SCM
intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness)
{
SCM symbol = scm_from_locale_symboln (name, len);
size_t raw_hash = scm_i_symbol_hash (symbol);
size_t hash;
SCM lsym;
scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
"Use hashtables instead.");
if (scm_is_false (obarray))
{
if (softness)
@ -795,6 +792,18 @@ scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int so
}
SCM
scm_intern_obarray_soft (const char *name, size_t len, SCM obarray,
unsigned int softness)
{
SCM symbol = scm_from_locale_symboln (name, len);
scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
"Use hashtables instead.");
return intern_obarray_soft (symbol, obarray, softness);
}
SCM
scm_intern_obarray (const char *name,size_t len,SCM obarray)
{
@ -850,10 +859,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
else if (scm_is_eq (o, SCM_BOOL_T))
o = SCM_BOOL_F;
vcell = scm_intern_obarray_soft (scm_i_string_chars (s),
scm_i_string_length (s),
o,
softness);
vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness);
if (scm_is_false (vcell))
return vcell;
answer = SCM_CAR (vcell);
@ -1070,7 +1076,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
{
char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
char *name = buf;
int len, n_digits;
int n_digits;
size_t len;
scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
"Use `gensym' instead.");
@ -1084,9 +1091,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
{
SCM_VALIDATE_STRING (1, prefix);
len = scm_i_string_length (prefix);
if (len > MAX_PREFIX_LENGTH)
name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN);
strncpy (name, scm_i_string_chars (prefix), len);
name = scm_to_locale_stringn (prefix, &len);
name = scm_realloc (name, len + SCM_INTBUFLEN);
}
if (SCM_UNBNDP (obarray))
@ -1108,7 +1114,7 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
obarray,
0);
if (name != buf)
scm_must_free (name);
free (name);
return SCM_CAR (vcell);
}
}
@ -1309,7 +1315,7 @@ scm_i_arrayp (SCM a)
{
scm_c_issue_deprecation_warning
("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
return SCM_I_ARRAYP(a) || SCM_I_ENCLOSED_ARRAYP(a);
return SCM_I_ARRAYP(a);
}
size_t

3
libguile/deprecated.h
View file

@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc.
/* Copyright (C) 2003,2004, 2005, 2006, 2007, 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 License
@ -24,6 +24,7 @@
*/
#include "libguile/__scm.h"
#include "libguile/arrays.h"
#include "libguile/strings.h"
#if (SCM_ENABLE_DEPRECATED == 1)

2
libguile/discouraged.c
View file

@ -265,7 +265,7 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol",
SCM dash_string, non_dash_symbol;
SCM_ASSERT (scm_is_symbol (symbol)
&& ('-' == scm_i_symbol_chars(symbol)[0]),
&& (scm_i_symbol_ref (symbol, 0) == '-'),
symbol, SCM_ARG1, FUNC_NAME);
dash_string = scm_symbol_to_string (symbol);

6
libguile/eq.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,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 License
@ -22,13 +22,13 @@
#endif
#include "libguile/_scm.h"
#include "libguile/ramap.h"
#include "libguile/array-map.h"
#include "libguile/stackchk.h"
#include "libguile/strorder.h"
#include "libguile/async.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/arrays.h"
#include "libguile/vectors.h"
#include "libguile/struct.h"

13
libguile/error.c
View file

@ -232,6 +232,19 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
scm_list_1 (bad_value));
}
void
scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
{
scm_error_scm (scm_arg_type_key,
scm_symbol_to_string (symbol),
(pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
: scm_from_locale_string ("Wrong type argument in position ~A: ~S"),
(pos == 0) ? scm_list_1 (bad_value)
: scm_list_2 (scm_from_int (pos), bad_value),
scm_list_1 (bad_value));
scm_remember_upto_here_2 (symbol, bad_value);
}
void
scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
{

2
libguile/error.h
View file

@ -53,6 +53,8 @@ SCM_API void scm_wrong_num_args (SCM proc) SCM_NORETURN;
SCM_API void scm_error_num_args_subr (const char* subr) SCM_NORETURN;
SCM_API void scm_wrong_type_arg (const char *subr, int pos,
SCM bad_value) SCM_NORETURN;
SCM_INTERNAL void scm_i_wrong_type_arg_symbol (SCM symbol, int pos,
SCM bad_value) SCM_NORETURN;
SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
SCM bad_value, const char *sz) SCM_NORETURN;
SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;

284
libguile/eval.c
View file

@ -710,6 +710,101 @@ is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
return 0;
}
static SCM
macroexp (SCM x, SCM env)
{
SCM res, proc, orig_sym;
/* Don't bother to produce error messages here. We get them when we
eventually execute the code for real. */
macro_tail:
orig_sym = SCM_CAR (x);
if (!scm_is_symbol (orig_sym))
return x;
{
SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
if (proc_ptr == NULL)
{
/* We have lost the race. */
goto macro_tail;
}
proc = *proc_ptr;
}
/* Only handle memoizing macros. `Acros' and `macros' are really
special forms and should not be evaluated here. */
if (!SCM_MACROP (proc)
|| (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
return x;
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
if (scm_ilength (res) <= 0)
/* Result of expansion is not a list. */
return (scm_list_2 (SCM_IM_BEGIN, res));
else
{
/* njrev: Several queries here: (1) I don't see how it can be
correct that the SCM_SETCAR 2 lines below this comment needs
protection, but the SCM_SETCAR 6 lines above does not, so
something here is probably wrong. (2) macroexp() is now only
used in one place - scm_m_generalized_set_x - whereas all other
macro expansion happens through expand_user_macros. Therefore
(2.1) perhaps macroexp() could be eliminated completely now?
(2.2) Does expand_user_macros need any critical section
protection? */
SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (res));
SCM_SETCDR (x, SCM_CDR (res));
SCM_CRITICAL_SECTION_END;
goto macro_tail;
}
}
/* Start of the memoizers for the standard R5RS builtin macros. */
static SCM scm_m_quote (SCM xorig, SCM env);
static SCM scm_m_begin (SCM xorig, SCM env);
static SCM scm_m_if (SCM xorig, SCM env);
static SCM scm_m_set_x (SCM xorig, SCM env);
static SCM scm_m_and (SCM xorig, SCM env);
static SCM scm_m_or (SCM xorig, SCM env);
static SCM scm_m_case (SCM xorig, SCM env);
static SCM scm_m_cond (SCM xorig, SCM env);
static SCM scm_m_lambda (SCM xorig, SCM env);
static SCM scm_m_letstar (SCM xorig, SCM env);
static SCM scm_m_do (SCM xorig, SCM env);
static SCM scm_m_quasiquote (SCM xorig, SCM env);
static SCM scm_m_delay (SCM xorig, SCM env);
static SCM scm_m_generalized_set_x (SCM xorig, SCM env);
#if 0 /* Futures are disabled, see "futures.h". */
static SCM scm_m_future (SCM xorig, SCM env);
#endif
static SCM scm_m_define (SCM x, SCM env);
static SCM scm_m_letrec (SCM xorig, SCM env);
static SCM scm_m_let (SCM xorig, SCM env);
static SCM scm_m_at (SCM xorig, SCM env);
static SCM scm_m_atat (SCM xorig, SCM env);
static SCM scm_m_atslot_ref (SCM xorig, SCM env);
static SCM scm_m_atslot_set_x (SCM xorig, SCM env);
static SCM scm_m_apply (SCM xorig, SCM env);
static SCM scm_m_cont (SCM xorig, SCM env);
#if SCM_ENABLE_ELISP
static SCM scm_m_nil_cond (SCM xorig, SCM env);
static SCM scm_m_atfop (SCM xorig, SCM env);
#endif /* SCM_ENABLE_ELISP */
static SCM scm_m_atbind (SCM xorig, SCM env);
static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
static SCM scm_m_eval_when (SCM xorig, SCM env);
static void
m_expand_body (const SCM forms, const SCM env)
{
@ -832,70 +927,10 @@ m_expand_body (const SCM forms, const SCM env)
}
}
static SCM
macroexp (SCM x, SCM env)
{
SCM res, proc, orig_sym;
/* Don't bother to produce error messages here. We get them when we
eventually execute the code for real. */
macro_tail:
orig_sym = SCM_CAR (x);
if (!scm_is_symbol (orig_sym))
return x;
{
SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
if (proc_ptr == NULL)
{
/* We have lost the race. */
goto macro_tail;
}
proc = *proc_ptr;
}
/* Only handle memoizing macros. `Acros' and `macros' are really
special forms and should not be evaluated here. */
if (!SCM_MACROP (proc)
|| (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
return x;
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
if (scm_ilength (res) <= 0)
/* Result of expansion is not a list. */
return (scm_list_2 (SCM_IM_BEGIN, res));
else
{
/* njrev: Several queries here: (1) I don't see how it can be
correct that the SCM_SETCAR 2 lines below this comment needs
protection, but the SCM_SETCAR 6 lines above does not, so
something here is probably wrong. (2) macroexp() is now only
used in one place - scm_m_generalized_set_x - whereas all other
macro expansion happens through expand_user_macros. Therefore
(2.1) perhaps macroexp() could be eliminated completely now?
(2.2) Does expand_user_macros need any critical section
protection? */
SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (res));
SCM_SETCDR (x, SCM_CDR (res));
SCM_CRITICAL_SECTION_END;
goto macro_tail;
}
}
/* Start of the memoizers for the standard R5RS builtin macros. */
SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
SCM
static SCM
scm_m_and (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -925,7 +960,7 @@ unmemoize_and (const SCM expr, const SCM env)
SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
SCM
static SCM
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -949,7 +984,7 @@ SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM
static SCM
scm_m_case (SCM expr, SCM env)
{
SCM clauses;
@ -1045,7 +1080,7 @@ SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM
static SCM
scm_m_cond (SCM expr, SCM env)
{
/* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
@ -1207,7 +1242,7 @@ canonicalize_define (const SCM expr)
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
SCM
static SCM
scm_m_define (SCM expr, SCM env)
{
ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
@ -1262,7 +1297,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
* (delay <expression>) is transformed into (#@delay '() <expression>), where
* the empty list represents the empty parameter list. This representation
* allows for easy creation of the closure during evaluation. */
SCM
static SCM
scm_m_delay (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@ -1305,7 +1340,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/
SCM
static SCM
scm_m_do (SCM expr, SCM env SCM_UNUSED)
{
SCM variables = SCM_EOL;
@ -1403,7 +1438,7 @@ unmemoize_do (const SCM expr, const SCM env)
SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
SCM
static SCM
scm_m_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -1453,7 +1488,7 @@ c_improper_memq (SCM obj, SCM list)
return scm_is_eq (list, obj);
}
SCM
static SCM
scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
{
SCM formals;
@ -1623,7 +1658,7 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
SCM
static SCM
scm_m_let (SCM expr, SCM env)
{
SCM bindings;
@ -1697,7 +1732,7 @@ unmemoize_let (const SCM expr, const SCM env)
SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
SCM
static SCM
scm_m_letrec (SCM expr, SCM env)
{
SCM bindings;
@ -1748,7 +1783,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
SCM
static SCM
scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
{
SCM binding_idx;
@ -1821,7 +1856,7 @@ unmemoize_letstar (const SCM expr, const SCM env)
SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
SCM
static SCM
scm_m_or (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -1905,7 +1940,7 @@ iqq (SCM form, SCM env, unsigned long int depth)
return form;
}
SCM
static SCM
scm_m_quasiquote (SCM expr, SCM env)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -1918,7 +1953,7 @@ scm_m_quasiquote (SCM expr, SCM env)
SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
SCM
static SCM
scm_m_quote (SCM expr, SCM env SCM_UNUSED)
{
SCM quotee;
@ -1947,7 +1982,7 @@ SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
static const char s_set_x[] = "set!";
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
SCM
static SCM
scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM variable;
@ -1977,13 +2012,14 @@ unmemoize_set_x (const SCM expr, const SCM env)
}
/* Start of the memoizers for non-R5RS builtin macros. */
SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
SCM_GLOBAL_SYMBOL (scm_sym_at, s_at);
SCM
static SCM
scm_m_at (SCM expr, SCM env SCM_UNUSED)
{
SCM mod, var;
@ -2004,7 +2040,7 @@ scm_m_at (SCM expr, SCM env SCM_UNUSED)
SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat);
SCM
static SCM
scm_m_atat (SCM expr, SCM env SCM_UNUSED)
{
SCM mod, var;
@ -2026,7 +2062,7 @@ SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
SCM
static SCM
scm_m_apply (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -2063,7 +2099,7 @@ SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
*
* FIXME - also implement `@bind*'.
*/
SCM
static SCM
scm_m_atbind (SCM expr, SCM env)
{
SCM bindings;
@ -2102,7 +2138,7 @@ scm_m_atbind (SCM expr, SCM env)
SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
SCM
static SCM
scm_m_cont (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -2123,7 +2159,7 @@ unmemoize_atcall_cc (const SCM expr, const SCM env)
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
SCM
static SCM
scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@ -2147,7 +2183,7 @@ SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
SCM
static SCM
scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
@ -2173,7 +2209,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
* (#@future '() <expression>), where the empty list represents the
* empty parameter list. This representation allows for easy creation
* of the closure during evaluation. */
SCM
static SCM
scm_m_future (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@ -2193,7 +2229,7 @@ unmemoize_future (const SCM expr, const SCM env)
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
SCM
static SCM
scm_m_generalized_set_x (SCM expr, SCM env)
{
SCM target, exp_target;
@ -2250,9 +2286,11 @@ scm_m_generalized_set_x (SCM expr, SCM env)
* arbitrary modules during the startup phase, the code from goops.c should be
* moved here. */
SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
SCM
static SCM
scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@ -2285,7 +2323,7 @@ unmemoize_atslot_ref (const SCM expr, const SCM env)
SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
SCM
static SCM
scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@ -2323,7 +2361,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
/* nil-cond expressions have the form
* (nil-cond COND VAL COND VAL ... ELSEVAL) */
SCM
static SCM
scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
{
const long length = scm_ilength (SCM_CDR (expr));
@ -2346,7 +2384,7 @@ SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
* if the value of var (across all aliasing) is not a macro, or
* (<un-aliased var> <expr> ...)
* if var is a macro. */
SCM
static SCM
scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
{
SCM location;
@ -2517,20 +2555,11 @@ scm_i_unmemocopy_body (SCM forms, SCM env)
#if (SCM_ENABLE_DEPRECATED == 1)
/* Deprecated in guile 1.7.0 on 2003-11-09. */
SCM
scm_m_expand_body (SCM exprs, SCM env)
{
scm_c_issue_deprecation_warning
("`scm_m_expand_body' is deprecated.");
m_expand_body (exprs, env);
return exprs;
}
static SCM scm_m_undefine (SCM expr, SCM env);
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
SCM
static SCM
scm_m_undefine (SCM expr, SCM env)
{
SCM variable;
@ -2554,55 +2583,10 @@ scm_m_undefine (SCM expr, SCM env)
return SCM_UNSPECIFIED;
}
SCM
scm_macroexp (SCM x, SCM env)
{
scm_c_issue_deprecation_warning
("`scm_macroexp' is deprecated.");
return macroexp (x, env);
}
#endif
#endif /* SCM_ENABLE_DEPRECATED */
#if (SCM_ENABLE_DEPRECATED == 1)
SCM
scm_unmemocar (SCM form, SCM env)
{
scm_c_issue_deprecation_warning
("`scm_unmemocar' is deprecated.");
if (!scm_is_pair (form))
return form;
else
{
SCM c = SCM_CAR (form);
if (SCM_VARIABLEP (c))
{
SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
if (scm_is_false (sym))
sym = sym_three_question_marks;
SCM_SETCAR (form, sym);
}
else if (SCM_ILOCP (c))
{
unsigned long int ir;
for (ir = SCM_IFRAME (c); ir != 0; --ir)
env = SCM_CDR (env);
env = SCM_CAAR (env);
for (ir = SCM_IDIST (c); ir != 0; --ir)
env = SCM_CDR (env);
SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
}
return form;
}
}
#endif
/*****************************************************************************/
/*****************************************************************************/
/* The definitions for execution start here. */
@ -3344,6 +3328,7 @@ scm_trampoline_0 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
case scm_tc7_program:
trampoline = scm_call_0;
break;
default:
@ -3396,8 +3381,7 @@ call_dsubr_1 (SCM proc, SCM arg1)
{
return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
}
static SCM
@ -3470,6 +3454,7 @@ scm_trampoline_1 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
case scm_tc7_program:
trampoline = scm_call_1;
break;
default:
@ -3564,6 +3549,7 @@ scm_trampoline_2 (SCM proc)
break;
case scm_tc7_gsubr:
case scm_tc7_pws:
case scm_tc7_program:
trampoline = scm_call_2;
break;
default:

45
libguile/eval.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_EVAL_H
#define SCM_EVAL_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -115,40 +115,6 @@ SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
SCM_API SCM scm_eval_car (SCM pair, SCM env);
SCM_API SCM scm_eval_body (SCM code, SCM env);
SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
SCM_API SCM scm_m_quote (SCM xorig, SCM env);
SCM_API SCM scm_m_begin (SCM xorig, SCM env);
SCM_API SCM scm_m_if (SCM xorig, SCM env);
SCM_API SCM scm_m_set_x (SCM xorig, SCM env);
SCM_API SCM scm_m_vref (SCM xorig, SCM env);
SCM_API SCM scm_m_vset (SCM xorig, SCM env);
SCM_API SCM scm_m_and (SCM xorig, SCM env);
SCM_API SCM scm_m_or (SCM xorig, SCM env);
SCM_API SCM scm_m_case (SCM xorig, SCM env);
SCM_API SCM scm_m_cond (SCM xorig, SCM env);
SCM_API SCM scm_m_lambda (SCM xorig, SCM env);
SCM_API SCM scm_m_letstar (SCM xorig, SCM env);
SCM_API SCM scm_m_do (SCM xorig, SCM env);
SCM_API SCM scm_m_quasiquote (SCM xorig, SCM env);
SCM_API SCM scm_m_delay (SCM xorig, SCM env);
SCM_API SCM scm_m_generalized_set_x (SCM xorig, SCM env);
SCM_API SCM scm_m_future (SCM xorig, SCM env);
SCM_API SCM scm_m_define (SCM x, SCM env);
SCM_API SCM scm_m_letrec (SCM xorig, SCM env);
SCM_API SCM scm_m_let (SCM xorig, SCM env);
SCM_API SCM scm_m_at (SCM xorig, SCM env);
SCM_API SCM scm_m_atat (SCM xorig, SCM env);
SCM_API SCM scm_m_apply (SCM xorig, SCM env);
SCM_API SCM scm_m_cont (SCM xorig, SCM env);
#if SCM_ENABLE_ELISP
SCM_API SCM scm_m_nil_cond (SCM xorig, SCM env);
SCM_API SCM scm_m_atfop (SCM xorig, SCM env);
#endif /* SCM_ENABLE_ELISP */
SCM_API SCM scm_m_atbind (SCM xorig, SCM env);
SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env);
SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env);
SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env);
SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
SCM_API SCM scm_m_eval_when (SCM xorig, SCM env);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
@ -190,15 +156,6 @@ SCM_INTERNAL void scm_init_eval (void);
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_API SCM scm_m_undefine (SCM x, SCM env);
/* Deprecated in guile 1.7.0 on 2003-11-09. */
SCM_API SCM scm_m_expand_body (SCM xorig, SCM env);
/* Deprecated in guile 1.7.0 on 2003-11-16. */
SCM_API SCM scm_unmemocar (SCM form, SCM env);
SCM_API SCM scm_macroexp (SCM x, SCM env);
/* Deprecated in guile 1.7.0 on 2004-03-29. */
SCM_API SCM scm_ceval (SCM x, SCM env);
SCM_API SCM scm_deval (SCM x, SCM env);

29
libguile/eval.i.c
View file

@ -1132,6 +1132,8 @@ dispatch:
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
case scm_tc7_program:
RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
@ -1236,13 +1238,13 @@ dispatch:
{
RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1,
scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
case scm_tc7_cxr:
RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
case scm_tc7_rpsubr:
RETURN (SCM_BOOL_T);
case scm_tc7_program:
RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1));
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
@ -1353,6 +1355,12 @@ dispatch:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, arg2));
case scm_tc7_program:
{ SCM args[2];
args[0] = arg1;
args[1] = arg2;
RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2));
}
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
@ -1492,6 +1500,8 @@ dispatch:
SCM_CDDR (debug.info->a.args)));
case scm_tc7_gsubr:
RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
case scm_tc7_program:
RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
debug.info->a.proc = proc;
@ -1563,6 +1573,11 @@ dispatch:
scm_cons2 (arg1, arg2,
scm_ceval_args (x, env,
proc))));
case scm_tc7_program:
RETURN (scm_vm_apply
(scm_the_vm (), proc,
scm_cons (arg1, scm_cons (arg2,
scm_ceval_args (x, env, proc)))));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
if (!SCM_CLOSUREP (proc))
@ -1764,8 +1779,7 @@ tail:
{
RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
case scm_tc7_cxr:
if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
scm_wrong_num_args (proc);
@ -1798,6 +1812,11 @@ tail:
args = SCM_CDR (args);
}
RETURN (arg1);
case scm_tc7_program:
if (SCM_UNBNDP (arg1))
RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
else
RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args)));
case scm_tc7_rpsubr:
if (scm_is_null (args))
RETURN (SCM_BOOL_T);

47
libguile/evalext.c
View file

@ -31,49 +31,23 @@
#include "libguile/evalext.h"
SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
(SCM sym, SCM env),
"Return @code{#t} if @var{sym} is defined in the lexical "
"environment @var{env}. When @var{env} is not specified, "
"look in the top-level environment as defined by the "
"current module.")
(SCM sym, SCM module),
"Return @code{#t} if @var{sym} is defined in the module "
"@var{module} or the current module when @var{module} is not"
"specified.")
#define FUNC_NAME s_scm_defined_p
{
SCM var;
SCM_VALIDATE_SYMBOL (1, sym);
if (SCM_UNBNDP (env))
var = scm_sym2var (sym, scm_current_module_lookup_closure (),
SCM_BOOL_F);
if (SCM_UNBNDP (module))
module = scm_current_module ();
else
{
SCM frames = env;
register SCM b;
for (; SCM_NIMP (frames); frames = SCM_CDR (frames))
{
SCM_ASSERT (scm_is_pair (frames), env, SCM_ARG2, FUNC_NAME);
b = SCM_CAR (frames);
if (scm_is_true (scm_procedure_p (b)))
break;
SCM_ASSERT (scm_is_pair (b), env, SCM_ARG2, FUNC_NAME);
for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b))
{
if (!scm_is_pair (b))
{
if (scm_is_eq (b, sym))
return SCM_BOOL_T;
else
break;
}
if (scm_is_eq (SCM_CAR (b), sym))
return SCM_BOOL_T;
}
}
var = scm_sym2var (sym,
SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F,
SCM_BOOL_F);
}
SCM_VALIDATE_MODULE (2, module);
var = scm_module_variable (module, sym);
return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var))
? SCM_BOOL_F
: SCM_BOOL_T);
@ -108,6 +82,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_pws:
case scm_tc7_program:
case scm_tcs_subrs:
case scm_tcs_struct:
return SCM_BOOL_T;

5
libguile/extensions.c
View file

@ -1,6 +1,6 @@
/* extensions.c - registering and loading extensions.
*
* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
* Copyright (C) 2001, 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 License
@ -41,7 +41,7 @@ typedef struct extension_t
void *data;
} extension_t;
static extension_t *registered_extensions;
static extension_t *registered_extensions = NULL;
/* Register a LIB/INIT pair for use by `scm_load_extension'. LIB is
allowed to be NULL and then only INIT is used to identify the
@ -157,7 +157,6 @@ SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0,
void
scm_init_extensions ()
{
registered_extensions = NULL;
#include "libguile/extensions.x"
}

60
libguile/filesys.c
View file

@ -1573,31 +1573,39 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
"component, @code{.} is returned.")
#define FUNC_NAME s_scm_dirname
{
const char *s;
long int i;
unsigned long int len;
SCM_VALIDATE_STRING (1, filename);
s = scm_i_string_chars (filename);
len = scm_i_string_length (filename);
i = len - 1;
#ifdef __MINGW32__
while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i;
while (i >= 0 && (s[i] != '/' && s[i] != '\\')) --i;
while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i;
while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
|| scm_i_string_ref (filename, i) == '\\'))
--i;
while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
&& scm_i_string_ref (filename, i) != '\\'))
--i;
while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
|| scm_i_string_ref (filename, i) == '\\'))
--i;
#else
while (i >= 0 && s[i] == '/') --i;
while (i >= 0 && s[i] != '/') --i;
while (i >= 0 && s[i] == '/') --i;
while (i >= 0 && scm_i_string_ref (filename, i) == '/')
--i;
while (i >= 0 && scm_i_string_ref (filename, i) != '/')
--i;
while (i >= 0 && scm_i_string_ref (filename, i) == '/')
--i;
#endif /* ndef __MINGW32__ */
if (i < 0)
{
#ifdef __MINGW32__
if (len > 0 && (s[0] == '/' || s[0] == '\\'))
if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
|| scm_i_string_ref (filename, 0) == '\\'))
#else
if (len > 0 && s[0] == '/')
if (len > 0 && scm_i_string_ref (filename, 0) == '/')
#endif /* ndef __MINGW32__ */
return scm_c_substring (filename, 0, 1);
else
@ -1616,11 +1624,9 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
"@var{basename}, it is removed also.")
#define FUNC_NAME s_scm_basename
{
const char *f, *s = 0;
int i, j, len, end;
SCM_VALIDATE_STRING (1, filename);
f = scm_i_string_chars (filename);
len = scm_i_string_length (filename);
if (SCM_UNBNDP (suffix))
@ -1628,32 +1634,44 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
else
{
SCM_VALIDATE_STRING (2, suffix);
s = scm_i_string_chars (suffix);
j = scm_i_string_length (suffix) - 1;
}
i = len - 1;
#ifdef __MINGW32__
while (i >= 0 && (f[i] == '/' || f[i] == '\\')) --i;
while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
|| scm_i_string_ref (filename, i) == '\\'))
--i;
#else
while (i >= 0 && f[i] == '/') --i;
while (i >= 0 && scm_i_string_ref (filename, i) == '/')
--i;
#endif /* ndef __MINGW32__ */
end = i;
while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
while (i >= 0 && j >= 0
&& (scm_i_string_ref (filename, i)
== scm_i_string_ref (suffix, j)))
{
--i;
--j;
}
if (j == -1)
end = i;
#ifdef __MINGW32__
while (i >= 0 && f[i] != '/' && f[i] != '\\') --i;
while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
&& scm_i_string_ref (filename, i) != '\\'))
--i;
#else
while (i >= 0 && f[i] != '/') --i;
while (i >= 0 && scm_i_string_ref (filename, i) != '/')
--i;
#endif /* ndef __MINGW32__ */
if (i == end)
{
#ifdef __MINGW32__
if (len > 0 && (f[0] == '/' || f[0] == '\\'))
if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
|| scm_i_string_ref (filename, 0) == '\\'))
#else
if (len > 0 && f[0] == '/')
if (len > 0 && scm_i_string_ref (filename, 0) == '/')
#endif /* ndef __MINGW32__ */
return scm_c_substring (filename, 0, 1);
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
}

4
libguile/fports.c
View file

@ -587,7 +587,7 @@ static void fport_flush (SCM port);
/* fill a port's read-buffer with a single read. returns the first
char or EOF if end of file. */
static int
static scm_t_wchar
fport_fill_input (SCM port)
{
long count;
@ -601,7 +601,7 @@ fport_fill_input (SCM port)
if (count == -1)
scm_syserror ("fport_fill_input");
if (count == 0)
return EOF;
return (scm_t_wchar) EOF;
else
{
pt->read_pos = pt->read_buf;

8
libguile/frames.c
View file

@ -33,7 +33,7 @@ scm_t_bits scm_tc16_vm_frame;
SCM
scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_byte_t *ip, scm_t_ptrdiff offset)
scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
"vmframe");
@ -111,12 +111,12 @@ SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
if (!bp->nargs)
return SCM_EOL;
else if (bp->nrest)
ret = fp[bp->nargs - 1];
ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
else
ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
for (i = bp->nargs - 2; i >= 0; i--)
ret = scm_cons (fp[i], ret);
ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
return ret;
}

40
libguile/frames.h
View file

@ -30,39 +30,46 @@
/* VM Frame Layout
---------------
| | <- fp + bp->nargs + bp->nlocs + 3
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| MV return address|
| Dynamic link | <- fp + bp->nargs + bp->blocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| ... |
| Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
+==================+
| Local variable 1 |
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+------------------+
| Return address |
| MV return address|
| Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
| |
As can be inferred from this drawing, it is assumed that
`sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
assumed to be as long as SCM objects. */
#define SCM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
#define SCM_FRAME_UPPER_ADDRESS(fp) \
(fp \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4)
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \
((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(ra);
#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \
((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(mvra);
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1]
@ -79,7 +86,7 @@ struct scm_vm_frame
SCM stack_holder;
SCM *fp;
SCM *sp;
scm_byte_t *ip;
scm_t_uint8 *ip;
scm_t_ptrdiff offset;
};
@ -92,9 +99,8 @@ struct scm_vm_frame
#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
/* FIXME rename scm_byte_t */
SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_byte_t *ip, scm_t_ptrdiff offset);
scm_t_uint8 *ip, scm_t_ptrdiff offset);
SCM_API SCM scm_vm_frame_p (SCM obj);
SCM_API SCM scm_vm_frame_program (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame);

6
libguile/gc-card.c
View file

@ -43,7 +43,7 @@
#include "libguile/strings.h"
#include "libguile/struct.h"
#include "libguile/tags.h"
#include "libguile/unif.h"
#include "libguile/arrays.h"
#include "libguile/validate.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
@ -162,6 +162,8 @@ scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg)
break;
case scm_tc7_variable:
break;
case scm_tc7_program:
break;
case scm_tcs_subrs:
/* the various "subrs" (primitives) are never freed */
continue;
@ -386,6 +388,8 @@ scm_i_tag_name (scm_t_bits tag)
return "closures";
case scm_tc7_pws:
return "pws";
case scm_tc7_program:
return "program";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:

10
libguile/gc-malloc.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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 License
@ -37,7 +37,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
@ -83,7 +83,7 @@ static int scm_i_minyield_malloc;
void
scm_gc_init_malloc (void)
{
scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
int mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
SCM_DEFAULT_INIT_MALLOC_LIMIT);
scm_i_minyield_malloc = scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
SCM_DEFAULT_MALLOC_MINYIELD);
@ -93,8 +93,10 @@ scm_gc_init_malloc (void)
if (scm_i_minyield_malloc < 1)
scm_i_minyield_malloc = 1;
if (scm_mtrigger < 0)
if (mtrigger < 0)
scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
else
scm_mtrigger = mtrigger;
}

Some files were not shown because too many files have changed in this diff Show more