GnuCash Daily Diff
Dave Peticolas
peticolas@linas.org
Wed, 16 May 2001 08:02:56 -0500 (CDT)
Index: gnucash/ChangeLog
diff -u gnucash/ChangeLog:1.473 gnucash/ChangeLog:1.482
--- gnucash/ChangeLog:1.473 Tue May 15 04:39:11 2001
+++ gnucash/ChangeLog Wed May 16 04:33:28 2001
@@ -1,3 +1,154 @@
+2001-05-16 Dave Peticolas <dave@krondo.com>
+
+ * src/doc/design/gnucash-design.texinfo: update docs
+
+ * src/doc/design/engine.texinfo: update docs
+
+ * src/engine/Account.c (xaccCloneAccountSimple): remove
+ redundant initialization
+ (xaccAccountGetSlots): handle NULL
+
+ * src/engine/Account.h: fix docs
+
+ * src/engine/AccountP.h: fix spelling errors in comments
+
+2001-05-16 Robert Graham Merkel <rgmerk@mira.net>
+
+ * src/scm/html-utilities.scm ((gnc:html-make-empty-data-warning)):
+ update message.
+
+ * src/scm/{gnucash.sgml, xacc-account-summary.sgml,
+ xacc-asset-liability-barcharts.sgml, xacc-reports.sgml}: more new
+ material.
+
+ * src/scm/xacc-stock-price-report.sgml: new file.
+
+2001-05-15 Christian Stimming <stimming@tuhh.de>
+
+ * src/scm/commodity-utilities.scm: added another case to
+ gnc:case-exchange-time-fn. Needs more work.
+ (gnc:exchange-by-euro): new function. Added this function to all
+ other exchange function so that exchange of EURO currencies works
+ automagically in some more places. Doesn't work often enough,
+ though. Darn.
+
+ * src/scm/report/price-scatter.scm: Catch all cases that would
+ cause Guppi's scatterplot to barf.
+
+2001-05-15 Rob Browning <rlb@cs.utexas.edu>
+
+ * doc/sgml/C/Makefile.am (GNUCASH_SGML_FILES): remove entries
+ listing missing files -- build was broken.
+
+ * src/scm/report/transaction-report.scm (addto!): make a
+ let-syntax since you apparently can't define-syntax before other
+ defines in a nested let.
+
+ * src/scm/report/register.scm (addto!): make a let-syntax since
+ you apparently can't define-syntax before other defines in a
+ nested let.
+
+ * src/scm/gnumeric/gnumeric-utilities.scm: use srfis as modules.
+
+ * src/scm/srfi/: moved to lib/srfi.
+
+ * src/scm/srfi/.cvsignore: moved to lib/srfi.
+
+ * src/scm/srfi/Makefile.am: moved to lib/srfi.
+
+ * src/scm/srfi/README: moved to lib/srfi.
+
+ * src/scm/srfi/srfi-1.r5rs.scm: merged to lib/srfi/srfi-1.scm.
+
+ * src/scm/srfi/srfi-1.unclear.scm: merged to lib/srfi/srfi-1.scm.
+
+ * src/scm/srfi/srfi-19.scm: moved to lib/srfi.
+
+ * src/scm/srfi/srfi-8.guile.scm: merged to lib/srfi/srfi-8.scm.
+
+ * src/scm/srfi/srfi-8.scm: merged to lib/srfi/srfi-8.scm.
+
+ * src/scm/utilities.scm (flatten): improved via grib's version.
+
+ * src/scm/text-export.scm: use srfis as modules.
+
+ * src/scm/main.scm: use srfis as modules.
+
+ * src/scm/date-utilities.scm: use srfi-19 as a module.
+
+ * src/scm/Makefile.am (SUBDIRS): remove srfi.
+
+ * src/gnome/window-main.c
+ (gnc_main_window_restore): fix prototype (const-wise).
+
+ * src/gnome/window-main.h
+ (gnc_main_window_restore): fix prototype (const-wise).
+
+ * Makefile.am (TAGS): add a msg to suggest --enable-tags.
+
+ * lib/Makefile.am (SUBDIRS): add srfi.
+
+ * configure.in: add lib/srfi/Makefile to AC_OUTPUT.
+
+ * lib/srfi/srfi-2.scm: new file.
+
+ * lib/srfi/srfi-9.scm: new file.
+
+ * lib/srfi/srfi-11.scm: new file.
+
+ * lib/srfi/srfi-8.scm: moved from src/scm/srfi/.
+
+ * lib/srfi/srfi-19.scm: moved from src/scm/srfi.
+
+ * lib/srfi/README: moved from src/scm/srfi/.
+
+ * lib/srfi/srfi-1.scm: moved from src/scm/srfi/.
+
+2001-05-15 James LewisMoss <jimdres@mindspring.com>
+
+ * src/test/test-xml-account.c (node_and_account_equal): add equals
+ tests for currency and security scu.
+
+ * src/test/gnc-test-stuff.c (equals_node_val_vs_int): new func.
+
+ * src/engine/gnc-account-xml-v2.c (gnc_account_end_handler):
+ reorder some things: cleanup.
+
+ * src/test/test-xml-account.c (node_and_account_equal): return
+ strduped strings now.
+ (test_account): make sure to free string.
+ (test_real_account): free string.
+
+ * src/engine/gnc-account-xml-v2.c (gnc_account_dom_tree_create):
+ use new func.
+
+ * src/engine/gnc-commodity-xml-v2.c
+ (gnc_commodity_dom_tree_create): use new func.
+
+ * src/engine/sixtp-dom-generators.c (int_to_dom_tree):new func.
+
+2001-05-14 James LewisMoss <jimdres@mindspring.com>
+
+ * src/engine/gnc-account-xml-v2.c (gnc_account_dom_tree_create):
+ add currency and security scus.
+ (account_currency_scu_handler): new func.
+ (account_security_scu_handler): new func.
+ Add refs to new funcs to parsing structure.
+
+2001-05-15 Robert Graham Merkel <rgmerk@mira.net>
+
+ * doc/sgml/C/xacc-reports.sgml, xacc-about.sgml,
+ xacc-dateinput.sgml, xacc-account-summary.sgml,
+ xacc-balancesheet.sgml, xacc-common-report-options.sgml
+ xacc-mainwin.sgml: update documentation for new features.
+
+ * doc/sgml/C/xacc-asset-liability-barcharts.sgml: new file.
+ Placeholder at this stage.
+
+ * doc/sgml/C/xacc-asset-liability-piecharts.sgml, xacc-gnome-mdi.sgml,
+ xacc-income-expense-barcharts.sgml, xacc-income-expense-piecharts.sgml,
+ xacc-multicolumn-view-reports.sgml: ditto.
+
2001-05-15 Dave Peticolas <dave@krondo.com>
* src/doc/design/engine.texinfo: update docs
Index: gnucash/Makefile.am
diff -u gnucash/Makefile.am:1.24 gnucash/Makefile.am:1.25
--- gnucash/Makefile.am:1.24 Tue May 1 15:57:58 2001
+++ gnucash/Makefile.am Tue May 15 10:52:59 2001
@@ -75,6 +75,11 @@
fi
${MAKE} TAGS.stamp
-.PHONY: TAGS
+else
+
+TAGS:
+ @echo "You must ./configure with --enable-etags to use TAGS."
endif
+
+.PHONY: TAGS
Index: gnucash/configure.in
diff -u gnucash/configure.in:1.184 gnucash/configure.in:1.185
--- gnucash/configure.in:1.184 Sun May 13 17:42:40 2001
+++ gnucash/configure.in Tue May 15 10:50:35 2001
@@ -590,6 +590,7 @@
intl/Makefile
lib/Makefile
lib/guile-www/Makefile
+ lib/srfi/Makefile
macros/Makefile
po/Makefile.in
po/Makefile
Index: gnucash/accounts/C/acctchrt_carloan.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_carloan.gnucash-xea:1.2 gnucash/accounts/C/acctchrt_carloan.gnucash-xea:1.3
--- gnucash/accounts/C/acctchrt_carloan.gnucash-xea:1.2 Wed May 9 20:59:22 2001
+++ gnucash/accounts/C/acctchrt_carloan.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for car loan and associated interest
- (car loan, car loan interest)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ a car loan (car loan, car loan interest).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Liabilities</act:name>
<act:id type="new">33a326fe16ae360f777a94b3f5bdfbdc</act:id>
Index: gnucash/accounts/C/acctchrt_cdmoneymkt.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_cdmoneymkt.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_cdmoneymkt.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_cdmoneymkt.gnucash-xea:1.1 Wed Apr 18 16:25:55 2001
+++ gnucash/accounts/C/acctchrt_cdmoneymkt.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,12 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for CD and money market investments
- (CD, CD interest, money market, money market interest)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ CDs or money market accounts (CD, CD interest, money market, money
+ market interest).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
<act:id type="new">7b1a39efc6234d1db148baa722c9471e</act:id>
Index: gnucash/accounts/C/acctchrt_childcare.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_childcare.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_childcare.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_childcare.gnucash-xea:1.1 Wed Apr 18 16:25:56 2001
+++ gnucash/accounts/C/acctchrt_childcare.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
An account for tracking childcare costs
- (childcare)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ childcare expenses.
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Expenses</act:name>
<act:id type="new">ee8238ee2c2ce590160761df09b99b72</act:id>
Index: gnucash/accounts/C/acctchrt_common.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_common.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_common.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_common.gnucash-xea:1.1 Wed Apr 18 16:25:57 2001
+++ gnucash/accounts/C/acctchrt_common.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,12 @@
</gnc-act:title>
<gnc-act:short-description>
A basic set of accounts most commonly used
- (checking, savings, cash, credit card, income, common expenses)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ Most users will want to select this set of accounts. It includes
+ most commonly used accounts (checking, savings, cash, credit card,
+ income, common expenses).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
<act:id type="new">98f262dfab9a2b99ac42919dcf58d304</act:id>
Index: gnucash/accounts/C/acctchrt_currency.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_currency.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_currency.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_currency.gnucash-xea:1.1 Wed Apr 18 16:25:57 2001
+++ gnucash/accounts/C/acctchrt_currency.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,13 @@
</gnc-act:title>
<gnc-act:short-description>
Account for trading and converting a foreign currency
- (note: account currently in DEM; edit account to change currency)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you convert
+ foreign currencies.
+
+ Note: account currently in DEM; edit account to change currency.
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
<act:id type="new">b3c65be1c5d163746ddc0c506f3f4619</act:id>
Index: gnucash/accounts/C/acctchrt_eduloan.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_eduloan.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_eduloan.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_eduloan.gnucash-xea:1.1 Wed Apr 18 16:25:58 2001
+++ gnucash/accounts/C/acctchrt_eduloan.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for school loan and associated interest
- (education loan, education loan interest)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ an educational loan (education loan, education loan interest).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Liabilities</act:name>
<act:id type="new">4e7e8e39487ad4aba0b62c2232c577c5</act:id>
Index: gnucash/accounts/C/acctchrt_fixedassets.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_fixedassets.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_fixedassets.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_fixedassets.gnucash-xea:1.1 Wed Apr 18 16:25:58 2001
+++ gnucash/accounts/C/acctchrt_fixedassets.gnucash-xea Tue May 15 14:11:27 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for tracking large fixed assets
- (house, vehicle, other assets)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ large fixed assets (house, vehicle, vacation home, other assets).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
<act:id type="new">64b6276c060185131cecbd1ac6218440</act:id>
Index: gnucash/accounts/C/acctchrt_homeloan.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_homeloan.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_homeloan.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_homeloan.gnucash-xea:1.1 Wed Apr 18 16:25:59 2001
+++ gnucash/accounts/C/acctchrt_homeloan.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for home loan and associated interest
- (mortgage loan, mortgage interest)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ a home loan (mortgage loan, mortgage interest).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Liabilities</act:name>
<act:id type="new">6664763bd1ea41462cba5ef856d9c00c</act:id>
Index: gnucash/accounts/C/acctchrt_homeown.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_homeown.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_homeown.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_homeown.gnucash-xea:1.1 Wed Apr 18 16:25:59 2001
+++ gnucash/accounts/C/acctchrt_homeown.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,12 @@
</gnc-act:title>
<gnc-act:short-description>
Expenses associated with owning a home
- (insurance, taxes, home repair)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you own a home.
+ This set provides a group of accounts to track home expenses
+ (insurance, taxes, home repair).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Expenses</act:name>
<act:id type="new">84732f5fdd27b6463d75bf958e3a4b06</act:id>
Index: gnucash/accounts/C/acctchrt_otherloan.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_otherloan.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_otherloan.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_otherloan.gnucash-xea:1.1 Wed Apr 18 16:25:59 2001
+++ gnucash/accounts/C/acctchrt_otherloan.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for tracking other loans and associated interest
- (other loan, other loan interest)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ something other than a home loan (other loan, other loan interest).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Liabilities</act:name>
<act:id type="new">8ec79e80d9abf58d78ce3129d3fe3365</act:id>
Index: gnucash/accounts/C/acctchrt_renter.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_renter.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_renter.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_renter.gnucash-xea:1.1 Wed Apr 18 16:25:59 2001
+++ gnucash/accounts/C/acctchrt_renter.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Expenses associated with renting a home
- (rent, renter's insurance)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you rent a home
+ or apartment (rent, renter's insurance).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Expenses</act:name>
<act:id type="new">9a2b4520f113372f4e576f5b6dc129c6</act:id>
Index: gnucash/accounts/C/acctchrt_retiremt.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_retiremt.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_retiremt.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_retiremt.gnucash-xea:1.1 Wed Apr 18 16:25:59 2001
+++ gnucash/accounts/C/acctchrt_retiremt.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Retirement account with related investment subaccounts
- (stock, bond, mutual fund, index fund)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ retirement accounts (stock, bond, mutual fund, index fund).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
<act:id type="new">e67ef2c52a4eaf3b9d37d317848a5812</act:id>
Index: gnucash/accounts/C/acctchrt_spouseinc.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_spouseinc.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_spouseinc.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_spouseinc.gnucash-xea:1.1 Wed Apr 18 16:25:59 2001
+++ gnucash/accounts/C/acctchrt_spouseinc.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,11 @@
</gnc-act:title>
<gnc-act:short-description>
Accounts for tracking spouse's income separately
- (salary(spouse), taxes (spouse))
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ a working spouse (salary(spouse), taxes (spouse)).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Income</act:name>
<act:id type="new">b4fadf6188d7f1ae7e7aa4fa27f5cc95</act:id>
Index: gnucash/accounts/C/acctchrt_spouseretire.gnucash-xea
diff -u gnucash/accounts/C/acctchrt_spouseretire.gnucash-xea:1.1 gnucash/accounts/C/acctchrt_spouseretire.gnucash-xea:1.2
--- gnucash/accounts/C/acctchrt_spouseretire.gnucash-xea:1.1 Wed Apr 18 16:26:00 2001
+++ gnucash/accounts/C/acctchrt_spouseretire.gnucash-xea Tue May 15 14:11:28 2001
@@ -5,8 +5,12 @@
</gnc-act:title>
<gnc-act:short-description>
Retirement account with related investment accounts for spouse
- (stock, bond, mutual fund, index fund)
</gnc-act:short-description>
+ <gnc-act:long-description>
+ You would want to select these set of accounts if you have
+ investments in a spouse's name(stock, bond, mutual fund, index
+ fund, interest, dividend).
+ </gnc-act:long-description>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
<act:id type="new">96d9b17add59eb4c7edec7ed241af755</act:id>
Index: gnucash/doc/sgml/C/Makefile.am
diff -u gnucash/doc/sgml/C/Makefile.am:1.16 gnucash/doc/sgml/C/Makefile.am:1.20
--- gnucash/doc/sgml/C/Makefile.am:1.16 Sun Apr 29 20:58:13 2001
+++ gnucash/doc/sgml/C/Makefile.am Wed May 16 02:52:45 2001
@@ -8,8 +8,11 @@
xacc-about.sgml \
xacc-accountedit.sgml \
xacc-acctypes.sgml \
+ xacc-account-summary.sgml \
xacc-adjbalwin.sgml \
xacc-apar.sgml \
+ xacc-asset-liability-barcharts.sgml \
+ xacc-asset-liability-piecharts.sgml \
xacc-balancereport.sgml \
xacc-balancesheet.sgml \
xacc-chartofaccts.sgml \
@@ -20,10 +23,15 @@
xacc-dochack.sgml \
xacc-doubleentry.sgml \
xacc-euro.sgml \
+ xacc-gnome-mdi.sgml \
xacc-gpl.sgml \
xacc-incomeexpense.sgml \
+ xacc-income-expense-barcharts.sgml \
+ xacc-income-expense-piecharts.sgml \
xacc-locatingtxns.sgml \
xacc-mainwin.sgml \
+ xacc-multicolumn-view-reports.sgml \
+ xacc-net-worth-barchart.sgml \
xacc-newacctwin.sgml \
xacc-pnl.sgml \
xacc-portfolio-report.sgml \
@@ -35,7 +43,10 @@
xacc-recnwin.sgml \
xacc-regwin-kbd.sgml \
xacc-regwin.sgml \
+ xacc-repdev.sgml \
xacc-reports.sgml \
+ xacc-scheme.sgml \
+ xacc-stock-price-report.sgml \
xacc-tax-report.sgml \
xacc-ticker.sgml \
xacc-trans-report.sgml \
Index: gnucash/doc/sgml/C/gnucash.sgml
diff -u gnucash/doc/sgml/C/gnucash.sgml:1.9 gnucash/doc/sgml/C/gnucash.sgml:1.12
--- gnucash/doc/sgml/C/gnucash.sgml:1.9 Sun Apr 29 20:58:13 2001
+++ gnucash/doc/sgml/C/gnucash.sgml Wed May 16 02:52:45 2001
@@ -4,8 +4,11 @@
<!entity xaccacctypes system "xacc-acctypes.sgml">
<!entity xaccnewacctwin system "xacc-newacctwin.sgml">
<!entity xaccadjbalwin system "xacc-adjbalwin.sgml">
+<!entity xaccassetbarcharts system "xacc-asset-liability-barcharts.sgml">
+<!entity xaccassetpiecharts system "xacc-asset-liability-piecharts.sgml">
<!entity xaccapar system "xacc-apar.sgml">
<!entity xacccommodity system "xacc-commodity.sgml">
+<!entity xacccommonreportoptions system "xacc-common-report-options.sgml">
<!entity xaccdepreciation system "xacc-depreciation.sgml">
<!entity xaccbalancereport system "xacc-balancereport.sgml">
<!entity xaccbalancesheet system "xacc-balancesheet.sgml">
@@ -13,12 +16,17 @@
<!entity xaccdoubleentry system "xacc-doubleentry.sgml">
<!entity xacceuro system "xacc-euro.sgml">
<!entity xaccdateinput system "xacc-dateinput.sgml">
+<!entity xaccgnomemdi system "xacc-gnome-mdi.sgml">
<!entity xaccincomeexpense system "xacc-incomeexpense.sgml">
+<!entity xaccincomeexpensebarcharts system "xacc-income-expense-barcharts.sgml">
+<!entity xaccincomeexpensepiecharts system "xacc-income-expense-piecharts.sgml">
<!entity xacclocatingtxns system "xacc-locatingtxns.sgml">
+<!entity xaccmulticolumnviewreports system "xacc-multicolumn-view-reports.sgml">
<!entity xaccpreferences system "xacc-preferences.sgml">
<!entity xaccchartofaccts system "xacc-chartofaccts.sgml">
<!entity xaccuserdocs system "xacc-userdocs.sgml">
<!entity xaccmainwin system "xacc-mainwin.sgml">
+<!entity xaccnetworthbarchart system "xacc-net-worth-barchart.sgml">
<!entity xaccpnl system "xacc-pnl.sgml">
<!entity xaccportfolioreport system "xacc-portfolio-report.sgml">
<!entity xaccprintcheck system "xacc-print-check.sgml">
@@ -30,6 +38,7 @@
<!entity xaccregwinkbd system "xacc-regwin-kbd.sgml">
<!entity xaccreports system "xacc-reports.sgml">
<!entity xaccrepdev system "xacc-repdev.sgml">
+<!entity xaccstockpricereport system "xacc-stock-price-report.sgml">
<!entity xaccticker system "xacc-ticker.sgml">
<!entity xacctaxreport system "xacc-tax-report.sgml">
<!entity xacctransreport system "xacc-trans-report.sgml">
@@ -42,13 +51,14 @@
<!entity xaccgpl system "xacc-gpl.sgml">
<!entity bofamym system "bofa-mym.sgml">
]>
-
<BOOK ID="index">
<TITLE>GnuCash User Manual</TITLE>
&xaccabout;
&xaccaccountedit;
&xaccacctypes;
+&xaccassetbarcharts;
+&xaccassetpiecharts;
&xaccnewacctwin;
&xaccadjbalwin;
&xaccapar;
@@ -56,16 +66,22 @@
&xaccbalancereport;
&xaccbalancesheet;
&xacccommodity;
+&xacccommonreportoptions;
&xacccurrencyhandling;
&xaccdoubleentry;
&xacceuro;
&xaccdateinput;
+&xaccgnomemdi;
&xaccincomeexpense;
+&xaccincomeexpensebarcharts;
+&xaccincomeexpensepiecharts;
&xacclocatingtxns;
&xaccpreferences;
&xaccchartofaccts;
&xaccuserdocs;
&xaccmainwin;
+&xaccmulticolumnviewreports;
+&xaccnetworthbarchart;
&xaccpnl;
&xaccportfolioreport;
&xaccprintcheck;
@@ -84,6 +100,7 @@
&xacctxfexport;
&xaccdochack;
&xaccscheme;
+&xaccstockpricereport;
&xaccrepdev;
&xaccy2k;
&xaccgpl;
Index: gnucash/doc/sgml/C/xacc-about.sgml
diff -u gnucash/doc/sgml/C/xacc-about.sgml:1.37 gnucash/doc/sgml/C/xacc-about.sgml:1.38
--- gnucash/doc/sgml/C/xacc-about.sgml:1.37 Fri May 4 03:16:35 2001
+++ gnucash/doc/sgml/C/xacc-about.sgml Tue May 15 07:22:05 2001
@@ -79,10 +79,27 @@
</listitem>
<listitem>
-<para><emphasis><link linkend="xacc-reports">Reports</link>.</emphasis> Display
- or output as HTML Balance, Transaction, and Profit/Loss
- reports, as well as graphical account balance tracking.
+<para><emphasis>Gnome MDI Interface</emphasis></para>
+<para>Have multiple views of your financial data, arranged how you want
+them, in one or more windows that stay around through GnuCash sessions.
+</para>
+</listitem>
+
+<listitem>
+<para><emphasis><link linkend="xacc-reports">Reports</link>.</emphasis> Display,
+export as HTML, or print a variety of reports, including Balance Sheet, Account
+Summary, Profit and Loss, Stock Portfolios, and Transaction Reports. Reports
+are saved from session to session, and rolling reports are possible with
+relative dates. GnuCash also supports a variety of customizable, printable,
+bar and pie charts.
</para>
+</listitem>
+
+<listitem>
+<para><emphasis>Gnome MDI Interface</emphasis></para>
+<para>Have multiple views of your financial data, arranged how you want
+them, in one or more windows that stay around through GnuCash sessions.
+</para>
</listitem>
</itemizedlist>
Index: gnucash/doc/sgml/C/xacc-account-summary.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-account-summary.sgml:1.2
--- /dev/null Wed May 16 08:01:30 2001
+++ gnucash/doc/sgml/C/xacc-account-summary.sgml Wed May 16 02:52:45 2001
@@ -0,0 +1,57 @@
+<article id="xacc-account-summary-report">
+<artheader>
+<title>Account Summary Report</title>
+</artheader>
+<sect1>
+<title>Account Summary Report</title>
+<para> <inlinemediaobject>
+<imageobject>
+<imagedata fileref="image/report-folio.png">
+</imageobject>
+</inlinemediaobject>
+</para>
+<para>This report is useful for giving an overview
+of a group of accounts. Note that there are
+balance-sheet and profit-and-loss reports available
+that provide more comprehensive totals for those
+purposes.
+
+ </para>
+<para>Options supported by this report include the following:
+<itemizedlist>
+<listitem><para><emphasis><link linkend="xacc-options-accounts">
+ Accounts</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-include-subaccounts">
+ Include Subaccounts?</emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-depth">
+ Account Display Depth</emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-report-title">
+ Report Title</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-style-sheet">
+ Stylesheet</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-date">
+ Date</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-report-currency">
+ Report Currency</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-price-source">
+ Price Source</link></emphasis></para></listitem>
+<listitem><para>Show Balances for Parent Accounts?</para>
+<para>If this option is selected, the individual balances for
+parent (non-leaf) accounts are shown. Many people do not use
+parent accounts for transactions and thus this balance is not
+usefu.</para>
+<listitem><para>Show subtotals</para>
+<para>Show totals for groups of accounts including a parent and
+all their children, as well as by account type.</para>
+<listitem><para><emphasis>
+<link linkend=xacc-options-show-foreign>Show Foreign Currencies
+</link></emphasis></para></listitem>
+
+</itemizedlist>
+</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-asset-liability-barcharts.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-asset-liability-barcharts.sgml:1.2
--- /dev/null Wed May 16 08:01:30 2001
+++ gnucash/doc/sgml/C/xacc-asset-liability-barcharts.sgml Wed May 16 02:52:45 2001
@@ -0,0 +1,45 @@
+<article id="xacc-asset-liability-barcharts">
+<artheader>
+<title>Asset and Liability Barcharts</title>
+</artheader>
+<sect1>
+<title>Asset and Liability Barcharts</title>
+<para><emphasis>PICTURES NEEDED!!!!</emphasis>
+</para>
+<para>These reports allow you to display home one, some,
+or all of your assets or liabilities change over time.
+If you want a barchart showing an overall picture of
+your net worth, use the <link linkend="xacc-net-worth-barchart">
+ Net Worth Barchart</link> instead.</para>
+
+ <itemizedlist>
+ <listitem><para><emphasis><link linkend="xacc-options-accounts">
+ Accounts</link></emphasis></para>
+ </listitem>
+ <listitem><para><emphasis><link linkend="xacc-options-report-title">
+ Report Title</link></emphasis></para></listitem>
+ <listitem><para><emphasis><link linkend="xacc-options-date">
+ From & To</link></emphasis></para></listitem>
+ <listitem><para><emphasis><link linkend="xacc-options-interval">
+ Step Size</link></emphasis></para>
+ </listitem>
+ <listitem><para><emphasis><link linkend="xacc-options-style-sheet">
+ Style Sheet</link></emphasis></para>
+ </listitem>
+ <listitem><para><emphasis><link linkend="xacc-options-price-source">
+ Price Source</link></emphasis></para>
+ </listitem>
+ <listitem><para><emphasis><link linkend="xacc-options-depth">
+ Depth</link></emphasis></para>
+ </listitem>
+ <listitem><para><emphasis>Add More!!!
+ </emphasis></para>
+ </listitem>
+
+ </itemizedlist>
+ </sect1>
+ </article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-asset-liability-piecharts.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-asset-liability-piecharts.sgml:1.1
--- /dev/null Wed May 16 08:01:30 2001
+++ gnucash/doc/sgml/C/xacc-asset-liability-piecharts.sgml Tue May 15 07:22:06 2001
@@ -0,0 +1,15 @@
+<article id="xacc-asset-liability-piecharts">
+<artheader>
+<title>Asset and Liability Piecharts</title>
+</artheader>
+<sect1>
+<title>Asset and Liability Piecharts</title>
+<para><emphasis>PICTURES NEEDED!!!!</emphasis>
+</para>
+<para>This is not yet documented.</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-balancesheet.sgml
diff -u gnucash/doc/sgml/C/xacc-balancesheet.sgml:1.3 gnucash/doc/sgml/C/xacc-balancesheet.sgml:1.4
--- gnucash/doc/sgml/C/xacc-balancesheet.sgml:1.3 Mon Dec 11 02:08:50 2000
+++ gnucash/doc/sgml/C/xacc-balancesheet.sgml Tue May 15 07:22:06 2001
@@ -13,13 +13,21 @@
</PARA>
<PARA>This report summarizes your assets, liabilities, and
- equity.
+ equity. According to the accounting equation, your assets
+should equal the sum of your liabilities and equity. If that
+is not the case, there is some kind of internal imbalance in
+your accounts.
</PARA>
<PARA>You can select the date for which the balance sheet is to be
calculated up to using the "preferences" toolbar button. The
default is today.
+</PARA>
+<PARA>Note that while you <EMPHASIS>can</EMPHASIS> select specific
+accounts for this report, unless you know exactly what you are
+doing it is unwise and highly likely to give you misleading and
+incorrect figures.
</PARA>
</SECT1>
</ARTICLE>
Index: gnucash/doc/sgml/C/xacc-common-report-options.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-common-report-options.sgml:1.2
--- /dev/null Wed May 16 08:01:30 2001
+++ gnucash/doc/sgml/C/xacc-common-report-options.sgml Wed May 16 02:52:45 2001
@@ -0,0 +1,91 @@
+<ARTICLE ID="XACC-COMMON-REPORT-OPTIONS"
+<ARTHEADER>
+<TITLE>Common Report Options</TITLE>
+</ARTHEADER>
+<SECT1>
+<TITLE> Common Report Options</TITLE>
+<PARA>Many reports share similar sorts of options. Some common ones
+include:
+
+<itemizedlist>
+<listitem>
+<para><emphasis><anchor id="xacc-options-report-title">Report Title</emphasis></para>
+<para>Set the title of the report. This doesn't affect anything
+else, but can be handy if you need to print the report for later
+viewing.</para></listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-date">Date Options</emphasis></para>
+<para>Reports typically allow you to specify either a single date, or
+a date range, for the report. Dates can be specified in two ways:
+directly (using the date selector), or selecting a "relative" date
+from the menu. Relative dates allow you to specify dates like "the
+beginning of this year" or "today", and are highly convenient for
+doing "rolling reports".</para></listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-interval">Interval/Step Size</emphasis></para>
+<para>This option is used on bar charts to determine the interval
+which each bar represents. Typical values are daily, weekly,
+monthly, and yearly.</para></listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-accounts">Accounts</emphasis></para>
+<para>Most reports give you the opportunity to select the appropriate
+accounts. Note that some reports only allow you to select certain
+types of accounts - for instance, an expense piechart only allows
+expense accounts to be selected. </para>
+</listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-include-subaccounts">
+Include Subaccounts?</emphasis></para>
+<para>Summary reports typically have "include all subaccounts" option,
+which if selected ensures that all subaccounts are included if the
+parent account is.</para>
+</listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-depth">Depth</emphasis></para>
+<para>This option allows the selection of how "deep" the
+report displays subaccounts. If the subaccounts go deeper
+than selected, most reports will calculate an overall value
+for all the subaccounts and include it in a higher-level
+total. If you want to make sure every account selected is
+individually displayed, select "All".</para>
+</listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-style-sheet">Style Sheet</emphasis></para>
+<para>Select a Style Sheet. Style sheets control how reports are
+displayed. At the moment, there are two style sheets,
+"default" and "technicolor". You can customize each of these from
+the global Style Sheet menu item.</para>
+</listitem>
+
+<listitem>
+ <para><emphasis><anchor id="xacc-options-plot-dimensions">Plot
+ Dimensions</emphasis></para>
+
+ <para>There are "Width" and "Height"
+ options for most of the graphs, which specify the
+ displayed dimensions
+ (in pixels).</para>
+</listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-report-currency">Report Currency</emphasis></para>
+<para>Most reports allow you to select the report currency (the default
+is your "home" currency). Generally, values will be converted to
+this currency for graphical display or summarization.</para>
+</listitem>
+
+<listitem>
+<para><emphasis><anchor id="xacc-options-price-source">Price Source</emphasis></para>
+<para>Select how stock and currency prices are calculated in this report.
+You can choose a weighted average of prices over all transactions,
+prices at current values, or prices at the time of the report date.</para>
+</listitem>
+</itemizedlist>
+</sect1>
+</article>
\ No newline at end of file
Index: gnucash/doc/sgml/C/xacc-dateinput.sgml
diff -u gnucash/doc/sgml/C/xacc-dateinput.sgml:1.4 gnucash/doc/sgml/C/xacc-dateinput.sgml:1.5
--- gnucash/doc/sgml/C/xacc-dateinput.sgml:1.4 Mon Dec 11 02:08:50 2000
+++ gnucash/doc/sgml/C/xacc-dateinput.sgml Tue May 15 07:22:06 2001
@@ -1,10 +1,10 @@
<ARTICLE ID="XACC-DATEINPUT">
<ARTHEADER>
-<TITLE>Date Data Input</TITLE>
+<TITLE>Date Accelerator Keys</TITLE>
</ARTHEADER>
<SECT1>
-<TITLE> Date Input</TITLE>
+<TITLE> Date Accelerator Keys</TITLE>
<PARA> The date cell handles the following accelerator keys:
<ITEMIZEDLIST>
Index: gnucash/doc/sgml/C/xacc-gnome-mdi.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-gnome-mdi.sgml:1.1
--- /dev/null Wed May 16 08:01:30 2001
+++ gnucash/doc/sgml/C/xacc-gnome-mdi.sgml Tue May 15 07:22:06 2001
@@ -0,0 +1,15 @@
+<article id="xacc-gnome-mdi">
+<artheader>
+<title>The Gnome MDI</title>
+</artheader>
+<sect1>
+<title>The Gnome MDI</title>
+<para><emphasis>PICTURES NEEDED!!!!</emphasis>
+</para>
+<para>This is not yet documented.</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-income-expense-barcharts.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-income-expense-barcharts.sgml:1.1
--- /dev/null Wed May 16 08:01:31 2001
+++ gnucash/doc/sgml/C/xacc-income-expense-barcharts.sgml Tue May 15 07:22:06 2001
@@ -0,0 +1,15 @@
+<article id="xacc-income-expense-barcharts">
+<artheader>
+<title>Income & Expense Barcharts</title>
+</artheader>
+<sect1>
+<title>Income & Expense Barcharts</title>
+<para><emphasis>PICTURES NEEDED!!!!</emphasis>
+</para>
+<para>This is not yet documented.</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-income-expense-piecharts.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-income-expense-piecharts.sgml:1.1
--- /dev/null Wed May 16 08:01:31 2001
+++ gnucash/doc/sgml/C/xacc-income-expense-piecharts.sgml Tue May 15 07:22:06 2001
@@ -0,0 +1,15 @@
+<article id="xacc-income-expense-piecharts">
+<artheader>
+<title>Income & Expense Piecharts</title>
+</artheader>
+<sect1>
+<title>Income & Expense Piecharts</title>
+<para><emphasis>PICTURES NEEDED!!!!</emphasis>
+</para>
+<para>This is not yet documented.</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-mainwin.sgml
diff -u gnucash/doc/sgml/C/xacc-mainwin.sgml:1.3 gnucash/doc/sgml/C/xacc-mainwin.sgml:1.4
--- gnucash/doc/sgml/C/xacc-mainwin.sgml:1.3 Mon Dec 11 02:08:50 2000
+++ gnucash/doc/sgml/C/xacc-mainwin.sgml Tue May 15 07:22:06 2001
@@ -1,14 +1,14 @@
<ARTICLE ID="XACC-MAINWIN">
<ARTHEADER>
-<TITLE>Main Window</TITLE>
+<TITLE>Account Window</TITLE>
</ARTHEADER>
-<PARA>This is the main account window. You control your set of
+<PARA>This is an account window. You control your set of
accounts from here.
</PARA>
-<PARA>Below is a picture of the main window, with only the main
+<PARA>Below is a picture of an account window, with only the main
accounts shown. Note how <EMPHASIS>Business Expenses</EMPHASIS> has been
selected by highlighting. The box with a cross in it,
immediately to its left, shows that it has one or more detail
Index: gnucash/doc/sgml/C/xacc-multicolumn-view-reports.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-multicolumn-view-reports.sgml:1.2
--- /dev/null Wed May 16 08:01:31 2001
+++ gnucash/doc/sgml/C/xacc-multicolumn-view-reports.sgml Tue May 15 22:10:56 2001
@@ -0,0 +1,15 @@
+<article id="xacc-multicolumn-view-report">
+<artheader>
+<title>Multicolumn Views</title>
+</artheader>
+<sect1>
+<title>Multicolumn Views</title>
+<para><emphasis>PICTURES NEEDED!!!!</emphasis>
+</para>
+<para>This is not yet documented.</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/doc/sgml/C/xacc-net-worth-barchart.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-net-worth-barchart.sgml:1.1
--- /dev/null Wed May 16 08:01:31 2001
+++ gnucash/doc/sgml/C/xacc-net-worth-barchart.sgml Tue May 15 20:11:21 2001
@@ -0,0 +1,30 @@
+<ARTICLE ID="XACC-NET-WORTH-BARCHART">
+<ARTHEADER>
+<TITLE>Net Worth Barchart</TITLE>
+</ARTHEADER>
+<SECT1>
+<TITLE>Net Worth Barchart</TITLE>
+
+<PARA>Your net worth is the difference between the value of your
+assets or liabilities - a measure of your wealth, in other words.
+As such, it's interesting and informative to track this information
+over time. This bar chart lets you view how it (hopefully) grows</PARA>
+
+<para><emphasis>Options</emphasis></para>
+<itemizedlist>
+<listitem><para>Accounts</para></listitem>
+<listitem><para>Report Name</para></listitem>
+<listitem><para>Stylesheet</para></listitem>
+<listitem><para>From, To</para></listitem>
+<listitem><para>Step Size</para></listitem>
+<listitem><para>Report Currency</para></listitem>
+<listitem><para>Plot Width, Height</para></listitem>
+<listitem><para>Show Asset & Liability Bars</para>
+<para>Show a pair of bars for each time step representing
+your assets and liabilities, respectively</para></listitem>
+<listitem><para>Show Net Worth Bars</para>
+<para>Show a a bar in each time step representing your overall
+net worth at that time.</para>
+</itemizedlist>
+</sect1>
+</article>
\ No newline at end of file
Index: gnucash/doc/sgml/C/xacc-portfolio-report.sgml
diff -u gnucash/doc/sgml/C/xacc-portfolio-report.sgml:1.3 gnucash/doc/sgml/C/xacc-portfolio-report.sgml:1.4
--- gnucash/doc/sgml/C/xacc-portfolio-report.sgml:1.3 Mon Dec 11 02:08:51 2000
+++ gnucash/doc/sgml/C/xacc-portfolio-report.sgml Tue May 15 07:22:07 2001
@@ -1,26 +1,37 @@
-
-<ARTICLE ID="XACC-PORTFOLIO-REPORT">
-<ARTHEADER>
-<TITLE>Stock Portfolio Report</TITLE>
-</ARTHEADER>
-<SECT1>
-<TITLE> Stock Portfolio Report</TITLE>
-<PARA> <INLINEMEDIAOBJECT>
-<IMAGEOBJECT>
-<IMAGEDATA FILEREF="image/report-folio.png">
-</IMAGEOBJECT>
-</INLINEMEDIAOBJECT>
-
- </PARA>
-<PARA>This report summarizes the value of the stocks in your
+<article id="XACC-PORTFOLIO-REPORT">
+<artheader>
+<title>Stock Portfolio Report</title>
+</artheader>
+<sect1>
+<title> Stock Portfolio Report</title>
+<para> <inlinemediaobject>
+<imageobject>
+<imagedata fileref="image/report-folio.png">
+</imageobject>
+</inlinemediaobject>
+</para>
+<para>This report summarizes the value of the stocks in your
current portfolio.
-
- </PARA>
-<PARA>There are currently no options for this report.
-</PARA>
-</SECT1>
-</ARTICLE>
+ </para>
+<para>Options supported by this report include the following:
+<itemizedlist>
+<listitem><para><emphasis><link linkend="xacc-options-accounts">
+ Accounts</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-report-title">
+ Report Title</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-style-sheet">
+ Stylesheet</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-date">
+ Date</link></emphasis></para></listitem>
+<listitem><para><emphasis><link linkend="xacc-options-report-currency">
+ Report Currency</link></emphasis></para></listitem>
+<listitem><para><emphasis<link linkend="xacc-options-price-source">
+ Price Source</link></emphasis></para></listitem>
+</itemizedlist>
+</para>
+</sect1>
+</article>
<!-- Local variables: -->
<!-- sgml-parent-document: "gnucash.sgml" -->
Index: gnucash/doc/sgml/C/xacc-reports.sgml
diff -u gnucash/doc/sgml/C/xacc-reports.sgml:1.9 gnucash/doc/sgml/C/xacc-reports.sgml:1.11
--- gnucash/doc/sgml/C/xacc-reports.sgml:1.9 Sun Apr 29 20:58:13 2001
+++ gnucash/doc/sgml/C/xacc-reports.sgml Wed May 16 02:52:45 2001
@@ -11,10 +11,18 @@
<itemizedlist>
<listitem><para><link linkend="xacc-balancesheet"> Balance Sheet:
-</link> shows Assets, Liabilities and Equity. </para> </listitem>
+</link> shows Assets, Liabilities and Equity. </para>
+<para><link linkend="xacc-net-worth-barchart">Net Worth
+Barchart</link>shows your net worth in a graphical environment.
+If you examine just assets or liabilities, <link linkend="xacc-asset-liability-barcharts">
+barcharts</link> showing data over time are available, as are
+<link linkend="xacc-asset-liability-piecharts">piecharts</link>.
<listitem><para><link linkend="xacc-pnl"> Profit And Loss State:
-</link> shows Income and expenses over a selectable period. </para>
+</link> shows Income and/or Expenses over a selectable period. </para>
+<para>
+There are also <link linkend="xacc-income-expense-barcharts">bar</link>
+and <link linkend="xacc-income-expense-piecharts">pie</link> charts.</para>
</listitem>
<listitem> <para><link linkend="xacc-trans-report"> Transaction Report
@@ -23,7 +31,8 @@
<listitem> <para><link linkend="xacc-portfolio-report">Stock Portfolio
</link> provides a quick summary of your stocks, their current value,
-and profits made. </para></listitem>
+and profits made. The <link linkend="xacc-stock-price-report">Stock Price Tracker
+</link> lets you track the price of a particular stock over time.</para></listitem>
<listitem> <para><link linkend="xacc-tax-report">Tax Report / TXF
Export:</link> shows tax related Income and Expenses. Can <link
@@ -31,11 +40,9 @@
to TaxCut or TurboTax. </para>
</listitem>
-<listitem> <para><application>Balance Tracker</application> tracks the
-balance of one or more accounts over time, and supports graphical
-output (if you have <application>gnuplot</application> installed).
-</para> </listitem>
-
+<listitem> <para><link linkend="xacc-balancereport">Balance
+Tracker</link> tracks the balance of one or more accounts over time,
+with the option of displaying both tables and a bar chart.</para>
</itemizedlist>
</para>
@@ -43,7 +50,11 @@
<sect1 id="xacc-reportwindow">
<title> The Report Window</title>
-<para> Once you select a report, a report window will appear: </para>
+<para> Once you select a report, a report will appear. This
+may appear as a seperate top-level window, as a notebook tab,
+or in the main window, selectable for viewing through the "Window"
+menu. This is controllable <link linkend="xacc-gnome-mdi">using
+the MDI interface.</link></para>
<para><inlinemediaobject>
<imageobject>
@@ -62,7 +73,7 @@
</emphasis> allow you to view the previous contents of the window,
just like a web browser </para> </listitem>
-<listitem> <para> <emphasis>Parameters</emphasis> pops up a dialog box
+<listitem> <para> <emphasis>Options</emphasis> pops up a dialog box
allowing you to change the information presented in the report:
</para>
@@ -85,9 +96,15 @@
</itemizedlist>
-</para>
</sect1>
+<sect1 id="xacc-multiple-reports">
+<title> Multiple Reports In A Window</title> <para>GnuCash allows you
+to place multiple reports into a single report window, allowing you to
+examine a set of financial information at a glance. This functionality
+is provided with the <link linkend="xacc-multicolumn-view-report">
+Multicolumn View</link> special report.</para></sect1>
+
<sect1 id="xacc-customreports">
<title> Constructing custom reports</title>
@@ -111,11 +128,13 @@
</filename> for an indication of how they are used.
</para>
-<para>At present, reports are produced by internally creating HTML and
-rendering this with a HTML widget. (Future versions of GnuCash will
-hopefully support a more flexible system). </para>
+<para>At present, reports are produced by calling a HTML-generation API,
+which outputs a dialect of HTML and rendering this with a HTML widget. This
+has limitations (particularly when trying to align objects precisely,
+as might be necessary for printing onto pre-printed invoices for example),
+so in the future an additional report generation interface may be needed.</para>
-</sect1>
+</sect1>
</article>
<!-- Local variables: -->
<!-- sgml-parent-document: "gnucash.sgml" -->
Index: gnucash/doc/sgml/C/xacc-stock-price-report.sgml
diff -u /dev/null gnucash/doc/sgml/C/xacc-stock-price-report.sgml:1.1
--- /dev/null Wed May 16 08:01:32 2001
+++ gnucash/doc/sgml/C/xacc-stock-price-report.sgml Wed May 16 02:52:46 2001
@@ -0,0 +1,17 @@
+<article id="xacc-stock-price-report">
+<artheader>
+<title>Stock Price Report</title>
+</artheader>
+<sect1>
+<title>Stock Price Report</title>
+<para>
+PICTURE NEEDED
+</para>
+<para>This report is not documented yet.
+</para>
+</sect1>
+</article>
+
+<!-- Local variables: -->
+<!-- sgml-parent-document: "gnucash.sgml" -->
+<!-- End: -->
Index: gnucash/lib/Makefile.am
diff -u gnucash/lib/Makefile.am:1.3 gnucash/lib/Makefile.am:1.4
--- gnucash/lib/Makefile.am:1.3 Tue Apr 17 16:37:31 2001
+++ gnucash/lib/Makefile.am Tue May 15 10:51:01 2001
@@ -1,5 +1,5 @@
-SUBDIRS = guile-www
+SUBDIRS = guile-www srfi
EXTRA_DIST = \
README
Index: gnucash/lib/srfi/.cvsignore
diff -u /dev/null gnucash/lib/srfi/.cvsignore:1.1
--- /dev/null Wed May 16 08:01:59 2001
+++ gnucash/lib/srfi/.cvsignore Tue May 15 10:48:42 2001
@@ -0,0 +1,2 @@
+Makefile
+Makefile.in
Index: gnucash/lib/srfi/Makefile.am
diff -u /dev/null gnucash/lib/srfi/Makefile.am:1.1
--- /dev/null Wed May 16 08:01:59 2001
+++ gnucash/lib/srfi/Makefile.am Tue May 15 10:48:43 2001
@@ -0,0 +1,13 @@
+
+gncscmdir = ${GNC_SHAREDIR}/guile-modules/srfi
+
+gncscm_DATA = \
+ srfi-1.scm \
+ srfi-2.scm \
+ srfi-8.scm \
+ srfi-9.scm \
+ srfi-11.scm \
+ srfi-19.scm
+
+
+EXTRA_DIST = README .cvsignore ${gncscm_DATA}
Index: gnucash/lib/srfi/README
diff -u /dev/null gnucash/lib/srfi/README:1.1
--- /dev/null Wed May 16 08:01:59 2001
+++ gnucash/lib/srfi/README Tue May 15 10:48:43 2001
@@ -0,0 +1,13 @@
+
+These files implement various useful SRFIs for Guile. See
+http://srfi.schemers.org/. The bits taken from the Guile source tree
+will go away whenever gnucash updates to require a more recent version
+of Guile.
+
+Sources of files:
+
+ srfi-1.scm: Guile translation of reference implementation by Olin Shivers.
+ srfi-2.scm: Guile source tree (modified for versioning).
+ srfi-8.scm: Guile source tree (modified for versioning).
+ srfi-9.scm: Guile source tree (modified for versioning).
+ srfi-19.scm: Guile source tree (modified for versioning).
Index: gnucash/lib/srfi/srfi-1.scm
diff -u /dev/null gnucash/lib/srfi/srfi-1.scm:1.1
--- /dev/null Wed May 16 08:01:59 2001
+++ gnucash/lib/srfi/srfi-1.scm Tue May 15 10:48:43 2001
@@ -0,0 +1,1660 @@
+;;; SRFI-1 list-processing library -*- Scheme -*-
+;;; Reference implementation
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;; -Olin
+
+;;; Modifications to make the code more portable are
+;;; Copyright 1999, Rob Browning <rlb@cs.utexas.edu>. You may do as
+;;; you please with this code as long as you do not remove this
+;;; copyright notice or hold me liable for its use.
+
+;;; This is a library of list- and pair-processing functions. I wrote it after
+;;; carefully considering the functions provided by the libraries found in
+;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
+;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
+;;; rich toolkit, providing a superset of the functionality found in any of
+;;; the various Schemes I considered.
+
+;;; This implementation is intended as a portable reference implementation
+;;; for SRFI-1. See the porting notes below for more information.
+
+;;; Exported:
+;;; xcons tree-copy make-list list-tabulate cons* list-copy
+;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
+;;; circular-list length+
+;;; iota
+;;; first second third fourth fifth sixth seventh eighth ninth tenth
+;;; car+cdr
+;;; take drop
+;;; take-right drop-right
+;;; take! drop-right!
+;;; split-at split-at!
+;;; last last-pair
+;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
+;;; count
+;;; append! append-reverse append-reverse! concatenate concatenate!
+;;; unfold fold pair-fold reduce
+;;; unfold-right fold-right pair-fold-right reduce-right
+;;; append-map append-map! map! pair-for-each filter-map map-in-order
+;;; filter partition remove
+;;; filter! partition! remove!
+;;; find find-tail any every list-index-pred
+;;; take-while drop-while take-while!
+;;; span break span! break!
+;;; delete delete!
+;;; alist-cons alist-copy
+;;; delete-duplicates delete-duplicates!
+;;; alist-delete alist-delete!
+;;; reverse!
+;;; lset<= lset= lset-adjoin
+;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
+;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+;;;
+;;; In principle, the following R4RS list- and pair-processing procedures
+;;; are also part of this package's exports, although they are not defined
+;;; in this file:
+;;; Primitives: cons pair? null? car cdr set-car! set-cdr!
+;;; Non-primitives: list length append reverse cadr ... cddddr list-ref
+;;; memq memv assq assv
+;;; (The non-primitives are defined in this file, but commented out.)
+;;;
+;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
+;;; in this file:
+;;; map for-each member assoc
+;;;
+;;; The remaining two R4RS list-processing procedures are not included:
+;;; list-tail (use drop)
+;;; list? (use proper-list?)
+
+
+;;; A note on recursion and iteration/reversal:
+;;; Many iterative list-processing algorithms naturally compute the elements
+;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
+;;; the order needed to cons them into the proper answer (right-to-left, or
+;;; tail-then-head). One style or idiom of programming these algorithms, then,
+;;; loops, consing up the elements in reverse order, then destructively
+;;; reverses the list at the end of the loop. I do not do this. The natural
+;;; and efficient way to code these algorithms is recursively. This trades off
+;;; intermediate temporary list structure for intermediate temporary stack
+;;; structure. In a stack-based system, this improves cache locality and
+;;; lightens the load on the GC system. Don't stand on your head to iterate!
+;;; Recurse, where natural. Multiple-value returns make this even more
+;;; convenient, when the recursion/iteration has multiple state values.
+
+;;; Porting:
+;;; This is carefully tuned code; do not modify casually.
+;;; - It is careful to share storage when possible;
+;;; - Side-effecting code tries not to perform redundant writes.
+;;;
+;;; That said, a port of this library to a specific Scheme system might wish
+;;; to tune this code to exploit particulars of the implementation.
+;;; The single most important compiler-specific optimisation you could make
+;;; to this library would be to add rewrite rules or transforms to:
+;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
+;;; LSET-UNION) into multiple applications of a primitive two-argument
+;;; variant.
+;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD,
+;;; ANY, EVERY) into open-coded loops. The killer here is that these
+;;; functions are n-ary. Handling the general case is quite inefficient,
+;;; requiring many intermediate data structures to be allocated and
+;;; discarded.
+;;; - transform applications of procedures that take optional arguments
+;;; into calls to variants that do not take optional arguments. This
+;;; eliminates unnecessary consing and parsing of the rest parameter.
+;;;
+;;; These transforms would provide BIG speedups. In particular, the n-ary
+;;; mapping functions are particularly slow and cons-intensive, and are good
+;;; candidates for tuning. I have coded fast paths for the single-list cases,
+;;; but what you really want to do is exploit the fact that the compiler
+;;; usually knows how many arguments are being passed to a particular
+;;; application of these functions -- they are usually explicitly called, not
+;;; passed around as higher-order values. If you can arrange to have your
+;;; compiler produce custom code or custom linkages based on the number of
+;;; arguments in the call, you can speed these functions up a *lot*. But this
+;;; kind of compiler technology no longer exists in the Scheme world as far as
+;;; I can see.
+;;;
+;;; Note that this code is, of course, dependent upon standard bindings for
+;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
+;;; to the procedure that takes the car of a list. If your Scheme
+;;; implementation allows user code to alter the bindings of these procedures
+;;; in a manner that would be visible to these definitions, then there might
+;;; be trouble. You could consider horrible kludgery along the lines of
+;;; (define fact
+;;; (let ((= =) (- -) (* *))
+;;; (letrec ((real-fact (lambda (n)
+;;; (if (= n 0) 1 (* n (real-fact (- n 1)))))))
+;;; real-fact)))
+;;; Or you could consider shifting to a reasonable Scheme system that, say,
+;;; has a module system protecting code from this kind of lossage.
+;;;
+;;; This code does a fair amount of run-time argument checking. If your
+;;; Scheme system has a sophisticated compiler that can eliminate redundant
+;;; error checks, this is no problem. However, if not, these checks incur
+;;; some performance overhead -- and, in a safe Scheme implementation, they
+;;; are in some sense redundant: if we don't check to see that the PROC
+;;; parameter is a procedure, we'll find out anyway three lines later when
+;;; we try to call the value. It's pretty easy to rip all this argument
+;;; checking code out if it's inappropriate for your implementation -- just
+;;; nuke every call to CHECK-ARG.
+;;;
+;;; On the other hand, if you *do* have a sophisticated compiler that will
+;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
+;;; being the only possible candidate of which I'm aware), leaving these checks
+;;; in can *help*, since their presence can be elided in redundant cases,
+;;; and in cases where they are needed, performing the checks early, at
+;;; procedure entry, can "lift" a check out of a loop.
+;;;
+;;; Finally, I have only checked the properties that can portably be checked
+;;; with R5RS Scheme -- and this is not complete. You may wish to alter
+;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
+;;; checks, such as procedure arity for higher-order values.
+;;;
+;;; The code has only these non-R4RS dependencies:
+;;; A few calls to an ERROR procedure;
+;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding
+;;; RECEIVE macro (which isn't R5RS, but is a trivial macro).
+;;; Many calls to a parameter-checking procedure check-arg:
+;;; (define (check-arg pred val caller)
+;;; (let lp ((val val))
+;;; (if (pred val) val (lp (error "Bad argument" val pred caller)))))
+;;;
+;;; Most of these procedures use the NULL-LIST? test to trigger the
+;;; base case in the inner loop or recursion. The NULL-LIST? function
+;;; is defined to be a careful one -- it raises an error if passed a
+;;; non-nil, non-pair value. The spec allows an implementation to use
+;;; a less-careful implementation that simply defines NULL-LIST? to
+;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
+;;; at the expense of having them silently accept dotted lists.
+
+;;; A note on dotted lists:
+;;; I, personally, take the view that the only consistent view of lists
+;;; in Scheme is the view that *everything* is a list -- values such as
+;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
+;;; fact that Scheme actually has no true list type. It has a pair type,
+;;; and there is an *interpretation* of the trees built using this type
+;;; as lists.
+;;;
+;;; I lobbied to have these list-processing procedures hew to this
+;;; view, and accept any value as a list argument. I was overwhelmingly
+;;; overruled during the SRFI discussion phase. So I am inserting this
+;;; text in the reference lib and the SRFI spec as a sort of "minority
+;;; opinion" dissent.
+;;;
+;;; Many of the procedures in this library can be trivially redefined
+;;; to handle dotted lists, just by changing the NULL-LIST? base-case
+;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
+;;; an empty list. For most of these procedures, that's all that is
+;;; required.
+;;;
+;;; However, we have to do a little more work for some procedures that
+;;; *produce* lists from other lists. Were we to extend these procedures to
+;;; accept dotted lists, we would have to define how they terminate the lists
+;;; produced as results when passed a dotted list. I designed a coherent set
+;;; of termination rules for these cases; this was posted to the SRFI-1
+;;; discussion list. I additionally wrote an earlier version of this library
+;;; that implemented that spec. It has been discarded during later phases of
+;;; the definition and implementation of this library.
+;;;
+;;; The argument *against* defining these procedures to work on dotted
+;;; lists is that dotted lists are the rare, odd case, and that by
+;;; arranging for the procedures to handle them, we lose error checking
+;;; in the cases where a dotted list is passed by accident -- e.g., when
+;;; the programmer swaps a two arguments to a list-processing function,
+;;; one being a scalar and one being a list. For example,
+;;; (member '(1 3 5 7 9) 7)
+;;; This would quietly return #f if we extended MEMBER to accept dotted
+;;; lists.
+;;;
+;;; The SRFI discussion record contains more discussion on this topic.
+
+(define-module (srfi srfi-1))
+
+(export
+ xcons tree-copy make-list list-tabulate cons* list-copy
+ proper-list? circular-list? dotted-list? not-pair? null-list? list=
+ circular-list length+
+ iota
+ first second third fourth fifth sixth seventh eighth ninth tenth
+ car+cdr
+ take drop
+ take-right drop-right
+ take! drop-right!
+ split-at split-at!
+ last last-pair
+ zip unzip1 unzip2 unzip3 unzip4 unzip5
+ count
+ append! append-reverse append-reverse! concatenate concatenate!
+ unfold fold pair-fold reduce
+ unfold-right fold-right pair-fold-right reduce-right
+ append-map append-map! map! pair-for-each filter-map map-in-order
+ filter partition remove
+ filter! partition! remove!
+ find find-tail any every list-index-pred
+ take-while drop-while take-while!
+ span break span! break!
+ delete delete!
+ alist-cons alist-copy
+ delete-duplicates delete-duplicates!
+ alist-delete alist-delete!
+ reverse!
+ lset<= lset= lset-adjoin
+ lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
+ lset-union! lset-intersection! lset-difference!
+ lset-xor! lset-diff+intersection!
+ map for-each member assoc)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Modifications from the "official" implementation.
+;;;
+;;; Removed all non r5rs-isms that I detected (i.e :optional and let-optionals).
+;;;
+;;; Renamed error to srfi-1:error
+;;; Renamed check-arg to srfi-1:check-arg
+;;;
+
+;; This has been modified for GnuCash to use guile's built in error
+;; function.
+
+(define (srfi-1:error msg . args)
+ (apply error msg args))
+
+(define (srfi-1:check-arg pred val caller)
+ (if (pred val)
+ val
+ (srfi-1:error "Bad argument" val "to function" caller)))
+
+;;; Constructors
+;;;;;;;;;;;;;;;;
+
+;;; Occasionally useful as a value to be passed to a fold or other
+;;; higher-order procedure.
+(define (xcons d a) (cons a d))
+
+;;;; Recursively copy every cons.
+;(define (tree-copy x)
+; (let recur ((x x))
+; (if (not (pair? x)) x
+; (cons (recur (car x)) (recur (cdr x))))))
+
+;;; Make a list of length LEN.
+
+(define (make-list len . maybe-elt)
+ (srfi-1:check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
+ (let ((elt (cond ((null? maybe-elt) #f) ; Default value
+ ((null? (cdr maybe-elt)) (car maybe-elt))
+ (else (srfi-1:error "Too many arguments to MAKE-LIST"
+ (cons len maybe-elt))))))
+ (do ((i len (- i 1))
+ (ans '() (cons elt ans)))
+ ((<= i 0) ans))))
+
+
+;(define (list . ans) ans) ; R4RS
+
+
+;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
+
+(define (list-tabulate len proc)
+ (srfi-1:check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
+ (srfi-1:check-arg procedure? proc list-tabulate)
+ (do ((i (- len 1) (- i 1))
+ (ans '() (cons (proc i) ans)))
+ ((< i 0) ans)))
+
+;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
+;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
+;;;
+;;; (cons first (unfold not-pair? car cdr rest values))
+
+(define (cons* first . rest)
+ (let recur ((x first) (rest rest))
+ (if (pair? rest)
+ (cons x (recur (car rest) (cdr rest)))
+ x)))
+
+;;; (unfold not-pair? car cdr lis values)
+
+(define (list-copy lis)
+ (let recur ((lis lis))
+ (if (pair? lis)
+ (cons (car lis) (recur (cdr lis)))
+ lis)))
+
+;;; IOTA count [start step] (start start+step ... start+(count-1)*step)
+
+(define (iota count . maybe-start+step)
+
+ (define (helper start step)
+ (srfi-1:check-arg number? start iota)
+ (srfi-1:check-arg number? step iota)
+ (let ((last-val (+ start (* (- count 1) step))))
+ (do ((count count (- count 1))
+ (val last-val (- val step))
+ (ans '() (cons val ans)))
+ ((<= count 0) ans))))
+
+ (srfi-1:check-arg integer? count iota)
+ (if (< count 0) (srfi-1:error "Negative step count" iota count))
+
+ (if (pair? maybe-start+step)
+ (helper (car maybe-start+step) (cadr maybe-start+step))
+ (helper 0 1)))
+
+;;; I thought these were lovely, but the public at large did not share my
+;;; enthusiasm...
+;;; :IOTA to (0 ... to-1)
+;;; :IOTA from to (from ... to-1)
+;;; :IOTA from to step (from from+step ...)
+
+;;; IOTA: to (1 ... to)
+;;; IOTA: from to (from+1 ... to)
+;;; IOTA: from to step (from+step from+2step ...)
+
+;(define (%parse-iota-args arg1 rest-args proc)
+; (let ((check (lambda (n) (srfi-1:check-arg integer? n proc))))
+; (check arg1)
+; (if (pair? rest-args)
+; (let ((arg2 (check (car rest-args)))
+; (rest (cdr rest-args)))
+; (if (pair? rest)
+; (let ((arg3 (check (car rest)))
+; (rest (cdr rest)))
+; (if (pair? rest) (srfi-1:error "Too many parameters" proc arg1 rest-args)
+; (values arg1 arg2 arg3)))
+; (values arg1 arg2 1)))
+; (values 0 arg1 1))))
+;
+;(define (iota: arg1 . rest-args)
+; (receive (from to step) (%parse-iota-args arg1 rest-args iota:)
+; (let* ((numsteps (floor (/ (- to from) step)))
+; (last-val (+ from (* step numsteps))))
+; (if (< numsteps 0) (srfi-1:error "Negative step count" iota: from to step))
+; (do ((steps-left numsteps (- steps-left 1))
+; (val last-val (- val step))
+; (ans '() (cons val ans)))
+; ((<= steps-left 0) ans)))))
+;
+;
+;(define (:iota arg1 . rest-args)
+; (receive (from to step) (%parse-iota-args arg1 rest-args :iota)
+; (let* ((numsteps (ceiling (/ (- to from) step)))
+; (last-val (+ from (* step (- numsteps 1)))))
+; (if (< numsteps 0) (srfi-1:error "Negative step count" :iota from to step))
+; (do ((steps-left numsteps (- steps-left 1))
+; (val last-val (- val step))
+; (ans '() (cons val ans)))
+; ((<= steps-left 0) ans)))))
+
+
+
+(define (circular-list val1 . vals)
+ (let ((ans (cons val1 vals)))
+ (set-cdr! (last-pair ans) ans)
+ ans))
+
+;;; <proper-list> ::= () ; Empty proper list
+;;; | (cons <x> <proper-list>) ; Proper-list pair
+;;; Note that this definition rules out circular lists -- and this
+;;; function is required to detect this case and return false.
+
+(define (proper-list? x)
+ (let lp ((x x) (lag x))
+ (if (pair? x)
+ (let ((x (cdr x)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (and (not (eq? x lag)) (lp x lag)))
+ (null? x)))
+ (null? x))))
+
+
+;;; A dotted list is a finite list (possibly of length 0) terminated
+;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
+;;; is a dotted list of length 0.
+;;;
+;;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
+;;; | (cons <x> <dotted-list>) ; Proper-list pair
+
+(define (dotted-list? x)
+ (let lp ((x x) (lag x))
+ (if (pair? x)
+ (let ((x (cdr x)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (and (not (eq? x lag)) (lp x lag)))
+ (not (null? x))))
+ (not (null? x)))))
+
+(define (circular-list? x)
+ (let lp ((x x) (lag x))
+ (and (pair? x)
+ (let ((x (cdr x)))
+ (and (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (or (eq? x lag) (lp x lag))))))))
+
+(define (not-pair? x) (not (pair? x))) ; Inline me.
+
+;;; This is a legal definition which is fast and sloppy:
+;;; (define null-list? not-pair?)
+;;; but we'll provide a more careful one:
+(define (null-list? l)
+ (cond ((pair? l) #f)
+ ((null? l) #t)
+ (else (srfi-1:error "null-pair?: argument out of domain" l))))
+
+
+(define (list= = . lists)
+ (or (null? lists) ; special case
+
+ (let lp1 ((list-a (car lists)) (others (cdr lists)))
+ (or (null? others)
+ (let ((list-b (car others))
+ (others (cdr others)))
+ (if (eq? list-a list-b) ; EQ? => LIST=
+ (lp1 list-b others)
+ (let lp2 ((list-a list-a) (list-b list-b))
+ (if (null-list? list-a)
+ (and (null-list? list-b)
+ (lp1 list-b others))
+ (and (not (null-list? list-b))
+ (= (car list-a) (car list-b))
+ (lp2 (cdr list-a) (cdr list-b)))))))))))
+
+
+
+;;; R4RS, so commented out.
+;(define (length x) ; LENGTH may diverge or
+; (let lp ((x x) (len 0)) ; raise an error if X is
+; (if (pair? x) ; a circular list. This version
+; (lp (cdr x) (+ len 1)) ; diverges.
+; len)))
+
+(define (length+ x) ; Returns #f if X is circular.
+ (let lp ((x x) (lag x) (len 0))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (len (+ len 1)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag))
+ (len (+ len 1)))
+ (and (not (eq? x lag)) (lp x lag len)))
+ len))
+ len)))
+
+(define (zip list1 . more-lists) (apply map list list1 more-lists))
+
+
+;;; Selectors
+;;;;;;;;;;;;;
+
+;;; R4RS non-primitives:
+;(define (caar x) (car (car x)))
+;(define (cadr x) (car (cdr x)))
+;(define (cdar x) (cdr (car x)))
+;(define (cddr x) (cdr (cdr x)))
+;
+;(define (caaar x) (caar (car x)))
+;(define (caadr x) (caar (cdr x)))
+;(define (cadar x) (cadr (car x)))
+;(define (caddr x) (cadr (cdr x)))
+;(define (cdaar x) (cdar (car x)))
+;(define (cdadr x) (cdar (cdr x)))
+;(define (cddar x) (cddr (car x)))
+;(define (cdddr x) (cddr (cdr x)))
+;
+;(define (caaaar x) (caaar (car x)))
+;(define (caaadr x) (caaar (cdr x)))
+;(define (caadar x) (caadr (car x)))
+;(define (caaddr x) (caadr (cdr x)))
+;(define (cadaar x) (cadar (car x)))
+;(define (cadadr x) (cadar (cdr x)))
+;(define (caddar x) (caddr (car x)))
+;(define (cadddr x) (caddr (cdr x)))
+;(define (cdaaar x) (cdaar (car x)))
+;(define (cdaadr x) (cdaar (cdr x)))
+;(define (cdadar x) (cdadr (car x)))
+;(define (cdaddr x) (cdadr (cdr x)))
+;(define (cddaar x) (cddar (car x)))
+;(define (cddadr x) (cddar (cdr x)))
+;(define (cdddar x) (cdddr (car x)))
+;(define (cddddr x) (cdddr (cdr x)))
+
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth x) (car (cddddr x)))
+(define (sixth x) (cadr (cddddr x)))
+(define (seventh x) (caddr (cddddr x)))
+(define (eighth x) (cadddr (cddddr x)))
+(define (ninth x) (car (cddddr (cddddr x))))
+(define (tenth x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr pair) (values (car pair) (cdr pair)))
+
+;;; take & drop
+
+(define (take lis k)
+ (srfi-1:check-arg integer? k take)
+ (let recur ((lis lis) (k k))
+ (if (zero? k) '()
+ (cons (car lis)
+ (recur (cdr lis) (- k 1))))))
+
+(define (drop lis k)
+ (srfi-1:check-arg integer? k drop)
+ (let iter ((lis lis) (k k))
+ (if (zero? k) lis (iter (cdr lis) (- k 1)))))
+
+(define (take! lis k)
+ (srfi-1:check-arg integer? k take!)
+ (if (zero? k) '()
+ (begin (set-cdr! (drop lis (- k 1)) '())
+ lis)))
+
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.
+
+(define (take-right lis k)
+ (srfi-1:check-arg integer? k take-right)
+ (let lp ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (lp (cdr lag) (cdr lead))
+ lag)))
+
+(define (drop-right lis k)
+ (srfi-1:check-arg integer? k drop-right)
+ (let recur ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (cons (car lag) (recur (cdr lag) (cdr lead)))
+ '())))
+
+;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
+;;; us stop LAG one step early, in time to smash its cdr to ().
+(define (drop-right! lis k)
+ (srfi-1:check-arg integer? k drop-right!)
+ (let ((lead (drop lis k)))
+ (if (pair? lead)
+
+ (let lp ((lag lis) (lead (cdr lead))) ; Standard case
+ (if (pair? lead)
+ (lp (cdr lag) (cdr lead))
+ (begin (set-cdr! lag '())
+ lis)))
+
+ '()))) ; Special case dropping everything -- no cons to side-effect.
+
+;(define (list-ref lis i) (car (drop lis i))) ; R4RS
+
+;;; These use the APL convention, whereby negative indices mean
+;;; "from the right." I liked them, but they didn't win over the
+;;; SRFI reviewers.
+;;; K >= 0: Take and drop K elts from the front of the list.
+;;; K <= 0: Take and drop -K elts from the end of the list.
+
+;(define (take lis k)
+; (srfi-1:check-arg integer? k take)
+; (if (negative? k)
+; (list-tail lis (+ k (length lis)))
+; (let recur ((lis lis) (k k))
+; (if (zero? k) '()
+; (cons (car lis)
+; (recur (cdr lis) (- k 1)))))))
+;
+;(define (drop lis k)
+; (srfi-1:check-arg integer? k drop)
+; (if (negative? k)
+; (let recur ((lis lis) (nelts (+ k (length lis))))
+; (if (zero? nelts) '()
+; (cons (car lis)
+; (recur (cdr lis) (- nelts 1)))))
+; (list-tail lis k)))
+;
+;
+;(define (take! lis k)
+; (srfi-1:check-arg integer? k take!)
+; (cond ((zero? k) '())
+; ((positive? k)
+; (set-cdr! (list-tail lis (- k 1)) '())
+; lis)
+; (else (list-tail lis (+ k (length lis))))))
+;
+;(define (drop! lis k)
+; (srfi-1:check-arg integer? k drop!)
+; (if (negative? k)
+; (let ((nelts (+ k (length lis))))
+; (if (zero? nelts) '()
+; (begin (set-cdr! (list-tail lis (- nelts 1)) '())
+; lis)))
+; (list-tail lis k)))
+
+(define (split-at x k)
+ (srfi-1:check-arg integer? k split-at)
+ (let recur ((lis x) (k k))
+ (if (zero? k) (values '() lis)
+ (receive (prefix suffix) (recur (cdr lis) (- k 1))
+ (values (cons (car lis) prefix) suffix)))))
+
+(define (split-at! x k)
+ (srfi-1:check-arg integer? k split-at!)
+ (if (zero? k) (values '() x)
+ (let* ((prev (drop x (- k 1)))
+ (suffix (cdr prev)))
+ (set-cdr! prev '())
+ (values x suffix))))
+
+
+(define (last lis) (car (last-pair lis)))
+
+(define (last-pair lis)
+ (srfi-1:check-arg pair? lis last-pair)
+ (let lp ((lis lis))
+ (let ((tail (cdr lis)))
+ (if (pair? tail) (lp tail) lis))))
+
+
+;;; Unzippers -- 1 through 5
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (unzip1 lis) (map car lis))
+
+(define (unzip2 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
+ (let ((elt (car lis))) ; dotted lists.
+ (receive (a b) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)))))))
+
+(define (unzip3 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis lis)
+ (let ((elt (car lis)))
+ (receive (a b c) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)
+ (cons (caddr elt) c)))))))
+
+(define (unzip4 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis lis lis)
+ (let ((elt (car lis)))
+ (receive (a b c d) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)
+ (cons (caddr elt) c)
+ (cons (cadddr elt) d)))))))
+
+(define (unzip5 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis lis lis lis)
+ (let ((elt (car lis)))
+ (receive (a b c d e) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)
+ (cons (caddr elt) c)
+ (cons (cadddr elt) d)
+ (cons (car (cddddr elt)) e)))))))
+
+
+;;; append! append-reverse append-reverse! concatenate concatenate!
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append! . lists)
+ ;; First, scan through lists looking for a non-empty one.
+ (let lp ((lists lists) (prev '()))
+ (if (not (pair? lists)) prev
+ (let ((first (car lists))
+ (rest (cdr lists)))
+ (if (not (pair? first)) (lp rest first)
+
+ ;; Now, do the splicing.
+ (let lp2 ((tail-cons (last-pair first))
+ (rest rest))
+ (if (pair? rest)
+ (let ((next (car rest))
+ (rest (cdr rest)))
+ (set-cdr! tail-cons next)
+ (lp2 (if (pair? next) (last-pair next) tail-cons)
+ rest))
+ first)))))))
+
+;;; APPEND is R4RS.
+;(define (append . lists)
+; (if (pair? lists)
+; (let recur ((list1 (car lists)) (lists (cdr lists)))
+; (if (pair? lists)
+; (let ((tail (recur (car lists) (cdr lists))))
+; (fold-right cons tail list1)) ; Append LIST1 & TAIL.
+; list1))
+; '()))
+
+;(define (append-reverse rev-head tail) (fold cons tail rev-head))
+
+;(define (append-reverse! rev-head tail)
+; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
+; tail
+; rev-head))
+
+;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
+
+(define (append-reverse rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (lp (cdr rev-head) (cons (car rev-head) tail)))))
+
+(define (append-reverse! rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (let ((next-rev (cdr rev-head)))
+ (set-cdr! rev-head tail)
+ (lp next-rev rev-head)))))
+
+
+(define (concatenate lists) (reduce-right append '() lists))
+(define (concatenate! lists) (reduce-right append! '() lists))
+
+;;; Fold/map internal utilities
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These little internal utilities are used by the general
+;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
+;;; One the other hand, the n-ary cases are painfully inefficient as it is.
+;;; An aggressive implementation should simply re-write these functions
+;;; for raw efficiency; I have written them for as much clarity, portability,
+;;; and simplicity as can be achieved.
+;;;
+;;; I use the dreaded call/cc to do local aborts. A good compiler could
+;;; handle this with extreme efficiency. An implementation that provides
+;;; a one-shot, non-persistent continuation grabber could help the compiler
+;;; out by using that in place of the call/cc's in these routines.
+;;;
+;;; These functions have funky definitions that are precisely tuned to
+;;; the needs of the fold/map procs -- for example, to minimize the number
+;;; of times the argument lists need to be examined.
+
+;;; Return (map cdr lists).
+;;; However, if any element of LISTS is empty, just abort and return '().
+(define (%cdrs lists)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (let ((lis (car lists)))
+ (if (null-list? lis) (abort '())
+ (cons (cdr lis) (recur (cdr lists)))))
+ '())))))
+
+(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt))
+ (let recur ((lists lists))
+ (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (%cars+cdrs lists)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (receive (list other-lists) (car+cdr lists)
+ (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+ (receive (a d) (car+cdr list)
+ (receive (cars cdrs) (recur other-lists)
+ (values (cons a cars) (cons d cdrs))))))
+ (values '() '()))))))
+
+;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
+;;; cars list. What a hack.
+(define (%cars+cdrs+ lists cars-final)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (receive (list other-lists) (car+cdr lists)
+ (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+ (receive (a d) (car+cdr list)
+ (receive (cars cdrs) (recur other-lists)
+ (values (cons a cars) (cons d cdrs))))))
+ (values (list cars-final) '()))))))
+
+;;; Like %CARS+CDRS, but blow up if any list is empty.
+(define (%cars+cdrs/no-test lists)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (receive (list other-lists) (car+cdr lists)
+ (receive (a d) (car+cdr list)
+ (receive (cars cdrs) (recur other-lists)
+ (values (cons a cars) (cons d cdrs)))))
+ (values '() '()))))
+
+
+;;; count
+;;;;;;;;;
+(define (count pred list1 . lists)
+ (srfi-1:check-arg procedure? pred count)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (let lp ((list1 list1) (lists lists) (i 0))
+ (if (null-list? list1) i
+ (receive (as ds) (%cars+cdrs lists)
+ (if (null? as) i
+ (lp (cdr list1) ds
+ (if (apply pred (car list1) as) (+ i 1) i))))))
+
+ ;; Fast path
+ (let lp ((lis list1) (i 0))
+ (if (null-list? lis) i
+ (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
+
+
+;;; fold/unfold
+;;;;;;;;;;;;;;;
+
+(define (unfold-right p f g seed . maybe-tail)
+ (srfi-1:check-arg procedure? p unfold-right)
+ (srfi-1:check-arg procedure? f unfold-right)
+ (srfi-1:check-arg procedure? g unfold-right)
+ (let lp ((seed seed)
+ (ans (if (pair? maybe-tail) (car maybe-tail) '())))
+ (if (p seed) ans
+ (lp (g seed)
+ (cons (f seed) ans)))))
+
+
+(define (unfold p f g seed . maybe-tail-gen)
+ (srfi-1:check-arg procedure? p unfold)
+ (srfi-1:check-arg procedure? f unfold)
+ (srfi-1:check-arg procedure? g unfold)
+ (if (pair? maybe-tail-gen)
+
+ (let ((tail-gen (car maybe-tail-gen)))
+ (if (pair? (cdr maybe-tail-gen))
+ (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
+
+ (let recur ((seed seed))
+ (if (p seed) (tail-gen seed)
+ (cons (f seed) (recur (g seed)))))))
+
+ (let recur ((seed seed))
+ (if (p seed) '()
+ (cons (f seed) (recur (g seed)))))))
+
+
+(define (fold kons knil lis1 . lists)
+ (srfi-1:check-arg procedure? kons fold)
+ (if (pair? lists)
+ (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case
+ (receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
+ (if (null? cars+ans) ans ; Done.
+ (lp cdrs (apply kons cars+ans)))))
+
+ (let lp ((lis lis1) (ans knil)) ; Fast path
+ (if (null-list? lis) ans
+ (lp (cdr lis) (kons (car lis) ans))))))
+
+
+(define (fold-right kons knil lis1 . lists)
+ (srfi-1:check-arg procedure? kons fold-right)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists))) ; N-ary case
+ (let ((cdrs (%cdrs lists)))
+ (if (null? cdrs) knil
+ (apply kons (%cars+ lists (recur cdrs))))))
+
+ (let recur ((lis lis1)) ; Fast path
+ (if (null-list? lis) knil
+ (let ((head (car lis)))
+ (kons head (recur (cdr lis))))))))
+
+
+(define (pair-fold-right f zero lis1 . lists)
+ (srfi-1:check-arg procedure? f pair-fold-right)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists))) ; N-ary case
+ (let ((cdrs (%cdrs lists)))
+ (if (null? cdrs) zero
+ (apply f (append! lists (list (recur cdrs)))))))
+
+ (let recur ((lis lis1)) ; Fast path
+ (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
+
+(define (pair-fold f zero lis1 . lists)
+ (srfi-1:check-arg procedure? f pair-fold)
+ (if (pair? lists)
+ (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case
+ (let ((tails (%cdrs lists)))
+ (if (null? tails) ans
+ (lp tails (apply f (append! lists (list ans)))))))
+
+ (let lp ((lis lis1) (ans zero))
+ (if (null-list? lis) ans
+ (let ((tail (cdr lis))) ; Grab the cdr now,
+ (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS.
+
+
+;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
+;;; These cannot meaningfully be n-ary.
+
+(define (reduce f ridentity lis)
+ (srfi-1:check-arg procedure? f reduce)
+ (if (null-list? lis) ridentity
+ (fold f (car lis) (cdr lis))))
+
+(define (reduce-right f ridentity lis)
+ (srfi-1:check-arg procedure? f reduce-right)
+ (if (null-list? lis) ridentity
+ (let recur ((head (car lis)) (lis (cdr lis)))
+ (if (pair? lis)
+ (f head (recur (car lis) (cdr lis)))
+ head))))
+
+
+
+;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append-map f lis1 . lists)
+ (really-append-map append-map append f lis1 lists))
+(define (append-map! f lis1 . lists)
+ (really-append-map append-map! append! f lis1 lists))
+
+(define (really-append-map who appender f lis1 lists)
+ (srfi-1:check-arg procedure? f who)
+ (if (pair? lists)
+ (receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
+ (if (null? cars) '()
+ (let recur ((cars cars) (cdrs cdrs))
+ (let ((vals (apply f cars)))
+ (receive (cars2 cdrs2) (%cars+cdrs cdrs)
+ (if (null? cars2) vals
+ (appender vals (recur cars2 cdrs2))))))))
+
+ ;; Fast path
+ (if (null-list? lis1) '()
+ (let recur ((elt (car lis1)) (rest (cdr lis1)))
+ (let ((vals (f elt)))
+ (if (null-list? rest) vals
+ (appender vals (recur (car rest) (cdr rest)))))))))
+
+
+(define (pair-for-each proc lis1 . lists)
+ (srfi-1:check-arg procedure? proc pair-for-each)
+ (if (pair? lists)
+
+ (let lp ((lists (cons lis1 lists)))
+ (let ((tails (%cdrs lists)))
+ (if (pair? tails)
+ (begin (apply proc lists)
+ (lp tails)))))
+
+ ;; Fast path.
+ (let lp ((lis lis1))
+ (if (not (null-list? lis))
+ (let ((tail (cdr lis))) ; Grab the cdr now,
+ (proc lis) ; in case PROC SET-CDR!s LIS.
+ (lp tail))))))
+
+;;; We stop when LIS1 runs out, not when any list runs out.
+(define (map! f lis1 . lists)
+ (srfi-1:check-arg procedure? f map!)
+ (if (pair? lists)
+ (let lp ((lis1 lis1) (lists lists))
+ (if (not (null-list? lis1))
+ (receive (heads tails) (%cars+cdrs/no-test lists)
+ (set-car! lis1 (apply f (car lis1) heads))
+ (lp (cdr lis1) tails))))
+
+ ;; Fast path.
+ (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+ lis1)
+
+
+;;; Map F across L, and save up all the non-false results.
+(define (filter-map f lis1 . lists)
+ (srfi-1:check-arg procedure? f filter-map)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists)))
+ (receive (cars cdrs) (%cars+cdrs lists)
+ (if (pair? cars)
+ (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
+ (else (recur cdrs))) ; Tail call in this arm.
+ '())))
+
+ ;; Fast path.
+ (let recur ((lis lis1))
+ (if (null-list? lis) lis
+ (let ((tail (recur (cdr lis))))
+ (cond ((f (car lis)) => (lambda (x) (cons x tail)))
+ (else tail)))))))
+
+
+;;; Map F across lists, guaranteeing to go left-to-right.
+;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+;;; in which case this procedure may simply be defined as a synonym for MAP.
+
+(define (map-in-order f lis1 . lists)
+ (srfi-1:check-arg procedure? f map-in-order)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists)))
+ (receive (cars cdrs) (%cars+cdrs lists)
+ (if (pair? cars)
+ (let ((x (apply f cars))) ; Do head first,
+ (cons x (recur cdrs))) ; then tail.
+ '())))
+
+ ;; Fast path.
+ (let recur ((lis lis1))
+ (if (null-list? lis) lis
+ (let ((tail (cdr lis))
+ (x (f (car lis)))) ; Do head first,
+ (cons x (recur tail))))))) ; then tail.
+
+
+;;; We extend MAP to handle arguments of unequal length.
+;; (define map map-in-order)
+
+
+;;; filter, remove, partition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+;;; disorder the elements of their argument.
+
+;; This FILTER shares the longest tail of L that has no deleted elements.
+;; If Scheme had multi-continuation calls, they could be made more efficient.
+
+(define (filter pred lis) ; Sleazing with EQ? makes this
+ (srfi-1:check-arg procedure? pred filter) ; one faster.
+ (let recur ((lis lis))
+ (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
+ (let ((head (car lis))
+ (tail (cdr lis)))
+ (if (pred head)
+ (let ((new-tail (recur tail))) ; Replicate the RECUR call so
+ (if (eq? tail new-tail) lis
+ (cons head new-tail)))
+ (recur tail)))))) ; this one can be a tail call.
+
+
+;;; Another version that shares longest tail.
+;(define (filter pred lis)
+; (receive (ans no-del?)
+; ;; (recur l) returns L with (pred x) values filtered.
+; ;; It also returns a flag NO-DEL? if the returned value
+; ;; is EQ? to L, i.e. if it didn't have to delete anything.
+; (let recur ((l l))
+; (if (null-list? l) (values l #t)
+; (let ((x (car l))
+; (tl (cdr l)))
+; (if (pred x)
+; (receive (ans no-del?) (recur tl)
+; (if no-del?
+; (values l #t)
+; (values (cons x ans) #f)))
+; (receive (ans no-del?) (recur tl) ; Delete X.
+; (values ans #f))))))
+; ans))
+
+
+
+;(define (filter! pred lis) ; Things are much simpler
+; (let recur ((lis lis)) ; if you are willing to
+; (if (pair? lis) ; push N stack frames & do N
+; (cond ((pred (car lis)) ; SET-CDR! writes, where N is
+; (set-cdr! lis (recur (cdr lis))); the length of the answer.
+; lis)
+; (else (recur (cdr lis))))
+; lis)))
+
+
+;;; This implementation of FILTER!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+;;; usually expensive on modern machines, and can be extremely expensive on
+;;; modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the
+;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the
+;;; beginning of the next.
+
+(define (filter! pred lis)
+ (srfi-1:check-arg procedure? pred filter!)
+ (let lp ((ans lis))
+ (cond ((null-list? ans) ans) ; Scan looking for
+ ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result.
+
+ ;; ANS is the eventual answer.
+ ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
+ ;; Scan over a contiguous segment of the list that
+ ;; satisfies PRED.
+ ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
+ ;; segment of the list that *doesn't* satisfy PRED.
+ ;; When the segment ends, patch in a link from PREV
+ ;; to the start of the next good segment, and jump to
+ ;; SCAN-IN.
+ (else (letrec ((scan-in (lambda (prev lis)
+ (if (pair? lis)
+ (if (pred (car lis))
+ (scan-in lis (cdr lis))
+ (scan-out prev (cdr lis))))))
+ (scan-out (lambda (prev lis)
+ (let lp ((lis lis))
+ (if (pair? lis)
+ (if (pred (car lis))
+ (begin (set-cdr! prev lis)
+ (scan-in lis (cdr lis)))
+ (lp (cdr lis)))
+ (set-cdr! prev lis))))))
+ (scan-in ans (cdr ans))
+ ans)))))
+
+
+
+;;; Answers share common tail with LIS where possible;
+;;; the technique is slightly subtle.
+
+(define (partition pred lis)
+ (srfi-1:check-arg procedure? pred partition)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
+ (let ((elt (car lis))
+ (tail (cdr lis)))
+ (receive (in out) (recur tail)
+ (if (pred elt)
+ (values (if (pair? out) (cons elt in) lis) out)
+ (values in (if (pair? in) (cons elt out) lis))))))))
+
+
+
+;(define (partition! pred lis) ; Things are much simpler
+; (let recur ((lis lis)) ; if you are willing to
+; (if (null-list? lis) (values lis lis) ; push N stack frames & do N
+; (let ((elt (car lis))) ; SET-CDR! writes, where N is
+; (receive (in out) (recur (cdr lis)) ; the length of LIS.
+; (cond ((pred elt)
+; (set-cdr! lis in)
+; (values lis out))
+; (else (set-cdr! lis out)
+; (values in lis))))))))
+
+
+;;; This implementation of PARTITION!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+;;; usually expensive on modern machines, and can be extremely expensive on
+;;; modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the
+;;; minimal number of SET-CDR!s to splice these runs together into the result
+;;; lists.
+
+(define (partition! pred lis)
+ (srfi-1:check-arg procedure? pred partition!)
+ (if (null-list? lis) (values lis lis)
+
+ ;; This pair of loops zips down contiguous in & out runs of the
+ ;; list, splicing the runs together. The invariants are
+ ;; SCAN-IN: (cdr in-prev) = LIS.
+ ;; SCAN-OUT: (cdr out-prev) = LIS.
+ (letrec ((scan-in (lambda (in-prev out-prev lis)
+ (let lp ((in-prev in-prev) (lis lis))
+ (if (pair? lis)
+ (if (pred (car lis))
+ (lp lis (cdr lis))
+ (begin (set-cdr! out-prev lis)
+ (scan-out in-prev lis (cdr lis))))
+ (set-cdr! out-prev lis))))) ; Done.
+
+ (scan-out (lambda (in-prev out-prev lis)
+ (let lp ((out-prev out-prev) (lis lis))
+ (if (pair? lis)
+ (if (pred (car lis))
+ (begin (set-cdr! in-prev lis)
+ (scan-in lis out-prev (cdr lis)))
+ (lp lis (cdr lis)))
+ (set-cdr! in-prev lis)))))) ; Done.
+
+ ;; Crank up the scan&splice loops.
+ (if (pred (car lis))
+ ;; LIS begins in-list. Search for out-list's first pair.
+ (let lp ((prev-l lis) (l (cdr lis)))
+ (cond ((not (pair? l)) (values lis l))
+ ((pred (car l)) (lp l (cdr l)))
+ (else (scan-out prev-l l (cdr l))
+ (values lis l)))) ; Done.
+
+ ;; LIS begins out-list. Search for in-list's first pair.
+ (let lp ((prev-l lis) (l (cdr lis)))
+ (cond ((not (pair? l)) (values l lis))
+ ((pred (car l))
+ (scan-in l prev-l (cdr l))
+ (values l lis)) ; Done.
+ (else (lp l (cdr l)))))))))
+
+
+;;; Inline us, please.
+(define (remove pred l) (filter (lambda (x) (not (pred x))) l))
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+
+
+;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
+;;; (I don't actually think these are the world's most important
+;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
+;;; are far more general.)
+;;;
+;;; Function Action
+;;; ---------------------------------------------------------------------------
+;;; remove pred lis Delete by general predicate
+;;; delete x lis [=] Delete by element comparison
+;;;
+;;; find pred lis Search by general predicate
+;;; find-tail pred lis Search by general predicate
+;;; member x lis [=] Search by element comparison
+;;;
+;;; assoc key lis [=] Search alist by key comparison
+;;; alist-delete key alist [=] Alist-delete by key comparison
+
+(define (delete x lis . maybe-=)
+ (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (filter (lambda (y) (not (= x y))) lis)))
+
+(define (delete! x lis . maybe-=)
+ (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (filter! (lambda (y) (not (= x y))) lis)))
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define (member x lis . maybe-=)
+ (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (find-tail (lambda (y) (= x y)) lis)))
+
+;;; R4RS, hence we don't bother to define.
+;;; The MEMBER and then FIND-TAIL call should definitely
+;;; be inlined for MEMQ & MEMV.
+;(define (memq x lis) (member x lis eq?))
+;(define (memv x lis) (member x lis eqv?))
+
+
+;;; right-duplicate deletion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; delete-duplicates delete-duplicates!
+;;;
+;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
+;;; in long lists, sort the list to bring duplicates together, then use a
+;;; linear-time algorithm to kill the dups. Or use an algorithm based on
+;;; element-marking. The former gives you O(n lg n), the latter is linear.
+
+(define (delete-duplicates lis . maybe-=)
+ (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (srfi-1:check-arg procedure? elt= delete-duplicates)
+ (let recur ((lis lis))
+ (if (null-list? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (delete x tail elt=))))
+ (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+(define (delete-duplicates! lis maybe-=)
+ (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (srfi-1:check-arg procedure? elt= delete-duplicates!)
+ (let recur ((lis lis))
+ (if (null-list? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (delete! x tail elt=))))
+ (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+
+;;; alist stuff
+;;;;;;;;;;;;;;;
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define (assoc x lis . maybe-=)
+ (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (find (lambda (entry) (= x (car entry))) lis)))
+
+(define (alist-cons key datum alist) (cons (cons key datum) alist))
+
+(define (alist-copy alist)
+ (map (lambda (elt) (cons (car elt) (cdr elt)))
+ alist))
+
+(define (alist-delete key alist . maybe-=)
+ (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (filter (lambda (elt) (not (= key (car elt)))) alist)))
+
+(define (alist-delete! key alist . maybe-=)
+ (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
+ (filter! (lambda (elt) (not (= key (car elt)))) alist)))
+
+
+;;; find find-tail take-while drop-while span break any every list-index-pred
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (find pred list)
+ (cond ((find-tail pred list) => car)
+ (else #f)))
+
+(define (find-tail pred list)
+ (srfi-1:check-arg procedure? pred find-tail)
+ (let lp ((list list))
+ (and (not (null-list? list))
+ (if (pred (car list)) list
+ (lp (cdr list))))))
+
+(define (take-while pred lis)
+ (srfi-1:check-arg procedure? pred take-while)
+ (let recur ((lis lis))
+ (if (null-list? lis) '()
+ (let ((x (car lis)))
+ (if (pred x)
+ (cons x (recur (cdr lis)))
+ '())))))
+
+(define (drop-while pred lis)
+ (srfi-1:check-arg procedure? pred drop-while)
+ (let lp ((lis lis))
+ (if (null-list? lis) '()
+ (if (pred (car lis))
+ (lp (cdr lis))
+ lis))))
+
+(define (take-while! pred lis)
+ (srfi-1:check-arg procedure? pred take-while!)
+ (if (or (null-list? lis) (not (pred (car lis)))) '()
+ (begin (let lp ((prev lis) (rest (cdr lis)))
+ (if (pair? rest)
+ (let ((x (car rest)))
+ (if (pred x) (lp rest (cdr rest))
+ (set-cdr! prev '())))))
+ lis)))
+
+(define (span pred lis)
+ (srfi-1:check-arg procedure? pred span)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values '() '())
+ (let ((x (car lis)))
+ (if (pred x)
+ (receive (prefix suffix) (recur (cdr lis))
+ (values (cons x prefix) suffix))
+ (values '() lis))))))
+
+(define (span! pred lis)
+ (srfi-1:check-arg procedure? pred span!)
+ (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
+ (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
+ (if (null-list? rest) rest
+ (let ((x (car rest)))
+ (if (pred x) (lp rest (cdr rest))
+ (begin (set-cdr! prev '())
+ rest)))))))
+ (values lis suffix))))
+
+
+(define (break pred lis) (span (lambda (x) (not (pred x))) lis))
+(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
+
+(define (any pred lis1 . lists)
+ (srfi-1:check-arg procedure? pred any)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+ (and (pair? heads)
+ (let lp ((heads heads) (tails tails))
+ (receive (next-heads next-tails) (%cars+cdrs tails)
+ (if (pair? next-heads)
+ (or (apply pred heads) (lp next-heads next-tails))
+ (apply pred heads)))))) ; Last PRED app is tail call.
+
+ ;; Fast path
+ (and (not (null-list? lis1))
+ (let lp ((head (car lis1)) (tail (cdr lis1)))
+ (if (null-list? tail)
+ (pred head) ; Last PRED app is tail call.
+ (or (pred head) (lp (car tail) (cdr tail))))))))
+
+
+;(define (every pred list) ; Simple definition.
+; (let lp ((list list)) ; Doesn't return the last PRED value.
+; (or (not (pair? list))
+; (and (pred (car list))
+; (lp (cdr list))))))
+
+(define (every pred lis1 . lists)
+ (srfi-1:check-arg procedure? pred every)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+ (or (not (pair? heads))
+ (let lp ((heads heads) (tails tails))
+ (receive (next-heads next-tails) (%cars+cdrs tails)
+ (if (pair? next-heads)
+ (and (apply pred heads) (lp next-heads next-tails))
+ (apply pred heads)))))) ; Last PRED app is tail call.
+
+ ;; Fast path
+ (or (null-list? lis1)
+ (let lp ((head (car lis1)) (tail (cdr lis1)))
+ (if (null-list? tail)
+ (pred head) ; Last PRED app is tail call.
+ (and (pred head) (lp (car tail) (cdr tail))))))))
+
+(define (list-index-pred pred lis1 . lists)
+ (srfi-1:check-arg procedure? pred list-index-pred)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (let lp ((lists (cons lis1 lists)) (n 0))
+ (receive (heads tails) (%cars+cdrs lists)
+ (and (pair? heads)
+ (if (apply pred heads) n
+ (lp tails (+ n 1))))))
+
+ ;; Fast path
+ (let lp ((lis lis1) (n 0))
+ (and (not (null-list? lis))
+ (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+;;; Reverse
+;;;;;;;;;;;
+
+;R4RS, so not defined here.
+;(define (reverse lis) (fold cons '() lis))
+
+;(define (reverse! lis)
+; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
+
+(define (reverse! lis)
+ (let lp ((lis lis) (ans '()))
+ (if (null-list? lis) ans
+ (let ((tail (cdr lis)))
+ (set-cdr! lis ans)
+ (lp tail lis)))))
+
+;;; Lists-as-sets
+;;;;;;;;;;;;;;;;;
+
+;;; This is carefully tuned code; do not modify casually.
+;;; - It is careful to share storage when possible;
+;;; - Side-effecting code tries not to perform redundant writes.
+;;; - It tries to avoid linear-time scans in special cases where constant-time
+;;; computations can be performed.
+;;; - It relies on similar properties from the other list-lib procs it calls.
+;;; For example, it uses the fact that the implementations of MEMBER and
+;;; FILTER in this source code share longest common tails between args
+;;; and results to get structure sharing in the lset procedures.
+
+(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
+
+(define (lset<= = . lists)
+ (srfi-1:check-arg procedure? = lset<=)
+ (or (not (pair? lists)) ; 0-ary case
+ (let lp ((s1 (car lists)) (rest (cdr lists)))
+ (or (not (pair? rest))
+ (let ((s2 (car rest)) (rest (cdr rest)))
+ (and (or (eq? s2 s1) ; Fast path
+ (%lset2<= = s1 s2)) ; Real test
+ (lp s2 rest)))))))
+
+(define (lset= = . lists)
+ (srfi-1:check-arg procedure? = lset=)
+ (or (not (pair? lists)) ; 0-ary case
+ (let lp ((s1 (car lists)) (rest (cdr lists)))
+ (or (not (pair? rest))
+ (let ((s2 (car rest))
+ (rest (cdr rest)))
+ (and (or (eq? s1 s2) ; Fast path
+ (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
+ (lp s2 rest)))))))
+
+
+(define (lset-adjoin = lis . elts)
+ (srfi-1:check-arg procedure? = lset-adjoin)
+ (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
+ lis elts))
+
+
+(define (lset-union = . lists)
+ (srfi-1:check-arg procedure? = lset-union)
+ (reduce (lambda (lis ans) ; Compute ANS + LIS.
+ (cond ((null? lis) ans) ; Don't copy any lists
+ ((null? ans) lis) ; if we don't have to.
+ ((eq? lis ans) ans)
+ (else
+ (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
+ ans
+ (cons elt ans)))
+ ans lis))))
+ '() lists))
+
+(define (lset-union! = . lists)
+ (srfi-1:check-arg procedure? = lset-union!)
+ (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS.
+ (cond ((null? lis) ans) ; Don't copy any lists
+ ((null? ans) lis) ; if we don't have to.
+ ((eq? lis ans) ans)
+ (else
+ (pair-fold (lambda (pair ans)
+ (let ((elt (car pair)))
+ (if (any (lambda (x) (= x elt)) ans)
+ ans
+ (begin (set-cdr! pair ans) pair))))
+ ans lis))))
+ '() lists))
+
+
+(define (lset-intersection = lis1 . lists)
+ (srfi-1:check-arg procedure? = lset-intersection)
+ (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+ (cond ((any null-list? lists) '()) ; Short cut
+ ((null? lists) lis1) ; Short cut
+ (else (filter (lambda (x)
+ (every (lambda (lis) (member x lis =)) lists))
+ lis1)))))
+
+(define (lset-intersection! = lis1 . lists)
+ (srfi-1:check-arg procedure? = lset-intersection!)
+ (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+ (cond ((any null-list? lists) '()) ; Short cut
+ ((null? lists) lis1) ; Short cut
+ (else (filter! (lambda (x)
+ (every (lambda (lis) (member x lis =)) lists))
+ lis1)))))
+
+
+(define (lset-difference = lis1 . lists)
+ (srfi-1:check-arg procedure? = lset-difference)
+ (let ((lists (filter pair? lists))) ; Throw out empty lists.
+ (cond ((null? lists) lis1) ; Short cut
+ ((memq lis1 lists) '()) ; Short cut
+ (else (filter (lambda (x)
+ (every (lambda (lis) (not (member x lis =)))
+ lists))
+ lis1)))))
+
+(define (lset-difference! = lis1 . lists)
+ (srfi-1:check-arg procedure? = lset-difference!)
+ (let ((lists (filter pair? lists))) ; Throw out empty lists.
+ (cond ((null? lists) lis1) ; Short cut
+ ((memq lis1 lists) '()) ; Short cut
+ (else (filter! (lambda (x)
+ (every (lambda (lis) (not (member x lis =)))
+ lists))
+ lis1)))))
+
+
+(define (lset-xor = . lists)
+ (srfi-1:check-arg procedure? = lset-xor)
+ (reduce (lambda (b a) ; Compute A xor B:
+ ;; Note that this code relies on the constant-time
+ ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+ ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+ ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+ ;; a careful case analysis to see it, but it's carefully
+ ;; built in.
+
+ ;; Compute a-b and a^b, then compute b-(a^b) and
+ ;; cons it onto the front of a-b.
+ (receive (a-b a-int-b) (lset-diff+intersection = a b)
+ (cond ((null? a-b) (lset-difference b a =))
+ ((null? a-int-b) (append b a))
+ (else (fold (lambda (xb ans)
+ (if (member xb a-int-b =) ans (cons xb ans)))
+ a-b
+ b)))))
+ '() lists))
+
+
+(define (lset-xor! = . lists)
+ (srfi-1:check-arg procedure? = lset-xor!)
+ (reduce (lambda (b a) ; Compute A xor B:
+ ;; Note that this code relies on the constant-time
+ ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+ ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+ ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+ ;; a careful case analysis to see it, but it's carefully
+ ;; built in.
+
+ ;; Compute a-b and a^b, then compute b-(a^b) and
+ ;; cons it onto the front of a-b.
+ (receive (a-b a-int-b) (lset-diff+intersection! = a b)
+ (cond ((null? a-b) (lset-difference! b a =))
+ ((null? a-int-b) (append! b a))
+ (else (pair-fold (lambda (b-pair ans)
+ (if (member (car b-pair) a-int-b =) ans
+ (begin (set-cdr! b-pair ans) b-pair)))
+ a-b
+ b)))))
+ '() lists))
+
+
+(define (lset-diff+intersection = lis1 . lists)
+ (srfi-1:check-arg procedure? = lset-diff+intersection)
+ (cond ((every null-list? lists) (values lis1 '())) ; Short cut
+ ((memq lis1 lists) (values '() lis1)) ; Short cut
+ (else (partition (lambda (elt)
+ (not (any (lambda (lis) (member elt lis =))
+ lists)))
+ lis1))))
+
+(define (lset-diff+intersection! = lis1 . lists)
+ (srfi-1:check-arg procedure? = lset-diff+intersection!)
+ (cond ((every null-list? lists) (values lis1 '())) ; Short cut
+ ((memq lis1 lists) (values '() lis1)) ; Short cut
+ (else (partition! (lambda (elt)
+ (not (any (lambda (lis) (member elt lis =))
+ lists)))
+ lis1))))
Index: gnucash/lib/srfi/srfi-11.scm
diff -u /dev/null gnucash/lib/srfi/srfi-11.scm:1.1
--- /dev/null Wed May 16 08:02:00 2001
+++ gnucash/lib/srfi/srfi-11.scm Tue May 15 10:48:43 2001
@@ -0,0 +1,234 @@
+;;;; srfi-11.scm --- SRFI-11 procedures for Guile
+
+;;; Copyright (C) 2000 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., 59 Temple Place, Suite 330,
+;;; Boston, MA 02111-1307 USA
+
+(define-module (srfi srfi-11)
+ :use-module (ice-9 syncase))
+
+(export-syntax let-values let*-values)
+
+;;;;;;;;;;;;;;
+;; let-values
+;;
+;; Current approach is to translate
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (<tmp-x> <tmp-y> . <tmp-z>)
+;; (call-with-values (lambda () (bar c))
+;; (lambda (<tmp-p> <tmp-q>)
+;; (let ((x <tmp-x>)
+;; (y <tmp-y>)
+;; (z <tmp-z>)
+;; (p <tmp-p>)
+;; (q <tmp-q>))
+;; (baz x y z p q))))))
+
+;; I originally wrote this as a define-macro, but then I found out
+;; that guile's gensym/gentemp was broken, so I tried rewriting it as
+;; a syntax-rules statement.
+;;
+;; Since syntax-rules didn't seem powerful enough to implement
+;; let-values in one definition without exposing illegal syntax (or
+;; perhaps my brain's just not powerful enough :>). I tried writing
+;; it using a private helper, but that didn't work because the
+;; let-values expands outside the scope of this module. I wonder why
+;; syntax-rules wasn't designed to allow "private" patterns or
+;; similar...
+;;
+;; So in the end, I dumped the syntax-rules implementation, reproduced
+;; here for posterity, and went with the define-macro one below --
+;; gensym/gentemp's got to be fixed anyhow...
+;
+; (define-syntax let-values-helper
+; (syntax-rules ()
+; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
+; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
+; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
+; ;; temps you create so you can use them later...
+; ;;
+; ;; I really don't fully understand why the (var-1 var-1) trick
+; ;; works below, but basically, when all those (x x) bindings show
+; ;; up in the final "let", syntax-rules forces a renaming.
+
+; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
+; body ...)
+; (lambda lambda-tmps
+; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
+
+; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
+; body ...)
+; (let-values-helper "consumer"
+; (var-2 ...)
+; (lambda-tmp ... var-1)
+; ((var-1 var-1) . final-let-bindings)
+; lv-bindings
+; body ...))
+
+; ((_ "cwv" () final-let-bindings body ...)
+; (let final-let-bindings
+; body ...))
+
+; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
+; body ...)
+; (call-with-values (lambda () binding-1)
+; (let-values-helper "consumer"
+; vars-1
+; ()
+; final-let-bindings
+; (other-bindings ...)
+; body ...)))))
+;
+; (define-syntax let-values
+; (syntax-rules ()
+; ((let-values () body ...)
+; (begin body ...))
+; ((let-values (binding ...) body ...)
+; (let-values-helper "cwv" (binding ...) () body ...))))
+;
+;
+; (define-syntax let-values
+; (letrec-syntax ((build-consumer
+; ;; Take the vars from one let binding (i.e. the (x
+; ;; y z) from ((x y z) (values 1 2 3)) and turn it
+; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
+; ;; <tmp-z>) ...) from above.
+; (syntax-rules ()
+; ((_ () new-tmps tmp-vars () body ...)
+; (lambda new-tmps
+; body ...))
+; ((_ () new-tmps tmp-vars vars body ...)
+; (lambda new-tmps
+; (lv-builder vars tmp-vars body ...)))
+; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
+; (build-consumer (var-2 ...)
+; (tmp-1 . new-tmps)
+; ((var-1 tmp-1) . tmp-vars)
+; bindings
+; body ...))))
+; (lv-builder
+; (syntax-rules ()
+; ((_ () tmp-vars body ...)
+; (let tmp-vars
+; body ...))
+; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
+; tmp-vars
+; body ...)
+; (call-with-values (lambda () binding-1)
+; (build-consumer vars-1
+; ()
+; tmp-vars
+; ((vars-2 binding-2) ...)
+; body ...))))))
+;
+; (syntax-rules ()
+; ((_ () body ...)
+; (begin body ...))
+; ((_ ((vars binding) ...) body ...)
+; (lv-builder ((vars binding) ...) () body ...)))))
+
+;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is
+;; broken -- right now (as of 1.4.1, it doesn't generate unique
+;; symbols)
+(define-macro (let-values vars . body)
+
+ (define (map-1-dot proc elts)
+ ;; map over one optionally dotted (a b c . d) list, producing an
+ ;; optionally dotted result.
+ (cond
+ ((null? elts) '())
+ ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
+ (else (proc elts))))
+
+ (define (undot-list lst)
+ ;; produce a non-dotted list from a possibly dotted list.
+ (cond
+ ((null? lst) '())
+ ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
+ (else (list lst))))
+
+ (define (let-values-helper vars body prev-let-vars)
+ (let* ((var-binding (car vars))
+ (new-tmps (map-1-dot (lambda (sym) (gentemp))
+ (car var-binding)))
+ (let-vars (map (lambda (sym tmp) (list sym tmp))
+ (undot-list (car var-binding))
+ (undot-list new-tmps))))
+
+ (if (null? (cdr vars))
+ `(call-with-values (lambda () ,(cadr var-binding))
+ (lambda ,new-tmps
+ (let ,(apply append let-vars prev-let-vars)
+ ,@body)))
+ `(call-with-values (lambda () ,(cadr var-binding))
+ (lambda ,new-tmps
+ ,(let-values-helper (cdr vars) body
+ (cons let-vars prev-let-vars)))))))
+
+ (if (null? vars)
+ `(begin ,@body)
+ (let-values-helper vars body '())))
+
+;;;;;;;;;;;;;;
+;; let*-values
+;;
+;; Current approach is to translate
+;;
+;; (let*-values (((x y z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (x y z)
+;; (call-with-values (lambda (bar c))
+;; (lambda (p q)
+;; (baz x y z p q)))))
+
+(define-syntax let*-values
+ (syntax-rules ()
+ ((let*-values () body ...)
+ (begin body ...))
+ ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
+ (call-with-values (lambda () binding-1)
+ (lambda vars-1
+ (let*-values ((vars-2 binding-2) ...)
+ body ...))))))
+
+; Alternate define-macro implementation...
+;
+; (define-macro (let*-values vars . body)
+; (define (let-values-helper vars body)
+; (let ((var-binding (car vars)))
+; (if (null? (cdr vars))
+; `(call-with-values (lambda () ,(cadr var-binding))
+; (lambda ,(car var-binding)
+; ,@body))
+; `(call-with-values (lambda () ,(cadr var-binding))
+; (lambda ,(car var-binding)
+; ,(let-values-helper (cdr vars) body))))))
+
+; (if (null? vars)
+; `(begin ,@body)
+; (let-values-helper vars body)))
Index: gnucash/lib/srfi/srfi-19.scm
diff -u /dev/null gnucash/lib/srfi/srfi-19.scm:1.1
--- /dev/null Wed May 16 08:02:00 2001
+++ gnucash/lib/srfi/srfi-19.scm Tue May 15 10:48:43 2001
@@ -0,0 +1,1492 @@
+;;; srfi-19.scm --- SRFI-19 procedures for Guile
+;;;
+;;; Copyright (C) 2001 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., 59 Temple Place, Suite 330,
+;;; Boston, MA 02111-1307 USA
+;;;
+;;; Originally from SRFI reference implementation by Will Fitzgerald.
+;;; Ported to Guile by Rob Browning <rlb@cs.utexas.edu>
+
+;; FIXME: I haven't checked a decent amount of this code for potential
+;; performance improvements, but I suspect that there may be some
+;; substantial ones to be realized, esp. in the later "parsing" half
+;; of the file, by rewriting the code with use of more Guile native
+;; functions that do more work in a "chunk".
+
+(define-module (srfi srfi-19)
+ :use-module (ice-9 syncase)
+ :use-module (srfi srfi-8)
+ :use-module (srfi srfi-9))
+
+(export
+ ;; Constants
+ time-duration
+ time-monotonic
+ time-process
+ time-tai
+ time-thread
+ time-utc
+ ;; Current time and clock resolution
+ current-date
+ current-julian-day
+ current-modified-julian-day
+ current-time
+ time-resolution
+ ;; Time object and accessors
+ make-time
+ time?
+ time-type
+ time-nanosecond
+ time-second
+ set-time-type!
+ set-time-nanosecond!
+ set-time-second!
+ copy-time
+ ;; Time comparison procedures
+ time<=?
+ time<?
+ time=?
+ time>=?
+ time>?
+ ;; Time arithmetic procedures
+ time-difference
+ time-difference!
+ add-duration
+ add-duration!
+ subtract-duration
+ subtract-duration!
+ ;; Date object and accessors
+ make-date
+ date?
+ date-nanosecond
+ date-second
+ date-minute
+ date-hour
+ date-day
+ date-month
+ date-year
+ date-zone-offset?
+ date-year-day
+ date-week-day
+ date-week-number
+ ;; Time/Date/Julian Day/Modified Julian Day converters
+ date->julian-day
+ date->modified-julian-day
+ date->time-monotonic
+ date->time-tai
+ date->time-utc
+ julian-day->date
+ julian-day->time-monotonic
+ julian-day->time-tai
+ julian-day->time-utc
+ modified-julian-day->date
+ modified-julian-day->time-monotonic
+ modified-julian-day->time-tai
+ modified-julian-day->time-utc
+ time-monotonic->date
+ time-monotonic->time-monotonic
+ time-monotonic->time-tai
+ time-monotonic->time-tai!
+ time-monotonic->time-utc
+ time-monotonic->time-utc!
+ time-tai->date
+ time-tai->julian-day
+ time-tai->modified-julian-day
+ time-tai->time-monotonic
+ time-tai->time-monotonic!
+ time-tai->time-utc
+ time-tai->time-utc!
+ time-utc->date
+ time-utc->julian-day
+ time-utc->modified-julian-day
+ time-utc->time-monotonic
+ time-utc->time-monotonic!
+ time-utc->time-tai
+ time-utc->time-tai!
+ ;; Date to string/string to date converters.
+ date->string
+ string->date)
+
+;; Guile's prior to 1.5.X didn't have this.
+(define (priv:open-input-string str)
+ (call-with-input-string str (lambda (port)
+ port)))
+
+;; :OPTIONAL is nice
+
+(define-syntax :optional
+ (syntax-rules ()
+ ((_ val default-value)
+ (if (null? val) default-value (car val)))))
+
+(define time-tai 'time-tai)
+(define time-utc 'time-utc)
+(define time-monotonic 'time-monotonic)
+(define time-thread 'time-thread)
+(define time-process 'time-process)
+(define time-duration 'time-duration)
+
+;; FIXME: do we want to add gc time?
+;; (define time-gc 'time-gc)
+
+;;-- LOCALE dependent constants
+
+(define priv:locale-number-separator ".")
+
+(define priv:locale-abbr-weekday-vector
+ (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+
+(define priv:locale-long-weekday-vector
+ (vector
+ "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+
+;; note empty string in 0th place.
+(define priv:locale-abbr-month-vector
+ (vector ""
+ "Jan"
+ "Feb"
+ "Mar"
+ "Apr"
+ "May"
+ "Jun"
+ "Jul"
+ "Aug"
+ "Sep"
+ "Oct"
+ "Nov"
+ "Dec"))
+
+(define priv:locale-long-month-vector
+ (vector ""
+ "January"
+ "February"
+ "March"
+ "April"
+ "May"
+ "June"
+ "July"
+ "August"
+ "September"
+ "October"
+ "November"
+ "December"))
+
+(define priv:locale-pm "PM")
+(define priv:locale-am "AM")
+
+;; See date->string
+(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
+(define priv:locale-short-date-format "~m/~d/~y")
+(define priv:locale-time-format "~H:~M:~S")
+(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
+
+;;-- Miscellaneous Constants.
+;;-- only the priv:tai-epoch-in-jd might need changing if
+;; a different epoch is used.
+
+(define priv:nano 1000000000) ; nanoseconds in a second
+(define priv:sid 86400) ; seconds in a day
+(define priv:sihd 43200) ; seconds in a half day
+(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
+
+;; FIXME: should this be something other than misc-error?
+(define (priv:time-error caller type value)
+ (if value
+ (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
+ (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
+
+;; A table of leap seconds
+;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
+;; and update as necessary.
+;; this procedures reads the file in the abover
+;; format and creates the leap second table
+;; it also calls the almost standard, but not R5 procedures read-line
+;; & open-input-string
+;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))
+
+(define (priv:read-tai-utc-data filename)
+ (define (convert-jd jd)
+ (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid))
+ (define (convert-sec sec)
+ (inexact->exact sec))
+ (let ((port (open-input-file filename))
+ (table '()))
+ (let loop ((line (read-line port)))
+ (if (not (eq? line eof))
+ (begin
+ (let* ((data (read (priv:open-input-string
+ (string-append "(" line ")"))))
+ (year (car data))
+ (jd (cadddr (cdr data)))
+ (secs (cadddr (cdddr data))))
+ (if (>= year 1972)
+ (set! table (cons
+ (cons (convert-jd jd) (convert-sec secs))
+ table)))
+ (loop (read-line port))))))
+ table))
+
+;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
+;; note they go higher to lower, and end in 1972.
+(define priv:leap-second-table
+ '((915148800 . 32)
+ (867715200 . 31)
+ (820454400 . 30)
+ (773020800 . 29)
+ (741484800 . 28)
+ (709948800 . 27)
+ (662688000 . 26)
+ (631152000 . 25)
+ (567993600 . 24)
+ (489024000 . 23)
+ (425865600 . 22)
+ (394329600 . 21)
+ (362793600 . 20)
+ (315532800 . 19)
+ (283996800 . 18)
+ (252460800 . 17)
+ (220924800 . 16)
+ (189302400 . 15)
+ (157766400 . 14)
+ (126230400 . 13)
+ (94694400 . 12)
+ (78796800 . 11)
+ (63072000 . 10)))
+
+(define (read-leap-second-table filename)
+ (set! priv:leap-second-table (priv:read-tai-utc-data filename))
+ (values))
+
+
+(define (priv:leap-second-delta utc-seconds)
+ (letrec ((lsd (lambda (table)
+ (cond ((>= utc-seconds (caar table))
+ (cdar table))
+ (else (lsd (cdr table)))))))
+ (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0
+ (lsd priv:leap-second-table))))
+
+
+;;; the TIME structure; creates the accessors, too.
+
+(define-record-type time
+ (make-time-unnormalized type nanosecond second)
+ time?
+ (type time-type set-time-type!)
+ (nanosecond time-nanosecond set-time-nanosecond!)
+ (second time-second set-time-second!))
+
+(define (copy-time time)
+ (make-time (time-type time) (time-nanosecond time) (time-second time)))
+
+(define (priv:time-normalize! t)
+ (if (>= (abs (time-nanosecond t)) 1000000000)
+ (begin
+ (set-time-second! t (+ (time-second t)
+ (quotient (time-nanosecond t) 1000000000)))
+ (set-time-nanosecond! t (remainder (time-nanosecond t)
+ 1000000000))))
+ (if (and (positive? (time-second t))
+ (negative? (time-nanosecond t)))
+ (begin
+ (set-time-second! t (- (time-second t) 1))
+ (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
+ (if (and (negative? (time-second t))
+ (positive? (time-nanosecond t)))
+ (begin
+ (set-time-second! t (+ (time-second t) 1))
+ (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
+ t)
+
+(define (make-time type nanosecond second)
+ (priv:time-normalize! (make-time-unnormalized type nanosecond second)))
+
+;; Helpers
+;; FIXME: finish this and publish it?
+(define (date->broken-down-time date)
+ (let ((result (mktime 0)))
+ ;; FIXME: What should we do about leap-seconds which may overflow
+ ;; set-tm:sec?
+ (set-tm:sec result (date-second date))
+ (set-tm:min result (date-minute date))
+ (set-tm:hour result (date-hour date))
+ ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday).
+ (set-tm:mday result (date-day date))
+ (set-tm:month result (- (date-month date) 1))
+ ;; FIXME: need to signal error on range violation.
+ (set-tm:year result (+ 1900 (date-year date)))
+ (set-tm:isdst result -1)
+ (set-tm:gmtoff result (- (date-zone-offset date)))
+ result))
+
+;;; current-time
+
+;;; specific time getters.
+
+(define (priv:current-time-utc)
+ ;; Resolution is microseconds.
+ (let ((tod (gettimeofday)))
+ (make-time time-utc (* (cdr tod) 1000) (car tod))))
+
+(define (priv:current-time-tai)
+ ;; Resolution is microseconds.
+ (let* ((tod (gettimeofday))
+ (sec (car tod))
+ (usec (cdr tod)))
+ (make-time time-tai
+ (* usec 1000)
+ (+ (car tod) (priv:leap-second-delta seconds)))))
+
+;;(define (priv:current-time-ms-time time-type proc)
+;; (let ((current-ms (proc)))
+;; (make-time time-type
+;; (quotient current-ms 10000)
+;; (* (remainder current-ms 1000) 10000))))
+
+;; -- we define it to be the same as TAI.
+;; A different implemation of current-time-montonic
+;; will require rewriting all of the time-monotonic converters,
+;; of course.
+
+(define (priv:current-time-monotonic)
+ ;; Resolution is microseconds.
+ (priv:current-time-tai))
+
+(define (priv:current-time-thread)
+ (priv:time-error 'current-time 'unsupported-clock-type 'time-thread))
+
+(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
+
+(define (priv:current-time-process)
+ (let ((run-time (get-internal-run-time)))
+ (make-time
+ time-process
+ (quotient run-time internal-time-units-per-second)
+ (* (remainder run-time internal-time-units-per-second)
+ priv:ns-per-guile-tick))))
+
+(define (priv:current-time-process)
+ (let ((run-time (get-internal-run-time)))
+ (list
+ 'time-process
+ (* (remainder run-time internal-time-units-per-second)
+ priv:ns-per-guile-tick)
+ (quotient run-time internal-time-units-per-second))))
+
+;;(define (priv:current-time-gc)
+;; (priv:current-time-ms-time time-gc current-gc-milliseconds))
+
+(define (current-time . clock-type)
+ (let ((clock-type (:optional clock-type time-utc)))
+ (cond
+ ((eq? clock-type time-tai) (priv:current-time-tai))
+ ((eq? clock-type time-utc) (priv:current-time-utc))
+ ((eq? clock-type time-monotonic) (priv:current-time-monotonic))
+ ((eq? clock-type time-thread) (priv:current-time-thread))
+ ((eq? clock-type time-process) (priv:current-time-process))
+ ;; ((eq? clock-type time-gc) (priv:current-time-gc))
+ (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))
+
+;; -- Time Resolution
+;; This is the resolution of the clock in nanoseconds.
+;; This will be implementation specific.
+
+(define (time-resolution . clock-type)
+ (let ((clock-type (:optional clock-type time-utc)))
+ (case clock-type
+ ((time-tai) 1000)
+ ((time-utc) 1000)
+ ((time-monotonic) 1000)
+ ((time-process) priv:ns-per-guile-tick)
+ ;; ((eq? clock-type time-thread) 1000)
+ ;; ((eq? clock-type time-gc) 10000)
+ (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type)))))
+
+;; -- Time comparisons
+
+(define (time=? t1 t2)
+ ;; Arrange tests for speed and presume that t1 and t2 are actually times.
+ ;; also presume it will be rare to check two times of different types.
+ (and (= (time-second t1) (time-second t2))
+ (= (time-nanosecond t1) (time-nanosecond 2))
+ (eq? (time-type t1) (time-type t2))))
+
+(define (time>? t1 t2)
+ (or (> (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (> (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<? t1 t2)
+ (or (< (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (< (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time>=? t1 t2)
+ (or (> (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (>= (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<=? t1 t2)
+ (or (< (time-second time1) (time-second time2))
+ (and (= (time-second time1) (time-second time2))
+ (<= (time-nanosecond time1) (time-nanosecond time2)))))
+
+;; -- Time arithmetic
+
+(define (time-difference! time1 time2)
+ (let ((sec-diff (- (time-second time1) (time-second time2)))
+ (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
+ (set-time-type! time1 time-duration)
+ (set-time-second! time1 sec-diff)
+ (set-time-nanosecond! time1 nsec-diff)
+ (priv:time-normalize! time1)))
+
+(define (time-difference time1 time2)
+ (let ((result (copy-time time1)))
+ (time-difference! result time2)))
+
+(define (add-duration! t duration)
+ (if (not (eq? (time-type duration) time-duration))
+ (priv:time-error 'add-duration 'not-duration duration)
+ (let ((sec-plus (+ (time-second t) (time-second duration)))
+ (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
+ (set-time-second! t sec-plus)
+ (set-time-nanosecond! t nsec-plus)
+ (priv:time-normalize! t))))
+
+(define (priv:add-duration t duration)
+ (let ((result (copy-time t)))
+ (add-duration! result)))
+
+(define (subtract-duration! t duration)
+ (if (not (eq? (time-type duration) time-duration))
+ (priv:time-error 'add-duration 'not-duration duration)
+ (let ((sec-minus (- (time-second t) (time-second duration)))
+ (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
+ (set-time-second! t sec-minus)
+ (set-time-nanosecond! t nsec-minus)
+ (priv:time-normalize! t))))
+
+(define (subtract-duration time1 duration)
+ (let ((result (copy-time time1)))
+ (subtract-duration! result duration)))
+
+;; -- Converters between types.
+
+(define (priv:time-tai->time-utc! time-in time-out caller)
+ (if (not (eq? (time-type time-in) time-tai))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-out time-utc)
+ (set-time-nanosecond! time-out (time-nanosecond time-in))
+ (set-time-second! time-out (- (time-second time-in)
+ (priv:leap-second-delta
+ (time-second time-in))))
+ time-out)
+
+(define (time-tai->time-utc time-in)
+ (priv:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc))
+
+
+(define (time-tai->time-utc! time-in)
+ (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
+
+(define (priv:time-utc->time-tai! time-in time-out caller)
+ (if (not (eq? (time-type time-in) time-utc))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-out time-tai)
+ (set-time-nanosecond! time-out (time-nanosecond time-in))
+ (set-time-second! time-out (+ (time-second time-in)
+ (priv:leap-second-delta
+ (time-second time-in))))
+ time-out)
+
+(define (time-utc->time-tai time-in)
+ (priv:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai))
+
+(define (time-utc->time-tai! time-in)
+ (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
+
+;; -- these depend on time-monotonic having the same definition as time-tai!
+(define (time-monotonic->time-utc time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-tai)
+ (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
+
+(define (time-monotonic->time-utc! time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-in time-tai)
+ (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))
+
+(define (time-monotonic->time-tai time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-tai)
+ ntime))
+
+(define (time-monotonic->time-tai! time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-in time-tai)
+ time-in)
+
+(define (time-utc->time-monotonic time-in)
+ (if (not (eq? (time-type time-in) time-utc))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (let ((ntime (priv:time-utc->time-tai! time-in (make-time #f #f #f)
+ 'time-utc->time-monotonic)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-utc->time-monotonic! time-in)
+ (if (not (eq? (time-type time-in) time-utc))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (let ((ntime (priv:time-utc->time-tai! time-in time-in
+ 'time-utc->time-monotonic!)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-tai->time-monotonic time-in)
+ (if (not (eq? (time-type time-in) time-tai))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-tai->time-monotonic! time-in)
+ (if (not (eq? (time-type time-in) time-tai))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-in time-monotonic)
+ time-in)
+
+;; -- Date Structures
+
+(define-record-type date
+ (make-date-unnormalized nanosecond second minute
+ hour day month
+ year
+ zone-offset)
+ date?
+ (nanosecond date-nanosecond)
+ (second date-second)
+ (minute date-minute)
+ (hour date-hour)
+ (day date-day)
+ (month date-month)
+ (year date-year)
+ (zone-offset date-zone-offset))
+
+;; gives the julian day which starts at noon.
+(define (priv:encode-julian-day-number day month year)
+ (let* ((a (quotient (- 14 month) 12))
+ (y (- (+ year 4800) a (if (negative? year) -1 0)))
+ (m (- (+ month (* 12 a)) 3)))
+ (+ day
+ (quotient (+ (* 153 m) 2) 5)
+ (* 365 y)
+ (quotient y 4)
+ (- (quotient y 100))
+ (quotient y 400)
+ -32045)))
+
+(define (priv:split-real r)
+ (if (integer? r) (values r 0)
+ (let ((l (truncate r)))
+ (values l (- r l)))))
+
+;; gives the seconds/date/month/year
+(define (priv:decode-julian-day-number jdn)
+ (let* ((days (truncate jdn))
+ (a (+ days 32044))
+ (b (quotient (+ (* 4 a) 3) 146097))
+ (c (- a (quotient (* 146097 b) 4)))
+ (d (quotient (+ (* 4 c) 3) 1461))
+ (e (- c (quotient (* 1461 d) 4)))
+ (m (quotient (+ (* 5 e) 2) 153))
+ (y (+ (* 100 b) d -4800 (quotient m 10))))
+ (values ; seconds date month year
+ (* (- jdn days) priv:sid)
+ (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
+ (+ m 3 (* -12 (quotient m 10)))
+ (if (>= 0 y) (- y 1) y))))
+
+;; relies on the fact that we named our time zone accessor
+;; differently from MzScheme's....
+;; This should be written to be OS specific.
+
+(define (priv:local-tz-offset)
+ ;; SRFI uses seconds West, but guile (and libc) use seconds East.
+ (- (tm:gmtoff (localtime 0))))
+
+;; special thing -- ignores nanos
+(define (priv:time->julian-day-number seconds tz-offset)
+ (+ (/ (+ seconds tz-offset priv:sihd)
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (priv:leap-second? second)
+ (and (assoc second priv:leap-second-table) #t))
+
+(define (time-utc->date time . tz-offset)
+ (if (not (eq? (time-type time) time-utc))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (:optional tz-offset (priv:local-tz-offset)))
+ (leap-second? (priv:leap-second? (+ offset (time-second time))))
+ (jdn (priv:time->julian-day-number (if leap-second?
+ (- (time-second time) 1)
+ (time-second time))
+ offset)))
+
+ (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ (let* ((hours (quotient secs (* 60 60)))
+ (rem (remainder secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+(define (time-tai->date time . tz-offset)
+ (if (not (eq? (time-type time) time-tai))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (:optional tz-offset (priv:local-tz-offset)))
+ (seconds (- (time-second time)
+ (priv:leap-second-delta (time-second time))))
+ (leap-second? (priv:leap-second? (+ offset seconds)))
+ (jdn (priv:time->julian-day-number (if leap-second?
+ (- seconds 1)
+ seconds)
+ offset)))
+ (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; adjust for leap seconds if necessary ...
+ (let* ((hours (quotient secs (* 60 60)))
+ (rem (remainder secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+;; this is the same as time-tai->date.
+(define (time-monotonic->date time . tz-offset)
+ (if (not (eq? (time-type time) time-monotonic))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (:optional tz-offset (priv:local-tz-offset)))
+ (seconds (- (time-second time)
+ (priv:leap-second-delta (time-second time))))
+ (leap-second? (priv:leap-second? (+ offset seconds)))
+ (jdn (priv:time->julian-day-number (if leap-second?
+ (- seconds 1)
+ seconds)
+ offset)))
+ (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; adjust for leap seconds if necessary ...
+ (let* ((hours (quotient secs (* 60 60)))
+ (rem (remainder secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+(define (date->time-utc date)
+ (let ((jdays (- (priv:encode-julian-day-number (date-day date)
+ (date-month date)
+ (date-year date))
+ priv:tai-epoch-in-jd)))
+ (make-time
+ time-utc
+ (date-nanosecond date)
+ (+ (* (- jdays 1/2) 24 60 60)
+ (* (date-hour date) 60 60)
+ (* (date-minute date) 60)
+ (date-second date)))))
+
+(define (date->time-tai date)
+ (time-utc->time-tai! (date->time-utc date)))
+
+(define (date->time-monotonic date)
+ (time-utc->time-monotonic! (date->time-utc date)))
+
+(define (priv:leap-year? year)
+ (or (= (modulo year 400) 0)
+ (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
+
+(define (leap-year? date)
+ (priv:leap-year? (date-year date)))
+
+(define priv:month-assoc '((1 . 31) (2 . 59) (3 . 90) (4 . 120)
+ (5 . 151) (6 . 181) (7 . 212) (8 . 243)
+ (9 . 273) (10 . 304) (11 . 334) (12 . 365)))
+
+(define (priv:year-day day month year)
+ (let ((days-pr (assoc day priv:month-assoc)))
+ (if (not days-pr)
+ (priv:error 'date-year-day 'invalid-month-specification month))
+ (if (and (priv:leap-year? year) (> month 2))
+ (+ day (cdr days-pr) 1)
+ (+ day (cdr days-pr)))))
+
+(define (date-year-day date)
+ (priv:year-day (date-day date) (date-month date) (date-year date)))
+
+;; from calendar faq
+(define (priv:week-day day month year)
+ (let* ((a (quotient (- 14 month) 12))
+ (y (- year a))
+ (m (+ month (* 12 a) -2)))
+ (modulo (+ day
+ y
+ (quotient y 4)
+ (- (quotient y 100))
+ (quotient y 400)
+ (quotient (* 31 m) 12))
+ 7)))
+
+(define (date-week-day date)
+ (priv:week-day (date-day date) (date-month date) (date-year date)))
+
+(define (priv:days-before-first-week date day-of-week-starting-week)
+ (let* ((first-day (make-date 0 0 0 0
+ 1
+ 1
+ (date-year date)
+ #f))
+ (fdweek-day (date-week-day first-day)))
+ (modulo (- day-of-week-starting-week fdweek-day)
+ 7)))
+
+(define (date-week-number date day-of-week-starting-week)
+ (quotient (- (date-year-day date)
+ (priv:days-before-first-week date day-of-week-starting-week))
+ 7))
+
+(define (current-date . tz-offset)
+ (time-utc->date (current-time time-utc)
+ (:optional tz-offset (priv:local-tz-offset))))
+
+;; given a 'two digit' number, find the year within 50 years +/-
+(define (priv:natural-year n)
+ (let* ((current-year (date-year (current-date)))
+ (current-century (* (quotient current-year 100) 100)))
+ (cond
+ ((>= n 100) n)
+ ((< n 0) n)
+ ((<= (- (+ current-century n) current-year) 50) (+ current-century n))
+ (else (+ (- current-century 100) n)))))
+
+(define (date->julian-day date)
+ (let ((nanosecond (date-nanosecond date))
+ (second (date-second date))
+ (minute (date-minute date))
+ (hour (date-hour date))
+ (day (date-day date))
+ (month (date-month date))
+ (year (date-year date)))
+ (+ (priv:encode-julian-day-number day month year)
+ (- 1/2)
+ (+ (/ (+ (* hour 60 60)
+ (* minute 60)
+ second
+ (/ nanosecond priv:nano))
+ priv:sid)))))
+
+(define (date->modified-julian-day date)
+ (- (date->julian-day date)
+ 4800001/2))
+
+(define (time-utc->julian-day time)
+ (if (not (eq? (time-type time) time-utc))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano))
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (time-utc->modified-julian-day time)
+ (- (time-utc->julian-day time)
+ 4800001/2))
+
+(define (time-tai->julian-day time)
+ (if (not (eq? (time-type time) time-tai))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (- (time-second time)
+ (priv:leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) priv:nano))
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (time-tai->modified-julian-day time)
+ (- (time-tai->julian-day time)
+ 4800001/2))
+
+;; this is the same as time-tai->julian-day
+(define (time-monotonic->julian-day time)
+ (if (not (eq? (time-type time) time-monotonic))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (- (time-second time)
+ (priv:leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) priv:nano))
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (time-monotonic->modified-julian-day time)
+ (- (time-monotonic->julian-day time)
+ 4800001/2))
+
+(define (julian-day->time-utc jdn)
+ (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
+ (receive (seconds parts)
+ (priv:split-real secs)
+ (make-time time-utc
+ (inexact->exact (truncate (* parts priv:nano)))
+ (inexact->exact seconds)))))
+
+(define (julian-day->time-tai jdn)
+ (time-utc->time-tai! (julian-day->time-utc jdn)))
+
+(define (julian-day->time-monotonic jdn)
+ (time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+(define (julian-day->date jdn . tz-offset)
+ (let ((offset (:optional tz-offset (priv:local-tz-offset))))
+ (time-utc->date (julian-day->time-utc jdn) offset)))
+
+(define (modified-julian-day->date jdn . tz-offset)
+ (let ((offset (:optional tz-offset (priv:local-tz-offset))))
+ (julian-day->date (+ jdn 4800001/2) offset)))
+
+(define (modified-julian-day->time-utc jdn)
+ (julian-day->time-utc (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-tai jdn)
+ (julian-day->time-tai (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-monotonic jdn)
+ (julian-day->time-monotonic (+ jdn 4800001/2)))
+
+(define (current-julian-day)
+ (time-utc->julian-day (current-time time-utc)))
+
+(define (current-modified-julian-day)
+ (time-utc->modified-julian-day (current-time time-utc)))
+
+;; returns a string rep. of number N, of minimum LENGTH, padded with
+;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's
+;; as if number->string was used. if string is longer than or equal
+;; in length to LENGTH, it's as if number->string was used.
+
+(define (priv:padding n pad-with length)
+ (let* ((str (number->string n))
+ (str-len (string-length str)))
+ (if (or (>= str-len length)
+ (not pad-with))
+ str
+ (string-append (make-string (- length str-len) pad-with) str))))
+
+(define (priv:last-n-digits i n)
+ (abs (remainder i (expt 10 n))))
+
+(define (priv:locale-abbr-weekday n)
+ (vector-ref priv:locale-abbr-weekday-vector n))
+
+(define (priv:locale-long-weekday n)
+ (vector-ref priv:locale-long-weekday-vector n))
+
+(define (priv:locale-abbr-month n)
+ (vector-ref priv:locale-abbr-month-vector n))
+
+(define (priv:locale-long-month n)
+ (vector-ref priv:locale-long-month-vector n))
+
+(define (priv:vector-find needle haystack comparator)
+ (let ((len (vector-length haystack)))
+ (define (priv:vector-find-int index)
+ (cond
+ ((>= index len) #f)
+ ((comparator needle (vector-ref haystack index)) index)
+ (else (priv:vector-find-int (+ index 1)))))
+ (priv:vector-find-int 0)))
+
+(define (priv:locale-abbr-weekday->index string)
+ (priv:vector-find string priv:locale-abbr-weekday-vector string=?))
+
+(define (priv:locale-long-weekday->index string)
+ (priv:vector-find string priv:locale-long-weekday-vector string=?))
+
+(define (priv:locale-abbr-month->index string)
+ (priv:vector-find string priv:locale-abbr-month-vector string=?))
+
+(define (priv:locale-long-month->index string)
+ (priv:vector-find string priv:locale-long-month-vector string=?))
+
+
+
+;; do nothing.
+;; Your implementation might want to do something...
+;;
+;; FIXME: is it even possible to do anything reasonable here?
+(define (priv:locale-print-time-zone date port)
+ (values))
+
+;; FIXME: we should use strftime to determine this dynamically if possible.
+;; Again, locale specific.
+(define (priv:locale-am/pm hr)
+ (if (> hr 11) priv:locale-pm priv:locale-am))
+
+(define (priv:tz-printer offset port)
+ (cond
+ ((= offset 0) (display "Z" port))
+ ((negative? offset) (display "-" port))
+ (else (display "+" port)))
+ (if (not (= offset 0))
+ (let ((hours (abs (quotient offset (* 60 60))))
+ (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
+ (display (priv:padding hours #\0 2) port)
+ (display (priv:padding minutes #\0 2) port))))
+
+;; STOPPED-HERE
+
+;; A table of output formatting directives.
+;; the first time is the format char.
+;; the second is a procedure that takes the date, a padding character
+;; (which might be #f), and the output port.
+;;
+(define priv:directives
+ (list
+ (cons #\~ (lambda (date pad-with port)
+ (display #\~ port)))
+ (cons #\a (lambda (date pad-with port)
+ (display (priv:locale-abbr-weekday (date-week-day date))
+ port)))
+ (cons #\A (lambda (date pad-with port)
+ (display (priv:locale-long-weekday (date-week-day date))
+ port)))
+ (cons #\b (lambda (date pad-with port)
+ (display (priv:locale-abbr-month (date-month date))
+ port)))
+ (cons #\B (lambda (date pad-with port)
+ (display (priv:locale-long-month (date-month date))
+ port)))
+ (cons #\c (lambda (date pad-with port)
+ (display (date->string date priv:locale-date-time-format) port)))
+ (cons #\d (lambda (date pad-with port)
+ (display (priv:padding (date-day date)
+ #\0 2)
+ port)))
+ (cons #\D (lambda (date pad-with port)
+ (display (date->string date "~m/~d/~y") port)))
+ (cons #\e (lambda (date pad-with port)
+ (display (priv:padding (date-day date)
+ #\Space 2)
+ port)))
+ (cons #\f (lambda (date pad-with port)
+ (if (> (date-nanosecond date)
+ priv:nano)
+ (display (priv:padding (+ (date-second date) 1)
+ pad-with 2)
+ port)
+ (display (priv:padding (date-second date)
+ pad-with 2)
+ port))
+ (receive (i f)
+ (priv:split-real (/
+ (date-nanosecond date)
+ priv:nano 1.0))
+ (let* ((ns (number->string f))
+ (le (string-length ns)))
+ (if (> le 2)
+ (begin
+ (display priv:locale-number-separator port)
+ (display (substring ns 2 le) port)))))))
+ (cons #\h (lambda (date pad-with port)
+ (display (date->string date "~b") port)))
+ (cons #\H (lambda (date pad-with port)
+ (display (priv:padding (date-hour date)
+ pad-with 2)
+ port)))
+ (cons #\I (lambda (date pad-with port)
+ (let ((hr (date-hour date)))
+ (if (> hr 12)
+ (display (priv:padding (- hr 12)
+ pad-with 2)
+ port)
+ (display (priv:padding hr
+ pad-with 2)
+ port)))))
+ (cons #\j (lambda (date pad-with port)
+ (display (priv:padding (date-year-day date)
+ pad-with 3)
+ port)))
+ (cons #\k (lambda (date pad-with port)
+ (display (priv:padding (date-hour date)
+ #\Space 2)
+ port)))
+ (cons #\l (lambda (date pad-with port)
+ (let ((hr (if (> (date-hour date) 12)
+ (- (date-hour date) 12) (date-hour date))))
+ (display (priv:padding hr #\Space 2)
+ port))))
+ (cons #\m (lambda (date pad-with port)
+ (display (priv:padding (date-month date)
+ pad-with 2)
+ port)))
+ (cons #\M (lambda (date pad-with port)
+ (display (priv:padding (date-minute date)
+ pad-with 2)
+ port)))
+ (cons #\n (lambda (date pad-with port)
+ (newline port)))
+ (cons #\N (lambda (date pad-with port)
+ (display (priv:padding (date-nanosecond date)
+ pad-with 7)
+ port)))
+ (cons #\p (lambda (date pad-with port)
+ (display (priv:locale-am/pm (date-hour date)) port)))
+ (cons #\r (lambda (date pad-with port)
+ (display (date->string date "~I:~M:~S ~p") port)))
+ (cons #\s (lambda (date pad-with port)
+ (display (time-second (date->time-utc date)) port)))
+ (cons #\S (lambda (date pad-with port)
+ (if (> (date-nanosecond date)
+ priv:nano)
+ (display (priv:padding (+ (date-second date) 1)
+ pad-with 2)
+ port)
+ (display (priv:padding (date-second date)
+ pad-with 2)
+ port))))
+ (cons #\t (lambda (date pad-with port)
+ (display #\Tab port)))
+ (cons #\T (lambda (date pad-with port)
+ (display (date->string date "~H:~M:~S") port)))
+ (cons #\U (lambda (date pad-with port)
+ (if (> (priv:days-before-first-week date 0) 0)
+ (display (priv:padding (+ (date-week-number date 0) 1)
+ #\0 2) port)
+ (display (priv:padding (date-week-number date 0)
+ #\0 2) port))))
+ (cons #\V (lambda (date pad-with port)
+ (display (priv:padding (date-week-number date 1)
+ #\0 2) port)))
+ (cons #\w (lambda (date pad-with port)
+ (display (date-week-day date) port)))
+ (cons #\x (lambda (date pad-with port)
+ (display (date->string date priv:locale-short-date-format) port)))
+ (cons #\X (lambda (date pad-with port)
+ (display (date->string date priv:locale-time-format) port)))
+ (cons #\W (lambda (date pad-with port)
+ (if (> (priv:days-before-first-week date 1) 0)
+ (display (priv:padding (+ (date-week-number date 1) 1)
+ #\0 2) port)
+ (display (priv:padding (date-week-number date 1)
+ #\0 2) port))))
+ (cons #\y (lambda (date pad-with port)
+ (display (priv:padding (priv:last-n-digits
+ (date-year date) 2)
+ pad-with
+ 2)
+ port)))
+ (cons #\Y (lambda (date pad-with port)
+ (display (date-year date) port)))
+ (cons #\z (lambda (date pad-with port)
+ (priv:tz-printer (date-zone-offset date) port)))
+ (cons #\Z (lambda (date pad-with port)
+ (priv:locale-print-time-zone date port)))
+ (cons #\1 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~d") port)))
+ (cons #\2 (lambda (date pad-with port)
+ (display (date->string date "~k:~M:~S~z") port)))
+ (cons #\3 (lambda (date pad-with port)
+ (display (date->string date "~k:~M:~S") port)))
+ (cons #\4 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+ (cons #\5 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
+
+
+(define (priv:get-formatter char)
+ (let ((associated (assoc char priv:directives)))
+ (if associated (cdr associated) #f)))
+
+(define (priv:date-printer date index format-string str-len port)
+ (if (>= index str-len)
+ (values)
+ (let ((current-char (string-ref format-string index)))
+ (if (not (char=? current-char #\~))
+ (begin
+ (display current-char port)
+ (priv:date-printer date (+ index 1) format-string str-len port))
+ (if (= (+ index 1) str-len) ; bad format string.
+ (priv:time-error 'priv:date-printer 'bad-date-format-string
+ format-string)
+ (let ((pad-char? (string-ref format-string (+ index 1))))
+ (cond
+ ((char=? pad-char? #\-)
+ (if (= (+ index 2) str-len) ; bad format string.
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (let ((formatter (priv:get-formatter
+ (string-ref format-string
+ (+ index 2)))))
+ (if (not formatter)
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #f port)
+ (priv:date-printer date
+ (+ index 3)
+ format-string
+ str-len
+ port))))))
+
+ ((char=? pad-char? #\_)
+ (if (= (+ index 2) str-len) ; bad format string.
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (let ((formatter (priv:get-formatter
+ (string-ref format-string
+ (+ index 2)))))
+ (if (not formatter)
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #\Space port)
+ (priv:date-printer date
+ (+ index 3)
+ format-string
+ str-len
+ port))))))
+ (else
+ (let ((formatter (priv:get-formatter
+ (string-ref format-string
+ (+ index 1)))))
+ (if (not formatter)
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #\0 port)
+ (priv:date-printer date
+ (+ index 2)
+ format-string
+ str-len
+ port))))))))))))
+
+
+(define (date->string date . format-string)
+ (call-with-output-string
+ (lambda (str-port)
+ (let ((fmt-str (:optional format-string "~c")))
+ (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
+ (get-output-string str-port)))))
+
+(define (priv:char->int ch)
+ (case ch
+ ((#\0) 0)
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ (else (priv:time-error 'bad-date-template-string
+ (list "Non-integer character" ch i)))))
+
+;; read an integer upto n characters long on port; upto -> #f is any length
+(define (priv:integer-reader upto port)
+ (let loop ((accum 0) (nchars 0))
+ (let ((ch (peek-char port)))
+ (if (or (eof-object? ch)
+ (not (char-numeric? ch))
+ (and upto (>= nchars upto)))
+ accum
+ (loop port
+ (+ (* accum 10) (priv:char->int (read-char port)))
+ (+ nchars 1))))))
+
+(define (priv:make-integer-reader upto)
+ (lambda (port)
+ (priv:integer-reader upto port)))
+
+;; read *exactly* n characters and convert to integer; could be padded
+(define (priv:integer-reader-exact n port)
+ (let ((padding-ok #t))
+ (define (accum-int port accum nchars)
+ (let ((ch (peek-char port)))
+ (cond
+ ((>= nchars n) accum)
+ ((eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ "Premature ending to integer read."))
+ ((char-numeric? ch)
+ (set! padding-ok #f)
+ (accum-int port
+ (+ (* accum 10) (priv:char->int (read-char port)))
+ (+ nchars 1)))
+ (padding-ok
+ (read-char port) ; consume padding
+ (accum-int port accum (+ nchars 1)))
+ (else ; padding where it shouldn't be
+ (priv:time-error 'string->date 'bad-date-template-string
+ "Non-numeric characters in integer read.")))))
+ (accum-int port 0 0)))
+
+
+(define (priv:make-integer-exact-reader n)
+ (lambda (port)
+ (priv:integer-reader-exact n port)))
+
+(define (priv:zone-reader port)
+ (let ((offset 0)
+ (positive? #f))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone +/-" ch)))
+ (if (or (char=? ch #\Z) (char=? ch #\z))
+ 0
+ (begin
+ (cond
+ ((char=? ch #\+) (set! positive? #t))
+ ((char=? ch #\-) (set! positive? #f))
+ (else
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone +/-" ch))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (* (priv:char->int ch)
+ 10 60 60)))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (priv:char->int ch)
+ 60 60))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (priv:char->int ch)
+ 10 60))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (priv:char->int ch)
+ 60))))
+ (if positive? offset (- offset)))))))
+
+;; looking at a char, read the char string, run thru indexer, return index
+(define (priv:locale-reader port indexer)
+
+ (define (read-char-string result)
+ (let ((ch (peek-char port)))
+ (if (char-alphabetic? ch)
+ (read-char-string (cons (read-char port) result))
+ (list->string (reverse result)))))
+
+ (let* ((str (read-char-string '()))
+ (index (indexer str)))
+ (if index index (priv:time-error 'string->date
+ 'bad-date-template-string
+ (list "Invalid string for " indexer)))))
+
+(define (priv:make-locale-reader indexer)
+ (lambda (port)
+ (priv:locale-reader port indexer)))
+
+(define (priv:make-char-id-reader char)
+ (lambda (port)
+ (if (char=? char (read-char port))
+ char
+ (priv:time-error 'string->date
+ 'bad-date-template-string
+ "Invalid character match."))))
+
+;; A List of formatted read directives.
+;; Each entry is a list.
+;; 1. the character directive;
+;; a procedure, which takes a character as input & returns
+;; 2. #t as soon as a character on the input port is acceptable
+;; for input,
+;; 3. a port reader procedure that knows how to read the current port
+;; for a value. Its one parameter is the port.
+;; 4. a action procedure, that takes the value (from 3.) and some
+;; object (here, always the date) and (probably) side-effects it.
+;; In some cases (e.g., ~A) the action is to do nothing
+
+(define priv:read-directives
+ (let ((ireader4 (priv:make-integer-reader 4))
+ (ireader2 (priv:make-integer-reader 2))
+ (ireaderf (priv:make-integer-reader #f))
+ (eireader2 (priv:make-integer-exact-reader 2))
+ (eireader4 (priv:make-integer-exact-reader 4))
+ (locale-reader-abbr-weekday (priv:make-locale-reader
+ priv:locale-abbr-weekday->index))
+ (locale-reader-long-weekday (priv:make-locale-reader
+ priv:locale-long-weekday->index))
+ (locale-reader-abbr-month (priv:make-locale-reader
+ priv:locale-abbr-month->index))
+ (locale-reader-long-month (priv:make-locale-reader
+ priv:locale-long-month->index))
+ (char-fail (lambda (ch) #t))
+ (do-nothing (lambda (val object) (values))))
+
+ (list
+ (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing)
+ (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
+ (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
+ (list #\b char-alphabetic? locale-reader-abbr-month
+ (lambda (val object)
+ (priv:set-date-month! object val)))
+ (list #\B char-alphabetic? locale-reader-long-month
+ (lambda (val object)
+ (priv:set-date-month! object val)))
+ (list #\d char-numeric? ireader2 (lambda (val object)
+ (priv:set-date-day!
+ object val)))
+ (list #\e char-fail eireader2 (lambda (val object)
+ (priv:set-date-day! object val)))
+ (list #\h char-alphabetic? locale-reader-abbr-month
+ (lambda (val object)
+ (priv:set-date-month! object val)))
+ (list #\H char-numeric? ireader2 (lambda (val object)
+ (priv:set-date-hour! object val)))
+ (list #\k char-fail eireader2 (lambda (val object)
+ (priv:set-date-hour! object val)))
+ (list #\m char-numeric? ireader2 (lambda (val object)
+ (priv:set-date-month! object val)))
+ (list #\M char-numeric? ireader2 (lambda (val object)
+ (priv:set-date-minute!
+ object val)))
+ (list #\S char-numeric? ireader2 (lambda (val object)
+ (priv:set-date-second! object val)))
+ (list #\y char-fail eireader2
+ (lambda (val object)
+ (priv:set-date-year! object (priv:natural-year val))))
+ (list #\Y char-numeric? ireader4 (lambda (val object)
+ (priv:set-date-year! object val)))
+ (list #\z (lambda (c)
+ (or (char=? c #\Z)
+ (char=? c #\z)
+ (char=? c #\+)
+ (char=? c #\-)))
+ priv:zone-reader (lambda (val object)
+ (priv:set-date-zone-offset! object val))))))
+
+(define (priv:string->date date index format-string str-len port template-string)
+ (define (skip-until port skipper)
+ (let ((ch (peek-char port)))
+ (if (eof-object? port)
+ (priv:time-error 'string->date 'bad-date-format-string template-string)
+ (if (not (skipper ch))
+ (begin (read-char port) (skip-until port skipper))))))
+ (if (>= index str-len)
+ (begin
+ (values))
+ (let ((current-char (string-ref format-string index)))
+ (if (not (char=? current-char #\~))
+ (let ((port-char (read-char port)))
+ (if (or (eof-object? port-char)
+ (not (char=? current-char port-char)))
+ (priv:time-error 'string->date
+ 'bad-date-format-string template-string))
+ (priv:string->date date
+ (+ index 1)
+ format-string
+ str-len
+ port
+ template-string))
+ ;; otherwise, it's an escape, we hope
+ (if (> (+ index 1) str-len)
+ (priv:time-error 'string->date
+ 'bad-date-format-string template-string)
+ (let* ((format-char (string-ref format-string (+ index 1)))
+ (format-info (assoc format-char priv:read-directives)))
+ (if (not format-info)
+ (priv:time-error 'string->date
+ 'bad-date-format-string template-string)
+ (begin
+ (let ((skipper (cadr format-info))
+ (reader (caddr format-info))
+ (actor (cadddr format-info)))
+ (skip-until port skipper)
+ (let ((val (reader port)))
+ (if (eof-object? val)
+ (priv:time-error 'string->date
+ 'bad-date-format-string
+ template-string)
+ (actor val date)))
+ (priv:string->date date
+ (+ index 2)
+ format-string
+ str-len
+ port
+ template-string))))))))))
+
+(define (string->date input-string template-string)
+ (define (priv:date-ok? date)
+ (and (date-nanosecond date)
+ (date-second date)
+ (date-minute date)
+ (date-hour date)
+ (date-day date)
+ (date-month date)
+ (date-year date)
+ (date-zone-offset date)))
+ (let ((newdate (make-date 0 0 0 0 #f #f #f (priv:local-tz-offset))))
+ (priv:string->date newdate
+ 0
+ template-string
+ (string-length template-string)
+ (priv:open-input-string input-string)
+ template-string)
+ (if (priv:date-ok? newdate)
+ newdate
+ (priv:time-error
+ 'string->date
+ 'bad-date-format-string
+ (list "Incomplete date read. " newdate template-string)))))
Index: gnucash/lib/srfi/srfi-2.scm
diff -u /dev/null gnucash/lib/srfi/srfi-2.scm:1.1
--- /dev/null Wed May 16 08:02:02 2001
+++ gnucash/lib/srfi/srfi-2.scm Tue May 15 10:48:43 2001
@@ -0,0 +1,62 @@
+;;;; srfi-2.scm --- SRFI-2 procedures for Guile
+;;;;
+;;;; Copyright (C) 2001 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., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(define-module (srfi srfi-2))
+
+(cond
+
+ ((or (string=? "1.3.4" (version))
+ (string=? "1.4" (version)))
+ (use-modules (ice-9 and-let*)))
+
+ ((string=? "1.3" (version))
+ (defmacro and-let* (vars . body)
+
+ (define (expand vars body)
+ (cond
+ ((null? vars)
+ `(begin ,@body))
+ ((pair? vars)
+ (let ((exp (car vars)))
+ (cond
+ ((pair? exp)
+ (cond
+ ((null? (cdr exp))
+ `(and ,(car exp) ,(expand (cdr vars) body)))
+ (else
+ (let ((var (car exp))
+ (val (cadr exp)))
+ `(let (,exp)
+ (and ,var ,(expand (cdr vars) body)))))))
+ (else
+ `(and ,exp ,(expand (cdr vars) body))))))
+ (else
+ (error "not a proper list" vars))))
+
+ (expand vars body)))
+
+ (else
+ (let ((msg
+ (string-append
+ "Loaded gnucash srfi-2.scm in unknown Guile version:" (version) ".\n"
+ "If you're running a Guile newer than 1.4, then this file should\n"
+ "not have been installed. Please report the bug.")))
+ (error msg))))
+
+(export-syntax and-let*)
Index: gnucash/lib/srfi/srfi-8.scm
diff -u /dev/null gnucash/lib/srfi/srfi-8.scm:1.1
--- /dev/null Wed May 16 08:02:02 2001
+++ gnucash/lib/srfi/srfi-8.scm Tue May 15 10:48:43 2001
@@ -0,0 +1,45 @@
+;;;; srfi-8.scm --- SRFI-8 procedures for Guile
+
+;;; Copyright (C) 2000 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., 59 Temple Place, Suite 330,
+;;; Boston, MA 02111-1307 USA
+
+(define-module (srfi srfi-8))
+
+(cond
+ ((or (string=? "1.3" (version))
+ (string=? "1.3.4" (version))
+ (string=? "1.4" (version)))
+
+ (use-modules (ice-9 slib))
+ (require 'macro-by-example)
+ (require 'values)
+
+ (define-syntax receive
+ (syntax-rules ()
+ ((receive formals expression body ...)
+ (call-with-values (lambda () expression)
+ (lambda formals body ...))))))
+
+ (else
+ (let ((msg
+ (string-append
+ "Loaded gnucash srfi-8.scm in unknown Guile version:" (version) ".\n"
+ "If you're running a Guile newer than 1.4, then this file should\n"
+ "not have been installed. Please report the bug.")))
+ (error msg))))
+
+(export-syntax receive)
Index: gnucash/lib/srfi/srfi-9.scm
diff -u /dev/null gnucash/lib/srfi/srfi-9.scm:1.1
--- /dev/null Wed May 16 08:02:02 2001
+++ gnucash/lib/srfi/srfi-9.scm Tue May 15 10:48:44 2001
@@ -0,0 +1,89 @@
+;;;; srfi-9.scm --- SRFI-9 procedures for Guile
+;;;;
+;;;; Copyright (C) 2001 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., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+;;; Commentary:
+
+;;; This module exports the syntactic form `define-record-type', which
+;;; is the means for creating record types defined in SRFI-9.
+;;;
+;;; The syntax of a record type definition is:
+;;;
+;;; <record type definition>
+;;; -> (define-record-type <type name>
+;;; (<constructor name> <field tag> ...)
+;;; <predicate name>
+;;; <field spec> ...)
+;;;
+;;; <field spec> -> (<field tag> <accessor name>)
+;;; -> (<field tag> <accessor name> <modifier name>)
+;;;
+;;; <field tag> -> <identifier>
+;;; <... name> -> <identifier>
+;;;
+;;; Usage example:
+;;;
+;;; guile> (use-modules (srfi srfi-9))
+;;; guile> (define-record-type :foo (make-foo x) foo?
+;;; (x get-x) (y get-y set-y!))
+;;; guile> (define f (make-foo 1))
+;;; guile> f
+;;; #<:foo x: 1 y: #f>
+;;; guile> (get-x f)
+;;; 1
+;;; guile> (set-y! f 2)
+;;; 2
+;;; guile> (get-y f)
+;;; 2
+;;; guile> f
+;;; #<:foo x: 1 y: 2>
+;;; guile> (foo? f)
+;;; #t
+;;; guile> (foo? 1)
+;;; #f
+
+;;; Code:
+
+(define-module (srfi srfi-9))
+
+(export-syntax define-record-type)
+
+(define-macro (define-record-type type-name constructor/field-tag
+ predicate-name . field-specs)
+ `(begin
+ (define ,type-name
+ (make-record-type ',type-name ',(map car field-specs)))
+ (define ,(car constructor/field-tag)
+ (record-constructor ,type-name ',(cdr constructor/field-tag)))
+ (define ,predicate-name
+ (record-predicate ,type-name))
+ ,@(map
+ (lambda (spec)
+ (cond
+ ((= (length spec) 2)
+ `(define ,(cadr spec)
+ (record-accessor ,type-name ',(car spec))))
+ ((= (length spec) 3)
+ `(begin
+ (define ,(cadr spec)
+ (record-accessor ,type-name ',(car spec)))
+ (define ,(caddr spec)
+ (record-modifier ,type-name ',(car spec)))))
+ (else
+ (error "invalid field spec " spec))))
+ field-specs)))
Index: gnucash/src/doc/design/engine.texinfo
diff -u gnucash/src/doc/design/engine.texinfo:1.33 gnucash/src/doc/design/engine.texinfo:1.34
--- gnucash/src/doc/design/engine.texinfo:1.33 Tue May 15 04:39:13 2001
+++ gnucash/src/doc/design/engine.texinfo Wed May 16 04:33:30 2001
@@ -258,7 +258,7 @@
account = < something to get an Account pointer >
- saved_guid = *xaccAccountGetGuid(account);
+ saved_guid = *xaccAccountGetGUID(account);
...
@@ -1537,12 +1537,6 @@
Allocate, initialize, and return a new Transaction.
@end deftypefun
-@deftypefun void xaccTransAppendSplit (Transaction * @var{trans}, Split * @var{split})
-Append @var{split} to the collection of Splits in @var{trans}. If the
-Split is already a part of another Transaction, it will be removed from
-that Transaction first.
-@end deftypefun
-
@deftypefun void xaccTransDestroy (Transaction * {trans})
Remove all of the Splits from each of their accounts and free the memory
associated with them. This routine must be followed by either an
@@ -1551,6 +1545,12 @@
original Splits are put back into place.
@end deftypefun
+@deftypefun void xaccTransAppendSplit (Transaction * @var{trans}, Split * @var{split})
+Append @var{split} to the collection of Splits in @var{trans}. If the
+Split is already a part of another Transaction, it will be removed from
+that Transaction first.
+@end deftypefun
+
@deftypefun void xaccTransBeginEdit (Transaction * @var{trans})
This method must be called before any changes are made to @var{trans} or
any of its component Splits. If this is not done, errors will result.
@@ -1694,9 +1694,19 @@
The list of debits and credits which apply to the Account. The sum of
all debits and credits is the account balance.
+@item A type
+An integer code identifying the type of account. The Account type
+determines whether the Account holds shares valued in a currency
+or not. It is also used by the GUI and reporting system to determine
+how debits & credits to the Account should be treated and displayed.
+
@item A name
The name of the Account.
+@item An account code
+A string that is intended to hold a unique user-selected identifier
+for the account. However, uniqueness of this field is not enforced.
+
@item A description
A textual description of the Account.
@@ -1704,6 +1714,10 @@
The commodity that Splits in the account are valued in, i.e., the
denomination of the 'value' member of Splits in the account.
+@item A curreny SCU
+The SCU is the smallest convertible unit that the currency is
+traded in. This value overrides the default SCU of the currency.
+
@item A security
For Accounts which may contain shares (such as stock accounts),
the denomination of the 'share quantity' member of Splits in
@@ -1711,9 +1725,134 @@
security is blank, and the share quantities are denominated
in the Account currency.
+@item A security SCU
+Analogous to the currency SCU, but for the security.
+
+@item A parent and child Account Group.
+The parent and child of an Account are Account Groups
+(@pxref{Account Groups}). Account Groups are used to
+connect Accounts together into an Account hierarchy.
+If the parent Account Group is not present, the Account
+is at the top level of the hierarchy. If the child
+Account Group is not present, the Account has no
+children.
+
@end table
In addition to the above, Accounts contain a key-value pair frame.
+
+@menu
+* Account Types::
+* General Account API::
+@end menu
+
+
+@node Account Types, General Account API, Accounts, Accounts
+@subsection Account Types
+@tindex GNCAccountType
+
+Account Types are defined by the @code{GNCAccountType} enumeration.
+Possible values are:
+
+ @table @code
+
+ @item BAD_TYPE, NO_TYPE
+ Both of these values indicate an illegal Account type.
+
+ @item BANK
+ Denotes a savings or checking account held at a bank.
+ Such an account is often interest bearing.
+
+ @item CASH
+ Denotes a shoe-box or pillowcase stuffed with cash. In other
+ words, actual currency held by the user.
+
+ @item CREDIT
+ Denotes credit card accounts.
+
+ @item ASSET
+ Denotes a generic asset account.
+
+
+ @item LIABILITY
+ Denotes a generic liability account.
+
+ @item STOCK
+ A stock account containing stock shares.
+
+ @item MUTUAL
+ A mutual fund account containing fund shares.
+
+ @item CURRENCY
+ Denotes a currency trading account. In many ways, a currency trading
+ account is like a stock trading account, where both quantities
+ and prices are set. However, generally both currency and security
+ are national currencies.
+
+ @item INCOME
+ Denotes an income account. The GnuCash financial model does not
+ use 'categories'. Actual accounts are used instead.
+
+ @item EXPENSE
+ Denotes an expense account.
+
+ @item EQUITY = 10,
+ Denotes an equity account.
+
+ @end table
+
+
+@node General Account API, , Account Types, Accounts
+@subsection General Account API
+
+@deftypefun {Account *} xaccMallocAccount (void)
+Allocate and initialize an Account. The account must be
+destroyed by calling @code{xaccAccountBeginEdit} followed
+by @code{xaccAccountDestroy}.
+@end deftypefun
+
+@deftypefun void xaccAccountDestroy (Account * @var{account})
+Destroys @var{account} and frees all memory associated with
+it. This routine will also destroy the Account's children.
+You must call @code{xaccAccountBeginEdit} before calling
+this function.
+@end deftypefun
+
+@deftypefun void xaccAccountBeginEdit (Account * @var{account})
+This routine, together with @code{xaccAccountCommitEdit},
+provide a two-phase-commit wrapper for account updates
+much in the same way as @var{xaccTransBeginEdit} and
+@var{xaccTransCommitEdit} do for Transactions.
+@end deftypefun
+
+@deftypefun void xaccAccountCommitEdit (Account * @var{account})
+The counterpart to @var{xaccAccountBeginEdit}.
+@end deftypefun
+
+@deftypefun {Account *} xaccCloneAccountSimple(const Account * @var{from})
+Return a 'copy' of @var{from} that is identical in the type, name, code,
+description, kvp data, and currency. All other fields are the same as an
+account returned by @code{xaccMallocAccount}.
+@end deftypefun
+
+@deftypefun {const GUID *} xaccAccountGetGUID (Account * @var{account})
+Return the globally unique id associated with @var{account}.
+@end deftypefun
+
+@deftypefun {Account *} xaccAccountLookup (const GUID * @var{guid})
+Return the Account associated with @var{guid}, or NULL if there is
+no such Account.
+@end deftypefun
+
+@deftypefun {kvp_frame *} xaccAccountGetSlots (Account * @var{account})
+Return the @code{kvp_frame} associated with @var{account}. User code
+may modify this @code{kvp_frame}, but must not destroy it.
+@end deftypefun
+
+@deftypefun void xaccAccountSetSlots_nc (Account * @var{account}, kvp_frame * @var{frame})
+Set the @code{kvp_frame} associated wih @var{account}. After the call,
+@var{frame} is owned by @var{account}, so don't destroy it.
+@end deftypefun
@node Account Groups, GNCBooks, Accounts, Engine
Index: gnucash/src/doc/design/gnucash-design.texinfo
diff -u gnucash/src/doc/design/gnucash-design.texinfo:1.26 gnucash/src/doc/design/gnucash-design.texinfo:1.27
--- gnucash/src/doc/design/gnucash-design.texinfo:1.26 Wed May 9 03:55:37 2001
+++ gnucash/src/doc/design/gnucash-design.texinfo Wed May 16 04:33:31 2001
@@ -130,11 +130,16 @@
* Split Getters::
* Split Setters::
-The Transaction Edit Cycle
+Transactions
* General Transaction API::
* Transaction Getters::
* Transaction Setters::
+
+Accounts
+
+* Account Types::
+* General Account API::
GNCBooks
Index: gnucash/src/engine/Account.c
diff -u gnucash/src/engine/Account.c:1.148 gnucash/src/engine/Account.c:1.149
--- gnucash/src/engine/Account.c:1.148 Mon May 14 16:31:49 2001
+++ gnucash/src/engine/Account.c Wed May 16 04:33:32 2001
@@ -141,8 +141,7 @@
Account *ret;
ret = xaccMallocAccount();
- xaccInitAccount(ret);
-
+
ret->type = from->type;
ret->accountName = g_strdup(from->accountName);
@@ -476,6 +475,7 @@
kvp_frame *
xaccAccountGetSlots(Account * account) {
+ if (!account) return NULL;
return(account->kvp_data);
}
Index: gnucash/src/engine/Account.h
diff -u gnucash/src/engine/Account.h:1.70 gnucash/src/engine/Account.h:1.71
--- gnucash/src/engine/Account.h:1.70 Sun May 13 16:57:19 2001
+++ gnucash/src/engine/Account.h Wed May 16 04:33:32 2001
@@ -81,16 +81,13 @@
CURRENCY = 7,
/* The currency account type indicates that the account is a
* currency trading account. In many ways, a currency trading
- * account is like a stock trading account, where both quantities
- * and prices are set.
+ * account is like a stock trading account, where both values
+ * and share quantities are set.
*/
INCOME = 8,
EXPENSE = 9,
- /* Income and expense accounts are used to denote income and expenses.
- * Thus, when data in these accountsare displayed, the sign of the
- * splits (entries) must be reversed.
- */
+ /* Income and expense accounts are used to denote income and expenses. */
EQUITY = 10,
/* Equity account is used to balance the balance sheet. */
@@ -122,14 +119,14 @@
/*
* The xaccAccountBeginEdit() and xaccAccountCommitEdit() subroutines
* provide a two-phase-commit wrapper for account updates.
- * They are incompletely implemented ....
+ * They are incompletely implemented.
*
* The xaccAccountDestroy() routine can be used to get rid of an
* account. The account should have been opened for editing
* (by calling xaccAccountBeginEdit()) before calling this routine.
*/
-Account *xaccMallocAccount (void);
-Account * xaccCloneAccountSimple(const Account *from);
+Account * xaccMallocAccount (void);
+Account * xaccCloneAccountSimple(const Account *from);
void xaccAccountBeginEdit (Account *account);
void xaccAccountCommitEdit (Account *account);
void xaccAccountDestroy (Account *account);
@@ -140,8 +137,6 @@
/*
* The xaccAccountGetGUID() subroutine will return the
* globally unique id associated with that account.
- * User code should use this id to reference accounts
- * and *not* the integer account id below.
*
* The xaccAccountLookup() subroutine will return the
* account associated with the given id, or NULL
@@ -222,7 +217,7 @@
* The future API will associate only one thing with an account:
* the 'commodity'. Use xaccAccountGetCommodity() to fetch it.
*/
-/* these two funcs take control of thier gnc_commodity args. Don't free */
+/* these two funcs take control of their gnc_commodity args. Don't free */
void xaccAccountSetCurrency (Account *account, gnc_commodity *currency);
void xaccAccountSetSecurity (Account *account, gnc_commodity *security);
void xaccAccountSetCurrencySCU (Account *account, int frac);
Index: gnucash/src/engine/AccountP.h
diff -u gnucash/src/engine/AccountP.h:1.33 gnucash/src/engine/AccountP.h:1.34
--- gnucash/src/engine/AccountP.h:1.33 Fri Mar 9 01:46:10 2001
+++ gnucash/src/engine/AccountP.h Wed May 16 04:33:33 2001
@@ -57,23 +57,23 @@
/* public data, describes account */
GUID guid; /* globally unique account id */
- /* The accountName is an arbitrary string assinged by the user.
+ /* The accountName is an arbitrary string assigned by the user.
* It is intended to a short, 5 to 30 character long string that
- * is displayed by the GUI as the account mnomenic.
+ * is displayed by the GUI as the account mnemonic.
*/
char *accountName;
- /* The accountCode is an arbitary string assigned by the user.
+ /* The accountCode is an arbitrary string assigned by the user.
* It is intended to be reporting code that is a synonym for the
- * accountName. Typically, it will be a numeric value tht follows
+ * accountName. Typically, it will be a numeric value that follows
* the numbering assignments commonly used by accountants, such
* as 100, 200 or 600 for top-level * accounts, and 101, 102.. etc.
* for detail accounts.
*/
char *accountCode;
- /* The description is an arbitraary string assigned by the user.
- * It is intended to be a longer, 1-5 sentance description of what
+ /* The description is an arbitrary string assigned by the user.
+ * It is intended to be a longer, 1-5 sentence description of what
* this account is all about.
*/
char *description;
Index: gnucash/src/engine/gnc-account-xml-v2.c
diff -u gnucash/src/engine/gnc-account-xml-v2.c:1.17 gnucash/src/engine/gnc-account-xml-v2.c:1.18
--- gnucash/src/engine/gnc-account-xml-v2.c:1.17 Wed May 9 18:03:36 2001
+++ gnucash/src/engine/gnc-account-xml-v2.c Tue May 15 10:52:22 2001
@@ -47,16 +47,18 @@
const gchar *account_version_string = "2.0.0";
/* ids */
-const char *gnc_account_string = "gnc:account";
-const char *act_name_string = "act:name";
-const char *act_id_string = "act:id";
-const char *act_type_string = "act:type";
-const char *act_currency_string = "act:currency";
-const char *act_code_string = "act:code";
-const char *act_description_string = "act:description";
-const char *act_security_string = "act:security";
-const char *act_slots_string = "act:slots";
-const char *act_parent_string = "act:parent";
+#define gnc_account_string "gnc:account"
+#define act_name_string "act:name"
+#define act_id_string "act:id"
+#define act_type_string "act:type"
+#define act_currency_string "act:currency"
+#define act_currency_scu_string "act:currency-scu"
+#define act_code_string "act:code"
+#define act_description_string "act:description"
+#define act_security_string "act:security"
+#define act_security_scu_string "act:security-scu"
+#define act_slots_string "act:slots"
+#define act_parent_string "act:parent"
xmlNodePtr
gnc_account_dom_tree_create(Account *act)
@@ -75,8 +77,11 @@
xaccAccountTypeEnumAsString(xaccAccountGetType(act))));
xmlAddChild(ret, commodity_ref_to_dom_tree(act_currency_string,
- xaccAccountGetCurrency(act)));
+ xaccAccountGetCurrency(act)));
+ xmlAddChild(ret, int_to_dom_tree(act_currency_scu_string,
+ xaccAccountGetCurrencySCU(act)));
+
if(xaccAccountGetCode(act) &&
strlen(xaccAccountGetCode(act)) > 0)
{
@@ -95,6 +100,8 @@
{
xmlAddChild(ret, commodity_ref_to_dom_tree(act_security_string,
xaccAccountGetSecurity(act)));
+ xmlAddChild(ret, int_to_dom_tree(act_security_scu_string,
+ xaccAccountGetSecuritySCU(act)));
}
if(xaccAccountGetSlots(act))
@@ -174,6 +181,16 @@
}
static gboolean
+account_currency_scu_handler (xmlNodePtr node, gpointer act)
+{
+ gint64 val;
+ dom_tree_to_integer(node, &val);
+ xaccAccountSetCurrencySCU((Account*)act, val);
+
+ return TRUE;
+}
+
+static gboolean
account_security_handler (xmlNodePtr node, gpointer act)
{
gnc_commodity *ref;
@@ -184,6 +201,16 @@
}
static gboolean
+account_security_scu_handler (xmlNodePtr node, gpointer act)
+{
+ gint64 val;
+ dom_tree_to_integer(node, &val);
+ xaccAccountSetSecuritySCU((Account*)act, val);
+
+ return TRUE;
+}
+
+static gboolean
account_slots_handler (xmlNodePtr node, gpointer act)
{
kvp_frame *frm = dom_tree_to_kvp_frame(node);
@@ -225,15 +252,17 @@
}
static struct dom_tree_handler account_handlers_v2[] = {
- { "act:name", account_name_handler, 1, 0 },
- { "act:id", account_id_handler, 1, 0 },
- { "act:type", account_type_handler, 1, 0 },
- { "act:currency", account_currency_handler, 1, 0 },
- { "act:code", account_code_handler, 0, 0 },
- { "act:description", account_description_handler, 0, 0},
- { "act:security", account_security_handler, 0, 0 },
- { "act:slots", account_slots_handler, 0, 0 },
- { "act:parent", account_parent_handler, 0, 0 },
+ { act_name_string, account_name_handler, 1, 0 },
+ { act_id_string, account_id_handler, 1, 0 },
+ { act_type_string, account_type_handler, 1, 0 },
+ { act_currency_string, account_currency_handler, 1, 0 },
+ { act_currency_scu_string, account_currency_scu_handler, 0, 0 },
+ { act_code_string, account_code_handler, 0, 0 },
+ { act_description_string, account_description_handler, 0, 0},
+ { act_security_string, account_security_handler, 0, 0 },
+ { act_security_scu_string, account_security_scu_handler, 0, 0 },
+ { act_slots_string, account_slots_handler, 0, 0 },
+ { act_parent_string, account_parent_handler, 0, 0 },
{ NULL, 0, 0, 0 }
};
@@ -279,16 +308,16 @@
else
{
gdata->cb(tag, gdata->data, acc);
+ /*
+ * Now return the account to the "edit" state. At the end of reading
+ * all the transactions, we will Commit. This replaces #splits
+ * rebalances with #accounts rebalances at the end. A BIG win!
+ */
+ xaccAccountBeginEdit(acc);
}
xmlFreeNode(tree);
- /* Now return the account to the "edit" state. At the end of reading
- * all the transactions, we will Commit. This replaces #splits
- * rebalances with #accounts rebalances at the end. A BIG win!
- */
- if (successful)
- xaccAccountBeginEdit(acc);
return successful;
}
Index: gnucash/src/engine/gnc-commodity-xml-v2.c
diff -u gnucash/src/engine/gnc-commodity-xml-v2.c:1.11 gnucash/src/engine/gnc-commodity-xml-v2.c:1.12
--- gnucash/src/engine/gnc-commodity-xml-v2.c:1.11 Wed May 9 18:03:36 2001
+++ gnucash/src/engine/gnc-commodity-xml-v2.c Tue May 15 10:52:57 2001
@@ -74,13 +74,9 @@
"cmdty:xcode",
gnc_commodity_get_exchange_code(com)));
}
-
- {
- gchar *text;
- text = g_strdup_printf("%d", gnc_commodity_get_fraction(com));
- xmlAddChild(ret, text_to_dom_tree("cmdty:fraction", text));
- g_free(text);
- }
+
+ xmlAddChild(ret, int_to_dom_tree("cmdty:fraction",
+ gnc_commodity_get_fraction(com)));
return ret;
}
Index: gnucash/src/engine/io-example-account.c
diff -u gnucash/src/engine/io-example-account.c:1.3 gnucash/src/engine/io-example-account.c:1.4
--- gnucash/src/engine/io-example-account.c:1.3 Fri May 11 17:26:42 2001
+++ gnucash/src/engine/io-example-account.c Tue May 15 10:49:10 2001
@@ -320,6 +320,8 @@
fprintf(out, "<?xml version=\"1.0\"?>\n");
fprintf(out, "<" GNC_ACCOUNT_STRING ">\n");
+ write_string_part(out, GNC_ACCOUNT_TITLE, gea->title);
+
write_string_part(out, GNC_ACCOUNT_SHORT, gea->short_description);
write_string_part(out, GNC_ACCOUNT_LONG, gea->long_description);
Index: gnucash/src/engine/sixtp-dom-generators.c
diff -u gnucash/src/engine/sixtp-dom-generators.c:1.12 gnucash/src/engine/sixtp-dom-generators.c:1.13
--- gnucash/src/engine/sixtp-dom-generators.c:1.12 Mon May 14 05:29:22 2001
+++ gnucash/src/engine/sixtp-dom-generators.c Tue May 15 10:50:05 2001
@@ -50,6 +50,18 @@
}
xmlNodePtr
+int_to_dom_tree(const char *tag, gint64 val)
+{
+ gchar *text;
+ xmlNodePtr result;
+
+ text = g_strdup_printf("%lld", val);
+ result = text_to_dom_tree(tag, text);
+ g_free(text);
+ return result;
+}
+
+xmlNodePtr
guid_to_dom_tree(const char *tag, const GUID* gid)
{
char guid_str[GUID_ENCODING_LENGTH + 1];
Index: gnucash/src/engine/sixtp-dom-generators.h
diff -u gnucash/src/engine/sixtp-dom-generators.h:1.5 gnucash/src/engine/sixtp-dom-generators.h:1.6
--- gnucash/src/engine/sixtp-dom-generators.h:1.5 Sun Mar 4 05:09:22 2001
+++ gnucash/src/engine/sixtp-dom-generators.h Tue May 15 10:50:05 2001
@@ -38,6 +38,7 @@
#include "kvp_frame.h"
xmlNodePtr text_to_dom_tree(const char *tag, const char *str);
+xmlNodePtr int_to_dom_tree(const char *tag, gint64 val);
xmlNodePtr guid_to_dom_tree(const char *tag, const GUID* gid);
xmlNodePtr commodity_ref_to_dom_tree(const char *tag, const gnc_commodity *c);
xmlNodePtr timespec_to_dom_tree(const char *tag, const Timespec *spec);
Index: gnucash/src/gnome/new-user-callbacks.c
diff -u gnucash/src/gnome/new-user-callbacks.c:1.8 gnucash/src/gnome/new-user-callbacks.c:1.9
--- gnucash/src/gnome/new-user-callbacks.c:1.8 Sat May 12 06:50:32 2001
+++ gnucash/src/gnome/new-user-callbacks.c Tue May 15 10:50:45 2001
@@ -109,12 +109,8 @@
NULL, TRUE);
gnc_ui_delete_new_user_window();
- gnc_ui_delete_nu_account_list();
gh_eval_str("(gnc:default-ui-start)");
-
- /* now we need to load all the accounts into the program */
-
gh_eval_str("(gnc:show-main-window)");
gh_eval_str("(gnc:hook-run-danglers gnc:*book-opened-hook* #f)");
@@ -122,10 +118,8 @@
if(our_final_group)
{
- AccountGroup *group;
-
- group = gnc_book_get_group(gncGetCurrentBook());
- xaccGroupConcatGroup(group, our_final_group);
+ xaccGroupConcatGroup(gnc_book_get_group(gncGetCurrentBook()),
+ our_final_group);
}
}
@@ -156,7 +150,6 @@
gnc_ui_delete_new_user_window();
gnc_ui_delete_nu_cancel_dialog();
- gnc_ui_delete_nu_account_list();
gh_eval_str("(gnc:default-ui-start)");
gh_eval_str("(gnc:show-main-window)");
@@ -230,18 +223,6 @@
g_slist_free (list);
}
-
-void
-on_newUserDruidFinishPage_prepare (GnomeDruidPage *gnomedruidpage,
- gpointer arg1,
- gpointer user_data)
-{
- /* gnc_ui_show_nu_account_list(); */
-
- /* need to reset the account guids merge the lists and replace the
- commodity with the one determined earlier here */
- /* need to fill up the account list info here */
-}
static gpointer
add_to_tree_account(Account* toadd, gpointer data)
Index: gnucash/src/gnome/new-user-callbacks.h
diff -u gnucash/src/gnome/new-user-callbacks.h:1.7 gnucash/src/gnome/new-user-callbacks.h:1.8
--- gnucash/src/gnome/new-user-callbacks.h:1.7 Sat May 12 06:50:32 2001
+++ gnucash/src/gnome/new-user-callbacks.h Tue May 15 10:50:45 2001
@@ -62,11 +62,6 @@
gpointer user_data);
void
-on_newUserDruidFinishPage_prepare (GnomeDruidPage *gnomedruidpage,
- gpointer arg1,
- gpointer user_data);
-
-void
on_newAccountTypesList_select_row (GtkCList *clist,
gint row,
gint column,
Index: gnucash/src/gnome/new-user-funs.c
diff -u gnucash/src/gnome/new-user-funs.c:1.7 gnucash/src/gnome/new-user-funs.c:1.8
--- gnucash/src/gnome/new-user-funs.c:1.7 Sat May 12 06:50:32 2001
+++ gnucash/src/gnome/new-user-funs.c Tue May 15 10:50:45 2001
@@ -41,7 +41,6 @@
static GtkWidget *newUserDialog = NULL;
static GtkWidget *cancelDialog = NULL;
-static GtkWidget *accountList = NULL;
static Account*
clone_account(const Account* from, gnc_commodity *com)
@@ -351,14 +350,3 @@
return deleteit(&cancelDialog);
}
-int
-gnc_ui_show_nu_account_list(void)
-{
- return createit(create_newAccountList, &accountList);
-}
-
-int
-gnc_ui_delete_nu_account_list(void)
-{
- return deleteit(&accountList);
-}
Index: gnucash/src/gnome/new-user-funs.h
diff -u gnucash/src/gnome/new-user-funs.h:1.4 gnucash/src/gnome/new-user-funs.h:1.5
--- gnucash/src/gnome/new-user-funs.h:1.4 Sat May 12 06:50:33 2001
+++ gnucash/src/gnome/new-user-funs.h Tue May 15 10:50:45 2001
@@ -35,9 +35,6 @@
int gnc_ui_show_nu_cancel_dialog(void);
int gnc_ui_delete_nu_cancel_dialog(void);
-int gnc_ui_show_nu_account_list(void);
-int gnc_ui_delete_nu_account_list(void);
-
void gnc_new_user_set_balance (Account *account, gnc_numeric balance);
gnc_numeric gnc_new_user_get_balance (Account *account);
Index: gnucash/src/gnome/new-user-interface.c
diff -u gnucash/src/gnome/new-user-interface.c:1.11 gnucash/src/gnome/new-user-interface.c:1.12
--- gnucash/src/gnome/new-user-interface.c:1.11 Sun May 13 05:05:35 2001
+++ gnucash/src/gnome/new-user-interface.c Tue May 15 10:50:45 2001
@@ -467,186 +467,8 @@
gtk_signal_connect (GTK_OBJECT (newUserDruidFinishPage), "finish",
GTK_SIGNAL_FUNC (on_newUserDruidFinishPage_finish),
NULL);
- gtk_signal_connect (GTK_OBJECT (newUserDruidFinishPage), "prepare",
- GTK_SIGNAL_FUNC (on_newUserDruidFinishPage_prepare),
- NULL);
return newUserDialog;
-}
-
-GtkWidget*
-create_newAccountList (void)
-{
- GtkWidget *newAccountList;
- GtkWidget *newAccountTopVBox;
- GtkWidget *newAccountLable;
- GtkWidget *newAccountHPaned;
- GtkWidget *newAccountTreeScrolledWindow;
- GtkWidget *newAccountTree;
- GtkWidget *newAccountTreeAccountLabel;
- GtkWidget *newAccountTreeDestriptionLabel;
- GtkWidget *newAccountTreeStartingBalanceLabel;
- GtkWidget *vbox4;
- GtkWidget *newAccountAccountNameLabel;
- GtkWidget *newAccountEnterStartingBalanceLabel;
- GtkWidget *newAccountStartingBalanceEntry;
- GtkWidget *hbox2;
- GtkWidget *newAccountSelectAllButton;
- GtkWidget *newAccountOKButton;
-
- newAccountList = gtk_window_new (GTK_WINDOW_TOPLEVEL);
- gtk_widget_set_name (newAccountList, "newAccountList");
- gtk_object_set_data (GTK_OBJECT (newAccountList), "newAccountList", newAccountList);
- gtk_widget_set_usize (newAccountList, 200, 400);
- gtk_window_set_title (GTK_WINDOW (newAccountList), _("New Account List"));
- gtk_window_set_default_size (GTK_WINDOW (newAccountList), 640, 480);
-
- newAccountTopVBox = gtk_vbox_new (FALSE, 0);
- gtk_widget_set_name (newAccountTopVBox, "newAccountTopVBox");
- gtk_widget_ref (newAccountTopVBox);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountTopVBox", newAccountTopVBox,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountTopVBox);
- gtk_container_add (GTK_CONTAINER (newAccountList), newAccountTopVBox);
-
- newAccountLable = gtk_label_new (_("If you would like the accounts to have a starting balance click on the account line and enter the starting balance in the text entry box on the right."));
- gtk_widget_set_name (newAccountLable, "newAccountLable");
- gtk_widget_ref (newAccountLable);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountLable", newAccountLable,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountLable);
- gtk_box_pack_start (GTK_BOX (newAccountTopVBox), newAccountLable, FALSE, TRUE, 0);
- gtk_label_set_justify (GTK_LABEL (newAccountLable), GTK_JUSTIFY_FILL);
- gtk_label_set_line_wrap (GTK_LABEL (newAccountLable), TRUE);
- gtk_misc_set_alignment (GTK_MISC (newAccountLable), 0.0800003, 0.08);
- gtk_misc_set_padding (GTK_MISC (newAccountLable), 1, 1);
-
- newAccountHPaned = gtk_hpaned_new ();
- gtk_widget_set_name (newAccountHPaned, "newAccountHPaned");
- gtk_widget_ref (newAccountHPaned);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountHPaned", newAccountHPaned,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountHPaned);
- gtk_box_pack_start (GTK_BOX (newAccountTopVBox), newAccountHPaned, TRUE, TRUE, 0);
- gtk_paned_set_position (GTK_PANED (newAccountHPaned), 1);
-
- newAccountTreeScrolledWindow = gtk_scrolled_window_new (NULL, NULL);
- gtk_widget_set_name (newAccountTreeScrolledWindow, "newAccountTreeScrolledWindow");
- gtk_widget_ref (newAccountTreeScrolledWindow);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountTreeScrolledWindow", newAccountTreeScrolledWindow,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountTreeScrolledWindow);
- gtk_paned_pack1 (GTK_PANED (newAccountHPaned), newAccountTreeScrolledWindow, FALSE, FALSE);
-
- newAccountTree = gtk_ctree_new (3, 0);
- gtk_widget_set_name (newAccountTree, "newAccountTree");
- gtk_widget_ref (newAccountTree);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountTree", newAccountTree,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountTree);
- gtk_container_add (GTK_CONTAINER (newAccountTreeScrolledWindow), newAccountTree);
- gtk_clist_set_column_width (GTK_CLIST (newAccountTree), 0, 86);
- gtk_clist_set_column_width (GTK_CLIST (newAccountTree), 1, 233);
- gtk_clist_set_column_width (GTK_CLIST (newAccountTree), 2, 80);
- gtk_clist_column_titles_show (GTK_CLIST (newAccountTree));
-
- newAccountTreeAccountLabel = gtk_label_new (_("Account Name"));
- gtk_widget_set_name (newAccountTreeAccountLabel, "newAccountTreeAccountLabel");
- gtk_widget_ref (newAccountTreeAccountLabel);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountTreeAccountLabel", newAccountTreeAccountLabel,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountTreeAccountLabel);
- gtk_clist_set_column_widget (GTK_CLIST (newAccountTree), 0, newAccountTreeAccountLabel);
-
- newAccountTreeDestriptionLabel = gtk_label_new (_("Description"));
- gtk_widget_set_name (newAccountTreeDestriptionLabel, "newAccountTreeDestriptionLabel");
- gtk_widget_ref (newAccountTreeDestriptionLabel);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountTreeDestriptionLabel", newAccountTreeDestriptionLabel,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountTreeDestriptionLabel);
- gtk_clist_set_column_widget (GTK_CLIST (newAccountTree), 1, newAccountTreeDestriptionLabel);
-
- newAccountTreeStartingBalanceLabel = gtk_label_new (_("Starting Balance"));
- gtk_widget_set_name (newAccountTreeStartingBalanceLabel, "newAccountTreeStartingBalanceLabel");
- gtk_widget_ref (newAccountTreeStartingBalanceLabel);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountTreeStartingBalanceLabel", newAccountTreeStartingBalanceLabel,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountTreeStartingBalanceLabel);
- gtk_clist_set_column_widget (GTK_CLIST (newAccountTree), 2, newAccountTreeStartingBalanceLabel);
-
- vbox4 = gtk_vbox_new (FALSE, 0);
- gtk_widget_set_name (vbox4, "vbox4");
- gtk_widget_ref (vbox4);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "vbox4", vbox4,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (vbox4);
- gtk_paned_pack2 (GTK_PANED (newAccountHPaned), vbox4, TRUE, TRUE);
-
- newAccountAccountNameLabel = gtk_label_new (_("Account: "));
- gtk_widget_set_name (newAccountAccountNameLabel, "newAccountAccountNameLabel");
- gtk_widget_ref (newAccountAccountNameLabel);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountAccountNameLabel", newAccountAccountNameLabel,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountAccountNameLabel);
- gtk_box_pack_start (GTK_BOX (vbox4), newAccountAccountNameLabel, FALSE, FALSE, 0);
- gtk_label_set_justify (GTK_LABEL (newAccountAccountNameLabel), GTK_JUSTIFY_RIGHT);
- gtk_label_set_line_wrap (GTK_LABEL (newAccountAccountNameLabel), TRUE);
- gtk_misc_set_alignment (GTK_MISC (newAccountAccountNameLabel), 0.49, 0.5);
-
- newAccountEnterStartingBalanceLabel = gtk_label_new (_("Enter Starting Balance"));
- gtk_widget_set_name (newAccountEnterStartingBalanceLabel, "newAccountEnterStartingBalanceLabel");
- gtk_widget_ref (newAccountEnterStartingBalanceLabel);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountEnterStartingBalanceLabel", newAccountEnterStartingBalanceLabel,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountEnterStartingBalanceLabel);
- gtk_box_pack_start (GTK_BOX (vbox4), newAccountEnterStartingBalanceLabel, FALSE, FALSE, 0);
- gtk_label_set_justify (GTK_LABEL (newAccountEnterStartingBalanceLabel), GTK_JUSTIFY_RIGHT);
-
- newAccountStartingBalanceEntry = gtk_entry_new ();
- gtk_widget_set_name (newAccountStartingBalanceEntry, "newAccountStartingBalanceEntry");
- gtk_widget_ref (newAccountStartingBalanceEntry);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountStartingBalanceEntry", newAccountStartingBalanceEntry,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountStartingBalanceEntry);
- gtk_box_pack_start (GTK_BOX (vbox4), newAccountStartingBalanceEntry, FALSE, FALSE, 0);
- gtk_widget_set_usize (newAccountStartingBalanceEntry, 100, -2);
-
- hbox2 = gtk_hbox_new (FALSE, 5);
- gtk_widget_set_name (hbox2, "hbox2");
- gtk_widget_ref (hbox2);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "hbox2", hbox2,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (hbox2);
- gtk_box_pack_start (GTK_BOX (newAccountTopVBox), hbox2, FALSE, FALSE, 0);
- gtk_container_set_border_width (GTK_CONTAINER (hbox2), 5);
-
- newAccountSelectAllButton = gtk_button_new_with_label (_("Select All"));
- gtk_widget_set_name (newAccountSelectAllButton, "newAccountSelectAllButton");
- gtk_widget_ref (newAccountSelectAllButton);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountSelectAllButton", newAccountSelectAllButton,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountSelectAllButton);
- gtk_box_pack_start (GTK_BOX (hbox2), newAccountSelectAllButton, FALSE, FALSE, 5);
-
- newAccountOKButton = gtk_button_new_with_label (_("OK"));
- gtk_widget_set_name (newAccountOKButton, "newAccountOKButton");
- gtk_widget_ref (newAccountOKButton);
- gtk_object_set_data_full (GTK_OBJECT (newAccountList), "newAccountOKButton", newAccountOKButton,
- (GtkDestroyNotify) gtk_widget_unref);
- gtk_widget_show (newAccountOKButton);
- gtk_box_pack_start (GTK_BOX (hbox2), newAccountOKButton, FALSE, FALSE, 5);
-
- gtk_signal_connect (GTK_OBJECT (newAccountTree), "select_row",
- GTK_SIGNAL_FUNC (on_newAccountTree_select_row),
- NULL);
- gtk_signal_connect (GTK_OBJECT (newAccountSelectAllButton), "clicked",
- GTK_SIGNAL_FUNC (on_newAccountSelectAllButton_clicked),
- NULL);
- gtk_signal_connect (GTK_OBJECT (newAccountOKButton), "clicked",
- GTK_SIGNAL_FUNC (on_newAccountOKButton_clicked),
- NULL);
-
- return newAccountList;
}
GtkWidget*
Index: gnucash/src/gnome/new-user-interface.h
diff -u gnucash/src/gnome/new-user-interface.h:1.1 gnucash/src/gnome/new-user-interface.h:1.2
--- gnucash/src/gnome/new-user-interface.h:1.1 Thu Jan 11 16:32:20 2001
+++ gnucash/src/gnome/new-user-interface.h Tue May 15 10:50:46 2001
@@ -3,5 +3,4 @@
*/
GtkWidget* create_newUserDialog (void);
-GtkWidget* create_newAccountList (void);
GtkWidget* create_addAccountCancelDialog (void);
Index: gnucash/src/gnome/new-user.glade
diff -u gnucash/src/gnome/new-user.glade:1.11 gnucash/src/gnome/new-user.glade:1.12
--- gnucash/src/gnome/new-user.glade:1.11 Sun May 13 05:05:35 2001
+++ gnucash/src/gnome/new-user.glade Tue May 15 10:50:46 2001
@@ -550,11 +550,6 @@
<handler>on_newUserDruidFinishPage_finish</handler>
<last_modification_time>Tue, 09 Jan 2001 18:08:04 GMT</last_modification_time>
</signal>
- <signal>
- <name>prepare</name>
- <handler>on_newUserDruidFinishPage_prepare</handler>
- <last_modification_time>Sun, 14 Jan 2001 18:14:22 GMT</last_modification_time>
- </signal>
<title>Finish Account Setup</title>
<text>Press `Finish' if everything is OK.</text>
<background_color>25,25,112</background_color>
@@ -562,237 +557,6 @@
<textbox_color>255,255,255</textbox_color>
<text_color>0,0,0</text_color>
<title_color>255,255,255</title_color>
- </widget>
- </widget>
-</widget>
-
-<widget>
- <class>GtkWindow</class>
- <name>newAccountList</name>
- <width>200</width>
- <height>400</height>
- <title>New Account List</title>
- <type>GTK_WINDOW_TOPLEVEL</type>
- <position>GTK_WIN_POS_NONE</position>
- <modal>False</modal>
- <default_width>640</default_width>
- <default_height>480</default_height>
- <allow_shrink>False</allow_shrink>
- <allow_grow>True</allow_grow>
- <auto_shrink>False</auto_shrink>
-
- <widget>
- <class>GtkVBox</class>
- <name>newAccountTopVBox</name>
- <homogeneous>False</homogeneous>
- <spacing>0</spacing>
-
- <widget>
- <class>GtkLabel</class>
- <name>newAccountLable</name>
- <label>If you would like the accounts to have a starting balance click on the account line and enter the starting balance in the text entry box on the right.</label>
- <justify>GTK_JUSTIFY_FILL</justify>
- <wrap>True</wrap>
- <xalign>0.0800003</xalign>
- <yalign>0.08</yalign>
- <xpad>1</xpad>
- <ypad>1</ypad>
- <child>
- <padding>0</padding>
- <expand>False</expand>
- <fill>True</fill>
- </child>
- </widget>
-
- <widget>
- <class>GtkHPaned</class>
- <name>newAccountHPaned</name>
- <handle_size>10</handle_size>
- <gutter_size>6</gutter_size>
- <position>1</position>
- <child>
- <padding>0</padding>
- <expand>True</expand>
- <fill>True</fill>
- </child>
-
- <widget>
- <class>GtkScrolledWindow</class>
- <name>newAccountTreeScrolledWindow</name>
- <hscrollbar_policy>GTK_POLICY_ALWAYS</hscrollbar_policy>
- <vscrollbar_policy>GTK_POLICY_ALWAYS</vscrollbar_policy>
- <hupdate_policy>GTK_UPDATE_CONTINUOUS</hupdate_policy>
- <vupdate_policy>GTK_UPDATE_CONTINUOUS</vupdate_policy>
- <child>
- <shrink>False</shrink>
- <resize>False</resize>
- </child>
-
- <widget>
- <class>GtkCTree</class>
- <name>newAccountTree</name>
- <can_focus>True</can_focus>
- <signal>
- <name>select_row</name>
- <handler>on_newAccountTree_select_row</handler>
- <last_modification_time>Tue, 03 Apr 2001 19:46:19 GMT</last_modification_time>
- </signal>
- <columns>3</columns>
- <column_widths>86,233,80</column_widths>
- <selection_mode>GTK_SELECTION_SINGLE</selection_mode>
- <show_titles>True</show_titles>
- <shadow_type>GTK_SHADOW_IN</shadow_type>
-
- <widget>
- <class>GtkLabel</class>
- <child_name>CTree:title</child_name>
- <name>newAccountTreeAccountLabel</name>
- <label>Account Name</label>
- <justify>GTK_JUSTIFY_CENTER</justify>
- <wrap>False</wrap>
- <xalign>0.5</xalign>
- <yalign>0.5</yalign>
- <xpad>0</xpad>
- <ypad>0</ypad>
- </widget>
-
- <widget>
- <class>GtkLabel</class>
- <child_name>CTree:title</child_name>
- <name>newAccountTreeDestriptionLabel</name>
- <label>Description</label>
- <justify>GTK_JUSTIFY_CENTER</justify>
- <wrap>False</wrap>
- <xalign>0.5</xalign>
- <yalign>0.5</yalign>
- <xpad>0</xpad>
- <ypad>0</ypad>
- </widget>
-
- <widget>
- <class>GtkLabel</class>
- <child_name>CTree:title</child_name>
- <name>newAccountTreeStartingBalanceLabel</name>
- <label>Starting Balance</label>
- <justify>GTK_JUSTIFY_CENTER</justify>
- <wrap>False</wrap>
- <xalign>0.5</xalign>
- <yalign>0.5</yalign>
- <xpad>0</xpad>
- <ypad>0</ypad>
- </widget>
- </widget>
- </widget>
-
- <widget>
- <class>GtkVBox</class>
- <name>vbox4</name>
- <homogeneous>False</homogeneous>
- <spacing>0</spacing>
- <child>
- <shrink>True</shrink>
- <resize>True</resize>
- </child>
-
- <widget>
- <class>GtkLabel</class>
- <name>newAccountAccountNameLabel</name>
- <label>Account: </label>
- <justify>GTK_JUSTIFY_RIGHT</justify>
- <wrap>True</wrap>
- <xalign>0.49</xalign>
- <yalign>0.5</yalign>
- <xpad>0</xpad>
- <ypad>0</ypad>
- <child>
- <padding>0</padding>
- <expand>False</expand>
- <fill>False</fill>
- </child>
- </widget>
-
- <widget>
- <class>GtkLabel</class>
- <name>newAccountEnterStartingBalanceLabel</name>
- <label>Enter Starting Balance</label>
- <justify>GTK_JUSTIFY_RIGHT</justify>
- <wrap>False</wrap>
- <xalign>0.5</xalign>
- <yalign>0.5</yalign>
- <xpad>0</xpad>
- <ypad>0</ypad>
- <child>
- <padding>0</padding>
- <expand>False</expand>
- <fill>False</fill>
- </child>
- </widget>
-
- <widget>
- <class>GtkEntry</class>
- <name>newAccountStartingBalanceEntry</name>
- <width>100</width>
- <can_focus>True</can_focus>
- <editable>True</editable>
- <text_visible>True</text_visible>
- <text_max_length>0</text_max_length>
- <text></text>
- <child>
- <padding>0</padding>
- <expand>False</expand>
- <fill>False</fill>
- </child>
- </widget>
- </widget>
- </widget>
-
- <widget>
- <class>GtkHBox</class>
- <name>hbox2</name>
- <border_width>5</border_width>
- <homogeneous>False</homogeneous>
- <spacing>5</spacing>
- <child>
- <padding>0</padding>
- <expand>False</expand>
- <fill>False</fill>
- </child>
-
- <widget>
- <class>GtkButton</class>
- <name>newAccountSelectAllButton</name>
- <can_focus>True</can_focus>
- <signal>
- <name>clicked</name>
- <handler>on_newAccountSelectAllButton_clicked</handler>
- <last_modification_time>Tue, 10 Apr 2001 16:54:25 GMT</last_modification_time>
- </signal>
- <label>Select All</label>
- <relief>GTK_RELIEF_NORMAL</relief>
- <child>
- <padding>5</padding>
- <expand>False</expand>
- <fill>False</fill>
- </child>
- </widget>
-
- <widget>
- <class>GtkButton</class>
- <name>newAccountOKButton</name>
- <can_focus>True</can_focus>
- <signal>
- <name>clicked</name>
- <handler>on_newAccountOKButton_clicked</handler>
- <last_modification_time>Tue, 10 Apr 2001 16:54:32 GMT</last_modification_time>
- </signal>
- <label>OK</label>
- <relief>GTK_RELIEF_NORMAL</relief>
- <child>
- <padding>5</padding>
- <expand>False</expand>
- <fill>False</fill>
- </child>
- </widget>
</widget>
</widget>
</widget>
Index: gnucash/src/gnome/window-main.c
diff -u gnucash/src/gnome/window-main.c:1.125 gnucash/src/gnome/window-main.c:1.126
--- gnucash/src/gnome/window-main.c:1.125 Sun May 13 05:18:34 2001
+++ gnucash/src/gnome/window-main.c Tue May 15 11:14:25 2001
@@ -479,7 +479,8 @@
********************************************************************/
void
-gnc_main_window_restore(GNCMainInfo * wind, char * filename) {
+gnc_main_window_restore(GNCMainInfo * wind, const char * filename)
+{
char * encoded;
char * session_name;
gboolean old_format_file;
Index: gnucash/src/gnome/window-main.h
diff -u gnucash/src/gnome/window-main.h:1.15 gnucash/src/gnome/window-main.h:1.16
--- gnucash/src/gnome/window-main.h:1.15 Tue Apr 24 18:11:09 2001
+++ gnucash/src/gnome/window-main.h Tue May 15 11:14:26 2001
@@ -54,7 +54,8 @@
GNCMainInfo * gnc_main_window_new(void);
void gnc_main_window_destroy(GNCMainInfo * wind);
void gnc_main_window_save(GNCMainInfo * wind, char * session);
-void gnc_main_window_restore(GNCMainInfo * wind, char * session);
+void gnc_main_window_restore(GNCMainInfo * wind,
+ const char * session);
GtkWidget * gnc_main_window_get_toplevel(GNCMainInfo * wind);
void gnc_main_window_create_child_toolbar(GNCMainInfo * mi,
GNCMainChildInfo * child);
Index: gnucash/src/scm/Makefile.am
diff -u gnucash/src/scm/Makefile.am:1.15 gnucash/src/scm/Makefile.am:1.16
--- gnucash/src/scm/Makefile.am:1.15 Thu May 3 03:47:23 2001
+++ gnucash/src/scm/Makefile.am Tue May 15 11:27:54 2001
@@ -1,5 +1,5 @@
-SUBDIRS = gnumeric printing qif-import report srfi
+SUBDIRS = gnumeric printing qif-import report
gncscmdir = ${GNC_SCM_INSTALL_DIR}
Index: gnucash/src/scm/commodity-utilities.scm
diff -u gnucash/src/scm/commodity-utilities.scm:1.19 gnucash/src/scm/commodity-utilities.scm:1.21
--- gnucash/src/scm/commodity-utilities.scm:1.19 Tue May 15 02:34:14 2001
+++ gnucash/src/scm/commodity-utilities.scm Wed May 16 01:31:16 2001
@@ -107,6 +107,13 @@
(gnc:monetary->string
(gnc:make-gnc-monetary commodity numeric)))
+;; Helper for exchange below
+(define (gnc:exchange-by-euro-numeric
+ foreign-commodity foreign-numeric domestic date)
+ (gnc:exchange-by-euro
+ (gnc:make-gnc-monetary foreign-commodity foreign-numeric)
+ domestic date))
+
;; Create a list of all prices of 'price-commodity' measured in the
;; currency 'report-currency'. The prices are taken from all splits in
;; 'currency-accounts' up until the date 'end-date-tp'. Returns a list
@@ -136,12 +143,24 @@
(list transaction-comm
value-amount share-amount))))
- ;; (warn "gnc:get-commodity-totalavg-prices: value "
- ;; (gnc:commodity-numeric->string
- ;; (first foreignlist) (second foreignlist))
- ;; " bought shares "
- ;; (gnc:commodity-numeric->string
- ;; price-commodity (third foreignlist)))
+ ;;(warn "gnc:get-commodity-totalavg-prices: value "
+ ;; (gnc:commodity-numeric->string
+ ;; (first foreignlist) (second foreignlist))
+ ;; " bought shares "
+ ;; (gnc:commodity-numeric->string
+ ;;price-commodity (third foreignlist)))
+
+ ;; Try EURO exchange if necessary
+ (if (not (gnc:commodity-equiv? (first foreignlist)
+ report-currency))
+ (let ((exchanged (gnc:exchange-by-euro-numeric
+ (first foreignlist) (second foreignlist)
+ report-currency transaction-date)))
+ (if exchanged
+ (set! foreignlist
+ (list report-currency
+ (gnc:gnc-monetary-amount exchanged)
+ (third foreignlist))))))
(list
transaction-date
@@ -227,6 +246,18 @@
;;(gnc:commodity-numeric->string
;; price-commodity (third foreignlist)))
+ ;; Try EURO exchange if necessary
+ (if (not (gnc:commodity-equiv? (first foreignlist)
+ report-currency))
+ (let ((exchanged (gnc:exchange-by-euro-numeric
+ (first foreignlist) (second foreignlist)
+ report-currency transaction-date)))
+ (if exchanged
+ (set! foreignlist
+ (list report-currency
+ (gnc:gnc-monetary-amount exchanged)
+ (third foreignlist))))))
+
(list
transaction-date
(if (not (gnc:commodity-equiv? (first foreignlist)
@@ -541,24 +572,43 @@
;; Actual functions for exchanging amounts.
+;; Exchange EURO currencies to each other, or returns #f if one of
+;; them is not an EURO currency at the given time. The function takes
+;; the <gnc-monetary> 'foreign' amount, the <gnc:commodity*>
+;; 'domestic' commodity, and a <gnc:time-pair> 'date'. It exchanges
+;; the amount into the domestic currency. If the 'date' is #f, it
+;; doesn't check for it. Returns a <gnc-monetary>, or #f if at least
+;; one of the currencies is not in the EURO.
+(define (gnc:exchange-by-euro foreign domestic date)
+ (and (gnc:is-euro-currency domestic)
+ (gnc:is-euro-currency (gnc:gnc-monetary-commodity foreign))
+ ;; FIXME: implement the date check.
+ (gnc:make-gnc-monetary
+ domestic
+ (gnc:convert-from-euro
+ domestic
+ (gnc:convert-to-euro (gnc:gnc-monetary-commodity foreign)
+ (gnc:gnc-monetary-amount foreign))))))
+
;; This one returns the ready-to-use function for calculation of the
;; exchange rates. The returned function takes a <gnc-monetary> and
-;; the domestic-commodity, exchanges the amount into the domestic
-;; currency and returns a <gnc-monetary>.
+;; the <gnc:commodity*> domestic-commodity, exchanges the amount into
+;; the domestic currency and returns a <gnc-monetary>.
(define (gnc:make-exchange-function exchange-alist)
(let ((exchangelist exchange-alist))
(lambda (foreign domestic)
(if foreign
- (gnc:make-gnc-monetary
- domestic
- (let ((pair (assoc (gnc:gnc-monetary-commodity foreign)
- exchangelist)))
- (if (not pair)
- (gnc:numeric-zero)
- (gnc:numeric-mul (gnc:gnc-monetary-amount foreign)
- (cadr pair)
- (gnc:commodity-get-fraction domestic)
- GNC-RND-ROUND))))
+ (or (gnc:exchange-by-euro foreign domestic #f)
+ (gnc:make-gnc-monetary
+ domestic
+ (let ((pair (assoc (gnc:gnc-monetary-commodity foreign)
+ exchangelist)))
+ (if (not pair)
+ (gnc:numeric-zero)
+ (gnc:numeric-mul (gnc:gnc-monetary-amount foreign)
+ (cadr pair)
+ (gnc:commodity-get-fraction domestic)
+ GNC-RND-ROUND)))))
#f))))
;; Helper for the gnc:exchange-by-pricalist* below. Exchange the
@@ -617,12 +667,13 @@
(define (gnc:exchange-by-pricedb-latest
foreign domestic)
(if (and (record? foreign) (gnc:gnc-monetary? foreign))
- (gnc:exchange-by-pricedb-helper
- foreign domestic
- (gnc:pricedb-lookup-latest
- (gnc:book-get-pricedb (gnc:get-current-book))
- (gnc:gnc-monetary-commodity foreign)
- domestic))
+ (or (gnc:exchange-by-euro foreign domestic #f)
+ (gnc:exchange-by-pricedb-helper
+ foreign domestic
+ (gnc:pricedb-lookup-latest
+ (gnc:book-get-pricedb (gnc:get-current-book))
+ (gnc:gnc-monetary-commodity foreign)
+ domestic)))
#f))
;; Yet another ready-to-use function for calculation of exchange
@@ -637,12 +688,13 @@
foreign domestic date)
(if (and (record? foreign) (gnc:gnc-monetary? foreign)
date)
- (gnc:exchange-by-pricedb-helper
- foreign domestic
- (gnc:pricedb-lookup-nearest-in-time
- (gnc:book-get-pricedb (gnc:get-current-book))
- (gnc:gnc-monetary-commodity foreign)
- domestic date))
+ (or (gnc:exchange-by-euro foreign domestic date)
+ (gnc:exchange-by-pricedb-helper
+ foreign domestic
+ (gnc:pricedb-lookup-nearest-in-time
+ (gnc:book-get-pricedb (gnc:get-current-book))
+ (gnc:gnc-monetary-commodity foreign)
+ domestic date)))
#f))
;; Exchange by the nearest price from pricelist. This function takes
@@ -655,12 +707,22 @@
pricealist foreign domestic date)
(if (and (record? foreign) (gnc:gnc-monetary? foreign)
date (not (null? pricealist)))
- (gnc:exchange-by-pricevalue-helper
- foreign domestic
- (gnc:pricealist-lookup-nearest-in-time
- pricealist (gnc:gnc-monetary-commodity foreign) date))
+ (or (gnc:exchange-by-euro foreign domestic date)
+ (gnc:exchange-by-pricevalue-helper
+ foreign domestic
+ (gnc:pricealist-lookup-nearest-in-time
+ pricealist (gnc:gnc-monetary-commodity foreign) date)))
#f))
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Choosing exchange functions made easy -- get the right function by
+;; the value of a multichoice 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
;; gnc:options-add-price-source!.
@@ -688,10 +750,25 @@
(lambda (foreign domestic date)
(gnc:exchange-by-pricealist-nearest
pricealist foreign domestic date))))
+ ('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)
(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"))))
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Functions using the exchange-fn's above to get from a
+;; commodity-collector to one value.
+
;; Adds all different commodities in the commodity-collector <foreign>
;; by using the exchange rates of <exchange-fn> to calculate the
Index: gnucash/src/scm/date-utilities.scm
diff -u gnucash/src/scm/date-utilities.scm:1.35 gnucash/src/scm/date-utilities.scm:1.36
--- gnucash/src/scm/date-utilities.scm:1.35 Sat May 12 03:40:57 2001
+++ gnucash/src/scm/date-utilities.scm Tue May 15 11:27:54 2001
@@ -19,8 +19,9 @@
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
+(use-modules (srfi srfi-19))
+
(gnc:support "date-utilities.scm")
-(gnc:depend "srfi/srfi-19.scm")
(define gnc:reldate-list '())
Index: gnucash/src/scm/html-utilities.scm
diff -u gnucash/src/scm/html-utilities.scm:1.38 gnucash/src/scm/html-utilities.scm:1.39
--- gnucash/src/scm/html-utilities.scm:1.38 Sat May 12 02:44:21 2001
+++ gnucash/src/scm/html-utilities.scm Wed May 16 02:52:46 2001
@@ -670,5 +670,5 @@
p
(gnc:html-markup-h2 (_ "No data"))
(gnc:html-markup-p
- (_ "The selected accounts contain no data for the selected time period")))
+ (_ "The selected accounts contain no data (or only zeroes) for the selected time period")))
p))
Index: gnucash/src/scm/main.scm
diff -u gnucash/src/scm/main.scm:1.43 gnucash/src/scm/main.scm:1.44
--- gnucash/src/scm/main.scm:1.43 Thu May 10 17:55:08 2001
+++ gnucash/src/scm/main.scm Tue May 15 11:27:55 2001
@@ -15,6 +15,11 @@
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
+;; Load the srfis (eventually, we should see where these are needed
+;; and only have the use-modules statements in those files).
+(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-8))
+
;; A list of things to do when in batch mode after the initial
;; startup. List items may be strings, in wich case they're read and
;; evaluated or procedures, in which case they're just executed.
@@ -27,11 +32,6 @@
(gnc:shutdown 1))
(gnc:setup-debugging)
-
- ;; Load the srfis
- (gnc:load "srfi/srfi-8.guile.scm")
- (gnc:load "srfi/srfi-1.unclear.scm")
- (gnc:load "srfi/srfi-1.r5rs.scm")
;; Now we can load a bunch of files.
(gnc:depend "doc.scm")
Index: gnucash/src/scm/report.scm
diff -u gnucash/src/scm/report.scm:1.48 gnucash/src/scm/report.scm:1.49
--- gnucash/src/scm/report.scm:1.48 Sat May 12 06:50:35 2001
+++ gnucash/src/scm/report.scm Tue May 15 15:04:01 2001
@@ -276,8 +276,16 @@
(define gnc:report-dirty?
(record-accessor <report> 'dirty?))
-(define gnc:report-set-dirty?!
+(define gnc:report-set-dirty?-internal!
(record-modifier <report> 'dirty?))
+
+(define (gnc:report-set-dirty?! report val)
+ (gnc:report-set-dirty?-internal! report val)
+ (let* ((template (hash-ref *gnc:_report-templates_*
+ (gnc:report-type report)))
+ (cb (gnc:report-template-options-changed-cb template)))
+ (if (and cb (procedure? cb))
+ (cb report))))
(define gnc:report-editor-widget
(record-accessor <report> 'editor-widget))
Index: gnucash/src/scm/text-export.scm
diff -u gnucash/src/scm/text-export.scm:1.12 gnucash/src/scm/text-export.scm:1.13
--- gnucash/src/scm/text-export.scm:1.12 Sat Apr 7 18:16:53 2001
+++ gnucash/src/scm/text-export.scm Tue May 15 11:27:55 2001
@@ -17,11 +17,12 @@
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
+(use-modules (srfi srfi-1))
+
(gnc:support "text-export.scm")
(require 'pretty-print)
(gnc:depend "engine-utilities.scm")
-(gnc:depend "srfi-1.scm")
;; TODO
;;
Index: gnucash/src/scm/utilities.scm
diff -u gnucash/src/scm/utilities.scm:1.9 gnucash/src/scm/utilities.scm:1.10
--- gnucash/src/scm/utilities.scm:1.9 Tue Apr 17 16:37:36 2001
+++ gnucash/src/scm/utilities.scm Tue May 15 11:27:55 2001
@@ -110,20 +110,20 @@
(filter values lst))
(define (flatten tree)
- ;; This is ugly, but efficient -- leaves nothing pending on the
- ;; stack, and doesn't build intermediate results that it throws
- ;; away.
- (define result '())
- (define (flatten-sub-tree tree)
- (cond
- ((null? tree) #t)
- ((list? tree)
- (flatten-sub-tree (car tree))
- (flatten-sub-tree (cdr tree)))
- (else
- (set! result (cons tree result)))))
- (flatten-sub-tree tree)
- (reverse! result))
+ ;; This leaves nothing pending on the stack, and doesn't build
+ ;; intermediate results that it throws away.
+ (define (flatten-element elt)
+ (if (list? elt)
+ (flatten-a-list elt)
+ (set! result (cons elt result))))
+ (define (flatten-a-list lst)
+ (for-each flatten-element lst))
+
+ (if (list? tree)
+ (begin
+ (flatten-a-list tree)
+ (reverse! result))
+ tree))
(define (striptrailingwhitespace line)
(substring line 0 (let loop ((pos (- (string-length line) 1)))
Index: gnucash/src/scm/gnumeric/gnumeric-utilities.scm
diff -u gnucash/src/scm/gnumeric/gnumeric-utilities.scm:1.2 gnucash/src/scm/gnumeric/gnumeric-utilities.scm:1.3
--- gnucash/src/scm/gnumeric/gnumeric-utilities.scm:1.2 Sun Mar 19 04:06:50 2000
+++ gnucash/src/scm/gnumeric/gnumeric-utilities.scm Tue May 15 11:33:56 2001
@@ -1,6 +1,8 @@
-;;;; $Id: gnumeric-utilities.scm,v 1.2 2000/03/19 10:06:50 peticolas Exp $
+;;;; $Id: gnumeric-utilities.scm,v 1.3 2001/05/15 16:33:56 rlb Exp $
;;;; gnumeric-utilities.scm - Gnumeric spreadsheet generation functions
+(use-modules (srfi srfi-19))
+
(gnc:support "gnumeric/gnumeric-utilities.scm")
(gnc:depend "xml-generator.scm")
@@ -39,7 +41,6 @@
;;; to suggest a better function.
;;; The point of this is that Gnumeric uses this as the "native" data
;;; representation.
-(gnc:depend "srfi/srfi-19.scm")
(define (exceldate y m d)
(let
Index: gnucash/src/scm/report/price-scatter.scm
diff -u gnucash/src/scm/report/price-scatter.scm:1.10 gnucash/src/scm/report/price-scatter.scm:1.11
--- gnucash/src/scm/report/price-scatter.scm:1.10 Mon May 14 04:11:15 2001
+++ gnucash/src/scm/report/price-scatter.scm Tue May 15 23:18:32 2001
@@ -126,14 +126,14 @@
(let* ((to-date-tp (gnc:timepair-end-day-time
(gnc:date-option-absolute-time
(get-option gnc:pagename-general
- optname-to-date))))
+ optname-to-date))))
(from-date-tp (gnc:timepair-start-day-time
(gnc:date-option-absolute-time
(get-option gnc:pagename-general
- optname-from-date))))
+ optname-from-date))))
(interval (get-option gnc:pagename-general optname-stepsize))
(report-title (get-option gnc:pagename-general
- gnc:optname-reportname))
+ gnc:optname-reportname))
(height (get-option gnc:pagename-display optname-plot-height))
(width (get-option gnc:pagename-display optname-plot-width))
@@ -144,11 +144,11 @@
gnc:pagename-display optname-markercolor)))
(report-currency (get-option pagename-price
- optname-report-currency))
+ optname-report-currency))
(price-commodity (get-option pagename-price
- optname-price-commodity))
+ optname-price-commodity))
(price-source (get-option pagename-price
- optname-price-source))
+ optname-price-source))
(dates-list (gnc:make-date-list
(gnc:timepair-end-day-time from-date-tp)
@@ -161,7 +161,15 @@
(filter gnc:account-has-shares? (gnc:group-get-subaccounts
(gnc:get-current-group))))
(data '()))
-
+
+ ;; Short helper for all the warnings below
+ (define (make-warning title text)
+ (gnc:html-document-add-object!
+ document
+ (gnc:make-html-text
+ (gnc:html-markup-h2 title)
+ (gnc:html-markup-p text))))
+
(gnc:html-scatter-set-title!
chart report-title)
(gnc:html-scatter-set-subtitle!
@@ -258,22 +266,41 @@
(gnc:html-scatter-set-data!
chart data)
-
+
+ ;; Make tons of tests so that Guppi won't barf
(if (not (null? data))
- (gnc:html-document-add-object! document chart)
- (gnc:html-document-add-object!
- document
- (gnc:html-make-empty-data-warning))))
+ (if (> (length data) 1)
+ (if (apply equal? (map second data))
+ (make-warning
+ (_ "All Prices equal")
+ (_ "All the prices found are equal. \
+This would result in a plot with one straight line. \
+Unfortunately, the plotting tool can't handle that."))
+ (if (apply equal? (map first data))
+ (make-warning
+ (_ "All Prices at the same date")
+ (_ "All the prices found are from the same date. \
+This would result in a plot with one straight line. \
+Unfortunately, the plotting tool can't handle that."))
+
+ (gnc:html-document-add-object! document chart)))
+
+ (make-warning
+ (_ "Only one price")
+ (_ "There was only one single price found for the \
+selected commodities in the selected time period. This doesn't give \
+a useful plot.")))
+ (make-warning
+ (_ "No data")
+ (_ "There is no price information available for the \
+selected commodities in the selected time period."))))
;; warning if report-currency == price-commodity
- (gnc:html-document-add-object!
- document
- (gnc:make-html-text
- (gnc:html-markup-h2 (_ "Identical commodities"))
- (gnc:html-markup-p
- (_ "Your selected commodity and the currency of the report \
+ (make-warning
+ (_ "Identical commodities")
+ (_ "Your selected commodity and the currency of the report \
are identical. It doesn't make sense to show prices for identical \
-commodities.")))))
+commodities.")))
document))
Index: gnucash/src/scm/report/register.scm
diff -u gnucash/src/scm/report/register.scm:1.19 gnucash/src/scm/report/register.scm:1.20
--- gnucash/src/scm/report/register.scm:1.19 Mon May 14 05:29:23 2001
+++ gnucash/src/scm/report/register.scm Tue May 15 11:36:29 2001
@@ -1,16 +1,16 @@
;; -*-scheme-*-
;; register.scm
+(use-modules (ice-9 syncase))
+
(require 'record)
(gnc:support "report/register.scm")
(gnc:depend "report-html.scm")
(gnc:depend "date-utilities.scm")
-
-(let ()
- (define-syntax addto!
- (syntax-rules ()
- ((_ alist element) (set! alist (cons element alist)))))
+(let-syntax ((addto!
+ (syntax-rules ()
+ ((_ alist element) (set! alist (cons element alist))))))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
@@ -612,7 +612,9 @@
'name (N_ "Invoice")
'options-generator options-generator
'renderer reg-renderer
- 'in-menu? #f))
+ 'in-menu? #f)
+
+ #t)
(define (gnc:apply-register-report func invoice? query journal? double?
Index: gnucash/src/scm/report/transaction-report.scm
diff -u gnucash/src/scm/report/transaction-report.scm:1.64 gnucash/src/scm/report/transaction-report.scm:1.66
--- gnucash/src/scm/report/transaction-report.scm:1.64 Sun May 6 16:53:37 2001
+++ gnucash/src/scm/report/transaction-report.scm Tue May 15 21:13:27 2001
@@ -31,127 +31,128 @@
(gnc:depend "date-utilities.scm")
;; Define the strings here to avoid typos and make changes easier.
-(let ((pagename-sorting (N_ "Sorting"))
- (optname-prime-sortkey (N_ "Primary Key"))
- (optname-prime-subtotal (N_ "Primary Subtotal"))
- (optname-prime-date-subtotal (N_ "Primary Subtotal for Date Key"))
- (optname-sec-sortkey (N_ "Secondary Key"))
- (optname-sec-subtotal (N_ "Secondary Subtotal"))
- (optname-sec-date-subtotal (N_ "Secondary Subtotal for Date Key"))
- (def:grand-total-style "grand-total")
- (def:normal-row-style "normal-row")
- (def:alternate-row-style "alternate-row")
- (def:primary-subtotal-style "primary-subheading")
- (def:secondary-subtotal-style "secondary-subheading")
- ;; The option-values of the sorting key multichoice option, for
- ;; which a subtotal should be enabled.
- (subtotal-enabled '(account-name account-code
- corresponding-acc-name
- corresponding-acc-code)))
-
- (define-syntax addto!
- (syntax-rules ()
- ((_ alist element) (set! alist (cons element alist)))))
-
- (define (split-account-full-name-same-p a b)
- (= (gnc:split-compare-account-full-names a b) 0))
-
- (define (split-account-code-same-p a b)
- (= (gnc:split-compare-account-codes a b) 0))
-
- (define (split-same-corr-account-full-name-p a b)
- (= (gnc:split-compare-other-account-full-names a b) 0))
-
- (define (split-same-corr-account-code-p a b)
- (= (gnc:split-compare-other-account-codes a b) 0))
-
- (define (timepair-same-year tp-a tp-b)
- (= (tm:year (gnc:timepair->date tp-a))
- (tm:year (gnc:timepair->date tp-b))))
-
- (define (timepair-same-month tp-a tp-b)
- (and (timepair-same-year tp-a tp-b)
- (= (tm:mon (gnc:timepair->date tp-a))
- (tm:mon (gnc:timepair->date tp-b)))))
-
- (define (split-same-month-p a b)
- (let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
- (tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
- (timepair-same-month tp-a tp-b)))
-
- (define (split-same-year-p a b)
- (let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
- (tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
- (timepair-same-year tp-a tp-b)))
-
- (define (set-last-row-style! table tag . rest)
- (let ((arg-list
- (cons table
- (cons (- (gnc:html-table-num-rows table) 1)
- (cons tag rest)))))
- (apply gnc:html-table-set-row-style! arg-list)))
-
- (define (add-subheading-row data table width subheading-style)
- (let ((heading-cell (gnc:make-html-table-cell data)))
- (gnc:html-table-cell-set-colspan! heading-cell width)
- (gnc:html-table-append-row/markup!
- table
- subheading-style
- (list heading-cell))))
-
- (define (render-account-full-name-subheading
- split table width subheading-style)
- (let ((account (gnc:split-get-account split)))
- (add-subheading-row (gnc:make-html-text (gnc:html-markup-anchor
- (gnc:account-anchor-text account)
- (gnc:account-get-full-name
- account)))
- table width subheading-style)))
-
- (define (render-account-code-subheading split table
- width subheading-style)
- (add-subheading-row (gnc:account-get-code
- (gnc:split-get-account split))
- table width subheading-style))
-
- (define (render-corresponding-account-name-subheading
- split table width subheading-style)
- (add-subheading-row (gnc:split-get-corr-account-full-name split)
- table width subheading-style))
-
-
- (define (render-corresponding-account-code-subheading
- split table width subheading-style)
- (add-subheading-row (gnc:split-get-corr-account-code split)
- table width subheading-style))
-
- (define (render-month-subheading split table width subheading-style)
- (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
+(let-syntax ((addto!
+ (syntax-rules ()
+ ((_ alist element) (set! alist (cons element alist))))))
+
+ (let ((pagename-sorting (N_ "Sorting"))
+ (optname-prime-sortkey (N_ "Primary Key"))
+ (optname-prime-subtotal (N_ "Primary Subtotal"))
+ (optname-prime-date-subtotal (N_ "Primary Subtotal for Date Key"))
+ (optname-sec-sortkey (N_ "Secondary Key"))
+ (optname-sec-subtotal (N_ "Secondary Subtotal"))
+ (optname-sec-date-subtotal (N_ "Secondary Subtotal for Date Key"))
+ (def:grand-total-style "grand-total")
+ (def:normal-row-style "normal-row")
+ (def:alternate-row-style "alternate-row")
+ (def:primary-subtotal-style "primary-subheading")
+ (def:secondary-subtotal-style "secondary-subheading")
+ ;; The option-values of the sorting key multichoice option, for
+ ;; which a subtotal should be enabled.
+ (subtotal-enabled '(account-name account-code
+ corresponding-acc-name
+ corresponding-acc-code)))
+
+ (define (split-account-full-name-same-p a b)
+ (= (gnc:split-compare-account-full-names a b) 0))
+
+ (define (split-account-code-same-p a b)
+ (= (gnc:split-compare-account-codes a b) 0))
+
+ (define (split-same-corr-account-full-name-p a b)
+ (= (gnc:split-compare-other-account-full-names a b) 0))
+
+ (define (split-same-corr-account-code-p a b)
+ (= (gnc:split-compare-other-account-codes a b) 0))
+
+ (define (timepair-same-year tp-a tp-b)
+ (= (tm:year (gnc:timepair->date tp-a))
+ (tm:year (gnc:timepair->date tp-b))))
+
+ (define (timepair-same-month tp-a tp-b)
+ (and (timepair-same-year tp-a tp-b)
+ (= (tm:mon (gnc:timepair->date tp-a))
+ (tm:mon (gnc:timepair->date tp-b)))))
+
+ (define (split-same-month-p a b)
+ (let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
+ (tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
+ (timepair-same-month tp-a tp-b)))
+
+ (define (split-same-year-p a b)
+ (let ((tp-a (gnc:transaction-get-date-posted (gnc:split-get-parent a)))
+ (tp-b (gnc:transaction-get-date-posted (gnc:split-get-parent b))))
+ (timepair-same-year tp-a tp-b)))
+
+ (define (set-last-row-style! table tag . rest)
+ (let ((arg-list
+ (cons table
+ (cons (- (gnc:html-table-num-rows table) 1)
+ (cons tag rest)))))
+ (apply gnc:html-table-set-row-style! arg-list)))
+
+ (define (add-subheading-row data table width subheading-style)
+ (let ((heading-cell (gnc:make-html-table-cell data)))
+ (gnc:html-table-cell-set-colspan! heading-cell width)
+ (gnc:html-table-append-row/markup!
+ table
+ subheading-style
+ (list heading-cell))))
+
+ (define (render-account-full-name-subheading
+ split table width subheading-style)
+ (let ((account (gnc:split-get-account split)))
+ (add-subheading-row (gnc:make-html-text (gnc:html-markup-anchor
+ (gnc:account-anchor-text account)
+ (gnc:account-get-full-name
+ account)))
+ table width subheading-style)))
+
+ (define (render-account-code-subheading split table
+ width subheading-style)
+ (add-subheading-row (gnc:account-get-code
+ (gnc:split-get-account split))
+ table width subheading-style))
+
+ (define (render-corresponding-account-name-subheading
+ split table width subheading-style)
+ (add-subheading-row (gnc:split-get-corr-account-full-name split)
+ table width subheading-style))
+
+
+ (define (render-corresponding-account-code-subheading
+ split table width subheading-style)
+ (add-subheading-row (gnc:split-get-corr-account-code split)
+ table width subheading-style))
+
+ (define (render-month-subheading split table width subheading-style)
+ (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
(gnc:split-get-parent split)))))
- (add-subheading-row (strftime "%B %Y" tm)
- table width subheading-style)))
-
- (define (render-year-subheading split table width subheading-style)
- (add-subheading-row (strftime "%Y" (gnc:timepair->date
- (gnc:transaction-get-date-posted
- (gnc:split-get-parent split))))
- table width subheading-style))
-
+ (add-subheading-row (strftime "%B %Y" tm)
+ table width subheading-style)))
+
+ (define (render-year-subheading split table width subheading-style)
+ (add-subheading-row (strftime "%Y" (gnc:timepair->date
+ (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split))))
+ table width subheading-style))
+
- (define (add-subtotal-row table width subtotal-string subtotal-collector
+ (define (add-subtotal-row table width subtotal-string subtotal-collector
subtotal-style)
(let ((currency-totals (subtotal-collector
'format gnc:make-gnc-monetary #f))
- (blanks (make-list (- width 1) #f)))
+ (blanks (gnc:make-html-table-cell/size 1 (- width 1) #f)))
(gnc:html-table-append-row/markup!
table
- subtotal-style
- (append (list subtotal-string) (make-list (- width 2) #f)
- (list (gnc:make-html-table-cell/markup
+ subtotal-style
+ (list (gnc:make-html-table-cell/size 1 (- width 1)
+ subtotal-string)
+ (gnc:make-html-table-cell/markup
"total-number-cell"
- (car currency-totals)))))
- (for-each (lambda (currency)
+ (car currency-totals))))
+ (for-each (lambda (currency)
(gnc:html-table-append-row/markup!
table
subtotal-style
@@ -160,435 +161,435 @@
"total-number-cell" currency)))))
(cdr currency-totals))))
- (define (total-string str) (string-append (_ "Total For ") str))
+ (define (total-string str) (string-append (_ "Total For ") str))
- (define (render-account-full-name-subtotal
- table width split total-collector subtotal-style)
- (let ((name-string (total-string (gnc:account-get-full-name
- (gnc:split-get-account split)))))
+ (define (render-account-full-name-subtotal
+ table width split total-collector subtotal-style)
+ (let ((name-string (total-string (gnc:account-get-full-name
+ (gnc:split-get-account split)))))
+
+ (add-subtotal-row table width
+ name-string total-collector subtotal-style)))
- (add-subtotal-row table width
- name-string total-collector subtotal-style)))
-
- (define (render-account-code-subtotal
- table width split total-collector subtotal-style)
- (let ((code-string (total-string (gnc:account-get-code
- (gnc:split-get-account split)))))
- (add-subtotal-row table width
- code-string total-collector subtotal-style)))
-
- (define (render-corresponding-account-name-subtotal
- table width split total-collector subtotal-style)
- (add-subtotal-row table width (total-string
- (gnc:split-get-corr-account-full-name split))
- total-collector subtotal-style))
-
- (define (render-corresponding-account-code-subtotal
- table width split total-collector subtotal-style)
- (add-subtotal-row table width (total-string
- (gnc:split-get-corr-account-code split))
- total-collector subtotal-style))
-
- (define (render-month-subtotal
- table width split total-collector subtotal-style)
- (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
- (gnc:split-get-parent split)))))
- (add-subtotal-row table width
- (total-string (strftime "%B %Y" tm))
- total-collector subtotal-style)))
-
-
- (define (render-year-subtotal
- table width split total-collector subtotal-style)
- (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
- (gnc:split-get-parent split)))))
- (add-subtotal-row table width
- (total-string (strftime "%Y" tm))
- total-collector subtotal-style)))
-
-
- (define (render-grand-total
- table width total-collector)
- (add-subtotal-row table width
- (_ "Grand Total")
- total-collector def:grand-total-style))
-
- (define account-types-to-reverse-assoc-list
- (list (cons 'none '())
- (cons 'income-expense '(income expense))
- (cons 'credit-accounts '(liability equity credit income))))
-
- (define (used-date columns-used)
- (vector-ref columns-used 0))
- (define (used-num columns-used)
- (vector-ref columns-used 1))
- (define (used-description columns-used)
- (vector-ref columns-used 2))
- (define (used-account columns-used)
- (vector-ref columns-used 3))
- (define (used-other-account columns-used)
- (vector-ref columns-used 4))
- (define (used-shares columns-used)
- (vector-ref columns-used 5))
- (define (used-price columns-used)
- (vector-ref columns-used 6))
- (define (used-amount-single columns-used)
- (vector-ref columns-used 7))
- (define (used-amount-double-positive columns-used)
- (vector-ref columns-used 8))
- (define (used-amount-double-negative columns-used)
- (vector-ref columns-used 9))
- (define (used-running-balance columns-used)
- (vector-ref columns-used 10))
- (define (used-account-full-name columns-used)
- (vector-ref columns-used 11))
-
- (define (used-memo columns-used)
- (vector-ref columns-used 12))
-
- (define columns-used-size 13)
-
- (define (num-columns-required columns-used)
- (do ((i 0 (+ i 1))
- (col-req 0 col-req))
- ((>= i columns-used-size) col-req)
- (if (vector-ref columns-used i) (set! col-req (+ col-req 1)))))
-
- (define (build-column-used options)
- (define (opt-val section name)
- (gnc:option-value
- (gnc:lookup-option options section name)))
- (let ((column-list (make-vector columns-used-size #f)))
- (if (opt-val (N_ "Display") (N_ "Date"))
- (vector-set! column-list 0 #t))
- (if (opt-val (N_ "Display") (N_ "Num"))
- (vector-set! column-list 1 #t))
- (if (opt-val (N_ "Display") (N_ "Description"))
- (vector-set! column-list 2 #t))
- (if (opt-val (N_ "Display") (N_ "Account"))
- (vector-set! column-list 3 #t))
- (if (opt-val (N_ "Display") (N_ "Other Account"))
- (vector-set! column-list 4 #t))
- (if (opt-val (N_ "Display") (N_ "Shares"))
- (vector-set! column-list 5 #t))
- (if (opt-val (N_ "Display") (N_ "Price"))
- (vector-set! column-list 6 #t))
- (let ((amount-setting (opt-val (N_ "Display") (N_ "Amount"))))
- (if (eq? amount-setting 'single)
- (vector-set! column-list 7 #t))
- (if (eq? amount-setting 'double)
- (begin (vector-set! column-list 8 #t)
- (vector-set! column-list 9 #t))))
- (if (opt-val (N_ "Display") (N_ "Running Balance"))
- (vector-set! column-list 10 #t))
- (if (opt-val (N_ "Display") (N_ "Use Full Account Name?"))
- (vector-set! column-list 11 #t))
- (if (opt-val (N_ "Display") (N_ "Memo"))
- (vector-set! column-list 12 #t))
- column-list))
-
- (define (make-heading-list column-vector)
- (let ((heading-list '()))
- (if (used-date column-vector)
- (addto! heading-list (_ "Date")))
- (if (used-num column-vector)
- (addto! heading-list (_ "Num")))
- (if (used-description column-vector)
- (addto! heading-list (_ "Description")))
- (if (used-memo column-vector)
- (addto! heading-list (_ "Memo")))
- (if (used-account column-vector)
- (addto! heading-list (_ "Account")))
- (if (used-other-account column-vector)
- (addto! heading-list (_ "Transfer from/to")))
- (if (used-shares column-vector)
- (addto! heading-list (_ "Shares")))
- (if (used-price column-vector)
- (addto! heading-list (_ "Price")))
- (if (used-amount-single column-vector)
- (addto! heading-list (_ "Amount")))
- ;; FIXME: Proper labels: what?
- (if (used-amount-double-positive column-vector)
- (addto! heading-list (_ "Debit")))
- (if (used-amount-double-negative column-vector)
- (addto! heading-list (_ "Credit")))
- (if (used-running-balance column-vector)
- (addto! heading-list (_ "Balance")))
- (reverse heading-list)))
-
- (define (add-split-row table split column-vector
- row-style account-types-to-reverse transaction-row?)
- (let* ((row-contents '())
- (parent (gnc:split-get-parent split))
- (account (gnc:split-get-account split))
- (account-type (gw:enum-<gnc:AccountType>-val->sym
- (gnc:account-get-type account) #f))
- (currency (gnc:account-get-commodity account))
- (damount (gnc:split-get-share-amount split))
- (split-value (gnc:make-gnc-monetary
- currency
- (if (member account-type account-types-to-reverse)
- (gnc:numeric-neg damount)
- damount))))
-
- (if (used-date column-vector)
- (addto! row-contents
- (if transaction-row?
- (gnc:timepair-to-datestring
- (gnc:transaction-get-date-posted parent))
- " ")))
- (if (used-num column-vector)
- (addto! row-contents
- (if transaction-row?
- (gnc:transaction-get-num parent)
- " ")))
- (if (used-description column-vector)
- (addto! row-contents
- (if transaction-row?
- (gnc:transaction-get-description parent)
- " ")))
-
- (if (used-memo column-vector)
- (addto! row-contents
- (gnc:split-get-memo split)))
+ (define (render-account-code-subtotal
+ table width split total-collector subtotal-style)
+ (let ((code-string (total-string (gnc:account-get-code
+ (gnc:split-get-account split)))))
+ (add-subtotal-row table width
+ code-string total-collector subtotal-style)))
+
+ (define (render-corresponding-account-name-subtotal
+ table width split total-collector subtotal-style)
+ (add-subtotal-row table width (total-string
+ (gnc:split-get-corr-account-full-name split))
+ total-collector subtotal-style))
+
+ (define (render-corresponding-account-code-subtotal
+ table width split total-collector subtotal-style)
+ (add-subtotal-row table width (total-string
+ (gnc:split-get-corr-account-code split))
+ total-collector subtotal-style))
+
+ (define (render-month-subtotal
+ table width split total-collector subtotal-style)
+ (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split)))))
+ (add-subtotal-row table width
+ (total-string (strftime "%B %Y" tm))
+ total-collector subtotal-style)))
+
+
+ (define (render-year-subtotal
+ table width split total-collector subtotal-style)
+ (let ((tm (gnc:timepair->date (gnc:transaction-get-date-posted
+ (gnc:split-get-parent split)))))
+ (add-subtotal-row table width
+ (total-string (strftime "%Y" tm))
+ total-collector subtotal-style)))
+
+
+ (define (render-grand-total
+ table width total-collector)
+ (add-subtotal-row table width
+ (_ "Grand Total")
+ total-collector def:grand-total-style))
+
+ (define account-types-to-reverse-assoc-list
+ (list (cons 'none '())
+ (cons 'income-expense '(income expense))
+ (cons 'credit-accounts '(liability equity credit income))))
+
+ (define (used-date columns-used)
+ (vector-ref columns-used 0))
+ (define (used-num columns-used)
+ (vector-ref columns-used 1))
+ (define (used-description columns-used)
+ (vector-ref columns-used 2))
+ (define (used-account columns-used)
+ (vector-ref columns-used 3))
+ (define (used-other-account columns-used)
+ (vector-ref columns-used 4))
+ (define (used-shares columns-used)
+ (vector-ref columns-used 5))
+ (define (used-price columns-used)
+ (vector-ref columns-used 6))
+ (define (used-amount-single columns-used)
+ (vector-ref columns-used 7))
+ (define (used-amount-double-positive columns-used)
+ (vector-ref columns-used 8))
+ (define (used-amount-double-negative columns-used)
+ (vector-ref columns-used 9))
+ (define (used-running-balance columns-used)
+ (vector-ref columns-used 10))
+ (define (used-account-full-name columns-used)
+ (vector-ref columns-used 11))
+
+ (define (used-memo columns-used)
+ (vector-ref columns-used 12))
+
+ (define columns-used-size 13)
+
+ (define (num-columns-required columns-used)
+ (do ((i 0 (+ i 1))
+ (col-req 0 col-req))
+ ((>= i columns-used-size) col-req)
+ (if (vector-ref columns-used i) (set! col-req (+ col-req 1)))))
+
+ (define (build-column-used options)
+ (define (opt-val section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name)))
+ (let ((column-list (make-vector columns-used-size #f)))
+ (if (opt-val (N_ "Display") (N_ "Date"))
+ (vector-set! column-list 0 #t))
+ (if (opt-val (N_ "Display") (N_ "Num"))
+ (vector-set! column-list 1 #t))
+ (if (opt-val (N_ "Display") (N_ "Description"))
+ (vector-set! column-list 2 #t))
+ (if (opt-val (N_ "Display") (N_ "Account"))
+ (vector-set! column-list 3 #t))
+ (if (opt-val (N_ "Display") (N_ "Other Account"))
+ (vector-set! column-list 4 #t))
+ (if (opt-val (N_ "Display") (N_ "Shares"))
+ (vector-set! column-list 5 #t))
+ (if (opt-val (N_ "Display") (N_ "Price"))
+ (vector-set! column-list 6 #t))
+ (let ((amount-setting (opt-val (N_ "Display") (N_ "Amount"))))
+ (if (eq? amount-setting 'single)
+ (vector-set! column-list 7 #t))
+ (if (eq? amount-setting 'double)
+ (begin (vector-set! column-list 8 #t)
+ (vector-set! column-list 9 #t))))
+ (if (opt-val (N_ "Display") (N_ "Running Balance"))
+ (vector-set! column-list 10 #t))
+ (if (opt-val (N_ "Display") (N_ "Use Full Account Name?"))
+ (vector-set! column-list 11 #t))
+ (if (opt-val (N_ "Display") (N_ "Memo"))
+ (vector-set! column-list 12 #t))
+ column-list))
+
+ (define (make-heading-list column-vector)
+ (let ((heading-list '()))
+ (if (used-date column-vector)
+ (addto! heading-list (_ "Date")))
+ (if (used-num column-vector)
+ (addto! heading-list (_ "Num")))
+ (if (used-description column-vector)
+ (addto! heading-list (_ "Description")))
+ (if (used-memo column-vector)
+ (addto! heading-list (_ "Memo")))
+ (if (used-account column-vector)
+ (addto! heading-list (_ "Account")))
+ (if (used-other-account column-vector)
+ (addto! heading-list (_ "Transfer from/to")))
+ (if (used-shares column-vector)
+ (addto! heading-list (_ "Shares")))
+ (if (used-price column-vector)
+ (addto! heading-list (_ "Price")))
+ (if (used-amount-single column-vector)
+ (addto! heading-list (_ "Amount")))
+ ;; FIXME: Proper labels: what?
+ (if (used-amount-double-positive column-vector)
+ (addto! heading-list (_ "Debit")))
+ (if (used-amount-double-negative column-vector)
+ (addto! heading-list (_ "Credit")))
+ (if (used-running-balance column-vector)
+ (addto! heading-list (_ "Balance")))
+ (reverse heading-list)))
+
+ (define (add-split-row table split column-vector
+ row-style account-types-to-reverse transaction-row?)
+ (let* ((row-contents '())
+ (parent (gnc:split-get-parent split))
+ (account (gnc:split-get-account split))
+ (account-type (gw:enum-<gnc:AccountType>-val->sym
+ (gnc:account-get-type account) #f))
+ (currency (gnc:account-get-commodity account))
+ (damount (gnc:split-get-share-amount split))
+ (split-value (gnc:make-gnc-monetary
+ currency
+ (if (member account-type account-types-to-reverse)
+ (gnc:numeric-neg damount)
+ damount))))
+
+ (if (used-date column-vector)
+ (addto! row-contents
+ (if transaction-row?
+ (gnc:timepair-to-datestring
+ (gnc:transaction-get-date-posted parent))
+ " ")))
+ (if (used-num column-vector)
+ (addto! row-contents
+ (if transaction-row?
+ (gnc:transaction-get-num parent)
+ " ")))
+ (if (used-description column-vector)
+ (addto! row-contents
+ (if transaction-row?
+ (gnc:transaction-get-description parent)
+ " ")))
+
+ (if (used-memo column-vector)
+ (addto! row-contents
+ (gnc:split-get-memo split)))
+
+ (if (used-account column-vector)
+ (if (used-account-full-name column-vector)
+ (addto! row-contents (gnc:account-get-full-name account))
+ (addto! row-contents (gnc:account-get-name account))))
+
+ (if (used-other-account column-vector)
+ (if (used-account-full-name column-vector)
+
+ (addto! row-contents (gnc:split-get-corr-account-full-name
+ split))
+ (addto! row-contents (gnc:split-get-corr-account-name split))))
+
+ (if (used-shares column-vector)
+ (addto! row-contents (gnc:split-get-share-amount split)))
+ (if (used-price column-vector)
+ (addto!
+ row-contents
+ (gnc:make-gnc-monetary currency (gnc:split-get-share-price split))))
+ (if (used-amount-single column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup "number-cell"
+ split-value)))
+ (if (used-amount-double-positive column-vector)
+ (if (gnc:numeric-positive-p (gnc:gnc-monetary-amount split-value))
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup "number-cell"
+ split-value))
+ (addto! row-contents " ")))
+ (if (used-amount-double-negative column-vector)
+ (if (gnc:numeric-negative-p (gnc:gnc-monetary-amount split-value))
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "number-cell" (gnc:monetary-neg split-value)))
+ (addto! row-contents " ")))
+ (if (used-running-balance column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:make-gnc-monetary currency
+ (gnc:split-get-balance split)))))
+ (gnc:html-table-append-row/markup! table row-style (reverse row-contents))
+ split-value))
+
+ (define (trep-options-generator)
+ (define gnc:*transaction-report-options* (gnc:new-options))
+ (define (gnc:register-trep-option new-option)
+ (gnc:register-option gnc:*transaction-report-options* new-option))
- (if (used-account column-vector)
- (if (used-account-full-name column-vector)
- (addto! row-contents (gnc:account-get-full-name account))
- (addto! row-contents (gnc:account-get-name account))))
+ ;; General options
- (if (used-other-account column-vector)
- (if (used-account-full-name column-vector)
-
- (addto! row-contents (gnc:split-get-corr-account-full-name
- split))
- (addto! row-contents (gnc:split-get-corr-account-name split))))
+ (gnc:options-add-date-interval!
+ gnc:*transaction-report-options*
+ gnc:pagename-general (N_ "From") (N_ "To") "a")
- (if (used-shares column-vector)
- (addto! row-contents (gnc:split-get-share-amount split)))
- (if (used-price column-vector)
- (addto!
- row-contents
- (gnc:make-gnc-monetary currency (gnc:split-get-share-price split))))
- (if (used-amount-single column-vector)
- (addto! row-contents
- (gnc:make-html-table-cell/markup "number-cell"
- split-value)))
- (if (used-amount-double-positive column-vector)
- (if (gnc:numeric-positive-p (gnc:gnc-monetary-amount split-value))
- (addto! row-contents
- (gnc:make-html-table-cell/markup "number-cell"
- split-value))
- (addto! row-contents " ")))
- (if (used-amount-double-negative column-vector)
- (if (gnc:numeric-negative-p (gnc:gnc-monetary-amount split-value))
- (addto! row-contents
- (gnc:make-html-table-cell/markup
- "number-cell" (gnc:monetary-neg split-value)))
- (addto! row-contents " ")))
- (if (used-running-balance column-vector)
- (addto! row-contents
- (gnc:make-html-table-cell/markup
- "number-cell"
- (gnc:make-gnc-monetary currency
- (gnc:split-get-balance split)))))
- (gnc:html-table-append-row/markup! table row-style (reverse row-contents))
- split-value))
-
- (define (trep-options-generator)
- (define gnc:*transaction-report-options* (gnc:new-options))
- (define (gnc:register-trep-option new-option)
- (gnc:register-option gnc:*transaction-report-options* new-option))
-
- ;; General options
-
- (gnc:options-add-date-interval!
- gnc:*transaction-report-options*
- gnc:pagename-general (N_ "From") (N_ "To") "a")
-
-
- (gnc:register-trep-option
- (gnc:make-multichoice-option
- gnc:pagename-general (N_ "Style")
- "d" (N_ "Report style")
- 'single
- (list (vector 'multi-line
- (N_ "Multi-Line")
- (N_ "Display N lines"))
- (vector 'single
- (N_ "Single")
- (N_ "Display 1 line")))))
-
- ;; Accounts options
-
- ;; account to do report on
- (gnc:register-trep-option
- (gnc:make-account-list-option
- gnc:pagename-accounts (N_ "Accounts")
- "c" (N_ "Do transaction report on these accounts")
- (lambda ()
- ;; FIXME : gnc:get-current-accounts disappeared.
- (let ((current-accounts '())
- (num-accounts (gnc:group-get-num-accounts
- (gnc:get-current-group)))
- (first-account (gnc:group-get-account
- (gnc:get-current-group) 0)))
- (cond ((not (null? current-accounts)) (list (car current-accounts)))
- ((> num-accounts 0) (list first-account))
- (else ()))))
- #f #t))
-
- ;; Sorting options
-
- (let ((options gnc:*transaction-report-options*)
- (key-choice-list
- (list (vector 'none
- (N_ "None")
- (N_ "Do not sort"))
- (vector 'account-name
- (N_ "Account Name")
- (N_ "Sort & subtotal by account name"))
- (vector 'account-code
- (N_ "Account Code")
- (N_ "Sort & subtotal by account code"))
- (vector 'date
- (N_ "Date")
- (N_ "Sort by date"))
- (vector 'exact-time
- (N_ "Exact Time")
- (N_ "Sort by exact time"))
-
- (vector 'corresponding-acc-name
- (N_ "Other Account Name")
- (N_ "Sort by account transferred from/to's name"))
-
- (vector 'corresponding-acc-code
- (N_ "Other Account Code")
- (N_ "Sort by account transferred from/to's code"))
-
- (vector 'amount
- (N_ "Amount")
- (N_ "Sort by amount"))
-
- (vector 'description
- (N_ "Description")
- (N_ "Sort by description"))
-
- (vector 'number
- (N_ "Number")
- (N_ "Sort by check/transaction number"))
-
- (vector 'memo
- (N_ "Memo")
- (N_ "Sort by memo"))))
- ;;description))
- (ascending-choice-list
- (list
- (vector 'ascend
- (N_ "Ascending")
- (N_ "smallest to largest, earliest to latest"))
- (vector 'descend
- (N_ "Descending")
- (N_ "largest to smallest, latest to earliest"))))
- (subtotal-choice-list
- (list
- (vector 'none (N_ "None") (N_ "None"))
- ;;(vector 'weekly (N_ "Weekly") (N_ "Weekly"))
- (vector 'monthly (N_ "Monthly") (N_ "Monthly"))
- (vector 'yearly (N_ "Yearly") (N_ "Yearly")))))
-
- ;; primary sorting criterion
- (gnc:register-trep-option
- (gnc:make-multichoice-callback-option
- pagename-sorting optname-prime-sortkey
- "a" (N_ "Sort by this criterion first")
- 'account-name
- key-choice-list #f
- (lambda (x)
- (gnc:option-db-set-option-selectable-by-name
- options pagename-sorting optname-prime-subtotal
- (and (member x subtotal-enabled) #t))
- (gnc:option-db-set-option-selectable-by-name
- options pagename-sorting optname-prime-date-subtotal
- (if (member x (list 'exact-time 'date)) #t #f)))))
-
- (gnc:register-trep-option
- (gnc:make-simple-boolean-option
- pagename-sorting optname-prime-subtotal
- "c"
- (N_ "Subtotal according to the primary key?")
- #t))
-
- (gnc:register-trep-option
+
+ (gnc:register-trep-option
(gnc:make-multichoice-option
- pagename-sorting optname-prime-date-subtotal
- "d" (N_ "Do a date subtotal")
- 'monthly
- subtotal-choice-list))
-
- (gnc:register-trep-option
- (gnc:make-multichoice-option
- pagename-sorting (N_ "Primary Sort Order")
- "e" (N_ "Order of primary sorting")
- 'ascend
- ascending-choice-list))
-
- ;; Secondary sorting criterion
- (gnc:register-trep-option
- (gnc:make-multichoice-callback-option
- pagename-sorting optname-sec-sortkey
- "f"
- (N_ "Sort by this criterion second")
- 'date
- key-choice-list #f
- (lambda (x)
- (gnc:option-db-set-option-selectable-by-name
- options pagename-sorting optname-sec-subtotal
- (and (member x subtotal-enabled) #t))
- (gnc:option-db-set-option-selectable-by-name
- options pagename-sorting optname-sec-date-subtotal
- (if (member x (list 'exact-time 'date )) #t #f)))))
-
- (gnc:register-trep-option
- (gnc:make-simple-boolean-option
- pagename-sorting optname-sec-subtotal
- "g"
- (N_ "Subtotal according to the secondary key?")
- #t))
-
- (gnc:register-trep-option
- (gnc:make-multichoice-option
- pagename-sorting optname-sec-date-subtotal
- "h" (N_ "Do a date subtotal")
- 'monthly
- subtotal-choice-list))
-
- (gnc:register-trep-option
- (gnc:make-multichoice-option
- pagename-sorting (N_ "Secondary Sort Order")
- "i" (N_ "Order of Secondary sorting")
- 'ascend
- ascending-choice-list)))
-
- ;; Display options
-
- (for-each
- (lambda (l)
+ gnc:pagename-general (N_ "Style")
+ "d" (N_ "Report style")
+ 'single
+ (list (vector 'multi-line
+ (N_ "Multi-Line")
+ (N_ "Display N lines"))
+ (vector 'single
+ (N_ "Single")
+ (N_ "Display 1 line")))))
+
+ ;; Accounts options
+
+ ;; account to do report on
(gnc:register-trep-option
- (gnc:make-simple-boolean-option
- gnc:pagename-display (car l) (cadr l) (caddr l) (cadddr l))))
- ;; One list per option here with: option-name, sort-tag,
- ;; help-string, default-value
- (list
- (list (N_ "Date") "a" (N_ "Display the date?") #t)
- (list (N_ "Num") "b" (N_ "Display the check number?") #t)
- (list (N_ "Description") "c" (N_ "Display the description?") #t)
- (list (N_ "Memo") "d" (N_ "Display the memo?") #t)
- (list (N_ "Account") "e" (N_ "Display the account?") #f)
- (list (N_ "Use Full Account Name?") "f"
- (N_ "Display the full account name") #t)
- (list (N_ "Other Account")"g"
- (N_ "Display the other account? \
+ (gnc:make-account-list-option
+ gnc:pagename-accounts (N_ "Accounts")
+ "c" (N_ "Do transaction report on these accounts")
+ (lambda ()
+ ;; FIXME : gnc:get-current-accounts disappeared.
+ (let ((current-accounts '())
+ (num-accounts (gnc:group-get-num-accounts
+ (gnc:get-current-group)))
+ (first-account (gnc:group-get-account
+ (gnc:get-current-group) 0)))
+ (cond ((not (null? current-accounts)) (list (car current-accounts)))
+ ((> num-accounts 0) (list first-account))
+ (else ()))))
+ #f #t))
+
+ ;; Sorting options
+
+ (let ((options gnc:*transaction-report-options*)
+ (key-choice-list
+ (list (vector 'none
+ (N_ "None")
+ (N_ "Do not sort"))
+ (vector 'account-name
+ (N_ "Account Name")
+ (N_ "Sort & subtotal by account name"))
+ (vector 'account-code
+ (N_ "Account Code")
+ (N_ "Sort & subtotal by account code"))
+ (vector 'date
+ (N_ "Date")
+ (N_ "Sort by date"))
+ (vector 'exact-time
+ (N_ "Exact Time")
+ (N_ "Sort by exact time"))
+
+ (vector 'corresponding-acc-name
+ (N_ "Other Account Name")
+ (N_ "Sort by account transferred from/to's name"))
+
+ (vector 'corresponding-acc-code
+ (N_ "Other Account Code")
+ (N_ "Sort by account transferred from/to's code"))
+
+ (vector 'amount
+ (N_ "Amount")
+ (N_ "Sort by amount"))
+
+ (vector 'description
+ (N_ "Description")
+ (N_ "Sort by description"))
+
+ (vector 'number
+ (N_ "Number")
+ (N_ "Sort by check/transaction number"))
+
+ (vector 'memo
+ (N_ "Memo")
+ (N_ "Sort by memo"))))
+ ;;description))
+ (ascending-choice-list
+ (list
+ (vector 'ascend
+ (N_ "Ascending")
+ (N_ "smallest to largest, earliest to latest"))
+ (vector 'descend
+ (N_ "Descending")
+ (N_ "largest to smallest, latest to earliest"))))
+ (subtotal-choice-list
+ (list
+ (vector 'none (N_ "None") (N_ "None"))
+ ;;(vector 'weekly (N_ "Weekly") (N_ "Weekly"))
+ (vector 'monthly (N_ "Monthly") (N_ "Monthly"))
+ (vector 'yearly (N_ "Yearly") (N_ "Yearly")))))
+
+ ;; primary sorting criterion
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ pagename-sorting optname-prime-sortkey
+ "a" (N_ "Sort by this criterion first")
+ 'account-name
+ key-choice-list #f
+ (lambda (x)
+ (gnc:option-db-set-option-selectable-by-name
+ options pagename-sorting optname-prime-subtotal
+ (and (member x subtotal-enabled) #t))
+ (gnc:option-db-set-option-selectable-by-name
+ options pagename-sorting optname-prime-date-subtotal
+ (if (member x (list 'exact-time 'date)) #t #f)))))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-prime-subtotal
+ "c"
+ (N_ "Subtotal according to the primary key?")
+ #t))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-sorting optname-prime-date-subtotal
+ "d" (N_ "Do a date subtotal")
+ 'monthly
+ subtotal-choice-list))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-sorting (N_ "Primary Sort Order")
+ "e" (N_ "Order of primary sorting")
+ 'ascend
+ ascending-choice-list))
+
+ ;; Secondary sorting criterion
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ pagename-sorting optname-sec-sortkey
+ "f"
+ (N_ "Sort by this criterion second")
+ 'date
+ key-choice-list #f
+ (lambda (x)
+ (gnc:option-db-set-option-selectable-by-name
+ options pagename-sorting optname-sec-subtotal
+ (and (member x subtotal-enabled) #t))
+ (gnc:option-db-set-option-selectable-by-name
+ options pagename-sorting optname-sec-date-subtotal
+ (if (member x (list 'exact-time 'date )) #t #f)))))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-sec-subtotal
+ "g"
+ (N_ "Subtotal according to the secondary key?")
+ #t))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-sorting optname-sec-date-subtotal
+ "h" (N_ "Do a date subtotal")
+ 'monthly
+ subtotal-choice-list))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-sorting (N_ "Secondary Sort Order")
+ "i" (N_ "Order of Secondary sorting")
+ 'ascend
+ ascending-choice-list)))
+
+ ;; Display options
+
+ (for-each
+ (lambda (l)
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display (car l) (cadr l) (caddr l) (cadddr l))))
+ ;; One list per option here with: option-name, sort-tag,
+ ;; help-string, default-value
+ (list
+ (list (N_ "Date") "a" (N_ "Display the date?") #t)
+ (list (N_ "Num") "b" (N_ "Display the check number?") #t)
+ (list (N_ "Description") "c" (N_ "Display the description?") #t)
+ (list (N_ "Memo") "d" (N_ "Display the memo?") #t)
+ (list (N_ "Account") "e" (N_ "Display the account?") #f)
+ (list (N_ "Use Full Account Name?") "f"
+ (N_ "Display the full account name") #t)
+ (list (N_ "Other Account")"g"
+ (N_ "Display the other account? \
(if this is a split transaction, this parameter is guessed).") #f)
(list (N_ "Shares") "h" (N_ "Display the number of shares?") #f)
(list (N_ "Price") "i" "Display the shares price?" #f)
@@ -1062,4 +1063,4 @@
'options-generator trep-options-generator
- 'renderer trep-renderer))
+ 'renderer trep-renderer)))
Index: gnucash/src/scm/srfi/.cvsignore
diff -u gnucash/src/scm/srfi/.cvsignore:1.2 gnucash/src/scm/srfi/.cvsignore:removed
--- gnucash/src/scm/srfi/.cvsignore:1.2 Wed Sep 13 17:33:14 2000
+++ gnucash/src/scm/srfi/.cvsignore Wed May 16 08:02:46 2001
@@ -1,2 +0,0 @@
-Makefile
-Makefile.in
Index: gnucash/src/scm/srfi/Makefile.am
diff -u gnucash/src/scm/srfi/Makefile.am:1.2 gnucash/src/scm/srfi/Makefile.am:removed
--- gnucash/src/scm/srfi/Makefile.am:1.2 Mon Jun 5 00:51:39 2000
+++ gnucash/src/scm/srfi/Makefile.am Wed May 16 08:02:46 2001
@@ -1,13 +0,0 @@
-
-gncscmdir = ${GNC_SCM_INSTALL_DIR}/srfi
-
-gncscm_DATA = \
- srfi-1.r5rs.scm \
- srfi-1.unclear.scm \
- srfi-19.scm \
- srfi-8.guile.scm \
- srfi-8.scm
-
-EXTRA_DIST = \
- .cvsignore \
- ${gncscm_DATA}
Index: gnucash/src/scm/srfi/README
diff -u gnucash/src/scm/srfi/README:1.1 gnucash/src/scm/srfi/README:removed
--- gnucash/src/scm/srfi/README:1.1 Thu Dec 30 18:05:39 1999
+++ gnucash/src/scm/srfi/README Wed May 16 08:02:46 2001
@@ -1,33 +0,0 @@
-
-These files are copies from a distribution I'm building that includes
-some of the srfis implemented for both rscheme and guile. I've
-changed a few things to be more GnuCash specific...
-
-Below is the README from that distribution.
-
-Each SRFI may have the following related files:
-
- srfi-N.html Offical upstream SRFI document.
- srfi-N.ref.scm Untouched reference implementation, if any.
-
- srfi-N.rXrs.scm Reference implementation w/o non-standard code.
- srfi-N.<I>.pre.scm Preload file for architecture <I>.
- srfi-N.<I>.post.scm Postload file for architecture <I>.
- srfi-N.<I>.scm Specialized version for architecture <I>.
-
- srfi-N.unclear.scm Standard definitions of unclearly defined functions.
- srfi-N.<I>.unclear.scm Unclearly defined functions for architecture <I>.
-
-Here <I> means something like guile or rscheme, and if you find a
-specialized file, then you don't need the rXrs version. However, if
-there is a preload and/or a postload file, then you should load those
-along with the rXrs file to get a complete implementation.
-
-The .unclear.scm files will contain code to (often trivially)
-implement functions required by the SRFI but whose "correct"
-implemention is not well defined. This will includes things like an
-"error" function. It is expected that you will often want to just
-ignore the .unclear.scm files and define the functions they contain
-locally in a way that makes sense for your particular project. If
-there is a <I>.unclear.scm file for your architecture, then you should
-probably choose that over the more general file.
Index: gnucash/src/scm/srfi/srfi-1.r5rs.scm
diff -u gnucash/src/scm/srfi/srfi-1.r5rs.scm:1.3 gnucash/src/scm/srfi/srfi-1.r5rs.scm:removed
--- gnucash/src/scm/srfi/srfi-1.r5rs.scm:1.3 Mon Apr 10 01:23:08 2000
+++ gnucash/src/scm/srfi/srfi-1.r5rs.scm Wed May 16 08:02:46 2001
@@ -1,1614 +0,0 @@
-;;; SRFI-1 list-processing library -*- Scheme -*-
-;;; Reference implementation
-;;;
-;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
-;;; this code as long as you do not remove this copyright notice or
-;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
-;;; -Olin
-
-;;; Modifications to make the code more portable are
-;;; Copyright 1999, Rob Browning <rlb@cs.utexas.edu>. You may do as
-;;; you please with this code as long as you do not remove this
-;;; copyright notice or hold me liable for its use.
-
-;;; This is a library of list- and pair-processing functions. I wrote it after
-;;; carefully considering the functions provided by the libraries found in
-;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
-;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
-;;; rich toolkit, providing a superset of the functionality found in any of
-;;; the various Schemes I considered.
-
-;;; This implementation is intended as a portable reference implementation
-;;; for SRFI-1. See the porting notes below for more information.
-
-;;; Exported:
-;;; xcons tree-copy make-list list-tabulate cons* list-copy
-;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
-;;; circular-list length+
-;;; iota
-;;; first second third fourth fifth sixth seventh eighth ninth tenth
-;;; car+cdr
-;;; take drop
-;;; take-right drop-right
-;;; take! drop-right!
-;;; split-at split-at!
-;;; last last-pair
-;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
-;;; count
-;;; append! append-reverse append-reverse! concatenate concatenate!
-;;; unfold fold pair-fold reduce
-;;; unfold-right fold-right pair-fold-right reduce-right
-;;; append-map append-map! map! pair-for-each filter-map map-in-order
-;;; filter partition remove
-;;; filter! partition! remove!
-;;; find find-tail any every list-index-pred
-;;; take-while drop-while take-while!
-;;; span break span! break!
-;;; delete delete!
-;;; alist-cons alist-copy
-;;; delete-duplicates delete-duplicates!
-;;; alist-delete alist-delete!
-;;; reverse!
-;;; lset<= lset= lset-adjoin
-;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
-;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
-;;;
-;;; In principle, the following R4RS list- and pair-processing procedures
-;;; are also part of this package's exports, although they are not defined
-;;; in this file:
-;;; Primitives: cons pair? null? car cdr set-car! set-cdr!
-;;; Non-primitives: list length append reverse cadr ... cddddr list-ref
-;;; memq memv assq assv
-;;; (The non-primitives are defined in this file, but commented out.)
-;;;
-;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
-;;; in this file:
-;;; map for-each member assoc
-;;;
-;;; The remaining two R4RS list-processing procedures are not included:
-;;; list-tail (use drop)
-;;; list? (use proper-list?)
-
-
-;;; A note on recursion and iteration/reversal:
-;;; Many iterative list-processing algorithms naturally compute the elements
-;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
-;;; the order needed to cons them into the proper answer (right-to-left, or
-;;; tail-then-head). One style or idiom of programming these algorithms, then,
-;;; loops, consing up the elements in reverse order, then destructively
-;;; reverses the list at the end of the loop. I do not do this. The natural
-;;; and efficient way to code these algorithms is recursively. This trades off
-;;; intermediate temporary list structure for intermediate temporary stack
-;;; structure. In a stack-based system, this improves cache locality and
-;;; lightens the load on the GC system. Don't stand on your head to iterate!
-;;; Recurse, where natural. Multiple-value returns make this even more
-;;; convenient, when the recursion/iteration has multiple state values.
-
-;;; Porting:
-;;; This is carefully tuned code; do not modify casually.
-;;; - It is careful to share storage when possible;
-;;; - Side-effecting code tries not to perform redundant writes.
-;;;
-;;; That said, a port of this library to a specific Scheme system might wish
-;;; to tune this code to exploit particulars of the implementation.
-;;; The single most important compiler-specific optimisation you could make
-;;; to this library would be to add rewrite rules or transforms to:
-;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
-;;; LSET-UNION) into multiple applications of a primitive two-argument
-;;; variant.
-;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD,
-;;; ANY, EVERY) into open-coded loops. The killer here is that these
-;;; functions are n-ary. Handling the general case is quite inefficient,
-;;; requiring many intermediate data structures to be allocated and
-;;; discarded.
-;;; - transform applications of procedures that take optional arguments
-;;; into calls to variants that do not take optional arguments. This
-;;; eliminates unnecessary consing and parsing of the rest parameter.
-;;;
-;;; These transforms would provide BIG speedups. In particular, the n-ary
-;;; mapping functions are particularly slow and cons-intensive, and are good
-;;; candidates for tuning. I have coded fast paths for the single-list cases,
-;;; but what you really want to do is exploit the fact that the compiler
-;;; usually knows how many arguments are being passed to a particular
-;;; application of these functions -- they are usually explicitly called, not
-;;; passed around as higher-order values. If you can arrange to have your
-;;; compiler produce custom code or custom linkages based on the number of
-;;; arguments in the call, you can speed these functions up a *lot*. But this
-;;; kind of compiler technology no longer exists in the Scheme world as far as
-;;; I can see.
-;;;
-;;; Note that this code is, of course, dependent upon standard bindings for
-;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
-;;; to the procedure that takes the car of a list. If your Scheme
-;;; implementation allows user code to alter the bindings of these procedures
-;;; in a manner that would be visible to these definitions, then there might
-;;; be trouble. You could consider horrible kludgery along the lines of
-;;; (define fact
-;;; (let ((= =) (- -) (* *))
-;;; (letrec ((real-fact (lambda (n)
-;;; (if (= n 0) 1 (* n (real-fact (- n 1)))))))
-;;; real-fact)))
-;;; Or you could consider shifting to a reasonable Scheme system that, say,
-;;; has a module system protecting code from this kind of lossage.
-;;;
-;;; This code does a fair amount of run-time argument checking. If your
-;;; Scheme system has a sophisticated compiler that can eliminate redundant
-;;; error checks, this is no problem. However, if not, these checks incur
-;;; some performance overhead -- and, in a safe Scheme implementation, they
-;;; are in some sense redundant: if we don't check to see that the PROC
-;;; parameter is a procedure, we'll find out anyway three lines later when
-;;; we try to call the value. It's pretty easy to rip all this argument
-;;; checking code out if it's inappropriate for your implementation -- just
-;;; nuke every call to CHECK-ARG.
-;;;
-;;; On the other hand, if you *do* have a sophisticated compiler that will
-;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
-;;; being the only possible candidate of which I'm aware), leaving these checks
-;;; in can *help*, since their presence can be elided in redundant cases,
-;;; and in cases where they are needed, performing the checks early, at
-;;; procedure entry, can "lift" a check out of a loop.
-;;;
-;;; Finally, I have only checked the properties that can portably be checked
-;;; with R5RS Scheme -- and this is not complete. You may wish to alter
-;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
-;;; checks, such as procedure arity for higher-order values.
-;;;
-;;; The code has only these non-R4RS dependencies:
-;;; A few calls to an ERROR procedure;
-;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding
-;;; RECEIVE macro (which isn't R5RS, but is a trivial macro).
-;;; Many calls to a parameter-checking procedure check-arg:
-;;; (define (check-arg pred val caller)
-;;; (let lp ((val val))
-;;; (if (pred val) val (lp (error "Bad argument" val pred caller)))))
-;;;
-;;; Most of these procedures use the NULL-LIST? test to trigger the
-;;; base case in the inner loop or recursion. The NULL-LIST? function
-;;; is defined to be a careful one -- it raises an error if passed a
-;;; non-nil, non-pair value. The spec allows an implementation to use
-;;; a less-careful implementation that simply defines NULL-LIST? to
-;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
-;;; at the expense of having them silently accept dotted lists.
-
-;;; A note on dotted lists:
-;;; I, personally, take the view that the only consistent view of lists
-;;; in Scheme is the view that *everything* is a list -- values such as
-;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
-;;; fact that Scheme actually has no true list type. It has a pair type,
-;;; and there is an *interpretation* of the trees built using this type
-;;; as lists.
-;;;
-;;; I lobbied to have these list-processing procedures hew to this
-;;; view, and accept any value as a list argument. I was overwhelmingly
-;;; overruled during the SRFI discussion phase. So I am inserting this
-;;; text in the reference lib and the SRFI spec as a sort of "minority
-;;; opinion" dissent.
-;;;
-;;; Many of the procedures in this library can be trivially redefined
-;;; to handle dotted lists, just by changing the NULL-LIST? base-case
-;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
-;;; an empty list. For most of these procedures, that's all that is
-;;; required.
-;;;
-;;; However, we have to do a little more work for some procedures that
-;;; *produce* lists from other lists. Were we to extend these procedures to
-;;; accept dotted lists, we would have to define how they terminate the lists
-;;; produced as results when passed a dotted list. I designed a coherent set
-;;; of termination rules for these cases; this was posted to the SRFI-1
-;;; discussion list. I additionally wrote an earlier version of this library
-;;; that implemented that spec. It has been discarded during later phases of
-;;; the definition and implementation of this library.
-;;;
-;;; The argument *against* defining these procedures to work on dotted
-;;; lists is that dotted lists are the rare, odd case, and that by
-;;; arranging for the procedures to handle them, we lose error checking
-;;; in the cases where a dotted list is passed by accident -- e.g., when
-;;; the programmer swaps a two arguments to a list-processing function,
-;;; one being a scalar and one being a list. For example,
-;;; (member '(1 3 5 7 9) 7)
-;;; This would quietly return #f if we extended MEMBER to accept dotted
-;;; lists.
-;;;
-;;; The SRFI discussion record contains more discussion on this topic.
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Modifications from the "official" implementation.
-;;;
-;;; Removed all non r5rs-isms that I detected (i.e :optional and let-optionals).
-;;;
-;;; Renamed error to srfi-1:error
-;;; Renamed check-arg to srfi-1:check-arg
-;;;
-
-
-;;; Constructors
-;;;;;;;;;;;;;;;;
-
-;;; Occasionally useful as a value to be passed to a fold or other
-;;; higher-order procedure.
-(define (xcons d a) (cons a d))
-
-;;;; Recursively copy every cons.
-;(define (tree-copy x)
-; (let recur ((x x))
-; (if (not (pair? x)) x
-; (cons (recur (car x)) (recur (cdr x))))))
-
-;;; Make a list of length LEN.
-
-(define (make-list len . maybe-elt)
- (srfi-1:check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
- (let ((elt (cond ((null? maybe-elt) #f) ; Default value
- ((null? (cdr maybe-elt)) (car maybe-elt))
- (else (srfi-1:error "Too many arguments to MAKE-LIST"
- (cons len maybe-elt))))))
- (do ((i len (- i 1))
- (ans '() (cons elt ans)))
- ((<= i 0) ans))))
-
-
-;(define (list . ans) ans) ; R4RS
-
-
-;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
-
-(define (list-tabulate len proc)
- (srfi-1:check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
- (srfi-1:check-arg procedure? proc list-tabulate)
- (do ((i (- len 1) (- i 1))
- (ans '() (cons (proc i) ans)))
- ((< i 0) ans)))
-
-;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
-;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
-;;;
-;;; (cons first (unfold not-pair? car cdr rest values))
-
-(define (cons* first . rest)
- (let recur ((x first) (rest rest))
- (if (pair? rest)
- (cons x (recur (car rest) (cdr rest)))
- x)))
-
-;;; (unfold not-pair? car cdr lis values)
-
-(define (list-copy lis)
- (let recur ((lis lis))
- (if (pair? lis)
- (cons (car lis) (recur (cdr lis)))
- lis)))
-
-;;; IOTA count [start step] (start start+step ... start+(count-1)*step)
-
-(define (iota count . maybe-start+step)
-
- (define (helper start step)
- (srfi-1:check-arg number? start iota)
- (srfi-1:check-arg number? step iota)
- (let ((last-val (+ start (* (- count 1) step))))
- (do ((count count (- count 1))
- (val last-val (- val step))
- (ans '() (cons val ans)))
- ((<= count 0) ans))))
-
- (srfi-1:check-arg integer? count iota)
- (if (< count 0) (srfi-1:error "Negative step count" iota count))
-
- (if (pair? maybe-start+step)
- (helper (car maybe-start+step) (cadr maybe-start+step))
- (helper 0 1)))
-
-;;; I thought these were lovely, but the public at large did not share my
-;;; enthusiasm...
-;;; :IOTA to (0 ... to-1)
-;;; :IOTA from to (from ... to-1)
-;;; :IOTA from to step (from from+step ...)
-
-;;; IOTA: to (1 ... to)
-;;; IOTA: from to (from+1 ... to)
-;;; IOTA: from to step (from+step from+2step ...)
-
-;(define (%parse-iota-args arg1 rest-args proc)
-; (let ((check (lambda (n) (srfi-1:check-arg integer? n proc))))
-; (check arg1)
-; (if (pair? rest-args)
-; (let ((arg2 (check (car rest-args)))
-; (rest (cdr rest-args)))
-; (if (pair? rest)
-; (let ((arg3 (check (car rest)))
-; (rest (cdr rest)))
-; (if (pair? rest) (srfi-1:error "Too many parameters" proc arg1 rest-args)
-; (values arg1 arg2 arg3)))
-; (values arg1 arg2 1)))
-; (values 0 arg1 1))))
-;
-;(define (iota: arg1 . rest-args)
-; (receive (from to step) (%parse-iota-args arg1 rest-args iota:)
-; (let* ((numsteps (floor (/ (- to from) step)))
-; (last-val (+ from (* step numsteps))))
-; (if (< numsteps 0) (srfi-1:error "Negative step count" iota: from to step))
-; (do ((steps-left numsteps (- steps-left 1))
-; (val last-val (- val step))
-; (ans '() (cons val ans)))
-; ((<= steps-left 0) ans)))))
-;
-;
-;(define (:iota arg1 . rest-args)
-; (receive (from to step) (%parse-iota-args arg1 rest-args :iota)
-; (let* ((numsteps (ceiling (/ (- to from) step)))
-; (last-val (+ from (* step (- numsteps 1)))))
-; (if (< numsteps 0) (srfi-1:error "Negative step count" :iota from to step))
-; (do ((steps-left numsteps (- steps-left 1))
-; (val last-val (- val step))
-; (ans '() (cons val ans)))
-; ((<= steps-left 0) ans)))))
-
-
-
-(define (circular-list val1 . vals)
- (let ((ans (cons val1 vals)))
- (set-cdr! (last-pair ans) ans)
- ans))
-
-;;; <proper-list> ::= () ; Empty proper list
-;;; | (cons <x> <proper-list>) ; Proper-list pair
-;;; Note that this definition rules out circular lists -- and this
-;;; function is required to detect this case and return false.
-
-(define (proper-list? x)
- (let lp ((x x) (lag x))
- (if (pair? x)
- (let ((x (cdr x)))
- (if (pair? x)
- (let ((x (cdr x))
- (lag (cdr lag)))
- (and (not (eq? x lag)) (lp x lag)))
- (null? x)))
- (null? x))))
-
-
-;;; A dotted list is a finite list (possibly of length 0) terminated
-;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
-;;; is a dotted list of length 0.
-;;;
-;;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
-;;; | (cons <x> <dotted-list>) ; Proper-list pair
-
-(define (dotted-list? x)
- (let lp ((x x) (lag x))
- (if (pair? x)
- (let ((x (cdr x)))
- (if (pair? x)
- (let ((x (cdr x))
- (lag (cdr lag)))
- (and (not (eq? x lag)) (lp x lag)))
- (not (null? x))))
- (not (null? x)))))
-
-(define (circular-list? x)
- (let lp ((x x) (lag x))
- (and (pair? x)
- (let ((x (cdr x)))
- (and (pair? x)
- (let ((x (cdr x))
- (lag (cdr lag)))
- (or (eq? x lag) (lp x lag))))))))
-
-(define (not-pair? x) (not (pair? x))) ; Inline me.
-
-;;; This is a legal definition which is fast and sloppy:
-;;; (define null-list? not-pair?)
-;;; but we'll provide a more careful one:
-(define (null-list? l)
- (cond ((pair? l) #f)
- ((null? l) #t)
- (else (srfi-1:error "null-pair?: argument out of domain" l))))
-
-
-(define (list= = . lists)
- (or (null? lists) ; special case
-
- (let lp1 ((list-a (car lists)) (others (cdr lists)))
- (or (null? others)
- (let ((list-b (car others))
- (others (cdr others)))
- (if (eq? list-a list-b) ; EQ? => LIST=
- (lp1 list-b others)
- (let lp2 ((list-a list-a) (list-b list-b))
- (if (null-list? list-a)
- (and (null-list? list-b)
- (lp1 list-b others))
- (and (not (null-list? list-b))
- (= (car list-a) (car list-b))
- (lp2 (cdr list-a) (cdr list-b)))))))))))
-
-
-
-;;; R4RS, so commented out.
-;(define (length x) ; LENGTH may diverge or
-; (let lp ((x x) (len 0)) ; raise an error if X is
-; (if (pair? x) ; a circular list. This version
-; (lp (cdr x) (+ len 1)) ; diverges.
-; len)))
-
-(define (length+ x) ; Returns #f if X is circular.
- (let lp ((x x) (lag x) (len 0))
- (if (pair? x)
- (let ((x (cdr x))
- (len (+ len 1)))
- (if (pair? x)
- (let ((x (cdr x))
- (lag (cdr lag))
- (len (+ len 1)))
- (and (not (eq? x lag)) (lp x lag len)))
- len))
- len)))
-
-(define (zip list1 . more-lists) (apply map list list1 more-lists))
-
-
-;;; Selectors
-;;;;;;;;;;;;;
-
-;;; R4RS non-primitives:
-;(define (caar x) (car (car x)))
-;(define (cadr x) (car (cdr x)))
-;(define (cdar x) (cdr (car x)))
-;(define (cddr x) (cdr (cdr x)))
-;
-;(define (caaar x) (caar (car x)))
-;(define (caadr x) (caar (cdr x)))
-;(define (cadar x) (cadr (car x)))
-;(define (caddr x) (cadr (cdr x)))
-;(define (cdaar x) (cdar (car x)))
-;(define (cdadr x) (cdar (cdr x)))
-;(define (cddar x) (cddr (car x)))
-;(define (cdddr x) (cddr (cdr x)))
-;
-;(define (caaaar x) (caaar (car x)))
-;(define (caaadr x) (caaar (cdr x)))
-;(define (caadar x) (caadr (car x)))
-;(define (caaddr x) (caadr (cdr x)))
-;(define (cadaar x) (cadar (car x)))
-;(define (cadadr x) (cadar (cdr x)))
-;(define (caddar x) (caddr (car x)))
-;(define (cadddr x) (caddr (cdr x)))
-;(define (cdaaar x) (cdaar (car x)))
-;(define (cdaadr x) (cdaar (cdr x)))
-;(define (cdadar x) (cdadr (car x)))
-;(define (cdaddr x) (cdadr (cdr x)))
-;(define (cddaar x) (cddar (car x)))
-;(define (cddadr x) (cddar (cdr x)))
-;(define (cdddar x) (cdddr (car x)))
-;(define (cddddr x) (cdddr (cdr x)))
-
-
-(define first car)
-(define second cadr)
-(define third caddr)
-(define fourth cadddr)
-(define (fifth x) (car (cddddr x)))
-(define (sixth x) (cadr (cddddr x)))
-(define (seventh x) (caddr (cddddr x)))
-(define (eighth x) (cadddr (cddddr x)))
-(define (ninth x) (car (cddddr (cddddr x))))
-(define (tenth x) (cadr (cddddr (cddddr x))))
-
-(define (car+cdr pair) (values (car pair) (cdr pair)))
-
-;;; take & drop
-
-(define (take lis k)
- (srfi-1:check-arg integer? k take)
- (let recur ((lis lis) (k k))
- (if (zero? k) '()
- (cons (car lis)
- (recur (cdr lis) (- k 1))))))
-
-(define (drop lis k)
- (srfi-1:check-arg integer? k drop)
- (let iter ((lis lis) (k k))
- (if (zero? k) lis (iter (cdr lis) (- k 1)))))
-
-(define (take! lis k)
- (srfi-1:check-arg integer? k take!)
- (if (zero? k) '()
- (begin (set-cdr! (drop lis (- k 1)) '())
- lis)))
-
-;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
-;;; off by K, then chasing down the list until the lead pointer falls off
-;;; the end.
-
-(define (take-right lis k)
- (srfi-1:check-arg integer? k take-right)
- (let lp ((lag lis) (lead (drop lis k)))
- (if (pair? lead)
- (lp (cdr lag) (cdr lead))
- lag)))
-
-(define (drop-right lis k)
- (srfi-1:check-arg integer? k drop-right)
- (let recur ((lag lis) (lead (drop lis k)))
- (if (pair? lead)
- (cons (car lag) (recur (cdr lag) (cdr lead)))
- '())))
-
-;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
-;;; us stop LAG one step early, in time to smash its cdr to ().
-(define (drop-right! lis k)
- (srfi-1:check-arg integer? k drop-right!)
- (let ((lead (drop lis k)))
- (if (pair? lead)
-
- (let lp ((lag lis) (lead (cdr lead))) ; Standard case
- (if (pair? lead)
- (lp (cdr lag) (cdr lead))
- (begin (set-cdr! lag '())
- lis)))
-
- '()))) ; Special case dropping everything -- no cons to side-effect.
-
-;(define (list-ref lis i) (car (drop lis i))) ; R4RS
-
-;;; These use the APL convention, whereby negative indices mean
-;;; "from the right." I liked them, but they didn't win over the
-;;; SRFI reviewers.
-;;; K >= 0: Take and drop K elts from the front of the list.
-;;; K <= 0: Take and drop -K elts from the end of the list.
-
-;(define (take lis k)
-; (srfi-1:check-arg integer? k take)
-; (if (negative? k)
-; (list-tail lis (+ k (length lis)))
-; (let recur ((lis lis) (k k))
-; (if (zero? k) '()
-; (cons (car lis)
-; (recur (cdr lis) (- k 1)))))))
-;
-;(define (drop lis k)
-; (srfi-1:check-arg integer? k drop)
-; (if (negative? k)
-; (let recur ((lis lis) (nelts (+ k (length lis))))
-; (if (zero? nelts) '()
-; (cons (car lis)
-; (recur (cdr lis) (- nelts 1)))))
-; (list-tail lis k)))
-;
-;
-;(define (take! lis k)
-; (srfi-1:check-arg integer? k take!)
-; (cond ((zero? k) '())
-; ((positive? k)
-; (set-cdr! (list-tail lis (- k 1)) '())
-; lis)
-; (else (list-tail lis (+ k (length lis))))))
-;
-;(define (drop! lis k)
-; (srfi-1:check-arg integer? k drop!)
-; (if (negative? k)
-; (let ((nelts (+ k (length lis))))
-; (if (zero? nelts) '()
-; (begin (set-cdr! (list-tail lis (- nelts 1)) '())
-; lis)))
-; (list-tail lis k)))
-
-(define (split-at x k)
- (srfi-1:check-arg integer? k split-at)
- (let recur ((lis x) (k k))
- (if (zero? k) (values '() lis)
- (receive (prefix suffix) (recur (cdr lis) (- k 1))
- (values (cons (car lis) prefix) suffix)))))
-
-(define (split-at! x k)
- (srfi-1:check-arg integer? k split-at!)
- (if (zero? k) (values '() x)
- (let* ((prev (drop x (- k 1)))
- (suffix (cdr prev)))
- (set-cdr! prev '())
- (values x suffix))))
-
-
-(define (last lis) (car (last-pair lis)))
-
-(define (last-pair lis)
- (srfi-1:check-arg pair? lis last-pair)
- (let lp ((lis lis))
- (let ((tail (cdr lis)))
- (if (pair? tail) (lp tail) lis))))
-
-
-;;; Unzippers -- 1 through 5
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (unzip1 lis) (map car lis))
-
-(define (unzip2 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
- (let ((elt (car lis))) ; dotted lists.
- (receive (a b) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)))))))
-
-(define (unzip3 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis lis)
- (let ((elt (car lis)))
- (receive (a b c) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)
- (cons (caddr elt) c)))))))
-
-(define (unzip4 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis lis lis)
- (let ((elt (car lis)))
- (receive (a b c d) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)
- (cons (caddr elt) c)
- (cons (cadddr elt) d)))))))
-
-(define (unzip5 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis lis lis lis)
- (let ((elt (car lis)))
- (receive (a b c d e) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)
- (cons (caddr elt) c)
- (cons (cadddr elt) d)
- (cons (car (cddddr elt)) e)))))))
-
-
-;;; append! append-reverse append-reverse! concatenate concatenate!
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (append! . lists)
- ;; First, scan through lists looking for a non-empty one.
- (let lp ((lists lists) (prev '()))
- (if (not (pair? lists)) prev
- (let ((first (car lists))
- (rest (cdr lists)))
- (if (not (pair? first)) (lp rest first)
-
- ;; Now, do the splicing.
- (let lp2 ((tail-cons (last-pair first))
- (rest rest))
- (if (pair? rest)
- (let ((next (car rest))
- (rest (cdr rest)))
- (set-cdr! tail-cons next)
- (lp2 (if (pair? next) (last-pair next) tail-cons)
- rest))
- first)))))))
-
-;;; APPEND is R4RS.
-;(define (append . lists)
-; (if (pair? lists)
-; (let recur ((list1 (car lists)) (lists (cdr lists)))
-; (if (pair? lists)
-; (let ((tail (recur (car lists) (cdr lists))))
-; (fold-right cons tail list1)) ; Append LIST1 & TAIL.
-; list1))
-; '()))
-
-;(define (append-reverse rev-head tail) (fold cons tail rev-head))
-
-;(define (append-reverse! rev-head tail)
-; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
-; tail
-; rev-head))
-
-;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
-
-(define (append-reverse rev-head tail)
- (let lp ((rev-head rev-head) (tail tail))
- (if (null-list? rev-head) tail
- (lp (cdr rev-head) (cons (car rev-head) tail)))))
-
-(define (append-reverse! rev-head tail)
- (let lp ((rev-head rev-head) (tail tail))
- (if (null-list? rev-head) tail
- (let ((next-rev (cdr rev-head)))
- (set-cdr! rev-head tail)
- (lp next-rev rev-head)))))
-
-
-(define (concatenate lists) (reduce-right append '() lists))
-(define (concatenate! lists) (reduce-right append! '() lists))
-
-;;; Fold/map internal utilities
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; These little internal utilities are used by the general
-;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
-;;; One the other hand, the n-ary cases are painfully inefficient as it is.
-;;; An aggressive implementation should simply re-write these functions
-;;; for raw efficiency; I have written them for as much clarity, portability,
-;;; and simplicity as can be achieved.
-;;;
-;;; I use the dreaded call/cc to do local aborts. A good compiler could
-;;; handle this with extreme efficiency. An implementation that provides
-;;; a one-shot, non-persistent continuation grabber could help the compiler
-;;; out by using that in place of the call/cc's in these routines.
-;;;
-;;; These functions have funky definitions that are precisely tuned to
-;;; the needs of the fold/map procs -- for example, to minimize the number
-;;; of times the argument lists need to be examined.
-
-;;; Return (map cdr lists).
-;;; However, if any element of LISTS is empty, just abort and return '().
-(define (%cdrs lists)
- (call-with-current-continuation
- (lambda (abort)
- (let recur ((lists lists))
- (if (pair? lists)
- (let ((lis (car lists)))
- (if (null-list? lis) (abort '())
- (cons (cdr lis) (recur (cdr lists)))))
- '())))))
-
-(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt))
- (let recur ((lists lists))
- (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
-
-;;; LISTS is a (not very long) non-empty list of lists.
-;;; Return two lists: the cars & the cdrs of the lists.
-;;; However, if any of the lists is empty, just abort and return [() ()].
-
-(define (%cars+cdrs lists)
- (call-with-current-continuation
- (lambda (abort)
- (let recur ((lists lists))
- (if (pair? lists)
- (receive (list other-lists) (car+cdr lists)
- (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
- (receive (a d) (car+cdr list)
- (receive (cars cdrs) (recur other-lists)
- (values (cons a cars) (cons d cdrs))))))
- (values '() '()))))))
-
-;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
-;;; cars list. What a hack.
-(define (%cars+cdrs+ lists cars-final)
- (call-with-current-continuation
- (lambda (abort)
- (let recur ((lists lists))
- (if (pair? lists)
- (receive (list other-lists) (car+cdr lists)
- (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
- (receive (a d) (car+cdr list)
- (receive (cars cdrs) (recur other-lists)
- (values (cons a cars) (cons d cdrs))))))
- (values (list cars-final) '()))))))
-
-;;; Like %CARS+CDRS, but blow up if any list is empty.
-(define (%cars+cdrs/no-test lists)
- (let recur ((lists lists))
- (if (pair? lists)
- (receive (list other-lists) (car+cdr lists)
- (receive (a d) (car+cdr list)
- (receive (cars cdrs) (recur other-lists)
- (values (cons a cars) (cons d cdrs)))))
- (values '() '()))))
-
-
-;;; count
-;;;;;;;;;
-(define (count pred list1 . lists)
- (srfi-1:check-arg procedure? pred count)
- (if (pair? lists)
-
- ;; N-ary case
- (let lp ((list1 list1) (lists lists) (i 0))
- (if (null-list? list1) i
- (receive (as ds) (%cars+cdrs lists)
- (if (null? as) i
- (lp (cdr list1) ds
- (if (apply pred (car list1) as) (+ i 1) i))))))
-
- ;; Fast path
- (let lp ((lis list1) (i 0))
- (if (null-list? lis) i
- (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
-
-
-;;; fold/unfold
-;;;;;;;;;;;;;;;
-
-(define (unfold-right p f g seed . maybe-tail)
- (srfi-1:check-arg procedure? p unfold-right)
- (srfi-1:check-arg procedure? f unfold-right)
- (srfi-1:check-arg procedure? g unfold-right)
- (let lp ((seed seed)
- (ans (if (pair? maybe-tail) (car maybe-tail) '())))
- (if (p seed) ans
- (lp (g seed)
- (cons (f seed) ans)))))
-
-
-(define (unfold p f g seed . maybe-tail-gen)
- (srfi-1:check-arg procedure? p unfold)
- (srfi-1:check-arg procedure? f unfold)
- (srfi-1:check-arg procedure? g unfold)
- (if (pair? maybe-tail-gen)
-
- (let ((tail-gen (car maybe-tail-gen)))
- (if (pair? (cdr maybe-tail-gen))
- (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
-
- (let recur ((seed seed))
- (if (p seed) (tail-gen seed)
- (cons (f seed) (recur (g seed)))))))
-
- (let recur ((seed seed))
- (if (p seed) '()
- (cons (f seed) (recur (g seed)))))))
-
-
-(define (fold kons knil lis1 . lists)
- (srfi-1:check-arg procedure? kons fold)
- (if (pair? lists)
- (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case
- (receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
- (if (null? cars+ans) ans ; Done.
- (lp cdrs (apply kons cars+ans)))))
-
- (let lp ((lis lis1) (ans knil)) ; Fast path
- (if (null-list? lis) ans
- (lp (cdr lis) (kons (car lis) ans))))))
-
-
-(define (fold-right kons knil lis1 . lists)
- (srfi-1:check-arg procedure? kons fold-right)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists))) ; N-ary case
- (let ((cdrs (%cdrs lists)))
- (if (null? cdrs) knil
- (apply kons (%cars+ lists (recur cdrs))))))
-
- (let recur ((lis lis1)) ; Fast path
- (if (null-list? lis) knil
- (let ((head (car lis)))
- (kons head (recur (cdr lis))))))))
-
-
-(define (pair-fold-right f zero lis1 . lists)
- (srfi-1:check-arg procedure? f pair-fold-right)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists))) ; N-ary case
- (let ((cdrs (%cdrs lists)))
- (if (null? cdrs) zero
- (apply f (append! lists (list (recur cdrs)))))))
-
- (let recur ((lis lis1)) ; Fast path
- (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
-
-(define (pair-fold f zero lis1 . lists)
- (srfi-1:check-arg procedure? f pair-fold)
- (if (pair? lists)
- (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case
- (let ((tails (%cdrs lists)))
- (if (null? tails) ans
- (lp tails (apply f (append! lists (list ans)))))))
-
- (let lp ((lis lis1) (ans zero))
- (if (null-list? lis) ans
- (let ((tail (cdr lis))) ; Grab the cdr now,
- (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS.
-
-
-;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
-;;; These cannot meaningfully be n-ary.
-
-(define (reduce f ridentity lis)
- (srfi-1:check-arg procedure? f reduce)
- (if (null-list? lis) ridentity
- (fold f (car lis) (cdr lis))))
-
-(define (reduce-right f ridentity lis)
- (srfi-1:check-arg procedure? f reduce-right)
- (if (null-list? lis) ridentity
- (let recur ((head (car lis)) (lis (cdr lis)))
- (if (pair? lis)
- (f head (recur (car lis) (cdr lis)))
- head))))
-
-
-
-;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (append-map f lis1 . lists)
- (really-append-map append-map append f lis1 lists))
-(define (append-map! f lis1 . lists)
- (really-append-map append-map! append! f lis1 lists))
-
-(define (really-append-map who appender f lis1 lists)
- (srfi-1:check-arg procedure? f who)
- (if (pair? lists)
- (receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
- (if (null? cars) '()
- (let recur ((cars cars) (cdrs cdrs))
- (let ((vals (apply f cars)))
- (receive (cars2 cdrs2) (%cars+cdrs cdrs)
- (if (null? cars2) vals
- (appender vals (recur cars2 cdrs2))))))))
-
- ;; Fast path
- (if (null-list? lis1) '()
- (let recur ((elt (car lis1)) (rest (cdr lis1)))
- (let ((vals (f elt)))
- (if (null-list? rest) vals
- (appender vals (recur (car rest) (cdr rest)))))))))
-
-
-(define (pair-for-each proc lis1 . lists)
- (srfi-1:check-arg procedure? proc pair-for-each)
- (if (pair? lists)
-
- (let lp ((lists (cons lis1 lists)))
- (let ((tails (%cdrs lists)))
- (if (pair? tails)
- (begin (apply proc lists)
- (lp tails)))))
-
- ;; Fast path.
- (let lp ((lis lis1))
- (if (not (null-list? lis))
- (let ((tail (cdr lis))) ; Grab the cdr now,
- (proc lis) ; in case PROC SET-CDR!s LIS.
- (lp tail))))))
-
-;;; We stop when LIS1 runs out, not when any list runs out.
-(define (map! f lis1 . lists)
- (srfi-1:check-arg procedure? f map!)
- (if (pair? lists)
- (let lp ((lis1 lis1) (lists lists))
- (if (not (null-list? lis1))
- (receive (heads tails) (%cars+cdrs/no-test lists)
- (set-car! lis1 (apply f (car lis1) heads))
- (lp (cdr lis1) tails))))
-
- ;; Fast path.
- (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
- lis1)
-
-
-;;; Map F across L, and save up all the non-false results.
-(define (filter-map f lis1 . lists)
- (srfi-1:check-arg procedure? f filter-map)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists)))
- (receive (cars cdrs) (%cars+cdrs lists)
- (if (pair? cars)
- (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
- (else (recur cdrs))) ; Tail call in this arm.
- '())))
-
- ;; Fast path.
- (let recur ((lis lis1))
- (if (null-list? lis) lis
- (let ((tail (recur (cdr lis))))
- (cond ((f (car lis)) => (lambda (x) (cons x tail)))
- (else tail)))))))
-
-
-;;; Map F across lists, guaranteeing to go left-to-right.
-;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
-;;; in which case this procedure may simply be defined as a synonym for MAP.
-
-(define (map-in-order f lis1 . lists)
- (srfi-1:check-arg procedure? f map-in-order)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists)))
- (receive (cars cdrs) (%cars+cdrs lists)
- (if (pair? cars)
- (let ((x (apply f cars))) ; Do head first,
- (cons x (recur cdrs))) ; then tail.
- '())))
-
- ;; Fast path.
- (let recur ((lis lis1))
- (if (null-list? lis) lis
- (let ((tail (cdr lis))
- (x (f (car lis)))) ; Do head first,
- (cons x (recur tail))))))) ; then tail.
-
-
-;;; We extend MAP to handle arguments of unequal length.
-;; (define map map-in-order)
-
-
-;;; filter, remove, partition
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
-;;; disorder the elements of their argument.
-
-;; This FILTER shares the longest tail of L that has no deleted elements.
-;; If Scheme had multi-continuation calls, they could be made more efficient.
-
-(define (filter pred lis) ; Sleazing with EQ? makes this
- (srfi-1:check-arg procedure? pred filter) ; one faster.
- (let recur ((lis lis))
- (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
- (let ((head (car lis))
- (tail (cdr lis)))
- (if (pred head)
- (let ((new-tail (recur tail))) ; Replicate the RECUR call so
- (if (eq? tail new-tail) lis
- (cons head new-tail)))
- (recur tail)))))) ; this one can be a tail call.
-
-
-;;; Another version that shares longest tail.
-;(define (filter pred lis)
-; (receive (ans no-del?)
-; ;; (recur l) returns L with (pred x) values filtered.
-; ;; It also returns a flag NO-DEL? if the returned value
-; ;; is EQ? to L, i.e. if it didn't have to delete anything.
-; (let recur ((l l))
-; (if (null-list? l) (values l #t)
-; (let ((x (car l))
-; (tl (cdr l)))
-; (if (pred x)
-; (receive (ans no-del?) (recur tl)
-; (if no-del?
-; (values l #t)
-; (values (cons x ans) #f)))
-; (receive (ans no-del?) (recur tl) ; Delete X.
-; (values ans #f))))))
-; ans))
-
-
-
-;(define (filter! pred lis) ; Things are much simpler
-; (let recur ((lis lis)) ; if you are willing to
-; (if (pair? lis) ; push N stack frames & do N
-; (cond ((pred (car lis)) ; SET-CDR! writes, where N is
-; (set-cdr! lis (recur (cdr lis))); the length of the answer.
-; lis)
-; (else (recur (cdr lis))))
-; lis)))
-
-
-;;; This implementation of FILTER!
-;;; - doesn't cons, and uses no stack;
-;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
-;;; usually expensive on modern machines, and can be extremely expensive on
-;;; modern Schemes (e.g., ones that have generational GC's).
-;;; It just zips down contiguous runs of in and out elts in LIS doing the
-;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the
-;;; beginning of the next.
-
-(define (filter! pred lis)
- (srfi-1:check-arg procedure? pred filter!)
- (let lp ((ans lis))
- (cond ((null-list? ans) ans) ; Scan looking for
- ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result.
-
- ;; ANS is the eventual answer.
- ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
- ;; Scan over a contiguous segment of the list that
- ;; satisfies PRED.
- ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
- ;; segment of the list that *doesn't* satisfy PRED.
- ;; When the segment ends, patch in a link from PREV
- ;; to the start of the next good segment, and jump to
- ;; SCAN-IN.
- (else (letrec ((scan-in (lambda (prev lis)
- (if (pair? lis)
- (if (pred (car lis))
- (scan-in lis (cdr lis))
- (scan-out prev (cdr lis))))))
- (scan-out (lambda (prev lis)
- (let lp ((lis lis))
- (if (pair? lis)
- (if (pred (car lis))
- (begin (set-cdr! prev lis)
- (scan-in lis (cdr lis)))
- (lp (cdr lis)))
- (set-cdr! prev lis))))))
- (scan-in ans (cdr ans))
- ans)))))
-
-
-
-;;; Answers share common tail with LIS where possible;
-;;; the technique is slightly subtle.
-
-(define (partition pred lis)
- (srfi-1:check-arg procedure? pred partition)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
- (let ((elt (car lis))
- (tail (cdr lis)))
- (receive (in out) (recur tail)
- (if (pred elt)
- (values (if (pair? out) (cons elt in) lis) out)
- (values in (if (pair? in) (cons elt out) lis))))))))
-
-
-
-;(define (partition! pred lis) ; Things are much simpler
-; (let recur ((lis lis)) ; if you are willing to
-; (if (null-list? lis) (values lis lis) ; push N stack frames & do N
-; (let ((elt (car lis))) ; SET-CDR! writes, where N is
-; (receive (in out) (recur (cdr lis)) ; the length of LIS.
-; (cond ((pred elt)
-; (set-cdr! lis in)
-; (values lis out))
-; (else (set-cdr! lis out)
-; (values in lis))))))))
-
-
-;;; This implementation of PARTITION!
-;;; - doesn't cons, and uses no stack;
-;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
-;;; usually expensive on modern machines, and can be extremely expensive on
-;;; modern Schemes (e.g., ones that have generational GC's).
-;;; It just zips down contiguous runs of in and out elts in LIS doing the
-;;; minimal number of SET-CDR!s to splice these runs together into the result
-;;; lists.
-
-(define (partition! pred lis)
- (srfi-1:check-arg procedure? pred partition!)
- (if (null-list? lis) (values lis lis)
-
- ;; This pair of loops zips down contiguous in & out runs of the
- ;; list, splicing the runs together. The invariants are
- ;; SCAN-IN: (cdr in-prev) = LIS.
- ;; SCAN-OUT: (cdr out-prev) = LIS.
- (letrec ((scan-in (lambda (in-prev out-prev lis)
- (let lp ((in-prev in-prev) (lis lis))
- (if (pair? lis)
- (if (pred (car lis))
- (lp lis (cdr lis))
- (begin (set-cdr! out-prev lis)
- (scan-out in-prev lis (cdr lis))))
- (set-cdr! out-prev lis))))) ; Done.
-
- (scan-out (lambda (in-prev out-prev lis)
- (let lp ((out-prev out-prev) (lis lis))
- (if (pair? lis)
- (if (pred (car lis))
- (begin (set-cdr! in-prev lis)
- (scan-in lis out-prev (cdr lis)))
- (lp lis (cdr lis)))
- (set-cdr! in-prev lis)))))) ; Done.
-
- ;; Crank up the scan&splice loops.
- (if (pred (car lis))
- ;; LIS begins in-list. Search for out-list's first pair.
- (let lp ((prev-l lis) (l (cdr lis)))
- (cond ((not (pair? l)) (values lis l))
- ((pred (car l)) (lp l (cdr l)))
- (else (scan-out prev-l l (cdr l))
- (values lis l)))) ; Done.
-
- ;; LIS begins out-list. Search for in-list's first pair.
- (let lp ((prev-l lis) (l (cdr lis)))
- (cond ((not (pair? l)) (values l lis))
- ((pred (car l))
- (scan-in l prev-l (cdr l))
- (values l lis)) ; Done.
- (else (lp l (cdr l)))))))))
-
-
-;;; Inline us, please.
-(define (remove pred l) (filter (lambda (x) (not (pred x))) l))
-(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
-
-
-
-;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
-;;; (I don't actually think these are the world's most important
-;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
-;;; are far more general.)
-;;;
-;;; Function Action
-;;; ---------------------------------------------------------------------------
-;;; remove pred lis Delete by general predicate
-;;; delete x lis [=] Delete by element comparison
-;;;
-;;; find pred lis Search by general predicate
-;;; find-tail pred lis Search by general predicate
-;;; member x lis [=] Search by element comparison
-;;;
-;;; assoc key lis [=] Search alist by key comparison
-;;; alist-delete key alist [=] Alist-delete by key comparison
-
-(define (delete x lis . maybe-=)
- (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
- (filter (lambda (y) (not (= x y))) lis)))
-
-(define (delete! x lis . maybe-=)
- (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
- (filter! (lambda (y) (not (= x y))) lis)))
-
-;;; Extended from R4RS to take an optional comparison argument.
-(define (member x lis . maybe-=)
- (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
- (find-tail (lambda (y) (= x y)) lis)))
-
-;;; R4RS, hence we don't bother to define.
-;;; The MEMBER and then FIND-TAIL call should definitely
-;;; be inlined for MEMQ & MEMV.
-;(define (memq x lis) (member x lis eq?))
-;(define (memv x lis) (member x lis eqv?))
-
-
-;;; right-duplicate deletion
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; delete-duplicates delete-duplicates!
-;;;
-;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
-;;; in long lists, sort the list to bring duplicates together, then use a
-;;; linear-time algorithm to kill the dups. Or use an algorithm based on
-;;; element-marking. The former gives you O(n lg n), the latter is linear.
-
-(define (delete-duplicates lis . maybe-=)
- (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?)))
- (srfi-1:check-arg procedure? elt= delete-duplicates)
- (let recur ((lis lis))
- (if (null-list? lis) lis
- (let* ((x (car lis))
- (tail (cdr lis))
- (new-tail (recur (delete x tail elt=))))
- (if (eq? tail new-tail) lis (cons x new-tail)))))))
-
-(define (delete-duplicates! lis maybe-=)
- (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?)))
- (srfi-1:check-arg procedure? elt= delete-duplicates!)
- (let recur ((lis lis))
- (if (null-list? lis) lis
- (let* ((x (car lis))
- (tail (cdr lis))
- (new-tail (recur (delete! x tail elt=))))
- (if (eq? tail new-tail) lis (cons x new-tail)))))))
-
-
-;;; alist stuff
-;;;;;;;;;;;;;;;
-
-;;; Extended from R4RS to take an optional comparison argument.
-(define (assoc x lis . maybe-=)
- (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
- (find (lambda (entry) (= x (car entry))) lis)))
-
-(define (alist-cons key datum alist) (cons (cons key datum) alist))
-
-(define (alist-copy alist)
- (map (lambda (elt) (cons (car elt) (cdr elt)))
- alist))
-
-(define (alist-delete key alist . maybe-=)
- (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
- (filter (lambda (elt) (not (= key (car elt)))) alist)))
-
-(define (alist-delete! key alist . maybe-=)
- (let ((= (if (pair? maybe-=) (car maybe-=) equal?)))
- (filter! (lambda (elt) (not (= key (car elt)))) alist)))
-
-
-;;; find find-tail take-while drop-while span break any every list-index-pred
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (find pred list)
- (cond ((find-tail pred list) => car)
- (else #f)))
-
-(define (find-tail pred list)
- (srfi-1:check-arg procedure? pred find-tail)
- (let lp ((list list))
- (and (not (null-list? list))
- (if (pred (car list)) list
- (lp (cdr list))))))
-
-(define (take-while pred lis)
- (srfi-1:check-arg procedure? pred take-while)
- (let recur ((lis lis))
- (if (null-list? lis) '()
- (let ((x (car lis)))
- (if (pred x)
- (cons x (recur (cdr lis)))
- '())))))
-
-(define (drop-while pred lis)
- (srfi-1:check-arg procedure? pred drop-while)
- (let lp ((lis lis))
- (if (null-list? lis) '()
- (if (pred (car lis))
- (lp (cdr lis))
- lis))))
-
-(define (take-while! pred lis)
- (srfi-1:check-arg procedure? pred take-while!)
- (if (or (null-list? lis) (not (pred (car lis)))) '()
- (begin (let lp ((prev lis) (rest (cdr lis)))
- (if (pair? rest)
- (let ((x (car rest)))
- (if (pred x) (lp rest (cdr rest))
- (set-cdr! prev '())))))
- lis)))
-
-(define (span pred lis)
- (srfi-1:check-arg procedure? pred span)
- (let recur ((lis lis))
- (if (null-list? lis) (values '() '())
- (let ((x (car lis)))
- (if (pred x)
- (receive (prefix suffix) (recur (cdr lis))
- (values (cons x prefix) suffix))
- (values '() lis))))))
-
-(define (span! pred lis)
- (srfi-1:check-arg procedure? pred span!)
- (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
- (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
- (if (null-list? rest) rest
- (let ((x (car rest)))
- (if (pred x) (lp rest (cdr rest))
- (begin (set-cdr! prev '())
- rest)))))))
- (values lis suffix))))
-
-
-(define (break pred lis) (span (lambda (x) (not (pred x))) lis))
-(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
-
-(define (any pred lis1 . lists)
- (srfi-1:check-arg procedure? pred any)
- (if (pair? lists)
-
- ;; N-ary case
- (receive (heads tails) (%cars+cdrs (cons lis1 lists))
- (and (pair? heads)
- (let lp ((heads heads) (tails tails))
- (receive (next-heads next-tails) (%cars+cdrs tails)
- (if (pair? next-heads)
- (or (apply pred heads) (lp next-heads next-tails))
- (apply pred heads)))))) ; Last PRED app is tail call.
-
- ;; Fast path
- (and (not (null-list? lis1))
- (let lp ((head (car lis1)) (tail (cdr lis1)))
- (if (null-list? tail)
- (pred head) ; Last PRED app is tail call.
- (or (pred head) (lp (car tail) (cdr tail))))))))
-
-
-;(define (every pred list) ; Simple definition.
-; (let lp ((list list)) ; Doesn't return the last PRED value.
-; (or (not (pair? list))
-; (and (pred (car list))
-; (lp (cdr list))))))
-
-(define (every pred lis1 . lists)
- (srfi-1:check-arg procedure? pred every)
- (if (pair? lists)
-
- ;; N-ary case
- (receive (heads tails) (%cars+cdrs (cons lis1 lists))
- (or (not (pair? heads))
- (let lp ((heads heads) (tails tails))
- (receive (next-heads next-tails) (%cars+cdrs tails)
- (if (pair? next-heads)
- (and (apply pred heads) (lp next-heads next-tails))
- (apply pred heads)))))) ; Last PRED app is tail call.
-
- ;; Fast path
- (or (null-list? lis1)
- (let lp ((head (car lis1)) (tail (cdr lis1)))
- (if (null-list? tail)
- (pred head) ; Last PRED app is tail call.
- (and (pred head) (lp (car tail) (cdr tail))))))))
-
-(define (list-index-pred pred lis1 . lists)
- (srfi-1:check-arg procedure? pred list-index-pred)
- (if (pair? lists)
-
- ;; N-ary case
- (let lp ((lists (cons lis1 lists)) (n 0))
- (receive (heads tails) (%cars+cdrs lists)
- (and (pair? heads)
- (if (apply pred heads) n
- (lp tails (+ n 1))))))
-
- ;; Fast path
- (let lp ((lis lis1) (n 0))
- (and (not (null-list? lis))
- (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
-
-;;; Reverse
-;;;;;;;;;;;
-
-;R4RS, so not defined here.
-;(define (reverse lis) (fold cons '() lis))
-
-;(define (reverse! lis)
-; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
-
-(define (reverse! lis)
- (let lp ((lis lis) (ans '()))
- (if (null-list? lis) ans
- (let ((tail (cdr lis)))
- (set-cdr! lis ans)
- (lp tail lis)))))
-
-;;; Lists-as-sets
-;;;;;;;;;;;;;;;;;
-
-;;; This is carefully tuned code; do not modify casually.
-;;; - It is careful to share storage when possible;
-;;; - Side-effecting code tries not to perform redundant writes.
-;;; - It tries to avoid linear-time scans in special cases where constant-time
-;;; computations can be performed.
-;;; - It relies on similar properties from the other list-lib procs it calls.
-;;; For example, it uses the fact that the implementations of MEMBER and
-;;; FILTER in this source code share longest common tails between args
-;;; and results to get structure sharing in the lset procedures.
-
-(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
-
-(define (lset<= = . lists)
- (srfi-1:check-arg procedure? = lset<=)
- (or (not (pair? lists)) ; 0-ary case
- (let lp ((s1 (car lists)) (rest (cdr lists)))
- (or (not (pair? rest))
- (let ((s2 (car rest)) (rest (cdr rest)))
- (and (or (eq? s2 s1) ; Fast path
- (%lset2<= = s1 s2)) ; Real test
- (lp s2 rest)))))))
-
-(define (lset= = . lists)
- (srfi-1:check-arg procedure? = lset=)
- (or (not (pair? lists)) ; 0-ary case
- (let lp ((s1 (car lists)) (rest (cdr lists)))
- (or (not (pair? rest))
- (let ((s2 (car rest))
- (rest (cdr rest)))
- (and (or (eq? s1 s2) ; Fast path
- (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
- (lp s2 rest)))))))
-
-
-(define (lset-adjoin = lis . elts)
- (srfi-1:check-arg procedure? = lset-adjoin)
- (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
- lis elts))
-
-
-(define (lset-union = . lists)
- (srfi-1:check-arg procedure? = lset-union)
- (reduce (lambda (lis ans) ; Compute ANS + LIS.
- (cond ((null? lis) ans) ; Don't copy any lists
- ((null? ans) lis) ; if we don't have to.
- ((eq? lis ans) ans)
- (else
- (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
- ans
- (cons elt ans)))
- ans lis))))
- '() lists))
-
-(define (lset-union! = . lists)
- (srfi-1:check-arg procedure? = lset-union!)
- (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS.
- (cond ((null? lis) ans) ; Don't copy any lists
- ((null? ans) lis) ; if we don't have to.
- ((eq? lis ans) ans)
- (else
- (pair-fold (lambda (pair ans)
- (let ((elt (car pair)))
- (if (any (lambda (x) (= x elt)) ans)
- ans
- (begin (set-cdr! pair ans) pair))))
- ans lis))))
- '() lists))
-
-
-(define (lset-intersection = lis1 . lists)
- (srfi-1:check-arg procedure? = lset-intersection)
- (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
- (cond ((any null-list? lists) '()) ; Short cut
- ((null? lists) lis1) ; Short cut
- (else (filter (lambda (x)
- (every (lambda (lis) (member x lis =)) lists))
- lis1)))))
-
-(define (lset-intersection! = lis1 . lists)
- (srfi-1:check-arg procedure? = lset-intersection!)
- (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
- (cond ((any null-list? lists) '()) ; Short cut
- ((null? lists) lis1) ; Short cut
- (else (filter! (lambda (x)
- (every (lambda (lis) (member x lis =)) lists))
- lis1)))))
-
-
-(define (lset-difference = lis1 . lists)
- (srfi-1:check-arg procedure? = lset-difference)
- (let ((lists (filter pair? lists))) ; Throw out empty lists.
- (cond ((null? lists) lis1) ; Short cut
- ((memq lis1 lists) '()) ; Short cut
- (else (filter (lambda (x)
- (every (lambda (lis) (not (member x lis =)))
- lists))
- lis1)))))
-
-(define (lset-difference! = lis1 . lists)
- (srfi-1:check-arg procedure? = lset-difference!)
- (let ((lists (filter pair? lists))) ; Throw out empty lists.
- (cond ((null? lists) lis1) ; Short cut
- ((memq lis1 lists) '()) ; Short cut
- (else (filter! (lambda (x)
- (every (lambda (lis) (not (member x lis =)))
- lists))
- lis1)))))
-
-
-(define (lset-xor = . lists)
- (srfi-1:check-arg procedure? = lset-xor)
- (reduce (lambda (b a) ; Compute A xor B:
- ;; Note that this code relies on the constant-time
- ;; short-cuts provided by LSET-DIFF+INTERSECTION,
- ;; LSET-DIFFERENCE & APPEND to provide constant-time short
- ;; cuts for the cases A = (), B = (), and A eq? B. It takes
- ;; a careful case analysis to see it, but it's carefully
- ;; built in.
-
- ;; Compute a-b and a^b, then compute b-(a^b) and
- ;; cons it onto the front of a-b.
- (receive (a-b a-int-b) (lset-diff+intersection = a b)
- (cond ((null? a-b) (lset-difference b a =))
- ((null? a-int-b) (append b a))
- (else (fold (lambda (xb ans)
- (if (member xb a-int-b =) ans (cons xb ans)))
- a-b
- b)))))
- '() lists))
-
-
-(define (lset-xor! = . lists)
- (srfi-1:check-arg procedure? = lset-xor!)
- (reduce (lambda (b a) ; Compute A xor B:
- ;; Note that this code relies on the constant-time
- ;; short-cuts provided by LSET-DIFF+INTERSECTION,
- ;; LSET-DIFFERENCE & APPEND to provide constant-time short
- ;; cuts for the cases A = (), B = (), and A eq? B. It takes
- ;; a careful case analysis to see it, but it's carefully
- ;; built in.
-
- ;; Compute a-b and a^b, then compute b-(a^b) and
- ;; cons it onto the front of a-b.
- (receive (a-b a-int-b) (lset-diff+intersection! = a b)
- (cond ((null? a-b) (lset-difference! b a =))
- ((null? a-int-b) (append! b a))
- (else (pair-fold (lambda (b-pair ans)
- (if (member (car b-pair) a-int-b =) ans
- (begin (set-cdr! b-pair ans) b-pair)))
- a-b
- b)))))
- '() lists))
-
-
-(define (lset-diff+intersection = lis1 . lists)
- (srfi-1:check-arg procedure? = lset-diff+intersection)
- (cond ((every null-list? lists) (values lis1 '())) ; Short cut
- ((memq lis1 lists) (values '() lis1)) ; Short cut
- (else (partition (lambda (elt)
- (not (any (lambda (lis) (member elt lis =))
- lists)))
- lis1))))
-
-(define (lset-diff+intersection! = lis1 . lists)
- (srfi-1:check-arg procedure? = lset-diff+intersection!)
- (cond ((every null-list? lists) (values lis1 '())) ; Short cut
- ((memq lis1 lists) (values '() lis1)) ; Short cut
- (else (partition! (lambda (elt)
- (not (any (lambda (lis) (member elt lis =))
- lists)))
- lis1))))
Index: gnucash/src/scm/srfi/srfi-1.unclear.scm
diff -u gnucash/src/scm/srfi/srfi-1.unclear.scm:1.1 gnucash/src/scm/srfi/srfi-1.unclear.scm:removed
--- gnucash/src/scm/srfi/srfi-1.unclear.scm:1.1 Thu Dec 30 18:05:41 1999
+++ gnucash/src/scm/srfi/srfi-1.unclear.scm Wed May 16 08:02:47 2001
@@ -1,18 +0,0 @@
-
-;;; I'm maintaining the license that Olin put on the SRFI-1 reference
-;;; code.
-;;;
-;;; Copyright 1999, Rob Browning <rlb@cs.utexas.edu>. You may do as
-;;; you please with this code as long as you do not remove this
-;;; copyright notice or hold me liable for its use.
-
-;; This has been modified for GnuCash to use guile's built in error
-;; function.
-
-(define (srfi-1:error msg . args)
- (apply error msg args))
-
-(define (srfi-1:check-arg pred val caller)
- (if (pred val)
- val
- (srfi-1:error "Bad argument" val "to function" caller)))
Index: gnucash/src/scm/srfi/srfi-19.scm
diff -u gnucash/src/scm/srfi/srfi-19.scm:1.4 gnucash/src/scm/srfi/srfi-19.scm:removed
--- gnucash/src/scm/srfi/srfi-19.scm:1.4 Sun Mar 19 04:01:11 2000
+++ gnucash/src/scm/srfi/srfi-19.scm Wed May 16 08:02:47 2001
@@ -1,477 +0,0 @@
-(gnc:support "srfi/srfi-19.scm") ;;; For purposes of GnuCash...
-;;----------------------------------------------------------------------
-;;
-;; Copyright: Copyright (c) 2000 Neodesic Corporation;
-;; All rights reserved.
-;;
-;; File: common-time.scm
-;; Created: January 2000
-;; Author: Will Fitzgerald
-;;
-;; Description: Implementation of Common Time Data Types and Procedures
-;;
-;;
-;; MzScheme specific, and depends on the following procedures:
-;;
-;; current-seconds
-;; seconds->date
-;; the date record and associated accessors
-;; current-process-milliseconds)
-;; current-milliseconds
-;;
-;; The following procedures were useful:
-;;
-;; error
-;; open-output-string
-;; get-output-string
-;;
-;; I attempted to minimize non-public procedures and constants,
-;; but the following remain:
-;;
-;; JDN-1900-01-01
-;; DOW-1900-01-01
-;; normalize-year
-;;
-;; Changes:
-;;
-;;----------------------------------------------------------------------
-
-;; MzScheme specific; we can define this only as a parameter.
-;(define current-time-zone (make-parameter -5))
-(define current-time-zone (lambda () -5))
-
-;; This is based on the algorithm described in
-;; http://www.tondering.dk/claus/calendar.html
-;;
-
-(define (encode-julian-day-number day month year)
- (if (< year 1)
- (error "can only convert Common Era (i.e., AD) dates.")
- (let* ((a (quotient (- 14 month) 12))
- (y (- (+ year 4800) a))
- (m (- (+ month (* 12 a)) 3)))
- (+ day
- (quotient (+ (* 153 m) 2) 5)
- (* 365 y)
- (quotient y 4)
- (- (quotient y 100))
- (quotient y 400)
- (- 32045)))))
-
-(define (decode-julian-day-number jdn)
- (if (< jdn 1721426)
- (error "can only convert Common Era (i.e., AD) dates.")
- (let* ((a (+ jdn 32044))
- (b (quotient (+ (* 4 a) 3) 146097))
- (c (- a (quotient (* 146097 b) 4)))
- (d (quotient (+ (* 4 c) 3) 1461))
- (e (- c (quotient (* 1461 d) 4)))
- (m (quotient (+ (* 5 e) 2) 153)))
- (values ; date month year
- (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
- (+ m 3 (* -12 (quotient m 10)))
- (+ (* 100 b) d -4800 (quotient m 10))))))
-
-(define JDN-1900-01-01 (encode-julian-day-number 1 1 1900)) ; non-public
-(define DOW-1900-01-01 6)
-
-;;; Code for MzScheme
-; (define (get-encoded-time)
-; (let ((date (seconds->date (current-seconds))))
-; (values
-; (date-second date)
-; (date-minute date)
-; (date-hour date)
-; (date-day date)
-; (date-month date)
-; (date-year date)
-; (date-week-day date)
-; (date-dst? date)
-; (current-time-zone))))
-;;; (22 33 17 13 3 2000 1 #f)
-
-(define (get-encoded-time) ;;; For Guile
- (let
- ((now (localtime (current-time))))
- (values (tm:sec now)
- (tm:min now)
- (tm:hour now)
- (tm:mday now)
- (tm:mon now)
- (+ 1900 (tm:year now))
- (tm:wday now)
- (> (tm:isdst now) 0)
- (/ (tm:gmtoff now) 3600))))
-
-(define (get-julian-day-number)
- (call-with-values
- get-encoded-time
- (lambda (second minute hour day month year week-day dst? time-zone)
- (encode-julian-day-number day month year))))
-
-;; number of seconds since midnight, January 1, 1900, UTC
-(define (get-universal-time)
- (call-with-values
- get-encoded-time
- (lambda (second minute hour day month year week-day dst? time-zone)
- (let ((jdn-now (encode-julian-day-number day month year)))
- (+ (* (- jdn-now JDN-1900-01-01) 86400)
- (* hour 3600)
- (* minute 60)
- second
- (if dst? -3600 0)
- (* time-zone 3600))))))
-
-(define (encode-universal-time second minute hour date month year . time-zone)
- (if (< year 1900)
- (error "Universal time is not defined for year:" year)
- (call-with-values
- (lambda ()
- (get-encoded-time))
- (lambda (csecond cminute chour cday cmonth
- cyear cweek-day cdst? ctime-zone)
- (let ((dst? (if (pair? time-zone) #f cdst?))
- (time-zone (if (pair? time-zone) (car time-zone) ctime-zone))
- (jdn (encode-julian-day-number date month
- (normalize-year year cyear))))
- (+ (* (- jdn JDN-1900-01-01) 86400)
- (* hour 3600)
- (* minute 60)
- second
- (if dst? -3600 0)
- (* time-zone 3600)))))))
-
-;; handles negative numbers fine--just like MCL!
-(define (decode-universal-time ut-time . time-zone)
- (call-with-values
- (lambda ()
- (get-encoded-time))
- (lambda (csecond cminute chour cday cmonth
- cyear cweek-day cdst? ctime-zone)
- (let
- ((dst? (if (pair? time-zone) #f cdst?))
- (time-zone (if (pair? time-zone) (car time-zone) ctime-zone)))
- (let*
- ((adj-ut-time (+ ut-time (if dst? 3600 0)
- (if time-zone (- (* time-zone 3600)) 0)))
- (jdn (+ (quotient adj-ut-time 86400) JDN-1900-01-01)))
- (call-with-values
- (lambda ()
- (decode-julian-day-number jdn))
- (lambda (day month year)
- (let ((second (modulo adj-ut-time 86400)))
- (let ((hour (quotient second 3600))
- (second (modulo second 3600)))
- (let ((minute (quotient second 60))
- (second (modulo second 60)))
- (values second minute hour day month year
- (modulo (+ jdn DOW-1900-01-01 1) 7) dst?
- time-zone)))))))))))
-
-;;; MzScheme require these:
-;(define internal-time-units-per-second 1000)
-;(define get-internal-run-time current-process-milliseconds)
-;(define get-internal-real-time current-milliseconds)
-
-; Guile has all three values as built-ins (or, at least, equivalents
-; thereof...
-
-(define (output-time-zone time-zone port)
- (if (= time-zone 0)
- (display #\Z port)
- (begin
- (if (< time-zone 0)
- (begin
- (display #\- port)
- (set! time-zone
- (- time-zone)))
- (display #\+ port))
- (let
- ((tdz-raw-minutes (inexact->exact (* time-zone 60))))
- (let
- ((tdz-hours (quotient tdz-raw-minutes 60))
- (tdz-minutes (remainder tdz-raw-minutes 60)))
- (display-2-digits tdz-hours port)
- (display #\: port)
- (display-2-digits tdz-minutes port))))))
-
-(define (display-2-digits value port)
- (display (quotient value 10) port)
- (display (modulo value 10) port))
-
-(define (display-4-digits value port)
- (display (quotient value 1000) port)
- (display (quotient (modulo value 1000) 100) port)
- (display-2-digits (modulo value 100) port))
-
-(define (erriso field index string)
- (let ((msg (string-append "Invalid ISO date string ["
- field "]")))
- (error msg index string)))
-
-(define (erriso2 field something index string)
- (let ((msg (string-append "Invalid ISO date string ["
- field "]")))
- (error msg something index string)))
-
-(define (char-to-digit ch i)
- (cond
- ((char=? ch #\0) 0)
- ((char=? ch #\1) 1)
- ((char=? ch #\2) 2)
- ((char=? ch #\3) 3)
- ((char=? ch #\4) 4)
- ((char=? ch #\5) 5)
- ((char=? ch #\6) 6)
- ((char=? ch #\7) 7)
- ((char=? ch #\8) 8)
- ((char=? ch #\9) 9)
- (else (error "Non-integer character" ch i))))
-
-;; non-public procedure
-(define (normalize-year year nowyear)
- (if (< year 100)
- (if (< year 50)
- (+ nowyear year)
- (+ (- nowyear 100) year))
- year))
-
-(define (universal-time->string universal-time . time-zone)
- (call-with-values
- (lambda ()
- (apply decode-universal-time universal-time time-zone))
- (lambda (second minute hour day month year day-of-week dst? time-zone)
- (let
- ((str
- (call-with-output-string
- (lambda (str)
- (display-4-digits year str)
- (display #\- str)
- (display-2-digits month str)
- (display #\- str)
- (display-2-digits day str)
- (display #\T str)
- (display-2-digits hour str)
- (display #\: str)
- (display-2-digits minute str)
- (display #\: str)
- (display-2-digits second str)
- (output-time-zone time-zone str)))))
- (display str)
- (newline)
- str))))
-
-(define (universal-time->date-string universal-time . time-zone)
- (call-with-values
- (lambda ()
- (apply decode-universal-time universal-time time-zone))
- (lambda (second minute hour day month year day-of-week dst? time-zone)
- (let ((str (open-output-string)))
- (display-4-digits year str)
- ;;
- (display #\- str)
- (display-2-digits month str)
- (display #\- str)
- (display-2-digits day str)
- (get-output-string str)))))
-
-(define (universal-time->time-string universal-time . time-zone)
- (call-with-values
- (lambda ()
- (apply decode-universal-time universal-time time-zone))
- (lambda (second minute hour day month year day-of-week dst? time-zone)
- (let ((str (open-output-string)))
- (display-2-digits hour str)
- (display #\: str)
- (display-2-digits minute str)
- (display #\: str)
- (display-2-digits second str)
- (get-output-string str)))))
-
-
-(define (string->universal-time string)
- (let ((cstring (string-copy string)))
- ;; remove non-numerics
- (do ((index 0 (+ index 1)))
- ((>= index (string-length cstring)))
- (let ((ch (string-ref cstring index)))
- (if (not (or (char-numeric? ch)
- (char=? ch #\.)))
- (string-set! cstring index #\Space))))
- (let ((nums (read-from-string-all cstring)))
- (let ((second (sixth nums))
- (minute (fifth nums))
- (hour (fourth nums))
- (date (third nums))
- (month (second nums))
- (year (first nums))
- (time-zone (seventh nums)))
- (encode-universal-time second minute hour date
- month year time-zone)))))
-
-(define (string->universal-time string)
- (let ((index 0)
- (len (string-length string))
- (char->int
- (lambda (i)
- (let ((ch (string-ref string i)))
- (char-to-digit ch i)))))
- (let
- ((accumulate-int
- (lambda ()
- (if (or (>= index len)
- (not (char-numeric? (string-ref string index))))
- #f
- (do ((acc (char->int index) (+ (* acc 10) (char->int index))))
- ((or (>= (+ index 1) len)
- (not (char-numeric? (string-ref string (+ index 1)))))
- (begin (set! index (+ index 1))
- acc))
- (set! index (+ index 1))))))
- (accumulate-frac
- (lambda ()
- (if (or (>= index len)
- (not (char-numeric? (string-ref string index))))
- #f
- (do ((acc (/ (char->int index) 10)
- (+ acc (/ (char->int index) dix)))
- (dix 100 (* dix 10)))
- ((or (>= (+ index 1) len)
- (not (char-numeric?
- (string-ref string (+ index 1)))))
- (begin
- (set! index (+ index 1))
- acc))
- (set! index (+ index 1)))))))
- (call-with-values
- get-encoded-time
- (lambda (csecond cminute chour cday cmonth cyear
- cweek-day cdst? ctime-zone)
- (let ((second #f) (minute #f) (hour #f) (day #f)
- (month #f) (year #f) (tzhour #f) (tzminute #f))
- (set! year (accumulate-int))
- (if (eq? year #f)
- (erriso "year" index string))
- (set! year (normalize-year year cyear))
- (set! index (+ index 1))
- (set! month (accumulate-int))
- (if (eq? month #f)
- (erriso "month" index string))
- (set! index (+ index 1))
- (set! day (accumulate-int))
- (if (eq? day #f)
- (erriso "day" index string))
- (set! index (+ index 1))
- (set! hour (accumulate-int))
- (if (eq? hour #f)
- (erriso "hour" index string))
- (set! index (+ index 1))
- (set! minute (accumulate-int))
- (if (eq? minute #f)
- (erriso "minute" index string))
- (set! index (+ index 1))
- (set! second (accumulate-int))
- (if (eq? second #f)
- (erriso "second" index string)
- ;; if fractional seconds, we round.
- (if (and (< index (string-length string))
- (char=? (string-ref string index)
- #\.))
- (let ((frac #f))
- (set! index (+ index 1))
- (set! frac (accumulate-frac))
- (if (eq? frac #f)
- (erriso "fractional second" index string)
- (if (>= frac 1/2)
- (set! second (+ second 1))))))
- ;; now, check for time zone
- (if (and (< index len)
- (or (char=? (string-ref string index) #\Z)
- (char=? (string-ref string index) #\z)))
- (encode-universal-time second minute hour day month year 0)
- (if (>= index len)
- (encode-universal-time second minute hour day month year)
- ;; we have a time zone
- (let ((pm-char (string-ref string index)))
- (set! index (+ index 1)) ; skip over +/-
- (set! tzhour (accumulate-int))
- (if (and (eq? tzhour #f) (= index len)) ; must be the end
- (encode-universal-time second minute hour day month year)
- (if (eq? tzhour #f)
- (erriso "time zone hour" index string)
- (begin
- (set! index (+ index 1))
- (set! tzminute (accumulate-int))
- (if (eq? tzminute #f)
- (erriso "time zone minute" index string))
- (if (char=? pm-char #\-)
- (encode-universal-time
- second minute
- hour day month
- year (- (+ tzhour
- (/ tzminute 60))))
- (if (char=? pm-char #\+)
- (encode-universal-time
- second minute hour day month year
- (+ tzhour (/ tzminute 60)))
- (erriso2 "time zone +/-"
- pm-char index
- string))))))))))))))))
-
-
-(define (julian-day-number->string jdn)
- (call-with-values
- (lambda ()
- (decode-julian-day-number jdn))
- (lambda (day month year)
- (let ((str (open-output-string)))
- (display-4-digits year str)
- (display #\- str)
- (display-2-digits month str)
- (display #\- str)
- (display-2-digits day str)
- (get-output-string str)))))
-
-(define (string->julian-day-number string)
- (let
- ((accumulate-integer
- (lambda (string index)
- (if (or (>= index (string-length string))
- (not (char-numeric? (string-ref string index))))
- (values #f index)
- (let ((char->int
- (lambda (i)
- (let ((ch (string-ref string i)))
- (char-to-digit ch i)))))
- (do ((acc (char->int index) (+ (* acc 10) (char->int i)))
- (i (+ index 1) (+ i 1)))
- ((or (>= i (string-length string))
- (not (char-numeric? (string-ref string i))))
- (values acc i))))))))
- (call-with-values
- get-encoded-time
- (lambda (csecond cminute chour cday cmonth cyear
- cweek-day cdst? ctime-zone)
- (let* ((index 0))
- (call-with-values
- (lambda ()
- (accumulate-integer string index))
- (lambda (year index)
- (if (eq? year #f)
- (erriso "year" index string)
- (let ((year (normalize-year year cyear)))
- (call-with-values
- (lambda ()
- (accumulate-integer string (+ index 1)))
- (lambda (month index)
- (if (eq? month #f)
- (erriso "month" index string)
- (call-with-values
- (lambda ()
- (accumulate-integer string (+ index 1)))
- (lambda (day index)
- (if (eq? day #f)
- (erriso "day" index string)
- (encode-julian-day-number
- day month year))))))))))))))))
-
Index: gnucash/src/scm/srfi/srfi-8.guile.scm
diff -u gnucash/src/scm/srfi/srfi-8.guile.scm:1.2 gnucash/src/scm/srfi/srfi-8.guile.scm:removed
--- gnucash/src/scm/srfi/srfi-8.guile.scm:1.2 Sat Mar 18 11:53:23 2000
+++ gnucash/src/scm/srfi/srfi-8.guile.scm Wed May 16 08:02:47 2001
@@ -1,16 +0,0 @@
-;;; I'm maintaining the license that Olin put on the SRFI-1 reference
-;;; code.
-;;;
-;;; Copyright 1999, Rob Browning <rlb@cs.utexas.edu>. You may do as
-;;; you please with this code as long as you do not remove this
-;;; copyright notice or hold me liable for its use.
-
-(use-modules (ice-9 slib))
-(require 'macro-by-example)
-(require 'values)
-
-(define-syntax receive
- (syntax-rules ()
- ((receive formals expression body ...)
- (call-with-values (lambda () expression)
- (lambda formals body ...)))))
Index: gnucash/src/scm/srfi/srfi-8.scm
diff -u gnucash/src/scm/srfi/srfi-8.scm:1.1 gnucash/src/scm/srfi/srfi-8.scm:removed
--- gnucash/src/scm/srfi/srfi-8.scm:1.1 Fri Jun 2 04:00:30 2000
+++ gnucash/src/scm/srfi/srfi-8.scm Wed May 16 08:02:47 2001
@@ -1,8 +0,0 @@
-;;; I'm maintaining the license that Olin put on the SRFI-1 reference
-;;; code.
-;;;
-;;; Copyright 1999, Rob Browning <rlb@cs.utexas.edu>. You may do as
-;;; you please with this code as long as you do not remove this
-;;; copyright notice or hold me liable for its use.
-
-(load "srfi-8.guile.scm")
Index: gnucash/src/test/gnc-test-stuff.c
diff -u gnucash/src/test/gnc-test-stuff.c:1.7 gnucash/src/test/gnc-test-stuff.c:1.8
--- gnucash/src/test/gnc-test-stuff.c:1.7 Wed Apr 25 03:11:48 2001
+++ gnucash/src/test/gnc-test-stuff.c Tue May 15 10:53:14 2001
@@ -16,6 +16,7 @@
#include "sixtp-parsers.h"
#include "test-stuff.h"
#include "io-gncxml-gen.h"
+#include "sixtp-utils.h"
/***********************************************************************/
@@ -612,6 +613,27 @@
g_free(cmp1);
return FALSE;
}
+}
+
+gboolean
+equals_node_val_vs_int(xmlNodePtr node, gint64 val)
+{
+ gchar *text;
+ gint64 test_val;
+
+ g_return_val_if_fail(node, FALSE);
+
+ text = dom_tree_to_text(node);
+
+ if(!string_to_gint64(text, &test_val))
+ {
+ g_free(text);
+ return FALSE;
+ }
+
+ g_free(text);
+
+ return val == test_val;
}
gboolean
Index: gnucash/src/test/gnc-test-stuff.h
diff -u gnucash/src/test/gnc-test-stuff.h:1.6 gnucash/src/test/gnc-test-stuff.h:1.7
--- gnucash/src/test/gnc-test-stuff.h:1.6 Thu Apr 5 16:37:56 2001
+++ gnucash/src/test/gnc-test-stuff.h Tue May 15 10:53:14 2001
@@ -74,6 +74,7 @@
const gnc_commodity *com);
gboolean equals_node_val_vs_kvp_frame(xmlNodePtr node, const kvp_frame *frm);
gboolean equals_node_val_vs_date(xmlNodePtr node, const Timespec tm);
+gboolean equals_node_val_vs_int(xmlNodePtr node, gint64 val);
void
test_files_in_dir(int argc, char **argv, gxpf_callback cb,
Index: gnucash/src/test/test-xml-account.c
diff -u gnucash/src/test/test-xml-account.c:1.14 gnucash/src/test/test-xml-account.c:1.15
--- gnucash/src/test/test-xml-account.c:1.14 Wed Apr 18 06:11:06 2001
+++ gnucash/src/test/test-xml-account.c Tue May 15 10:53:14 2001
@@ -27,12 +27,12 @@
if(!check_dom_tree_version(node, "2.0.0"))
{
- return "version wrong. Not 2.0.0 or not there";
+ return g_strdup("version wrong. Not 2.0.0 or not there");
}
if(!node->name || safe_strcmp(node->name, "gnc:account"))
{
- return "Name of toplevel node is bad";
+ return g_strdup("Name of toplevel node is bad");
}
for(mark = node->xmlChildrenNode; mark; mark = mark->next)
@@ -41,14 +41,14 @@
{
if(!equals_node_val_vs_string(mark, xaccAccountGetName(act)))
{
- return "names differ";
+ return g_strdup("names differ");
}
}
else if(safe_strcmp(mark->name, "act:id") == 0)
{
if(!equals_node_val_vs_guid(mark, xaccAccountGetGUID(act)))
{
- return "ids differ";
+ return g_strdup("ids differ");
}
}
else if(safe_strcmp(mark->name, "act:type") == 0)
@@ -60,17 +60,17 @@
if(!txt)
{
- return "couldn't get type string";
+ return g_strdup("couldn't get type string");
}
else if(!xaccAccountStringToType(txt, &type))
{
g_free(txt);
- return "couldn't convert type string to int";
+ return g_strdup("couldn't convert type string to int");
}
else if(type != xaccAccountGetType(act))
{
g_free(txt);
- return "types differ";
+ return g_strdup("types differ");
}
else
{
@@ -82,14 +82,14 @@
if(!equals_node_val_vs_commodity(
mark, xaccAccountGetCurrency(act)))
{
- return "currencies differ";
+ return g_strdup("currencies differ");
}
}
else if(safe_strcmp(mark->name, "act:code") == 0)
{
if(!equals_node_val_vs_string(mark, xaccAccountGetCode(act)))
{
- return "codes differ";
+ return g_strdup("codes differ");
}
}
else if(safe_strcmp(mark->name, "act:description") == 0)
@@ -97,7 +97,7 @@
if(!equals_node_val_vs_string(
mark, xaccAccountGetDescription(act)))
{
- return "descriptions differ";
+ return g_strdup("descriptions differ");
}
}
else if(safe_strcmp(mark->name, "act:security") == 0)
@@ -105,14 +105,14 @@
if(!equals_node_val_vs_commodity(
mark, xaccAccountGetSecurity(act)))
{
- return "securities differ";
+ return g_strdup("securities differ");
}
}
else if(safe_strcmp(mark->name, "act:slots") == 0)
{
if(!equals_node_val_vs_kvp_frame(mark, xaccAccountGetSlots(act)))
{
- return "slots differ";
+ return g_strdup("slots differ");
}
}
else if(safe_strcmp(mark->name, "act:parent") == 0)
@@ -121,12 +121,26 @@
mark, xaccAccountGetGUID(xaccGroupGetParentAccount(
xaccAccountGetParent(act)))))
{
- return "parent ids differ";
+ return g_strdup("parent ids differ");
}
}
+ else if(safe_strcmp(mark->name, "act:currency-scu") == 0)
+ {
+ if(!equals_node_val_vs_int(mark, xaccAccountGetCurrencySCU(act)))
+ {
+ return g_strdup("currency scus differ");
+ }
+ }
+ else if(safe_strcmp(mark->name, "act:security-scu") == 0)
+ {
+ if(!equals_node_val_vs_int(mark, xaccAccountGetSecuritySCU(act)))
+ {
+ return g_strdup("security scus differ");
+ }
+ }
else
{
- return "unknown node in dom tree";
+ return g_strdup_printf("unknown node in dom tree: %s", mark->name);
}
}
@@ -188,6 +202,7 @@
xmlElemDump(stdout, NULL, test_node);
fprintf(stdout, "\n");
xmlFreeNode(test_node);
+ g_free(compare_msg);
return;
}
else
@@ -282,7 +297,7 @@
static gboolean
test_real_account(const char *tag, gpointer global_data, gpointer data)
{
- const char *msg;
+ char *msg;
Account *act = (Account*)data;
if(!xaccAccountGetParent(act))
@@ -292,6 +307,7 @@
msg = node_and_account_equal((xmlNodePtr)global_data, act);
do_test_args(msg == NULL, "test_real_account",
__FILE__, __LINE__, msg);
+ g_free(msg);
return TRUE;
}
Index: gnucash/src/test/test-files/xml2/Money95bank_fr.gml2
diff -u gnucash/src/test/test-files/xml2/Money95bank_fr.gml2:1.2 gnucash/src/test/test-files/xml2/Money95bank_fr.gml2:1.3
--- gnucash/src/test/test-files/xml2/Money95bank_fr.gml2:1.2 Thu Mar 29 02:41:20 2001
+++ gnucash/src/test/test-files/xml2/Money95bank_fr.gml2 Tue May 15 10:58:10 2001
@@ -1,6 +1,5 @@
<?xml version="1.0"?>
<gnc-v2>
-<gnc:count-data cd:type="commodity">0</gnc:count-data>
<gnc:count-data cd:type="account">52</gnc:count-data>
<gnc:count-data cd:type="transaction">143</gnc:count-data>
<gnc:account version="2.0.0">
@@ -11,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Livret bleu</act:name>
@@ -20,6 +20,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Salaire</act:name>
@@ -29,6 +30,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Primes</act:name>
@@ -38,6 +40,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">547e0f4df1fb2f3a124f09cddd90add4</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -48,6 +51,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">547e0f4df1fb2f3a124f09cddd90add4</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -58,6 +62,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Epicerie</act:name>
@@ -67,6 +72,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">fb45010dd73162faf7870d23451773e7</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -77,6 +83,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">fb45010dd73162faf7870d23451773e7</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -87,6 +94,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Automobile</act:name>
@@ -96,6 +104,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">24e0d1cb0af579d19129ec79f16f9205</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -106,6 +115,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">24e0d1cb0af579d19129ec79f16f9205</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -116,6 +126,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Crédit auto</act:name>
@@ -125,6 +136,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">343f5c0ccf4c7a3d54443ece59073d4c</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -135,6 +147,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">343f5c0ccf4c7a3d54443ece59073d4c</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -145,6 +158,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Divers</act:name>
@@ -154,6 +168,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Fournitures diverses</act:name>
@@ -163,6 +178,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">d9f9dda3d1a61bd15b3b4c67b40c2769</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -173,6 +189,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Frais de transport</act:name>
@@ -182,6 +199,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">3af7ef0f555aa2a41d75d034c6afd436</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -192,6 +210,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Personnels</act:name>
@@ -201,6 +220,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">011ba398b7c38291d50cd10de44d4710</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -211,6 +231,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Autres frais</act:name>
@@ -220,6 +241,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">e6501ba2005ac400866b117379443af3</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -230,6 +252,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Impôts</act:name>
@@ -239,6 +262,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Impôts sur le revenu</act:name>
@@ -248,6 +272,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">0a5c854c367926d4ce7ffaa60f99a85a</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -258,6 +283,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Loyer</act:name>
@@ -267,6 +293,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">436e114c09ccaa489be81be1a24f1656</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -277,6 +304,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Canal Plus-Câble</act:name>
@@ -286,6 +314,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">ae47cf420aa54ba58fb1906b4edba98f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -296,6 +325,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">ae47cf420aa54ba58fb1906b4edba98f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -306,6 +336,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">ae47cf420aa54ba58fb1906b4edba98f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -316,6 +347,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">ae47cf420aa54ba58fb1906b4edba98f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -326,6 +358,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">ae47cf420aa54ba58fb1906b4edba98f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -336,6 +369,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">ae47cf420aa54ba58fb1906b4edba98f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -346,6 +380,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Chauffage</act:name>
@@ -355,6 +390,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">a648b21f385e784fbe2b26cb3f718a79</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -365,6 +401,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">a648b21f385e784fbe2b26cb3f718a79</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -375,6 +412,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">a648b21f385e784fbe2b26cb3f718a79</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -385,6 +423,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Cuisine-Salle de bains</act:name>
@@ -394,6 +433,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">8f5104499ca8138b3c48f5c900d7b285</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -404,6 +444,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">8f5104499ca8138b3c48f5c900d7b285</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -414,6 +455,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">8f5104499ca8138b3c48f5c900d7b285</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -424,6 +466,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Dentiste</act:name>
@@ -433,6 +476,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">1c3053f62d72017f9faacec828e3b874</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -443,6 +487,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">1c3053f62d72017f9faacec828e3b874</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -453,6 +498,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Coiffeur</act:name>
@@ -462,6 +508,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">5d9afede4f8d14de29b0f64ebd23a649</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -472,6 +519,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Devises</act:name>
@@ -481,6 +529,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">37563222f8bfa2ef6edb653a3b492d0b</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -491,6 +540,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">37563222f8bfa2ef6edb653a3b492d0b</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -501,6 +551,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">9643f159a0522e203df526c2125ccdd4</trn:id>
Index: gnucash/src/test/test-files/xml2/Money95invst.gml2
diff -u gnucash/src/test/test-files/xml2/Money95invst.gml2:1.1 gnucash/src/test/test-files/xml2/Money95invst.gml2:1.2
--- gnucash/src/test/test-files/xml2/Money95invst.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/Money95invst.gml2 Tue May 15 10:58:10 2001
@@ -1,6 +1,5 @@
<?xml version="1.0"?>
<gnc-v2>
-<gnc:count-data cd:type="commodity">0</gnc:count-data>
<gnc:count-data cd:type="account">3</gnc:count-data>
<gnc:count-data cd:type="transaction">10</gnc:count-data>
<gnc:account version="2.0.0">
@@ -11,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Livret bleu</act:name>
@@ -20,6 +20,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Retained Earnings</act:name>
@@ -29,6 +30,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">ad7c592d0603871110acb8f2c7bcd215</trn:id>
Index: gnucash/src/test/test-files/xml2/Money95mutual.gml2
diff -u gnucash/src/test/test-files/xml2/Money95mutual.gml2:1.1 gnucash/src/test/test-files/xml2/Money95mutual.gml2:1.2
--- gnucash/src/test/test-files/xml2/Money95mutual.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/Money95mutual.gml2 Tue May 15 10:58:10 2001
@@ -17,6 +17,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>FRF</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Money95mfunds fr</act:name>
@@ -26,6 +27,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>FRF</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>O-Sicav Plus</act:name>
@@ -35,10 +37,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>FRF</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>O-Sicav Plus</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">89e091b3489a50957b400a868f101d59</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -49,6 +53,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>FRF</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Money95mfunds fr</act:name>
@@ -58,6 +63,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>FRF</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">41b9e953585cd5662712d62848e71789</act:parent>
</gnc:account>
<gnc:transaction version="2.0.0">
Index: gnucash/src/test/test-files/xml2/Money95stocks.gml2
diff -u gnucash/src/test/test-files/xml2/Money95stocks.gml2:1.1 gnucash/src/test/test-files/xml2/Money95stocks.gml2:1.2
--- gnucash/src/test/test-files/xml2/Money95stocks.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/Money95stocks.gml2 Tue May 15 10:58:10 2001
@@ -23,6 +23,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Money95stocks fr</act:name>
@@ -32,6 +33,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Microsoft</act:name>
@@ -41,10 +43,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>MSFT</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">2a42eb5710ad4ddbf9352f070d603fe2</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -55,10 +59,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>USSA</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">2a42eb5710ad4ddbf9352f070d603fe2</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -69,6 +75,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Commissions</act:name>
@@ -78,6 +85,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Money95stocks fr</act:name>
@@ -87,6 +95,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">5efcfb966ef97810de2fbaaa2b352205</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -97,6 +106,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>BRL</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">67da2dc62331fb318640aa5a1a3da937</trn:id>
Index: gnucash/src/test/test-files/xml2/abc.gml2
diff -u gnucash/src/test/test-files/xml2/abc.gml2:1.1 gnucash/src/test/test-files/xml2/abc.gml2:1.2
--- gnucash/src/test/test-files/xml2/abc.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/abc.gml2 Tue May 15 10:58:11 2001
@@ -1,6 +1,5 @@
<?xml version="1.0"?>
<gnc-v2>
-<gnc:count-data cd:type="commodity">0</gnc:count-data>
<gnc:count-data cd:type="account">4</gnc:count-data>
<gnc:count-data cd:type="transaction">7</gnc:count-data>
<gnc:account version="2.0.0">
@@ -11,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>EUR</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>My Investment Account</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -21,6 +21,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>EUR</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Gift Received</act:name>
@@ -30,6 +31,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>EUR</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Gift Received</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -40,6 +42,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>EUR</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Other Income</act:description>
</gnc:account>
<gnc:transaction version="2.0.0">
Index: gnucash/src/test/test-files/xml2/abcall.gml2
diff -u gnucash/src/test/test-files/xml2/abcall.gml2:1.1 gnucash/src/test/test-files/xml2/abcall.gml2:1.2
--- gnucash/src/test/test-files/xml2/abcall.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/abcall.gml2 Tue May 15 10:58:11 2001
@@ -1,6 +1,5 @@
<?xml version="1.0"?>
<gnc-v2>
-<gnc:count-data cd:type="commodity">0</gnc:count-data>
<gnc:count-data cd:type="account">7</gnc:count-data>
<gnc:count-data cd:type="transaction">10</gnc:count-data>
<gnc:account version="2.0.0">
@@ -11,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Some Old Bank Acct</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -21,6 +21,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>My Investment Account</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -31,6 +32,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>SlaveCardt</act:name>
@@ -40,6 +42,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>my credit card</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -50,6 +53,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Gift Received</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -60,6 +64,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Investment Income</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -70,6 +75,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Other Income</act:description>
</gnc:account>
<gnc:transaction version="2.0.0">
Index: gnucash/src/test/test-files/xml2/carols-data-file.gml2
diff -u gnucash/src/test/test-files/xml2/carols-data-file.gml2:1.1 gnucash/src/test/test-files/xml2/carols-data-file.gml2:1.2
--- gnucash/src/test/test-files/xml2/carols-data-file.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/carols-data-file.gml2 Tue May 15 10:58:11 2001
@@ -251,6 +251,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -279,6 +280,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -294,6 +296,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -309,6 +312,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -333,6 +337,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -348,6 +353,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -363,6 +369,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -378,6 +385,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -393,6 +401,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -408,6 +417,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -423,6 +433,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -438,6 +449,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -453,6 +465,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -468,6 +481,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -483,6 +497,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -498,6 +513,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -513,6 +529,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -529,6 +546,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
Index: gnucash/src/test/test-files/xml2/cbb-export.gml2
diff -u gnucash/src/test/test-files/xml2/cbb-export.gml2:1.1 gnucash/src/test/test-files/xml2/cbb-export.gml2:1.2
--- gnucash/src/test/test-files/xml2/cbb-export.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/cbb-export.gml2 Tue May 15 10:58:11 2001
@@ -1,6 +1,5 @@
<?xml version="1.0"?>
<gnc-v2>
-<gnc:count-data cd:type="commodity">0</gnc:count-data>
<gnc:count-data cd:type="account">12</gnc:count-data>
<gnc:count-data cd:type="transaction">9</gnc:count-data>
<gnc:account version="2.0.0">
@@ -11,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Gifts</act:name>
@@ -20,6 +20,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Gift Expenses</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -30,6 +31,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Salary</act:name>
@@ -39,6 +41,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Salary Income</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -49,6 +52,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Clothing</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -59,6 +63,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Dining-Out</act:name>
@@ -68,6 +73,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Entertainment</act:name>
@@ -77,6 +83,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Household</act:name>
@@ -86,6 +93,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Household Misc. Exp</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -96,6 +104,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Telephone</act:name>
@@ -105,6 +114,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Telephone Expense</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -115,6 +125,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>HRK</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">9d2c18d552ab4a405bee914ca188eb70</trn:id>
Index: gnucash/src/test/test-files/xml2/conrads-file.gml2
diff -u gnucash/src/test/test-files/xml2/conrads-file.gml2:1.1 gnucash/src/test/test-files/xml2/conrads-file.gml2:1.2
--- gnucash/src/test/test-files/xml2/conrads-file.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/conrads-file.gml2 Tue May 15 10:58:11 2001
@@ -17,6 +17,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>AUD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Assets</act:name>
@@ -26,6 +27,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>AUD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:code>A0000</act:code>
<act:slots>
<slot>
@@ -42,11 +44,13 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>AUD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:code>A0001</act:code>
<act:security>
<cmdty:space>AMEX</cmdty:space>
<cmdty:id>stk</cmdty:id>
</act:security>
+ <act:security-scu>100</act:security-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -63,11 +67,13 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>AUD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:code>A0002</act:code>
<act:security>
<cmdty:space>AMEX</cmdty:space>
<cmdty:id>stk</cmdty:id>
</act:security>
+ <act:security-scu>100</act:security-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -84,6 +90,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>AUD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:code>C0000</act:code>
<act:slots>
<slot>
@@ -100,6 +107,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>AUD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:code>C0001</act:code>
<act:slots>
<slot>
Index: gnucash/src/test/test-files/xml2/every.gml2
diff -u gnucash/src/test/test-files/xml2/every.gml2:1.1 gnucash/src/test/test-files/xml2/every.gml2:1.2
--- gnucash/src/test/test-files/xml2/every.gml2:1.1 Thu Mar 29 02:41:23 2001
+++ gnucash/src/test/test-files/xml2/every.gml2 Tue May 15 10:58:11 2001
@@ -41,6 +41,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:description>Mutual Fund Family</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -51,10 +52,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Cap & Income</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">1b791374ee19ad07b06c3e0a99aeb4fa</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -65,10 +68,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Eq Inc II</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">1b791374ee19ad07b06c3e0a99aeb4fa</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -79,10 +84,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Govt Res</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">1b791374ee19ad07b06c3e0a99aeb4fa</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -93,10 +100,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Growth & Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">1b791374ee19ad07b06c3e0a99aeb4fa</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -107,10 +116,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID NewMkt Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">1b791374ee19ad07b06c3e0a99aeb4fa</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -121,6 +132,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:description>Reconcile Accounts</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -131,6 +143,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Fidelity Inv</act:name>
@@ -140,6 +153,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:parent type="guid">1ade3e58381c463d8a8c2703d134ccea</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -150,10 +164,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Eq Inc II</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">b7eaa97e2760274bd7eb5104a3f6fd84</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -164,10 +180,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Growth & Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">b7eaa97e2760274bd7eb5104a3f6fd84</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -178,6 +196,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Fidelity Inv</act:name>
@@ -187,6 +206,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:parent type="guid">fec86ac037ee8dd3cfe9512f7fced74b</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -197,10 +217,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Eq Inc II</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">57e365b7b895c5a9ef328a69367c49e5</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -211,10 +233,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Growth & Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">57e365b7b895c5a9ef328a69367c49e5</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -225,10 +249,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID NewMkt Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">57e365b7b895c5a9ef328a69367c49e5</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -239,6 +265,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Fidelity Inv</act:name>
@@ -248,6 +275,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:parent type="guid">0406079e56613a22d8112b8dbfbed622</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -258,10 +286,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Cap & Income</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">928026d717b302da3d24fb64f086b18a</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -272,10 +302,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Eq Inc II</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">928026d717b302da3d24fb64f086b18a</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -286,10 +318,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Govt Res</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">928026d717b302da3d24fb64f086b18a</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -300,10 +334,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID Growth & Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">928026d717b302da3d24fb64f086b18a</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -314,10 +350,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>FID NewMkt Inc</cmdty:id>
</act:security>
+ <act:security-scu>100000</act:security-scu>
<act:parent type="guid">928026d717b302da3d24fb64f086b18a</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -328,6 +366,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Commissions</act:name>
@@ -337,6 +376,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Fidelity Inv</act:name>
@@ -346,6 +386,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
<act:parent type="guid">c4ab48d47126697c3ee461627fedbc86</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -356,6 +397,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>IRR</cmdty:id>
</act:currency>
+ <act:currency-scu>1</act:currency-scu>
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">d6e78e4275e257da6c333a9876c3b644</trn:id>
Index: gnucash/src/test/test-files/xml2/goonies-file.gml2
diff -u gnucash/src/test/test-files/xml2/goonies-file.gml2:1.1 gnucash/src/test/test-files/xml2/goonies-file.gml2:1.2
--- gnucash/src/test/test-files/xml2/goonies-file.gml2:1.1 Thu Mar 29 02:41:24 2001
+++ gnucash/src/test/test-files/xml2/goonies-file.gml2 Tue May 15 10:58:12 2001
@@ -15,7 +15,6 @@
<cmdty:name>HN Stock</cmdty:name>
<cmdty:fraction>100</cmdty:fraction>
</gnc:commodity>
-<gnc:pricedb version="1"/>
<gnc:account version="2.0.0">
<act:name>Bank Account</act:name>
<act:id type="guid">117841ae858b1700a017d752b7f02b09</act:id>
@@ -24,6 +23,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -39,10 +39,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>HAL</cmdty:id>
</act:security>
+ <act:security-scu>1</act:security-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -58,10 +60,12 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:security>
<cmdty:space>NYSE</cmdty:space>
<cmdty:id>HN</cmdty:id>
</act:security>
+ <act:security-scu>100</act:security-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -77,6 +81,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -86,12 +91,11 @@
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">69ebbc554a972eaf56f8817990cf4cd9</trn:id>
- <trn:num></trn:num>
<trn:date-posted>
- <ts:date>2001-03-27 00:00:00 +1000</ts:date>
+ <ts:date>2001-03-26 09:00:00 -0500</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-03-27 12:26:10 +1000</ts:date>
+ <ts:date>2001-03-26 21:26:10 -0500</ts:date>
</trn:date-entered>
<trn:description>Initial Balance</trn:description>
<trn:splits>
@@ -115,10 +119,10 @@
<trn:id type="guid">f7aa7c9b3b8b9de253919540af3d0de0</trn:id>
<trn:num>0001</trn:num>
<trn:date-posted>
- <ts:date>2001-03-27 00:00:00 +1000</ts:date>
+ <ts:date>2001-03-26 09:00:00 -0500</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-03-27 12:26:30 +1000</ts:date>
+ <ts:date>2001-03-26 21:26:30 -0500</ts:date>
</trn:date-entered>
<trn:description>Buy stock</trn:description>
<trn:splits>
@@ -142,10 +146,10 @@
<trn:id type="guid">2cefabdbeaf2c66aa1998024efda6dab</trn:id>
<trn:num>002</trn:num>
<trn:date-posted>
- <ts:date>2001-03-27 00:00:00 +1000</ts:date>
+ <ts:date>2001-03-26 09:00:00 -0500</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-03-27 12:26:44 +1000</ts:date>
+ <ts:date>2001-03-26 21:26:44 -0500</ts:date>
</trn:date-entered>
<trn:description>Buy stock</trn:description>
<trn:splits>
@@ -169,10 +173,10 @@
<trn:id type="guid">df124638424fb790b19e7b02ad1a6237</trn:id>
<trn:num>003</trn:num>
<trn:date-posted>
- <ts:date>2001-03-27 00:00:00 +1000</ts:date>
+ <ts:date>2001-03-26 09:00:00 -0500</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-03-27 12:27:05 +1000</ts:date>
+ <ts:date>2001-03-26 21:27:05 -0500</ts:date>
</trn:date-entered>
<trn:description>Buy Stock</trn:description>
<trn:splits>
@@ -197,4 +201,3 @@
<!-- Local variables: -->
<!-- mode: xml -->
<!-- End: -->
-
Index: gnucash/src/test/test-files/xml2/hierachical-data-file.gml2
diff -u gnucash/src/test/test-files/xml2/hierachical-data-file.gml2:1.1 gnucash/src/test/test-files/xml2/hierachical-data-file.gml2:1.2
--- gnucash/src/test/test-files/xml2/hierachical-data-file.gml2:1.1 Thu Apr 5 16:15:53 2001
+++ gnucash/src/test/test-files/xml2/hierachical-data-file.gml2 Tue May 15 10:58:12 2001
@@ -10,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -25,6 +26,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -41,6 +43,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -56,6 +59,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -71,6 +75,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -87,6 +92,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -103,6 +109,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -119,6 +126,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -129,10 +137,10 @@
<gnc:transaction version="2.0.0">
<trn:id type="guid">9926159b3af5a5cdb1f0de7ff72fe751</trn:id>
<trn:date-posted>
- <ts:date>2001-04-05 00:00:00 +1000</ts:date>
+ <ts:date>2001-04-04 10:00:00 -0400</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-04-05 17:43:14 +1000</ts:date>
+ <ts:date>2001-04-05 03:43:14 -0400</ts:date>
</trn:date-entered>
<trn:description></trn:description>
<trn:splits>
@@ -155,10 +163,10 @@
<gnc:transaction version="2.0.0">
<trn:id type="guid">3ae95f7210a67e83bf7f53adac572857</trn:id>
<trn:date-posted>
- <ts:date>2001-04-05 00:00:00 +1000</ts:date>
+ <ts:date>2001-04-04 10:00:00 -0400</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-04-05 17:00:17 +1000</ts:date>
+ <ts:date>2001-04-05 03:00:17 -0400</ts:date>
</trn:date-entered>
<trn:description></trn:description>
<trn:splits>
@@ -181,10 +189,10 @@
<gnc:transaction version="2.0.0">
<trn:id type="guid">50eae9025b2f98260d372d017c13ad00</trn:id>
<trn:date-posted>
- <ts:date>2001-04-05 00:00:00 +1000</ts:date>
+ <ts:date>2001-04-04 10:00:00 -0400</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-04-05 17:00:40 +1000</ts:date>
+ <ts:date>2001-04-05 03:00:40 -0400</ts:date>
</trn:date-entered>
<trn:description></trn:description>
<trn:splits>
@@ -207,10 +215,10 @@
<gnc:transaction version="2.0.0">
<trn:id type="guid">ca0b226a20d5d30387c5cdeee9033fb2</trn:id>
<trn:date-posted>
- <ts:date>2001-04-05 00:00:00 +1000</ts:date>
+ <ts:date>2001-04-04 10:00:00 -0400</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-04-05 17:21:15 +1000</ts:date>
+ <ts:date>2001-04-05 03:21:15 -0400</ts:date>
</trn:date-entered>
<trn:description></trn:description>
<trn:splits>
@@ -233,10 +241,10 @@
<gnc:transaction version="2.0.0">
<trn:id type="guid">1c9c58d27d44a85565eb9d2a01341052</trn:id>
<trn:date-posted>
- <ts:date>2001-04-05 00:00:00 +1000</ts:date>
+ <ts:date>2001-04-04 10:00:00 -0400</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-04-05 17:22:12 +1000</ts:date>
+ <ts:date>2001-04-05 03:22:12 -0400</ts:date>
</trn:date-entered>
<trn:description></trn:description>
<trn:splits>
@@ -259,10 +267,10 @@
<gnc:transaction version="2.0.0">
<trn:id type="guid">c8762190f365c705d10fc1e34e01b44a</trn:id>
<trn:date-posted>
- <ts:date>2002-08-13 00:00:00 +1000</ts:date>
+ <ts:date>2002-08-12 10:00:00 -0400</ts:date>
</trn:date-posted>
<trn:date-entered>
- <ts:date>2001-04-05 17:00:32 +1000</ts:date>
+ <ts:date>2001-04-05 03:00:32 -0400</ts:date>
</trn:date-entered>
<trn:description></trn:description>
<trn:splits>
Index: gnucash/src/test/test-files/xml2/ms-money.gml2
diff -u gnucash/src/test/test-files/xml2/ms-money.gml2:1.1 gnucash/src/test/test-files/xml2/ms-money.gml2:1.2
--- gnucash/src/test/test-files/xml2/ms-money.gml2:1.1 Thu Mar 29 02:41:24 2001
+++ gnucash/src/test/test-files/xml2/ms-money.gml2 Tue May 15 10:58:12 2001
@@ -1,6 +1,5 @@
<?xml version="1.0"?>
<gnc-v2>
-<gnc:count-data cd:type="commodity">0</gnc:count-data>
<gnc:count-data cd:type="account">39</gnc:count-data>
<gnc:count-data cd:type="transaction">347</gnc:count-data>
<gnc:account version="2.0.0">
@@ -11,6 +10,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>New Bank</act:name>
@@ -20,6 +20,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>School Credit</act:name>
@@ -29,6 +30,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Dividend</act:name>
@@ -38,6 +40,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Other Income</act:name>
@@ -47,6 +50,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Credit balance</act:name>
@@ -56,6 +60,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">fd1d2d2d58ceefc149f572a1e6936cec</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -66,6 +71,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Reimbursement</act:name>
@@ -75,6 +81,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Camcorder</act:name>
@@ -84,6 +91,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">60a59d2467d55241a1f13d5c0c43fa1b</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -94,6 +102,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Unspecified</act:name>
@@ -103,6 +112,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>WS</act:name>
@@ -112,6 +122,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>A</act:name>
@@ -121,6 +132,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Insurance</act:name>
@@ -130,6 +142,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">74446cb1e9d9fb729f0d002aea325430</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -140,6 +153,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">74446cb1e9d9fb729f0d002aea325430</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -150,6 +164,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">74446cb1e9d9fb729f0d002aea325430</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -160,6 +175,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">74446cb1e9d9fb729f0d002aea325430</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -170,6 +186,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">74446cb1e9d9fb729f0d002aea325430</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -180,6 +197,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Bills</act:name>
@@ -189,6 +207,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Electricity</act:name>
@@ -198,6 +217,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">b978ff4097c571ecbbd134bd50cb439f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -208,6 +228,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">b978ff4097c571ecbbd134bd50cb439f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -218,6 +239,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">b978ff4097c571ecbbd134bd50cb439f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -228,6 +250,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">b978ff4097c571ecbbd134bd50cb439f</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -238,6 +261,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Clothing</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -248,6 +272,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Education</act:name>
@@ -257,6 +282,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Education</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -267,6 +293,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Groceries</act:name>
@@ -276,6 +303,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">073d73615847b401ef859cc852509ab7</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -286,6 +314,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Insurance</act:name>
@@ -295,6 +324,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>A</act:name>
@@ -304,6 +334,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">2f38dff5dceaa7e0ee4d645a19215103</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -314,6 +345,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Photo</act:name>
@@ -323,6 +355,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">246d4bbc03fd4ebfc817afda54011ebc</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -333,6 +366,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:description>Miscellaneous</act:description>
</gnc:account>
<gnc:account version="2.0.0">
@@ -343,6 +377,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Student account</act:name>
@@ -352,6 +387,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
<act:parent type="guid">96d92c6744c5df991da54c700630fe72</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -362,6 +398,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>Retained Earnings</act:name>
@@ -371,6 +408,7 @@
<cmdty:space>ISO4217</cmdty:space>
<cmdty:id>USD</cmdty:id>
</act:currency>
+ <act:currency-scu>100</act:currency-scu>
</gnc:account>
<gnc:transaction version="2.0.0">
<trn:id type="guid">58a96777671bde4e1352e2b061edd814</trn:id>
Index: gnucash/src/test/test-files/xml2/pricedb1.gml2
diff -u gnucash/src/test/test-files/xml2/pricedb1.gml2:1.1 gnucash/src/test/test-files/xml2/pricedb1.gml2:1.2
--- gnucash/src/test/test-files/xml2/pricedb1.gml2:1.1 Thu Mar 29 02:41:25 2001
+++ gnucash/src/test/test-files/xml2/pricedb1.gml2 Tue May 15 10:58:13 2001
@@ -1,8 +1,6 @@
<?xml version="1.0"?>
<gnc-v2>
<gnc:count-data cd:type="commodity">12</gnc:count-data>
-<gnc:count-data cd:type="account">0</gnc:count-data>
-<gnc:count-data cd:type="transaction">0</gnc:count-data>
<gnc:commodity version="2.0.0">
<cmdty:space>AMEX</cmdty:space>
<cmdty:id>stk</cmdty:id>