Changeset 15738 in project


Ignore:
Timestamp:
09/05/09 03:37:23 (10 years ago)
Author:
Kon Lovett
Message:

Save

Location:
release/4/srfi-19/trunk
Files:
1 added
4 edited

Legend:

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

    r15727 r15738  
    1515(define-constant SEC/MIN  60)
    1616
    17 #;(define-constant iNS/S    1000000000.0)
    18 #;(define-constant iSEC/DY  86400.0)
     17#;(define-constant iNS/S      1000000000.0)
     18#;(define-constant iSEC/DY    86400.0)
    1919#;(define-constant iONE-HALF  0.5)
    2020
     
    2525(define-constant DY/YR 365) ;normal days per year
    2626
    27 (define-constant MN/YR 12)
     27(define-constant MN/YR 12)  ;months per year
    2828
    2929;;
    3030
    31 (define-inline (%->boolean obj) (and obj #t))
     31(define-inline (->boolean obj) (and obj #t))
    3232
    33 (define-inline (%fxabs x) (if (fx< x 0) (fxneg x) x))
     33(define-inline (fxabs x) (if (fx< x 0) (fxneg x) x))
    3434
    3535;; For storage savings since some aritmetic routines do not
     
    4646; Number MUST be a fixnum or flonum
    4747
    48 (define-inline (%number->maybe-fixnum x)
     48(define-inline (number->maybe-fixnum x)
    4949  (if (fixnum? x) x (##sys#double->number x)) )
    5050
     
    5353; Others returned
    5454
    55 (define-inline (%maybe-integer->maybe-fixnum x)
    56   (if (##sys#integer? x) (%number->maybe-fixnum x) x) )
     55(define-inline (maybe-integer->maybe-fixnum x)
     56  (if (##sys#integer? x) (number->maybe-fixnum x) x) )
  • release/4/srfi-19/trunk/srfi-19-core.scm

    r15727 r15738  
    8383;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
    8484
    85 (eval-when (compile)
    86   (declare
    87     (not usual-integrations
    88       + - * /
    89       remainder quotient modulo
    90       expt
    91       abs
    92       round floor truncate
    93       number? integer? inexact?
    94       zero? negative? positive?
    95       = <= >= < >
    96       inexact->exact exact->inexact
    97       char-alphabetic? char-numeric?
    98       number->string string->number
    99       string-length string-append
    100       string->list list->string)
    101     (inline)
    102     (generic)
    103     (no-procedure-checks)
    104     (import
    105       ; SRFI-18 - This is a hack, works because Unit srfi-18 is part of the Chicken core.
    106       seconds->time)
    107     (bound-to-procedure
    108       ##sys#slot
    109       seconds->time
    110       ##sys#check-structure)
    111     (export
    112       ; SRFI-19
    113       time-tai
    114       time-utc
    115       time-monotonic
    116       time-thread
    117       time-process
    118       time-duration
    119       time-gc
    120       current-date
    121       current-julian-day
    122       current-modified-julian-day
    123       current-time
    124       time-resolution
    125       make-time time?
    126       time-type
    127       time-nanosecond
    128       time-second
    129       set-time-type!
    130       set-time-nanosecond!
    131       set-time-second!
    132       copy-time
    133       time<=?
    134       time<?
    135       time=?
    136       time>=?
    137       time>?
    138       time-difference
    139       time-difference!
    140       add-duration
    141       add-duration!
    142       subtract-duration
    143       subtract-duration!
    144       make-date
    145       date?
    146       date-nanosecond
    147       date-second
    148       date-minute
    149       date-hour
    150       date-day
    151       date-month
    152       date-year
    153       date-zone-offset
    154       leap-year? ; Actually part of SRFI 19 but not in original document
    155       date-year-day
    156       date-week-day
    157       date-week-number
    158       date->julian-day
    159       date->modified-julian-day
    160       date->time-monotonic
    161       date->time-tai
    162       date->time-utc
    163       julian-day->date
    164       julian-day->time-monotonic
    165       julian-day->time-tai
    166       julian-day->time-utc
    167       modified-julian-day->date
    168       modified-julian-day->time-monotonic
    169       modified-julian-day->time-tai
    170       modified-julian-day->time-utc
    171       time-monotonic->date
    172       time-monotonic->julian-day
    173       time-monotonic->modified-julian-day
    174       time-monotonic->time-tai
    175       time-monotonic->time-tai!
    176       time-monotonic->time-utc
    177       time-monotonic->time-utc!
    178       time-tai->date
    179       time-tai->julian-day
    180       time-tai->modified-julian-day
    181       time-tai->time-monotonic
    182       time-tai->time-monotonic!
    183       time-tai->time-utc
    184       time-tai->time-utc!
    185       time-utc->date
    186       time-utc->julian-day
    187       time-utc->modified-julian-day
    188       time-utc->time-monotonic
    189       time-utc->time-monotonic!
    190       time-utc->time-tai
    191       time-utc->time-tai!
    192       ; Extensions
    193       ONE-SECOND-DURATION
    194       ONE-NANOSECOND-DURATION
    195       time-type?
    196       make-duration
    197       divide-duration
    198       divide-duration!
    199       multiply-duration
    200       multiply-duration!
    201       srfi-19:current-time
    202       srfi-19:time?
    203       time->srfi-18-time
    204       srfi-18-time->time
    205       time-max
    206       time-min
    207       time-negative?
    208       time-positive?
    209       time-zero?
    210       time-abs
    211       time-abs!
    212       time-negate
    213       time-negate!
    214       seconds->time/type
    215       seconds->date/type
    216       time->nanoseconds
    217       nanoseconds->time
    218       nanoseconds->seconds
    219       read-leap-second-table
    220       time->milliseconds
    221       milliseconds->time
    222       milliseconds->seconds
    223       time->date
    224       make-timezone-locale
    225       timezone-locale?
    226       timezone-locale-name
    227       timezone-locale-offset
    228       timezone-locale-dst?
    229       local-timezone-locale
    230       utc-timezone-locale
    231       default-date-clock-type
    232       date-zone-name
    233       date-dst?
    234       copy-date
    235       date->time
    236       date-difference
    237       date-add-duration
    238       date-subtract-duration
    239       date=?
    240       date>?
    241       date<?
    242       date>=?
    243       date<=?
    244       time->julian-day
    245       time->modified-julian-day
    246       date-compare
    247       time-compare
    248       ; Internal API, for srfi-19-io & srfi-19-period
    249       tm:date-day-set!
    250       tm:date-hour-set!
    251       tm:date-minute-set!
    252       tm:date-month-set!
    253       tm:date-nanosecond-set!
    254       tm:date-second-set!
    255       tm:date-year-set!
    256       tm:date-zone-offset-set!
    257       tm:make-incomplete-date
    258       tm:check-date
    259       tm:check-exploded-date
    260       tm:time-type
    261       tm:check-time
    262       tm:make-empty-time
    263       tm:as-empty-time
    264       tm:time-monotonic->time-tai
    265       tm:time-utc->time-tai
    266       tm:time-tai->time-monotonic
    267       tm:time-utc->time-monotonic
    268       tm:time-monotonic->time-utc
    269       tm:time-tai->time-utc
    270       tm:week-day
    271       tm:days-before-first-week
    272       tm:subtract-duration
    273       tm:add-duration
    274       tm:time=?
    275       tm:time<?
    276       tm:time>?
    277       tm:time<=?
    278       tm:time>=?
    279       tm:time-max
    280       tm:time-min
    281       tm:check-duration
    282       tm:time-difference) ) )
    283 
    284 (require-extension srfi-6 srfi-8 srfi-9 posix miscmacros numbers locale misc-extn-record)
     85(include "chicken-primitive-object-inlines")
     86
     87(declare
     88  (not usual-integrations
     89    + - * /
     90    remainder quotient modulo
     91    expt
     92    abs
     93    round floor truncate
     94    number? integer? inexact?
     95    zero? negative? positive?
     96    = <= >= < >
     97    inexact->exact exact->inexact
     98    char-alphabetic? char-numeric?
     99    number->string string->number
     100    string-length string-append
     101    string->list list->string)
     102  (inline)
     103  (generic)
     104  (no-procedure-checks)
     105  (import
     106    ; SRFI-18 - This is a hack, works because Unit srfi-18 is part of the Chicken core.
     107    seconds->time)
     108  (bound-to-procedure
     109    ##sys#slot
     110    seconds->time
     111    ##sys#check-structure)
     112  (export
     113    ; SRFI-19
     114    time-tai
     115    time-utc
     116    time-monotonic
     117    time-thread
     118    time-process
     119    time-duration
     120    time-gc
     121    current-date
     122    current-julian-day
     123    current-modified-julian-day
     124    current-time
     125    time-resolution
     126    make-time time?
     127    time-type
     128    time-nanosecond
     129    time-second
     130    set-time-type!
     131    set-time-nanosecond!
     132    set-time-second!
     133    copy-time
     134    time<=?
     135    time<?
     136    time=?
     137    time>=?
     138    time>?
     139    time-difference
     140    time-difference!
     141    add-duration
     142    add-duration!
     143    subtract-duration
     144    subtract-duration!
     145    make-date
     146    date?
     147    date-nanosecond
     148    date-second
     149    date-minute
     150    date-hour
     151    date-day
     152    date-month
     153    date-year
     154    date-zone-offset
     155    leap-year? ; Actually part of SRFI 19 but not in original document
     156    date-year-day
     157    date-week-day
     158    date-week-number
     159    date->julian-day
     160    date->modified-julian-day
     161    date->time-monotonic
     162    date->time-tai
     163    date->time-utc
     164    julian-day->date
     165    julian-day->time-monotonic
     166    julian-day->time-tai
     167    julian-day->time-utc
     168    modified-julian-day->date
     169    modified-julian-day->time-monotonic
     170    modified-julian-day->time-tai
     171    modified-julian-day->time-utc
     172    time-monotonic->date
     173    time-monotonic->julian-day
     174    time-monotonic->modified-julian-day
     175    time-monotonic->time-tai
     176    time-monotonic->time-tai!
     177    time-monotonic->time-utc
     178    time-monotonic->time-utc!
     179    time-tai->date
     180    time-tai->julian-day
     181    time-tai->modified-julian-day
     182    time-tai->time-monotonic
     183    time-tai->time-monotonic!
     184    time-tai->time-utc
     185    time-tai->time-utc!
     186    time-utc->date
     187    time-utc->julian-day
     188    time-utc->modified-julian-day
     189    time-utc->time-monotonic
     190    time-utc->time-monotonic!
     191    time-utc->time-tai
     192    time-utc->time-tai!
     193    ; Extensions
     194    ONE-SECOND-DURATION
     195    ONE-NANOSECOND-DURATION
     196    time-type?
     197    make-duration
     198    divide-duration
     199    divide-duration!
     200    multiply-duration
     201    multiply-duration!
     202    srfi-19:current-time
     203    srfi-19:time?
     204    time->srfi-18-time
     205    srfi-18-time->time
     206    time-max
     207    time-min
     208    time-negative?
     209    time-positive?
     210    time-zero?
     211    time-abs
     212    time-abs!
     213    time-negate
     214    time-negate!
     215    seconds->time/type
     216    seconds->date/type
     217    time->nanoseconds
     218    nanoseconds->time
     219    nanoseconds->seconds
     220    read-leap-second-table
     221    time->milliseconds
     222    milliseconds->time
     223    milliseconds->seconds
     224    time->date
     225    make-timezone-locale
     226    timezone-locale?
     227    timezone-locale-name
     228    timezone-locale-offset
     229    timezone-locale-dst?
     230    local-timezone-locale
     231    utc-timezone-locale
     232    default-date-clock-type
     233    date-zone-name
     234    date-dst?
     235    copy-date
     236    date->time
     237    date-difference
     238    date-add-duration
     239    date-subtract-duration
     240    date=?
     241    date>?
     242    date<?
     243    date>=?
     244    date<=?
     245    time->julian-day
     246    time->modified-julian-day
     247    date-compare
     248    time-compare
     249    ; Internal API, for srfi-19-io & srfi-19-period
     250    tm:date-day-set!
     251    tm:date-hour-set!
     252    tm:date-minute-set!
     253    tm:date-month-set!
     254    tm:date-nanosecond-set!
     255    tm:date-second-set!
     256    tm:date-year-set!
     257    tm:date-zone-offset-set!
     258    tm:make-incomplete-date
     259    tm:check-date
     260    tm:check-exploded-date
     261    tm:time-type
     262    tm:check-time
     263    tm:make-empty-time
     264    tm:as-empty-time
     265    tm:time-monotonic->time-tai
     266    tm:time-utc->time-tai
     267    tm:time-tai->time-monotonic
     268    tm:time-utc->time-monotonic
     269    tm:time-monotonic->time-utc
     270    tm:time-tai->time-utc
     271    tm:week-day
     272    tm:days-before-first-week
     273    tm:subtract-duration
     274    tm:add-duration
     275    tm:time=?
     276    tm:time<?
     277    tm:time>?
     278    tm:time<=?
     279    tm:time>=?
     280    tm:time-max
     281    tm:time-min
     282    tm:check-duration
     283    tm:time-difference) )
     284
     285(require-extension #;srfi-6 #;srfi-8 #;srfi-9 posix miscmacros numbers locale srfi-9-ext type-checks type-errors)
    285286
    286287(register-feature! 'srfi-19)
     
    518519;;
    519520
    520 (define-inline (%memq? obj ls) (%->boolean (memq obj ls)))
     521(define-inline (%memq? obj ls) (->boolean (memq obj ls)))
    521522
    522523(define (time-type? obj)
     
    544545;; ...    - argument checking then tm:...
    545546
    546 (define-record-type/unsafe-inline-unchecked time
     547(define-record-type/primitive time
    547548  (%make-time timtyp ns sec)
    548549  %time?
     
    558559
    559560(define (tm:make-time timtyp ns sec)
    560   (%make-time timtyp (%number->maybe-fixnum ns) (%maybe-integer->maybe-fixnum sec)) )
     561  (%make-time timtyp (number->maybe-fixnum ns) (maybe-integer->maybe-fixnum sec)) )
    561562
    562563(define (tm:set-time-nanosecond! tim ns)
    563   (%set-time-nanosecond! tim (%number->maybe-fixnum ns)) )
     564  (%set-time-nanosecond! tim (number->maybe-fixnum ns)) )
    564565
    565566(define (tm:set-time-second! tim sec)
    566   (%set-time-second! tim (%maybe-integer->maybe-fixnum sec)) )
     567  (%set-time-second! tim (maybe-integer->maybe-fixnum sec)) )
    567568
    568569;;
     
    11011102  (unless (timezone-components? tzc)
    11021103    (error-invalid-timezone-components 'make-timezone-locale tzc) )
    1103   (set-timezone-component! tzc 'dst? (%->boolean dstf))
     1104  (set-timezone-component! tzc 'dst? (->boolean dstf))
    11041105  tzc )
    11051106
     
    11481149;;; Date Object (Public Immutable)
    11491150
    1150 (define-record-type/unsafe-inline-unchecked date
     1151(define-record-type/primitive date
    11511152  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    11521153  %date?
     
    11721173;;
    11731174
    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)))
     1175(define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (number->maybe-fixnum x)))
     1176
     1177(define (tm:date-second-set! dat x) (%date-second-set! dat (number->maybe-fixnum x)))
     1178
     1179(define (tm:date-minute-set! dat x) (%date-minute-set! dat (number->maybe-fixnum x)))
     1180
     1181(define (tm:date-hour-set! dat x) (%date-hour-set! dat (number->maybe-fixnum x)))
     1182
     1183(define (tm:date-day-set! dat x) (%date-day-set! dat (number->maybe-fixnum x)))
     1184
     1185(define (tm:date-month-set! dat x) (%date-month-set! dat (number->maybe-fixnum x)))
     1186
     1187(define (tm:date-year-set! dat x) (%date-year-set! dat (number->maybe-fixnum x)))
     1188
     1189(define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (number->maybe-fixnum x)))
    11891190
    11901191;; Leap Year Test
     
    12261227(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    12271228  (%make-date
    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
     1229   (number->maybe-fixnum ns)
     1230   (number->maybe-fixnum sec) (number->maybe-fixnum min) (number->maybe-fixnum hr)
     1231   (number->maybe-fixnum dy) (number->maybe-fixnum mn) (number->maybe-fixnum yr)
     1232   (number->maybe-fixnum tzo) tzn dstf
    12321233   wdy ydy jdy) )
    12331234
     
    12741275
    12751276  ; Timezone offset in (-SEC/DY +SEC/DY)
    1276   (unless (and (fixnum? tzo) (let ((atzo (%fxabs tzo))) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
     1277  (unless (and (fixnum? tzo) (let ((atzo (fxabs tzo))) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
    12771278    (error-invalid-timezone-offset loc tzo))
    12781279
     
    14611462
    14621463(define (tm:decode-julian-day-number jdn)
    1463   (let* ((dys (%number->maybe-fixnum (truncate jdn)))
     1464  (let* ((dys (number->maybe-fixnum (truncate jdn)))
    14641465         (a (fx+ dys 32044))
    14651466         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
     
    14701471         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))))
    14711472    (values
    1472       (%number->maybe-fixnum (floor (* (- jdn dys) SEC/DY)))  ; seconds
     1473      (number->maybe-fixnum (floor (* (- jdn dys) SEC/DY)))  ; seconds
    14731474      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1) ; day
    14741475      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))      ; month
  • release/4/srfi-19/trunk/srfi-19-period.scm

    r15727 r15738  
    22;;;; Chicken port, Kon Lovett, Apr '07
    33
    4 (eval-when (compile)
     4
     5(module srfi-19-period (;export
     6    time-period?
     7    time-period-null?
     8    time-period-compare
     9    time-period=?
     10    time-period<?
     11    time-period>?
     12    time-period<=?
     13    time-period>=?
     14    time-period-type
     15    time-period-begin
     16    time-period-end
     17    time-period-last
     18    time-period-length
     19    make-null-time-period
     20    make-time-period
     21    copy-time-period
     22    time-period-contains/period?
     23    time-period-contains/time?
     24    time-period-contains/date?
     25    time-period-contains?
     26    time-period-intersects?
     27    time-period-intersection
     28    time-period-union
     29    time-period-span
     30    time-period-shift
     31    time-period-shift!
     32    time-period-preceding
     33    time-period-succeeding)
     34
     35  (import scheme
     36          chicken
     37          (only extras fprintf)
     38          srfi-19-support
     39          srfi-9-ext type-checks type-errors)
     40  (require-library #;srfi-8
     41                   srfi-19-support
     42                   srfi-9-ext type-checks type-errors)
     43
    544  (declare
    645    (not usual-integrations
    7       + - * /
     46      - * /
    847      remainder quotient modulo
    948      expt
     
    1453      = <= >= < >
    1554      inexact->exact exact->inexact
    16       char-alphabetic? char-numeric?
    17       number->string string->number
    18       string-length string-append
    19       string->list list->string)
     55      char-alphabetic? char-numeric?)
    2056    (inline)
    2157    (generic)
    22     (no-procedure-checks)
    23     (no-bound-checks)
    24     (export
    25       time-period?
    26       time-period-null?
    27       time-period-compare
    28       time-period=?
    29       time-period<?
    30       time-period>?
    31       time-period<=?
    32       time-period>=?
    33       time-period-type
    34       time-period-begin
    35       time-period-end
    36       time-period-last
    37       time-period-length
    38       make-null-time-period
    39       make-time-period
    40       copy-time-period
    41       time-period-contains/period?
    42       time-period-contains/time?
    43       time-period-contains/date?
    44       time-period-contains?
    45       time-period-intersects?
    46       time-period-intersection
    47       time-period-union
    48       time-period-span
    49       time-period-shift
    50       time-period-shift!
    51       time-period-preceding
    52       time-period-succeeding) ) )
    53 
    54 (use srfi-8 srfi-19-core misc-extn-record)
     58    (no-procedure-checks) )
    5559
    5660;;;
     
    5963
    6064;;;
    61 
    62 (define (error-invalid-type loc typ obj)
    63   (error loc (string-append "invalid " typ) obj) )
    6465
    6566(define (error-invalid-clock-type loc obj)
     
    7778;;; Time Period
    7879
    79 (define-record-type/unsafe-inline-unchecked time-period
    80   (%make-time-period beg end)
    81   %time-period?
    82   (beg %time-period-begin)
    83   (end %time-period-end) )
    84 
    85 (define-inline (%check-time-period loc obj)
    86   (##sys#check-structure obj 'time-period loc) )
     80(define-record-type/primitive time-period
     81  (*make-time-period beg end)
     82  time-period?
     83  (beg *time-period-begin)
     84  (end *time-period-end) )
     85
     86(define-check+error-type time-period)
    8787
    8888(define-record-printer (time-period per out)
    89   (fprintf out "#,(time-period ~A ~A)" (%time-period-begin per) (%time-period-end per)) )
    90 
    91 (define-reader-ctor 'time-period %make-time-period)
     89  (fprintf out "#,(time-period ~A ~A)" (*time-period-begin per) (*time-period-end per)) )
     90
     91(define-reader-ctor 'time-period *make-time-period)
    9292
    9393(define (tm:time-period-binop-check loc obj1 obj2)
    94   (%check-time-period loc obj1)
    95   (%check-time-period loc obj2) )
    96 
    97 (define (tm:time-period-type per) (tm:time-type (%time-period-begin per)))
    98 
    99 (define (tm:time-period-null? per) (tm:time<=? (%time-period-end per) (%time-period-begin per)))
     94  (check-time-period loc obj1)
     95  (check-time-period loc obj2) )
     96
     97(define (tm:time-period-type per) (tm:time-type (*time-period-begin per)))
     98
     99(define (tm:time-period-null? per) (tm:time<=? (*time-period-end per) (*time-period-begin per)))
    100100
    101101(define (tm:as-empty-time-period per)
    102   (%make-time-period
    103    (tm:as-empty-time (%time-period-begin per))
    104    (tm:as-empty-time (%time-period-end per))) )
     102  (*make-time-period
     103   (tm:as-empty-time (*time-period-begin per))
     104   (tm:as-empty-time (*time-period-end per))) )
    105105
    106106(define (tm:ensure-compatible-time loc t1 t2)
     
    141141
    142142(define (tm:time-period=? per1 per2)
    143   (and (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
    144        (tm:time=? (%time-period-end per1) (%time-period-end per2))) )
     143  (and (tm:time=? (*time-period-begin per1) (*time-period-begin per2))
     144       (tm:time=? (*time-period-end per1) (*time-period-end per2))) )
    145145
    146146(define (tm:time-points-within? b1 e1 b2 e2)
     
    152152       (let ((tper
    153153              (if (eq? (tm:time-period-type per1) (tm:time-period-type per2)) per2
    154                   (%make-time-period
    155                    (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2))
    156                    (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2))))))
     154                  (*make-time-period
     155                   (tm:ensure-compatible-time loc (*time-period-begin per1) (*time-period-begin per2))
     156                   (tm:ensure-compatible-time loc (*time-period-end per1) (*time-period-end per2))))))
    157157         (tm:time-points-within?
    158           (%time-period-begin per1) (%time-period-end per1)
    159           (%time-period-begin tper) (%time-period-end tper)) ) ) )
     158          (*time-period-begin per1) (*time-period-end per1)
     159          (*time-period-begin tper) (*time-period-end tper)) ) ) )
    160160
    161161(define (tm:time-period-contains/time? loc per tim)
    162162  (and (not (tm:time-period-null? per))
    163        (let ((tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)))
    164          (tm:time-points-within? (%time-period-begin per) (%time-period-end per) tpt tpt) ) ) )
     163       (let ((tpt (tm:ensure-compatible-time loc (*time-period-begin per) tim)))
     164         (tm:time-points-within? (*time-period-begin per) (*time-period-end per) tpt tpt) ) ) )
    165165
    166166(define (tm:time-period-contains/date? loc per dat)
    167167  (tm:time-period-contains/time?
    168     loc per (tm:ensure-compatible-date loc (%time-period-begin per) dat)) )
     168    loc per (tm:ensure-compatible-date loc (*time-period-begin per) dat)) )
    169169
    170170(define (tm:time-point-intersection b1 e1 b2 e2)
     
    176176(define (tm:time-period-intersection-values per1 per2 loc)
    177177  (and (not (or (tm:time-period-null? per1) (tm:time-period-null? per2)))
    178        (let ((b1 (%time-period-begin per1))
    179              (e1 (%time-period-end per1)))
    180          (let ((b2 (tm:ensure-compatible-time loc b1 (%time-period-begin per2)))
    181                (e2 (tm:ensure-compatible-time loc e1 (%time-period-end per2))))
     178       (let ((b1 (*time-period-begin per1))
     179             (e1 (*time-period-end per1)))
     180         (let ((b2 (tm:ensure-compatible-time loc b1 (*time-period-begin per2)))
     181               (e2 (tm:ensure-compatible-time loc e1 (*time-period-end per2))))
    182182           (tm:time-point-intersection b1 e1 b2 e2) ) ) ) )
    183183
    184184(define (tm:time-period-shift per-in dur per-out)
    185   (tm:add-duration (%time-period-begin per-in) dur (%time-period-begin per-out))
    186   (tm:add-duration (%time-period-end per-in) dur (%time-period-end per-out))
     185  (tm:add-duration (*time-period-begin per-in) dur (*time-period-begin per-out))
     186  (tm:add-duration (*time-period-end per-in) dur (*time-period-end per-out))
    187187  per-out )
    188188
    189189;FIXME - should take into account span
     190#;
    190191(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))
     192  (let ((diff (- (*time-period-begin per1) (*time-period-begin per2))))
     193    (if (zero? diff) (- (*time-period-end per1) (*time-period-end per2))
    193194        diff ) ) )
    194195
    195196;;
    196197
    197 (define time-period? %time-period?)
    198 
    199198(define (time-period-begin prd)
    200   (%check-time-period 'time-period-begin prd)
    201   (%time-period-begin prd) )
     199  (check-time-period 'time-period-begin prd)
     200  (*time-period-begin prd) )
    202201
    203202(define (time-period-end prd)
    204   (%check-time-period 'time-period-end prd)
    205   (%time-period-end prd) )
     203  (check-time-period 'time-period-end prd)
     204  (*time-period-end prd) )
    206205
    207206(define (make-null-time-period . args)
     
    225224    (when (eq? 'time-duration (tm:time-type end))
    226225      (set! end (tm:add-duration beg end (tm:as-empty-time beg))))
    227     (%make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) ) )
     226    (*make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) ) )
    228227
    229228(define (copy-time-period per)
    230   (%check-time-period 'copy-time-period per)
    231   (%make-time-period (copy-time (%time-period-begin per)) (copy-time (%time-period-end per))) )
     229  (check-time-period 'copy-time-period per)
     230  (*make-time-period (copy-time (*time-period-begin per)) (copy-time (*time-period-end per))) )
    232231
    233232(define (time-period-type per)
    234   (%check-time-period 'time-period-type per)
     233  (check-time-period 'time-period-type per)
    235234  (tm:time-period-type per) )
    236235
    237236(define (time-period-null? per)
    238   (%check-time-period 'time-period-null? per)
     237  (check-time-period 'time-period-null? per)
    239238  (tm:time-period-null? per) )
    240239
     240#;
    241241(define (time-period-compare per1 per2)
    242242  (tm:time-period-binop-check 'time-period-compare per1 per2)
     
    252252(define (time-period<? per1 per2)
    253253  (tm:time-period-binop-check 'time-period<? per1 per2)
    254   (tm:time<? (%time-period-end per1) (%time-period-begin per2)) )
     254  (tm:time<? (*time-period-end per1) (*time-period-begin per2)) )
    255255
    256256(define (time-period>? per1 per2)
    257257  (tm:time-period-binop-check 'time-period>? per1 per2)
    258   (tm:time>? (%time-period-begin per1) (%time-period-end per2)) )
     258  (tm:time>? (*time-period-begin per1) (*time-period-end per2)) )
    259259
    260260(define (time-period<=? per1 per2)
    261261  (tm:time-period-binop-check 'time-period<=? per1 per2)
    262   (tm:time<=? (%time-period-end per1) (%time-period-begin per2)) )
     262  (tm:time<=? (*time-period-end per1) (*time-period-begin per2)) )
    263263
    264264(define (time-period>=? per1 per2)
    265265  (tm:time-period-binop-check 'time-period>=? per1 per2)
    266   (tm:time>=? (%time-period-begin per1) (%time-period-end per2)) )
     266  (tm:time>=? (*time-period-begin per1) (*time-period-end per2)) )
    267267
    268268(define (time-period-preceding per1 per2)
    269269  (tm:time-period-binop-check 'time-period-preceding per1 per2)
    270   (and (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
    271        (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )
     270  (and (tm:time<=? (*time-period-begin per1) (*time-period-begin per2))
     271       (make-time-period (*time-period-begin per1) (*time-period-begin per2)) ) )
    272272
    273273(define (time-period-succeeding per1 per2)
    274274  (tm:time-period-binop-check 'time-period-succeeding per1 per2)
    275   (and (tm:time>=? (%time-period-end per1) (%time-period-end per2))
    276        (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )
     275  (and (tm:time>=? (*time-period-end per1) (*time-period-end per2))
     276       (make-time-period (*time-period-end per2) (*time-period-end per1)) ) )
    277277
    278278(define (time-period-last per)
    279   (%check-time-period 'time-period-last per)
    280   (let ((end (%time-period-end per)))
     279  (check-time-period 'time-period-last per)
     280  (let ((end (*time-period-end per)))
    281281    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-empty-time end)) ) )
    282282
    283283(define (time-period-length per)
    284   (%check-time-period 'time-period-length per)
     284  (check-time-period 'time-period-length per)
    285285  (let ((dur (tm:make-empty-time time-duration)))
    286286    (if (tm:time-period-null? per) dur
    287         (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )
     287        (tm:time-difference (*time-period-begin per) (*time-period-end per) dur)) ) )
    288288
    289289(define (time-period-contains/period? per1 per2)
    290   (%check-time-period 'time-period-contains/period? per1)
    291   (%check-time-period 'time-period-contains/period? per2)
     290  (check-time-period 'time-period-contains/period? per1)
     291  (check-time-period 'time-period-contains/period? per2)
    292292  (tm:time-period-contains/period? 'time-period-contains/period? per1 per2) )
    293293
    294294(define (time-period-contains/time? per tim)
    295   (%check-time-period 'time-period-contains/time? per)
     295  (check-time-period 'time-period-contains/time? per)
    296296  (tm:check-time 'time-period-contains/time? tim)
    297297  (tm:time-period-contains/time? 'time-period-contains/time? per tim) )
    298298
    299299(define (time-period-contains/date? per dat)
    300   (%check-time-period 'time-period-contains/date? per)
     300  (check-time-period 'time-period-contains/date? per)
    301301  (tm:check-date 'time-period-contains/date? dat)
    302302  (tm:time-period-contains/date? 'time-period-contains/date? per dat) )
    303303
    304304(define (time-period-contains? per obj)
    305   (%check-time-period 'time-period-contains? per)
     305  (check-time-period 'time-period-contains? per)
    306306  (cond ((time-period? obj)
    307307         (tm:time-period-contains/period? 'time-period-contains? per obj))
     
    314314
    315315(define (time-period-intersects? per1 per2)
    316   (%check-time-period 'time-period-intersects? per1)
    317   (%check-time-period 'time-period-intersects? per2)
     316  (check-time-period 'time-period-intersects? per1)
     317  (check-time-period 'time-period-intersects? per2)
    318318  (receive (bi ei) (tm:time-period-intersection-values 'time-period-intersects? per1 per2)
    319319    (tm:time<=? bi ei) ) )
    320320
    321321(define (time-period-intersection per1 per2)
    322   (%check-time-period 'time-period-intersection per1)
    323   (%check-time-period 'time-period-intersection per2)
     322  (check-time-period 'time-period-intersection per1)
     323  (check-time-period 'time-period-intersection per2)
    324324  (receive (bi ei) (tm:time-period-intersection-values 'time-period-intersection per1 per2)
    325325    (and (tm:time<=? bi ei)
    326          (%make-time-period bi ei)) ) )
     326         (*make-time-period bi ei)) ) )
    327327
    328328(define (time-period-union per1 per2)
    329   (%check-time-period 'time-period-union per1)
    330   (%check-time-period 'time-period-union per2)
    331   (let ((b1 (%time-period-begin per1))
    332         (e1 (%time-period-end per1)))
     329  (check-time-period 'time-period-union per1)
     330  (check-time-period 'time-period-union per2)
     331  (let ((b1 (*time-period-begin per1))
     332        (e1 (*time-period-end per1)))
    333333    (let ((b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2)))
    334334          (e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))))
     
    336336        (and (tm:time<=? bi ei)
    337337             (receive (bu eu) (tm:time-point-union-values b1 e1 b2 e2)
    338                (%make-time-period bu eu) ) ) ) ) ) )
     338               (*make-time-period bu eu) ) ) ) ) ) )
    339339
    340340(define (time-period-span per1 per2)
    341   (%check-time-period 'time-period-span per1)
    342   (%check-time-period 'time-period-span per2)
    343   (let ((b1 (%time-period-begin per1))
    344         (e1 (%time-period-end per1)))
    345     (let ((b2 (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2)))
    346           (e2 (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2))))
     341  (check-time-period 'time-period-span per1)
     342  (check-time-period 'time-period-span per2)
     343  (let ((b1 (*time-period-begin per1))
     344        (e1 (*time-period-end per1)))
     345    (let ((b2 (tm:ensure-compatible-time 'time-period-span b1 (*time-period-begin per2)))
     346          (e2 (tm:ensure-compatible-time 'time-period-span e1 (*time-period-end per2))))
    347347    (receive (bu eu) (tm:time-point-union-values b1 e1 b2 e2)
    348       (%make-time-period bu eu) ) ) ) )
     348      (*make-time-period bu eu) ) ) ) )
    349349
    350350(define (time-period-shift per dur)
    351   (%check-time-period 'time-period-shift per)
     351  (check-time-period 'time-period-shift per)
    352352  (tm:check-duration 'time-period-shift dur)
    353353  (tm:time-period-shift per dur (tm:as-empty-time-period per)) )
    354354
    355355(define (time-period-shift! per dur)
    356   (%check-time-period 'time-period-shift! per)
     356  (check-time-period 'time-period-shift! per)
    357357  (tm:check-duration 'time-period-shift! dur)
    358358  (tm:time-period-shift per dur per) )
     359
     360) ;srfi-19-period
  • release/4/srfi-19/trunk/srfi-19.setup

    r15727 r15738  
    55(verify-extension-name "srfi-19")
    66
     7(required-extension-version
     8  'type-errors         "1.4.0"
     9  'locale              "0.6.2")
     10
    711(setup-shared-extension-module (extension-name) (extension-version "0.0.0"))
Note: See TracChangeset for help on using the changeset viewer.