From 48bdab38d4fd66e2c2ea59d971c60d3e1ae235ab Mon Sep 17 00:00:00 2001 From: John Ralls Date: Sat, 17 Feb 2018 14:58:18 -0800 Subject: [PATCH] Replace sprintf with Guile's built-in format. --- gnucash/import-export/qif-imp/qif-file.scm | 3 +- gnucash/import-export/qif-imp/qif-parse.scm | 9 +- gnucash/import-export/qif-imp/qif-to-gnc.scm | 6 +- gnucash/report/business-reports/aging.scm | 5 +- .../business-reports/customer-summary.scm | 21 +- .../report/business-reports/easy-invoice.scm | 5 +- .../report/business-reports/fancy-invoice.scm | 5 +- gnucash/report/business-reports/invoice.scm | 3 +- .../report/business-reports/job-report.scm | 7 +- .../locale-specific/us/taxtxf-de_DE.scm | 3 +- gnucash/report/locale-specific/us/taxtxf.scm | 27 +- gnucash/report/report-gnome/report-gnome.scm | 4 +- gnucash/report/report-system/eguile-gnc.scm | 3 +- .../report/report-system/html-document.scm | 3 +- gnucash/report/report-system/html-table.scm | 6 +- gnucash/report/report-system/html-text.scm | 6 +- .../report/report-system/html-utilities.scm | 4 +- .../report-system/report-collectors.scm | 1 - .../report/report-system/report-utilities.scm | 9 +- gnucash/report/report-system/report.scm | 1 - .../report-system/test/test-test-extras.scm | 1 - .../standard-reports/account-piecharts.scm | 18 +- .../standard-reports/advanced-portfolio.scm | 12 +- .../standard-reports/budget-barchart.scm | 2 - .../report/standard-reports/budget-flow.scm | 4 +- .../budget-income-statement.scm | 15 +- gnucash/report/standard-reports/budget.scm | 3 +- gnucash/report/standard-reports/cash-flow.scm | 9 +- .../standard-reports/cashflow-barchart.scm | 5 +- .../standard-reports/category-barchart.scm | 14 +- .../report/standard-reports/daily-reports.scm | 10 +- .../standard-reports/equity-statement.scm | 10 +- .../standard-reports/income-statement.scm | 7 +- .../report/standard-reports/net-barchart.scm | 5 +- .../report/standard-reports/net-linechart.scm | 5 +- gnucash/report/standard-reports/portfolio.scm | 6 +- .../report/standard-reports/price-scatter.scm | 6 +- .../report/standard-reports/sx-summary.scm | 7 +- .../test/test-generic-category-report.scm | 1 - .../test/test-standard-category-report.scm | 1 - .../report/standard-reports/transaction.scm | 5 +- .../report/standard-reports/trial-balance.scm | 9 +- .../report/utility-reports/hello-world.scm | 22 +- .../report/utility-reports/view-column.scm | 6 +- libgnucash/app-utils/date-utilities.scm | 7 +- libgnucash/app-utils/test/CMakeLists.txt | 2 +- .../app-utils/test/test-date-utilities.scm | 21 +- libgnucash/engine/test/test-extras.scm | 1 - libgnucash/scm/CMakeLists.txt | 2 +- libgnucash/scm/printf.scm | 1219 ----------------- po/POTFILES.in | 1 - 51 files changed, 151 insertions(+), 1416 deletions(-) delete mode 100644 libgnucash/scm/printf.scm diff --git a/gnucash/import-export/qif-imp/qif-file.scm b/gnucash/import-export/qif-imp/qif-file.scm index f2240842b7..77ecfb686f 100644 --- a/gnucash/import-export/qif-imp/qif-file.scm +++ b/gnucash/import-export/qif-imp/qif-file.scm @@ -26,7 +26,6 @@ (use-modules (gnucash core-utils)) -(use-modules (gnucash printf)) (use-modules (ice-9 regex)) (use-modules (srfi srfi-13)) (use-modules (ice-9 rdelim)) @@ -1028,7 +1027,7 @@ (gnc:list-display-to-string (list (_ "Parse ambiguity between formats") " " formats "\n" - (sprintf #f (_ "Value '%s' could be %s or %s.") + (format #f (_ "Value '~a' could be ~a or ~a.") parsed (printer parsed) (printer this-parsed)))))))))) diff --git a/gnucash/import-export/qif-imp/qif-parse.scm b/gnucash/import-export/qif-imp/qif-parse.scm index dab31f6624..733cae6598 100644 --- a/gnucash/import-export/qif-imp/qif-parse.scm +++ b/gnucash/import-export/qif-imp/qif-parse.scm @@ -23,9 +23,6 @@ ;; Boston, MA 02110-1301, USA gnu@gnu.org ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(use-modules (gnucash printf)) - (define qif-category-compiled-rexp (make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))? *$")) @@ -188,7 +185,7 @@ (list GNC-BANK-TYPE)) (#t (errorproc errortype - (sprintf #f (_ "Unrecognized account type '%s'. Defaulting to Bank.") + (format #f (_ "Unrecognized account type '~s'. Defaulting to Bank.") read-value)) (list GNC-BANK-TYPE))))) @@ -295,7 +292,7 @@ ; 'vest) (else (errorproc errortype - (sprintf #f (_ "Unrecognized action '%s'.") read-value)) + (format #f (_ "Unrecognized action '~a'.") read-value)) #f))) #f)) @@ -320,7 +317,7 @@ 'budgeted) (else (errorproc errortype - (sprintf #f (_ "Unrecognized status '%s'. Defaulting to uncleared.") + (format #f (_ "Unrecognized status '~a'. Defaulting to uncleared.") read-value)) #f))) #f)) diff --git a/gnucash/import-export/qif-imp/qif-to-gnc.scm b/gnucash/import-export/qif-imp/qif-to-gnc.scm index 519d6e90a3..11ea351263 100644 --- a/gnucash/import-export/qif-imp/qif-to-gnc.scm +++ b/gnucash/import-export/qif-imp/qif-to-gnc.scm @@ -26,8 +26,6 @@ (use-modules (srfi srfi-13)) -(use-modules (gnucash printf)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; qif-import:find-or-make-acct @@ -65,12 +63,12 @@ (if (not (null? (gnc-account-lookup-by-full-name old-root long-name))) (let loop ((count 2)) (let* ((test-name - (string-append long-name (sprintf #f " %a" count))) + (string-append long-name (format #f " ~a" count))) (test-acct (gnc-account-lookup-by-full-name old-root test-name))) (if (and (not (null? test-acct)) (not (compatible? test-acct))) (loop (+ 1 count)) - (string-append short-name (sprintf #f " %a" count))))) + (string-append short-name (format #f " ~a" count))))) short-name)) ;; If a GnuCash account already exists in the old root with the same diff --git a/gnucash/report/business-reports/aging.scm b/gnucash/report/business-reports/aging.scm index 4e8ce1f1a2..da2bd39253 100644 --- a/gnucash/report/business-reports/aging.scm +++ b/gnucash/report/business-reports/aging.scm @@ -27,7 +27,6 @@ (define-module (gnucash report aging)) (use-modules (gnucash utilities)) -(use-modules (gnucash printf)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -222,8 +221,8 @@ "\nClient Currency" (gnc-ommodity-get-mnemonic(company-get-currency company-info))))) (gnc-error-dialog '() error-str) (gnc:error error-str) - (cons #f (sprintf - (_ "Transactions relating to '%s' contain \ + (cons #f (format + (_ "Transactions relating to '~a' contain \ more than one currency. This report is not designed to cope with this possibility.") (gncOwnerGetName owner)))) (begin (gnc:debug "it's an old company") diff --git a/gnucash/report/business-reports/customer-summary.scm b/gnucash/report/business-reports/customer-summary.scm index 192a299f0d..34ca9d56e3 100644 --- a/gnucash/report/business-reports/customer-summary.scm +++ b/gnucash/report/business-reports/customer-summary.scm @@ -30,7 +30,6 @@ (use-modules (srfi srfi-1)) (use-modules (gnucash gnc-module)) -(use-modules (gnucash printf)) (use-modules (gnucash utilities)) ; for gnc:debug (use-modules (gnucash gettext)) @@ -904,8 +903,8 @@ (list (gncOwnerGetName owner) (gnc:make-gnc-monetary currency profit) - ;;(sprintf #f (if (< (abs markupfloat) 10) "%2.1f%%" "%2.0f%%") markupfloat) - (sprintf #f "%2.0f%%" markupfloat) + ;;(format #f (if (< (abs markupfloat) 10) "~2.1f%%" "%2.0f%%") markupfloat) + (format #f "~2,0f%" markupfloat) (gnc:make-gnc-monetary currency sales)))) (if show-column-expense? (set! @@ -928,7 +927,7 @@ (list (_ "No Customer") (gnc:make-gnc-monetary currency other-profit) - (sprintf #f "%2.0f%%" markupfloat) + (format #f "~2,0f%" markupfloat) (gnc:make-gnc-monetary currency other-sales)))) (if show-column-expense? (set! @@ -959,8 +958,8 @@ (list (_ "Total") (gnc:make-gnc-monetary currency total-profit) - ;;(sprintf #f (if (< (abs markupfloat) 10) "%2.1f%%" "%2.0f%%") markupfloat) - (sprintf #f "%2.0f%%" markupfloat) + ;;(format #f (if (< (abs markupfloat) 10) "~2,1f%" "~2,0f%") markupfloat) + (format #f "~2,0f%" markupfloat) (gnc:make-gnc-monetary currency toplevel-total-income)))) (if show-column-expense? (set! @@ -1000,8 +999,8 @@ (if any-valid-owner? ;; Report contains valid data (let ((headline - (sprintf - #f (_ "%s %s - %s") + (format + #f (_ "~a ~a - ~a") report-title (qof-print-date start-date) (qof-print-date end-date)))) @@ -1020,9 +1019,9 @@ (gnc:html-document-add-object! document (gnc:make-html-text - (sprintf #f - (_ "No valid %s selected. Click on the Options button to select a company.") - (_ type-str))))) ;; FIXME because of translations: Please change this string into full sentences instead of sprintf, because in non-english languages the "no valid" has different forms depending on the grammatical gender of the "%s". + (format #f + (_ "No valid ~a selected. Click on the Options button to select a company.") + (_ type-str))))) ;; FIXME because of translations: Please change this string into full sentences instead of format, because in non-english languages the "no valid" has different forms depending on the grammatical gender of the "%s". (qof-query-destroy owner-query) (qof-query-destroy toplevel-income-query) diff --git a/gnucash/report/business-reports/easy-invoice.scm b/gnucash/report/business-reports/easy-invoice.scm index 4b89071856..4e4a68ca7f 100644 --- a/gnucash/report/business-reports/easy-invoice.scm +++ b/gnucash/report/business-reports/easy-invoice.scm @@ -31,7 +31,6 @@ (define-module (gnucash report easy-invoice)) (use-modules (srfi srfi-1)) -(use-modules (gnucash printf)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -714,7 +713,7 @@ (begin (set! credit-note? #t) (set! default-title (_ "Credit Note")))))) - (set! title (sprintf #f (_"%s #%d") (title-string default-title custom-title) + (set! title (format #f (_"~a #~d") (title-string default-title custom-title) (gncInvoiceGetID invoice))))) ; (gnc:html-document-set-title! document title) @@ -735,7 +734,7 @@ (add-html! document "") (add-html! document "") (add-html! document title) -;; (add-html! document (sprintf #f (_ "Invoice #%d") +;; (add-html! document (format #f (_ "Invoice #~d") ;; (gncInvoiceGetID invoice))) (add-html! document "") (add-html! document "") diff --git a/gnucash/report/business-reports/fancy-invoice.scm b/gnucash/report/business-reports/fancy-invoice.scm index 17a47a7544..2cc8f20973 100644 --- a/gnucash/report/business-reports/fancy-invoice.scm +++ b/gnucash/report/business-reports/fancy-invoice.scm @@ -49,7 +49,6 @@ (define-module (gnucash report fancy-invoice)) (use-modules (srfi srfi-1)) -(use-modules (gnucash printf)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -867,13 +866,13 @@ ;; Translators: %s below is "Invoice" or "Bill" or even the ;; custom title from the options. The next column contains ;; the number of the document. - date-table (list (sprintf #f (_ "%s #") title) (gncInvoiceGetID invoice))) + date-table (list (format #f (_ "~s #") title) (gncInvoiceGetID invoice))) ;; Translators: The first %s below is "Invoice" or ;; "Bill" or even the custom title from the ;; options. This string sucks for i18n, but I don't ;; have a better solution right now without breaking ;; other people's invoices. - (make-date-row! date-table (sprintf #f (_ "%s Date") title) post-date date-format) + (make-date-row! date-table (format #f (_ "~s Date") title) post-date date-format) (make-date-row! date-table (_ "Due Date") due-date date-format) date-table) (gnc:make-html-text diff --git a/gnucash/report/business-reports/invoice.scm b/gnucash/report/business-reports/invoice.scm index a74e48f1b7..96236aeb89 100644 --- a/gnucash/report/business-reports/invoice.scm +++ b/gnucash/report/business-reports/invoice.scm @@ -25,7 +25,6 @@ (define-module (gnucash report invoice)) (use-modules (srfi srfi-1)) -(use-modules (gnucash printf)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -687,7 +686,7 @@ (set! title (title-string default-title custom-title)))) - (gnc:html-document-set-title! document (sprintf #f (_"%s #%d") title + (gnc:html-document-set-title! document (format #f (_"~a #~d") title (gncInvoiceGetID invoice))) (if (not (null? invoice)) diff --git a/gnucash/report/business-reports/job-report.scm b/gnucash/report/business-reports/job-report.scm index 9cec45aa56..8ec2dad374 100644 --- a/gnucash/report/business-reports/job-report.scm +++ b/gnucash/report/business-reports/job-report.scm @@ -27,7 +27,6 @@ (define-module (gnucash report job-report)) (use-modules (srfi srfi-1)) -(use-modules (gnucash printf)) (use-modules (gnucash gnc-module)) (use-modules (gnucash utilities)) ; for gnc:debug (use-modules (gnucash gettext)) @@ -632,9 +631,9 @@ (gnc:html-document-add-object! document (gnc:make-html-text - (sprintf #f - (_ "No valid %s selected. Click on the Options button to select a company.") - (_ type-str))))) ;; FIXME because of translations: Please change this string into full sentences instead of sprintf, because in non-english languages the "no valid" has different forms depending on the grammatical gender of the "%s". + (format #f + (_ "No valid ~a selected. Click on the Options button to select a company.") + (_ type-str))))) ;; FIXME because of translations: Please change this string into full sentences instead of format, because in non-english languages the "no valid" has different forms depending on the grammatical gender of the "%s". (qof-query-destroy query) document)) diff --git a/gnucash/report/locale-specific/us/taxtxf-de_DE.scm b/gnucash/report/locale-specific/us/taxtxf-de_DE.scm index 9d6cd90e51..ee5aa2da55 100644 --- a/gnucash/report/locale-specific/us/taxtxf-de_DE.scm +++ b/gnucash/report/locale-specific/us/taxtxf-de_DE.scm @@ -69,7 +69,6 @@ (define-module (gnucash report taxtxf-de_DE)) (use-modules (gnucash utilities)) (use-modules (srfi srfi-1)) -(use-modules (gnucash printf)) (use-modules (gnucash core-utils)) ; for gnc:version (use-modules (gnucash gettext)) @@ -845,7 +844,7 @@ "center" (gnc:html-markup-p (gnc:html-markup/format - (_ "Period from %s to %s") from-date to-date))))) + (_ "Period from ~a to ~a") from-date to-date))))) (gnc:html-document-add-object! doc (gnc:make-html-text diff --git a/gnucash/report/locale-specific/us/taxtxf.scm b/gnucash/report/locale-specific/us/taxtxf.scm index 8bd1f51971..bb0d067ce1 100644 --- a/gnucash/report/locale-specific/us/taxtxf.scm +++ b/gnucash/report/locale-specific/us/taxtxf.scm @@ -102,7 +102,6 @@ (load-extension "libgncmod-gnome-utils" "scm_init_sw_gnome_utils_module")) (use-modules (sw_gnome_utils)) ;; to get to gnc-error-dialog -(use-modules (gnucash printf)) (use-modules (gnucash core-utils)) ; for gnc:version (gnc:module-load "gnucash/html" 0) ; added for 'gnc-html-engine-supports-css' @@ -594,7 +593,7 @@ (value (string-append "$" ; in txf output, income is positive; expense negative ; liabilities are positive, assets are negative; ; essentially, just reverse signs on dr's & cr's - (sprintf #f "%.2f" (gnc-numeric-to-double + (format #f "!0,2f" (gnc-numeric-to-double (gnc-numeric-neg account-value))))) ) @@ -3180,8 +3179,8 @@ (not (string=? "" (gnc-get-current-book-tax-name)))) "Tax Name: %s
" - "%s") - "Period from %s to %s
Tax Year %s
Tax Entity Type: %s
All amounts in USD unless otherwise noted") + "~a") + "Period from ~a to ~s
Tax Year ~a
Tax Entity Type: %s
All amounts in USD unless otherwise noted") (gnc-get-current-book-tax-name) from-date to-date @@ -3456,27 +3455,27 @@ (string-append "Selected Report Options:
" ;; selected accounts - "      %s
" + "      ~a
" ;; suppress 0.00 values - "      %s
" + "      ~a
" ;; full acct names - "      %s
" + "      ~a
" ;; transfer detail - "      %s
" + "      ~a
" ;; TXF detail - "      %s
" + "      ~a
" ;; action:memo detail - "      %s
" + "      ~a
" ;; transaction detail - "      %s
" + "      ~a
" ;; special dates - "      %s
" + "      ~a
" ;; currency conversion date - "      %s
" + "      ~a
" ;; alternate transaction shading (if (gnc-html-engine-supports-css) "" - "      %s
" + "      ~a
" )) (if (not (null? user-sel-accnts)) "Subset of accounts" diff --git a/gnucash/report/report-gnome/report-gnome.scm b/gnucash/report/report-gnome/report-gnome.scm index 61f83ca030..ade1d0f124 100644 --- a/gnucash/report/report-gnome/report-gnome.scm +++ b/gnucash/report/report-gnome/report-gnome.scm @@ -31,8 +31,6 @@ (use-modules (gnucash gettext)) (use-modules (gnucash report utility-reports)) -(use-modules (gnucash printf)) - (eval-when (compile load eval expand) (load-extension "libgncmod-gnome-utils" "scm_init_sw_gnome_utils_module") @@ -67,7 +65,7 @@ (if (not menu-tip) (set! menu-tip - (sprintf #f (_ "Display the %s report") (_ name)))) + (format #f (_ "Display the ~a report") (_ name)))) (set! item (gnc:make-menu-item diff --git a/gnucash/report/report-system/eguile-gnc.scm b/gnucash/report/report-system/eguile-gnc.scm index 1f8a614caa..012b427089 100644 --- a/gnucash/report/report-system/eguile-gnc.scm +++ b/gnucash/report/report-system/eguile-gnc.scm @@ -86,7 +86,6 @@ (use-modules (ice-9 regex)) ; for regular expressions (use-modules (ice-9 rdelim)) ; for read-line (use-modules (ice-9 local-eval)) ; for the-environment -(use-modules (gnucash printf)) (use-modules (gnucash app-utils)) ; for _ ;; This is needed for displaying error messages -- note that it assumes that @@ -244,7 +243,7 @@ ;; Process a template file and return the result as a string (define (eguile-file-to-string infile environment) (if (not (access? infile R_OK)) - (sprintf #f (_ "Template file \"%s\" can not be read") infile) + (format #f (_ "Template file \"~a\" can not be read") infile) (let ((script (with-input-from-file infile (lambda () (with-output-to-string template->script))))) diff --git a/gnucash/report/report-system/html-document.scm b/gnucash/report/report-system/html-document.scm index c8edb98dd3..b95ddb11c7 100644 --- a/gnucash/report/report-system/html-document.scm +++ b/gnucash/report/report-system/html-document.scm @@ -22,7 +22,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (gnc:module-load "gnucash/html" 0) -(use-modules (gnucash printf)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; class @@ -238,7 +237,7 @@ (if (not style-info) (gnc:make-html-data-style-info (lambda (datum parms) - (sprintf #f "%a %a" markup datum)) + (format #f "~a ~a" markup datum)) #f) style-info))) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index ae21218bc8..e33e6d6cd6 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -33,8 +33,6 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(use-modules (gnucash printf)) - (define (make-record-type "" '(col-headers @@ -147,8 +145,8 @@ (gnc:html-document-push-style doc style) (push (gnc:html-document-markup-start doc (gnc:html-table-cell-tag cell) #t - (sprintf #f "rowspan=\"%a\"" (gnc:html-table-cell-rowspan cell)) - (sprintf #f "colspan=\"%a\"" (gnc:html-table-cell-colspan cell)))) + (format #f "rowspan=\"~a\"" (gnc:html-table-cell-rowspan cell)) + (format #f "colspan=\"~a\"" (gnc:html-table-cell-colspan cell)))) (for-each (lambda (child) (push (gnc:html-object-render child doc))) diff --git a/gnucash/report/report-system/html-text.scm b/gnucash/report/report-system/html-text.scm index 76b0d79ae3..b9e61d5412 100644 --- a/gnucash/report/report-system/html-text.scm +++ b/gnucash/report/report-system/html-text.scm @@ -30,8 +30,6 @@ ;; doc as arg to get the string out. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(use-modules (gnucash printf)) - (define (make-record-type "" '(body style))) @@ -125,12 +123,12 @@ ;; I'm not entirely pleased about the way this works, but I can't ;; really see a way around it. It still works within the style ;; system, but it flattens out its children's lists prematurely. Has -;; to, to pass them as args to sprintf. +;; to, to pass them as args to format. (define (gnc:html-markup/format format . entities) (lambda (doc) (apply - sprintf #f format + format #f format (map (lambda (elt) (let ((rendered-elt diff --git a/gnucash/report/report-system/html-utilities.scm b/gnucash/report/report-system/html-utilities.scm index 5fe50f04d9..2357036773 100644 --- a/gnucash/report/report-system/html-utilities.scm +++ b/gnucash/report/report-system/html-utilities.scm @@ -22,8 +22,6 @@ ;; Boston, MA 02110-1301, USA gnu@gnu.org ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(use-modules (gnucash printf)) - ;; returns a list with n #f (empty cell) values (define (gnc:html-make-empty-cell) #f) (define (gnc:html-make-empty-cells n) @@ -808,7 +806,7 @@ (gnc:html-markup-p (gnc:html-markup-anchor (gnc-build-url URL-TYPE-OPTIONS - (string-append "report-id=" (sprintf #f "%a" report-id)) + (string-append "report-id=" (format #f "~a" report-id)) "") (_ "Edit report options"))))) diff --git a/gnucash/report/report-system/report-collectors.scm b/gnucash/report/report-system/report-collectors.scm index c1bc225959..523c8a7f93 100644 --- a/gnucash/report/report-system/report-collectors.scm +++ b/gnucash/report/report-system/report-collectors.scm @@ -26,7 +26,6 @@ (use-modules (srfi srfi-1)) (use-modules (gnucash utilities)) -(use-modules (gnucash printf)) (use-modules (gnucash report report-system)) (use-modules (gnucash app-utils)) (use-modules (gnucash engine)) diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm index a2ba5eb2f6..dbe56c6b9e 100644 --- a/gnucash/report/report-system/report-utilities.scm +++ b/gnucash/report/report-system/report-utilities.scm @@ -18,7 +18,6 @@ ;; Boston, MA 02110-1301, USA gnu@gnu.org (use-modules (srfi srfi-13)) -(use-modules (gnucash printf)) (define (list-ref-safe list elt) (if (> (length list) elt) @@ -686,14 +685,14 @@ (xaccTransGetVoidStatus trans))) (define (gnc:report-starting report-name) - (gnc-window-show-progress (sprintf #f - (_ "Building '%s' report ...") + (gnc-window-show-progress (format #f + (_ "Building '~a' report ...") (gnc:gettext report-name)) 0)) (define (gnc:report-render-starting report-name) - (gnc-window-show-progress (sprintf #f - (_ "Rendering '%s' report ...") + (gnc-window-show-progress (format #f + (_ "Rendering '~a' report ...") (if (string-null? report-name) (gnc:gettext "Untitled") (gnc:gettext report-name))) diff --git a/gnucash/report/report-system/report.scm b/gnucash/report/report-system/report.scm index 13dff545c4..2e7712a2f0 100644 --- a/gnucash/report/report-system/report.scm +++ b/gnucash/report/report-system/report.scm @@ -22,7 +22,6 @@ (use-modules (gnucash utilities)) (use-modules (gnucash app-utils)) -(use-modules (gnucash printf)) (use-modules (gnucash gettext)) (eval-when (compile load eval expand) diff --git a/gnucash/report/report-system/test/test-test-extras.scm b/gnucash/report/report-system/test/test-test-extras.scm index 64c8dabc06..f551748e36 100644 --- a/gnucash/report/report-system/test/test-test-extras.scm +++ b/gnucash/report/report-system/test/test-test-extras.scm @@ -96,7 +96,6 @@ ;(use-modules (gnucash engine)) ;(use-modules (gnucash utilities)) -;(use-modules (gnucash printf)) ;(use-modules (gnucash report report-system)) ;(use-modules (gnucash app-utils)) (use-modules (gnucash engine)) diff --git a/gnucash/report/standard-reports/account-piecharts.scm b/gnucash/report/standard-reports/account-piecharts.scm index a5845fcb39..0277dc9dba 100644 --- a/gnucash/report/standard-reports/account-piecharts.scm +++ b/gnucash/report/standard-reports/account-piecharts.scm @@ -31,8 +31,6 @@ (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) -(use-modules (gnucash printf)) - (gnc:module-load "gnucash/report/report-system" 0) (define menuname-income (N_ "Income Piechart")) @@ -564,17 +562,17 @@ balance at a given time")) (gnc:html-piechart-set-subtitle! chart (string-append (if do-intervals? - (sprintf #f - (_ "%s to %s") + (format #f + (_ "~a to ~a") (qof-print-date from-date) (qof-print-date to-date)) - (sprintf #f - (_ "Balance at %s") + (format #f + (_ "Balance at ~a") (qof-print-date to-date))) (if show-total? (let ((total (apply + (unzip1 combined)))) - (sprintf - #f ": %s" + (format + #f ": ~a" (xaccPrintAmount (double-to-gnc-numeric total @@ -602,8 +600,8 @@ balance at a given time")) ) "") (if show-percent? - (sprintf - #f " (%2.2f %%)" + (format + #f " (~2,2f %)" (* 100.0 (/ (car pair) (apply + (unzip1 combined))))) "") )) diff --git a/gnucash/report/standard-reports/advanced-portfolio.scm b/gnucash/report/standard-reports/advanced-portfolio.scm index 2586156a3e..b696674366 100644 --- a/gnucash/report/standard-reports/advanced-portfolio.scm +++ b/gnucash/report/standard-reports/advanced-portfolio.scm @@ -32,8 +32,6 @@ (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) -(use-modules (gnucash printf)) - (gnc:module-load "gnucash/report/report-system" 0) (define reportname (N_ "Advanced Portfolio")) @@ -945,7 +943,7 @@ ) (if (= 0.0 moneyinvalue) "" - (sprintf #f "%.2f%%" (* 100 (/ bothgainvalue moneyinvalue))))) + (format #f "~0,2f%" (* 100 (/ bothgainvalue moneyinvalue))))) ) (gnc:make-html-table-header-cell/markup "number-cell" income))) (if (not (eq? handle-brokerage-fees 'ignore-brokerage)) @@ -959,7 +957,7 @@ ) (if (= 0.0 moneyinvalue) "" - (sprintf #f "%.2f%%" (* 100 (/ totalreturnvalue moneyinvalue)))))) + (format #f "~0,2f%" (* 100 (/ totalreturnvalue moneyinvalue)))))) ) ) @@ -1027,7 +1025,7 @@ (gnc:html-document-set-title! document (string-append report-title - (sprintf #f " %s" (qof-print-date to-date)))) + (format #f " ~a" (qof-print-date to-date)))) (if (not (null? accounts)) ; at least 1 account selected @@ -1145,7 +1143,7 @@ ) (if (= 0.0 totalinvalue) "" - (sprintf #f "%.2f%%" (* 100 (/ totalgainvalue totalinvalue)))))) + (format #f "~0,2f%" (* 100 (/ totalgainvalue totalinvalue)))))) (gnc:make-html-table-cell/markup "total-number-cell" sum-total-income))) (if (not (eq? handle-brokerage-fees 'ignore-brokerage)) @@ -1164,7 +1162,7 @@ ) (if (= 0.0 totalinvalue) "" - (sprintf #f "%.2f%%" (* 100 (/ totalreturnvalue totalinvalue)))))) + (format #f "~0,2f%" (* 100 (/ totalreturnvalue totalinvalue)))))) )) diff --git a/gnucash/report/standard-reports/budget-barchart.scm b/gnucash/report/standard-reports/budget-barchart.scm index fcec3553bd..05b721c144 100644 --- a/gnucash/report/standard-reports/budget-barchart.scm +++ b/gnucash/report/standard-reports/budget-barchart.scm @@ -31,8 +31,6 @@ (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) -(use-modules (gnucash printf)) - (gnc:module-load "gnucash/report/report-system" 0) ;; included since Bug726449 diff --git a/gnucash/report/standard-reports/budget-flow.scm b/gnucash/report/standard-reports/budget-flow.scm index 457db2ba46..f7189686a1 100644 --- a/gnucash/report/standard-reports/budget-flow.scm +++ b/gnucash/report/standard-reports/budget-flow.scm @@ -30,8 +30,6 @@ (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) -(use-modules (gnucash printf)) - (gnc:module-load "gnucash/report/report-system" 0) (gnc:module-load "gnucash/gnome-utils" 0) ;for gnc-build-url @@ -318,7 +316,7 @@ ;; Display Title Name - Budget - Period (gnc:html-document-set-title! - doc (sprintf #f (_ "%s: %s - %s") + doc (format #f (_ "~a: ~a - ~a") report-name (gnc-budget-get-name budget) (qof-print-date (gnc-budget-get-period-start-date budget (- period 1))))) diff --git a/gnucash/report/standard-reports/budget-income-statement.scm b/gnucash/report/standard-reports/budget-income-statement.scm index 58f2faddb8..c220781ed8 100644 --- a/gnucash/report/standard-reports/budget-income-statement.scm +++ b/gnucash/report/standard-reports/budget-income-statement.scm @@ -42,7 +42,6 @@ (define-module (gnucash report standard-reports budget-income-statement)) (use-modules (gnucash utilities)) -(use-modules (gnucash printf)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -503,20 +502,20 @@ (period-for (if use-budget-period-range? (if (equal? user-budget-period-start user-budget-period-end) - (sprintf + (format #f - (_ "for Budget %s Period %u") + (_ "for Budget ~a Period ~d") budget-name user-budget-period-start) - (sprintf + (format #f - (_ "for Budget %s Periods %u - %u") + (_ "for Budget ~a Periods ~d - ~d") budget-name user-budget-period-start user-budget-period-end)) - (sprintf + (format #f - (_ "for Budget %s") + (_ "for Budget ~a") budget-name))) ) @@ -615,7 +614,7 @@ (gnc:html-document-set-title! doc - (sprintf #f "%s %s %s" company-name report-title period-for)) + (format #f "~a ~a ~a" company-name report-title period-for)) (set! table-env (list diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm index 12ab6f5720..fb1d9696c5 100644 --- a/gnucash/report/standard-reports/budget.scm +++ b/gnucash/report/standard-reports/budget.scm @@ -31,7 +31,6 @@ (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) -(use-modules (gnucash printf)) (use-modules (gnucash engine)) (use-modules (srfi srfi-1)) @@ -876,7 +875,7 @@ ) (gnc:html-document-set-title! - doc (sprintf #f (_ "%s: %s") + doc (format #f (_ "~a: ~a") report-name (gnc-budget-get-name budget))) (set! accounts (sort accounts account-full-namestring mult-val)))) (gnc:html-markup-p (gnc:html-markup/format - (_ "The string option is %s.") + (_ "The string option is ~a.") (gnc:html-markup-b string-val))) (gnc:html-markup-p (gnc:html-markup/format - (_ "The date option is %s.") + (_ "The date option is ~a.") (gnc:html-markup-b date-string))) (gnc:html-markup-p (gnc:html-markup/format - (_ "The date and time option is %s.") + (_ "The date and time option is ~a.") (gnc:html-markup-b date-string2))) (gnc:html-markup-p (gnc:html-markup/format - (_ "The relative date option is %s.") + (_ "The relative date option is ~a.") (gnc:html-markup-b rel-date-string))) (gnc:html-markup-p (gnc:html-markup/format - (_ "The combination date option is %s.") + (_ "The combination date option is ~a.") (gnc:html-markup-b combo-date-string))) (gnc:html-markup-p (gnc:html-markup/format - (_ "The number option is %s.") + (_ "The number option is ~a.") (gnc:html-markup-b (number->string num-val)))) ;; Here we print the value of the number option formatted as @@ -406,7 +406,7 @@ new, totally cool report, consult the mailing list %s.") ;; it yourself -- it will be wrong in other locales. (gnc:html-markup-p (gnc:html-markup/format - (_ "The number option formatted as currency is %s.") + (_ "The number option formatted as currency is ~a.") (gnc:html-markup-b (xaccPrintAmount (inexact->exact num-val) diff --git a/gnucash/report/utility-reports/view-column.scm b/gnucash/report/utility-reports/view-column.scm index 6e9a918acc..49a300ddd4 100644 --- a/gnucash/report/utility-reports/view-column.scm +++ b/gnucash/report/utility-reports/view-column.scm @@ -36,8 +36,6 @@ (load-extension "libgncmod-report-system" "scm_init_sw_report_system_module")) (use-modules (sw_report_system)) -(use-modules (gnucash printf)) - (gnc:module-load "gnucash/report/report-system" 0) (gnc:module-load "gnucash/html" 0) ;for gnc-build-url @@ -172,7 +170,7 @@ (gnc-build-url URL-TYPE-OPTIONS (string-append "report-id=" - (sprintf #f "%a" (car report-info))) + (format #f "~a" (car report-info))) "") (_ "Edit Options")) " " @@ -180,7 +178,7 @@ (gnc-build-url URL-TYPE-REPORT (string-append "id=" - (sprintf #f "%a" (car report-info))) + (format #f "~a" (car report-info))) "") (_ "Single Report"))))) diff --git a/libgnucash/app-utils/date-utilities.scm b/libgnucash/app-utils/date-utilities.scm index 3627d292c4..ffad895572 100644 --- a/libgnucash/app-utils/date-utilities.scm +++ b/libgnucash/app-utils/date-utilities.scm @@ -22,7 +22,6 @@ (use-modules (gnucash core-utils) - (gnucash printf) (gnucash gettext)) (define gnc:reldate-list '()) @@ -72,7 +71,7 @@ (gnc-locale-to-utf8 (strftime "%Y" datevec))) (define (gnc:date-get-quarter-string datevec) - (sprintf #f "Q%d" (gnc:date-get-quarter datevec))) + (format #f "Q~d" (gnc:date-get-quarter datevec))) (define (gnc:date-get-quarter-year-string datevec) (string-append @@ -92,7 +91,7 @@ 604800)) (begin-string (qof-print-date (+ beginweekt64 345600))) (end-string (qof-print-date (+ beginweekt64 864000)))) - (sprintf #f (_ "%s to %s") begin-string end-string))) + (format #f (_ "~s to ~s") begin-string end-string))) ; (let ((begin-string (qof-print-date ; (+ (* (gnc:date-get-week @@ -104,7 +103,7 @@ ; (gnc:time64-start-day-time ; (gnc-mktime datevec))) ; 604800) 864000)))) -; (sprintf #f (_ "%s to %s") begin-string end-string))) +; (format #f (_ "~s to ~s") begin-string end-string))) ;; is leap year? (define (gnc:leap-year? year) diff --git a/libgnucash/app-utils/test/CMakeLists.txt b/libgnucash/app-utils/test/CMakeLists.txt index 6e77225c66..2489498aeb 100644 --- a/libgnucash/app-utils/test/CMakeLists.txt +++ b/libgnucash/app-utils/test/CMakeLists.txt @@ -58,7 +58,7 @@ GNC_ADD_SCHEME_TARGETS(scm-test-c-interface FALSE ) -GNC_ADD_SCHEME_TESTS(${test_app_utils_scheme_SOURCES}) +GNC_ADD_SCHEME_TESTS("${test_app_utils_scheme_SOURCES}") # Doesn't work yet: GNC_ADD_TEST_WITH_GUILE(test-app-utils "${test_app_utils_SOURCES}" APP_UTILS_TEST_INCLUDE_DIRS APP_UTILS_TEST_LIBS) diff --git a/libgnucash/app-utils/test/test-date-utilities.scm b/libgnucash/app-utils/test/test-date-utilities.scm index 6fca517300..1dc30e1572 100644 --- a/libgnucash/app-utils/test/test-date-utilities.scm +++ b/libgnucash/app-utils/test/test-date-utilities.scm @@ -3,9 +3,10 @@ (use-modules (gnucash engine test test-extras)) (define (run-test) - (and (test test-weeknum-calculator))) + (and (test test-weeknum-calculator) + (test test-date-get-quarter-string))) -(define (create-time64 l) +(define (create-datevec l) (let ((now (gnc-localtime (current-time)))) (set-tm:sec now (list-ref l 5)) (set-tm:min now (list-ref l 4)) @@ -14,6 +15,10 @@ (set-tm:mon now (list-ref l 1)) (set-tm:year now (list-ref l 0)) (set-tm:isdst now -1) + now)) + +(define (create-time64 l) + (let ((now (create-datevec l))) (gnc-mktime now))) (define (weeknums-equal? pair-of-dates) @@ -36,3 +41,15 @@ (not (weeknums-equal? (cons '(1969 12 28 0 0 1) '(1970 1 5 0 0 1)))) )) + +(define (test-date-get-quarter-string) + (and (or (string=? "Q1" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23)))) + (begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (creaete-datevec '(2001 2 14 11 42 23)))) + #f)) + (or (string=? "Q2" (gnc:date-get-quarter-string (create-datevec '(2013 4 23 18 11 49)))) + (begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23)))) + #f)) + (or (string=? "Q3" (gnc:date-get-quarter-string (create-datevec '(1997 9 11 08 14 21)))) + (begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23))))) + #f))) + diff --git a/libgnucash/engine/test/test-extras.scm b/libgnucash/engine/test/test-extras.scm index a8f0519a15..d9a86360d2 100644 --- a/libgnucash/engine/test/test-extras.scm +++ b/libgnucash/engine/test/test-extras.scm @@ -21,7 +21,6 @@ (use-modules (gnucash gnc-module)) -(use-modules (gnucash printf)) (use-modules (gnucash app-utils)) (use-modules (gnucash engine)) (use-modules (srfi srfi-1)) diff --git a/libgnucash/scm/CMakeLists.txt b/libgnucash/scm/CMakeLists.txt index 785ef827e2..7fd32ca8c9 100644 --- a/libgnucash/scm/CMakeLists.txt +++ b/libgnucash/scm/CMakeLists.txt @@ -1,5 +1,5 @@ SET(GUILE_DEPENDS scm-core-utils scm-gnc-module) -SET(scm_scm_1_SCHEME printf.scm string.scm utilities.scm) +SET(scm_scm_1_SCHEME string.scm utilities.scm) GNC_ADD_SCHEME_TARGETS(scm-scm-1 diff --git a/libgnucash/scm/printf.scm b/libgnucash/scm/printf.scm deleted file mode 100644 index db6f2e857a..0000000000 --- a/libgnucash/scm/printf.scm +++ /dev/null @@ -1,1219 +0,0 @@ -;; gnucash -;; Copyright (C) 2009 Andy Wingo - -;; 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 of -;; the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, contact: -;; -;; Free Software Foundation Voice: +1-617-542-5942 -;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 -;; Boston, MA 02111-1307, USA gnu@gnu.org - -;;; Commentary: -;; -;;Code pulled in from Aubrey Jaffer's SLIB. -;; -;;; Code: - -(define-module (gnucash printf) - #:export (printf fprintf sprintf)) - -;; Stub slib support, so we don't depend on slib proper. -(define slib:error error) -(define slib:tab #\tab) -(define slib:form-feed #\page) -(define (require feature) #f) ; noop -(define (require-if condition feature) #f) ; noop - -;; The parts of slib that we need: glob.scm, genwrite.scm, and printf.scm. - -;;; "glob.scm" String matching for filenames (a la BASH). -;;; Copyright (C) 1998 Radey Shouman. -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warranty or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;@code{(require 'filename)} or @code{(require 'glob)} -;;@ftindex filename -;;@ftindex glob - -(define (glob:pattern->tokens pat) - (cond - ((string? pat) - (let loop ((i 0) - (toks '())) - (if (>= i (string-length pat)) - (reverse toks) - (let ((pch (string-ref pat i))) - (case pch - ((#\? #\*) - (loop (+ i 1) - (cons (substring pat i (+ i 1)) toks))) - ((#\[) - (let ((j - (let search ((j (+ i 2))) - (cond - ((>= j (string-length pat)) - (slib:error 'glob:make-matcher - "unmatched [" pat)) - ((char=? #\] (string-ref pat j)) - (if (and (< (+ j 1) (string-length pat)) - (char=? #\] (string-ref pat (+ j 1)))) - (+ j 1) - j)) - (else (search (+ j 1))))))) - (loop (+ j 1) (cons (substring pat i (+ j 1)) toks)))) - (else - (let search ((j (+ i 1))) - (cond ((= j (string-length pat)) - (loop j (cons (substring pat i j) toks))) - ((memv (string-ref pat j) '(#\? #\* #\[)) - (loop j (cons (substring pat i j) toks))) - (else (search (+ j 1))))))))))) - ((pair? pat) - (for-each (lambda (elt) (or (string? elt) - (slib:error 'glob:pattern->tokens - "bad pattern" pat))) - pat) - pat) - (else (slib:error 'glob:pattern->tokens "bad pattern" pat)))) - -(define (glob:make-matcher pat ch=? ch<=?) - (define (match-end str k kmatch) - (and (= k (string-length str)) (reverse (cons k kmatch)))) - (define (match-str pstr nxt) - (let ((plen (string-length pstr))) - (lambda (str k kmatch) - (and (<= (+ k plen) (string-length str)) - (let loop ((i 0)) - (cond ((= i plen) - (nxt str (+ k plen) (cons k kmatch))) - ((ch=? (string-ref pstr i) - (string-ref str (+ k i))) - (loop (+ i 1))) - (else #f))))))) - (define (match-? nxt) - (lambda (str k kmatch) - (and (< k (string-length str)) - (nxt str (+ k 1) (cons k kmatch))))) - (define (match-set1 chrs) - (let recur ((i 0)) - (cond ((= i (string-length chrs)) - (lambda (ch) #f)) - ((and (< (+ i 2) (string-length chrs)) - (char=? #\- (string-ref chrs (+ i 1)))) - (let ((nxt (recur (+ i 3)))) - (lambda (ch) - (or (and (ch<=? ch (string-ref chrs (+ i 2))) - (ch<=? (string-ref chrs i) ch)) - (nxt ch))))) - (else - (let ((nxt (recur (+ i 1))) - (chrsi (string-ref chrs i))) - (lambda (ch) - (or (ch=? chrsi ch) (nxt ch)))))))) - (define (match-set tok nxt) - (let ((chrs (substring tok 1 (- (string-length tok) 1)))) - (if (and (positive? (string-length chrs)) - (memv (string-ref chrs 0) '(#\^ #\!))) - (let ((pred (match-set1 (substring chrs 1 (string-length chrs))))) - (lambda (str k kmatch) - (and (< k (string-length str)) - (not (pred (string-ref str k))) - (nxt str (+ k 1) (cons k kmatch))))) - (let ((pred (match-set1 chrs))) - (lambda (str k kmatch) - (and (< k (string-length str)) - (pred (string-ref str k)) - (nxt str (+ k 1) (cons k kmatch)))))))) - (define (match-* nxt) - (lambda (str k kmatch) - (let ((kmatch (cons k kmatch))) - (let loop ((kk (string-length str))) - (and (>= kk k) - (or (nxt str kk kmatch) - (loop (- kk 1)))))))) - - (let ((matcher - (let recur ((toks (glob:pattern->tokens pat))) - (if (null? toks) - match-end - (let ((pch (or (string=? (car toks) "") - (string-ref (car toks) 0)))) - (case pch - ((#\?) (match-? (recur (cdr toks)))) - ((#\*) (match-* (recur (cdr toks)))) - ((#\[) (match-set (car toks) (recur (cdr toks)))) - (else (match-str (car toks) (recur (cdr toks)))))))))) - (lambda (str) (matcher str 0 '())))) - -(define (glob:caller-with-matches pat proc ch=? ch<=?) - (define (glob:wildcard? pat) - (cond ((string=? pat "") #f) - ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) - (else #f))) - (let* ((toks (glob:pattern->tokens pat)) - (wild? (map glob:wildcard? toks)) - (matcher (glob:make-matcher toks ch=? ch<=?))) - (lambda (str) - (let loop ((inds (matcher str)) - (wild? wild?) - (res '())) - (cond ((not inds) #f) - ((null? wild?) - (apply proc (reverse res))) - ((car wild?) - (loop (cdr inds) - (cdr wild?) - (cons (substring str (car inds) (cadr inds)) res))) - (else - (loop (cdr inds) (cdr wild?) res))))))) - -(define (glob:make-substituter pattern template ch=? ch<=?) - (define (wildcard? pat) - (cond ((string=? pat "") #f) - ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) - (else #f))) - (define (countq val lst) - (do ((lst lst (cdr lst)) - (c 0 (if (eq? val (car lst)) (+ c 1) c))) - ((null? lst) c))) - (let ((tmpl-literals (map (lambda (tok) - (if (wildcard? tok) #f tok)) - (glob:pattern->tokens template))) - (pat-wild? (map wildcard? (glob:pattern->tokens pattern))) - (matcher (glob:make-matcher pattern ch=? ch<=?))) - (or (= (countq #t pat-wild?) (countq #f tmpl-literals)) - (slib:error 'glob:make-substituter - "number of wildcards doesn't match" pattern template)) - (lambda (str) - (let ((indices (matcher str))) - (and indices - (let loop ((inds indices) - (wild? pat-wild?) - (lits tmpl-literals) - (res '())) - (cond - ((null? lits) - (apply string-append (reverse res))) - ((car lits) - (loop inds wild? (cdr lits) (cons (car lits) res))) - ((null? wild?) ;this should never happen. - (loop '() '() lits res)) - ((car wild?) - (loop (cdr inds) (cdr wild?) (cdr lits) - (cons (substring str (car inds) (cadr inds)) - res))) - (else - (loop (cdr inds) (cdr wild?) lits res))))))))) - -;;@body -;;Returns a predicate which returns a non-false value if its string argument -;;matches (the string) @var{pattern}, false otherwise. Filename matching -;;is like -;;@cindex glob -;;@dfn{glob} expansion described the bash manpage, except that names -;;beginning with @samp{.} are matched and @samp{/} characters are not -;;treated specially. -;; -;;These functions interpret the following characters specially in -;;@var{pattern} strings: -;;@table @samp -;;@item * -;;Matches any string, including the null string. -;;@item ? -;;Matches any single character. -;;@item [@dots{}] -;;Matches any one of the enclosed characters. A pair of characters -;;separated by a minus sign (-) denotes a range; any character lexically -;;between those two characters, inclusive, is matched. If the first -;;character following the @samp{[} is a @samp{!} or a @samp{^} then any -;;character not enclosed is matched. A @samp{-} or @samp{]} may be -;;matched by including it as the first or last character in the set. -;;@end table -(define (filename:match?? pattern) - (glob:make-matcher pattern char=? char<=?)) -(define (filename:match-ci?? pattern) - (glob:make-matcher pattern char-ci=? char-ci<=?)) - - -;;@args pattern template -;;Returns a function transforming a single string argument according to -;;glob patterns @var{pattern} and @var{template}. @var{pattern} and -;;@var{template} must have the same number of wildcard specifications, -;;which need not be identical. @var{pattern} and @var{template} may have -;;a different number of literal sections. If an argument to the function -;;matches @var{pattern} in the sense of @code{filename:match??} then it -;;returns a copy of @var{template} in which each wildcard specification is -;;replaced by the part of the argument matched by the corresponding -;;wildcard specification in @var{pattern}. A @code{*} wildcard matches -;;the longest leftmost string possible. If the argument does not match -;;@var{pattern} then false is returned. -;; -;;@var{template} may be a function accepting the same number of string -;;arguments as there are wildcard specifications in @var{pattern}. In -;;the case of a match the result of applying @var{template} to a list -;;of the substrings matched by wildcard specifications will be returned, -;;otherwise @var{template} will not be called and @code{#f} will be returned. -(define (filename:substitute?? pattern template) - (cond ((procedure? template) - (glob:caller-with-matches pattern template char=? char<=?)) - ((string? template) - (glob:make-substituter pattern template char=? char<=?)) - (else - (slib:error 'filename:substitute?? "bad second argument" template)))) -(define (filename:substitute-ci?? pattern template) - (cond ((procedure? template) - (glob:caller-with-matches pattern template char-ci=? char-ci<=?)) - ((string? template) - (glob:make-substituter pattern template char-ci=? char-ci<=?)) - (else - (slib:error 'filename:substitute-ci?? "bad second argument" template)))) - -;;@example -;;((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") -;; "scm_10.html") -;;@result{} "scm5c4_10.htm" -;;((filename:substitute?? "??" "beg?mid?end") "AZ") -;;@result{} "begAmidZend" -;;((filename:substitute?? "*na*" "?NA?") "banana") -;;@result{} "banaNA" -;;((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) -;; "ABZ") -;;@result{} "ZA" -;;@end example - -;;@body -;;@var{str} can be a string or a list of strings. Returns a new string -;;(or strings) similar to @code{str} but with the suffix string @var{old} -;;removed and the suffix string @var{new} appended. If the end of -;;@var{str} does not match @var{old}, an error is signaled. -(define (replace-suffix str old new) - (let* ((f (glob:make-substituter (list "*" old) (list "*" new) - char=? char<=?)) - (g (lambda (st) - (or (f st) - (slib:error 'replace-suffix "suffix doesn't match:" - old st))))) - (if (pair? str) - (map g str) - (g str)))) - -;;@example -;;(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") -;;@result{} "/usr/local/lib/slib/batch.c" -;;@end example - -;;@args proc k -;;@args proc -;;Calls @1 with @2 arguments, strings returned by successive calls to -;;@code{tmpnam}. -;;If @1 returns, then any files named by the arguments to @1 are -;;deleted automatically and the value(s) yielded by the @1 is(are) -;;returned. @2 may be ommited, in which case it defaults to @code{1}. -;; -;;@args proc suffix1 ... -;;Calls @1 with strings returned by successive calls to @code{tmpnam}, -;;each with the corresponding @var{suffix} string appended. -;;If @1 returns, then any files named by the arguments to @1 are -;;deleted automatically and the value(s) yielded by the @1 is(are) -;;returned. -(define (call-with-tmpnam proc . suffi) - (define (do-call paths) - (let ((ans (apply proc paths))) - (for-each (lambda (path) (if (file-exists? path) (delete-file path))) - paths) - ans)) - (cond ((null? suffi) (do-call (list (tmpnam)))) - ((and (= 1 (length suffi)) (number? (car suffi))) - (do ((cnt (if (null? suffi) 0 (+ -1 (car suffi))) (+ -1 cnt)) - (paths '() (cons (tmpnam) paths))) - ((negative? cnt) - (do-call paths)))) - (else (do-call (map (lambda (suffix) (string-append (tmpnam) suffix)) - suffi))))) - - -;;"genwrite.scm" generic write used by pretty-print and truncated-print. -;; Copyright (c) 1991, Marc Feeley -;; Author: Marc Feeley (feeley@iro.umontreal.ca) -;; Distribution restrictions: none - -(define genwrite:newline-str (make-string 1 #\newline)) -;@ -(define (generic-write obj display? width output) - - (define (read-macro? l) - (define (length1? l) (and (pair? l) (null? (cdr l)))) - (let ((head (car l)) (tail (cdr l))) - (case head - ((quote quasiquote unquote unquote-splicing) (length1? tail)) - (else #f)))) - - (define (read-macro-body l) - (cadr l)) - - (define (read-macro-prefix l) - (let ((head (car l)) (tail (cdr l))) - (case head - ((quote) "'") - ((quasiquote) "`") - ((unquote) ",") - ((unquote-splicing) ",@")))) - - (define (out str col) - (and col (output str) (+ col (string-length str)))) - - (define (wr obj col) - - (define (wr-expr expr col) - (if (read-macro? expr) - (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) - (wr-lst expr col))) - - (define (wr-lst l col) - (if (pair? l) - (let loop ((l (cdr l)) - (col (and col (wr (car l) (out "(" col))))) - (cond ((not col) col) - ((pair? l) - (loop (cdr l) (wr (car l) (out " " col)))) - ((null? l) (out ")" col)) - (else (out ")" (wr l (out " . " col)))))) - (out "()" col))) - - (cond ((pair? obj) (wr-expr obj col)) - ((null? obj) (wr-lst obj col)) - ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) - ((boolean? obj) (out (if obj "#t" "#f") col)) - ((number? obj) (out (number->string obj) col)) - ((symbol? obj) (out (symbol->string obj) col)) - ((procedure? obj) (out "#[procedure]" col)) - ((string? obj) (if display? - (out obj col) - (let loop ((i 0) (j 0) (col (out "\"" col))) - (if (and col (< j (string-length obj))) - (let ((c (string-ref obj j))) - (if (or (char=? c #\\) - (char=? c #\")) - (loop j - (+ j 1) - (out "\\" - (out (substring obj i j) - col))) - (loop i (+ j 1) col))) - (out "\"" - (out (substring obj i j) col)))))) - ((char? obj) (if display? - (out (make-string 1 obj) col) - (out (case obj - ((#\space) "space") - ((#\newline) "newline") - (else (make-string 1 obj))) - (out "#\\" col)))) - ((input-port? obj) (out "#[input-port]" col)) - ((output-port? obj) (out "#[output-port]" col)) - ((eof-object? obj) (out "#[eof-object]" col)) - (else (out "#[unknown]" col)))) - - (define (pp obj col) - - (define (spaces n col) - (if (> n 0) - (if (> n 7) - (spaces (- n 8) (out " " col)) - (out (substring " " 0 n) col)) - col)) - - (define (indent to col) - (and col - (if (< to col) - (and (out genwrite:newline-str col) (spaces to 0)) - (spaces (- to col) col)))) - - (define (pr obj col extra pp-pair) - (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines - (let ((result '()) - (left (min (+ (- (- width col) extra) 1) max-expr-width))) - (generic-write obj display? #f - (lambda (str) - (set! result (cons str result)) - (set! left (- left (string-length str))) - (> left 0))) - (if (> left 0) ; all can be printed on one line - (out (reverse-string-append result) col) - (if (pair? obj) - (pp-pair obj col extra) - (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) - (wr obj col))) - - (define (pp-expr expr col extra) - (if (read-macro? expr) - (pr (read-macro-body expr) - (out (read-macro-prefix expr) col) - extra - pp-expr) - (let ((head (car expr))) - (if (symbol? head) - (let ((proc (style head))) - (if proc - (proc expr col extra) - (if (> (string-length (symbol->string head)) - max-call-head-width) - (pp-general expr col extra #f #f #f pp-expr) - (pp-call expr col extra pp-expr)))) - (pp-list expr col extra pp-expr))))) - - ; (head item1 - ; item2 - ; item3) - (define (pp-call expr col extra pp-item) - (let ((col* (wr (car expr) (out "(" col)))) - (and col - (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) - - ; (item1 - ; item2 - ; item3) - (define (pp-list l col extra pp-item) - (let ((col (out "(" col))) - (pp-down l col col extra pp-item))) - - (define (pp-down l col1 col2 extra pp-item) - (let loop ((l l) (col col1)) - (and col - (cond ((pair? l) - (let ((rest (cdr l))) - (let ((extra (if (null? rest) (+ extra 1) 0))) - (loop rest - (pr (car l) (indent col2 col) extra pp-item))))) - ((null? l) - (out ")" col)) - (else - (out ")" - (pr l - (indent col2 (out "." (indent col2 col))) - (+ extra 1) - pp-item))))))) - - (define (pp-general expr col extra named? pp-1 pp-2 pp-3) - - (define (tail1 rest col1 col2 col3) - (if (and pp-1 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) - (tail2 rest col1 col2 col3))) - - (define (tail2 rest col1 col2 col3) - (if (and pp-2 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) - (tail3 rest col1 col2))) - - (define (tail3 rest col1 col2) - (pp-down rest col2 col1 extra pp-3)) - - (let* ((head (car expr)) - (rest (cdr expr)) - (col* (wr head (out "(" col)))) - (if (and named? (pair? rest)) - (let* ((name (car rest)) - (rest (cdr rest)) - (col** (wr name (out " " col*)))) - (tail1 rest (+ col indent-general) col** (+ col** 1))) - (tail1 rest (+ col indent-general) col* (+ col* 1))))) - - (define (pp-expr-list l col extra) - (pp-list l col extra pp-expr)) - - (define (pp-LAMBDA expr col extra) - (pp-general expr col extra #f pp-expr-list #f pp-expr)) - - (define (pp-IF expr col extra) - (pp-general expr col extra #f pp-expr #f pp-expr)) - - (define (pp-COND expr col extra) - (pp-call expr col extra pp-expr-list)) - - (define (pp-CASE expr col extra) - (pp-general expr col extra #f pp-expr #f pp-expr-list)) - - (define (pp-AND expr col extra) - (pp-call expr col extra pp-expr)) - - (define (pp-LET expr col extra) - (let* ((rest (cdr expr)) - (named? (and (pair? rest) (symbol? (car rest))))) - (pp-general expr col extra named? pp-expr-list #f pp-expr))) - - (define (pp-BEGIN expr col extra) - (pp-general expr col extra #f #f #f pp-expr)) - - (define (pp-DO expr col extra) - (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) - - ; define formatting style (change these to suit your style) - - (define indent-general 2) - - (define max-call-head-width 5) - - (define max-expr-width 50) - - (define (style head) - (case head - ((lambda let* letrec define) pp-LAMBDA) - ((if set!) pp-IF) - ((cond) pp-COND) - ((case) pp-CASE) - ((and or) pp-AND) - ((let) pp-LET) - ((begin) pp-BEGIN) - ((do) pp-DO) - (else #f))) - - (pr obj col 0 pp-expr)) - - (if width - (out genwrite:newline-str (pp obj 0)) - (wr obj 0))) - -; (reverse-string-append l) = (apply string-append (reverse l)) -;@ -(define (reverse-string-append l) - - (define (rev-string-append l i) - (if (pair? l) - (let* ((str (car l)) - (len (string-length str)) - (result (rev-string-append (cdr l) (+ i len)))) - (let loop ((j 0) (k (- (- (string-length result) i) len))) - (if (< j len) - (begin - (string-set! result k (string-ref str j)) - (loop (+ j 1) (+ k 1))) - result))) - (make-string i))) - - (rev-string-append l 0)) - - -;;;; "printf.scm" Implementation of standard C functions for Scheme -;;; Copyright (C) 1991-1993, 1996, 1999-2001 Aubrey Jaffer and Radey Shouman. -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warranty or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'string-case) -(require-if 'compiling 'generic-write) - -;; Determine the case of digits > 9. We assume this to be constant. -(define stdio:hex-upper-case? (string=? "-F" (number->string -15 16))) - -;; Parse the output of NUMBER->STRING and pass the results to PROC. -;; PROC takes (SIGN-CHARACTER DIGIT-STRING EXPONENT-INTEGER . IMAGPART) -;; SIGN-CHAR will be either #\+ or #\-, DIGIT-STRING will always begin -;; with a "0", after which a decimal point should be understood. -;; If STR denotes a number with imaginary part not exactly zero, -;; 3 additional elements for the imaginary part are passed. -;; If STR cannot be parsed, return #F without calling PROC. -(define (stdio:parse-float str proc) - (let ((n (string-length str))) - (define (parse-error) #f) - (define (prefix i cont) - (if (and (< i (- n 1)) - (char=? #\# (string-ref str i))) - (case (string-ref str (+ i 1)) - ((#\d #\i #\e) (prefix (+ i 2) cont)) - ((#\.) (cont i)) - (else (parse-error))) - (cont i))) - (define (sign i cont) - (if (< i n) - (let ((c (string-ref str i))) - (case c - ((#\- #\+) (cont (+ i 1) c)) - (else (cont i #\+)))))) - (define (digits i cont) - (do ((j i (+ j 1))) - ((or (>= j n) - (not (or (char-numeric? (string-ref str j)) - (char=? #\# (string-ref str j))))) - (cont j (if (= i j) "0" (substring str i j)))))) - (define (point i cont) - (if (and (< i n) - (char=? #\. (string-ref str i))) - (cont (+ i 1)) - (cont i))) - (define (exp i cont) - (cond ((>= i n) (cont i 0)) - ((memv (string-ref str i) - '(#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L)) - (sign (+ i 1) - (lambda (i sgn) - (digits i - (lambda (i digs) - (cont i - (if (char=? #\- sgn) - (- (string->number digs)) - (string->number digs)))))))) - (else (cont i 0)))) - (define (real i cont) - (prefix - i - (lambda (i) - (sign - i - (lambda (i sgn) - (digits - i - (lambda (i idigs) - (point - i - (lambda (i) - (digits - i - (lambda (i fdigs) - (exp i - (lambda (i ex) - (let* ((digs (string-append "0" idigs fdigs)) - (ndigs (string-length digs))) - (let loop ((j 1) - (ex (+ ex (string-length idigs)))) - (cond ((>= j ndigs) ;; Zero - (cont i sgn "0" 1)) - ((char=? #\0 (string-ref digs j)) - (loop (+ j 1) (- ex 1))) - (else - (cont i sgn - (substring digs (- j 1) ndigs) - ex)))))))))))))))))) - (real 0 - (lambda (i sgn digs ex) - (cond - ((= i n) (proc sgn digs ex)) - ((memv (string-ref str i) '(#\+ #\-)) - (real i - (lambda (j im-sgn im-digs im-ex) - (if (and (= j (- n 1)) - (char-ci=? #\i (string-ref str j))) - (proc sgn digs ex im-sgn im-digs im-ex) - (parse-error))))) - ((eqv? (string-ref str i) #\@) - ;; Polar form: No point in parsing the angle ourselves, - ;; since some transcendental approximation is unavoidable. - (let ((num (string->number str))) - (if num - (stdio:parse-float - (number->string (real-part num)) - (lambda (sgn digs ex) - (stdio:parse-float - (number->string (imag-part num)) - (lambda (im-sgn im-digs im-ex) - (proc sgn digs ex im-sgn im-digs im-ex))))) - (parse-error)))) - (else #f)))))) - -;; STR is a digit string representing a floating point mantissa, STR must -;; begin with "0", after which a decimal point is understood. -;; The output is a digit string rounded to NDIGS digits after the decimal -;; point implied between chars 0 and 1. -;; If STRIP-0S is not #F then trailing zeros will be stripped from the result. -;; In this case, STRIP-0S should be the minimum number of digits required -;; after the implied decimal point. -(define (stdio:round-string str ndigs strip-0s) - (let* ((n (- (string-length str) 1)) - (res - (cond ((< ndigs 0) "") - ((= n ndigs) str) - ((< n ndigs) - (let ((padlen (max 0 (- (or strip-0s ndigs) n)))) - (if (zero? padlen) - str - (string-append str - (make-string padlen - (if (char-numeric? - (string-ref str n)) - #\0 #\#)))))) - (else - (let ((res (substring str 0 (+ ndigs 1))) - (dig (lambda (i) - (let ((c (string-ref str i))) - (if (char-numeric? c) - (string->number (string c)) - 0))))) - (let ((ldig (dig (+ 1 ndigs)))) - (if (or (> ldig 5) - (and (= ldig 5) - (let loop ((i (+ 2 ndigs))) - (if (> i n) - (odd? (dig ndigs)) - (if (zero? (dig i)) - (loop (+ i 1)) - #t))))) - (let inc! ((i ndigs)) - (let ((d (dig i))) - (if (< d 9) - (string-set! res i - (string-ref - (number->string (+ d 1)) 0)) - (begin - (string-set! res i #\0) - (inc! (- i 1)))))))) - res))))) - (if strip-0s - (let loop ((i (- (string-length res) 1))) - (if (or (<= i strip-0s) - (not (char=? #\0 (string-ref res i)))) - (substring res 0 (+ i 1)) - (loop (- i 1)))) - res))) - -(define (stdio:iprintf out format-string . args) - (cond - ((not (equal? "" format-string)) - (let ((pos -1) - (fl (string-length format-string)) - (fc (string-ref format-string 0))) - - (define (advance) - (set! pos (+ 1 pos)) - (cond ((>= pos fl) (set! fc #f)) - (else (set! fc (string-ref format-string pos))))) - (define (must-advance) - (set! pos (+ 1 pos)) - (cond ((>= pos fl) (incomplete)) - (else (set! fc (string-ref format-string pos))))) - (define (end-of-format?) - (>= pos fl)) - (define (incomplete) - (slib:error 'printf "conversion specification incomplete" - format-string)) - (define (wna) - (slib:error 'printf "wrong number of arguments" - (length args) - format-string)) - (define (out* strs) - (if (string? strs) (out strs) - (let out-loop ((strs strs)) - (or (null? strs) - (and (out (car strs)) - (out-loop (cdr strs))))))) - - (let loop ((args args)) - (advance) - (cond - ((end-of-format?) - ;;(or (null? args) (wna)) ;Extra arguments are *not* a bug. - ) - ((eqv? #\\ fc);;Emulating C strings may not be a good idea. - (must-advance) - (and (case fc - ((#\n #\N) (out #\newline)) - ((#\t #\T) (out slib:tab)) - ;;((#\r #\R) (out #\return)) - ((#\f #\F) (out slib:form-feed)) - ((#\newline) #t) - (else (out fc))) - (loop args))) - ((eqv? #\% fc) - (must-advance) - (let ((left-adjust #f) ;- - (signed #f) ;+ - (blank #f) - (alternate-form #f) ;# - (leading-0s #f) ;0 - (width 0) - (precision -1) - (type-modifier #f) - (read-format-number - (lambda () - (cond - ((eqv? #\* fc) ; GNU extension - (must-advance) - (let ((ans (car args))) - (set! args (cdr args)) - ans)) - (else - (do ((c fc fc) - (accum 0 (+ (* accum 10) - (string->number (string c))))) - ((not (char-numeric? fc)) accum) - (must-advance))))))) - (define (pad pre . strs) - (let loop ((len (string-length pre)) - (ss strs)) - (cond ((>= len width) (cons pre strs)) - ((null? ss) - (cond (left-adjust - (cons pre - (append strs - (list (make-string - (- width len) #\space))))) - (leading-0s - (cons pre - (cons (make-string (- width len) #\0) - strs))) - (else - (cons (make-string (- width len) #\space) - (cons pre strs))))) - (else - (loop (+ len (string-length (car ss))) (cdr ss)))))) - (define integer-convert - (lambda (s radix fixcase) - (cond ((not (negative? precision)) - (set! leading-0s #f) - (if (and (zero? precision) - (eqv? 0 s)) - (set! s "")))) - (set! s (cond ((symbol? s) (symbol->string s)) - ((number? s) (number->string s radix)) - ((or (not s) (null? s)) "0") - ((string? s) s) - (else "1"))) - (if fixcase (set! s (fixcase s))) - (let ((pre (cond ((equal? "" s) "") - ((eqv? #\- (string-ref s 0)) - (set! s (substring s 1 (string-length s))) - "-") - (signed "+") - (blank " ") - (alternate-form - (case radix - ((8) "0") - ((16) "0x") - (else ""))) - (else "")))) - (pad pre - (if (< (string-length s) precision) - (make-string - (- precision (string-length s)) #\0) - "") - s)))) - (define (float-convert num fc) - (define (f digs exp strip-0s) - (let ((digs (stdio:round-string - digs (+ exp precision) (and strip-0s exp)))) - (cond ((>= exp 0) - (let* ((i0 (cond ((zero? exp) 0) - ((char=? #\0 (string-ref digs 0)) 1) - (else 0))) - (i1 (max 1 (+ 1 exp))) - (idigs (substring digs i0 i1)) - (fdigs (substring digs i1 - (string-length digs)))) - (cons idigs - (if (and (string=? fdigs "") - (not alternate-form)) - '() - (list "." fdigs))))) - ((zero? precision) - (list (if alternate-form "0." "0"))) - ((and strip-0s (string=? digs "") (list "0"))) - (else - (list "0." - (make-string (min precision (- -1 exp)) #\0) - digs))))) - (define (e digs exp strip-0s) - (let* ((digs (stdio:round-string - digs (+ 1 precision) (and strip-0s 0))) - (istrt (if (char=? #\0 (string-ref digs 0)) 1 0)) - (fdigs (substring - digs (+ 1 istrt) (string-length digs))) - (exp (if (zero? istrt) exp (- exp 1)))) - (list - (substring digs istrt (+ 1 istrt)) - (if (and (string=? fdigs "") (not alternate-form)) - "" ".") - fdigs - (if (char-upper-case? fc) "E" "e") - (if (negative? exp) "-" "+") - (if (< -10 exp 10) "0" "") - (number->string (abs exp))))) - (define (g digs exp) - (let ((strip-0s (not alternate-form))) - (set! alternate-form #f) - (cond ((<= (- 1 precision) exp precision) - (set! precision (- precision exp)) - (f digs exp strip-0s)) - (else - (set! precision (- precision 1)) - (e digs exp strip-0s))))) - (define (k digs exp sep) - (let* ((units '#("y" "z" "a" "f" "p" "n" "u" "m" "" - "k" "M" "G" "T" "P" "E" "Z" "Y")) - (base 8) ;index of "" - (uind (let ((i (if (negative? exp) - (quotient (- exp 3) 3) - (quotient (- exp 1) 3)))) - (and - (< -1 (+ i base) (vector-length units)) - i)))) - (cond (uind - (set! exp (- exp (* 3 uind))) - (set! precision (max 0 (- precision exp))) - (append - (f digs exp #f) - (list sep - (vector-ref units (+ uind base))))) - (else - (g digs exp))))) - - (cond ((negative? precision) - (set! precision 6)) - ((and (zero? precision) - (char-ci=? fc #\g)) - (set! precision 1))) - (let* ((str - (cond ((number? num) - (number->string (exact->inexact num))) - ((string? num) num) - ((symbol? num) (symbol->string num)) - (else "???")))) - (define (format-real signed? sgn digs exp . rest) - (if (null? rest) - (cons - (if (char=? #\- sgn) "-" - (if signed? "+" (if blank " " ""))) - (case fc - ((#\e #\E) (e digs exp #f)) - ((#\f #\F) (f digs exp #f)) - ((#\g #\G) (g digs exp)) - ((#\k) (k digs exp "")) - ((#\K) (k digs exp " ")))) - (append (format-real signed? sgn digs exp) - (apply format-real #t rest) - '("i")))) - (or (stdio:parse-float str - (lambda (sgn digs expon . imag) - (apply pad - (apply format-real - signed - sgn digs expon imag)))) - (pad "???")))) - (do () - ((case fc - ((#\-) (set! left-adjust #t) #f) - ((#\+) (set! signed #t) #f) - ((#\ ) (set! blank #t) #f) - ((#\#) (set! alternate-form #t) #f) - ((#\0) (set! leading-0s #t) #f) - (else #t))) - (must-advance)) - (cond (left-adjust (set! leading-0s #f))) - (cond (signed (set! blank #f))) - - (set! width (read-format-number)) - (cond ((negative? width) - (set! left-adjust #t) - (set! width (- width)))) - (cond ((eqv? #\. fc) - (must-advance) - (set! precision (read-format-number)))) - (case fc ;Ignore these specifiers - ((#\l #\L #\h) - (set! type-modifier fc) - (must-advance))) - - ;;At this point fc completely determines the format to use. - (if (null? args) - (if (memv (char-downcase fc) - '(#\c #\s #\a #\d #\i #\u #\o #\x #\b - #\f #\e #\g #\k)) - (wna))) - - (case fc - ;; only - is allowed between % and c - ((#\c #\C) ; C is enhancement - (and (out (string (car args))) (loop (cdr args)))) - - ;; only - flag, no type-modifiers - ((#\s #\S) ; S is enhancement - (let ((s (cond - ((symbol? (car args)) (symbol->string (car args))) - ((not (car args)) "(NULL)") - (else (car args))))) - (cond ((not (or (negative? precision) - (>= precision (string-length s)))) - (set! s (substring s 0 precision)))) - (and - (out* (cond - ((<= width (string-length s)) s) - (left-adjust - (list - s (make-string (- width (string-length s)) #\ ))) - (else - (list - (make-string (- width (string-length s)) - (if leading-0s #\0 #\ )) - s)))) - (loop (cdr args))))) - - ;; SLIB extension - ((#\a #\A) ;#\a #\A are pretty-print - (require 'generic-write) - (let ((os "") (pr precision)) - (generic-write - (car args) (not alternate-form) #f - (cond ((and left-adjust (negative? pr)) - (set! pr 0) - (lambda (s) - (set! pr (+ pr (string-length s))) - (out s))) - (left-adjust - (lambda (s) - (define sl (- pr (string-length s))) - (set! pr (cond ((negative? sl) - (out (substring s 0 pr)) 0) - (else (out s) sl))) - (positive? sl))) - ((negative? pr) - (set! pr width) - (lambda (s) - (set! pr (- pr (string-length s))) - (cond ((not os) (out s)) - ((negative? pr) - (out os) - (set! os #f) - (out s)) - (else (set! os (string-append os s)))) - #t)) - (else - (lambda (s) - (define sl (- pr (string-length s))) - (cond ((negative? sl) - (set! os (string-append - os (substring s 0 pr)))) - (else (set! os (string-append os s)))) - (set! pr sl) - (positive? sl))))) - (cond ((and left-adjust (negative? precision)) - (cond - ((> width pr) (out (make-string (- width pr) #\ ))))) - (left-adjust - (cond - ((> width (- precision pr)) - (out (make-string (- width (- precision pr)) #\ ))))) - ((not os)) - ((<= width (string-length os)) (out os)) - (else (and (out (make-string - (- width (string-length os)) #\ )) - (out os))))) - (loop (cdr args))) - ((#\d #\D #\i #\I #\u #\U) - (and (out* (integer-convert (car args) 10 #f)) - (loop (cdr args)))) - ((#\o #\O) - (and (out* (integer-convert (car args) 8 #f)) - (loop (cdr args)))) - ((#\x) - (and (out* (integer-convert - (car args) 16 - (if stdio:hex-upper-case? string-downcase #f))) - (loop (cdr args)))) - ((#\X) - (and (out* (integer-convert - (car args) 16 - (if stdio:hex-upper-case? #f string-upcase))) - (loop (cdr args)))) - ((#\b #\B) - (and (out* (integer-convert (car args) 2 #f)) - (loop (cdr args)))) - ((#\%) (and (out #\%) (loop args))) - ((#\f #\F #\e #\E #\g #\G #\k #\K) - (and (out* (float-convert (car args) fc)) (loop (cdr args)))) - (else - (cond - ((end-of-format?) (incomplete)) - (else (and (out #\%) (out fc) (out #\?) (loop args)))))))) - (else (and (out fc) (loop args))))))))) -;@ -(define (fprintf port format . args) - (let ((cnt 0)) - (apply stdio:iprintf - (lambda (x) - (cond ((string? x) - (set! cnt (+ (string-length x) cnt)) (display x port) #t) - (else (set! cnt (+ 1 cnt)) (display x port) #t))) - format args) - cnt)) -;@ -(define (printf format . args) - (apply stdio:fprintf (current-output-port) format args)) -;@ -(define (sprintf str format . args) - (let* ((cnt 0) - (s (cond ((string? str) str) - ((number? str) (make-string str)) - ((not str) (make-string 100)) - (else (slib:error 'sprintf "first argument not understood" - str)))) - (end (string-length s))) - (apply stdio:iprintf - (lambda (x) - (cond ((string? x) - (if (or str (>= (- end cnt) (string-length x))) - (do ((lend (min (string-length x) (- end cnt))) - (i 0 (+ i 1))) - ((>= i lend)) - (string-set! s cnt (string-ref x i)) - (set! cnt (+ cnt 1))) - (let () - (set! s (string-append (substring s 0 cnt) x)) - (set! cnt (string-length s)) - (set! end cnt)))) - ((and str (>= cnt end))) - (else (cond ((and (not str) (>= cnt end)) - (set! s (string-append s (make-string 100))) - (set! end (string-length s)))) - (string-set! s cnt (if (char? x) x #\?)) - (set! cnt (+ cnt 1)))) - (not (and str (>= cnt end)))) - format - args) - (cond ((string? str) cnt) - ((eqv? end cnt) s) - (else (substring s 0 cnt))))) - -(define stdio:fprintf fprintf) - -;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789"))) diff --git a/po/POTFILES.in b/po/POTFILES.in index f0ab5999b9..47fd1c8bcb 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -694,7 +694,6 @@ libgnucash/gnc-module/example/gncmod-example.c libgnucash/gnc-module/gnc-module.c libgnucash/gnc-module/gnc-module.scm libgnucash/scm/price-quotes.scm -libgnucash/scm/printf.scm libgnucash/scm/string.scm libgnucash/scm/utilities.scm libgnucash/tax/us/de_DE.scm