source: project/release/2/gmp/gmp_rational.scm @ 8742

(include "gmp_types.scm")
(require 'gmp_utils)

(declare
        (foreign-declare "#include <gmp.h>"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Scheme Construction Function for the Rational Variable Type mpq_t
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; uses a finalizer to free the memory during gc
(define make-mpq_t
        (let (  (alloc (foreign-lambda* mpq_t () 
                                                "return (malloc(sizeof(mpq_t)));"))
                        (dealloc (foreign-lambda void "free" c-pointer)))
                (lambda ()
                        (let ((m (alloc)))
                                (set-finalizer! m dealloc)
                                m))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Canonicalization Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_canonicalize
        (foreign-lambda void "mpq_canonicalize" mpq_t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Initialization and Assignment Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_init
        (foreign-lambda void "mpq_init" mpq_t))

(define mpq_clear
        (foreign-lambda void "mpq_clear" mpq_t))

(define mpq_set
        (foreign-lambda void "mpq_set" mpq_t mpq_t))

(define mpq_set_z
        (foreign-lambda void "mpq_set_z" mpq_t mpz_t))

(define mpq_set_ui
        (foreign-lambda void "mpq_set_ui" mpq_t unsigned-long unsigned-long))

(define mpq_set_si
        (foreign-lambda void "mpq_set_si" mpq_t long long))

(define mpq_set_str
        (foreign-lambda int "mpq_set_str" mpq_t c-string int))

(define mpq_swap
        (foreign-lambda void "mpq_swap" mpq_t mpq_t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Conversion Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_get_d
        (foreign-lambda double "mpq_get_d" mpq_t))

(define mpq_set_d
        (foreign-lambda void "mpq_set_d" mpq_t double))

(define mpq_set_f
        (foreign-lambda void "mpq_set_f" mpq_t mpf_t))

;; if there is a return char *, then manually copy it into a c-string, and
;; free the real c-pointer returned by the function. This should make garbage
;; collection happy.
(define mpq_get_str
        (let (  (alloc (foreign-lambda c-pointer "mpq_get_str" c-pointer int mpq_t))
                        (free (foreign-lambda void "free" c-pointer)))
        (lambda (ptr base mpq)
                (let ((c-ptr (alloc ptr base mpq)))
                        (if (not ptr)
                                (let ((str (c-pointer->c-string c-ptr))) ;; copy the string...
                                        (free c-ptr) ;; remove the mem alloced by mpz_get_str
                                        str)
                                ptr)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Arithmetic Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_add
        (foreign-lambda void "mpq_add" mpq_t mpq_t mpq_t))

(define mpq_sub
        (foreign-lambda void "mpq_sub" mpq_t mpq_t mpq_t))

(define mpq_mul
        (foreign-lambda void "mpq_mul" mpq_t mpq_t mpq_t))

(define mpq_mul_2exp
        (foreign-lambda void "mpq_mul_2exp" mpq_t mpq_t unsigned-long))

(define mpq_div
        (foreign-lambda void "mpq_div" mpq_t mpq_t mpq_t))

(define mpq_div_2exp
        (foreign-lambda void "mpq_div_2exp" mpq_t mpq_t unsigned-long))

(define mpq_neg
        (foreign-lambda void "mpq_neg" mpq_t mpq_t))

(define mpq_abs
        (foreign-lambda void "mpq_abs" mpq_t mpq_t))

(define mpq_inv
        (foreign-lambda void "mpq_inv" mpq_t mpq_t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Comparison Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_cmp
        (foreign-lambda int "mpq_cmp" mpq_t mpq_t))

(define mpq_cmp_ui
        (foreign-lambda* int ((mpq_t op1) (unsigned-long num2) (unsigned-long den2))
                "return(mpq_cmp_ui(op1, num2, den2));"))

(define mpq_cmp_si
        (foreign-lambda* int ((mpq_t op1) (long num2) (unsigned-long den2))
                "return(mpq_cmp_si(op1, num2, den2));"))

(define mpq_sgn
        (foreign-lambda* int ((mpq_t mpq))
                "return(mpq_sgn(mpq));"))

(define mpq_equal
        (foreign-lambda int "mpq_equal" mpq_t mpq_t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Applying Integer Funtions to Rationals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_numref
        (foreign-lambda* mpz_t ((mpq_t op))
                "return(mpq_numref(op));"))

(define mpq_denref
        (foreign-lambda* mpz_t ((mpq_t op))
                "return(mpq_denref(op));"))

(define mpq_get_num
        (foreign-lambda void "mpq_get_num" mpz_t mpq_t))

(define mpq_get_den
        (foreign-lambda void "mpq_get_den" mpz_t mpq_t))

(define mpq_set_num
        (foreign-lambda void "mpq_set_num" mpq_t mpz_t))

(define mpq_set_den
        (foreign-lambda void "mpq_set_den" mpq_t mpz_t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Input and Output Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define mpq_out_str
        (lambda (port-var int-var mpq_t-var)
                (let (  (mos (foreign-lambda size_t "mpq_out_str" c-pointer int mpq_t))
                                (fp (port->file* port-var)))
                        (mos fp int-var mpq_t-var))))

(define mpq_inp_str
        (lambda (mpq_t-var port-var int-var)
                (let (  (mos (foreign-lambda size_t "mpq_inp_str" mpq_t c-pointer int))
                                (fp (port->file* port-var)))
                        (mos mpq_t-var fp int-var))))