Changeset 13970 in project


Ignore:
Timestamp:
03/27/09 17:33:43 (11 years ago)
Author:
Kon Lovett
Message:

Renamed ->fixnum. Common error routines. Added 'time-period-compare'.

Location:
release/3/srfi-19/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/3/srfi-19/trunk/srfi-19-common.scm

    r13899 r13970  
    3333(define-inline (%fxabs x) (if (fx< x 0) (fxneg x) x))
    3434
    35 #;(define-inline (%inexact-integer? x) (and (inexact? x) (integer? x)))
    36 
    3735;; For storage savings since some aritmetic routines do not
    3836;; return fixnums when possible.
     
    4846; Number MUST be a fixnum or flonum
    4947
    50 (define-inline (%->fixnum x)
    51   (if (fixnum? x) x (##sys#double->number x))
    52   #;(inexact->exact x) )
     48(define-inline (%number->maybe-fixnum x)
     49  (if (fixnum? x) x (##sys#double->number x)) )
    5350
    5451; When domain is integer and range is flonum-integer
     
    5653; Others returned
    5754
    58 (define-inline (%->fixnum* x)
    59   (if (##sys#integer? x) (%->fixnum x) x)
    60   #;(if (%inexact-integer? x) (%->fixnum x) x) )
     55(define-inline (%maybe-integer->maybe-fixnum x)
     56  (if (##sys#integer? x) (%number->maybe-fixnum x) x) )
  • release/3/srfi-19/trunk/srfi-19-core.scm

    r13958 r13970  
    292292(include "srfi-19-common")
    293293
     294;;;
     295
     296(define (error-invalid-type loc typ obj)
     297  (error loc (string-append "invalid " typ) obj) )
     298
     299(define (error-invalid-clock-type loc obj)
     300  (error-invalid-type loc "clock type" obj) )
     301
     302(define (error-invalid-time-type loc obj)
     303  (error-invalid-type loc "time type" obj) )
     304
     305(define (error-invalid-timezone-offset loc obj)
     306  (error-invalid-type loc "timezone offset" obj) )
     307
     308(define (error-invalid-nanoseconds loc obj)
     309  (error-invalid-type loc "nanoseconds" obj) )
     310
     311(define (error-invalid-seconds loc obj)
     312  (error-invalid-type loc "seconds" obj) )
     313
     314(define (error-invalid-minutes loc obj)
     315  (error-invalid-type loc "minutes" obj) )
     316
     317(define (error-invalid-hours loc obj)
     318  (error-invalid-type loc "hours" obj) )
     319
     320(define (error-invalid-day loc obj)
     321  (error-invalid-type loc "day" obj) )
     322
     323(define (error-invalid-month loc obj)
     324  (error-invalid-type loc "month" obj) )
     325
     326(define (error-invalid-year loc obj)
     327  (error-invalid-type loc "year" obj) )
     328
     329(define (error-invalid-timezone-components loc obj)
     330  (error-invalid-type loc "timezone components" obj) )
     331
     332(define (error-invalid-timezone-name loc obj)
     333  (error-invalid-type loc "timezone name" obj) )
     334
     335(define (error-incompatible-time-types loc timtyp1 timtyp2)
     336  (error loc "incompatible time types" timtyp1 timtyp2) )
     337
     338(define (error-compare-dates-w-diff-tz loc dat1 dat2)
     339  (error loc "cannot compare dates from different time-zones" dat1 dat2) )
     340
     341;;
     342
     343(define-inline (%check-number loc obj nam)
     344  (unless (or (fixnum? obj) (flonum? obj))
     345    (error-invalid-type loc nam obj) ) )
     346
    294347;;; Timing Routines
    295348
     
    395448
    396449  (define (read-data)
    397     (let loop ((lst '()))
     450    (let loop ((ls '()))
    398451       (let ((line (read-line)))
    399          (if (eof-object? line) lst
     452         (if (eof-object? line) ls
    400453             (let ((data (with-input-from-string (conc #\( line #\)) read)))
    401454               (let ((year (car data))
    402455                     (jd   (cadddr (cdr data)))
    403456                     (secs (cadddr (cdddr data))))
    404                  (loop (if (< year FIRST-LEAP-YEAR) lst
    405                            (cons (cons (convert-jd jd) (convert-sec secs)) lst))) ) ) ) ) ) )
     457                 (loop (if (< year FIRST-LEAP-YEAR) ls
     458                           (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
    406459
    407460      (with-input-from-port (open-input-file flnm) read-data) )
     
    422475(define (read-leap-second-table flnm)
    423476  (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
    424   (set! tm:second-before-leap-second-table (tm:calc-second-before-leap-second-table tm:leap-second-table)) )
     477  (set! tm:second-before-leap-second-table
     478        (tm:calc-second-before-leap-second-table tm:leap-second-table)) )
    425479
    426480;; Macros to inline the leap-second-delta algorithm
    427481
    428482; 'leap-second-item' is like the 'it' in the anaphoric 'if'
    429 (define-macro ($find-leap-second-delta ?secs ?lst ?tst)
    430   (let ((lstvar (gensym)))
    431     `(let loop ((,lstvar ,?lst))
    432        (if (null? ,lstvar) 0
    433            (let ((leap-second-item (car ,lstvar)))
     483(define-macro ($find-leap-second-delta ?secs ?ls ?tst)
     484  (let ((lsvar (gensym)))
     485    `(let loop ((,lsvar ,?ls))
     486       (if (null? ,lsvar) 0
     487           (let ((leap-second-item (car ,lsvar)))
    434488             (if ,?tst (cdr leap-second-item)
    435                  (loop (cdr ,lstvar)) ) ) ) ) ) )
     489                 (loop (cdr ,lsvar)) ) ) ) ) ) )
    436490
    437491(define-macro ($leap-second-delta ?secs ?tst)
     
    464518;;
    465519
     520(define-inline (%memq? obj ls) (%->boolean (memq obj ls)))
     521
    466522(define (time-type? obj)
    467   (case obj
    468     ((time-monotonic time-utc time-tai time-gc time-duration time-process time-thread) #t)
    469     (else #f) ) )
     523  (%memq? obj '(time-monotonic time-utc time-tai time-gc time-duration time-process time-thread)) )
    470524
    471525(define (clock-time-type? obj)
    472   (case obj
    473     ((time-monotonic time-tai time-utc) #t)
    474     (else #f) ) )
     526  (%memq? obj '(time-monotonic time-tai time-utc)) )
    475527
    476528;;
     
    485537(define (tm:check-time-type loc obj)
    486538  (unless (time-type? obj)
    487     (error loc "invalid time type" obj) ) )
     539    (error-invalid-time-type loc obj) ) )
    488540
    489541;; There are 3 kinds of time record procedures:
     
    505557(define tm:time-type %time-type)
    506558
    507 (define (tm:make-time timtyp ns sec) (%make-time timtyp (%->fixnum ns) (%->fixnum* sec)))
    508 
    509 (define (tm:set-time-nanosecond! tim ns) (%set-time-nanosecond! tim (%->fixnum ns)))
    510 
    511 (define (tm:set-time-second! tim sec) (%set-time-second! tim (%->fixnum* sec)))
     559(define (tm:make-time timtyp ns sec)
     560  (%make-time timtyp (%number->maybe-fixnum ns) (%maybe-integer->maybe-fixnum sec)) )
     561
     562(define (tm:set-time-nanosecond! tim ns)
     563  (%set-time-nanosecond! tim (%number->maybe-fixnum ns)) )
     564
     565(define (tm:set-time-second! tim sec)
     566  (%set-time-second! tim (%maybe-integer->maybe-fixnum sec)) )
    512567
    513568;;
     
    532587(define (tm:check-time-has-type loc tim timtyp)
    533588  (unless (eq? timtyp (%time-type tim))
    534     (error loc "incompatible time types" (%time-type tim) timtyp) ) )
     589    (error-incompatible-time-types loc (%time-type tim) timtyp) ) )
    535590
    536591(define (tm:check-time-and-type loc tim timtyp)
     
    544599(define (tm:check-time-nanoseconds loc obj)
    545600  (unless (and (fixnum? obj) (fx<= 0 obj) (fx< obj NS/S))
    546     (error loc "invalid nanoseconds" obj)) )
    547 
    548 (define (tm:check-time-seconds loc obj)
    549   (unless (fixnum? obj)
    550     (error loc "invalid seconds" obj) ) )
     601    (error-invalid-nanoseconds loc obj)  ) )
     602
     603(define (tm:check-time-seconds loc obj) (%check-number loc obj "seconds"))
    551604
    552605(define (tm:check-time-elements loc obj1 obj2 obj3)
     
    583636                (hours 0) (minutes 0) (seconds 0)
    584637                (milliseconds 0) (microseconds 0) (nanoseconds 0))
     638  #;(%check-number 'make-duration days "days")
     639  #;(%check-number 'make-duration hours "hours")
     640  #;(%check-number 'make-duration minutes "minutes")
     641  #;(%check-number 'make-duration seconds "seconds")
     642  #;(%check-number 'make-duration milliseconds "milliseconds")
     643  #;(%check-number 'make-duration microseconds "microseconds")
     644  #;(%check-number 'make-duration nanoseconds "nanoseconds")
    585645  (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    586646        (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)))
    587647    (receive (ns sec) (tm:split-nanoseconds nanos)
    588       (make-time 'time-duration ns (+ secs sec)) ) ) )
     648      (let ((sec (+ secs sec)))
     649        (tm:check-time-elements 'make-duration 'time-duration ns sec)
     650        (tm:make-time 'time-duration ns sec) ) ) ) )
    589651
    590652(define (copy-time tim) (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)))
     
    593655;; The type of time default is 'time-duration.
    594656
    595 (define (seconds->time/type sec . timtyp)
    596   (let ((tsec (truncate sec)))
    597     (make-time
    598      (optional timtyp 'time-duration)
    599      (round (abs (* (- (exact->inexact sec) tsec) NS/S)))
    600      tsec) ) )
     657(define (seconds->time/type sec . args)
     658  (let-optionals args ((timtyp 'time-duration))
     659    (let* ((tsec (truncate sec))
     660           (ns (round (abs (* (- (exact->inexact sec) tsec) NS/S)))) )
     661      (tm:check-time-elements 'seconds->time/type timtyp ns tsec)
     662      (tm:make-time timtyp ns tsec) ) ) )
    601663
    602664;; Time record-type operations
     
    639701(define (nanoseconds->time ns . args)
    640702  (let-optionals args ((timtyp 'time-duration))
    641     (tm:check-time-type 'nanoseconds->time timtyp)
    642703    (receive (ns sec) (tm:split-nanoseconds ns)
     704      (tm:check-time-elements 'nanoseconds->time timtyp ns sec)
    643705      (tm:make-time timtyp ns sec) ) ) )
    644706
    645 (define (nanoseconds->seconds ns)
    646   (/ ns NS/S) )
     707(define (nanoseconds->seconds ns) (/ ns NS/S))
    647708
    648709(define (time->milliseconds tim)
     
    652713(define (milliseconds->time ms . args)
    653714  (let-optionals args ((timtyp 'time-duration))
    654     (tm:check-time-type 'milliseconds->time timtyp)
    655     (tm:make-time timtyp (fx* (remainder ms MS/S) NS/MS) (quotient ms MS/S)) ) )
     715    (let ((ns (fx* (remainder ms MS/S) NS/MS))
     716          (sec (quotient ms MS/S)) )
     717      (tm:check-time-elements 'milliseconds->time timtyp ns sec)
     718      (tm:make-time timtyp ns sec) ) ) )
    656719
    657720(define (milliseconds->seconds ms) (/ (exact->inexact ms) MS/S))
     
    757820
    758821(define (tm:time-max tim . rest)
    759   (let loop ((acc tim) (lst rest))
    760     (if (null? lst) acc
    761         (let ((tim (car lst)))
    762           (loop (if (tm:time<? acc tim) tim acc) (cdr lst)))) ) )
     822  (let loop ((acc tim) (ls rest))
     823    (if (null? ls) acc
     824        (let ((tim (car ls)))
     825          (loop (if (tm:time<? acc tim) tim acc) (cdr ls)))) ) )
    763826
    764827(define (tm:time-min tim . rest)
    765   (let loop ((acc tim) (lst rest))
    766     (if (null? lst) acc
    767         (let ((tim (car lst)))
    768           (loop (if (tm:time>? acc tim) tim acc) (cdr lst)))) ) )
     828  (let loop ((acc tim) (ls rest))
     829    (if (null? ls) acc
     830        (let ((tim (car ls)))
     831          (loop (if (tm:time>? acc tim) tim acc) (cdr ls)))) ) )
    769832
    770833(define (time-compare tim1 tim2)
     
    10371100(define (make-timezone-locale dstf tzc)
    10381101  (unless (timezone-components? tzc)
    1039     (error 'make-timezone-locale "invalid timezone components" tzc) )
     1102    (error-invalid-timezone-components 'make-timezone-locale tzc) )
    10401103  (set-timezone-component! tzc 'dst? (%->boolean dstf))
    10411104  tzc )
     
    11091172;;
    11101173
    1111 (define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (%->fixnum x)))
    1112 
    1113 (define (tm:date-second-set! dat x) (%date-second-set! dat (%->fixnum x)))
    1114 
    1115 (define (tm:date-minute-set! dat x) (%date-minute-set! dat (%->fixnum x)))
    1116 
    1117 (define (tm:date-hour-set! dat x) (%date-hour-set! dat (%->fixnum x)))
    1118 
    1119 (define (tm:date-day-set! dat x) (%date-day-set! dat (%->fixnum x)))
    1120 
    1121 (define (tm:date-month-set! dat x) (%date-month-set! dat (%->fixnum x)))
    1122 
    1123 (define (tm:date-year-set! dat x) (%date-year-set! dat (%->fixnum x)))
    1124 
    1125 (define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (%->fixnum x)))
     1174(define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (%number->maybe-fixnum x)))
     1175
     1176(define (tm:date-second-set! dat x) (%date-second-set! dat (%number->maybe-fixnum x)))
     1177
     1178(define (tm:date-minute-set! dat x) (%date-minute-set! dat (%number->maybe-fixnum x)))
     1179
     1180(define (tm:date-hour-set! dat x) (%date-hour-set! dat (%number->maybe-fixnum x)))
     1181
     1182(define (tm:date-day-set! dat x) (%date-day-set! dat (%number->maybe-fixnum x)))
     1183
     1184(define (tm:date-month-set! dat x) (%date-month-set! dat (%number->maybe-fixnum x)))
     1185
     1186(define (tm:date-year-set! dat x) (%date-year-set! dat (%number->maybe-fixnum x)))
     1187
     1188(define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (%number->maybe-fixnum x)))
    11261189
    11271190;; Leap Year Test
     
    11631226(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    11641227  (%make-date
    1165    (%->fixnum ns)
    1166    (%->fixnum sec) (%->fixnum min) (%->fixnum hr)
    1167    (%->fixnum dy) (%->fixnum mn) (%->fixnum yr)
    1168    (%->fixnum tzo) tzn dstf
     1228   (%number->maybe-fixnum ns)
     1229   (%number->maybe-fixnum sec) (%number->maybe-fixnum min) (%number->maybe-fixnum hr)
     1230   (%number->maybe-fixnum dy) (%number->maybe-fixnum mn) (%number->maybe-fixnum yr)
     1231   (%number->maybe-fixnum tzo) tzn dstf
    11691232   wdy ydy jdy) )
    11701233
     
    11761239(define (tm:check-year loc yr)
    11771240  (unless (and (fixnum? yr) (not (fx= 0 yr)))
    1178     (error loc "invalid year" yr) ) )
     1241    (error-invalid-year loc yr) ) )
    11791242
    11801243; Months in [1 12]
    11811244(define (tm:check-month loc mn)
    11821245  (unless (and (fixnum? mn) (fx<= 1 mn) (fx<= mn 12))
    1183     (error loc "invalid month" mn) ) )
     1246    (error-invalid-month loc mn) ) )
    11841247
    11851248; Days in [1 28/29/30/31] - depending on month & year
    11861249(define (tm:check-day loc dy mn yr)
    11871250  (unless (and (fixnum? dy) (fx<= 1 dy) (fx<= dy (tm:days-in-month mn yr)))
    1188     (error loc "invalid day" dy) ) )
     1251    (error-invalid-day loc dy) ) )
    11891252
    11901253(define (tm:check-exploded-date loc ns sec min hr dy mn yr tzo tzn)
     
    11951258  ; Seconds in [0 60] ; 60 legal due to leap second
    11961259  (unless (and (fixnum? sec) (fx<= 0 sec) (fx<= sec 60))
    1197     (error loc "invalid seconds" sec))
     1260    (error-invalid-seconds loc sec))
    11981261
    11991262  ; Minutes in [0 59]
    12001263  (unless (and (fixnum? min) (and (fx<= 0 min) (fx< min 60)))
    1201     (error loc "invalid minutes" min))
     1264    (error-invalid-minutes loc min)  )
    12021265
    12031266  ; Hours in [0 23]
    12041267  (unless (and (fixnum? hr) (and (<= 0 hr) (< hr 24)))
    1205     (error loc "invalid hours" hr))
     1268    (error-invalid-hours loc hr) )
    12061269
    12071270  ; Year, Month & Day within limits
     
    12121275  ; Timezone offset in (-SEC/DY +SEC/DY)
    12131276  (unless (and (fixnum? tzo) (let ((atzo (%fxabs tzo))) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
    1214     (error loc "invalid timezone offset" tzo))
     1277    (error-invalid-timezone-offset loc tzo))
    12151278
    12161279  ; Timezone not specified or a string
    12171280  (unless (or (not tzn) (string? tzn))
    1218     (error loc "invalid timezone name" tzn)) )
     1281    (error-invalid-timezone-name loc tzn)  ) )
    12191282
    12201283;; Date Syntax
     
    12651328(define (seconds->date/type sec . r)
    12661329  (unless (number? sec)
    1267     (error 'seconds->date/type "invalid seconds" sec))
     1330    (error-invalid-seconds 'seconds->date/type sec))
    12681331  (let ((tzc (optional r #f)))
    12691332    (when (boolean? tzc)
    12701333      (set! tzc ((if tzc local-timezone-locale utc-timezone-locale))) )
    12711334    (unless (timezone-components? tzc)
    1272       (error 'seconds->date/type "invalid timezone-locale" tzc) )
     1335      (error-invalid-timezone-components 'seconds->date/type tzc) )
    12731336    (let* ((fsec (exact->inexact sec))
    12741337           (isec (truncate fsec))
     
    13361399  (%check-date loc dat2)
    13371400  (if (not (fx= (%date-zone-offset dat1) (%date-zone-offset dat2)))
    1338       (error loc "cannot compare dates from different time-zones" dat1 dat2)
     1401      (error-compare-dates-w-diff-tz loc dat1 dat2)
    13391402      (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
    13401403        (if (not (fx= 0 dif)) dif
     
    13981461
    13991462(define (tm:decode-julian-day-number jdn)
    1400   (let* ((dys (%->fixnum (truncate jdn)))
     1463  (let* ((dys (%number->maybe-fixnum (truncate jdn)))
    14011464         (a (fx+ dys 32044))
    14021465         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
     
    14071470         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))))
    14081471    (values
    1409       (%->fixnum (floor (* (- jdn dys) SEC/DY)))  ; seconds
     1472      (%number->maybe-fixnum (floor (* (- jdn dys) SEC/DY)))  ; seconds
    14101473      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1) ; day
    14111474      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))      ; month
     
    14231486(define (tm:tai-before-leap-second? tim)
    14241487  (let ((sec (%time-second tim)))
    1425     (let loop ((lst tm:second-before-leap-second-table))
    1426       (and (not (null? lst))
    1427            (or (= sec (car lst))
    1428                (loop (cdr lst)) ) ) ) ) )
     1488    (let loop ((ls tm:second-before-leap-second-table))
     1489      (and (not (null? ls))
     1490           (or (= sec (car ls))
     1491               (loop (cdr ls)) ) ) ) ) )
    14291492
    14301493(define (tm:time->date loc tim tzc)
     
    14381501        (set! tzo (timezone-locale-offset tzo)))
    14391502      (unless (fixnum? tzo)
    1440         (error loc "invalid timezone offset" tzo) )
     1503        (error-invalid-timezone-offset loc tzo) )
    14411504      (receive (secs dy mn yr)
    14421505          (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
     
    14741537    ((time-tai)       (tm:time-tai->date 'time->date tim tzc))
    14751538    (else ; This shouldn't happen
    1476      (error 'time->date "invalid clock type" tim))) )
     1539     (error-invalid-clock-type 'time->date tim))) )
    14771540
    14781541;; Date to Time
     
    15351598    ((time-tai)       (tm:date->time-tai 'date->time dat))
    15361599    (else
    1537      (error 'date->time "invalid clock type" timtyp))) )
     1600     (error-invalid-clock-type 'date->time timtyp))) )
    15381601
    15391602;; Leap Year
     
    16621725    ((time-tai)       (tm:time-tai->julian-day tim))
    16631726    (else
    1664      (error 'time->julian-day "invalid clock type" tim))) )
     1727     (error-invalid-clock-type 'time->julian-day tim))) )
    16651728
    16661729(define (tm:time-utc->modified-julian-day tim)
     
    16921755    ((time-tai)       (tm:time-tai->modified-julian-day tim))
    16931756    (else
    1694      (error 'time->modified-julian-day "invalid clock type" tim))) )
     1757     (error-invalid-clock-type 'time->modified-julian-day tim))) )
    16951758
    16961759;; Julian-day to Time
  • release/3/srfi-19/trunk/srfi-19-io.scm

    r13899 r13970  
    6464;;;
    6565
     66(define (error-bad-date-format loc obj)
     67  (error loc "bad date format" obj) )
     68
     69(define (error-bad-date-template loc msg . args)
     70  (apply error loc
     71               (if (string=? "" msg) "bad date template"
     72                   (string-append "bad date template - " msg))
     73               args) )
     74
     75;;;
     76
    6677;; -- Locale bundle item keys
    6778
     
    96107
    97108(define (tm:natural-year n)
    98   (let* ((current-year (date-year (current-date)))
    99          (current-century (fx* (fx/ current-year 100) 100)))
    100     (cond ((fx>= n 100) n)
    101           ((fx< n 0) n)
    102           ((fx<= (fx- (fx+ current-century n) current-year) 50)
    103            (fx+ current-century n))
    104           (else
    105            (fx+ (fx- current-century 100) n))) ) )
     109  (if (or (fx< n 0) (fx>= n 100)) n
     110      (let* ((current-year (date-year (current-date)))
     111             (current-century (fx* (fx/ current-year 100) 100)))
     112        (if (fx<= (fx- (fx+ current-century n) current-year) 50) (fx+ current-century n)
     113            (fx+ (fx- current-century 100) n) ) ) ) )
    106114
    107115;; Return a string representing the decimal expansion of the fractional
     
    111119  (let loop ((num (- r (round r)))
    112120             (p precision)
    113              (lst '()))
    114     (if (or (fx= 0 p) (zero? num)) (apply string-append (reverse! lst))
     121             (ls '()))
     122    (if (or (fx= 0 p) (zero? num)) (apply string-append (reverse! ls))
    115123        (let* ((num-times-10 (* 10 num))
    116124               (round-num-times-10 (round num-times-10)))
    117125          (loop (- num-times-10 round-num-times-10)
    118126                (fx- p 1)
    119                 (cons (number->string (inexact->exact round-num-times-10))
    120                       lst)) ) ) ) )
     127                (cons (number->string (inexact->exact round-num-times-10)) ls)) ) ) ) )
    121128
    122129;; Returns a string rep. of number N, of minimum LENGTH,
     
    385392             (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port))
    386393            ((fx< len-rem 2)
    387              (error loc "bad date format" (list->string format-rem)))
     394             (error-bad-date-format loc (list->string format-rem)))
    388395            (else
    389396             (let ((pad-ch (cadr format-rem)))
    390397               (cond ((char=? pad-ch #\-)
    391398                      (if (fx< len-rem 3)
    392                           (error loc "bad date format" (list->string format-rem))
     399                          (error-bad-date-format loc (list->string format-rem))
    393400                          (let ((formatter (get-formatter (caddr format-rem))))
    394401                            (if (not formatter)
    395                                 (error loc "bad date format" (list->string format-rem))
     402                                (error-bad-date-format loc (list->string format-rem))
    396403                                (begin
    397404                                  (formatter date #f port)
     
    400407                      ((char=? pad-ch #\_)
    401408                       (if (fx< len-rem 3)
    402                            (error loc "bad date format" (list->string format-rem))
     409                           (error-bad-date-format loc (list->string format-rem))
    403410                           (let ((formatter (get-formatter (caddr format-rem))))
    404411                             (if (not formatter)
    405                                  (error loc "bad date format" (list->string format-rem))
     412                                 (error-bad-date-format loc (list->string format-rem))
    406413                                 (begin
    407414                                   (formatter date #\space port)
     
    411418                       (let ((formatter (get-formatter pad-ch)))
    412419                         (if (not formatter)
    413                              (error loc "bad date format" (list->string format-rem))
     420                             (error-bad-date-format loc (list->string format-rem))
    414421                             (begin
    415422                               (formatter date #\0 port)
     
    451458    ((#\9) 9)
    452459    (else
    453      (error 'date-read "bad date template: not a decimal digit" ch))) )
     460     (error-bad-date-template 'date-read "not a decimal digit" ch))) )
    454461
    455462;; read an integer upto n characters long on port;
     
    478485               accum)
    479486              ((eof-object? ch)
    480                (error 'string->date "bad date template: premature ending to integer read"))
     487               (error-bad-date-template 'string->date "premature ending to integer read" 'eof-object))
    481488              ((char-numeric? ch)
    482489               (set! padding-ok #f)
     
    485492               (read-char port)    ; consume padding
    486493               (loop accum (fx+ nchars 1)))
    487               (else                 ; padding where it shouldn't be
    488                (error 'string->date "bad date template: non-numeric characters in integer read"))) ) ) ) )
     494              (else                ; padding where it shouldn't be
     495               (error-bad-date-template 'string->date "non-numeric characters in integer read" ch))) ) ) ) )
    489496
    490497(define (tm:make-integer-exact-reader n)
     
    497504        (ch (read-char port)) )
    498505    (when (eof-object? ch)
    499       (error 'string->date "bad date template: invalid time zone +/-"))
     506      (error-bad-date-template 'string->date "invalid time zone +/-" 'eof-object))
    500507    (if (or (char=? ch #\Z) (char=? ch #\z)) 0
    501508        (begin
     
    503510                ((char=? ch #\-) (set! is-pos #f))
    504511                (else
    505                  (error 'string->date "bad date template: invalid time zone +/-" ch)))
     512                 (error-bad-date-template 'string->date "invalid time zone +/-" ch)))
    506513          (let ((ch (read-char port)))
    507514            (when (eof-object? ch)
    508               (error 'string->date "bad date template: invalid time zone number"))
     515              (error-bad-date-template 'string->date "invalid time zone number" 'eof-object))
    509516            (set! offset (fx* (tm:digit->int ch) (fx* 10 SEC/HR))))
    510517          ;; non-existing values are considered zero
     
    533540           (index (indexer str)))
    534541      (unless index
    535         (error 'string->date "bad date template: invalid string for indexer" str))
     542        (error-bad-date-template 'string->date "invalid string for indexer" str))
    536543      index ) ) )
    537544
     
    542549(define (tm:make-char-id-reader char)
    543550  (lambda (port)
    544     (if (char=? char (read-char port)) char
    545         (error 'string->date "bad date template: invalid character match"))) )
     551    (let ((rch (read-char port)))
     552      (if (char=? char rch) char
     553          (error-bad-date-template 'string->date "invalid character match" rch) ) ) ) )
    546554
    547555;; A List of formatted read directives.
     
    634642             (let loop ((ch (peek-char port)))
    635643               (if (eof-object? ch)
    636                    (error 'scan-date "bad date template" (list->string format-rem))
     644                   (error-bad-date-template 'scan-date "" (list->string format-rem))
    637645                   (unless (skipper ch)
    638646                     (read-char port)
     
    644652                   (when (or (eof-object? port-char)
    645653                             (not (char=? current-char port-char)))
    646                      (error 'scan-date "bad date template" (list->string format-rem))))
     654                     (error-bad-date-template 'scan-date "" (list->string format-rem))))
    647655                 (loop (cdr format-rem) (fx- len-rem 1)))
    648656                ;; otherwise, it's an escape, we hope
    649657                ((fx< len-rem 2)
    650                  (error 'scan-date "bad date template" (list->string format-rem)))
     658                 (error-bad-date-template 'scan-date "" (list->string format-rem)))
    651659                (else
    652660                 (let* ((format-char (cadr format-rem))
    653661                        (format-info (assoc format-char tm:read-directives)))
    654662                   (unless format-info
    655                      (error 'scan-date "bad date template" (list->string format-rem)))
     663                     (error-bad-date-template 'scan-date "" (list->string format-rem)))
    656664                   (let ((skipper (cadr format-info))
    657665                         (reader (caddr format-info))
     
    660668                     (let ((val (reader port)))
    661669                       (if (eof-object? val)
    662                          (error 'scan-date "bad date template" (list->string format-rem))
     670                         (error-bad-date-template 'scan-date "" (list->string format-rem))
    663671                         (actor val date))))
    664672                   (loop (cddr format-rem) (fx- len-rem 2))))) ) ) ) ) )
     
    687695      (tm:date-reader newdate (string->list template-string) (string-length template-string) port)
    688696      (unless (date-compl?)
    689         (error 'scan-date "bad date template: date read incomplete" template-string newdate))
     697        (error-bad-date-template 'scan-date "date read incomplete" template-string newdate))
    690698      (date-ok)
    691699      newdate ) ) )
  • release/3/srfi-19/trunk/srfi-19-period.scm

    r13899 r13970  
    2525      time-period?
    2626      time-period-null?
     27      time-period-compare
    2728      time-period=?
    2829      time-period<?
     
    5758(include "srfi-19-common")
    5859
     60;;;
     61
     62(define (error-invalid-type loc typ obj)
     63  (error loc (string-append "invalid " typ) obj) )
     64
     65(define (error-invalid-clock-type loc obj)
     66  (error-invalid-type loc "clock type" obj) )
     67
     68(define (error-invalid-time-object loc obj)
     69  (error-invalid-type loc "time object" obj) )
     70
     71(define (error-incompatible-clock-type loc obj)
     72  (error loc "incompatible clock type" obj) )
     73
     74(define (error-incompatible-clock-types loc obj1 obj2)
     75  (error loc "incompatible clock types" obj1 obj2) )
     76
    5977;;; Time Period
    6078
     
    89107  (let ((tt1 (tm:time-type t1))
    90108        (tt2 (tm:time-type t2))
    91         (errtt (lambda () (error loc "incompatible clock-types" t1 t2))))
     109        (errtt (lambda () (error-incompatible-clock-types loc t1 t2))))
    92110    (if (eq? tt1 tt2) t2
    93111        (let ((ntime (tm:as-empty-time t1)))
     
    120138    ((time-monotonic) (date->time-monotonic dat))
    121139    (else
    122      (error loc "incompatible clock type" tim))) )
    123 
    124 #;
    125 (define (tm:time-period-compare loc per1 per2)
    126   (tm:time-period-binop-check loc per1 per2)
    127   (tm:time-period-subtract per1 per2) )
     140     (error-incompatible-clock-type loc tim))) )
    128141
    129142(define (tm:time-period=? per1 per2)
     
    174187  per-out )
    175188
     189;FIXME - should take into account span
     190(define (tm:time-period-subtract per1 per2)
     191  (let ((diff (- (%time-period-begin per1) (%time-period-begin per2))))
     192    (if (zero? diff) (- (%time-period-end per1) (%time-period-end per2))
     193        diff ) ) )
     194
    176195;;
    177196
     
    198217    (tm:check-time 'make-time-period beg)
    199218    (when (eq? 'time-duration (tm:time-type beg))
    200       (error 'make-time-period "invalid time" beg))
     219      (error-invalid-clock-type 'make-time-period beg))
    201220    (cond ((number? end)
    202221           (set! end (seconds->time/type end 'time-duration)) )
     
    219238  (%check-time-period 'time-period-null? per)
    220239  (tm:time-period-null? per) )
     240
     241(define (time-period-compare per1 per2)
     242  (tm:time-period-binop-check 'time-period-compare per1 per2)
     243  (let ((diff (tm:time-period-subtract per1 per2)))
     244    (cond ((negative? diff) -1)
     245          ((zero? diff)     0)
     246          (else             1 ) ) ) )
    221247
    222248(define (time-period=? per1 per2)
     
    285311         (tm:time-period-contains/date? 'time-period-contains? per obj))
    286312        (else
    287          (error 'time-period-contains? "invalid time object" obj))) )
     313         (error-invalid-time-object 'time-period-contains? obj))) )
    288314
    289315(define (time-period-intersects? per1 per2)
Note: See TracChangeset for help on using the changeset viewer.