IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Replace the gnc:numeric pair with normal Scheme rationals.

Browse Source 
This allows direct conversion between Scheme numbers and gnc_numeric
without the performance or accuracy penalties arising from using doubles
as an intermediary.
This commit is contained in:
John Ralls 2017-12-21 15:30:49 -08:00
parent 7061803596
commit e0300d3a62
30 changed files with 190 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gnucash/report/business-reports/balsheet-eg.eguile.scm
View File

@ -288,7 +288,7 @@
<?scm <?scm
(for xpair in xlist do (for xpair in xlist do
(let* ((comm (car xpair)) (let* ((comm (car xpair))
(one-num (gnc:make-gnc-numeric 10000 1)) (one-num 10000/1)
(one-foreign-mny (gnc:make-gnc-monetary comm one-num)) (one-foreign-mny (gnc:make-gnc-monetary comm one-num))
(one-local-mny (exchange-fn one-foreign-mny opt-report-commodity))) (one-local-mny (exchange-fn one-foreign-mny opt-report-commodity)))
?> ?>

2
gnucash/report/business-reports/receipt.scm
View File

@ -46,7 +46,7 @@
(if (or (not taxable) (eq? taxtable '())) (if (or (not taxable) (eq? taxtable '()))
(display "&nbsp;") (display "&nbsp;")
(let* ((amttot (gnc:make-commodity-collector)) (let* ((amttot (gnc:make-commodity-collector))
(pctot (gnc:make-numeric-collector)) (pctot (gnc:make-number-collector))
(entries (gncTaxTableGetEntries taxtable)) (entries (gncTaxTableGetEntries taxtable))
(amt? #f) ; becomes #t if any entries are amounts (amt? #f) ; becomes #t if any entries are amounts
(pc? #f)) ; becomes #t if any entries are percentages (pc? #f)) ; becomes #t if any entries are percentages

2
gnucash/report/business-reports/taxinvoice.scm
View File

@ -53,7 +53,7 @@
(if (or (not taxable) (eq? taxtable '())) (if (or (not taxable) (eq? taxtable '()))
(display "&nbsp;") (display "&nbsp;")
(let* ((amttot (gnc:make-commodity-collector)) (let* ((amttot (gnc:make-commodity-collector))
(pctot (gnc:make-numeric-collector)) (pctot (gnc:make-number-collector))
(entries (gncTaxTableGetEntries taxtable)) (entries (gncTaxTableGetEntries taxtable))
(amt? #f) ; becomes #t if any entries are amounts (amt? #f) ; becomes #t if any entries are amounts
(pc? #f)) ; becomes #t if any entries are percentages (pc? #f)) ; becomes #t if any entries are percentages

4
gnucash/report/locale-specific/us/taxtxf.scm
View File

@ -701,7 +701,7 @@
(gnc-commodity-equiv account-commodity (gnc-commodity-equiv account-commodity
USD-currency))) USD-currency)))
(xaccSplitGetValue split) (xaccSplitGetValue split)
(gnc:make-gnc-numeric 100 100))) 100/100))
(missing-pricedb-entry? #f) (missing-pricedb-entry? #f)
(pricedb-lookup-price #f) (pricedb-lookup-price #f)
(pricedb-lookup-price-value (gnc-numeric-zero)) (pricedb-lookup-price-value (gnc-numeric-zero))
@ -798,7 +798,7 @@
trans-currency trans-currency
USD-currency)) USD-currency))
(gnc-numeric-div (gnc-numeric-div
(gnc:make-gnc-numeric 100 100) 100/100
(xaccSplitGetSharePrice split) (xaccSplitGetSharePrice split)
GNC-DENOM-AUTO GNC-DENOM-AUTO
(logior (GNC-DENOM-SIGFIGS 6) (logior (GNC-DENOM-SIGFIGS 6)

14
gnucash/report/report-system/commodity-utilities.scm
View File

@ -415,8 +415,8 @@
;; numeric-collectors, where [abc] are numeric-collectors. See the ;; numeric-collectors, where [abc] are numeric-collectors. See the
;; real variable names below. ;; real variable names below.
(define (make-newrate unknown-coll un->known-coll known-pair) (define (make-newrate unknown-coll un->known-coll known-pair)
(let ((a (gnc:make-numeric-collector)) (let ((a (gnc:make-number-collector))
(b (gnc:make-numeric-collector))) (b (gnc:make-number-collector)))
(a 'add (unknown-coll 'total #f)) (a 'add (unknown-coll 'total #f))
(b 'add (b 'add
;; round to (at least) 8 significant digits ;; round to (at least) 8 significant digits
@ -459,7 +459,7 @@
;; If this is an Euro currency, create the ;; If this is an Euro currency, create the
;; pair of appropriately exchanged amounts. ;; pair of appropriately exchanged amounts.
(if euro-monetary (if euro-monetary
(let ((a (gnc:make-numeric-collector))) (let ((a (gnc:make-number-collector)))
(a 'add (a 'add
(gnc:gnc-monetary-amount euro-monetary)) (gnc:gnc-monetary-amount euro-monetary))
(list report-commodity (list report-commodity
@ -532,8 +532,8 @@
(define (create-commodity-list inner-comm outer-comm share-amount value-amount) (define (create-commodity-list inner-comm outer-comm share-amount value-amount)
(let ((foreignlist (list inner-comm (let ((foreignlist (list inner-comm
(cons (gnc:make-numeric-collector) (cons (gnc:make-number-collector)
(gnc:make-numeric-collector)))) (gnc:make-number-collector))))
(comm-list #f)) (comm-list #f))
((caadr foreignlist) 'add share-amount) ((caadr foreignlist) 'add share-amount)
((cdadr foreignlist) 'add value-amount) ((cdadr foreignlist) 'add value-amount)
@ -560,8 +560,8 @@
(if (not pair) (if (not pair)
(begin (begin
(set! pair (list (car foreignlist) (set! pair (list (car foreignlist)
(cons (gnc:make-numeric-collector) (cons (gnc:make-number-collector)
(gnc:make-numeric-collector)))) (gnc:make-number-collector))))
(gnc:debug "New commodity " (gnc:debug "New commodity "
(gnc-commodity-get-mnemonic (car foreignlist))))) (gnc-commodity-get-mnemonic (car foreignlist)))))
pair)) pair))

2
gnucash/report/report-system/html-barchart.scm
View File

@ -300,8 +300,6 @@
(lambda () (lambda ()
(let ((n (read))) (let ((n (read)))
(if (number? n) n 0.0))))) (if (number? n) n 0.0)))))
((gnc:gnc-numeric? elt)
(gnc-numeric-to-double elt))
(#t (#t
0.0))) 0.0)))

2
gnucash/report/report-system/html-linechart.scm
View File

@ -335,8 +335,6 @@
(lambda () (lambda ()
(let ((n (read))) (let ((n (read)))
(if (number? n) n 0.0))))) (if (number? n) n 0.0)))))
((gnc:gnc-numeric? elt)
(gnc-numeric-to-double elt))
(#t (#t
0.0))) 0.0)))

4
gnucash/report/report-system/html-piechart.scm
View File

@ -152,9 +152,7 @@
(lambda () (lambda ()
(let ((n (read))) (let ((n (read)))
(if (number? n) (abs n) 0.0))))) (if (number? n) (abs n) 0.0)))))
((gnc:gnc-numeric? elt) (#t
(abs (gnc-numeric-to-double elt)))
(#t
0.0))) 0.0)))
nlist)) nlist))

4
gnucash/report/report-system/html-scatter.scm
View File

@ -131,9 +131,7 @@
(lambda () (lambda ()
(let ((n (read))) (let ((n (read)))
(if (number? n) n 0.0))))) (if (number? n) n 0.0)))))
((gnc:gnc-numeric? elt) (#t
(gnc-numeric-to-double elt))
(#t
0.0))) 0.0)))
(let* ((retval '()) (let* ((retval '())

2
gnucash/report/report-system/report-system.scm
View File

@ -671,7 +671,7 @@
(export gnc:make-stats-collector) (export gnc:make-stats-collector)
(export gnc:make-drcr-collector) (export gnc:make-drcr-collector)
(export gnc:make-value-collector) (export gnc:make-value-collector)
(export gnc:make-numeric-collector) (export gnc:make-number-collector)
(export gnc:make-commodity-collector) (export gnc:make-commodity-collector)
(export gnc:commodity-collector-get-negated) (export gnc:commodity-collector-get-negated)
(export gnc:commodity-collectorlist-get-merged) (export gnc:commodity-collectorlist-get-merged)

40
gnucash/report/report-system/report-utilities.scm
View File

@ -266,24 +266,24 @@
;; Same as above but with gnc:numeric ;; Same as above but with gnc:numeric
(define (gnc:make-numeric-collector) (define (gnc:make-number-collector)
(let ;;; values (let ;;; values
((value (gnc-numeric-zero))) ((value 0))
(lambda (action amount) ;;; Dispatch function (lambda (action amount) ;;; Dispatch function
(case action (case action
((add) (if (gnc:gnc-numeric? amount) ((add) (if (number? amount)
(set! value (gnc-numeric-add amount value (set! value (gnc-numeric-add amount value
GNC-DENOM-AUTO GNC-DENOM-LCD)) GNC-DENOM-AUTO GNC-DENOM-LCD))
(gnc:warn (gnc:warn
"gnc:numeric-collector called with wrong argument: " "gnc:Number-collector called with wrong argument: "
amount))) amount)))
((total) value) ((total) value)
(else (gnc:warn "bad gnc:numeric-collector action: " action)))))) (else (gnc:warn "bad gnc:number-collector action: " action))))))
;; Replace all 'action function calls by the normal functions below. ;; Replace all 'action function calls by the normal functions below.
(define (gnc:numeric-collector-add collector amount) (define (gnc:number-collector-add collector amount)
(collector 'add amount)) (collector 'add amount))
(define (gnc:numeric-collector-total collector) (define (gnc:number-collector-total collector)
(collector 'total #f)) (collector 'total #f))
;; A commodity collector. This is intended to handle multiple ;; A commodity collector. This is intended to handle multiple
@ -338,12 +338,12 @@
(gnc-commodity-get-fraction commodity) GNC-RND-ROUND))) (gnc-commodity-get-fraction commodity) GNC-RND-ROUND)))
(if (not pair) (if (not pair)
(begin (begin
;; create a new pair, using the gnc:numeric-collector ;; create a new pair, using the gnc:number-collector
(set! pair (list commodity (gnc:make-numeric-collector))) (set! pair (list commodity (gnc:make-number-collector)))
;; and add it to the alist ;; and add it to the alist
(set! commoditylist (cons pair commoditylist)))) (set! commoditylist (cons pair commoditylist))))
;; add the value ;; add the value
(gnc:numeric-collector-add (cadr pair) rvalue))) (gnc:number-collector-add (cadr pair) rvalue)))
;; helper function to walk an association list, adding each ;; helper function to walk an association list, adding each
;; (commodity -> collector) pair to our list at the appropriate ;; (commodity -> collector) pair to our list at the appropriate
@ -352,7 +352,7 @@
(cond ((null? clist) '()) (cond ((null? clist) '())
(else (add-commodity-value (else (add-commodity-value
(caar clist) (caar clist)
(gnc:numeric-collector-total (cadar clist))) (gnc:number-collector-total (cadar clist)))
(add-commodity-clist (cdr clist))))) (add-commodity-clist (cdr clist)))))
(define (minus-commodity-clist clist) (define (minus-commodity-clist clist)
@ -360,7 +360,7 @@
(else (add-commodity-value (else (add-commodity-value
(caar clist) (caar clist)
(gnc-numeric-neg (gnc-numeric-neg
(gnc:numeric-collector-total (cadar clist)))) (gnc:number-collector-total (cadar clist))))
(minus-commodity-clist (cdr clist))))) (minus-commodity-clist (cdr clist)))))
;; helper function walk the association list doing a callback on ;; helper function walk the association list doing a callback on
@ -368,7 +368,7 @@
(define (process-commodity-list fn clist) (define (process-commodity-list fn clist)
(map (map
(lambda (pair) (fn (car pair) (lambda (pair) (fn (car pair)
(gnc:numeric-collector-total (cadr pair)))) (gnc:number-collector-total (cadr pair))))
clist)) clist))
;; helper function which is given a commodity and returns, if ;; helper function which is given a commodity and returns, if
@ -381,8 +381,8 @@
(gnc-numeric-zero) (gnc-numeric-zero)
(if sign? (if sign?
(gnc-numeric-neg (gnc-numeric-neg
(gnc:numeric-collector-total (cadr pair))) (gnc:number-collector-total (cadr pair)))
(gnc:numeric-collector-total (cadr pair)))) (gnc:number-collector-total (cadr pair))))
'())))) '()))))
;; helper function which is given a commodity and returns, if ;; helper function which is given a commodity and returns, if
@ -395,8 +395,8 @@
(gnc-numeric-zero) (gnc-numeric-zero)
(if sign? (if sign?
(gnc-numeric-neg (gnc-numeric-neg
(gnc:numeric-collector-total (cadr pair))) (gnc:number-collector-total (cadr pair)))
(gnc:numeric-collector-total (cadr pair))))))) (gnc:number-collector-total (cadr pair)))))))
;; Dispatch function ;; Dispatch function
(lambda (action commodity amount) (lambda (action commodity amount)

8
gnucash/report/standard-reports/advanced-portfolio.scm
View File

@ -321,7 +321,7 @@
;; If the units ratio is zero the stock is worthless and the value should be zero too ;; If the units ratio is zero the stock is worthless and the value should be zero too
(value-ratio (if (gnc-numeric-zero-p units-ratio) (value-ratio (if (gnc-numeric-zero-p units-ratio)
(gnc-numeric-zero) (gnc-numeric-zero)
(gnc-numeric-div (gnc:make-gnc-numeric 1 1) units-ratio GNC-DENOM-AUTO GNC-DENOM-REDUCE)))) (gnc-numeric-div 1/1 units-ratio GNC-DENOM-AUTO GNC-DENOM-REDUCE))))
(gnc:debug "blist is " b-list " current units is " (gnc:debug "blist is " b-list " current units is "
(gnc-numeric-to-string current-units) (gnc-numeric-to-string current-units)
@ -341,7 +341,7 @@
(gnc:debug "this is a spinoff") (gnc:debug "this is a spinoff")
(gnc:debug "blist is " b-list " value ratio is " (gnc-numeric-to-string value-ratio)) (gnc:debug "blist is " b-list " value ratio is " (gnc-numeric-to-string value-ratio))
(apply-basis-ratio b-list (gnc:make-gnc-numeric 1 1) value-ratio)) (apply-basis-ratio b-list 1/1 value-ratio))
) )
;; when all else fails, just send the b-list back ;; when all else fails, just send the b-list back
@ -473,7 +473,7 @@
(exchange-fn (exchange-fn
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
(gnc-price-get-currency price) (gnc-price-get-currency price)
(gnc:make-gnc-numeric 100 1)) 100/1)
currency)))) currency))))
(set! price #f)) (set! price #f))
@ -514,7 +514,7 @@
;; If we still don't have a price, use a price of 1 and complain later ;; If we still don't have a price, use a price of 1 and complain later
(if (not price) (if (not price)
(begin (begin
(set! price (gnc:make-gnc-monetary currency (gnc:make-gnc-numeric 1 1))) (set! price (gnc:make-gnc-monetary currency 1/1))
;; If use-txn is set, but pricing-txn isn't set, it's a bogus price ;; If use-txn is set, but pricing-txn isn't set, it's a bogus price
(set! use-txn #t) (set! use-txn #t)
(set! pricing-txn #f) (set! pricing-txn #f)

16
gnucash/report/standard-reports/cash-flow.scm
View File

@ -427,9 +427,9 @@
(gnc:timepair-ge (gnc-transaction-get-date-posted parent) from-date-tp)) (gnc:timepair-ge (gnc-transaction-get-date-posted parent) from-date-tp))
(let* ((parent-description (xaccTransGetDescription parent)) (let* ((parent-description (xaccTransGetDescription parent))
(parent-currency (xaccTransGetCurrency parent))) (parent-currency (xaccTransGetCurrency parent)))
;(gnc:debug parent-description (gnc:debug parent-description
; " - " " - "
; (gnc-commodity-get-printname parent-currency)) (gnc-commodity-get-printname parent-currency))
(for-each (for-each
(lambda (s) (lambda (s)
(let* ((s-account (xaccSplitGetAccount s)) (let* ((s-account (xaccSplitGetAccount s))
@ -444,7 +444,7 @@
(string-append (string-append
"WARNING: s-account is NULL for split: " "WARNING: s-account is NULL for split: "
(gncSplitGetGUID s) "\n"))) (gncSplitGetGUID s) "\n")))
;(gnc:debug (xaccAccountGetName s-account)) (gnc:debug (xaccAccountGetName s-account))
(if (and ;; make sure we don't have (if (and ;; make sure we don't have
(not (null? s-account)) ;; any dangling splits (not (null? s-account)) ;; any dangling splits
(or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING))) (or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
@ -453,7 +453,7 @@
(begin (begin
(if (gnc-numeric-negative-p s-value) (if (gnc-numeric-negative-p s-value)
(let ((s-account-in-collector (account-hashtable-ref money-in-hash s-account))) (let ((s-account-in-collector (account-hashtable-ref money-in-hash s-account)))
;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity) ;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity)
; (gnc-numeric-to-double s-amount) ; (gnc-numeric-to-double s-amount)
; (gnc-commodity-get-printname parent-currency) ; (gnc-commodity-get-printname parent-currency)
; (gnc-numeric-to-double s-value)) ; (gnc-numeric-to-double s-value))
@ -494,14 +494,14 @@
) )
) )
) )
) )
) )
) )
) )
(xaccTransGetSplitList parent) (xaccTransGetSplitList parent)
) )
) )
) )
) )
) )

8
gnucash/report/standard-reports/category-barchart.scm
View File

@ -306,20 +306,20 @@ developing over time"))
(let* ((start-frac-avg (averaging-fraction-func (gnc:timepair->secs from-date-tp))) (let* ((start-frac-avg (averaging-fraction-func (gnc:timepair->secs from-date-tp)))
(end-frac-avg (averaging-fraction-func (+ 1 (gnc:timepair->secs to-date-tp)))) (end-frac-avg (averaging-fraction-func (+ 1 (gnc:timepair->secs to-date-tp))))
(diff-avg (- end-frac-avg start-frac-avg)) (diff-avg (- end-frac-avg start-frac-avg))
(diff-avg-numeric (gnc:make-gnc-numeric (diff-avg-numeric (/
(inexact->exact (round (* diff-avg 1000000))) ; 6 decimals precision (inexact->exact (round (* diff-avg 1000000))) ; 6 decimals precision
1000000)) 1000000))
(start-frac-int (interval-fraction-func (gnc:timepair->secs from-date-tp))) (start-frac-int (interval-fraction-func (gnc:timepair->secs from-date-tp)))
(end-frac-int (interval-fraction-func (+ 1 (gnc:timepair->secs to-date-tp)))) (end-frac-int (interval-fraction-func (+ 1 (gnc:timepair->secs to-date-tp))))
(diff-int (- end-frac-int start-frac-int)) (diff-int (- end-frac-int start-frac-int))
(diff-int-numeric (gnc:make-gnc-numeric (diff-int-numeric (/
(inexact->exact diff-int) 1)) (inexact->exact diff-int) 1))
) )
;; Extra sanity check to ensure a number smaller than 1 ;; Extra sanity check to ensure a number smaller than 1
(if (> diff-avg diff-int) (if (> diff-avg diff-int)
(gnc-numeric-div diff-int-numeric diff-avg-numeric GNC-DENOM-AUTO GNC-RND-ROUND) (gnc-numeric-div diff-int-numeric diff-avg-numeric GNC-DENOM-AUTO GNC-RND-ROUND)
(gnc:make-gnc-numeric 1 1))) 1/1))
(gnc:make-gnc-numeric 1 1))) 1/1))
;; If there is averaging, the report-title is extended ;; If there is averaging, the report-title is extended
;; accordingly. ;; accordingly.
(report-title (report-title

4
gnucash/report/standard-reports/net-barchart.scm
View File

@ -314,11 +314,11 @@
(liabilities (assoc-ref rpt 'liability))) (liabilities (assoc-ref rpt 'liability)))
(set! assets-list (if assets (car assets) (set! assets-list (if assets (car assets)
(map (lambda (d) (map (lambda (d)
(gnc:make-gnc-monetary report-currency (gnc:make-gnc-numeric 0 1))) (gnc:make-gnc-monetary report-currency 0/1))
dates-list))) dates-list)))
(set! liability-list (if liabilities (car liabilities) (set! liability-list (if liabilities (car liabilities)
(map (lambda (d) (map (lambda (d)
(gnc:make-gnc-monetary report-currency (gnc:make-gnc-numeric 0 1))) (gnc:make-gnc-monetary report-currency 0/1))
dates-list))) dates-list)))
) )

2
gnucash/report/standard-reports/sx-summary.scm
View File

@ -355,7 +355,7 @@
(guid (gncAccountGetGUID account)) (guid (gncAccountGetGUID account))
(num-bal (hash-ref sx-value-hash guid))) (num-bal (hash-ref sx-value-hash guid)))
(if num-bal (if num-bal
(if (eq? 0 (gnc:gnc-numeric-denom num-bal)) (if (eq? 0 (denominator num-bal))
(gnc:warn "Oops, invalid gnc_numeric when looking up SX balance for account GUID " guid ": " num-bal) (gnc:warn "Oops, invalid gnc_numeric when looking up SX balance for account GUID " guid ": " num-bal)
(begin (begin
(balance-collector (balance-collector

44
gnucash/report/standard-reports/test/test-cash-flow.scm
View File

@ -36,7 +36,7 @@
(exchange-fn (lambda (currency amount date) amount)) (exchange-fn (lambda (currency amount date) amount))
(report-currency (gnc-default-report-currency)) (report-currency (gnc-default-report-currency))
) )
(env-create-transaction env to-date-tp bank-account expense-account (gnc:make-gnc-numeric 100 1)) (env-create-transaction env to-date-tp bank-account expense-account 100/1)
(let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list bank-account)) (let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list bank-account))
(cons 'to-date-tp to-date-tp) (cons 'to-date-tp to-date-tp)
(cons 'from-date-tp from-date-tp) (cons 'from-date-tp from-date-tp)
@ -48,16 +48,24 @@
(money-in-alist (cdr (assq 'money-in-alist result))) (money-in-alist (cdr (assq 'money-in-alist result)))
(money-out-alist (cdr (assq 'money-out-alist result))) (money-out-alist (cdr (assq 'money-out-alist result)))
(expense-acc-in-collector (cadr (assoc expense-account money-in-alist)))) (expense-acc-in-collector (cadr (assoc expense-account money-in-alist))))
(and (null? money-out-alist) (and (or (null? money-out-alist)
(equal? (gnc:make-gnc-numeric 10000 100) (begin (format #t "The money-out-alist is not null.~%") #f))
(or (equal? 10000/100
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-in-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-in-collector
report-currency exchange-fn))) report-currency exchange-fn)))
(equal? (gnc:make-gnc-numeric 10000 100) (begin (format #t "Failed expense-acc-in-collector ~g expected 100.00~%" (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-in-collector
report-currency exchange-fn))) #f))
(or (equal? 10000/100
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
report-currency exchange-fn))) report-currency exchange-fn)))
(equal? (gnc:make-gnc-numeric 0 1) (begin (format #t "Failed money-in-collector ~g expected 100.00~%" (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
report-currency exchange-fn))) #f))
(or (equal? 0/1
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
report-currency exchange-fn))) report-currency exchange-fn)))
(begin (format #t "Failed sum-collector-commodity ~g expected 100.00~%" (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
report-currency exchange-fn))) #f))
(begin (format #t "test-one-tx-in-cash-flow success~%") #t)
))))) )))))
(define (test-one-tx-skip-cash-flow) (define (test-one-tx-skip-cash-flow)
@ -72,7 +80,7 @@
(exchange-fn (lambda (currency amount date) amount)) (exchange-fn (lambda (currency amount date) amount))
(report-currency (gnc-default-report-currency)) (report-currency (gnc-default-report-currency))
) )
(env-create-transaction env to-date-tp bank-account wallet-account (gnc:make-gnc-numeric 100 1)) (env-create-transaction env to-date-tp bank-account wallet-account 100/1)
(let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list wallet-account bank-account)) (let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list wallet-account bank-account))
(cons 'to-date-tp to-date-tp) (cons 'to-date-tp to-date-tp)
(cons 'from-date-tp from-date-tp) (cons 'from-date-tp from-date-tp)
@ -85,12 +93,14 @@
(money-out-alist (cdr (assq 'money-out-alist result)))) (money-out-alist (cdr (assq 'money-out-alist result))))
(and (null? money-in-alist) (and (null? money-in-alist)
(null? money-out-alist) (null? money-out-alist)
(equal? (gnc:make-gnc-numeric 0 1) (equal? 0/1
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
report-currency exchange-fn))) report-currency exchange-fn)))
(equal? (gnc:make-gnc-numeric 0 1) (equal? 0/1
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
report-currency exchange-fn)))))))) report-currency exchange-fn)))
(begin (format #t "test-one-tx-skip-cash-flow success~%") #t)
)))))
(define (test-both-way-cash-flow) (define (test-both-way-cash-flow)
(let* ((env (create-test-env)) (let* ((env (create-test-env))
@ -104,8 +114,8 @@
(exchange-fn (lambda (currency amount date) amount)) (exchange-fn (lambda (currency amount date) amount))
(report-currency (gnc-default-report-currency)) (report-currency (gnc-default-report-currency))
) )
(env-create-transaction env to-date-tp bank-account expense-account (gnc:make-gnc-numeric 100 1)) (env-create-transaction env to-date-tp bank-account expense-account 100/1)
(env-create-transaction env to-date-tp expense-account bank-account (gnc:make-gnc-numeric 50 1)) (env-create-transaction env to-date-tp expense-account bank-account 50/1)
(let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list wallet-account bank-account)) (let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list wallet-account bank-account))
(cons 'to-date-tp to-date-tp) (cons 'to-date-tp to-date-tp)
(cons 'from-date-tp from-date-tp) (cons 'from-date-tp from-date-tp)
@ -124,11 +134,13 @@
(expenses-out-total (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-out-collector (expenses-out-total (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-out-collector
report-currency report-currency
exchange-fn)))) exchange-fn))))
(and (equal? (gnc:make-gnc-numeric 10000 100) expenses-in-total) (and (equal? 10000/100 expenses-in-total)
(equal? (gnc:make-gnc-numeric 5000 100) expenses-out-total) (equal? 5000/100 expenses-out-total)
(equal? (gnc:make-gnc-numeric 10000 100) (equal? 10000/100
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
report-currency exchange-fn))) report-currency exchange-fn)))
(equal? (gnc:make-gnc-numeric 5000 100) (equal? 5000/100
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
report-currency exchange-fn)))))))) report-currency exchange-fn)))
(begin (format #t "test-both-way-cash-flow success~%") #t)
)))))

38
gnucash/report/standard-reports/test/test-cashflow-barchart.scm
View File

@ -79,12 +79,12 @@
date-1 date-1
bank-account bank-account
income-account income-account
(gnc:make-gnc-numeric 1 1)) 1/1)
(env-create-transaction env (env-create-transaction env
date-2 date-2
wallet-account wallet-account
income-account income-account
(gnc:make-gnc-numeric 5 1)) 5/1)
(begin (begin
(set-option report gnc:pagename-display "Show Table" #t) (set-option report gnc:pagename-display "Show Table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
@ -111,25 +111,27 @@
(list (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))) result))))
(format #t "Report Result ~a~%" result)
(and (every (lambda (row) ; test in=net & out=0 in all rows (all days) (and (every (lambda (row) ; test in=net & out=0 in all rows (all days)
(and (or (equal? (second row) (fourth row)) (and (or (equal? (second row) (fourth row))
(begin (format #t "Failed, ~a and ~a differ~%" (second row) (fourth row)) #f)) (begin (format #t "Failed, ~a and ~a differ~%" (second row) (fourth row)) #f))
(or (= 0 (string->number (car (third row)))) (or (= 0 (string->number (car (third row))))
(begin (format #t "Failed ~d isn't 0~%" (car (third row))) #f)))) (begin (format #t "Failed ~d isn't 0~%" (car (third row))) #f))))
tbl) tbl)
(or (= 0 (tbl-ref->number tbl 0 1)) (begin (format #t "Failed refnum ~d isn't 0~%" (tbl-ref->number tbl 0 1) )) #f)) ; 1st day in =0 (or (= 0 (tbl-ref->number tbl 0 1))
(or (= 1 (tbl-ref->number tbl 1 1)) (begin (format #t "Failed refnum ~d isn't 1~%" (tbl-ref->number tbl 1 1)) #f)) ; 2nd day in =1 (begin (format #t "Failed refnum ~g isn't 0~%" (tbl-ref->number tbl 0 1)) #f)) ; 1st day in =0
(or (= 5 (tbl-ref->number tbl 2 1)) (begin (format #t "Failed refnum ~d isn't 5~%" (tbl-ref->number tbl 2 1)) #f)) ; 3rd day in =5 (or (= 1 (tbl-ref->number tbl 1 1)) (begin (format #t "Failed refnum ~g isn't 1~%" (tbl-ref->number tbl 1 1)) #f)) ; 2nd day in =1
(or (= (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) (begin (format #t "Failed refnums ~d and ~d differ ~%" (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) #f)); total in=total net (or (= 5 (tbl-ref->number tbl 2 1)) (begin (format #t "Failed refnum ~g isn't 5~%" (tbl-ref->number tbl 2 1)) #f)) ; 3rd day in =5
(or (= 0 (tbl-ref->number total 0 1)) (begin (format #t "Failed refnum ~d isn't 0~%" (tbl-ref->number total 0 1)) #f)) ; total out=0 (or (= (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) (begin (format #t "Failed refnums ~g and ~g differ ~%" (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) #f)); total in=total net
(or (= 3 (tbl-row-count tbl)) (begin (format #t "Failed row count ~d isn't 3~%" (tbl-row-count tbl)) #f)) (or (= 0 (tbl-ref->number total 0 1)) (begin (format #t "Failed refnum ~g isn't 0~%" (tbl-ref->number total 0 1)) #f)) ; total out=0
(or (= 4 (tbl-column-count tbl)) (begin (format #t "Failed column count ~d isn't 4~%" (tbl-column-count tbl)) #f)))) (or (= 3 (tbl-row-count tbl)) (begin (format #t "Failed row count ~g isn't 3~%" (tbl-row-count tbl)) #f))
(or (= 4 (tbl-column-count tbl)) (begin (format #t "Failed column count ~g isn't 4~%" (tbl-column-count tbl)) #f))))
) )
) )
) )
) )
)
;; Test two transactions from two different assets to expense in two different days ;; Test two transactions from two different assets to expense in two different days
(define (test-out-txn) (define (test-out-txn)
@ -151,22 +153,22 @@
date-1 date-1
bank-account bank-account
income-account income-account
(gnc:make-gnc-numeric 100 1)) ; large in txn to avoid negative net (hard to parse) 100/1) ; large in txn to avoid negative net (hard to parse)
(env-create-transaction env (env-create-transaction env
date-1 date-1
expense-account expense-account
bank-account bank-account
(gnc:make-gnc-numeric 1 1)) 1/1)
(env-create-transaction env (env-create-transaction env
date-2 date-2
wallet-account wallet-account
income-account income-account
(gnc:make-gnc-numeric 100 1)) ; large in txn to avoid negative net (hard to parse) 100/1) ; large in txn to avoid negative net (hard to parse)
(env-create-transaction env (env-create-transaction env
date-2 date-2
expense-account expense-account
wallet-account wallet-account
(gnc:make-gnc-numeric 5 1)) 5/1)
(begin (begin
(set-option report gnc:pagename-display "Show Table" #t) (set-option report gnc:pagename-display "Show Table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
@ -234,17 +236,17 @@
date-1 date-1
bank-account bank-account
income-account income-account
(gnc:make-gnc-numeric 1 1)) 1/1)
(env-create-transaction env (env-create-transaction env
date-1 date-1
bank-account bank-account
wallet-account wallet-account
(gnc:make-gnc-numeric 20 1)) ; this transaction should not be counted 20/1) ; this transaction should not be counted
(env-create-transaction env (env-create-transaction env
date-2 date-2
wallet-account wallet-account
income-account income-account
(gnc:make-gnc-numeric 5 1)) 5/1)
(begin (begin
(set-option report gnc:pagename-display "Show Table" #t) (set-option report gnc:pagename-display "Show Table" #t)

79
gnucash/report/standard-reports/test/test-generic-net-barchart.scm
View File

@ -82,7 +82,7 @@
(gnc:get-start-this-month) (gnc:get-start-this-month)
my-income-account my-income-account
my-asset-account my-asset-account
(gnc:make-gnc-numeric -1 1)) -1/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (set-option report gnc:pagename-general "Start Date"
@ -106,11 +106,13 @@
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))) result))))
(and (= 1 (tbl-ref->number tbl 0 1)) (or (and (= 1 (tbl-ref->number tbl 0 1))
(= 0 (tbl-ref->number tbl 0 2)) (= 0 (tbl-ref->number tbl 0 2))
(= 1 (tbl-ref->number tbl 0 3)) (= 1 (tbl-ref->number tbl 0 3))
(= 1 (tbl-row-count tbl)) (= 1 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl))))))))) (= 4 (tbl-column-count tbl)))
(begin (format #t "Single-txn test ~a failed~%" uuid) #f))
))))))
(define (two-txn-test uuid) (define (two-txn-test uuid)
@ -133,12 +135,12 @@
date-1 date-1
my-income-account my-income-account
my-asset-account my-asset-account
(gnc:make-gnc-numeric -1 1)) -1/1)
(env-create-transaction env (env-create-transaction env
date-2 date-2
my-income-account my-income-account
my-asset-account my-asset-account
(gnc:make-gnc-numeric -5 1)) -5/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
@ -160,15 +162,24 @@
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))) result))))
(and (every (lambda (row) (or (and (every (lambda (row)
(and (equal? (second row) (fourth row)) (and (or (equal? (second row) (fourth row))
(= 0 (string->number (car (third row)))))) (begin (format "Second Element ~g != fourth element ~g~%" (second row) (fourth row)) #f))
(or (= 0 (string->number (car (third row))))
(begin (format "third row element ~a not 0~%" (car (third row))) #f))))
tbl) tbl)
(= 0 (tbl-ref->number tbl 0 1)) (or (= 0 (tbl-ref->number tbl 0 1))
(= 1 (tbl-ref->number tbl 1 1)) (begin (format #t "Item 1 failed: ~g not 0~%" (tbl-ref->number tbl 0 1)) #f))
(= 6 (tbl-ref->number tbl 2 1)) (or (= 1 (tbl-ref->number tbl 1 1))
(= 3 (tbl-row-count tbl)) (begin (format #t "Item 1 failed: ~g not 1~%" (tbl-ref->number tbl 1 1)) #f))
(= 4 (tbl-column-count tbl))))))))) (or (= 6 (tbl-ref->number tbl 2 1))
(begin (format #t "Item 2 failed: ~g not 6~%" (tbl-ref->number tbl 2 1)) #f))
(or (= 3 (tbl-row-count tbl))
(begin (format #t "Item 3 failed: ~g not 3~%" (tbl-row-count tbl)) #f))
(or (= 4 (tbl-column-count tbl))
(begin (format #t "Item 4 failed: ~g not 4~%" (tbl-column-count tbl)) #f)))
(begin (format #t "Two-txn test ~a failed~%" uuid) #f))
))))))
(define (two-txn-test-2 uuid) (define (two-txn-test-2 uuid)
@ -189,10 +200,10 @@
(date-0 (gnc:get-start-this-month)) (date-0 (gnc:get-start-this-month))
(date-1 (gnc:timepair-next-day date-0)) (date-1 (gnc:timepair-next-day date-0))
(date-2 (gnc:timepair-next-day date-1))) (date-2 (gnc:timepair-next-day date-1)))
(env-create-transaction env date-1 my-income-account my-asset-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-income-account my-asset-account -1/1)
(env-create-transaction env date-1 my-expense-account my-liability-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-expense-account my-liability-account -1/1)
(env-create-transaction env date-2 my-income-account my-asset-account (gnc:make-gnc-numeric -5 1)) (env-create-transaction env date-2 my-income-account my-asset-account -5/1)
(env-create-transaction env date-2 my-expense-account my-liability-account (gnc:make-gnc-numeric -5 1)) (env-create-transaction env date-2 my-expense-account my-liability-account -5/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
@ -214,7 +225,7 @@
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))) result))))
(and (every (lambda (row) (or (and (every (lambda (row)
(and (= (string->number (car (fourth row))) (and (= (string->number (car (fourth row)))
(+ (string->number (car (second row))) (+ (string->number (car (second row)))
(string->number (car (third row))))) (string->number (car (third row)))))
@ -225,7 +236,9 @@
(= 1 (tbl-ref->number tbl 1 1)) (= 1 (tbl-ref->number tbl 1 1))
(= 6 (tbl-ref->number tbl 2 1)) (= 6 (tbl-ref->number tbl 2 1))
(= 3 (tbl-row-count tbl)) (= 3 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl))))))))) (= 4 (tbl-column-count tbl)))
(begin (format #t "two-txn test 2 ~a failed~%" uuid) #f))
))))))
(define (two-txn-test-income uuid) (define (two-txn-test-income uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((template (gnc:find-report-template uuid))
@ -245,10 +258,10 @@
(date-0 (gnc:get-start-this-month)) (date-0 (gnc:get-start-this-month))
(date-1 (gnc:timepair-next-day date-0)) (date-1 (gnc:timepair-next-day date-0))
(date-2 (gnc:timepair-next-day date-1))) (date-2 (gnc:timepair-next-day date-1)))
(env-create-transaction env date-1 my-income-account my-asset-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-income-account my-asset-account -1/1)
(env-create-transaction env date-1 my-expense-account my-liability-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-expense-account my-liability-account -1/1)
(env-create-transaction env date-2 my-income-account my-asset-account (gnc:make-gnc-numeric -5 1)) (env-create-transaction env date-2 my-income-account my-asset-account -5/1)
(env-create-transaction env date-2 my-expense-account my-liability-account (gnc:make-gnc-numeric -5 1)) (env-create-transaction env date-2 my-expense-account my-liability-account -5/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
@ -270,7 +283,7 @@
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))) result))))
(and (every (lambda (row) (or (and (every (lambda (row)
(and (= (string->number (car (fourth row))) (and (= (string->number (car (fourth row)))
(+ (string->number (car (second row))) (+ (string->number (car (second row)))
(string->number (car (third row))))) (string->number (car (third row)))))
@ -281,7 +294,9 @@
(= 1 (tbl-ref->number tbl 1 1)) (= 1 (tbl-ref->number tbl 1 1))
(= 5 (tbl-ref->number tbl 2 1)) (= 5 (tbl-ref->number tbl 2 1))
(= 3 (tbl-row-count tbl)) (= 3 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl))))))))) (= 4 (tbl-column-count tbl)))
(begin (format #t "two-txn-income test ~a failed~%" uuid) #f))
))))))
(define (closing-test uuid) (define (closing-test uuid)
@ -306,12 +321,12 @@
(date-2 (gnc:timepair-next-day date-1)) (date-2 (gnc:timepair-next-day date-1))
(date-3 (gnc:timepair-next-day date-2))) (date-3 (gnc:timepair-next-day date-2)))
(env-create-transaction env date-1 my-income-account my-asset-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-income-account my-asset-account -1/1)
(env-create-transaction env date-2 my-income-account my-asset-account (gnc:make-gnc-numeric -2 1)) (env-create-transaction env date-2 my-income-account my-asset-account -2/1)
(env-create-transaction env date-3 my-income-account my-asset-account (gnc:make-gnc-numeric -3 1)) (env-create-transaction env date-3 my-income-account my-asset-account -3/1)
(let ((closing-txn (env-create-transaction env date-2 my-asset-account my-equity-account (let ((closing-txn (env-create-transaction env date-2 my-asset-account my-equity-account
(gnc:make-gnc-numeric 300 1)))) 300/1)))
(xaccTransSetIsClosingTxn closing-txn #t)) (xaccTransSetIsClosingTxn closing-txn #t))
(begin (begin
@ -335,7 +350,7 @@
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))) result))))
(and (every (lambda (row) (or (and (every (lambda (row)
(and (= (string->number (car (fourth row))) (and (= (string->number (car (fourth row)))
(+ (string->number (car (second row))) (+ (string->number (car (second row)))
(string->number (car (third row))))))) (string->number (car (third row)))))))
@ -345,5 +360,7 @@
(= 2 (tbl-ref->number tbl 2 1)) (= 2 (tbl-ref->number tbl 2 1))
(= 3 (tbl-ref->number tbl 3 1)) (= 3 (tbl-ref->number tbl 3 1))
(= 4 (tbl-row-count tbl)) (= 4 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl))))))))) (= 4 (tbl-column-count tbl)))
(begin (format #t "Closing-txn test ~a failed~%" uuid) #f))
))))))

14
gnucash/report/standard-reports/test/test-generic-net-linechart.scm
View File

@ -80,7 +80,7 @@
(gnc:get-start-this-month) (gnc:get-start-this-month)
my-income-account my-income-account
my-asset-account my-asset-account
(gnc:make-gnc-numeric -1 1)) -1/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (set-option report gnc:pagename-general "Start Date"
@ -131,12 +131,12 @@
date-1 date-1
my-income-account my-income-account
my-asset-account my-asset-account
(gnc:make-gnc-numeric -1 1)) -1/1)
(env-create-transaction env (env-create-transaction env
date-2 date-2
my-income-account my-income-account
my-asset-account my-asset-account
(gnc:make-gnc-numeric -5 1)) -5/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
@ -187,10 +187,10 @@
(date-0 (gnc:get-start-this-month)) (date-0 (gnc:get-start-this-month))
(date-1 (gnc:timepair-next-day date-0)) (date-1 (gnc:timepair-next-day date-0))
(date-2 (gnc:timepair-next-day date-1))) (date-2 (gnc:timepair-next-day date-1)))
(env-create-transaction env date-1 my-income-account my-asset-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-income-account my-asset-account -1/1)
(env-create-transaction env date-1 my-expense-account my-liability-account (gnc:make-gnc-numeric -1 1)) (env-create-transaction env date-1 my-expense-account my-liability-account -1/1)
(env-create-transaction env date-2 my-income-account my-asset-account (gnc:make-gnc-numeric -5 1)) (env-create-transaction env date-2 my-income-account my-asset-account -5/1)
(env-create-transaction env date-2 my-expense-account my-liability-account (gnc:make-gnc-numeric -5 1)) (env-create-transaction env date-2 my-expense-account my-liability-account -5/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))

2
gnucash/report/utility-reports/hello-world.scm
View File

@ -409,7 +409,7 @@ new, totally cool report, consult the mailing list %s.")
(_ "The number option formatted as currency is %s.") (_ "The number option formatted as currency is %s.")
(gnc:html-markup-b (gnc:html-markup-b
(xaccPrintAmount (xaccPrintAmount
(gnc:make-gnc-numeric (inexact->exact num-val) 1) (inexact->exact num-val)
(gnc-default-print-info #f))))))) (gnc-default-print-info #f)))))))
;; you can add as many objects as you want. Here's another ;; you can add as many objects as you want. Here's another

2
libgnucash/app-utils/gnc-euro.c
View File

@ -218,7 +218,7 @@ gnc_euro_currency_get_rate (const gnc_commodity *currency)
return gnc_numeric_zero (); return gnc_numeric_zero ();
return double_to_gnc_numeric (result->rate, GNC_DENOM_AUTO, return double_to_gnc_numeric (result->rate, GNC_DENOM_AUTO,
GNC_HOW_DENOM_SIGFIGS(6) | GNC_HOW_RND_ROUND_HALF_UP); GNC_HOW_RND_ROUND_HALF_UP);
} }
/* ------------------------------------------------------ */ /* ------------------------------------------------------ */

4
libgnucash/app-utils/guile-util.c
View File

@ -520,7 +520,7 @@ gnc_split_scm_get_amount(SCM split_scm)
return gnc_numeric_zero (); return gnc_numeric_zero ();
result = scm_call_1(getters.split_scm_amount, split_scm); result = scm_call_1(getters.split_scm_amount, split_scm);
if (!gnc_numeric_p(result)) if (!scm_rational_p(result))
return gnc_numeric_zero (); return gnc_numeric_zero ();
return gnc_scm_to_numeric(result); return gnc_scm_to_numeric(result);
@ -545,7 +545,7 @@ gnc_split_scm_get_value(SCM split_scm)
return gnc_numeric_zero (); return gnc_numeric_zero ();
result = scm_call_1(getters.split_scm_value, split_scm); result = scm_call_1(getters.split_scm_value, split_scm);
if (!gnc_numeric_p(result)) if (!scm_rational_p(result))
return gnc_numeric_zero (); return gnc_numeric_zero ();
return gnc_scm_to_numeric(result); return gnc_scm_to_numeric(result);

3
libgnucash/engine/engine-helpers-guile.h
View File

@ -50,11 +50,8 @@ GSList * gnc_query_scm2path (SCM path_scm);
SCM gnc_query2scm (QofQuery * q); SCM gnc_query2scm (QofQuery * q);
QofQuery * gnc_scm2query (SCM query_scm); QofQuery * gnc_scm2query (SCM query_scm);
int gnc_gh_gint64_p(SCM num);
SCM gnc_numeric_to_scm(gnc_numeric arg); SCM gnc_numeric_to_scm(gnc_numeric arg);
gnc_numeric gnc_scm_to_numeric(SCM arg); gnc_numeric gnc_scm_to_numeric(SCM arg);
int gnc_numeric_p(SCM arg);
gnc_commodity * gnc_scm_to_commodity(SCM scm); gnc_commodity * gnc_scm_to_commodity(SCM scm);
SCM gnc_commodity_to_scm (const gnc_commodity *commodity); SCM gnc_commodity_to_scm (const gnc_commodity *commodity);
SCM gnc_book_to_scm (const QofBook *book); SCM gnc_book_to_scm (const QofBook *book);

97
libgnucash/engine/engine-helpers.c
View File

@ -319,8 +319,8 @@ int
gnc_timepair_p(SCM x) gnc_timepair_p(SCM x)
{ {
return(scm_is_pair(x) && return(scm_is_pair(x) &&
gnc_gh_gint64_p(SCM_CAR(x)) && (scm_is_signed_integer(SCM_CAR(x), INT64_MIN, INT64_MAX) &&
gnc_gh_gint64_p(SCM_CDR(x))); scm_is_signed_integer(SCM_CDR(x), INT64_MIN, INT64_MAX)));
} }
SCM SCM
@ -1110,10 +1110,8 @@ gnc_scm2query_term_query_v1 (SCM query_term_scm)
break; break;
scm = SCM_CAR (query_term_scm); scm = SCM_CAR (query_term_scm);
query_term_scm = SCM_CDR (query_term_scm); query_term_scm = SCM_CDR (query_term_scm);
amount = scm_to_double (scm); val = gnc_numeric_create (scm_to_int64(scm_numerator(scm)),
scm_to_int64(scm_denominator(scm)));
val = double_to_gnc_numeric (amount, GNC_DENOM_AUTO,
GNC_HOW_DENOM_SIGFIGS(6) | GNC_HOW_RND_ROUND_HALF_UP);
if (!g_strcmp0 (pr_type, "pr-price")) if (!g_strcmp0 (pr_type, "pr-price"))
{ {
@ -1997,96 +1995,23 @@ gnc_scm2query (SCM query_scm)
return q; return q;
} }
int
gnc_gh_gint64_p(SCM num)
{
static int initialized = 0;
static SCM maxval;
static SCM minval;
if (!initialized)
{
/* to be super safe, we have to build these manually because
though we know that we have gint64's here, we *don't* know how
to portably specify a 64bit constant to the compiler (i.e. like
0x7FFFFFFFFFFFFFFF). */
gint64 tmp;
tmp = 0x7FFFFFFF;
tmp <<= 32;
tmp |= 0xFFFFFFFF;
maxval = scm_from_int64(tmp);
tmp = 0x80000000;
tmp <<= 32;
minval = scm_from_int64(tmp);
scm_gc_protect_object(maxval);
scm_gc_protect_object(minval);
initialized = 1;
}
return (scm_is_exact(num) &&
(scm_geq_p(num, minval) != SCM_BOOL_F) &&
(scm_leq_p(num, maxval) != SCM_BOOL_F));
}
gnc_numeric gnc_numeric
gnc_scm_to_numeric(SCM gncnum) gnc_scm_to_numeric(SCM gncnum)
{ {
static SCM get_num = SCM_BOOL_F; if (scm_is_signed_integer(scm_numerator(gncnum), INT64_MIN, INT64_MAX) &&
static SCM get_denom = SCM_BOOL_F; scm_is_signed_integer(scm_denominator(gncnum), INT64_MIN, INT64_MAX))
return gnc_numeric_create(scm_to_int64(scm_numerator(gncnum)),
if (get_num == SCM_BOOL_F) scm_to_int64(scm_denominator(gncnum)));
{ return gnc_numeric_create(0, GNC_ERROR_OVERFLOW);
get_num = scm_c_eval_string("gnc:gnc-numeric-num");
}
if (get_denom == SCM_BOOL_F)
{
get_denom = scm_c_eval_string("gnc:gnc-numeric-denom");
}
return gnc_numeric_create(scm_to_int64(scm_call_1(get_num, gncnum)),
scm_to_int64(scm_call_1(get_denom, gncnum)));
} }
SCM SCM
gnc_numeric_to_scm(gnc_numeric arg) gnc_numeric_to_scm(gnc_numeric arg)
{ {
static SCM maker = SCM_BOOL_F; return scm_divide(scm_from_int64(arg.num),
scm_from_int64(arg.denom));
if (maker == SCM_BOOL_F)
{
maker = scm_c_eval_string("gnc:make-gnc-numeric");
}
return scm_call_2(maker, scm_from_int64(gnc_numeric_num(arg)),
scm_from_int64(gnc_numeric_denom(arg)));
} }
int
gnc_numeric_p(SCM arg)
{
static SCM type_p = SCM_BOOL_F;
SCM ret = SCM_BOOL_F;
if (type_p == SCM_BOOL_F)
{
type_p = scm_c_eval_string("gnc:gnc-numeric?");
}
ret = scm_call_1(type_p, arg);
if (ret == SCM_BOOL_F)
{
return FALSE;
}
else
{
return TRUE;
}
}
static SCM static SCM
gnc_generic_to_scm(const void *cx, const gchar *type_str) gnc_generic_to_scm(const void *cx, const gchar *type_str)
{ {

6
libgnucash/engine/engine.scm
View File

@ -43,12 +43,6 @@
(export GNC-ERROR-OVERFLOW) (export GNC-ERROR-OVERFLOW)
(export GNC-ERROR-DENOM-DIFF) (export GNC-ERROR-DENOM-DIFF)
(export GNC-ERROR-REMAINDER) (export GNC-ERROR-REMAINDER)
(export <gnc-numeric>)
(export gnc:gnc-numeric?)
(export gnc:make-gnc-numeric)
(export gnc:gnc-numeric-denom)
(export gnc:gnc-numeric-num)
(export gnc:gnc-numeric-denom-reciprocal)
(export <gnc-monetary>) (export <gnc-monetary>)
(export gnc:gnc-monetary?) (export gnc:gnc-monetary?)
(export gnc:make-gnc-monetary) (export gnc:make-gnc-monetary)

22
libgnucash/engine/gnc-numeric.scm
View File

@ -47,26 +47,6 @@
(define GNC-ERROR-DENOM-DIFF -3) (define GNC-ERROR-DENOM-DIFF -3)
(define GNC-ERROR-REMAINDER -4) (define GNC-ERROR-REMAINDER -4)
(define <gnc-numeric>
(make-record-type "<gnc-numeric>"
'(num denom)))
(define gnc:make-gnc-numeric
(record-constructor <gnc-numeric>))
(define gnc:gnc-numeric?
(record-predicate <gnc-numeric>))
(define gnc:gnc-numeric-num
(record-accessor <gnc-numeric> 'num))
(define gnc:gnc-numeric-denom
(record-accessor <gnc-numeric> 'denom))
(define (gnc:gnc-numeric-denom-reciprocal arg)
(- arg))
(define <gnc-monetary> (define <gnc-monetary>
(make-record-type "<gnc-monetary>" (make-record-type "<gnc-monetary>"
@ -76,7 +56,7 @@
(define (gnc:make-gnc-monetary c a) (define (gnc:make-gnc-monetary c a)
;;FIXME: we used to type-check the values, like: ;;FIXME: we used to type-check the values, like:
;; (gw:wcp-is-of-type? <gnc:commodity*> c) ;; (gw:wcp-is-of-type? <gnc:commodity*> c)
(if (and #t (gnc:gnc-numeric? a)) (if (and #t (number? a))
((record-constructor <gnc-monetary>) c a) ((record-constructor <gnc-monetary>) c a)
(warn "wrong arguments for gnc:make-gnc-monetary: " c a))) (warn "wrong arguments for gnc:make-gnc-monetary: " c a)))

18
libgnucash/engine/kvp-scm.cpp
View File

@ -25,22 +25,26 @@ extern "C"
KvpValue * KvpValue *
gnc_scm_to_kvp_value_ptr(SCM val) gnc_scm_to_kvp_value_ptr(SCM val)
{ {
if (scm_is_number(val)) if (scm_is_rational(val))
{ {
/* in guile 1.8 (exact? ) only works on numbers */ if (scm_is_exact_integer(val) &&
if (scm_is_exact (val) && gnc_gh_gint64_p(val)) scm_is_signed_integer(val, INT64_MIN, INT64_MAX))
{ {
return new KvpValue{scm_to_int64(val)}; return new KvpValue{scm_to_int64(val)};
} }
else if (scm_is_exact(val) &&
scm_is_signed_integer(scm_numerator(val),
INT64_MIN, INT64_MAX) &&
scm_is_signed_integer(scm_denominator(val),
INT64_MIN, INT64_MAX))
{
return new KvpValue{gnc_scm_to_numeric(val)};
}
else else
{ {
return new KvpValue{scm_to_double(val)}; return new KvpValue{scm_to_double(val)};
} }
} }
else if (gnc_numeric_p(val))
{
return new KvpValue{gnc_scm_to_numeric(val)};
}
else if (gnc_guid_p(val)) else if (gnc_guid_p(val))
{ {
auto guid = gnc_scm2guid(val); auto guid = gnc_scm2guid(val);

8
libgnucash/engine/test/test-extras.scm
View File

@ -115,7 +115,7 @@
(cons 'sink (make-test-sink)))) (cons 'sink (make-test-sink))))
(define (env-random-amount env n) (define (env-random-amount env n)
(gnc:make-gnc-numeric (env-random env n) 1)) (/ (env-random env n) 1))
(define (env-random env n) (define (env-random env n)
(random n (assoc-ref env 'random))) (random n (assoc-ref env 'random)))
@ -183,9 +183,9 @@
(for-each (lambda (date) (for-each (lambda (date)
(env-create-transaction env date to-account (env-create-transaction env date to-account
from-account from-account
(gnc:make-gnc-numeric (/
(gnc:date-get-month-day (gnc:timepair->date date)) (gnc:date-get-month-day (gnc:timepair->date date))
1))) 1)))
(cdr (reverse dates-this-month))))) (cdr (reverse dates-this-month)))))
(define (env-create-account-structure env account-structure) (define (env-create-account-structure env account-structure)

4
libgnucash/engine/test/test-split.scm
View File

@ -17,8 +17,8 @@
(bank-account (cdr (assoc "Bank" account-alist))) (bank-account (cdr (assoc "Bank" account-alist)))
(expense-account (cdr (assoc "Expenses" account-alist))) (expense-account (cdr (assoc "Expenses" account-alist)))
(wallet-account (cdr (assoc "Wallet" account-alist))) (wallet-account (cdr (assoc "Wallet" account-alist)))
(tx1 (env-create-transaction env today bank-account wallet-account (gnc:make-gnc-numeric 20 1))) (tx1 (env-create-transaction env today bank-account wallet-account 20/1))
(tx2 (env-create-transaction env today bank-account expense-account (gnc:make-gnc-numeric 10 1))) (tx2 (env-create-transaction env today bank-account expense-account 10/1))
(splits-tx1 (xaccTransGetSplitList tx1)) (splits-tx1 (xaccTransGetSplitList tx1))
(splits-tx2 (xaccTransGetSplitList tx2))) (splits-tx2 (xaccTransGetSplitList tx2)))
(and (split-in-list? (first splits-tx1) splits-tx1) (and (split-in-list? (first splits-tx1) splits-tx1)