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

reverted borken version.

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@4274 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Robert Graham Merkel 2001-05-24 07:26:20 +00:00
parent 096a3efbf0
commit 10b47deeb9
1 changed files with 137 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
lib/srfi/srfi-19.scm
View File

@ -27,10 +27,12 @@
;; functions that do more work in a "chunk".
(define-module (srfi srfi-19)
:use-module (srfi srfi-6)
:use-module (ice-9 syncase)
:use-module (srfi srfi-8)
:use-module (srfi srfi-9)
:export (;; Constants
:use-module (srfi srfi-9))
(export
;; Constants
time-duration
time-monotonic
time-process
@ -116,9 +118,19 @@
time-utc->time-tai!
;; Date to string/string to date converters.
date->string
string->date))
string->date)
(cond-expand-provide (current-module) '(srfi-19))
;; 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)
@ -215,7 +227,7 @@
(let loop ((line (read-line port)))
(if (not (eq? line eof))
(begin
(let* ((data (read (open-input-string
(let* ((data (read (priv:open-input-string
(string-append "(" line ")"))))
(year (car data))
(jd (cadddr (cdr data)))
@ -378,7 +390,7 @@
;; (priv:current-time-ms-time time-gc current-gc-milliseconds))
(define (current-time . clock-type)
(let ((clock-type (if (null? clock-type) time-utc (car 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))
@ -393,7 +405,7 @@
;; This will be implementation specific.
(define (time-resolution . clock-type)
(let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
(let ((clock-type (:optional clock-type time-utc)))
(case clock-type
((time-tai) 1000)
((time-utc) 1000)
@ -565,11 +577,8 @@
;; -- Date Structures
;; FIXME: to be really safe, perhaps we should normalize the
;; seconds/nanoseconds/minutes coming in to make-date...
(define-record-type date
(make-date nanosecond second minute
(make-date-unnormalized nanosecond second minute
hour day month
year
zone-offset)
@ -583,28 +592,6 @@
(year date-year)
(zone-offset date-zone-offset))
(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)
(
;; gives the julian day which starts at noon.
(define (priv:encode-julian-day-number day month year)
(let* ((a (quotient (- 14 month) 12))
@ -625,7 +612,7 @@
;; gives the seconds/date/month/year
(define (priv:decode-julian-day-number jdn)
(let* ((days (inexact->exact (truncate jdn)))
(let* ((days (truncate jdn))
(a (+ days 32044))
(b (quotient (+ (* 4 a) 3) 146097))
(c (- a (quotient (* 146097 b) 4)))
@ -659,7 +646,7 @@
(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 (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))
(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)
@ -668,9 +655,8 @@
(call-with-values (lambda () (priv:decode-julian-day-number jdn))
(lambda (secs date month year)
(let* ((int-secs (inexact->exact (floor secs)))
(hours (quotient int-secs (* 60 60)))
(rem (remainder int-secs (* 60 60)))
(let* ((hours (quotient secs (* 60 60)))
(rem (remainder secs (* 60 60)))
(minutes (quotient rem 60))
(seconds (remainder rem 60)))
(make-date (time-nanosecond time)
@ -685,7 +671,7 @@
(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 (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))
(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)))
@ -713,7 +699,7 @@
(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 (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))
(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)))
@ -810,9 +796,8 @@
7))
(define (current-date . tz-offset)
(time-utc->date
(current-time time-utc)
(if (null? tz-offset) (priv:local-tz-offset) (car 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)
@ -897,11 +882,11 @@
(time-utc->time-monotonic! (julian-day->time-utc jdn)))
(define (julian-day->date jdn . tz-offset)
(let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car 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 (if (null? tz-offset) (priv:local-tz-offset) (car 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)
@ -1227,10 +1212,11 @@
(define (date->string date . format-string)
(let ((str-port (open-output-string))
(fmt-str (if (null? format-string) "~c" (car 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)))
(get-output-string str-port)))))
(define (priv:char->int ch)
(case ch
@ -1335,18 +1321,18 @@
;; looking at a char, read the char string, run thru indexer, return index
(define (priv:locale-reader port indexer)
(let ((string-port (open-output-string)))
(define (read-char-string)
(define (read-char-string result)
(let ((ch (peek-char port)))
(if (char-alphabetic? ch)
(begin (write-char (read-char port) string-port)
(read-char-string))
(get-output-string string-port))))
(let* ((str (read-char-string))
(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))))))
(list "Invalid string for " indexer)))))
(define (priv:make-locale-reader indexer)
(lambda (port)
@ -1496,7 +1482,7 @@
0
template-string
(string-length template-string)
(open-input-string input-string)
(priv:open-input-string input-string)
template-string)
(if (priv:date-ok? newdate)
newdate