mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-27 21:40:34 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	GUILE-VERSION
This commit is contained in:
Andy Wingo 2011-04-28 15:53:35 +02:00
commit 1903eae4c9
117 changed files with 3447 additions and 2474 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -198,6 +198,21 @@ test_scm_with_guile_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-scm-with-guile
TESTS += test-scm-with-guile
test_scm_spawn_thread_CFLAGS = ${test_cflags}
test_scm_spawn_thread_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-scm-spawn-thread
TESTS += test-scm-spawn-thread
test_pthread_create_CFLAGS = ${test_cflags}
test_pthread_create_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-pthread-create
TESTS += test-pthread-create
test_pthread_create_secondary_CFLAGS = ${test_cflags} $(BDW_GC_CFLAGS)
test_pthread_create_secondary_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-pthread-create-secondary
TESTS += test-pthread-create-secondary
else
EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c

2
test-suite/standalone/test-asmobs-lib.c
View file

@ -16,7 +16,7 @@
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

2
test-suite/standalone/test-extensions-lib.c
View file

@ -16,7 +16,7 @@
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

2
test-suite/standalone/test-ffi-lib.c
View file

@ -16,7 +16,7 @@
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

2
test-suite/standalone/test-list.c
View file

@ -18,7 +18,7 @@
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

2
test-suite/standalone/test-num2integral.c
View file

@ -16,7 +16,7 @@
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

85
test-suite/standalone/test-pthread-create-secondary.c Normal file
View file

@ -0,0 +1,85 @@
/* Copyright (C) 2011 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
*/
/* Test whether threads created with `pthread_create' work, and whether
a secondary thread can call `scm_with_guile'. (bug #32436). */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <pthread.h>
#include <stdlib.h>
#include <libguile.h>
#include <gc/gc_version.h>
/* Up to GC 7.2alpha5, calling `GC_INIT' from a secondary thread would
lead to a segfault. This was fixed in BDW-GC on 2011-04-16 by Ivan
Maidanski. See <http://thread.gmane.org/gmane.lisp.guile.bugs/5340>
for details. */
#if (GC_VERSION_MAJOR > 7) \
|| ((GC_VERSION_MAJOR == 7) && (GC_VERSION_MINOR > 2)) \
|| ((GC_VERSION_MAJOR == 7) && (GC_VERSION_MINOR == 2) \
&& (GC_ALPHA_VERSION > 5))
static void *
do_something (void *arg)
{
scm_list_copy (scm_make_list (scm_from_int (1234), SCM_BOOL_T));
scm_gc ();
return NULL;
}
static void *
thread (void *arg)
{
scm_with_guile (do_something, NULL);
return NULL;
}
int
main (int argc, char *argv[])
{
int i;
for (i = 0; i < 77; i++)
{
pthread_t thr;
pthread_create (&thr, NULL, thread, NULL);
pthread_join (thr, NULL);
}
return EXIT_SUCCESS;
}
#else /* GC < 7.2 */
int
main (int argc, char *argv[])
{
/* Skip. */
return 77;
}
#endif /* GC < 7.2 */

69
test-suite/standalone/test-pthread-create.c Normal file
View file

@ -0,0 +1,69 @@
/* Copyright (C) 2011 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
*/
/* Test whether threads created with `pthread_create' work (bug #32436)
when then main thread is the one that initializes Guile. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <pthread.h>
#include <stdlib.h>
#include <libguile.h>
static void *
do_something (void *arg)
{
scm_list_copy (scm_make_list (scm_from_int (1234), SCM_BOOL_T));
scm_gc ();
return NULL;
}
static void *
thread (void *arg)
{
scm_with_guile (do_something, NULL);
return NULL;
}
static void *
inner_main (void *data)
{
int i;
pthread_t thr;
do_something (NULL);
for (i = 0; i < 77; i++)
{
pthread_create (&thr, NULL, thread, NULL);
pthread_join (thr, NULL);
}
return NULL;
}
int
main (int argc, char *argv[])
{
scm_with_guile (inner_main, NULL);
return EXIT_SUCCESS;
}

62
test-suite/standalone/test-scm-spawn-thread.c Normal file
View file

@ -0,0 +1,62 @@
/* Copyright (C) 2011 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
*/
/* Test whether a thread created with `scm_spawn_thread' can be joined.
See <http://thread.gmane.org/gmane.lisp.guile.devel/11804> for the
original report. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <libguile.h>
#include <time.h>
#include <stdlib.h>
static SCM
thread_main (void *data)
{
return SCM_BOOL_T;
}
static SCM
thread_handler (void *data, SCM key, SCM args)
{
return SCM_BOOL_T;
}
static void *
inner_main (void *data)
{
SCM thread, timeout;
thread = scm_spawn_thread (thread_main, 0, thread_handler, 0);
timeout = scm_from_unsigned_integer (time (NULL) + 10);
return (void *) scm_join_thread_timed (thread, timeout, SCM_BOOL_F);
}
int
main (int argc, char **argv)
{
SCM result;
result = PTR2SCM (scm_with_guile (inner_main, 0));
return scm_is_true (result) ? EXIT_SUCCESS : EXIT_FAILURE;
}

2
test-suite/standalone/test-with-guile-module.c
View file

@ -16,7 +16,7 @@
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

38
test-suite/tests/control.test
View file

@ -350,3 +350,41 @@
(and (eq? key 'foo)
(eq? vm new-vm)
(eq? (the-vm) prev-vm)))))))
;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
;;
(with-test-prefix "shift and reset"
(pass-if (equal?
117
(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
(pass-if (equal?
60
(* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
(pass-if (equal?
121
(let ((f (lambda (x) (shift k (k (k x))))))
(+ 1 (reset (+ 10 (f 100)))))))
(pass-if (equal?
'a
(car (reset
(let ((x (shift f
(shift f1 (f1 (cons 'a (f '())))))))
(shift g x))))))
;; Example by Olivier Danvy
(pass-if (equal?
'(1 2 3 4 5)
(let ()
(define (traverse xs)
(define (visit xs)
(if (null? xs)
'()
(visit (shift*
(lambda (k)
(cons (car xs) (k (cdr xs))))))))
(reset* (lambda () (visit xs))))
(traverse '(1 2 3 4 5))))))

184
test-suite/tests/ports.test
View file

@ -391,7 +391,8 @@
(with-fluids ((%default-port-encoding e))
(call-with-output-string
(lambda (p)
(display (port-encoding p) p)))))
(and (string=? e (port-encoding p))
(display (port-encoding p) p))))))
encodings)
encodings)))
@ -462,80 +463,129 @@
(= (port-line p) 0)
(= (port-column p) 0))))
(pass-if "read-char, wrong encoding, error"
(let ((p (with-fluids ((%default-port-encoding "UTF-8"))
(open-bytevector-input-port #vu8(255 65 66 67)))))
(catch 'decoding-error
(lambda ()
(set-port-conversion-strategy! p 'error)
(read-char p)
#f)
(lambda (key subr message err port)
(and (eq? port p)
(pass-if "peek-char [utf-16]"
(let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
(open-input-string "안녕하세요"))))
(and (char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
(= (port-line p) 0)
(= (port-column p) 0))))
;; PORT should point past the error.
(equal? '(#\A #\B #\C)
(list (read-char port)
(read-char port)
(read-char port)))
;; Mini DSL to test decoding error handling.
(letrec-syntax ((decoding-error?
(syntax-rules ()
((_ port exp)
(catch 'decoding-error
(lambda ()
(pk 'exp exp)
#f)
(lambda (key subr message errno p)
(and (eq? p port)
(not (= 0 errno))))))))
(make-check
(syntax-rules (-> error eof)
((_ port (proc -> error))
(decoding-error? port (proc port)))
((_ port (proc -> eof))
(eof-object? (proc port)))
((_ port (proc -> char))
(eq? (proc port) char))))
(make-checks
(syntax-rules ()
((_ port check ...)
(and (make-check port check) ...))))
(test-decoding-error
(syntax-rules (tests)
((_ sequence encoding strategy (tests checks ...))
(pass-if (format #f "test-decoding-error: ~s ~s ~s ~s"
(caar '(checks ...))
'sequence encoding strategy)
(let ((p (open-bytevector-input-port
(u8-list->bytevector 'sequence))))
(set-port-encoding! p encoding)
(set-port-conversion-strategy! p strategy)
(make-checks p checks ...)))))))
(eof-object? (read-char port)))))))
(test-decoding-error (255 65 66 67) "UTF-8" 'error
(tests
(read-char -> error)
(read-char -> #\A)
(read-char -> #\B)
(read-char -> #\C)
(read-char -> eof)))
(pass-if "read-char, wrong encoding, escape"
;; `escape' should behave exactly like `error'.
(let ((p (with-fluids ((%default-port-encoding "UTF-8"))
(open-bytevector-input-port #vu8(255 65 66 67)))))
(catch 'decoding-error
(lambda ()
(set-port-conversion-strategy! p 'escape)
(read-char p)
#f)
(lambda (key subr message err port)
(and (eq? port p)
(test-decoding-error (255 65 66 67) "UTF-8" 'escape
;; `escape' should behave exactly like `error'.
(tests
(read-char -> error)
(read-char -> #\A)
(read-char -> #\B)
(read-char -> #\C)
(read-char -> eof)))
;; PORT should point past the error.
(equal? '(#\A #\B #\C)
(list (read-char port)
(read-char port)
(read-char port)))
(test-decoding-error (255 206 187 206 188) "UTF-8" 'substitute
(tests
(read-char -> #\?)
(read-char -> #\λ)
(read-char -> #\μ)
(read-char -> eof)))
(eof-object? (read-char port)))))))
(test-decoding-error (206 187 206) "UTF-8" 'error
;; Unterminated sequence.
(tests
(read-char -> #\λ)
(read-char -> error)
(read-char -> eof)))
(pass-if "read-char, wrong encoding, substitute"
(let ((p (with-fluids ((%default-port-encoding "UTF-8"))
(open-bytevector-input-port #vu8(255 206 187 206 188)))))
(set-port-conversion-strategy! p 'substitute)
(equal? (list (read-char p) (read-char p) (read-char p))
'(#\? #\λ #\μ))))
(test-decoding-error (206 187 206) "UTF-8" 'substitute
;; Unterminated sequence.
(tests
(read-char -> #\λ)
(read-char -> #\?)
(read-char -> eof)))
(pass-if "peek-char, wrong encoding, error"
(let-syntax ((decoding-error?
(syntax-rules ()
((_ port exp)
(catch 'decoding-error
(lambda ()
(pk 'exp exp)
#f)
(lambda (key subr message errno p)
(eq? p port)))))))
(let ((p (with-fluids ((%default-port-encoding "UTF-8"))
(open-bytevector-input-port #vu8(255 65 66 67)))))
(set-port-conversion-strategy! p 'error)
(test-decoding-error (255 65 66 67) "UTF-8" 'error
(tests
;; `peek-char' should repeatedly raise an error.
(peek-char -> error)
(peek-char -> error)
(peek-char -> error)
;; `peek-char' should repeatedly raise an error.
(and (decoding-error? p (peek-char p))
(decoding-error? p (peek-char p))
(decoding-error? p (peek-char p))
;; Move past the error.
(read-char -> error)
;; Move past the error.
(decoding-error? p (read-char p))
(read-char -> #\A)
(read-char -> #\B)
(read-char -> #\C)
(read-char -> eof)))
;; Finish happily.
(equal? '(#\A #\B #\C)
(list (read-char p)
(read-char p)
(read-char p)))
(eof-object? (read-char p)))))))
;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
;; of the "Conformance" chapter of Unicode 6.0.0.)
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'error
(tests
(read-char -> error) ;; C0: should be in the C2..DF range
(read-char -> error) ;; 80: invalid
(read-char -> #\A)
(read-char -> eof)))
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'error
(tests
(read-char -> error) ;; C0: should be in the C2..DF range
(read-char -> error) ;; 80: invalid
(read-char -> #\A)
(read-char -> eof)))
(test-decoding-error (#xe0 #x88 #x88) "UTF-8" 'error
(tests
(read-char -> error) ;; 2nd byte should be in the A0..BF range
(read-char -> eof)))
(test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8" 'error
(tests
(read-char -> error) ;; 2nd byte should be in the 90..BF range
(read-char -> eof)))))
(with-test-prefix "call-with-output-string"
@ -994,3 +1044,7 @@
'("read" "read-char" "read-line")))
(delete-file (test-file))
;;; Local Variables:
;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
;;; End:

13
test-suite/tests/posix.test
View file

@ -198,16 +198,3 @@
(setaffinity (getpid) mask)
(equal? mask (getaffinity (getpid))))
(throw 'unresolved))))
;;
;; nproc
;;
(with-test-prefix "nproc"
(pass-if "total-processor-count"
(>= (total-processor-count) 1))
(pass-if "current-processor-count"
(and (>= (current-processor-count) 1)
(>= (total-processor-count) (current-processor-count)))))

15
test-suite/tests/r6rs-ports.test
View file

@ -294,6 +294,10 @@
(equal? (read-to-string port) str)))
(pass-if "bytevector-input-port is binary"
(with-fluids ((%default-port-encoding "UTF-8"))
(binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
(pass-if-exception "bytevector-input-port is read-only"
exception:wrong-type-arg
@ -350,7 +354,9 @@
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(bytevector=? (get-bytevector-all port) source)))
(and (binary-port? port)
(input-port? port)
(bytevector=? (get-bytevector-all port) source))))
(pass-if "custom binary input port does not support `port-position'"
(let* ((str "Hello Port!")
@ -422,7 +428,10 @@
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
(pass-if "bytevector-output-port is binary"
(binary-port? (open-bytevector-output-port)))
(pass-if "open-bytevector-output-port [extract after close]"
(let-values (((port get-content)
(open-bytevector-output-port)))
@ -468,7 +477,7 @@
(bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
(pass-if "make-custom-binary-output"
(pass-if "make-custom-binary-output-port"
(let ((port (make-custom-binary-output-port "cbop"
(lambda (x y z) 0)
#f #f #f)))

8
test-suite/tests/rdelim.test
View file

@ -72,8 +72,8 @@
(eof-object? (read-line p)))))
(pass-if "decoding error"
(let ((p (with-fluids ((%default-port-encoding "UTF-8"))
(open-bytevector-input-port #vu8(65 255 66 67 68)))))
(let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
(set-port-encoding! p "UTF-8")
(set-port-conversion-strategy! p 'error)
(catch 'decoding-error
(lambda ()
@ -87,8 +87,8 @@
(eof-object? (read-line p)))))))
(pass-if "decoding error, substitute"
(let ((p (with-fluids ((%default-port-encoding "UTF-8"))
(open-bytevector-input-port #vu8(65 255 66 67 68)))))
(let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
(set-port-encoding! p "UTF-8")
(set-port-conversion-strategy! p 'substitute)
(and (string=? (read-line p) "A?BCD")
(eof-object? (read-line p))))))

17
test-suite/tests/syntax.test
View file

@ -983,11 +983,18 @@
(with-test-prefix "break"
(pass-if-syntax-error "too many args" exception:too-many-args
(eval '(while #t
(break 1))
(interaction-environment)))
(pass-if "normal return"
(not (while #f (error "not reached"))))
(pass-if "no args"
(while #t (break)))
(pass-if "multiple values"
(equal? '(1 2 3)
(call-with-values
(lambda () (while #t (break 1 2 3)))
list)))
(with-test-prefix "from cond"
(pass-if "first"
(while (begin

22
test-suite/tests/threads.test
View file

@ -1,6 +1,6 @@
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011 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
@ -213,7 +213,7 @@
(signal-condition-variable c)
(unlock-mutex cm)
(lock-mutex m
(+ (current-time) 2))))))
(+ (current-time) 5))))))
(lock-mutex m)
(wait-condition-variable c cm)
(unlock-mutex cm)
@ -257,7 +257,7 @@
(unlock-mutex m2
c2
(+ (current-time)
2))))))
5))))))
(wait-condition-variable c1 m1)
(unlock-mutex m1)
(lock-mutex m2)
@ -292,7 +292,7 @@
(pass-if "timed joining succeeds if thread exits within timeout"
(let ((t (begin-thread (begin (sleep 1) #t))))
(join-thread t (+ (current-time) 2))))
(join-thread t (+ (current-time) 5))))
(pass-if "asyncs are still working 1"
(asyncs-still-working?))
@ -463,3 +463,17 @@
(lambda () (lock-mutex m))
(lambda key (set! success #t)))
success)))))
;;
;; nproc
;;
(with-test-prefix "nproc"
(pass-if "total-processor-count"
(>= (total-processor-count) 1))
(pass-if "current-processor-count"
(and (>= (current-processor-count) 1)
(>= (total-processor-count) (current-processor-count)))))

17
test-suite/tests/tree-il.test
View file

@ -1153,6 +1153,13 @@
(number? (string-contains (car w)
"non-literal format string")))))
(pass-if "non-literal format string using gettext"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
@ -1190,6 +1197,16 @@
(number? (string-contains (car w)
"expected 1, got 0")))))
(pass-if "one missing argument, gettext"
(let ((w (call-with-warnings
(lambda ()
(compile '(format some-port (_ "foo ~A~%"))
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(pass-if "two missing arguments"
(let ((w (call-with-warnings
(lambda ()