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

(define-module (test-suite lib)
  :use-module (ice-9 stack-catch)
  :use-module (ice-9 regex)
  :export (

 ;; Exceptions which are commonly being tested for.
 exception:bad-variable
 exception:missing-expression
 exception:out-of-range exception:unbound-var
 exception:used-before-defined
 exception:wrong-num-args exception:wrong-type-arg
 exception:numerical-overflow
 exception:struct-set!-denied
 exception:system-error
 exception:miscellaneous-error
 exception:string-contains-nul

 ;; Reporting passes and failures.
 run-test
 pass-if expect-fail
 pass-if-exception expect-fail-exception

 ;; Naming groups of tests in a regular fashion.
 with-test-prefix with-test-prefix* current-test-prefix
 format-test-name

 ;; Using the debugging evaluator.
 with-debugging-evaluator with-debugging-evaluator*

 ;; Reporting results in various ways.
 register-reporter unregister-reporter reporter-registered?
 make-count-reporter print-counts
 make-log-reporter
 full-reporter
 user-reporter))

;;;; If you're using Emacs's Scheme mode:
;;;;   (put 'with-test-prefix 'scheme-indent-function 1)

;;;; CORE FUNCTIONS
;;;;
;;;; The function (run-test name expected-result thunk) is the heart of the
;;;; testing environment.  The first parameter NAME is a unique name for the
;;;; test to be executed (for an explanation of this parameter see below under
;;;; TEST NAMES).  The second parameter EXPECTED-RESULT is a boolean value
;;;; that indicates whether the corresponding test is expected to pass.  If
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
;;;; #f the test is expected to fail.  Finally, THUNK is the function that
;;;; actually performs the test.  For example:
;;;;
;;;;    (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
;;;;
;;;; To report success, THUNK should either return #t or throw 'pass.  To
;;;; report failure, THUNK should either return #f or throw 'fail.  If THUNK
;;;; returns a non boolean value or throws 'unresolved, this indicates that
;;;; the test did not perform as expected.  For example the property that was
;;;; to be tested could not be tested because something else went wrong.
;;;; THUNK may also throw 'untested to indicate that the test was deliberately
;;;; not performed, for example because the test case is not complete yet.
;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
;;;; requires some feature that is not available in the configured testing
;;;; environment.  All other exceptions thrown by THUNK are considered as
;;;; errors.
;;;;
;;;;
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for
;;;;   (run-test name #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
;;;;   (run-test name #f (lambda () body))
;;;;
;;;; For example:
;;;;
;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
;;;;
;;;;
;;;; Convenience macros to test for exceptions
;;;;
;;;; The following macros take exception parameters which are pairs
;;;; (type . message), where type is a symbol that denotes an exception type
;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
;;;; regular expression that describes the error message for the exception
;;;; like "Argument .* out of range".
;;;;
;;;; * (pass-if-exception name exception body) will pass if the execution of
;;;;   body causes the given exception to be thrown.  If no exception is
;;;;   thrown, the test fails.  If some other exception is thrown, is is an
;;;;   error.
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
;;;;   the execution of body causes the given exception to be thrown.  If no
;;;;   exception is thrown, the test fails expectedly.  If some other
;;;;   exception is thrown, it is an error.

;;;; TEST NAMES
;;;;
;;;; Every test in the test suite has a unique name, to help
;;;; developers find tests that are failing (or unexpectedly passing),
;;;; and to help gather statistics.
;;;;
;;;; A test name is a list of printable objects.  For example:
;;;; ("ports.scm" "file" "read and write back list of strings")
;;;; ("ports.scm" "pipe" "read")
;;;;
;;;; Test names may contain arbitrary objects, but they always have
;;;; the following properties:
;;;; - Test names can be compared with EQUAL?.
;;;; - Test names can be reliably stored and retrieved with the standard WRITE
;;;;   and READ procedures; doing so preserves their identity.
;;;;
;;;; For example:
;;;;
;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
;;;;
;;;; In that case, the test name is the list ("simple addition").
;;;;
;;;; In the case of simple tests the expression that is tested would often
;;;; suffice as a test name by itself.  Therefore, the convenience macros
;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
;;;; a test name in such cases.
;;;;
;;;; * (pass-if expression) is a short form for
;;;;   (run-test 'expression #t (lambda () expression))
;;;; * (expect-fail expression) is a short form for
;;;;   (run-test 'expression #f (lambda () expression))
;;;;
;;;; For example:
;;;;
;;;;    (pass-if (= 2 (+ 1 1)))
;;;;
;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
;;;; a prefix for the names of all tests whose results are reported
;;;; within their dynamic scope.  For example:
;;;;
;;;; (begin
;;;;   (with-test-prefix "basic arithmetic"
;;;;     (pass-if "addition" (= (+ 2 2) 4))
;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
;;;;
;;;; In that example, the three test names are:
;;;;   ("basic arithmetic" "addition"),
;;;;   ("basic arithmetic" "subtraction"), and
;;;;   ("multiplication").
;;;;
;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
;;;; a new element to the current prefix:
;;;;
;;;; (with-test-prefix "arithmetic"
;;;;   (with-test-prefix "addition"
;;;;     (pass-if "integer" (= (+ 2 2) 4))
;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
;;;;   (with-test-prefix "subtraction"
;;;;     (pass-if "integer" (= (- 2 2) 0))
;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
;;;;
;;;; The four test names here are:
;;;;   ("arithmetic" "addition" "integer")
;;;;   ("arithmetic" "addition" "complex")
;;;;   ("arithmetic" "subtraction" "integer")
;;;;   ("arithmetic" "subtraction" "complex")
;;;;
;;;; To print a name for a human reader, we DISPLAY its elements,
;;;; separated by ": ".  So, the last set of test names would be
;;;; reported as:
;;;;
;;;;   arithmetic: addition: integer
;;;;   arithmetic: addition: complex
;;;;   arithmetic: subtraction: integer
;;;;   arithmetic: subtraction: complex
;;;;
;;;; The Guile benchmarks use with-test-prefix to include the name of
;;;; the source file containing the test in the test name, to help
;;;; developers to find failing tests, and to provide each file with its
;;;; own namespace.

;;;; REPORTERS
;;;;
;;;; A reporter is a function which we apply to each test outcome.
;;;; Reporters can log results, print interesting results to the
;;;; standard output, collect statistics, etc.
;;;;
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
;;;; possibly additional arguments depending on RESULT; its return value
;;;; is ignored.  RESULT has one of the following forms:
;;;;
;;;; pass         - The test named TEST passed.
;;;;                Additional arguments are ignored.
;;;; upass        - The test named TEST passed unexpectedly.
;;;;                Additional arguments are ignored.
;;;; fail         - The test named TEST failed.
;;;;                Additional arguments are ignored.
;;;; xfail        - The test named TEST failed, as expected.
;;;;                Additional arguments are ignored.
;;;; unresolved   - The test named TEST did not perform as expected, for
;;;;                example the property that was to be tested could not be
;;;;                tested because something else went wrong.
;;;;                Additional arguments are ignored.
;;;; untested     - The test named TEST was not actually performed, for
;;;;                example because the test case is not complete yet.
;;;;                Additional arguments are ignored.
;;;; unsupported  - The test named TEST requires some feature that is not
;;;;                available in the configured testing environment.
;;;;                Additional arguments are ignored.
;;;; error        - An error occurred while the test named TEST was
;;;;                performed.  Since this result means that the system caught
;;;;                an exception it could not handle, the exception arguments
;;;;                are passed as additional arguments.
;;;;
;;;; This library provides some standard reporters for logging results
;;;; to a file, reporting interesting results to the user, and
;;;; collecting totals.
;;;;
;;;; You can use the REGISTER-REPORTER function and friends to add
;;;; whatever reporting functions you like.  If you don't register any
;;;; reporters, the library uses FULL-REPORTER, which simply writes
;;;; all results to the standard output.

;;;; MISCELLANEOUS
;;;;

;;; Define some exceptions which are commonly being tested for.
(define exception:bad-variable
  (cons 'syntax-error "Bad variable"))
(define exception:missing-expression
  (cons 'misc-error "^missing or extra expression"))
(define exception:out-of-range
  (cons 'out-of-range "^.*out of range"))
(define exception:unbound-var
  (cons 'unbound-variable "^Unbound variable"))
(define exception:used-before-defined
  (cons 'unbound-variable "^Variable used before given a value"))
(define exception:wrong-num-args
  (cons 'wrong-number-of-args "^Wrong number of arguments"))
(define exception:wrong-type-arg
  (cons 'wrong-type-arg "^Wrong type"))
(define exception:numerical-overflow
  (cons 'numerical-overflow "^Numerical overflow"))
(define exception:struct-set!-denied
  (cons 'misc-error "^set! denied for field"))
(define exception:system-error
  (cons 'system-error ".*"))
(define exception:miscellaneous-error
  (cons 'misc-error "^.*"))

;; as per throw in scm_to_locale_stringn()
(define exception:string-contains-nul
  (cons 'misc-error "^string contains #\\\\nul character"))

;;; Display all parameters to the default output port, followed by a newline.
(define (display-line . objs)
  (for-each display objs)
  (newline))

;;; Display all parameters to the given output port, followed by a newline.
(define (display-line-port port . objs)
  (for-each (lambda (obj) (display obj port)) objs)
  (newline port))

;;;; CORE FUNCTIONS
;;;;

;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test #f)
(let ((test-running #f))
  (define (local-run-test name expect-pass thunk)
    (if test-running
	(error "Nested calls to run-test are not permitted.")
	(let ((test-name (full-name name)))
	  (set! test-running #t)
	  (catch #t
	    (lambda ()
	      (let ((result (thunk)))
		(if (eq? result #t) (throw 'pass))
		(if (eq? result #f) (throw 'fail))
		(throw 'unresolved)))
	    (lambda (key . args)
	      (case key
		((pass)
		 (report (if expect-pass 'pass 'upass) test-name))
		((fail)
		 (report (if expect-pass 'fail 'xfail) test-name))
		((unresolved untested unsupported)
		 (report key test-name))
		((quit)
		 (report 'unresolved test-name)
		 (quit))
		(else
		 (report 'error test-name (cons key args))))))
	  (set! test-running #f))))
  (set! run-test local-run-test))

;;; A short form for tests that are expected to pass, taken from Greg.
(defmacro pass-if (name . rest)
  (if (and (null? rest) (pair? name))
      ;; presume this is a simple test, i.e. (pass-if (even? 2))
      ;; where the body should also be the name.
      `(run-test ',name #t (lambda () ,name))
      `(run-test ,name #t (lambda () ,@rest))))

;;; A short form for tests that are expected to fail, taken from Greg.
(defmacro expect-fail (name . rest)
  (if (and (null? rest) (pair? name))
      ;; presume this is a simple test, i.e. (expect-fail (even? 2))
      ;; where the body should also be the name.
      `(run-test ',name #f (lambda () ,name))
      `(run-test ,name #f (lambda () ,@rest))))

;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
  (run-test name expect-pass
    (lambda ()
      (stack-catch (car exception)
	(lambda () (thunk) #f)
	(lambda (key proc message . rest)
	  (cond
           ;; handle explicit key
           ((string-match (cdr exception) message)
            #t)
           ;; handle `(error ...)' which uses `misc-error' for key and doesn't
           ;; yet format the message and args (we have to do it here).
           ((and (eq? 'misc-error (car exception))
                 (list? rest)
                 (string-match (cdr exception)
                               (apply simple-format #f message (car rest))))
            #t)
           ;; handle syntax errors which use `syntax-error' for key and don't
           ;; yet format the message and args (we have to do it here).
           ((and (eq? 'syntax-error (car exception))
                 (list? rest)
                 (string-match (cdr exception)
                               (apply simple-format #f message (car rest))))
            #t)
           ;; unhandled; throw again
           (else
            (apply throw key proc message rest))))))))

;;; A short form for tests that expect a certain exception to be thrown.
(defmacro pass-if-exception (name exception body . rest)
  `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))

;;; A short form for tests expected to fail to throw a certain exception.
(defmacro expect-fail-exception (name exception body . rest)
  `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))

;;;; TEST NAMES
;;;;

;;;; Turn a test name into a nice human-readable string.
(define (format-test-name name)
  (call-with-output-string
   (lambda (port)
     (let loop ((name name)
		(separator ""))
       (if (pair? name)
	   (begin
	     (display separator port)
	     (display (car name) port)
	     (loop (cdr name) ": ")))))))

;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
  (append (current-test-prefix) (list name)))

;;; A fluid containing the current test prefix, as a list.
(define prefix-fluid (make-fluid))
(fluid-set! prefix-fluid '())
(define (current-test-prefix)
  (fluid-ref prefix-fluid))

;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
;;; The name prefix is only changed within the dynamic scope of the
;;; call to with-test-prefix*.  Return the value returned by THUNK.
(define (with-test-prefix* prefix thunk)
  (with-fluids ((prefix-fluid
		 (append (fluid-ref prefix-fluid) (list prefix))))
    (thunk)))

;;; (with-test-prefix PREFIX BODY ...)
;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
;;; The name prefix is only changed within the dynamic scope of the
;;; with-test-prefix expression.  Return the value returned by the last
;;; BODY expression.
(defmacro with-test-prefix (prefix . body)
  `(with-test-prefix* ,prefix (lambda () ,@body)))

;;; Call THUNK using the debugging evaluator.
(define (with-debugging-evaluator* thunk)
  (let ((dopts #f))
    (dynamic-wind
	(lambda ()
	  (set! dopts (debug-options))
	  (debug-enable 'debug))
	thunk
	(lambda ()
	  (debug-options dopts)))))

;;; Evaluate BODY... using the debugging evaluator.
(define-macro (with-debugging-evaluator . body)
  `(with-debugging-evaluator* (lambda () ,@body)))

;;;; REPORTERS
;;;;

;;; The global list of reporters.
(define reporters '())

;;; The default reporter, to be used only if no others exist.
(define default-reporter #f)

;;; Add the procedure REPORTER to the current set of reporter functions.
;;; Signal an error if that reporter procedure object is already registered.
(define (register-reporter reporter)
  (if (memq reporter reporters)
      (error "register-reporter: reporter already registered: " reporter))
  (set! reporters (cons reporter reporters)))

;;; Remove the procedure REPORTER from the current set of reporter
;;; functions.  Signal an error if REPORTER is not currently registered.
(define (unregister-reporter reporter)
  (if (memq reporter reporters)
      (set! reporters (delq! reporter reporters))
      (error "unregister-reporter: reporter not registered: " reporter)))

;;; Return true iff REPORTER is in the current set of reporter functions.
(define (reporter-registered? reporter)
  (if (memq reporter reporters) #t #f))

;;; Send RESULT to all currently registered reporter functions.
(define (report . args)
  (if (pair? reporters)
      (for-each (lambda (reporter) (apply reporter args))
		reporters)
      (apply default-reporter args)))

;;;; Some useful standard reporters:
;;;; Count reporters count the occurrence of each test result type.
;;;; Log reporters write all test results to a given log file.
;;;; Full reporters write all test results to the standard output.
;;;; User reporters write interesting test results to the standard output.

;;; The complete list of possible test results.
(define result-tags
  '((pass        "PASS"        "passes:                 ")
    (fail        "FAIL"        "failures:               ")
    (upass       "UPASS"       "unexpected passes:      ")
    (xfail       "XFAIL"       "expected failures:      ")
    (unresolved  "UNRESOLVED"  "unresolved test cases:  ")
    (untested    "UNTESTED"    "untested test cases:    ")
    (unsupported "UNSUPPORTED" "unsupported test cases: ")
    (error       "ERROR"       "errors:                 ")))

;;; The list of important test results.
(define important-result-tags
  '(fail upass unresolved error))

;;; Display a single test result in formatted form to the given port
(define (print-result port result name . args)
  (let* ((tag (assq result result-tags))
	 (label (if tag (cadr tag) #f)))
    (if label
	(begin
	  (display label port)
	  (display ": " port)
	  (display (format-test-name name) port)
	  (if (pair? args)
	      (begin
		(display " - arguments: " port)
		(write args port)))
	  (newline port))
	(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
	       result))))

;;; Return a list of the form (COUNTER RESULTS), where:
;;; - COUNTER is a reporter procedure, and
;;; - RESULTS is a procedure taking no arguments which returns the
;;;   results seen so far by COUNTER.  The return value is an alist
;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
(define (make-count-reporter)
  (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
    (list
     (lambda (result name . args)
       (let ((pair (assq result counts)))
	 (if pair
	     (set-cdr! pair (+ 1 (cdr pair)))
	     (error "count-reporter: unexpected test result: "
		    (cons result (cons name args))))))
     (lambda ()
       (append counts '())))))

;;; Print a count reporter's results nicely.  Pass this function the value
;;; returned by a count reporter's RESULTS procedure.
(define (print-counts results . port?)
  (let ((port (if (pair? port?)
		  (car port?)
		  (current-output-port))))
    (newline port)
    (display-line-port port "Totals for this test run:")
    (for-each
     (lambda (tag)
       (let ((result (assq (car tag) results)))
	 (if result
	     (display-line-port port (caddr tag) (cdr result))
	     (display-line-port port
				"Test suite bug: "
				"no total available for `" (car tag) "'"))))
     result-tags)
    (newline port)))

;;; Return a reporter procedure which prints all results to the file
;;; FILE, in human-readable form.  FILE may be a filename, or a port.
(define (make-log-reporter file)
  (let ((port (if (output-port? file) file
		  (open-output-file file))))
    (lambda args
      (apply print-result port args)
      (force-output port))))

;;; A reporter that reports all results to the user.
(define (full-reporter . args)
  (apply print-result (current-output-port) args))

;;; A reporter procedure which shows interesting results (failures,
;;; unexpected passes etc.) to the user.
(define (user-reporter result name . args)
  (if (memq result important-result-tags)
      (apply full-reporter result name args)))

(set! default-reporter full-reporter)


code:
/test-conversion
/test-gh
/test-list
/test-num2integral
/test-round
/test-unwind
/test-with-guile-module
/test-use-srfi
/test-scm-with-guile
/test-scm-c-read
/test-fast-slot-ref
/test-scm-take-locale-symbol

license: unknown


code:
## Process this file with automake to produce Makefile.in.
##
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 General Public License as
## published by the Free Software Foundation; either version 2, 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 General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING.  If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA

# initializations so we can use += below.
TESTS =
noinst_LTLIBRARIES =
check_PROGRAMS =
check_SCRIPTS =
BUILT_SOURCES =
EXTRA_DIST =

TESTS_ENVIRONMENT = 						\
  builddir="$(builddir)"					\
  "${top_builddir}/pre-inst-guile-env"

test_cflags =					\
  -I$(top_srcdir)/test-suite/standalone		\
  -I$(top_srcdir) -I$(top_builddir)		\
  $(EXTRA_DEFS) $(GUILE_CFLAGS)

AM_LDFLAGS = $(GUILE_CFLAGS)

snarfcppopts =						\
  $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS)	\
  -I$(top_srcdir) -I$(top_builddir)

SUFFIXES = .x
.c.x:
	${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts)

CLEANFILES = *.x

.DELETE_ON_ERROR:

check_SCRIPTS += test-system-cmds
TESTS += test-system-cmds

check_SCRIPTS += test-require-extension
TESTS += test-require-extension

check_SCRIPTS += test-bad-identifiers
TESTS += test-bad-identifiers

# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
test_num2integral_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-num2integral
TESTS += test-num2integral

# test-round
test_round_CFLAGS = ${test_cflags}
test_round_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-round
TESTS += test-round

# test-gh
test_gh_SOURCES = test-gh.c
test_gh_CFLAGS = ${test_cflags}
test_gh_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-gh
TESTS += test-gh

# test-asmobs
noinst_LTLIBRARIES += libtest-asmobs.la
libtest_asmobs_la_SOURCES = test-asmobs-lib.c test-asmobs-lib.x
libtest_asmobs_la_CFLAGS = ${test_cflags}
libtest_asmobs_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
libtest_asmobs_la_LIBADD = ${top_builddir}/libguile/libguile.la
BUILT_SOURCES += test-asmobs-lib.x
check_SCRIPTS += test-asmobs
TESTS += test-asmobs

# test-list
test_list_SOURCES = test-list.c
test_list_CFLAGS = ${test_cflags}
test_list_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-list
TESTS += test-list

# test-unwind
test_unwind_SOURCES = test-unwind.c
test_unwind_CFLAGS = ${test_cflags}
test_unwind_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-unwind
TESTS += test-unwind

# test-conversion
test_conversion_SOURCES = test-conversion.c
test_conversion_CFLAGS = ${test_cflags}
test_conversion_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-conversion
TESTS += test-conversion

# test-fast-slot-ref
check_SCRIPTS += test-fast-slot-ref
TESTS += test-fast-slot-ref

# test-use-srfi
check_SCRIPTS += test-use-srfi
TESTS += test-use-srfi

# test-scm-c-read
test_scm_c_read_SOURCES = test-scm-c-read.c
test_scm_c_read_CFLAGS = ${test_cflags}
test_scm_c_read_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-scm-c-read
TESTS += test-scm-c-read

# test-scm-take-locale-symbol
test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c
test_scm_take_locale_symbol_CFLAGS = ${test_cflags}
test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-scm-take-locale-symbol
TESTS += test-scm-take-locale-symbol

if BUILD_PTHREAD_SUPPORT

# test-with-guile-module
test_with_guile_module_CFLAGS = ${test_cflags}
test_with_guile_module_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-with-guile-module
TESTS += test-with-guile-module

test_scm_with_guile_CFLAGS = ${test_cflags}
test_scm_with_guile_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-scm-with-guile
TESTS += test-scm-with-guile

else

EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c

endif

all-local:
	cd ${srcdir} && chmod u+x ${check_SCRIPTS}

EXTRA_DIST += ${check_SCRIPTS}


code:
-*-text-*-

These tests use the standard automake TESTS mechanism.  Tests should
be listed in TESTS in Makefile.am, and should exit with 0 on success,
non-zero on failure, and 77 if the result should be ignored.  See the
automake info pages for more information.

If you want to use a scheme script, prefix it as follows:

  #!/bin/sh
  exec guile -s "$0" "$@"
  !#

Makefile.am will arrange for all tests (scripts or executables) to be
run under pre-inst-guile-env so that the PATH, LD_LIBRARY_PATH, and
GUILE_LOAD_PATH will be augmented appropriately.

The Makefile.am has an example of creating a shared library to be used
from a test scheme script as well.

You can also create standalone executables that include your own code,
are linked against libguile, and that run a given test script (or
scripts).  One way to do this is to create the binary, make sure it
calls scm_shell (argc, argv) as its final action, and put this bit at
the top of your test script:

  #!./my-test-binary -s
  !#

path: test-suite/standalone/README


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

(load-extension (string-append (getenv "builddir") "/libtest-asmobs")
                "libtest_asmobs_init")

(define (test x v)
  (if v
      (if (not (equal? (eval x (current-module)) v))
	  (error "Wrong return value" x))
      (catch #t
	     (lambda ()
	       (begin (eval x (current-module))
		      (throw 'should-be-error)))
	     (lambda (key . args)
	       (if (eq? key 'should-be-error)
		   (error "Should be error" x))))))

(define asmob000 (make-asmob000))
(test '(asmob000) '())
(test '(asmob000 1) #f)
(test '(asmob000 1 2) #f)
(test '(asmob000 1 2 3) #f)

(define asmob100 (make-asmob100))
(test '(asmob100) #f)
(test '(asmob100 1) '(1))
(test '(asmob100 1 2) #f)
(test '(asmob100 1 2 3) #f)

(define asmob010 (make-asmob010))
(test '(asmob010) '(#f))
(test '(asmob010 1) '(1))
(test '(asmob010 1 2) #f)
(test '(asmob010 1 2 3) #f)

(define asmob001 (make-asmob001))
(test '(asmob001) '(()))
(test '(asmob001 1) '((1)))
(test '(asmob001 1 2) '((1 2)))
(test '(asmob001 1 2 3) '((1 2 3)))

(define asmob200 (make-asmob200))
(test '(asmob200) #f)
(test '(asmob200 1) #f)
(test '(asmob200 1 2) '(1 2))
(test '(asmob200 1 2 3) #f)

(define asmob110 (make-asmob110))
(test '(asmob110) #f)
(test '(asmob110 1) '(1 #f))
(test '(asmob110 1 2) '(1 2))
(test '(asmob110 1 2 3) #f)

(define asmob020 (make-asmob020))
(test '(asmob020) '(#f #f))
(test '(asmob020 1) '(1 #f))
(test '(asmob020 1 2) '(1 2))
(test '(asmob020 1 2 3) #f)

(define asmob101 (make-asmob101))
(test '(asmob101) #f)
(test '(asmob101 1) '(1 ()))
(test '(asmob101 1 2) '(1 (2)))
(test '(asmob101 1 2 3) '(1 (2 3)))

(define asmob011 (make-asmob011))
(test '(asmob011) '(#f ()))
(test '(asmob011 1) '(1 ()))
(test '(asmob011 1 2) '(1 (2)))
(test '(asmob011 1 2 3) '(1 (2 3)))

(define asmob300 (make-asmob300))
(test '(asmob300) #f)
(test '(asmob300 1) #f)
(test '(asmob300 1 2) #f)
(test '(asmob300 1 2 3) '(1 2 3))

(define asmob210 (make-asmob210))
(test '(asmob210) #f)
(test '(asmob210 1) #f)
(test '(asmob210 1 2) '(1 2 #f))
(test '(asmob210 1 2 3) '(1 2 3))

(define asmob120 (make-asmob120))
(test '(asmob120) #f)
(test '(asmob120 1) '(1 #f #f))
(test '(asmob120 1 2) '(1 2 #f))
(test '(asmob120 1 2 3) '(1 2 3))

(define asmob030 (make-asmob030))
(test '(asmob030) '(#f #f #f))
(test '(asmob030 1) '(1 #f #f))
(test '(asmob030 1 2) '(1 2 #f))
(test '(asmob030 1 2 3) '(1 2 3))

(define asmob201 (make-asmob201))
(test '(asmob201) #f)
(test '(asmob201 1) #f)
(test '(asmob201 1 2) '(1 2 ()))
(test '(asmob201 1 2 3) '(1 2 (3)))

(define asmob021 (make-asmob021))
(test '(asmob021) '(#f #f ()))
(test '(asmob021 1) '(1 #f ()))
(test '(asmob021 1 2) '(1 2 ()))
(test '(asmob021 1 2 3) '(1 2 (3)))

(define asmob111 (make-asmob111))
(test '(asmob111) #f)
(test '(asmob111 1) '(1 #f ()))
(test '(asmob111 1 2) '(1 2 ()))
(test '(asmob111 1 2 3) '(1 2 (3)))

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

path: test-suite/standalone/test-asmobs


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

#ifndef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

long asmob000;
long asmob100;
long asmob010;
long asmob001;
long asmob200;
long asmob110;
long asmob020;
long asmob101;
long asmob011;
long asmob300;
long asmob210;
long asmob120;
long asmob030;
long asmob201;
long asmob021;
long asmob111;

/* since we don't have SCM_DEFINE_STATIC or similar */
SCM scm_make_asmob000 (void);
SCM scm_make_asmob001 (void);
SCM scm_make_asmob010 (void);
SCM scm_make_asmob011 (void);
SCM scm_make_asmob100 (void);
SCM scm_make_asmob101 (void);
SCM scm_make_asmob110 (void);
SCM scm_make_asmob111 (void);
SCM scm_make_asmob120 (void);
SCM scm_make_asmob020 (void);
SCM scm_make_asmob021 (void);
SCM scm_make_asmob200 (void);
SCM scm_make_asmob201 (void);
SCM scm_make_asmob210 (void);
SCM scm_make_asmob030 (void);
SCM scm_make_asmob300 (void);

SCM_DEFINE (scm_make_asmob000, "make-asmob000", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob000, 0);
}

SCM_DEFINE (scm_make_asmob100, "make-asmob100", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob100, 0);
}

SCM_DEFINE (scm_make_asmob010, "make-asmob010", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob010, 0);
}

SCM_DEFINE (scm_make_asmob001, "make-asmob001", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob001, 0);
}

SCM_DEFINE (scm_make_asmob200, "make-asmob200", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob200, 0);
}

SCM_DEFINE (scm_make_asmob110, "make-asmob110", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob110, 0);
}

SCM_DEFINE (scm_make_asmob020, "make-asmob020", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob020, 0);
}

SCM_DEFINE (scm_make_asmob101, "make-asmob101", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob101, 0);
}

SCM_DEFINE (scm_make_asmob011, "make-asmob011", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob011, 0);
}

SCM_DEFINE (scm_make_asmob300, "make-asmob300", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob300, 0);
}

SCM_DEFINE (scm_make_asmob210, "make-asmob210", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob210, 0);
}

SCM_DEFINE (scm_make_asmob120, "make-asmob120", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob120, 0);
}

SCM_DEFINE (scm_make_asmob030, "make-asmob030", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob030, 0);
}

SCM_DEFINE (scm_make_asmob201, "make-asmob201", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob201, 0);
}

SCM_DEFINE (scm_make_asmob021, "make-asmob021", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob021, 0);
}

SCM_DEFINE (scm_make_asmob111, "make-asmob111", 0, 0, 0, (), "")
{
  SCM_RETURN_NEWSMOB (asmob111, 0);
}

static SCM
apply0 (SCM smob)
{
  return SCM_EOL;
}

static SCM
apply1 (SCM smob, SCM a1)
{
  if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
  return scm_list_1 (a1);
}

static SCM
apply2 (SCM smob, SCM a1, SCM a2)
{
  if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
  if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F;
  return scm_list_2 (a1, a2);
}

static SCM
apply3 (SCM smob, SCM a1, SCM a2, SCM rest)
{
  if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
  if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F;
  if (SCM_UNBNDP (rest)) rest = SCM_BOOL_F;
  return scm_list_3 (a1, a2, rest);
}

void libtest_asmobs_init (void);

void
libtest_asmobs_init ()
{
  asmob000 = scm_make_smob_type ("asmob000", 0);
  scm_set_smob_apply (asmob000, apply0, 0, 0, 0);
  asmob100 = scm_make_smob_type ("asmob100", 0);
  scm_set_smob_apply (asmob100, apply1, 1, 0, 0);
  asmob010 = scm_make_smob_type ("asmob010", 0);
  scm_set_smob_apply (asmob010, apply1, 0, 1, 0);
  asmob001 = scm_make_smob_type ("asmob001", 0);
  scm_set_smob_apply (asmob001, apply1, 0, 0, 1);
  asmob200 = scm_make_smob_type ("asmob200", 0);
  scm_set_smob_apply (asmob200, apply2, 2, 0, 0);
  asmob110 = scm_make_smob_type ("asmob110", 0);
  scm_set_smob_apply (asmob110, apply2, 1, 1, 0);
  asmob020 = scm_make_smob_type ("asmob020", 0);
  scm_set_smob_apply (asmob020, apply2, 0, 2, 0);
  asmob101 = scm_make_smob_type ("asmob101", 0);
  scm_set_smob_apply (asmob101, apply2, 1, 0, 1);
  asmob011 = scm_make_smob_type ("asmob011", 0);
  scm_set_smob_apply (asmob011, apply2, 0, 1, 1);
  asmob300 = scm_make_smob_type ("asmob300", 0);
  scm_set_smob_apply (asmob300, apply3, 3, 0, 0);
  asmob210 = scm_make_smob_type ("asmob210", 0);
  scm_set_smob_apply (asmob210, apply3, 2, 1, 0);
  asmob120 = scm_make_smob_type ("asmob120", 0);
  scm_set_smob_apply (asmob120, apply3, 1, 2, 0);
  asmob030 = scm_make_smob_type ("asmob030", 0);
  scm_set_smob_apply (asmob030, apply3, 0, 3, 0);
  asmob201 = scm_make_smob_type ("asmob201", 0);
  scm_set_smob_apply (asmob201, apply3, 2, 0, 1);
  asmob021 = scm_make_smob_type ("asmob021", 0);
  scm_set_smob_apply (asmob021, apply3, 0, 2, 1);
  asmob111 = scm_make_smob_type ("asmob111", 0);
  scm_set_smob_apply (asmob111, apply3, 1, 1, 1);
# include "test-asmobs-lib.x"
}


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

;; The use of certain identifiers as variable or parameter names has
;; been found to cause build problems on particular platforms.  The
;; aim of this test is to cause "make check" to fail (on GNU/Linux,
;; which most Guile developers use) if we accidentally add new code
;; that uses those identifiers.

(define bad-identifiers
  '(
    ;; On AIX 5.2 and 5.3, /usr/include/sys/timer.h includes:
    ;;	 #ifndef  _LINUX_SOURCE_COMPAT
    ;;	 #define func_data       t_union.data
    ;;	 #endif
    ;; So we want to avoid using func_data in Guile source code.
    "func_data"

    ;; More troublesome identifiers can be added into the list here.
    ))

(use-modules (ice-9 regex) (ice-9 rdelim))

(define bad-id-regexp
  (make-regexp (string-append "\\<("
			      (string-join (map regexp-quote bad-identifiers) "|")
			      ")\\>")))

(define exit-status 0)

;; Non-exported code from (ice-9 ftw).
(define (directory-files dir)
  (let ((dir-stream (opendir dir)))
    (let loop ((new (readdir dir-stream))
               (acc '()))
      (if (eof-object? new)
	  (begin
	    (closedir dir-stream)
	    acc)
          (loop (readdir dir-stream)
                (if (or (string=? "."  new)             ;;; ignore
                        (string=? ".." new))            ;;; ignore
                    acc
                    (cons (in-vicinity dir new) acc)))))))

(define (directory-files-matching dir pattern)
  (let ((file-name-regexp (make-regexp pattern)))
    (filter (lambda (fn)
	      (regexp-exec file-name-regexp fn))
	    (directory-files dir))))

(let loop ((file-names (directory-files-matching "../../libguile"
						 "\\.[ch]$")))
  (or (null? file-names)
      (begin
	(with-input-from-file (car file-names)
	  (lambda ()
	    (let loop ((linenum 1) (line (read-line)))
	      (or (eof-object? line)
		  (begin
		    (if (regexp-exec bad-id-regexp line)
			(begin
			  (set! exit-status 1)
			  (format (current-error-port)
				  "~a:~a: ~a\n"
				  (car file-names)
				  linenum
				  line)))
		    (loop (+ linenum 1) (read-line)))))))
	(loop (cdr file-names)))))

(exit exit-status)

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


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

#if HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

#include <stdio.h>
#include <assert.h>
#include <string.h>

#ifdef HAVE_INTTYPES_H
# include <inttypes.h>
#endif

#ifndef PRIiMAX
# if (defined SIZEOF_LONG_LONG) && (SIZEOF_LONG_LONG >= 8)
#  define PRIiMAX "lli"
#  define PRIuMAX "llu"
# else
#  define PRIiMAX "li"
#  define PRIuMAX "lu"
# endif
#endif

static void
test_1 (const char *str, scm_t_intmax min, scm_t_intmax max,
	int result)
{
  int r = scm_is_signed_integer (scm_c_eval_string (str), min, max);
  if (r != result)
    {
      fprintf (stderr, "fail: scm_is_signed_integer (%s, "
	       "%" PRIiMAX ", %" PRIiMAX ") == %d\n",
	       str, min, max, result);
      exit (1);
    }
}

static void
test_is_signed_integer ()
{
  test_1 ("'foo",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0);
  test_1 ("3.0",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0);
  test_1 ("(inexact->exact 3.0)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("3.5",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0);
  test_1 ("most-positive-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("(+ most-positive-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("most-negative-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("(- most-negative-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_1 ("(- (expt 2 63) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(expt 2 63)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
      test_1 ("(- (expt 2 63))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(- (- (expt 2 63)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_1 ("(- (expt 2 31) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(expt 2 31)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
      test_1 ("(- (expt 2 31))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(- (- (expt 2 31)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");

  /* bignum with range that fits into fixnum. */
  test_1 ("(+ most-positive-fixnum 1)",
	  -32768, 32767,
	  0);

  /* bignum with range that doesn't fit into fixnum, but probably
     fits into long. */
  test_1 ("(+ most-positive-fixnum 1)",
	  SCM_MOST_NEGATIVE_FIXNUM-1, SCM_MOST_POSITIVE_FIXNUM+1,
	  1);
}

static void
test_2 (const char *str, scm_t_uintmax min, scm_t_uintmax max,
	int result)
{
  int r = scm_is_unsigned_integer (scm_c_eval_string (str), min, max);
  if (r != result)
    {
      fprintf (stderr, "fail: scm_is_unsigned_integer (%s, "
	       "%" PRIuMAX ", %" PRIuMAX ") == %d\n",
	       str, min, max, result);
      exit (1);
    }
}

static void
test_is_unsigned_integer ()
{
  test_2 ("'foo",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("3.0",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("(inexact->exact 3.0)",
	  0, SCM_T_UINTMAX_MAX,
	  1);
  test_2 ("3.5",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("most-positive-fixnum",
	  0, SCM_T_UINTMAX_MAX,
	  1);
  test_2 ("(+ most-positive-fixnum 1)",
	  0, SCM_T_UINTMAX_MAX,
	  1);
  test_2 ("most-negative-fixnum",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("(- most-negative-fixnum 1)",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_2 ("(- (expt 2 64) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      1);
      test_2 ("(expt 2 64)",
	      0, SCM_T_UINTMAX_MAX,
	      0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_2 ("(- (expt 2 32) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      1);
      test_2 ("(expt 2 32)",
	      0, SCM_T_UINTMAX_MAX,
	      0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");

  /* bignum with range that fits into fixnum. */
  test_2 ("(+ most-positive-fixnum 1)",
	  0, 32767,
	  0);

  /* bignum with range that doesn't fit into fixnum, but probably
     fits into long. */
  test_2 ("(+ most-positive-fixnum 1)",
	  0, SCM_MOST_POSITIVE_FIXNUM+1,
	  1);
}

typedef struct {
  SCM val;
  scm_t_intmax min, max;
  scm_t_intmax result;
} to_signed_data;

static SCM
out_of_range_handler (void *data, SCM key, SCM args)
{
  return scm_equal_p (key, scm_from_locale_symbol ("out-of-range"));
}

static SCM
wrong_type_handler (void *data, SCM key, SCM args)
{
  return scm_equal_p (key, scm_from_locale_symbol ("wrong-type-arg"));
}

static SCM
misc_error_handler (void *data, SCM key, SCM args)
{
  return scm_equal_p (key, scm_from_locale_symbol ("misc-error"));
}

static SCM
any_handler (void *data, SCM key, SCM args)
{
  return SCM_BOOL_T;
}

static SCM
to_signed_integer_body (void *data)
{
  to_signed_data *d = (to_signed_data *)data;
  d->result = scm_to_signed_integer (d->val, d->min, d->max);
  return SCM_BOOL_F;
}

static void
test_3 (const char *str, scm_t_intmax min, scm_t_intmax max,
	scm_t_intmax result, int range_error, int type_error)
{
  to_signed_data data;
  data.val = scm_c_eval_string (str);
  data.min = min;
  data.max = max;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_integer_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_signed_int (%s, "
		   "%" PRIiMAX ", %" PRIiMAX ") -> out of range\n",
		   str, min, max);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_integer_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_signed_int (%s, "
		   "%" PRIiMAX", %" PRIiMAX ") -> wrong type\n",
		   str, min, max);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_signed_integer_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: scm_to_signed_int (%s, "
		   "%" PRIiMAX ", %" PRIiMAX ") = %" PRIiMAX "\n",
		   str, min, max, result);
	  exit (1);
	}
    }
}

static void
test_to_signed_integer ()
{
  test_3 ("'foo",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0, 0, 1);
  test_3 ("3.5",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0, 0, 1);
  test_3 ("12",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  12, 0, 0);
  test_3 ("1000",
	  -999, 999,
	  0, 1, 0);
  test_3 ("-1000",
	  -999, 999,
	  0, 1, 0);
  test_3 ("most-positive-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM, 0, 0);
  test_3 ("most-negative-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_NEGATIVE_FIXNUM, 0, 0);
  test_3 ("(+ most-positive-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM+1, 0, 0);
  test_3 ("(- most-negative-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_NEGATIVE_FIXNUM-1, 0, 0);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_3 ("(- (expt 2 63) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MAX, 0, 0);
      test_3 ("(+ (- (expt 2 63)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN+1, 0, 0);
      test_3 ("(- (expt 2 63))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN, 0, 0);
      test_3 ("(expt 2 63)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
      test_3 ("(- (- (expt 2 63)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_3 ("(- (expt 2 31) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MAX, 0, 0);
      test_3 ("(+ (- (expt 2 31)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN+1, 0, 0);
      test_3 ("(- (expt 2 31))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN, 0, 0);
      test_3 ("(expt 2 31)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
      test_3 ("(- (- (expt 2 31)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");
}

typedef struct {
  SCM val;
  scm_t_uintmax min, max;
  scm_t_uintmax result;
} to_unsigned_data;

static SCM
to_unsigned_integer_body (void *data)
{
  to_unsigned_data *d = (to_unsigned_data *)data;
  d->result = scm_to_unsigned_integer (d->val, d->min, d->max);
  return SCM_BOOL_F;
}

static void
test_4 (const char *str, scm_t_uintmax min, scm_t_uintmax max,
	scm_t_uintmax result, int range_error, int type_error)
{
  to_unsigned_data data;
  data.val = scm_c_eval_string (str);
  data.min = min;
  data.max = max;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_integer_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_unsigned_int (%s, "
		   "%" PRIuMAX ", %" PRIuMAX ") -> out of range\n",
		   str, min, max);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_integer_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_unsigned_int (%s, "
		   "%" PRIuMAX ", %" PRIuMAX ") -> wrong type\n",
		   str, min, max);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_unsigned_integer_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: scm_to_unsigned_int (%s, "
		   "%" PRIuMAX ", %" PRIuMAX ") == %" PRIuMAX "\n",
		   str, min, max, result);
	  exit (1);
	}
    }
}

static void
test_to_unsigned_integer ()
{
  test_4 ("'foo",
	  0, SCM_T_UINTMAX_MAX,
	  0, 0, 1);
  test_4 ("3.5",
	  0, SCM_T_UINTMAX_MAX,
	  0, 0, 1);
  test_4 ("12",
	  0, SCM_T_UINTMAX_MAX,
	  12, 0, 0);
  test_4 ("1000",
	  0, 999,
	  0, 1, 0);
  test_4 ("most-positive-fixnum",
	  0, SCM_T_UINTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM, 0, 0);
  test_4 ("(+ most-positive-fixnum 1)",
	  0, SCM_T_UINTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM+1, 0, 0);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_4 ("(- (expt 2 64) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      SCM_T_UINTMAX_MAX, 0, 0);
      test_4 ("(expt 2 64)",
	      0, SCM_T_UINTMAX_MAX,
	      0, 1, 0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_4 ("(- (expt 2 32) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      SCM_T_UINTMAX_MAX, 0, 0);
      test_4 ("(expt 2 32)",
	      0, SCM_T_UINTMAX_MAX,
	      0, 1, 0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");
}

static void
test_5 (scm_t_intmax val, const char *result)
{
  SCM res = scm_c_eval_string (result);
  if (scm_is_false (scm_equal_p (scm_from_signed_integer (val), res)))
    {
      fprintf (stderr, "fail: scm_from_signed_integer (%" PRIiMAX ") == %s\n",
	       val, result);
      exit (1);
    }
}

static void
test_from_signed_integer ()
{
  test_5 (12, "12");
  if (sizeof (scm_t_intmax) == 8)
    {
      test_5 (SCM_T_INTMAX_MAX, "(- (expt 2 63) 1)");
      test_5 (SCM_T_INTMAX_MIN, "(- (expt 2 63))");
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_5 (SCM_T_INTMAX_MAX, "(- (expt 2 31) 1)");
      test_5 (SCM_T_INTMAX_MIN, "(- (expt 2 31))");
    }
  test_5 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum");
  test_5 (SCM_MOST_NEGATIVE_FIXNUM, "most-negative-fixnum");
  test_5 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)");
  test_5 (SCM_MOST_NEGATIVE_FIXNUM-1, "(- most-negative-fixnum 1)");
}

static void
test_6 (scm_t_uintmax val, const char *result)
{
  SCM res = scm_c_eval_string (result);
  if (scm_is_false (scm_equal_p (scm_from_unsigned_integer (val), res)))
    {
      fprintf (stderr, "fail: scm_from_unsigned_integer (%"
	       PRIuMAX ") == %s\n",
	       val, result);
      exit (1);
    }
}

static void
test_from_unsigned_integer ()
{
  test_6 (12, "12");
  if (sizeof (scm_t_intmax) == 8)
    {
      test_6 (SCM_T_UINTMAX_MAX, "(- (expt 2 64) 1)");
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_6 (SCM_T_UINTMAX_MAX, "(- (expt 2 32) 1)");
    }
  test_6 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum");
  test_6 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)");
}

static void
test_7s (SCM n, scm_t_intmax c_n, const char *result, const char *func)
{
  SCM r = scm_c_eval_string (result);

  if (scm_is_false (scm_equal_p (n, r)))
    {
      fprintf (stderr, "fail: %s (%" PRIiMAX ") == %s\n", func, c_n, result);
      exit (1);
    }
}

#define TEST_7S(func,arg,res) test_7s (func(arg), arg, res, #func)

static void
test_7u (SCM n, scm_t_uintmax c_n, const char *result, const char *func)
{
  SCM r = scm_c_eval_string (result);

  if (scm_is_false (scm_equal_p (n, r)))
    {
      fprintf (stderr, "fail: %s (%" PRIuMAX ") == %s\n", func, c_n, result);
      exit (1);
    }
}

#define TEST_7U(func,arg,res) test_7u (func(arg), arg, res, #func)

typedef struct {
  SCM val;
  scm_t_intmax (*func) (SCM);
  scm_t_intmax result;
} to_signed_func_data;

static SCM
to_signed_func_body (void *data)
{
  to_signed_func_data *d = (to_signed_func_data *)data;
  d->result = d->func (d->val);
  return SCM_BOOL_F;
}

static void
test_8s (const char *str, scm_t_intmax (*func) (SCM), const char *func_name,
	 scm_t_intmax result, int range_error, int type_error)
{
  to_signed_func_data data;
  data.val = scm_c_eval_string (str);
  data.func = func;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_func_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> out of range\n", func_name, str);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_func_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> wrong type\n", func_name, str);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_signed_func_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
	  exit (1);
	}
    }
}

typedef struct {
  SCM val;
  scm_t_uintmax (*func) (SCM);
  scm_t_uintmax result;
} to_unsigned_func_data;

static SCM
to_unsigned_func_body (void *data)
{
  to_unsigned_func_data *d = (to_unsigned_func_data *)data;
  d->result = d->func (d->val);
  return SCM_BOOL_F;
}

static void
test_8u (const char *str, scm_t_uintmax (*func) (SCM), const char *func_name,
	 scm_t_uintmax result, int range_error, int type_error)
{
  to_unsigned_func_data data;
  data.val = scm_c_eval_string (str);
  data.func = func;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_func_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> out of range\n", func_name, str);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_func_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> wrong type\n", func_name, str);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_unsigned_func_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
	  exit (1);
	}
    }
}

/* We can't rely on the scm_to functions being proper functions but we
   want to pass them to test_8s and test_8u, so we wrap'em.  Also, we
   need to give them a common return type.
*/

#define DEFSTST(f) static scm_t_intmax  tst_##f (SCM x) { return f(x); }
#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); }

DEFSTST (scm_to_schar)
DEFUTST (scm_to_uchar)
DEFSTST (scm_to_char)
DEFSTST (scm_to_short)
DEFUTST (scm_to_ushort)
DEFSTST (scm_to_int)
DEFUTST (scm_to_uint)
DEFSTST (scm_to_long)
DEFUTST (scm_to_ulong)
#if SCM_SIZEOF_LONG_LONG != 0
DEFSTST (scm_to_long_long)
DEFUTST (scm_to_ulong_long)
#endif
DEFSTST (scm_to_ssize_t)
DEFUTST (scm_to_size_t)

DEFSTST (scm_to_int8)
DEFUTST (scm_to_uint8)
DEFSTST (scm_to_int16)
DEFUTST (scm_to_uint16)
DEFSTST (scm_to_int32)
DEFUTST (scm_to_uint32)
DEFSTST (scm_to_int64)
DEFUTST (scm_to_uint64)

#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te)

static void
test_int_sizes ()
{
  TEST_7U (scm_from_uchar,  91, "91");
  TEST_7S (scm_from_schar,  91, "91");
  TEST_7S (scm_from_char,   91, "91");
  TEST_7S (scm_from_short, -911, "-911");
  TEST_7U (scm_from_ushort, 911, "911");
  TEST_7S (scm_from_int,    911, "911");
  TEST_7U (scm_from_uint,   911, "911");
  TEST_7S (scm_from_long,   911, "911");
  TEST_7U (scm_from_ulong,  911, "911");
#if SCM_SIZEOF_LONG_LONG != 0
  TEST_7S (scm_from_long_long,   911, "911");
  TEST_7U (scm_from_ulong_long,  911, "911");
#endif
  TEST_7U (scm_from_size_t,  911, "911");
  TEST_7S (scm_from_ssize_t, 911, "911");

  TEST_7S (scm_from_int8, -128, "-128");
  TEST_7S (scm_from_int8,  127,  "127");
  TEST_7S (scm_from_int8,  128, "-128");
  TEST_7U (scm_from_uint8, 255,  "255");

  TEST_7S (scm_from_int16, -32768, "-32768");
  TEST_7S (scm_from_int16,  32767,  "32767");
  TEST_7S (scm_from_int16,  32768, "-32768");
  TEST_7U (scm_from_uint16, 65535,  "65535");

  TEST_7S (scm_from_int32,  SCM_T_INT32_MIN,     "-2147483648");
  TEST_7S (scm_from_int32,  SCM_T_INT32_MAX,      "2147483647");
  TEST_7S (scm_from_int32,  SCM_T_INT32_MAX+1LL, "-2147483648");
  TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX,     "4294967295");

  TEST_7S (scm_from_int64,  SCM_T_INT64_MIN,  "-9223372036854775808");
  TEST_7S (scm_from_int64,  SCM_T_INT64_MAX,   "9223372036854775807");
  TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615");

  TEST_8S ("91",   scm_to_schar,   91, 0, 0);
  TEST_8U ("91",   scm_to_uchar,   91, 0, 0);
  TEST_8S ("91",   scm_to_char,    91, 0, 0);
  TEST_8S ("-911", scm_to_short, -911, 0, 0);
  TEST_8U ("911",  scm_to_ushort, 911, 0, 0);
  TEST_8S ("-911", scm_to_int,   -911, 0, 0);
  TEST_8U ("911",  scm_to_uint,   911, 0, 0);
  TEST_8S ("-911", scm_to_long,  -911, 0, 0);
  TEST_8U ("911",  scm_to_ulong,  911, 0, 0);
#if SCM_SIZEOF_LONG_LONG != 0
  TEST_8S ("-911", scm_to_long_long, -911, 0, 0);
  TEST_8U ("911",  scm_to_ulong_long, 911, 0, 0);
#endif
  TEST_8U ("911",  scm_to_size_t,   911, 0, 0);
  TEST_8S ("911",  scm_to_ssize_t,  911, 0, 0);

  TEST_8S ("-128", scm_to_int8,   SCM_T_INT8_MIN, 0, 0);
  TEST_8S ("127",  scm_to_int8,   SCM_T_INT8_MAX, 0, 0);
  TEST_8S ("128",  scm_to_int8,                0, 1, 0);
  TEST_8S ("#f",   scm_to_int8,                0, 0, 1);
  TEST_8U ("255",  scm_to_uint8, SCM_T_UINT8_MAX, 0, 0);
  TEST_8U ("256",  scm_to_uint8,               0, 1, 0);
  TEST_8U ("-1",   scm_to_uint8,               0, 1, 0);
  TEST_8U ("#f",   scm_to_uint8,               0, 0, 1);

  TEST_8S ("-32768", scm_to_int16,   SCM_T_INT16_MIN, 0, 0);
  TEST_8S ("32767",  scm_to_int16,   SCM_T_INT16_MAX, 0, 0);
  TEST_8S ("32768",  scm_to_int16,                 0, 1, 0);
  TEST_8S ("#f",     scm_to_int16,                 0, 0, 1);
  TEST_8U ("65535",  scm_to_uint16, SCM_T_UINT16_MAX, 0, 0);
  TEST_8U ("65536",  scm_to_uint16,                0, 1, 0);
  TEST_8U ("-1",     scm_to_uint16,                0, 1, 0);
  TEST_8U ("#f",     scm_to_uint16,                0, 0, 1);

  TEST_8S ("-2147483648", scm_to_int32,   SCM_T_INT32_MIN, 0, 0);
  TEST_8S ("2147483647",  scm_to_int32,   SCM_T_INT32_MAX, 0, 0);
  TEST_8S ("2147483648",  scm_to_int32,                 0, 1, 0);
  TEST_8S ("#f",          scm_to_int32,                 0, 0, 1);
  TEST_8U ("4294967295",  scm_to_uint32, SCM_T_UINT32_MAX, 0, 0);
  TEST_8U ("4294967296",  scm_to_uint32,                0, 1, 0);
  TEST_8U ("-1",          scm_to_uint32,                0, 1, 0);
  TEST_8U ("#f",          scm_to_uint32,                0, 0, 1);

  TEST_8S ("-9223372036854775808", scm_to_int64,   SCM_T_INT64_MIN, 0, 0);
  TEST_8S ("9223372036854775807",  scm_to_int64,   SCM_T_INT64_MAX, 0, 0);
  TEST_8S ("9223372036854775808",  scm_to_int64,                 0, 1, 0);
  TEST_8S ("#f",                   scm_to_int64,                 0, 0, 1);
  TEST_8U ("18446744073709551615", scm_to_uint64, SCM_T_UINT64_MAX, 0, 0);
  TEST_8U ("18446744073709551616", scm_to_uint64,                0, 1, 0);
  TEST_8U ("-1",                   scm_to_uint64,                0, 1, 0);
  TEST_8U ("#f",                   scm_to_uint64,                0, 0, 1);

}

static void
test_9 (double val, const char *result)
{
  SCM res = scm_c_eval_string (result);
  if (scm_is_false (scm_eqv_p (res, scm_from_double (val))))
    {
      fprintf (stderr, "fail: scm_from_double (%g) == %s\n", val, result);
      exit (1);
    }
}

/* The `infinity' and `not-a-number' values.  */
static double guile_Inf, guile_NaN;

/* Initialize GUILE_INF and GUILE_NAN.  Taken from `guile_ieee_init ()' in
   `libguile/numbers.c'.  */
static void
ieee_init (void)
{
#ifdef INFINITY
  /* C99 INFINITY, when available.
     FIXME: The standard allows for INFINITY to be something that overflows
     at compile time.  We ought to have a configure test to check for that
     before trying to use it.  (But in practice we believe this is not a
     problem on any system guile is likely to target.)  */
  guile_Inf = INFINITY;
#elif HAVE_DINFINITY
  /* OSF */
  extern unsigned int DINFINITY[2];
  guile_Inf = (*((double *) (DINFINITY)));
#else
  double tmp = 1e+10;
  guile_Inf = tmp;
  for (;;)
    {
      guile_Inf *= 1e+10;
      if (guile_Inf == tmp)
	break;
      tmp = guile_Inf;
    }
#endif

#ifdef NAN
  /* C99 NAN, when available */
  guile_NaN = NAN;
#elif HAVE_DQNAN
  {
    /* OSF */
    extern unsigned int DQNAN[2];
    guile_NaN = (*((double *)(DQNAN)));
  }
#else
  guile_NaN = guile_Inf / guile_Inf;
#endif
}

static void
test_from_double ()
{
  test_9 (12, "12.0");
  test_9 (0.25, "0.25");
  test_9 (0.1, "0.1");
  test_9 (guile_Inf, "+inf.0");
  test_9 (-guile_Inf, "-inf.0");
  test_9 (guile_NaN, "+nan.0");
}

typedef struct {
  SCM val;
  double result;
} to_double_data;

static SCM
to_double_body (void *data)
{
  to_double_data *d = (to_double_data *)data;
  d->result = scm_to_double (d->val);
  return SCM_BOOL_F;
}

static void
test_10 (const char *val, double result, int type_error)
{
  to_double_data data;
  data.val = scm_c_eval_string (val);

  if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_double_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_double (%s) -> wrong type\n", val);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_double_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: scm_to_double (%s) = %g\n", val, result);
	  exit (1);
	}
    }
}

static void
test_to_double ()
{
  test_10 ("#f",          0.0,  1);
  test_10 ("12",         12.0,  0);
  test_10 ("0.25",       0.25,  0);
  test_10 ("1/4",        0.25,  0);
  test_10 ("+inf.0", guile_Inf, 0);
  test_10 ("-inf.0",-guile_Inf, 0);
  test_10 ("+1i",         0.0,  1);
}

typedef struct {
  SCM val;
  char *result;
} to_locale_string_data;

static SCM
to_locale_string_body (void *data)
{
  to_locale_string_data *d = (to_locale_string_data *)data;
  d->result = scm_to_locale_string (d->val);
  return SCM_BOOL_F;
}

static void
test_11 (const char *str, const char *result, int misc_error, int type_error)
{
  to_locale_string_data data;
  data.val = scm_c_eval_string (str);
  data.result = NULL;

  if (misc_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_locale_string_body, &data,
					    misc_error_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_locale_string (%s) -> misc error\n", str);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_locale_string_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_locale_string (%s) -> wrong type\n", str);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_locale_string_body, &data,
					   any_handler, NULL))
	  || data.result == NULL || strcmp (data.result, result))
	{
	  fprintf (stderr,
		   "fail: scm_to_locale_string (%s) = %s\n", str, result);
	  exit (1);
	}
    }

  free (data.result);
}

static void
test_locale_strings ()
{
  const char *lstr = "This is not a string.";
  char *lstr2;
  SCM str, str2;
  char buf[20];
  size_t len;

  if (!scm_is_string (scm_c_eval_string ("\"foo\"")))
    {
      fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n");
      exit (1);
    }

  str = scm_from_locale_string (lstr);

  if (!scm_is_string (str))
    {
      fprintf (stderr, "fail: scm_is_string (str) = true\n");
      exit (1);
    }

  lstr2 = scm_to_locale_string (str);
  if (strcmp (lstr, lstr2))
    {
      fprintf (stderr, "fail: lstr = lstr2\n");
      exit (1);
    }
  free (lstr2);

  buf[15] = 'x';
  len = scm_to_locale_stringbuf (str, buf, 15);
  if (len != strlen (lstr))
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n");
      exit (1);
    }
  if (buf[15] != 'x')
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
      exit (1);
    }
  if (strncmp (lstr, buf, 15))
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
      exit (1);
    }

  str2 = scm_from_locale_stringn (lstr, 10);

  if (!scm_is_string (str2))
    {
      fprintf (stderr, "fail: scm_is_string (str2) = true\n");
      exit (1);
    }

  lstr2 = scm_to_locale_string (str2);
  if (strncmp (lstr, lstr2, 10))
    {
      fprintf (stderr, "fail: lstr = lstr2\n");
      exit (1);
    }
  free (lstr2);

  buf[10] = 'x';
  len = scm_to_locale_stringbuf (str2, buf, 20);
  if (len != 10)
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n");
      exit (1);
    }
  if (buf[10] != 'x')
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
      exit (1);
    }
  if (strncmp (lstr, buf, 10))
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
      exit (1);
    }

  lstr2 = scm_to_locale_stringn (str2, &len);
  if (len != 10)
    {
      fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n");
      exit (1);
    }

  test_11 ("#f", NULL, 0, 1);
  test_11 ("\"foo\"", "foo", 0, 0);
  test_11 ("(string #\\f #\\nul)", NULL, 1, 0);
}

static void
tests (void *data, int argc, char **argv)
{
  test_is_signed_integer ();
  test_is_unsigned_integer ();
  test_to_signed_integer ();
  test_to_unsigned_integer ();
  test_from_signed_integer ();
  test_from_unsigned_integer ();
  test_int_sizes ();
  test_from_double ();
  test_to_double ();
  test_locale_strings ();
}

int
main (int argc, char *argv[])
{
  ieee_init ();
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
#!/bin/sh

# Copyright (C) 2006 Free Software Foundation, Inc.
#
# This library is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 of the License, or (at
# your option) any later version.
#
# This library is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
# License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with this library; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

# Test for %fast-slot-ref, which was previously implemented such that
# an out-of-range slot index could escape being properly detected, and
# could then cause a segmentation fault.
#
# Prior to the change in this commit to goops.c, the following
# sequence reliably causes a segmentation fault on my GNU/Linux when
# executing the (%fast-slot-ref i 3) line.  For reasons as yet
# unknown, it does not cause a segmentation fault if the same code is
# loaded as a script; that is why we run it here using "guile -q <<EOF".
exec guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm >/dev/null 2>&1 <<EOF
(use-modules (oop goops))
(define-module (oop goops))
(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3))
(define i (make <c>))
(%fast-slot-ref i 1)
(%fast-slot-ref i 0)
(%fast-slot-ref i 3)
(%fast-slot-ref i -1)
(%fast-slot-ref i 2)
(exit 0)
EOF


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

/* some bits originally by Jim Blandy <jimb@red-bean.com> */

#ifndef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>
#include <libguile/gh.h>

#include <assert.h>
#include <string.h>

#if SCM_ENABLE_DEPRECATED

static int
string_equal (SCM str, char *lit)
{
  int len = strlen (lit);
  int result;

  result = ((scm_i_string_length (str) == len)
            && (!memcmp (scm_i_string_chars (str), lit, len)));
  scm_remember_upto_here_1 (str);
  return result;
}

static void
test_gh_set_substr ()
{
  SCM string;

  string = gh_str02scm ("Free, darnit!");
  assert (gh_string_p (string));

  gh_set_substr ("dammit", string, 6, 6);
  assert (string_equal (string, "Free, dammit!"));

  /* Make sure that we can use the string itself as a source.

     I guess this behavior isn't really visible, since the GH API
     doesn't provide any direct access to the string contents.  But I
     think it should, eventually.  You can't write efficient string
     code if you have to copy the string just to look at it.  */

  /* Copy a substring to an overlapping region to its right.  */
  gh_set_substr (scm_i_string_chars (string), string, 4, 6);
  assert (string_equal (string, "FreeFree, it!"));

  string = gh_str02scm ("Free, darnit!");
  assert (gh_string_p (string));

  /* Copy a substring to an overlapping region to its left.  */
  gh_set_substr (scm_i_string_chars (string) + 6, string, 2, 6);
  assert (string_equal (string, "Frdarnitrnit!"));
}

static void
tests (void *data, int argc, char **argv)
{
  test_gh_set_substr ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}

#else

int
main (int argc, char *argv[])
{
  return 0;
}

#endif /* !SCM_ENABLE_DEPRECATED */


code:
/* test-list.c - exercise libguile/list.c functions */

/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#ifndef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

#include <stdio.h>
#include <assert.h>
#include <string.h>

/* pretty trivial, but ensure this entrypoint exists, since it was
   documented in Guile 1.6 and earlier */
static void
test_scm_list (void)
{
  {
    if (! scm_is_eq (SCM_EOL, scm_list (SCM_EOL)))
      {
        fprintf (stderr, "fail: scm_list SCM_EOL\n");
        exit (1);
      }
  }

  {
    SCM lst = scm_list_2 (scm_from_int (1), scm_from_int (2));
    if (! scm_is_true (scm_equal_p (lst, scm_list (lst))))
      {
        fprintf (stderr, "fail: scm_list '(1 2)\n");
        exit (1);
      }
  }
}

static void
tests (void *data, int argc, char **argv)
{
  test_scm_list ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


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

#ifndef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

#include <stdio.h>
#include <assert.h>

#if SCM_ENABLE_DISCOURAGED == 1

SCM out_of_range_handler (void *data, SCM key, SCM args);
SCM call_num2long_long_body (void *data);
SCM call_num2ulong_long_body (void *data);

/* expect to catch an `out-of-range' exception */
SCM
out_of_range_handler (void *data, SCM key, SCM args)
{
  assert (scm_equal_p (key, scm_str2symbol ("out-of-range")));
  return SCM_BOOL_T;
}

SCM
call_num2long_long_body (void *data)
{
  scm_num2long_long (* (SCM *) data, SCM_ARG1, "call_num2long_long_body");
  return SCM_BOOL_F;
}

SCM
call_num2ulong_long_body (void *data)
{
  scm_num2ulong_long (* (SCM *) data, SCM_ARG1, "call_num2ulong_long_body");
  return SCM_BOOL_F;
}

static void
test_long_long ()
{
#if SCM_SIZEOF_LONG_LONG != 0
  {
    SCM n = scm_long_long2num (SCM_I_LLONG_MIN);
    long long result = scm_num2long_long(n, 0, "main");
    assert (result == SCM_I_LLONG_MIN);
  }

  /* LLONG_MIN - 1 */
  {
    SCM n = scm_difference (scm_long_long2num (SCM_I_LLONG_MIN), scm_from_int (1));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
  {
    SCM n = scm_sum (scm_long_long2num (SCM_I_LLONG_MIN),
                     scm_long_long2num (SCM_I_LLONG_MIN / 2));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* SCM_I_LLONG_MAX + 1 */
  {
    SCM n = scm_sum (scm_long_long2num (SCM_I_LLONG_MAX), scm_from_int (1));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* 2^1024 */
  {
    SCM n = scm_ash (scm_from_int (1), scm_from_int (1024));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* -2^1024 */
  {
    SCM n = scm_difference (scm_from_int (0),
                            scm_ash (scm_from_int (1), scm_from_int (1024)));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

#endif /* SCM_SIZEOF_LONG_LONG != 0 */
}

static void
test_ulong_long ()
{
#if SCM_SIZEOF_LONG_LONG != 0

  {
    SCM n = scm_ulong_long2num (SCM_I_ULLONG_MAX);
    unsigned long long result = scm_num2ulong_long(n, 0, "main");
    assert (result == SCM_I_ULLONG_MAX);
  }

  /* -1 */
  {
    SCM n = scm_from_int (-1);
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* SCM_I_ULLONG_MAX + 1 */
  {
    SCM n = scm_sum (scm_ulong_long2num (SCM_I_ULLONG_MAX), scm_from_int (1));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* 2^1024 */
  {
    SCM n = scm_ash (scm_from_int (1), scm_from_int (1024));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

#endif /* SCM_SIZEOF_LONG_LONG != 0 */
}

static void
tests (void *data, int argc, char **argv)
{
  test_long_long ();
  test_ulong_long ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}

#else  /* SCM_ENABLE_DISCOURAGED == 0 */

int
main (int argc, char *argv[])
{
  return 0;
}

#endif /* SCM_ENABLE_DISCOURAGED == 0 */


code:
#!/bin/sh

set -e

# expect these to throw errors, if they succeed it's wrong
#
# (Note the syntax "! guile -c ..." isn't used here, because that doesn't
# work on Solaris 10.)
#
guile -q -c '(require-extension 7)' 2>/dev/null            && exit 1
guile -q -c '(require-extension (blarg))' 2>/dev/null      && exit 1
guile -q -c '(require-extension (srfi "foo"))' 2>/dev/null && exit 1

# expect these to succeed
guile -q -c '(require-extension (srfi 1)) (exit (procedure? take-right))'
guile -q -c '(require-extension (srfi))'

exit 0


code:
/* Copyright (C) 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#if HAVE_CONFIG_H
# include <config.h>
#endif

#include <assert.h>
#include <math.h>
#include <stdio.h>

#if HAVE_FENV_H
#include <fenv.h>
#elif defined HAVE_MACHINE_FPU_H
/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>.
   On NetBSD, this header has to be included along with <sys/types.h>.  */
# ifdef HAVE_SYS_TYPES_H
#  include <sys/types.h>
# endif
# include <machine/fpu.h>
#endif

#include <libguile.h>

#define numberof(x)  (sizeof (x) / sizeof ((x)[0]))

static void
test_scm_c_round ()
{
  /* FE constants are defined only where supported, in particular for
     instance some ARM systems have been seen with only a couple of modes */
  static const int modes[] = {
    0,
#ifdef FE_TONEAREST
    FE_TONEAREST,
#endif
#ifdef FE_UPWARD
    FE_UPWARD,
#endif
#ifdef FE_DOWNWARD
    FE_DOWNWARD,
#endif
#ifdef FE_TOWARDZERO
    FE_TOWARDZERO,
#endif
  };

  double  x, want;
  int  i;

  for (i = 0; i < numberof (modes); i++)
    {
      /* First iteration is the default rounding mode, ie. no call to
         fesetround.  Subsequent iterations are the FE modes from the
         table.  */
      if (i != 0)
        {
#if HAVE_FESETROUND
          fesetround (modes[i]);
#endif
        }

      assert (scm_c_round (0.0) == 0.0);
      assert (scm_c_round (1.0) == 1.0);
      assert (scm_c_round (-1.0) == -1.0);

      assert (scm_c_round (0.5) == 0.0);
      assert (scm_c_round (1.5) == 2.0);
      assert (scm_c_round (-1.5) == -2.0);
      assert (scm_c_round (2.5) == 2.0);
      assert (scm_c_round (-2.5) == -2.0);
      assert (scm_c_round (3.5) == 4.0);
      assert (scm_c_round (-3.5) == -4.0);

      /* 2^(DBL_MANT_DIG-1)-1+0.5 */
      x = ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5;
      want = ldexp (1.0, DBL_MANT_DIG - 1);
      assert (scm_c_round (x) == want);

      /* -(2^(DBL_MANT_DIG-1)-1+0.5) */
      x = - (ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5);
      want = - ldexp (1.0, DBL_MANT_DIG - 1);
      assert (scm_c_round (x) == want);

      /* 2^DBL_MANT_DIG-1
         In the past scm_c_round had incorrectly incremented this value, due
         to the way that x+0.5 would round upwards (in the usual default
         nearest-even mode on most systems).  */
      x = ldexp (1.0, DBL_MANT_DIG) - 1.0;
      assert (x == floor (x));      /* should be an integer already */
      assert (scm_c_round (x) == x);  /* scm_c_round should return it unchanged */

      /* -(2^DBL_MANT_DIG-1) */
      x = - (ldexp (1.0, DBL_MANT_DIG) - 1.0);
      assert (x == floor (x));      /* should be an integer already */
      assert (scm_c_round (x) == x);  /* scm_c_round should return it unchanged */

      /* 2^64 */
      x = ldexp (1.0, 64);
      assert (scm_c_round (x) == x);

      /* -2^64
         In the past scm_c_round had incorrectely gone to the next highest
         representable value in FE_UPWARD, due to x+0.5 rounding.  */
      x = - ldexp (1.0, 64);
      assert (scm_c_round (x) == x);
    }
}

static void
tests (void *data, int argc, char **argv)
{
  test_scm_c_round ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
/* Copyright (C) 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Exercise `scm_c_read ()' and the port type API.  Verify assumptions that
   can be made by port type implementations.  */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>
#include <assert.h>

/* Size of our port's internal buffer.  */
#define PORT_BUFFER_SIZE 1024

/* Return a new port of type PORT_TYPE.  */
static inline SCM
make_port (scm_t_bits port_type)
{
  SCM port;
  char *c_buffer;
  scm_t_port *c_port;

  c_buffer = scm_gc_calloc (PORT_BUFFER_SIZE, "custom-port-buffer");

  port = scm_new_port_table_entry (port_type);

  /* Associate C_BUFFER with PORT, for test purposes.  */
  SCM_SETSTREAM (port, (scm_t_bits) c_buffer);

  /* Use C_BUFFER as PORT's internal buffer.  */
  c_port = SCM_PTAB_ENTRY (port);
  c_port->read_pos = c_port->read_buf = (unsigned char *) c_buffer;
  c_port->read_end = (unsigned char *) c_buffer + PORT_BUFFER_SIZE;
  c_port->read_buf_size = PORT_BUFFER_SIZE;

  /* Mark PORT as open and readable.  */
  SCM_SET_CELL_TYPE (port, port_type | SCM_OPN | SCM_RDNG);

  return port;
}

/* Read one byte from PORT.  */
static int
fill_input (SCM port)
{
  int result;
  scm_t_port *c_port = SCM_PTAB_ENTRY (port);

  /* Make sure that C_PORT's internal buffer wasn't changed behind our back.
     See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00042.html
     for an example where this assumption matters.  */
  assert (c_port->read_buf == (unsigned char *) SCM_STREAM (port));
  assert (c_port->read_buf_size == PORT_BUFFER_SIZE);

  if (c_port->read_pos >= c_port->read_end)
    result = EOF;
  else
    result = (int) *c_port->read_pos++;

  return result;
}

/* Return true (non-zero) if BUF contains only zeros.  */
static inline int
zeroed_buffer_p (const char *buf, size_t len)
{
  size_t i;

  for (i = 0; i < len; i++)
    if (buf[i] != 0)
      return 0;

  return 1;
}

/* Run the test.  */
static void *
do_start (void *arg)
{
  SCM port;
  scm_t_bits port_type;
  char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)];
  size_t read, last_read;

  port_type = scm_make_port_type ("custom-input-port", fill_input, NULL);
  port = make_port (port_type);

  read = 0;
  do
    {
      last_read = scm_c_read (port, &buffer[read], 123);
      assert (last_read <= 123);
      assert (zeroed_buffer_p (&buffer[read], last_read));

      read += last_read;
    }
  while (last_read > 0 && read < sizeof (buffer));

  /* We shouldn't be able to read more than what's in PORT's buffer.  */
  assert (read == PORT_BUFFER_SIZE);

  return NULL;
}

int
main (int argc, char *argv[])
{
  scm_with_guile (do_start, NULL);

  return 0;
}


code:
/* Copyright (C) 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Exercise `scm_take_locale_symbol ()', making sure it returns an interned
   symbol.  See https://savannah.gnu.org/bugs/index.php?25865 .  */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

#include <stdlib.h>
#include <string.h>

static void *
do_test (void *result)
{
  SCM taken_sym, sym;

  taken_sym = scm_take_locale_symbol (strdup ("some random symbol"));
  sym = scm_from_locale_symbol ("some random symbol");

  if (scm_is_true (scm_symbol_p (sym))
      && scm_is_true (scm_symbol_p (taken_sym))

      /* Relying solely on `scm_symbol_interned_p ()' is insufficient since
	 it doesn't reflect the actual state of the symbol hashtable, hence
	 the additional `scm_is_eq' test.  */
      && scm_is_true (scm_symbol_interned_p (sym))
      && scm_is_true (scm_symbol_interned_p (taken_sym))
      && scm_is_eq (taken_sym, sym))
    * (int *) result = EXIT_SUCCESS;
  else
    * (int *) result = EXIT_FAILURE;

  return NULL;
}

int
main (int argc, char *argv[])
{
  int result;

  scm_with_guile (do_test, &result);

  return result;
}


code:
/* Copyright (C) 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* Test whether `scm_with_guile ()' can be called several times from a given
   thread, but from a different stack depth.  Up to 1.8.5, `scm_with_guile
   ()' would not update the thread's `base' field, which would then confuse
   the GC.

   See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00037.html
   for a detailed report.  */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>

static void *
entry_point (void *arg)
{
  /* Invoke the GC.  If `THREAD->base' is incorrect, then Guile will just
     segfault somewhere in `scm_mark_locations ()'.  */
  scm_gc ();

  return NULL;
}

static void
go_deeper_into_the_stack (unsigned level)
{
  /* The assumption is that the compiler is not smart enough to optimize this
     out.  */
  if (level > 0)
    go_deeper_into_the_stack (level - 1);
  else
    scm_with_guile (entry_point, NULL);
}

int
main (int argc, char *argv[])
{
  /* Invoke `scm_with_guile ()' from someplace deep into the stack.  */
  go_deeper_into_the_stack (100);

  /* Invoke it from much higher into the stack.  This time, Guile is expected
     to update the `base' field of the current thread.  */
  scm_with_guile (entry_point, NULL);

  return 0;
}


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

(define (test-system-cmd)
  (if (not (boolean? (system)))
      (begin
        (simple-format
         #t
         "test-system-cmds: (system) did not return a boolean\n")
        (exit 1)))

  (let ((rs (status:exit-val (system "guile -c '(exit 42)'"))))
    (if (not (= 42 rs))
        (begin
          (simple-format
           #t
           "test-system-cmds: system exit status was ~S rather than 42\n"
           rs)
          (exit 1)))))

(define (test-system*-cmd)
  (let ((rs (status:exit-val (system* "guile" "-c" "(exit 42)"))))
    (if (not (= 42 rs))
        (begin
          (simple-format
           #t
           "test-system-cmds: system* exit status was ~S rather than 42\n"
           rs)
          (exit 1)))))

(if (defined? 'system)
    (test-system-cmd))

(if (defined? 'system*)
    (test-system*-cmd))

(exit 0)

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

path: test-suite/standalone/test-system-cmds


code:
/* Copyright (C) 2004, 2005, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#if HAVE_CONFIG_H
# include <config.h>
#endif

/* This blob per the Autoconf manual (under "Particular Functions"), updated
   to match that of Gnulib.  */
#ifndef alloca
# if HAVE_ALLOCA_H
#  include <alloca.h>
# elif defined __GNUC__
#  define alloca __builtin_alloca
# elif defined _AIX
#  define alloca __alloca
# elif defined _MSC_VER
#  include <malloc.h>
#  define alloca _alloca
# else
#  include <stddef.h>
#  ifdef  __cplusplus
extern "C"
#  endif
void *alloca (size_t);
# endif
#endif

#include <libguile.h>
#include <stdlib.h>
#include <stdio.h>
#include <unistd.h>

#ifdef HAVE_STRING_H
# include <string.h>
#endif

void set_flag (void *data);
void func1 (void);
void func2 (void);
void func3 (void);
void func4 (void);
void check_flag1 (const char *msg, void (*func)(void), int val);
SCM check_flag1_body (void *data);
SCM return_tag (void *data, SCM tag, SCM args);
void check_cont (int rewindable);
SCM check_cont_body (void *data);
void close_port (SCM port);
void delete_file (void *data);
void check_ports (void);
void check_fluid (void);

int flag1, flag2, flag3;

void
set_flag (void *data)
{
  int *f = (int *)data;
  *f = 1;
}

/* FUNC1 should leave flag1 zero.
 */

void
func1 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, 0);
  scm_dynwind_end ();
}

/* FUNC2 should set flag1.
 */

void
func2 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_end ();
}

/* FUNC3 should set flag1.
 */

void
func3 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, 0);
  scm_misc_error ("func3", "gratuitous error", SCM_EOL);
  scm_dynwind_end ();
}

/* FUNC4 should set flag1.
 */

void
func4 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY);
  scm_misc_error ("func4", "gratuitous error", SCM_EOL);
  scm_dynwind_end ();
}

SCM
check_flag1_body (void *data)
{
  void (*f)(void) = (void (*)(void))data;
  f ();
  return SCM_UNSPECIFIED;
}

SCM
return_tag (void *data, SCM tag, SCM args)
{
  return tag;
}

void
check_flag1 (const char *tag, void (*func)(void), int val)
{
  scm_internal_catch (SCM_BOOL_T,
		      check_flag1_body, func,
		      return_tag, NULL);
  if (flag1 != val)
    {
      printf ("%s failed\n", tag);
      exit (1);
    }
}

SCM
check_cont_body (void *data)
{
  scm_t_dynwind_flags flags = (data? SCM_F_DYNWIND_REWINDABLE : 0);
  int first;
  SCM val;

  scm_dynwind_begin (flags);

  val = scm_make_continuation (&first);
  scm_dynwind_end ();
  return val;
}

void
check_cont (int rewindable)
{
  SCM res;

  res = scm_internal_catch (SCM_BOOL_T,
			    check_cont_body, (void *)(long)rewindable,
			    return_tag, NULL);

  /* RES is now either the created continuation, the value passed to
     the continuation, or a catch-tag, such as 'misc-error.
   */

  if (scm_is_true (scm_procedure_p (res)))
    {
      /* a continuation, invoke it */
      scm_call_1 (res, SCM_BOOL_F);
    }
  else if (scm_is_false (res))
    {
      /* the result of invoking the continuation, dynwind must be
	 rewindable */
      if (rewindable)
	return;
      printf ("continuation not blocked\n");
      exit (1);
    }
  else
    {
      /* the catch tag, dynwind must not have been rewindable. */
      if (!rewindable)
	return;
      printf ("continuation didn't work\n");
      exit (1);
    }
}

void
close_port (SCM port)
{
  scm_close_port (port);
}

void
delete_file (void *data)
{
  unlink ((char *)data);
}

void
check_ports ()
{
#define FILENAME_TEMPLATE "/check-ports.XXXXXX"
  char *filename;
  const char *tmpdir = getenv ("TMPDIR");

  if (tmpdir == NULL)
    tmpdir = "/tmp";

  filename = (char *) alloca (strlen (tmpdir) +
			      sizeof (FILENAME_TEMPLATE) + 1);
  strcpy (filename, tmpdir);
  strcat (filename, FILENAME_TEMPLATE);

  if (mktemp (filename) == NULL)
    exit (1);

  scm_dynwind_begin (0);
  {
    SCM port = scm_open_file (scm_from_locale_string (filename),
			      scm_from_locale_string ("w"));
    scm_dynwind_unwind_handler_with_scm (close_port, port,
				       SCM_F_WIND_EXPLICITLY);

    scm_dynwind_current_output_port (port);
    scm_write (scm_version (), SCM_UNDEFINED);
  }
  scm_dynwind_end ();

  scm_dynwind_begin (0);
  {
    SCM port = scm_open_file (scm_from_locale_string (filename),
			      scm_from_locale_string ("r"));
    SCM res;
    scm_dynwind_unwind_handler_with_scm (close_port, port,
				       SCM_F_WIND_EXPLICITLY);
    scm_dynwind_unwind_handler (delete_file, filename, SCM_F_WIND_EXPLICITLY);

    scm_dynwind_current_input_port (port);
    res = scm_read (SCM_UNDEFINED);
    if (scm_is_false (scm_equal_p (res, scm_version ())))
      {
	printf ("ports didn't work\n");
	exit (1);
      }
  }
  scm_dynwind_end ();
#undef FILENAME_TEMPLATE
}

void
check_fluid ()
{
  SCM f = scm_make_fluid ();
  SCM x;

  scm_fluid_set_x (f, scm_from_int (12));

  scm_dynwind_begin (0);
  scm_dynwind_fluid (f, scm_from_int (13));
  x = scm_fluid_ref (f);
  scm_dynwind_end ();

  if (!scm_is_eq (x, scm_from_int (13)))
    {
      printf ("setting fluid didn't work\n");
      exit (1);
    }

  if (!scm_is_eq (scm_fluid_ref (f), scm_from_int (12)))
    {
      printf ("resetting fluid didn't work\n");
      exit (1);
    }
}

static void
inner_main (void *data, int argc, char **argv)
{
  check_flag1 ("func1", func1, 0);
  check_flag1 ("func2", func2, 1);
  check_flag1 ("func3", func3, 1);
  check_flag1 ("func4", func4, 1);

  check_cont (0);
  check_cont (1);

  check_ports ();

  check_fluid ();

  exit (0);
}

int
main (int argc, char **argv)
{
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0;
}


code:
#!/bin/sh

# Copyright (C) 2006 Free Software Foundation, Inc.
#
# This library is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 of the License, or (at
# your option) any later version.
#
# This library is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
# License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with this library; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

# Test that two srfi numbers on the command line work.
#
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1,10 >/dev/null <<EOF
(if (and (defined? 'partition)
         (defined? 'define-reader-ctor))
    (exit 0)   ;; good
    (exit 1))  ;; bad
EOF
if test $? = 0; then :; else
  echo "guile --use-srfi=1,10 fails to run"
  exit 1
fi

# Test that running "guile --use-srfi=1" leaves the interactive REPL with
# the srfi-1 version of iota.
#
# In guile 1.8.1 and earlier, and 1.6.8 and earlier, these failed because in
# `top-repl' the core bindings got ahead of anything --use-srfi gave.
#

guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1 >/dev/null <<EOF
(catch #t
  (lambda ()
    (iota 2 3 4))
  (lambda args
    (exit 1))) ;; bad
(exit 0)       ;; good
EOF
if test $? = 0; then :; else
  echo "guile --use-srfi=1 doesn't give SRFI-1 iota"
  exit 1
fi

# Similar test on srfi-17 car, which differs in being a #:replacement.  This
# exercises duplicates handling in `top-repl' versus `use-srfis' (in
# boot-9.scm).
#
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=17 >/dev/null <<EOF
(if (procedure-with-setter? car)
    (exit 0)   ;; good
    (exit 1))  ;; bad
EOF
if test $? = 0; then :; else
  echo "guile --use-srfi=17 doesn't give SRFI-17 car"
  exit 1
fi


code:
/* Copyright (C) 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#ifndef HAVE_CONFIG_H
# include <config.h>
#endif

#include <pthread.h>
#include <libguile.h>

void *thread_inner_main (void *unused);
void *thread_main (void *unused);
void *do_join (void *data);
void *inner_main (void *unused);

void *
thread_inner_main (void *unused)
{
  int argc = 3;
  char *argv[] = {
    "guile",
    "-c",
    "(or (current-module) (exit -1))",
    0
  };

  scm_shell (argc, argv);

  return NULL;			/* dummy */
}

void *
thread_main (void *unused)
{
  scm_with_guile (&thread_inner_main, NULL);

  return NULL;			/* dummy */
}

void *
do_join (void *data)
{
  pthread_t *thread = (pthread_t *) data;

  pthread_join (*thread, NULL);

  return NULL;			/* dummy */
}

void *
inner_main (void *unused)
{
  pthread_t thread;

  pthread_create (&thread, NULL, &thread_main, NULL);
  scm_without_guile (do_join, &thread);

  return NULL;			/* dummy */
}

int
main (int argc, char **argv)
{
  scm_with_guile (&inner_main, NULL);

  return 0;
}