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

Fixing bug #341589: Apparently, guile 1.8 will actually enforce the rule

Browse Source 
that all datum portions of case-statement clauses be unique.  The syntax:
   'foo expands to a list of two symbols: (quote foo) 
   If both 'foo and 'bar are used, then the "quote" symbol won't be unique.


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@14034 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Chris Shoemaker 2006-05-13 04:52:09 +00:00
parent 6555992b08
commit 3dd0f96c60
7 changed files with 118 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/report/report-system/commodity-utilities.scm
View File

@ -821,14 +821,15 @@
(define (gnc:case-exchange-fn
source-option report-currency to-date-tp)
(case source-option
('weighted-average (gnc:make-exchange-function
((weighted-average) (gnc:make-exchange-function
(gnc:make-exchange-alist
report-currency to-date-tp)))
('pricedb-latest gnc:exchange-by-pricedb-latest)
('pricedb-nearest (lambda (foreign domestic)
((pricedb-latest) gnc:exchange-by-pricedb-latest)
((pricedb-nearest) (lambda (foreign domestic)
(gnc:exchange-by-pricedb-nearest
foreign domestic to-date-tp)))
(else (gnc:warn "gnc:case-exchange-fn: bad price-source value"))))
(else (gnc:warn "gnc:case-exchange-fn: bad price-source value: "
source-option))))
;; Return a ready-to-use function. Which one to use is determined by
;; the value of 'source-option', whose possible values are set in
@ -841,23 +842,24 @@
source-option report-currency commodity-list to-date-tp
start-percent delta-percent)
(case source-option
('weighted-average (let ((pricealist
((weighted-average) (let ((pricealist
(gnc:get-commoditylist-totalavg-prices
commodity-list report-currency to-date-tp
start-percent delta-percent)))
(lambda (foreign domestic date)
(gnc:exchange-by-pricealist-nearest
pricealist foreign domestic date))))
('actual-transactions (let ((pricealist
((actual-transactions) (let ((pricealist
(gnc:get-commoditylist-inst-prices
commodity-list report-currency to-date-tp)))
(lambda (foreign domestic date)
(gnc:exchange-by-pricealist-nearest
pricealist foreign domestic date))))
('pricedb-latest (lambda (foreign domestic date)
((pricedb-latest) (lambda (foreign domestic date)
(gnc:exchange-by-pricedb-latest foreign domestic)))
('pricedb-nearest gnc:exchange-by-pricedb-nearest)
(else (gnc:warn "gnc:case-exchange-time-fn: bad price-source value"))))
((pricedb-nearest) gnc:exchange-by-pricedb-nearest)
(else (gnc:warn "gnc:case-exchange-time-fn: bad price-source value: "
source-option))))

49
src/report/report-system/report-utilities.scm
View File

@ -247,13 +247,13 @@
(set! totalitems 0))))
(lambda (action value) ;;; Dispatch function
(case action
('add (adder value))
('total (gettotal))
('average (getaverage))
('numitems (getnumitems))
('getmax (getmax))
('getmin (getmin))
('reset (reset-all))
((add) (adder value))
((total) (gettotal))
((average) (getaverage))
((numitems) (getnumitems))
((getmax) (getmax))
((getmin) (getmin))
((reset) (reset-all))
(else (gnc:warn "bad stats-collector action: " action)))))))
(define (gnc:make-drcr-collector)
@ -278,11 +278,11 @@
(set! totalitems 0))))
(lambda (action value) ;;; Dispatch function
(case action
('add (adder value))
('debits (getdebits))
('credits (getcredits))
('items (getitems))
('reset (reset-all))
((add) (adder value))
((debits) (getdebits))
((credits) (getcredits))
((items) (getitems))
((reset) (reset-all))
(else (gnc:warn "bad dr-cr-collector action: " action)))))))
;; This is a collector of values -- works similar to the stats-collector but
@ -292,9 +292,9 @@
((value 0))
(lambda (action amount) ;;; Dispatch function
(case action
('add (if (number? amount)
((add) (if (number? amount)
(set! value (+ amount value))))
('total value)
((total) value)
(else (gnc:warn "bad value-collector action: " action))))))
;; Bah. Let's get back to normal data types -- this procedure thingy
;; from above makes every code almost unreadable. First step: replace
@ -311,12 +311,13 @@
((value (gnc:numeric-zero)))
(lambda (action amount) ;;; Dispatch function
(case action
('add (if (gnc:gnc-numeric? amount)
((add) (if (gnc:gnc-numeric? amount)
(set! value (gnc:numeric-add-fixed amount value))
(gnc:warn
"gnc:numeric-collector called with wrong argument: " amount)))
('total value)
((total) value)
(else (gnc:warn "bad gnc:numeric-collector action: " action))))))
;; Replace all 'action function calls by the normal functions below.
(define (gnc:numeric-collector-add collector amount)
(collector 'add amount))
@ -435,16 +436,16 @@
;; Dispatch function
(lambda (action commodity amount)
(case action
('add (add-commodity-value commodity amount))
('merge (add-commodity-clist
((add) (add-commodity-value commodity amount))
((merge) (add-commodity-clist
(gnc:commodity-collector-list commodity)))
('minusmerge (minus-commodity-clist
((minusmerge) (minus-commodity-clist
(gnc:commodity-collector-list commodity)))
('format (process-commodity-list commodity commoditylist))
('reset (set! commoditylist '()))
('getpair (getpair commodity amount))
('getmonetary (getmonetary commodity amount))
('list commoditylist) ; this one is only for internal use
((format) (process-commodity-list commodity commoditylist))
((reset) (set! commoditylist '()))
((getpair) (getpair commodity amount))
((getmonetary) (getmonetary commodity amount))
((list) commoditylist) ; this one is only for internal use
(else (gnc:warn "bad commodity-collector action: " action))))))

92
src/report/standard-reports/advanced-portfolio.scm
View File

@ -204,44 +204,58 @@
(define (basis-builder b-list b-units b-value b-method)
(if (gnc:numeric-positive-p b-units)
(case b-method
('average-basis (if (not (eqv? b-list '()))
(list (cons (gnc:numeric-add b-units (caar b-list) 10000 GNC-RND-ROUND)
(gnc:numeric-div (gnc:numeric-add b-value
(gnc:numeric-mul (caar b-list)
(cdar b-list)
10000 GNC-RND-ROUND)
10000 GNC-RND-ROUND)
(gnc:numeric-add b-units (caar b-list) 10000 GNC-RND-ROUND)
10000 GNC-RND-ROUND)))
(append b-list (list (cons b-units (gnc:numeric-div b-value b-units 10000 GNC-RND-ROUND))))
)
)
(else (append b-list (list (cons b-units (gnc:numeric-div b-value b-units 10000 GNC-RND-ROUND)))))
)
((average-basis)
(if (not (eqv? b-list '()))
(list (cons (gnc:numeric-add b-units
(caar b-list) 10000 GNC-RND-ROUND)
(gnc:numeric-div
(gnc:numeric-add b-value
(gnc:numeric-mul (caar b-list)
(cdar b-list)
10000 GNC-RND-ROUND)
10000 GNC-RND-ROUND)
(gnc:numeric-add b-units
(caar b-list) 10000 GNC-RND-ROUND)
10000 GNC-RND-ROUND)))
(append b-list
(list (cons b-units (gnc:numeric-div
b-value b-units 10000
GNC-RND-ROUND))))))
(else (append b-list
(list (cons b-units (gnc:numeric-div
b-value b-units 10000
GNC-RND-ROUND))))))
(if (not (eqv? b-list '()))
(case b-method
('fifo-basis (if (not (= -1 (gnc:numeric-compare (gnc:numeric-abs b-units) (caar b-list))))
(basis-builder (cdr b-list) (gnc:numeric-add
b-units
(caar b-list) 10000 GNC-RND-ROUND)
b-value b-method)
(append (list (cons (gnc:numeric-add
b-units
(caar b-list) 10000 GNC-RND-ROUND)
(cdar b-list))) (cdr b-list))))
('filo-basis (if (not (= -1 (gnc:numeric-compare (gnc:numeric-abs b-units) (caar (reverse b-list)))))
(basis-builder (reverse (cdr (reverse b-list))) (gnc:numeric-add
b-units
(caar (reverse b-list))
10000 GNC-RND-ROUND)
b-value b-method)
(append (cdr (reverse b-list)) (list (cons (gnc:numeric-add
b-units
(caar (reverse b-list)) 10000 GNC-RND-ROUND)
(cdar (reverse b-list)))))))
('average-basis (list (cons (gnc:numeric-add (caar b-list) b-units 10000 GNC-RND-ROUND)
(cdar b-list))))
)
((fifo-basis)
(if (not (= -1 (gnc:numeric-compare
(gnc:numeric-abs b-units) (caar b-list))))
(basis-builder (cdr b-list) (gnc:numeric-add
b-units
(caar b-list) 10000 GNC-RND-ROUND)
b-value b-method)
(append (list (cons (gnc:numeric-add
b-units
(caar b-list) 10000 GNC-RND-ROUND)
(cdar b-list))) (cdr b-list))))
((filo-basis)
(if (not (= -1 (gnc:numeric-compare
(gnc:numeric-abs b-units) (caar (reverse b-list)))))
(basis-builder (reverse (cdr (reverse b-list)))
(gnc:numeric-add
b-units
(caar (reverse b-list))
10000 GNC-RND-ROUND)
b-value b-method)
(append (cdr (reverse b-list))
(list (cons (gnc:numeric-add
b-units
(caar (reverse b-list)) 10000 GNC-RND-ROUND)
(cdar (reverse b-list)))))))
((average-basis)
(list (cons (gnc:numeric-add
(caar b-list) b-units 10000 GNC-RND-ROUND)
(cdar b-list)))))
'()
)
)
@ -581,14 +595,14 @@
(pricedb (gnc:book-get-pricedb (gnc:get-current-book)))
(price-fn
(case price-source
('pricedb-latest
((pricedb-latest)
(lambda (foreign date)
(gnc:pricedb-lookup-latest-any-currency pricedb foreign)))
('pricedb-nearest
((pricedb-nearest)
(lambda (foreign date)
(gnc:pricedb-lookup-nearest-in-time-any-currency
pricedb foreign (gnc:timepair-canonical-day-time date))))
('pricedb-latest-before
((pricedb-latest-before)
(lambda (foreign date)
(gnc:pricedb-lookup-latest-before-any-currency
pricedb foreign (gnc:timepair-canonical-day-time date))))))

6
src/report/standard-reports/portfolio.scm
View File

@ -196,14 +196,14 @@
(exchange-fn (gnc:case-exchange-fn price-source currency to-date))
(price-fn
(case price-source
('weighted-average
((weighted-average)
(let ((pricealist
(gnc:get-commoditylist-totalavg-prices
commodity-list currency to-date 0 0)))
(lambda (foreign date)
(cons #f (gnc:pricealist-lookup-nearest-in-time
pricealist foreign date)))))
('pricedb-latest
((pricedb-latest)
(lambda (foreign date)
(let ((price
(gnc:pricedb-lookup-latest-any-currency
@ -212,7 +212,7 @@
(let ((v (gnc:price-get-value (car price))))
(cons (car price) v))
(cons #f (gnc:numeric-zero))))))
('pricedb-nearest
((pricedb-nearest)
(lambda (foreign date)
(let ((price
(gnc:pricedb-lookup-nearest-in-time-any-currency

38
src/report/standard-reports/price-scatter.scm
View File

@ -192,22 +192,22 @@
(gnc:html-scatter-set-height! chart height)
(gnc:html-scatter-set-marker! chart
(case marker
('circle "circle")
('cross "cross")
('square "square")
('asterisk "asterisk")
('filledcircle "filled circle")
('filledsquare "filled square")))
((circle) "circle")
((cross) "cross")
((square) "square")
((asterisk) "asterisk")
((filledcircle) "filled circle")
((filledsquare) "filled square")))
(gnc:html-scatter-set-markercolor! chart mcolor)
(gnc:html-scatter-set-y-axis-label!
chart (gnc:commodity-get-mnemonic report-currency))
(gnc:html-scatter-set-x-axis-label!
chart (case interval
('DayDelta (N_ "Days"))
('WeekDelta (N_ "Weeks"))
('TwoWeekDelta (N_ "Double-Weeks"))
('MonthDelta (N_ "Months"))
('YearDelta (N_ "Years"))))
((DayDelta) (N_ "Days"))
((WeekDelta) (N_ "Weeks"))
((TwoWeekDelta) (N_ "Double-Weeks"))
((MonthDelta) (N_ "Months"))
((YearDelta) (N_ "Years"))))
(if
(not (gnc:commodity-equiv? report-currency price-commodity))
@ -216,15 +216,15 @@
(set!
data
(case price-source
('actual-transactions
((actual-transactions)
(gnc:get-commodity-inst-prices
currency-accounts to-date-tp
price-commodity report-currency))
('weighted-average
((weighted-average)
(gnc:get-commodity-totalavg-prices
currency-accounts to-date-tp
price-commodity report-currency))
('pricedb
((pricedb)
(map (lambda (p)
(list (gnc:price-get-time p)
(gnc:price-get-value p)))
@ -264,11 +264,11 @@
;; scaling thing is totally bogus as well,
;; so this doesn't matter too much.
(case interval
('DayDelta 86400)
('WeekDelta 604800)
('TwoWeekDelta 1209600)
('MonthDelta 2628000)
('YearDelta 31536000)))
((DayDelta) 86400)
((WeekDelta) 604800)
((TwoWeekDelta) 1209600)
((MonthDelta) 2628000)
((YearDelta) 31536000)))
(second x)))
data))

4
src/report/standard-reports/transaction.scm
View File

@ -1293,9 +1293,9 @@ Credit Card, and Income accounts")))))
#t)
(case void-status
(('non-void-only)
((non-void-only)
(gnc:query-set-match-non-voids-only! query (gnc:get-current-book)))
(('void-only)
((void-only)
(gnc:query-set-match-voids-only! query (gnc:get-current-book)))
(else #f))

10
src/scm/gnumeric/table-utils.scm
View File

@ -17,11 +17,11 @@
(set! count 0))))
(lambda (action value . rowdata)
(case action
('add (adder value rowdata))
('total (gettotal))
('getcount (getcount))
('getrows (getrows))
('reset (resetall)))))))
((add) (adder value rowdata))
((total) (gettotal))
((getcount) (getcount))
((getrows) (getrows))
((reset) (resetall)))))))
;;; Here's how it looks:
; > (define a (make-table-collector))