1;;; date.ms 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16(mat time 17 (error? ; wrong number of arguments 18 (make-time)) 19 (error? ; wrong number of arguments 20 (make-time 'time-utc)) 21 (error? ; wrong number of arguments 22 (make-time 'time-utc 17)) 23 (error? ; wrong number of arguments 24 (make-time 'time-utc 17 0 50)) 25 (error? ; invalid type 26 (make-time 'time-nonsense 17 0)) 27 (error? ; invalid seconds 28 (make-time 'time-utc 0 #f)) 29 (error? ; invalid nanoseconds 30 (make-time 'time-utc -1 17)) 31 (error? ; invalid nanoseconds 32 (make-time 'time-utc #e1e9 17)) 33 (error? ; invalid nanoseconds 34 (make-time 'time-utc #f 17)) 35 (error? ; wrong number of arguments 36 (time?)) 37 (error? ; wrong number of arguments 38 (time? #f 3)) 39 (begin 40 (define $time-t1 (make-time 'time-utc (- #e1e9 1) #e1e9)) 41 (and (time? $time-t1) (not (date? $time-t1)))) 42 (error? ; wrong number of arguments 43 (time-type)) 44 (error? ; wrong number of arguments 45 (time-type $time-t1 #t)) 46 (error? ; not a time record 47 (time-type 17)) 48 (error? ; wrong number of arguments 49 (time-second)) 50 (error? ; wrong number of arguments 51 (time-second $time-t1 #t)) 52 (error? ; not a time record 53 (time-second 17)) 54 (error? ; wrong number of arguments 55 (time-nanosecond)) 56 (error? ; wrong number of arguments 57 (time-nanosecond $time-t1 #t)) 58 (error? ; not a time record 59 (time-nanosecond 17)) 60 (error? ; wrong number of arguments 61 (set-time-type!)) 62 (error? ; wrong number of arguments 63 (set-time-type! $time-t1)) 64 (error? ; wrong number of arguments 65 (set-time-type! $time-t1 'time-utc 0)) 66 (error? ; not a time record 67 (set-time-type! 'time-utc 'time-utc)) 68 (error? ; invalid type 69 (set-time-type! $time-t1 'time-nonsense)) 70 (error? ; wrong number of arguments 71 (set-time-second!)) 72 (error? ; wrong number of arguments 73 (set-time-second! $time-t1)) 74 (error? ; wrong number of arguments 75 (set-time-second! $time-t1 5000 0)) 76 (error? ; not a time record 77 (set-time-second! 5000 5000)) 78 (error? ; invalid second 79 (set-time-second! $time-t1 'time-utc)) 80 (error? ; wrong number of arguments 81 (set-time-nanosecond!)) 82 (error? ; wrong number of arguments 83 (set-time-nanosecond! $time-t1)) 84 (error? ; wrong number of arguments 85 (set-time-nanosecond! $time-t1 5000 0)) 86 (error? ; not a time record 87 (set-time-nanosecond! 5000 5000)) 88 (error? ; invalid nanosecond 89 (set-time-nanosecond! $time-t1 -1)) 90 (error? ; invalid nanosecond 91 (set-time-nanosecond! $time-t1 'time-utc)) 92 (error? ; invalid nanosecond 93 (set-time-nanosecond! $time-t1 #e1e9)) 94 (error? ; wrong number of arguments 95 (current-time 'time-utc #t)) 96 (error? ; invalid type 97 (current-time 'time-nonsense)) 98 (begin 99 (define $time-t2 (current-time 'time-utc)) 100 (and (time? $time-t2) (not (date? $time-t2)))) 101 (begin 102 (define $time-t3 (current-time 'time-monotonic)) 103 (and (time? $time-t3) (not (date? $time-t3)))) 104 (begin 105 (define $time-t4 (current-time 'time-duration)) 106 (and (time? $time-t4) (not (date? $time-t4)))) 107 (begin 108 (define $time-t5 (current-time 'time-process)) 109 (and (time? $time-t5) (not (date? $time-t5)))) 110 (begin 111 (define $time-t6 (current-time 'time-thread)) 112 (and (time? $time-t6) (not (date? $time-t6)))) 113 (begin 114 (define $time-t7 (current-time 'time-collector-cpu)) 115 (and (time? $time-t7) (not (date? $time-t7)))) 116 (begin 117 (define $time-t8 (current-time 'time-collector-real)) 118 (and (time? $time-t8) (not (date? $time-t8)))) 119 (eqv? (time-type $time-t1) 'time-utc) 120 (eqv? (time-type $time-t2) 'time-utc) 121 (eqv? (time-type $time-t3) 'time-monotonic) 122 (eqv? (time-type $time-t4) 'time-duration) 123 (eqv? (time-type $time-t5) 'time-process) 124 (eqv? (time-type $time-t6) 'time-thread) 125 (eqv? (time-type $time-t7) 'time-collector-cpu) 126 (eqv? (time-type $time-t8) 'time-collector-real) 127 (eqv? (time-second $time-t1) #e1e9) 128 (eqv? (time-nanosecond $time-t1) (- #e1e9 1)) 129 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t2)) 130 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t3)) 131 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t4)) 132 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t5)) 133 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t6)) 134 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t7)) 135 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (>= x 0))) (time-second $time-t8)) 136 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t2)) 137 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t3)) 138 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t4)) 139 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t5)) 140 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t6)) 141 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t7)) 142 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x (- #e1e9 1)))) (time-nanosecond $time-t8)) 143 (eqv? 144 (let ([sec (+ (time-second (current-time 'time-thread)) 3)] 145 [cnt 0] 146 [ans 0]) 147 (define fib (lambda (x) (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))) 148 (let f () 149 (when (< (time-second (current-time 'time-thread)) sec) 150 (for-each 151 (lambda (t) 152 (let ([n (time-nanosecond (current-time t))]) 153 (unless (<= 0 n #e1e9) 154 (errorf #f "(time-nanosecond (current-time '~s)) = ~s" t n)))) 155 '(time-utc time-monotonic time-duration time-process time-thread)) 156 (set! ans (+ ans (fib 20))) 157 (set! cnt (+ cnt 1)) 158 (f))) 159 (/ ans cnt)) 160 6765) 161 (begin 162 (set-time-type! $time-t1 'time-monotonic) 163 (eqv? (time-type $time-t1) 'time-monotonic)) 164 (begin 165 (set-time-second! $time-t1 3) 166 (eqv? (time-second $time-t1) 3)) 167 (begin 168 (set-time-nanosecond! $time-t1 3000) 169 (eqv? (time-nanosecond $time-t1) 3000)) 170 (error? ; wrong number of arguments 171 (time=?)) 172 (error? ; wrong number of arguments 173 (time=? $time-t1)) 174 (error? ; wrong number of arguments 175 (time=? $time-t1 $time-t1 $time-t1)) 176 (error? ; invalid argument 177 (time=? $time-t1 3)) 178 (error? ; invalid argument 179 (time=? car $time-t1)) 180 (error? ; different types 181 (time=? $time-t4 $time-t5)) 182 (error? ; wrong number of arguments 183 (time<?)) 184 (error? ; wrong number of arguments 185 (time<? $time-t1)) 186 (error? ; wrong number of arguments 187 (time<? $time-t1 $time-t1 $time-t1)) 188 (error? ; invalid argument 189 (time<? $time-t1 3)) 190 (error? ; invalid argument 191 (time<? car $time-t1)) 192 (error? ; different types 193 (time<? $time-t4 $time-t5)) 194 (error? ; wrong number of arguments 195 (time<=?)) 196 (error? ; wrong number of arguments 197 (time<=? $time-t1)) 198 (error? ; wrong number of arguments 199 (time<=? $time-t1 $time-t1 $time-t1)) 200 (error? ; invalid argument 201 (time<=? $time-t1 3)) 202 (error? ; invalid argument 203 (time<=? car $time-t1)) 204 (error? ; different types 205 (time<=? $time-t4 $time-t5)) 206 (error? ; wrong number of arguments 207 (time>?)) 208 (error? ; wrong number of arguments 209 (time>? $time-t1)) 210 (error? ; wrong number of arguments 211 (time>? $time-t1 $time-t1 $time-t1)) 212 (error? ; invalid argument 213 (time>? $time-t1 3)) 214 (error? ; invalid argument 215 (time>? car $time-t1)) 216 (error? ; different types 217 (time>? $time-t4 $time-t5)) 218 (error? ; wrong number of arguments 219 (time>=?)) 220 (error? ; wrong number of arguments 221 (time>=? $time-t1)) 222 (error? ; wrong number of arguments 223 (time>=? $time-t1 $time-t1 $time-t1)) 224 (error? ; invalid argument 225 (time>=? $time-t1 3)) 226 (error? ; invalid argument 227 (time>=? car $time-t1)) 228 (error? ; different types 229 (time>=? $time-t4 $time-t5)) 230 (time=? $time-t1 $time-t1) 231 (time<=? $time-t1 $time-t1) 232 (time>=? $time-t1 $time-t1) 233 (not (time<? $time-t1 $time-t1)) 234 (not (time>? $time-t1 $time-t1)) 235 (equal? 236 (let ([ta (make-time 'time-duration 200 #e1e19)] 237 [tb (make-time 'time-duration 300 #e1e20)] 238 [tc (make-time 'time-duration 300 #e1e20)] 239 [td (make-time 'time-duration 301 #e1e20)] 240 [te (make-time 'time-duration 400 #e1e21)]) 241 (define-syntax foo 242 (syntax-rules () 243 [(_ x ...) 244 (list 245 (let ([t x]) 246 (list (time<? t x) ... 247 (time<=? t x) ... 248 (time=? t x) ... 249 (time>=? t x) ... 250 (time>? t x) ...)) 251 ...)])) 252 (foo ta tb tc td te)) 253 '((#f #t #t #t #t 254 #t #t #t #t #t 255 #t #f #f #f #f 256 #t #f #f #f #f 257 #f #f #f #f #f) 258 (#f #f #f #t #t 259 #f #t #t #t #t 260 #f #t #t #f #f 261 #t #t #t #f #f 262 #t #f #f #f #f) 263 (#f #f #f #t #t 264 #f #t #t #t #t 265 #f #t #t #f #f 266 #t #t #t #f #f 267 #t #f #f #f #f) 268 (#f #f #f #f #t 269 #f #f #f #t #t 270 #f #f #f #t #f 271 #t #t #t #t #f 272 #t #t #t #f #f) 273 (#f #f #f #f #f 274 #f #f #f #f #t 275 #f #f #f #f #t 276 #t #t #t #t #t 277 #t #t #t #t #f))) 278 (error? (time-difference $time-t2 $time-t3)) 279 (error? (add-duration $time-t3 $time-t2)) 280 (error? (subtract-duration $time-t3 $time-t2)) 281 (let ([t (make-time 'time-duration 1000000 -20)]) 282 (and (time? t) 283 (not (date? t)) 284 (eqv? (time-second t) -20) 285 (eqv? (time-nanosecond t) 1000000))) 286 (equal? 287 (let ([t1 (make-time 'time-process 999999999 7)] 288 [t2 (make-time 'time-duration 10 2)]) 289 (let ([t3 (add-duration t1 t2)] 290 [t4 (subtract-duration t1 t2)]) 291 (let ([t5 (time-difference t3 t1)] 292 [t6 (time-difference t1 t3)] 293 [t7 (time-difference t1 t4)] 294 [t8 (time-difference t4 t1)]) 295 (list 296 (list (time-second t3) (time-nanosecond t3)) 297 (list (time-second t4) (time-nanosecond t4)) 298 (time=? t5 t2) 299 (list (time-second t6) (time-nanosecond t6)) 300 (time=? t7 t2) 301 (list (time-second t8) (time-nanosecond t8)))))) 302 '((10 9) (5 999999989) #t (-3 999999990) #t (-3 999999990))) 303 (error? (copy-time (current-date))) 304 (begin 305 (define $new-time-t2 (copy-time $time-t2)) 306 (time? $new-time-t2)) 307 (not (eq? $new-time-t2 $time-t2)) 308 (time=? $new-time-t2 $time-t2) 309) 310 311(mat date 312 (error? ; wrong number of arguments 313 (make-date)) 314 (error? ; wrong number of arguments 315 (make-date 0)) 316 (error? ; wrong number of arguments 317 (make-date 0 0)) 318 (error? ; wrong number of arguments 319 (make-date 0 0 0)) 320 (error? ; wrong number of arguments 321 (make-date 0 0 0 0)) 322 (error? ; wrong number of arguments 323 (make-date 0 0 0 0 1)) 324 (error? ; wrong number of arguments 325 (make-date 0 0 0 0 1 1)) 326 (error? ; wrong number of arguments 327 (make-date 0 0 0 0 1 1 2007 0 0)) 328 (error? ; invalid nanosecond 329 (make-date -1 0 0 0 1 1 2007 0)) 330 (error? ; invalid nanosecond 331 (make-date #e1e9 0 0 0 1 1 2007 0)) 332 (error? ; invalid nanosecond 333 (make-date 'zero 0 0 0 1 1 2007 0)) 334 (error? ; invalid second 335 (make-date 0 -1 0 0 1 1 2007 0)) 336 (error? ; invalid second 337 (make-date 0 62 0 0 1 1 2007 0)) 338 (error? ; invalid second 339 (make-date 0 "hello" 0 0 1 1 2007 0)) 340 (error? ; invalid minute 341 (make-date 0 0 -1 0 1 1 2007 0)) 342 (error? ; invalid minute 343 (make-date 0 0 60 0 1 1 2007 0)) 344 (error? ; invalid minute 345 (make-date 0 0 "hello" 0 1 1 2007 0)) 346 (error? ; invalid hour 347 (make-date 0 0 0 -1 1 1 2007 0)) 348 (error? ; invalid hour 349 (make-date 0 0 0 24 1 1 2007 0)) 350 (error? ; invalid hour 351 (make-date 0 0 0 "hello" 1 1 2007 0)) 352 (error? ; invalid day 353 (make-date 0 0 0 0 0 1 2007 0)) 354 (error? ; invalid day 355 (make-date 0 0 0 0 32 1 2007 0)) 356 (error? ; invalid day 357 (make-date 0 0 0 0 31 11 2007 0)) 358 (error? ; invalid day 359 (make-date 0 0 0 0 29 2 2007 0)) 360 (error? ; invalid day 361 (make-date 0 0 0 0 "hello" 1 2007 0)) 362 (error? ; invalid month 363 (make-date 0 0 0 0 1 0 2007 0)) 364 (error? ; invalid month 365 (make-date 0 0 0 0 1 13 2007 0)) 366 (error? ; invalid month 367 (make-date 0 0 0 0 1 'eleven 2007 0)) 368 (error? ; invalid year 369 (make-date 0 0 0 0 1 1 'mmvii 0)) 370 (error? ; invalid tz 371 (make-date 0 0 0 0 1 1 2007 (* -25 60 60))) 372 (error? ; invalid tz 373 (make-date 0 0 0 0 1 1 2007 (* 25 60 60))) 374 (error? ; invalid tz 375 (make-date 0 0 0 0 1 1 2007 'est)) 376 (error? ; invalid tz 377 (make-date 0 0 0 0 1 1 2007 "est")) 378 (error? ; wrong number of arguments 379 (date?)) 380 (error? ; wrong number of arguments 381 (date? #f 3)) 382 (begin 383 (define $date-d1 (make-date 1 2 3 4 5 6 1970 8)) 384 (and (date? $date-d1) (not (time? $date-d1)))) 385 (error? ; wrong number of arguments 386 (date-nanosecond)) 387 (error? ; wrong number of arguments 388 (date-nanosecond $date-d1 #t)) 389 (error? ; not a date record 390 (date-nanosecond 17)) 391 (error? ; not a date record 392 (date-nanosecond $time-t1)) 393 (error? ; wrong number of arguments 394 (date-nanosecond)) 395 (error? ; wrong number of arguments 396 (date-nanosecond $date-d1 #t)) 397 (error? ; not a date record 398 (date-nanosecond 17)) 399 (error? ; not a date record 400 (date-nanosecond $time-t1)) 401 (error? ; wrong number of arguments 402 (date-second)) 403 (error? ; wrong number of arguments 404 (date-second $date-d1 #t)) 405 (error? ; not a date record 406 (date-second 17)) 407 (error? ; not a date record 408 (date-second $time-t1)) 409 (error? ; wrong number of arguments 410 (date-minute)) 411 (error? ; wrong number of arguments 412 (date-minute $date-d1 #t)) 413 (error? ; not a date record 414 (date-minute 17)) 415 (error? ; not a date record 416 (date-minute $time-t1)) 417 (error? ; wrong number of arguments 418 (date-hour)) 419 (error? ; wrong number of arguments 420 (date-hour $date-d1 #t)) 421 (error? ; not a date record 422 (date-hour 17)) 423 (error? ; not a date record 424 (date-hour $time-t1)) 425 (error? ; wrong number of arguments 426 (date-day)) 427 (error? ; wrong number of arguments 428 (date-day $date-d1 #t)) 429 (error? ; not a date record 430 (date-day 17)) 431 (error? ; not a date record 432 (date-day $time-t1)) 433 (error? ; wrong number of arguments 434 (date-month)) 435 (error? ; wrong number of arguments 436 (date-month $date-d1 #t)) 437 (error? ; not a date record 438 (date-month 17)) 439 (error? ; not a date record 440 (date-month $time-t1)) 441 (error? ; wrong number of arguments 442 (date-year)) 443 (error? ; wrong number of arguments 444 (date-year $date-d1 #t)) 445 (error? ; not a date record 446 (date-year 17)) 447 (error? ; not a date record 448 (date-year $time-t1)) 449 (error? ; wrong number of arguments 450 (date-week-day)) 451 (error? ; wrong number of arguments 452 (date-week-day $date-d1 #t)) 453 (error? ; not a date record 454 (date-week-day 17)) 455 (error? ; not a date record 456 (date-week-day $time-t1)) 457 (error? ; wrong number of arguments 458 (date-year-day)) 459 (error? ; wrong number of arguments 460 (date-year-day $date-d1 #t)) 461 (error? ; not a date record 462 (date-year-day 17)) 463 (error? ; not a date record 464 (date-year-day $time-t1)) 465 (error? ; wrong number of arguments 466 (date-dst?)) 467 (error? ; wrong number of arguments 468 (date-dst? $date-d1 #t)) 469 (error? ; not a date record 470 (date-dst? 17)) 471 (error? ; not a date record 472 (date-dst? $time-t1)) 473 (error? ; wrong number of arguments 474 (date-zone-offset)) 475 (error? ; wrong number of arguments 476 (date-zone-offset $date-d1 #t)) 477 (error? ; not a date record 478 (date-zone-offset 17)) 479 (error? ; not a date record 480 (date-zone-offset $time-t1)) 481 (error? ; wrong number of arguments 482 (date-zone-name)) 483 (error? ; wrong number of arguments 484 (date-zone-name $date-d1 #t)) 485 (error? ; not a date record 486 (date-zone-name 17)) 487 (error? ; not a date record 488 (date-zone-name $time-t1)) 489 (error? ; wrong number of arguments 490 (current-date 0 #t)) 491 (error? ; invalid offset 492 (current-date (* -25 60 60))) 493 (error? ; invalid offset 494 (current-date (* 25 60 60))) 495 (begin 496 (define $date-d2 (current-date)) 497 (and (date? $date-d2) (not (time? $date-d2)))) 498 (begin 499 (define $date-d3 (current-date (* -5 60 60))) 500 (and (date? $date-d3) (not (time? $date-d3)))) 501 (begin 502 (define $date-d4 (current-date (* 10 60 60))) 503 (and (date? $date-d4) (not (time? $date-d4)))) 504 (begin 505 (define $date-d5 (make-date 0 1 1 1 15 6 2016)) 506 (and (date? $date-d5) (not (time? $date-d5)))) 507 (date? (make-date 0 0 0 0 1 1 1970 -24)) 508 (date? (make-date 999999999 59 59 23 31 12 2007 24)) 509 (begin 510 (define $date-d8 (make-date 999999999 59 59 23 31 12 2007 24)) 511 #t) 512 (eqv? (fixnum? 999999999) 513 (fixnum? (date-nanosecond $date-d8))) 514 (eqv? (date-nanosecond $date-d1) 1) 515 (eqv? (date-second $date-d1) 2) 516 (eqv? (date-minute $date-d1) 3) 517 (eqv? (date-hour $date-d1) 4) 518 (eqv? (date-day $date-d1) 5) 519 (eqv? (date-month $date-d1) 6) 520 (eqv? (date-year $date-d1) 1970) 521 (eqv? (date-zone-offset $date-d1) 8) 522 (boolean? (date-dst? $date-d5)) 523 (fixnum? (date-zone-offset $date-d5)) 524 (eqv? (date-zone-name $date-d1) #f) 525 (or (string? (date-zone-name $date-d2)) 526 (not (date-zone-name $date-d2))) 527 (eqv? (date-zone-name $date-d3) #f) 528 (eqv? (date-zone-name $date-d4) #f) 529 (or (string? (date-zone-name $date-d5)) 530 (not (date-zone-name $date-d5))) 531 (begin 532 (define (plausible-dst? d) 533 ;; Recognize a few time zone names and correlate with the DST field. 534 ;; Names like "EST" appear on Unix variants, while the long names 535 ;; show up on Windows. 536 (cond 537 [(member (date-zone-name d) '("EST" "CST" "MST" "PST" 538 "Eastern Standard Time" 539 "Central Standard Time" 540 "Mountain Standard Time" 541 "Pacific Standard Time")) 542 (eqv? (date-dst? d) #f)] 543 [(member (date-zone-name d) '("EDT" "CDT" "MDT" "PDT" 544 "Eastern Daylight Time" 545 "Central Daylight Time" 546 "Mountain Daylight Time" 547 "Pacific Daylight Time")) 548 (eqv? (date-dst? d) #t)] 549 [else #t])) 550 (plausible-dst? $date-d5)) 551 (begin 552 (define $date-d6 (make-date 0 1 1 1 15 1 2016)) 553 (plausible-dst? $date-d6)) 554 ; check whether tz offsets are set according to DST, assuming that 555 ; DST always means a 1-hour shift 556 (let ([delta (time-second (time-difference (date->time-utc $date-d5) 557 (date->time-utc $date-d6)))] 558 [no-dst-delta (* 152 24 60 60)]; 152 days 559 [hour-delta (* 60 60)]) 560 (cond 561 [(and (date-dst? $date-d5) (not (date-dst? $date-d6))) 562 ;; Northern-hemisphere DST reduces delta 563 (= delta (- no-dst-delta hour-delta))] 564 [(and (not (date-dst? $date-d5)) (date-dst? $date-d6)) 565 ;; Southern-hemisphere DST increases delta 566 (= delta (+ no-dst-delta hour-delta))] 567 [else 568 ;; No DST or always DST 569 (= delta no-dst-delta)])) 570 ; check to make sure dst isn't screwing with our explicitly created dates 571 ; when we call mktime to fill in wday and yday 572 (let f ([mon 1]) 573 (or (= mon 13) 574 (and (andmap 575 (lambda (day) 576 (let ([d (make-date 5 6 7 8 day mon 2007 -18000)]) 577 (and (eqv? (date-nanosecond d) 5) 578 (eqv? (date-second d) 6) 579 (eqv? (date-minute d) 7) 580 (eqv? (date-hour d) 8) 581 (eqv? (date-day d) day) 582 (eqv? (date-month d) mon) 583 (eqv? (date-year d) 2007) 584 (eqv? (date-zone-offset d) -18000)))) 585 '(5 10 15 20 25)) 586 (f (+ mon 1))))) 587 (eqv? (date-zone-offset $date-d3) (* -5 60 60)) 588 (eqv? (date-zone-offset $date-d4) (* 10 60 60)) 589 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x 999999999))) (date-nanosecond $date-d2)) 590 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x 999999999))) (date-nanosecond $date-d3)) 591 ((lambda (x) (and (or (fixnum? x) (bignum? x)) (<= 0 x 999999999))) (date-nanosecond $date-d4)) 592 ((lambda (x) (and (fixnum? x) (<= 0 x 61))) (date-second $date-d2)) 593 ((lambda (x) (and (fixnum? x) (<= 0 x 61))) (date-second $date-d3)) 594 ((lambda (x) (and (fixnum? x) (<= 0 x 61))) (date-second $date-d4)) 595 ((lambda (x) (and (fixnum? x) (<= 0 x 59))) (date-minute $date-d2)) 596 ((lambda (x) (and (fixnum? x) (<= 0 x 59))) (date-minute $date-d3)) 597 ((lambda (x) (and (fixnum? x) (<= 0 x 59))) (date-minute $date-d4)) 598 ((lambda (x) (and (fixnum? x) (<= 0 x 23))) (date-hour $date-d2)) 599 ((lambda (x) (and (fixnum? x) (<= 0 x 23))) (date-hour $date-d3)) 600 ((lambda (x) (and (fixnum? x) (<= 0 x 23))) (date-hour $date-d4)) 601 ((lambda (x) (and (fixnum? x) (<= 1 x 31))) (date-day $date-d2)) 602 ((lambda (x) (and (fixnum? x) (<= 1 x 31))) (date-day $date-d3)) 603 ((lambda (x) (and (fixnum? x) (<= 1 x 31))) (date-day $date-d4)) 604 ((lambda (x) (and (fixnum? x) (<= 1 x 12))) (date-month $date-d2)) 605 ((lambda (x) (and (fixnum? x) (<= 1 x 12))) (date-month $date-d3)) 606 ((lambda (x) (and (fixnum? x) (<= 1 x 12))) (date-month $date-d4)) 607 ((lambda (x) (and (fixnum? x) (<= 1900 x 2038))) (date-year $date-d2)) 608 ((lambda (x) (and (fixnum? x) (<= 1900 x 2038))) (date-year $date-d3)) 609 ((lambda (x) (and (fixnum? x) (<= 1900 x 2038))) (date-year $date-d4)) 610 (let ([s (date-and-time)]) 611 (and (fixnum? (read (open-input-string (substring s 8 10)))) 612 (fixnum? (read (open-input-string (substring s 20 24)))))) 613 (let ([d (current-date)]) 614 (let ([s (date-and-time d)]) 615 (and (= (read (open-input-string (substring s 8 10))) (date-day d)) 616 (= (read (open-input-string (substring s 11 13))) (date-hour d)) 617 (= (read (open-input-string (substring s 20 24))) (date-year d))))) 618) 619 620(mat conversions/sleep 621 (error? (date->time-utc (current-time))) 622 (error? (time-utc->date (current-date))) 623 (error? (sleep 20)) 624 (time? (date->time-utc (current-date))) 625 (date? (time-utc->date (current-time 'time-utc))) 626 (let ([t (current-time 'time-utc)]) 627 (sleep (make-time 'time-duration 0 1)) 628 (time<? t (date->time-utc (current-date)))) 629 (let ([t (current-time)]) 630 (and 631 (time=? (date->time-utc (time-utc->date t)) t) 632 (time=? (date->time-utc (time-utc->date t -86400)) t) 633 (time=? (date->time-utc (time-utc->date t 0)) t) 634 (time=? (date->time-utc (time-utc->date t 86400)) t))) 635) 636 637(mat time&date-printing 638 (equal? 639 (with-output-to-string (lambda () (pretty-print (make-time 'time-duration 1 -1)))) 640 "#<time-duration -0.999999999>\n") 641 (equal? 642 (with-output-to-string (lambda () (write (time-utc->date (make-time 'time-utc 708626501 1427137297) -14400)))) 643 "#<date Mon Mar 23 15:01:37 2015>") 644) 645