;;;
Part of :  / MP
Contents : tests for the MPZ numbers
Date : Thu Nov 27 , 2008
;;;
;;;Abstract
;;;
;;;
;;;
Copyright ( c ) 2008 , 2009   <  >
;;;
;;;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 3 of the License , or ( at
;;;your option) any later version.
;;;
;;;This program is  distributed in the hope that it  will be useful, but
;;;WITHOUT  ANY   WARRANTY;  without   even  the  implied   warranty  of
;;;MERCHANTABILITY  or FITNESS FOR  A PARTICULAR  PURPOSE.  See  the GNU
General Public License for more details .
;;;
You should   have received   a copy of   the GNU General   Public License
;;;along with this program.  If not, see </>.
;;;


(import (nausicaa)
  (compensations)
  (checks)
  (foreign memory)
  (foreign cstrings)
  (foreign math mp mpz)
  (foreign math mp sizeof))

(check-set-mode! 'report-failed)
(display "*** testing mpz\n")


;;;; helpers

(define (mpz->string o)
  (let ((str #f))
    (dynamic-wind
	(lambda ()
	  (set! str (mpz_get_str pointer-null 10 o)))
	(lambda ()
	  (cstring->string str))
	(lambda ()
	  (primitive-free str)))))


(parametrise ((check-test-name 'explicit-allocation))

  (check
      (let ((a (malloc sizeof-mpz_t))
	    (b (malloc sizeof-mpz_t))
	    (c (malloc sizeof-mpz_t)))
	(mpz_init a)
	(mpz_init b)
	(mpz_init c)

	(mpz_set_si a 10)
	(mpz_set_si b 5)
	(mpz_add c a b)

	(mpz_clear a)
	(mpz_clear b)
	(primitive-free a)
	(primitive-free b)
	(begin0
	    (substring (mpz->string c) 0 2)
	  (mpz_clear c)
	  (primitive-free c)))
    => "15")

  #t)


(parametrise ((check-test-name	'dynamic-wind))

  (define-syntax with-mpz
    (syntax-rules ()
      ((_ () ?form0 ?form ...)
       (begin ?form0 ?form ...))
      ((_ (?id0 ?id ...) ?form0 ?form ...)
       (let ((?id0 #f))
	 (dynamic-wind
	     (lambda ()
	       (set! ?id0 (malloc sizeof-mpz_t))
	       (mpz_init ?id0))
	     (lambda ()
	       (with-mpz (?id ...) ?form0 ?form ...))
	     (lambda ()
	       (mpz_clear ?id0)
	       (primitive-free ?id0)))))))

  (check
      (with-mpz (a b c)
	(mpz_set_si a 10)
	(mpz_set_si b 5)
	(mpz_add c a b)
        (substring (mpz->string c) 0 2))
    => "15")

  #t)


(parametrise ((check-test-name 'compensated-allocation))

  (define (mpz/c)
    (letrec ((p (compensate
		    (malloc sizeof-mpz_t)
		  (with
		   (mpz_clear p)
		   (primitive-free p)))))
      (mpz_init p)
      p))

  (check
      (with-compensations
	(let ((c (mpz/c)))
	  (with-compensations
	    (let ((a (mpz/c))
		  (b (mpz/c)))
	      (mpz_set_si a 10)
	      (mpz_set_si b 5)
	      (mpz_add c a b)))
	  (substring (mpz->string c) 0 2)))
    => "15")

  #t)


(parametrise ((check-test-name 'factory-allocation))

  (define mpz-factory
    (make-caching-object-factory mpz_init mpz_clear sizeof-mpz_t 10))

  (define (mpz)
    (letrec ((p (compensate
		    (mpz-factory)
		  (with
		   (mpz-factory p)))))
      p))

  (check
      (with-compensations
	(let ((c (mpz)))
	  (with-compensations
	    (let ((a (mpz))
		  (b (mpz)))
	      (mpz_set_si a 10)
	      (mpz_set_si b 5)
	      (mpz_add c a b)))
	  (substring (mpz->string c) 0 2)))
    => "15")

  (mpz-factory 'purge)

  #t)


;;;; done

(check-report)

;;; end of file



Abstract




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
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

along with this program.  If not, see </>.

 helpers
 done
 end of file
Part of :  / MP
Contents : tests for the MPZ numbers
Date : Thu Nov 27 , 2008
Copyright ( c ) 2008 , 2009   <  >
the Free Software Foundation , either version 3 of the License , or ( at
General Public License for more details .
You should   have received   a copy of   the GNU General   Public License


(import (nausicaa)
  (compensations)
  (checks)
  (foreign memory)
  (foreign cstrings)
  (foreign math mp mpz)
  (foreign math mp sizeof))

(check-set-mode! 'report-failed)
(display "*** testing mpz\n")



(define (mpz->string o)
  (let ((str #f))
    (dynamic-wind
	(lambda ()
	  (set! str (mpz_get_str pointer-null 10 o)))
	(lambda ()
	  (cstring->string str))
	(lambda ()
	  (primitive-free str)))))


(parametrise ((check-test-name 'explicit-allocation))

  (check
      (let ((a (malloc sizeof-mpz_t))
	    (b (malloc sizeof-mpz_t))
	    (c (malloc sizeof-mpz_t)))
	(mpz_init a)
	(mpz_init b)
	(mpz_init c)

	(mpz_set_si a 10)
	(mpz_set_si b 5)
	(mpz_add c a b)

	(mpz_clear a)
	(mpz_clear b)
	(primitive-free a)
	(primitive-free b)
	(begin0
	    (substring (mpz->string c) 0 2)
	  (mpz_clear c)
	  (primitive-free c)))
    => "15")

  #t)


(parametrise ((check-test-name	'dynamic-wind))

  (define-syntax with-mpz
    (syntax-rules ()
      ((_ () ?form0 ?form ...)
       (begin ?form0 ?form ...))
      ((_ (?id0 ?id ...) ?form0 ?form ...)
       (let ((?id0 #f))
	 (dynamic-wind
	     (lambda ()
	       (set! ?id0 (malloc sizeof-mpz_t))
	       (mpz_init ?id0))
	     (lambda ()
	       (with-mpz (?id ...) ?form0 ?form ...))
	     (lambda ()
	       (mpz_clear ?id0)
	       (primitive-free ?id0)))))))

  (check
      (with-mpz (a b c)
	(mpz_set_si a 10)
	(mpz_set_si b 5)
	(mpz_add c a b)
        (substring (mpz->string c) 0 2))
    => "15")

  #t)


(parametrise ((check-test-name 'compensated-allocation))

  (define (mpz/c)
    (letrec ((p (compensate
		    (malloc sizeof-mpz_t)
		  (with
		   (mpz_clear p)
		   (primitive-free p)))))
      (mpz_init p)
      p))

  (check
      (with-compensations
	(let ((c (mpz/c)))
	  (with-compensations
	    (let ((a (mpz/c))
		  (b (mpz/c)))
	      (mpz_set_si a 10)
	      (mpz_set_si b 5)
	      (mpz_add c a b)))
	  (substring (mpz->string c) 0 2)))
    => "15")

  #t)


(parametrise ((check-test-name 'factory-allocation))

  (define mpz-factory
    (make-caching-object-factory mpz_init mpz_clear sizeof-mpz_t 10))

  (define (mpz)
    (letrec ((p (compensate
		    (mpz-factory)
		  (with
		   (mpz-factory p)))))
      p))

  (check
      (with-compensations
	(let ((c (mpz)))
	  (with-compensations
	    (let ((a (mpz))
		  (b (mpz)))
	      (mpz_set_si a 10)
	      (mpz_set_si b 5)
	      (mpz_add c a b)))
	  (substring (mpz->string c) 0 2)))
    => "15")

  (mpz-factory 'purge)

  #t)



(check-report)

