0000: 3b 3b 20 53 52 46 49 2d 31 39 3a 20 54 69 6d 65 ;; SRFI-19: Time
0010: 20 44 61 74 61 20 54 79 70 65 73 20 61 6e 64 20 Data Types and
0020: 50 72 6f 63 65 64 75 72 65 73 2e 0a 3b 3b 0a 3b Procedures..;;.;
0030: 3b 20 4d 6f 64 69 66 69 65 64 20 62 79 20 44 65 ; Modified by De
0040: 72 69 63 6b 20 45 64 64 69 6e 67 74 6f 6e 20 74 rick Eddington t
0050: 6f 20 62 65 20 69 6e 63 6c 75 64 65 64 20 69 6e o be included in
0060: 74 6f 20 74 68 65 20 28 73 72 66 69 20 3a 31 39 to the (srfi :19
0070: 20 74 69 6d 65 29 20 52 36 52 53 20 6c 69 62 72 time) R6RS libr
0080: 61 72 79 2e 0a 3b 3b 20 54 4f 44 4f 3a 20 46 6f ary..;; TODO: Fo
0090: 72 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e r implementation
00a0: 73 20 77 68 69 63 68 20 68 61 76 65 20 74 68 72 s which have thr
00b0: 65 61 64 73 2c 20 0a 3b 3b 20 20 20 20 20 20 20 eads, .;;
00c0: 74 68 65 20 74 68 72 65 61 64 20 74 69 6d 69 6e the thread timin
00d0: 67 20 73 74 75 66 66 20 63 61 6e 20 70 72 6f 62 g stuff can prob
00e0: 61 62 6c 79 20 62 65 20 6d 61 64 65 20 74 6f 20 ably be made to
00f0: 77 6f 72 6b 2e 0a 3b 3b 20 0a 3b 3b 20 43 6f 70 work..;; .;; Cop
0100: 79 72 69 67 68 74 20 28 43 29 20 49 2f 4e 45 54 yright (C) I/NET
0110: 2c 20 49 6e 63 2e 20 28 32 30 30 30 2c 20 32 30 , Inc. (2000, 20
0120: 30 32 2c 20 32 30 30 33 29 2e 20 41 6c 6c 20 52 02, 2003). All R
0130: 69 67 68 74 73 20 52 65 73 65 72 76 65 64 2e 20 ights Reserved.
0140: 0a 3b 3b 20 0a 3b 3b 20 54 68 69 73 20 64 6f 63 .;; .;; This doc
0150: 75 6d 65 6e 74 20 61 6e 64 20 74 72 61 6e 73 6c ument and transl
0160: 61 74 69 6f 6e 73 20 6f 66 20 69 74 20 6d 61 79 ations of it may
0170: 20 62 65 20 63 6f 70 69 65 64 20 61 6e 64 20 66 be copied and f
0180: 75 72 6e 69 73 68 65 64 20 74 6f 20 6f 74 68 65 urnished to othe
0190: 72 73 2c 20 0a 3b 3b 20 61 6e 64 20 64 65 72 69 rs, .;; and deri
01a0: 76 61 74 69 76 65 20 77 6f 72 6b 73 20 74 68 61 vative works tha
01b0: 74 20 63 6f 6d 6d 65 6e 74 20 6f 6e 20 6f 72 20 t comment on or
01c0: 6f 74 68 65 72 77 69 73 65 20 65 78 70 6c 61 69 otherwise explai
01d0: 6e 20 69 74 20 6f 72 20 61 73 73 69 73 74 20 69 n it or assist i
01e0: 6e 20 69 74 73 20 0a 3b 3b 20 69 6d 70 6c 65 6d n its .;; implem
01f0: 65 6e 74 61 74 69 6f 6e 20 6d 61 79 20 62 65 20 entation may be
0200: 70 72 65 70 61 72 65 64 2c 20 63 6f 70 69 65 64 prepared, copied
0210: 2c 20 70 75 62 6c 69 73 68 65 64 20 61 6e 64 20 , published and
0220: 64 69 73 74 72 69 62 75 74 65 64 2c 20 69 6e 20 distributed, in
0230: 77 68 6f 6c 65 20 6f 72 20 0a 3b 3b 20 69 6e 20 whole or .;; in
0240: 70 61 72 74 2c 20 77 69 74 68 6f 75 74 20 72 65 part, without re
0250: 73 74 72 69 63 74 69 6f 6e 20 6f 66 20 61 6e 79 striction of any
0260: 20 6b 69 6e 64 2c 20 70 72 6f 76 69 64 65 64 20 kind, provided
0270: 74 68 61 74 20 74 68 65 20 61 62 6f 76 65 20 63 that the above c
0280: 6f 70 79 72 69 67 68 74 20 0a 3b 3b 20 6e 6f 74 opyright .;; not
0290: 69 63 65 20 61 6e 64 20 74 68 69 73 20 70 61 72 ice and this par
02a0: 61 67 72 61 70 68 20 61 72 65 20 69 6e 63 6c 75 agraph are inclu
02b0: 64 65 64 20 6f 6e 20 61 6c 6c 20 73 75 63 68 20 ded on all such
02c0: 63 6f 70 69 65 73 20 61 6e 64 20 64 65 72 69 76 copies and deriv
02d0: 61 74 69 76 65 20 77 6f 72 6b 73 2e 20 0a 3b 3b ative works. .;;
02e0: 20 48 6f 77 65 76 65 72 2c 20 74 68 69 73 20 64 However, this d
02f0: 6f 63 75 6d 65 6e 74 20 69 74 73 65 6c 66 20 6d ocument itself m
0300: 61 79 20 6e 6f 74 20 62 65 20 6d 6f 64 69 66 69 ay not be modifi
0310: 65 64 20 69 6e 20 61 6e 79 20 77 61 79 2c 20 73 ed in any way, s
0320: 75 63 68 20 61 73 20 62 79 20 0a 3b 3b 20 72 65 uch as by .;; re
0330: 6d 6f 76 69 6e 67 20 74 68 65 20 63 6f 70 79 72 moving the copyr
0340: 69 67 68 74 20 6e 6f 74 69 63 65 20 6f 72 20 72 ight notice or r
0350: 65 66 65 72 65 6e 63 65 73 20 74 6f 20 74 68 65 eferences to the
0360: 20 53 63 68 65 6d 65 20 52 65 71 75 65 73 74 20 Scheme Request
0370: 46 6f 72 20 0a 3b 3b 20 49 6d 70 6c 65 6d 65 6e For .;; Implemen
0380: 74 61 74 69 6f 6e 20 70 72 6f 63 65 73 73 20 6f tation process o
0390: 72 20 65 64 69 74 6f 72 73 2c 20 65 78 63 65 70 r editors, excep
03a0: 74 20 61 73 20 6e 65 65 64 65 64 20 66 6f 72 20 t as needed for
03b0: 74 68 65 20 70 75 72 70 6f 73 65 20 6f 66 20 0a the purpose of .
03c0: 3b 3b 20 64 65 76 65 6c 6f 70 69 6e 67 20 53 52 ;; developing SR
03d0: 46 49 73 20 69 6e 20 77 68 69 63 68 20 63 61 73 FIs in which cas
03e0: 65 20 74 68 65 20 70 72 6f 63 65 64 75 72 65 73 e the procedures
03f0: 20 66 6f 72 20 63 6f 70 79 72 69 67 68 74 73 20 for copyrights
0400: 64 65 66 69 6e 65 64 20 69 6e 20 74 68 65 20 53 defined in the S
0410: 52 46 49 20 0a 3b 3b 20 70 72 6f 63 65 73 73 20 RFI .;; process
0420: 6d 75 73 74 20 62 65 20 66 6f 6c 6c 6f 77 65 64 must be followed
0430: 2c 20 6f 72 20 61 73 20 72 65 71 75 69 72 65 64 , or as required
0440: 20 74 6f 20 74 72 61 6e 73 6c 61 74 65 20 69 74 to translate it
0450: 20 69 6e 74 6f 20 6c 61 6e 67 75 61 67 65 73 20 into languages
0460: 6f 74 68 65 72 20 0a 3b 3b 20 74 68 61 6e 20 45 other .;; than E
0470: 6e 67 6c 69 73 68 2e 20 0a 3b 3b 20 0a 3b 3b 20 nglish. .;; .;;
0480: 54 68 65 20 6c 69 6d 69 74 65 64 20 70 65 72 6d The limited perm
0490: 69 73 73 69 6f 6e 73 20 67 72 61 6e 74 65 64 20 issions granted
04a0: 61 62 6f 76 65 20 61 72 65 20 70 65 72 70 65 74 above are perpet
04b0: 75 61 6c 20 61 6e 64 20 77 69 6c 6c 20 6e 6f 74 ual and will not
04c0: 20 62 65 20 72 65 76 6f 6b 65 64 20 0a 3b 3b 20 be revoked .;;
04d0: 62 79 20 74 68 65 20 61 75 74 68 6f 72 73 20 6f by the authors o
04e0: 72 20 74 68 65 69 72 20 73 75 63 63 65 73 73 6f r their successo
04f0: 72 73 20 6f 72 20 61 73 73 69 67 6e 73 2e 20 0a rs or assigns. .
0500: 3b 3b 20 0a 3b 3b 20 54 68 69 73 20 64 6f 63 75 ;; .;; This docu
0510: 6d 65 6e 74 20 61 6e 64 20 74 68 65 20 69 6e 66 ment and the inf
0520: 6f 72 6d 61 74 69 6f 6e 20 63 6f 6e 74 61 69 6e ormation contain
0530: 65 64 20 68 65 72 65 69 6e 20 69 73 20 70 72 6f ed herein is pro
0540: 76 69 64 65 64 20 6f 6e 20 61 6e 20 22 41 53 20 vided on an "AS
0550: 49 53 22 20 0a 3b 3b 20 62 61 73 69 73 20 61 6e IS" .;; basis an
0560: 64 20 54 48 45 20 41 55 54 48 4f 52 20 41 4e 44 d THE AUTHOR AND
0570: 20 54 48 45 20 53 52 46 49 20 45 44 49 54 4f 52 THE SRFI EDITOR
0580: 53 20 44 49 53 43 4c 41 49 4d 20 41 4c 4c 20 57 S DISCLAIM ALL W
0590: 41 52 52 41 4e 54 49 45 53 2c 20 45 58 50 52 45 ARRANTIES, EXPRE
05a0: 53 53 20 4f 52 20 0a 3b 3b 20 49 4d 50 4c 49 45 SS OR .;; IMPLIE
05b0: 44 2c 20 49 4e 43 4c 55 44 49 4e 47 20 42 55 54 D, INCLUDING BUT
05c0: 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 54 4f 20 NOT LIMITED TO
05d0: 41 4e 59 20 57 41 52 52 41 4e 54 59 20 54 48 41 ANY WARRANTY THA
05e0: 54 20 54 48 45 20 55 53 45 20 4f 46 20 54 48 45 T THE USE OF THE
05f0: 20 0a 3b 3b 20 49 4e 46 4f 52 4d 41 54 49 4f 4e .;; INFORMATION
0600: 20 48 45 52 45 49 4e 20 57 49 4c 4c 20 4e 4f 54 HEREIN WILL NOT
0610: 20 49 4e 46 52 49 4e 47 45 20 41 4e 59 20 52 49 INFRINGE ANY RI
0620: 47 48 54 53 20 4f 52 20 41 4e 59 20 49 4d 50 4c GHTS OR ANY IMPL
0630: 49 45 44 20 57 41 52 52 41 4e 54 49 45 53 20 4f IED WARRANTIES O
0640: 46 20 0a 3b 3b 20 4d 45 52 43 48 41 4e 54 41 42 F .;; MERCHANTAB
0650: 49 4c 49 54 59 20 4f 52 20 46 49 54 4e 45 53 53 ILITY OR FITNESS
0660: 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 4c 41 FOR A PARTICULA
0670: 52 20 50 55 52 50 4f 53 45 2e 20 0a 0a 0a 3b 3b R PURPOSE. ...;;
0680: 20 2d 2d 20 42 75 67 20 66 69 78 65 73 2e 0a 3b -- Bug fixes..;
0690: 3b 0a 3b 3b 20 4d 41 4b 45 2d 54 49 4d 45 20 68 ;.;; MAKE-TIME h
06a0: 61 64 20 70 61 72 61 6d 65 74 65 72 73 20 73 65 ad parameters se
06b0: 63 6f 6e 64 73 20 61 6e 64 20 6e 61 6e 6f 73 65 conds and nanose
06c0: 63 6f 6e 64 73 20 72 65 76 65 72 73 65 64 3b 20 conds reversed;
06d0: 63 68 61 6e 67 65 20 61 6c 6c 0a 3b 3b 20 20 20 change all.;;
06e0: 20 20 20 20 20 20 20 20 72 65 66 65 72 65 6e 63 referenc
06f0: 65 73 20 69 6e 20 66 69 6c 65 20 74 6f 20 6d 61 es in file to ma
0700: 74 63 68 2e 20 20 57 69 6c 6c 20 46 3a 20 32 30 tch. Will F: 20
0710: 30 32 2d 31 30 2d 31 35 0a 3b 3b 0a 3b 3b 20 44 02-10-15.;;.;; D
0720: 41 54 45 2d 59 45 41 52 2d 44 41 59 20 72 65 74 ATE-YEAR-DAY ret
0730: 75 72 6e 65 64 20 74 68 65 20 77 72 6f 6e 67 20 urned the wrong
0740: 64 61 79 3b 20 74 6d 3a 79 65 61 72 2d 64 61 79 day; tm:year-day
0750: 20 66 69 78 65 64 20 74 6f 20 64 6f 20 74 68 65 fixed to do the
0760: 20 72 69 67 68 74 0a 3b 3b 20 20 20 20 20 20 20 right.;;
0770: 20 20 20 20 20 20 20 20 74 68 69 6e 67 2e 20 57 thing. W
0780: 69 6c 6c 20 46 3a 20 32 30 30 32 2d 31 30 2d 31 ill F: 2002-10-1
0790: 35 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 5.;;
07a0: 20 20 20 49 74 20 61 6c 73 6f 20 63 61 6c 6c 65 It also calle
07b0: 64 20 61 6e 20 75 6e 64 65 66 69 6e 65 64 20 65 d an undefined e
07c0: 72 72 6f 72 20 70 72 6f 63 65 64 75 72 65 2e 0a rror procedure..
07d0: 3b 3b 0a 3b 3b 20 44 49 53 50 4c 41 59 49 4e 47 ;;.;; DISPLAYING
07e0: 20 70 72 6f 63 65 64 75 72 65 20 72 65 6d 6f 76 procedure remov
07f0: 65 64 2e 20 57 69 6c 6c 20 46 3a 20 32 30 30 32 ed. Will F: 2002
0800: 2d 31 30 2d 31 35 2e 0a 3b 3b 0a 3b 3b 20 54 4d -10-15..;;.;; TM
0810: 3a 4e 41 4e 4f 20 63 6f 6e 73 74 61 6e 74 20 63 :NANO constant c
0820: 6f 72 72 65 63 74 65 64 2e 20 32 30 30 32 2d 31 orrected. 2002-1
0830: 31 2d 30 34 2e 0a 3b 3b 0a 3b 3b 20 54 68 65 20 1-04..;;.;; The
0840: 66 6f 6c 6c 6f 77 69 6e 67 20 66 69 78 65 73 20 following fixes
0850: 62 79 20 57 69 6c 6c 20 46 69 74 7a 67 65 72 61 by Will Fitzgera
0860: 6c 64 2c 20 46 65 62 72 75 61 72 79 2c 20 32 30 ld, February, 20
0870: 30 33 2e 0a 3b 3b 20 20 2d 2d 20 54 68 61 6e 6b 03..;; -- Thank
0880: 73 20 74 6f 20 53 74 65 76 65 6e 20 4d 61 20 61 s to Steven Ma a
0890: 6e 64 20 6f 74 68 65 72 73 2e 0a 3b 3b 0a 3b 3b nd others..;;.;;
08a0: 20 28 43 55 52 52 45 4e 54 2d 54 49 4d 45 20 27 (CURRENT-TIME '
08b0: 54 49 4d 45 2d 54 48 52 45 41 44 29 20 61 64 64 TIME-THREAD) add
08c0: 65 64 2e 0a 3b 3b 0a 3b 3b 20 54 49 4d 45 2d 52 ed..;;.;; TIME-R
08d0: 45 53 4f 4c 55 54 49 4f 4e 20 66 6f 72 20 54 49 ESOLUTION for TI
08e0: 4d 45 2d 50 52 4f 43 45 53 53 20 61 64 64 65 64 ME-PROCESS added
08f0: 2e 20 0a 3b 3b 0a 3b 3b 20 54 49 4d 45 20 63 6f . .;;.;; TIME co
0900: 6d 70 61 72 69 73 6f 6e 20 70 72 6f 63 65 64 75 mparison procedu
0910: 72 65 73 20 28 74 69 6d 65 3d 3f 2c 20 65 74 63 res (time=?, etc
0920: 2e 20 66 69 78 65 64 2e 20 0a 3b 3b 0a 3b 3b 20 . fixed. .;;.;;
0930: 43 6f 72 72 65 63 74 65 64 20 65 72 72 6f 72 73 Corrected errors
0940: 20 69 6e 20 63 6f 6e 76 65 72 74 69 6e 67 20 62 in converting b
0950: 65 74 77 65 65 6e 20 54 41 49 20 61 6e 64 20 55 etween TAI and U
0960: 54 43 20 74 69 6d 65 2e 0a 3b 3b 0a 3b 3b 20 54 TC time..;;.;; T
0970: 41 49 20 61 6e 64 20 55 54 43 20 64 61 74 65 20 AI and UTC date
0980: 63 6f 6e 76 65 72 74 65 72 73 20 6e 6f 20 6c 6f converters no lo
0990: 6e 67 65 72 20 6c 6f 6f 6b 20 61 74 20 6c 65 61 nger look at lea
09a0: 70 20 73 65 63 6f 6e 64 73 2c 0a 3b 3b 20 77 68 p seconds,.;; wh
09b0: 69 63 68 20 77 61 73 20 61 6e 20 65 72 72 6f 72 ich was an error
09c0: 2e 0a 3b 3b 0a 3b 3b 20 63 6f 72 72 65 63 74 69 ..;;.;; correcti
09d0: 6f 6e 73 20 74 6f 20 63 61 6c 6c 73 20 74 6f 20 ons to calls to
09e0: 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 0a 3b 3b tm:time-error.;;
09f0: 0a 3b 3b 20 74 69 6d 65 7a 6f 6e 65 20 6f 66 66 .;; timezone off
0a00: 73 65 74 20 6e 6f 74 20 75 73 65 64 20 69 6e 20 set not used in
0a10: 64 61 74 65 2d 3e 74 69 6d 65 2d 75 74 63 20 61 date->time-utc a
0a20: 6e 64 20 64 61 74 65 2d 3e 6a 75 6c 69 61 6e 2d nd date->julian-
0a30: 64 61 79 0a 3b 3b 0a 3b 3b 20 74 79 70 6f 73 20 day.;;.;; typos
0a40: 69 6e 20 74 6d 3a 69 6e 74 65 67 65 72 2d 72 65 in tm:integer-re
0a50: 61 64 65 72 2d 65 78 61 63 74 2c 20 74 6d 3a 73 ader-exact, tm:s
0a60: 74 72 69 6e 67 2d 3e 64 61 74 65 2c 0a 3b 3b 20 tring->date,.;;
0a70: 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e time-monotonic->
0a80: 74 69 6d 65 2d 75 74 63 21 2c 20 74 6d 3a 63 68 time-utc!, tm:ch
0a90: 61 72 2d 3e 69 6e 74 20 66 69 78 65 64 0a 3b 3b ar->int fixed.;;
0aa0: 0a 3b 3b 20 63 6f 72 72 65 63 74 65 64 20 22 7e .;; corrected "~
0ab0: 6b 22 2c 20 22 7e 66 22 20 66 6f 72 6d 61 74 74 k", "~f" formatt
0ac0: 69 6e 67 20 66 6f 72 20 64 61 74 65 2d 3e 73 74 ing for date->st
0ad0: 72 69 6e 67 20 28 69 6e 63 6c 75 64 65 73 20 66 ring (includes f
0ae0: 69 78 20 66 6f 72 0a 3b 3b 20 22 7e 34 22 0a 3b ix for.;; "~4".;
0af0: 3b 0a 3b 3b 20 27 73 70 6c 69 74 2d 72 65 61 6c ;.;; 'split-real
0b00: 27 20 66 69 78 65 64 2e 0a 3b 3b 0a 3b 3b 20 66 ' fixed..;;.;; f
0b10: 69 78 65 64 20 6a 75 6c 69 61 6e 2d 64 61 79 2d ixed julian-day-
0b20: 3e 74 69 6d 65 2d 75 74 63 20 61 6e 64 20 76 61 >time-utc and va
0b30: 72 69 61 6e 74 73 2e 0a 3b 3b 0a 3b 3b 20 63 68 riants..;;.;; ch
0b40: 61 6e 67 65 73 20 32 30 30 33 2d 30 32 2d 32 36 anges 2003-02-26
0b50: 2c 20 62 61 73 65 64 20 6f 6e 20 63 6f 6d 6d 65 , based on comme
0b60: 6e 74 73 20 62 79 20 4d 61 72 74 69 6e 20 47 61 nts by Martin Ga
0b70: 73 62 69 63 68 6c 65 72 2e 0a 3b 3b 20 0a 3b 3b sbichler..;; .;;
0b80: 20 6d 6f 72 6f 6e 69 63 2c 20 6f 76 65 72 6c 79 moronic, overly
0b90: 20 63 6f 6d 70 6c 69 63 61 74 65 64 20 43 4f 50 complicated COP
0ba0: 59 2d 54 49 4d 45 20 70 72 6f 63 65 64 75 72 65 Y-TIME procedure
0bb0: 20 63 68 61 6e 67 65 64 0a 3b 3b 20 74 6f 20 73 changed.;; to s
0bc0: 69 6d 70 6c 65 20 76 65 72 73 69 6f 6e 20 73 75 imple version su
0bd0: 67 67 65 73 74 65 64 20 62 79 20 4d 61 72 74 69 ggested by Marti
0be0: 6e 20 47 61 73 62 69 63 68 6c 65 72 2e 0a 3b 3b n Gasbichler..;;
0bf0: 0a 3b 3b 20 54 6f 20 70 72 6f 76 69 64 65 20 6d .;; To provide m
0c00: 6f 72 65 20 70 6f 72 74 61 62 69 6c 69 74 79 2c ore portability,
0c10: 20 63 68 61 6e 67 65 64 20 23 5c 53 70 61 63 65 changed #\Space
0c20: 20 74 6f 20 23 5c 73 70 61 63 65 0a 3b 3b 20 61 to #\space.;; a
0c30: 6e 64 20 23 5c 74 61 62 20 74 6f 20 23 5c 54 61 nd #\tab to #\Ta
0c40: 62 20 74 6f 20 28 69 6e 74 65 67 65 72 2d 3e 63 b to (integer->c
0c50: 68 61 72 20 39 29 0a 3b 3b 0a 3b 3b 20 63 68 61 har 9).;;.;; cha
0c60: 6e 67 65 64 20 61 72 69 74 79 2d 33 20 63 61 6c nged arity-3 cal
0c70: 6c 73 20 74 6f 20 2f 20 61 6e 64 20 2d 20 74 6f ls to / and - to
0c80: 20 61 72 69 74 79 20 32 20 63 61 6c 6c 73 20 28 arity 2 calls (
0c90: 61 67 61 69 6e 2c 0a 3b 3b 20 66 6f 72 20 6d 6f again,.;; for mo
0ca0: 72 65 20 67 65 6e 65 72 61 6c 20 70 6f 72 74 61 re general porta
0cb0: 62 69 6c 69 74 79 29 2e 20 0a 3b 3b 0a 3b 3b 20 bility). .;;.;;
0cc0: 73 70 6c 69 74 2d 72 65 61 6c 20 66 69 78 65 64 split-real fixed
0cd0: 20 61 67 61 69 6e 20 2d 2d 20 62 79 20 72 65 6d again -- by rem
0ce0: 6f 76 69 6e 67 20 69 74 2c 20 61 6e 64 20 75 73 oving it, and us
0cf0: 69 6e 67 0a 3b 3b 20 27 66 72 61 63 74 69 6f 6e ing.;; 'fraction
0d00: 61 6c 20 70 61 72 74 27 2e 20 57 69 6c 6c 20 46 al part'. Will F
0d10: 69 74 7a 67 65 72 61 6c 64 20 35 2f 31 36 2f 32 itzgerald 5/16/2
0d20: 30 30 33 2e 0a 3b 3b 20 2d 2d 2d 2d 2d 2d 2d 2d 003..;; --------
0d30: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0d40: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0d50: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0d60: 2d 2d 2d 2d 2d 2d 0a 0a 28 64 65 66 69 6e 65 2d ------..(define-
0d70: 73 79 6e 74 61 78 20 72 65 63 65 69 76 65 0a 20 syntax receive.
0d80: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
0d90: 29 0a 20 20 20 20 28 28 72 65 63 65 69 76 65 20 ). ((receive
0da0: 66 6f 72 6d 61 6c 73 20 65 78 70 72 65 73 73 69 formals expressi
0db0: 6f 6e 20 62 6f 64 79 20 2e 2e 2e 29 0a 20 20 20 on body ...).
0dc0: 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 76 61 6c (call-with-val
0dd0: 75 65 73 20 28 6c 61 6d 62 64 61 20 28 29 20 65 ues (lambda () e
0de0: 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 xpression).
0df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e00: 20 20 28 6c 61 6d 62 64 61 20 66 6f 72 6d 61 6c (lambda formal
0e10: 73 20 62 6f 64 79 20 2e 2e 2e 29 29 29 29 29 0a s body ...))))).
0e20: 0a 3b 3b 3b 20 2d 2d 20 77 65 20 77 61 6e 74 20 .;;; -- we want
0e30: 72 65 63 65 69 76 65 20 6c 61 74 65 72 20 6f 6e receive later on
0e40: 20 66 6f 72 20 61 20 63 6f 75 70 6c 65 20 6f 66 for a couple of
0e50: 20 73 6d 61 6c 6c 20 74 68 69 6e 67 73 0a 3b 3b small things.;;
0e60: 20 0a 0a 3b 3b 20 3a 4f 50 54 49 4f 4e 41 4c 20 ..;; :OPTIONAL
0e70: 69 73 20 6e 69 63 65 2c 20 74 6f 6f 0a 0a 28 64 is nice, too..(d
0e80: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a 6f 70 efine-syntax :op
0e90: 74 69 6f 6e 61 6c 0a 20 20 28 73 79 6e 74 61 78 tional. (syntax
0ea0: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). ((
0eb0: 5f 20 76 61 6c 20 64 65 66 61 75 6c 74 2d 76 61 _ val default-va
0ec0: 6c 75 65 29 0a 20 20 20 20 20 28 69 66 20 28 6e lue). (if (n
0ed0: 75 6c 6c 3f 20 76 61 6c 29 20 64 65 66 61 75 6c ull? val) defaul
0ee0: 74 2d 76 61 6c 75 65 20 28 63 61 72 20 76 61 6c t-value (car val
0ef0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 )))))..(define t
0f00: 69 6d 65 2d 74 61 69 20 27 74 69 6d 65 2d 74 61 ime-tai 'time-ta
0f10: 69 29 0a 28 64 65 66 69 6e 65 20 74 69 6d 65 2d i).(define time-
0f20: 75 74 63 20 27 74 69 6d 65 2d 75 74 63 29 0a 28 utc 'time-utc).(
0f30: 64 65 66 69 6e 65 20 74 69 6d 65 2d 6d 6f 6e 6f define time-mono
0f40: 74 6f 6e 69 63 20 27 74 69 6d 65 2d 6d 6f 6e 6f tonic 'time-mono
0f50: 74 6f 6e 69 63 29 0a 23 7c 28 64 65 66 69 6e 65 tonic).#|(define
0f60: 20 74 69 6d 65 2d 74 68 72 65 61 64 20 27 74 69 time-thread 'ti
0f70: 6d 65 2d 74 68 72 65 61 64 29 0a 28 64 65 66 69 me-thread).(defi
0f80: 6e 65 20 74 69 6d 65 2d 70 72 6f 63 65 73 73 20 ne time-process
0f90: 27 74 69 6d 65 2d 70 72 6f 63 65 73 73 29 7c 23 'time-process)|#
0fa0: 0a 28 64 65 66 69 6e 65 20 74 69 6d 65 2d 64 75 .(define time-du
0fb0: 72 61 74 69 6f 6e 20 27 74 69 6d 65 2d 64 75 72 ration 'time-dur
0fc0: 61 74 69 6f 6e 29 0a 0a 3b 3b 20 65 78 61 6d 70 ation)..;; examp
0fd0: 6c 65 20 6f 66 20 65 78 74 65 6e 73 69 6f 6e 20 le of extension
0fe0: 28 4d 5a 53 63 68 65 6d 65 20 73 70 65 63 69 66 (MZScheme specif
0ff0: 69 63 29 0a 3b 28 64 65 66 69 6e 65 20 74 69 6d ic).;(define tim
1000: 65 2d 67 63 20 27 74 69 6d 65 2d 67 63 29 0a 0a e-gc 'time-gc)..
1010: 3b 3b 2d 2d 20 4c 4f 43 41 4c 45 20 64 65 70 65 ;;-- LOCALE depe
1020: 6e 64 65 6e 74 20 63 6f 6e 73 74 61 6e 74 73 0a ndent constants.
1030: 0a 28 64 65 66 69 6e 65 20 74 6d 3a 6c 6f 63 61 .(define tm:loca
1040: 6c 65 2d 6e 75 6d 62 65 72 2d 73 65 70 61 72 61 le-number-separa
1050: 74 6f 72 20 22 2e 22 29 0a 0a 28 64 65 66 69 6e tor ".")..(defin
1060: 65 20 74 6d 3a 6c 6f 63 61 6c 65 2d 61 62 62 72 e tm:locale-abbr
1070: 2d 77 65 65 6b 64 61 79 2d 76 65 63 74 6f 72 20 -weekday-vector
1080: 28 76 65 63 74 6f 72 20 22 53 75 6e 22 20 22 4d (vector "Sun" "M
1090: 6f 6e 22 20 22 54 75 65 22 20 22 57 65 64 22 0a on" "Tue" "Wed".
10a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 54 "T
10d0: 68 75 22 20 22 46 72 69 22 20 22 53 61 74 22 29 hu" "Fri" "Sat")
10e0: 29 20 0a 28 64 65 66 69 6e 65 20 74 6d 3a 6c 6f ) .(define tm:lo
10f0: 63 61 6c 65 2d 6c 6f 6e 67 2d 77 65 65 6b 64 61 cale-long-weekda
1100: 79 2d 76 65 63 74 6f 72 20 28 76 65 63 74 6f 72 y-vector (vector
1110: 20 22 53 75 6e 64 61 79 22 20 22 4d 6f 6e 64 61 "Sunday" "Monda
1120: 79 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 y".
1130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1150: 20 22 54 75 65 73 64 61 79 22 20 22 57 65 64 6e "Tuesday" "Wedn
1160: 65 73 64 61 79 22 0a 20 20 20 20 20 20 20 20 20 esday".
1170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1190: 20 20 20 20 20 22 54 68 75 72 73 64 61 79 22 20 "Thursday"
11a0: 22 46 72 69 64 61 79 22 0a 20 20 20 20 20 20 20 "Friday".
11b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11d0: 20 20 20 20 20 20 20 22 53 61 74 75 72 64 61 79 "Saturday
11e0: 22 29 29 0a 3b 3b 20 6e 6f 74 65 20 65 6d 70 74 ")).;; note empt
11f0: 79 20 73 74 72 69 6e 67 20 69 6e 20 30 74 68 20 y string in 0th
1200: 70 6c 61 63 65 2e 20 0a 28 64 65 66 69 6e 65 20 place. .(define
1210: 74 6d 3a 6c 6f 63 61 6c 65 2d 61 62 62 72 2d 6d tm:locale-abbr-m
1220: 6f 6e 74 68 2d 76 65 63 74 6f 72 20 20 20 28 76 onth-vector (v
1230: 65 63 74 6f 72 20 22 22 20 22 4a 61 6e 22 20 22 ector "" "Jan" "
1240: 46 65 62 22 20 22 4d 61 72 22 0a 20 20 20 20 20 Feb" "Mar".
1250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1270: 20 20 20 20 20 20 20 20 20 22 41 70 72 22 20 22 "Apr" "
1280: 4d 61 79 22 20 22 4a 75 6e 22 20 22 4a 75 6c 22 May" "Jun" "Jul"
1290: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
12a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
12c0: 41 75 67 22 20 22 53 65 70 22 20 22 4f 63 74 22 Aug" "Sep" "Oct"
12d0: 20 22 4e 6f 76 22 0a 20 20 20 20 20 20 20 20 20 "Nov".
12e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1300: 20 20 20 20 20 22 44 65 63 22 29 29 20 0a 28 64 "Dec")) .(d
1310: 65 66 69 6e 65 20 74 6d 3a 6c 6f 63 61 6c 65 2d efine tm:locale-
1320: 6c 6f 6e 67 2d 6d 6f 6e 74 68 2d 76 65 63 74 6f long-month-vecto
1330: 72 20 20 20 28 76 65 63 74 6f 72 20 22 22 20 22 r (vector "" "
1340: 4a 61 6e 75 61 72 79 22 20 22 46 65 62 72 75 61 January" "Februa
1350: 72 79 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 ry".
1360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1380: 20 20 22 4d 61 72 63 68 22 20 22 41 70 72 69 6c "March" "April
1390: 22 20 22 4d 61 79 22 0a 20 20 20 20 20 20 20 20 " "May".
13a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13c0: 20 20 20 20 20 20 22 4a 75 6e 65 22 20 22 4a 75 "June" "Ju
13d0: 6c 79 22 20 22 41 75 67 75 73 74 22 0a 20 20 20 ly" "August".
13e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1400: 20 20 20 20 20 20 20 20 20 20 20 22 53 65 70 74 "Sept
1410: 65 6d 62 65 72 22 20 22 4f 63 74 6f 62 65 72 22 ember" "October"
1420: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
1450: 4e 6f 76 65 6d 62 65 72 22 20 22 44 65 63 65 6d November" "Decem
1460: 62 65 72 22 29 29 20 0a 0a 28 64 65 66 69 6e 65 ber")) ..(define
1470: 20 74 6d 3a 6c 6f 63 61 6c 65 2d 70 6d 20 22 50 tm:locale-pm "P
1480: 4d 22 29 0a 28 64 65 66 69 6e 65 20 74 6d 3a 6c M").(define tm:l
1490: 6f 63 61 6c 65 2d 61 6d 20 22 41 4d 22 29 0a 0a ocale-am "AM")..
14a0: 3b 3b 20 53 65 65 20 64 61 74 65 2d 3e 73 74 72 ;; See date->str
14b0: 69 6e 67 0a 28 64 65 66 69 6e 65 20 74 6d 3a 6c ing.(define tm:l
14c0: 6f 63 61 6c 65 2d 64 61 74 65 2d 74 69 6d 65 2d ocale-date-time-
14d0: 66 6f 72 6d 61 74 20 22 7e 61 20 7e 62 20 7e 64 format "~a ~b ~d
14e0: 20 7e 48 3a 7e 4d 3a 7e 53 7e 7a 20 7e 59 22 29 ~H:~M:~S~z ~Y")
14f0: 0a 28 64 65 66 69 6e 65 20 74 6d 3a 6c 6f 63 61 .(define tm:loca
1500: 6c 65 2d 73 68 6f 72 74 2d 64 61 74 65 2d 66 6f le-short-date-fo
1510: 72 6d 61 74 20 22 7e 6d 2f 7e 64 2f 7e 79 22 29 rmat "~m/~d/~y")
1520: 0a 28 64 65 66 69 6e 65 20 74 6d 3a 6c 6f 63 61 .(define tm:loca
1530: 6c 65 2d 74 69 6d 65 2d 66 6f 72 6d 61 74 20 22 le-time-format "
1540: 7e 48 3a 7e 4d 3a 7e 53 22 29 0a 28 64 65 66 69 ~H:~M:~S").(defi
1550: 6e 65 20 74 6d 3a 69 73 6f 2d 38 36 30 31 2d 64 ne tm:iso-8601-d
1560: 61 74 65 2d 74 69 6d 65 2d 66 6f 72 6d 61 74 20 ate-time-format
1570: 22 7e 59 2d 7e 6d 2d 7e 64 54 7e 48 3a 7e 4d 3a "~Y-~m-~dT~H:~M:
1580: 7e 53 7e 7a 22 29 0a 3b 3b 2d 2d 20 4d 69 73 63 ~S~z").;;-- Misc
1590: 65 6c 6c 61 6e 65 6f 75 73 20 43 6f 6e 73 74 61 ellaneous Consta
15a0: 6e 74 73 2e 0a 3b 3b 2d 2d 20 6f 6e 6c 79 20 74 nts..;;-- only t
15b0: 68 65 20 74 6d 3a 74 61 69 2d 65 70 6f 63 68 2d he tm:tai-epoch-
15c0: 69 6e 2d 6a 64 20 6d 69 67 68 74 20 6e 65 65 64 in-jd might need
15d0: 20 63 68 61 6e 67 69 6e 67 20 69 66 0a 3b 3b 20 changing if.;;
15e0: 20 20 61 20 64 69 66 66 65 72 65 6e 74 20 65 70 a different ep
15f0: 6f 63 68 20 69 73 20 75 73 65 64 2e 0a 0a 28 64 och is used...(d
1600: 65 66 69 6e 65 20 74 6d 3a 6e 61 6e 6f 20 28 65 efine tm:nano (e
1610: 78 70 74 20 31 30 20 39 29 29 0a 28 64 65 66 69 xpt 10 9)).(defi
1620: 6e 65 20 74 6d 3a 73 69 64 20 20 38 36 34 30 30 ne tm:sid 86400
1630: 29 20 20 20 20 3b 20 73 65 63 6f 6e 64 73 20 69 ) ; seconds i
1640: 6e 20 61 20 64 61 79 0a 28 64 65 66 69 6e 65 20 n a day.(define
1650: 74 6d 3a 73 69 68 64 20 34 33 32 30 30 29 20 20 tm:sihd 43200)
1660: 20 20 3b 20 73 65 63 6f 6e 64 73 20 69 6e 20 61 ; seconds in a
1670: 20 68 61 6c 66 20 64 61 79 0a 28 64 65 66 69 6e half day.(defin
1680: 65 20 74 6d 3a 74 61 69 2d 65 70 6f 63 68 2d 69 e tm:tai-epoch-i
1690: 6e 2d 6a 64 20 34 38 38 31 31 37 35 2f 32 29 20 n-jd 4881175/2)
16a0: 3b 20 6a 75 6c 69 61 6e 20 64 61 79 20 6e 75 6d ; julian day num
16b0: 62 65 72 20 66 6f 72 20 27 74 68 65 20 65 70 6f ber for 'the epo
16c0: 63 68 27 0a 0a 0a 3b 3b 3b 20 41 20 56 65 72 79 ch'...;;; A Very
16d0: 20 73 69 6d 70 6c 65 20 45 72 72 6f 72 20 73 79 simple Error sy
16e0: 73 74 65 6d 20 66 6f 72 20 74 68 65 20 74 69 6d stem for the tim
16f0: 65 20 70 72 6f 63 65 64 75 72 65 73 0a 3b 3b 3b e procedures.;;;
1700: 20 0a 28 64 65 66 69 6e 65 20 74 6d 3a 74 69 6d .(define tm:tim
1710: 65 2d 65 72 72 6f 72 2d 74 79 70 65 73 0a 20 20 e-error-types.
1720: 27 28 28 69 6e 76 61 6c 69 64 2d 63 6c 6f 63 6b '((invalid-clock
1730: 2d 74 79 70 65 20 2e 20 22 69 6e 76 61 6c 69 64 -type . "invalid
1740: 20 63 6c 6f 63 6b 20 74 79 70 65 22 29 0a 20 20 clock type").
1750: 20 20 28 75 6e 73 75 70 70 6f 72 74 65 64 2d 63 (unsupported-c
1760: 6c 6f 63 6b 2d 74 79 70 65 20 2e 20 22 75 6e 73 lock-type . "uns
1770: 75 70 70 6f 72 74 65 64 20 63 6c 6f 63 6b 20 74 upported clock t
1780: 79 70 65 22 29 0a 20 20 20 20 28 69 6e 63 6f 6d ype"). (incom
1790: 70 61 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 patible-time-typ
17a0: 65 73 20 2e 20 22 69 6e 63 6f 6d 70 61 74 69 62 es . "incompatib
17b0: 6c 65 20 74 69 6d 65 20 74 79 70 65 73 22 29 0a le time types").
17c0: 20 20 20 20 28 6e 6f 74 2d 64 75 72 61 74 69 6f (not-duratio
17d0: 6e 20 2e 20 22 6e 6f 74 20 64 75 72 61 74 69 6f n . "not duratio
17e0: 6e 22 29 0a 20 20 20 20 28 64 61 74 65 73 2d 61 n"). (dates-a
17f0: 72 65 2d 69 6d 6d 75 74 61 62 6c 65 20 2e 20 22 re-immutable . "
1800: 64 61 74 65 73 20 61 72 65 20 69 6d 6d 75 74 61 dates are immuta
1810: 62 6c 65 22 29 0a 20 20 20 20 28 62 61 64 2d 64 ble"). (bad-d
1820: 61 74 65 2d 66 6f 72 6d 61 74 2d 73 74 72 69 6e ate-format-strin
1830: 67 20 2e 20 22 62 61 64 20 64 61 74 65 20 66 6f g . "bad date fo
1840: 72 6d 61 74 20 73 74 72 69 6e 67 22 29 0a 20 20 rmat string").
1850: 20 20 28 62 61 64 2d 64 61 74 65 2d 74 65 6d 70 (bad-date-temp
1860: 6c 61 74 65 2d 73 74 72 69 6e 67 20 2e 20 22 62 late-string . "b
1870: 61 64 20 64 61 74 65 20 74 65 6d 70 6c 61 74 65 ad date template
1880: 20 73 74 72 69 6e 67 22 29 0a 20 20 20 20 28 69 string"). (i
1890: 6e 76 61 6c 69 64 2d 6d 6f 6e 74 68 2d 73 70 65 nvalid-month-spe
18a0: 63 69 66 69 63 61 74 69 6f 6e 20 2e 20 22 69 6e cification . "in
18b0: 76 61 6c 69 64 20 6d 6f 6e 74 68 20 73 70 65 63 valid month spec
18c0: 69 66 69 63 61 74 69 6f 6e 22 29 0a 20 20 20 20 ification").
18d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a ))..(define (tm:
18e0: 74 69 6d 65 2d 65 72 72 6f 72 20 63 61 6c 6c 65 time-error calle
18f0: 72 20 74 79 70 65 20 76 61 6c 75 65 29 0a 20 20 r type value).
1900: 28 63 6f 6e 64 20 0a 20 20 20 20 5b 28 61 73 73 (cond . [(ass
1910: 6f 63 20 74 79 70 65 20 74 6d 3a 74 69 6d 65 2d oc type tm:time-
1920: 65 72 72 6f 72 2d 74 79 70 65 73 29 0a 20 20 20 error-types).
1930: 20 20 3d 3e 0a 20 20 20 20 20 28 6c 61 6d 62 64 =>. (lambd
1940: 61 20 28 70 29 0a 20 20 20 20 20 20 20 28 69 66 a (p). (if
1950: 20 76 61 6c 75 65 0a 20 20 20 20 20 20 20 20 20 value.
1960: 28 65 72 72 6f 72 20 63 61 6c 6c 65 72 20 28 63 (error caller (c
1970: 64 72 20 70 29 20 76 61 6c 75 65 29 0a 20 20 20 dr p) value).
1980: 20 20 20 20 20 20 28 65 72 72 6f 72 20 63 61 6c (error cal
1990: 6c 65 72 20 28 63 64 72 20 70 29 29 29 29 5d 0a ler (cdr p))))].
19a0: 20 20 20 20 5b 65 6c 73 65 0a 20 20 20 20 20 28 [else. (
19b0: 65 72 72 6f 72 20 63 61 6c 6c 65 72 20 22 28 6c error caller "(l
19c0: 69 62 72 61 72 79 20 28 73 72 66 69 20 3a 31 39 ibrary (srfi :19
19d0: 20 74 69 6d 65 29 29 20 69 6e 74 65 72 6e 61 6c time)) internal
19e0: 20 65 72 72 6f 72 3a 20 75 6e 73 75 70 70 6f 72 error: unsuppor
19f0: 74 65 64 20 65 72 72 6f 72 20 74 79 70 65 22 20 ted error type"
1a00: 74 79 70 65 29 5d 29 29 0a 0a 0a 3b 3b 20 41 20 type)]))...;; A
1a10: 74 61 62 6c 65 20 6f 66 20 6c 65 61 70 20 73 65 table of leap se
1a20: 63 6f 6e 64 73 0a 3b 3b 20 53 65 65 20 66 74 70 conds.;; See ftp
1a30: 3a 2f 2f 6d 61 69 61 2e 75 73 6e 6f 2e 6e 61 76 ://maia.usno.nav
1a40: 79 2e 6d 69 6c 2f 73 65 72 37 2f 74 61 69 2d 75 y.mil/ser7/tai-u
1a50: 74 63 2e 64 61 74 0a 3b 3b 20 61 6e 64 20 75 70 tc.dat.;; and up
1a60: 64 61 74 65 20 61 73 20 6e 65 63 65 73 73 61 72 date as necessar
1a70: 79 2e 0a 3b 3b 20 74 68 69 73 20 70 72 6f 63 65 y..;; this proce
1a80: 64 75 72 65 73 20 72 65 61 64 73 20 74 68 65 20 dures reads the
1a90: 66 69 6c 65 20 69 6e 20 74 68 65 20 61 62 6f 76 file in the abov
1aa0: 65 72 0a 3b 3b 20 66 6f 72 6d 61 74 20 61 6e 64 er.;; format and
1ab0: 20 63 72 65 61 74 65 73 20 74 68 65 20 6c 65 61 creates the lea
1ac0: 70 20 73 65 63 6f 6e 64 20 74 61 62 6c 65 0a 3b p second table.;
1ad0: 3b 20 69 74 20 61 6c 73 6f 20 63 61 6c 6c 73 20 ; it also calls
1ae0: 74 68 65 20 61 6c 6d 6f 73 74 20 73 74 61 6e 64 the almost stand
1af0: 61 72 64 2c 20 62 75 74 20 6e 6f 74 20 52 35 20 ard, but not R5
1b00: 70 72 6f 63 65 64 75 72 65 73 20 72 65 61 64 2d procedures read-
1b10: 6c 69 6e 65 20 0a 3b 3b 20 26 20 6f 70 65 6e 2d line .;; & open-
1b20: 69 6e 70 75 74 2d 73 74 72 69 6e 67 0a 3b 3b 20 input-string.;;
1b30: 69 65 20 28 73 65 74 21 20 74 6d 3a 6c 65 61 70 ie (set! tm:leap
1b40: 2d 73 65 63 6f 6e 64 2d 74 61 62 6c 65 20 28 74 -second-table (t
1b50: 6d 3a 72 65 61 64 2d 74 61 69 2d 75 74 63 2d 64 m:read-tai-utc-d
1b60: 61 74 65 20 22 74 61 69 2d 75 74 63 2e 64 61 74 ate "tai-utc.dat
1b70: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d "))..(define (tm
1b80: 3a 72 65 61 64 2d 74 61 69 2d 75 74 63 2d 64 61 :read-tai-utc-da
1b90: 74 61 20 66 69 6c 65 6e 61 6d 65 29 0a 20 20 28 ta filename). (
1ba0: 64 65 66 69 6e 65 20 28 63 6f 6e 76 65 72 74 2d define (convert-
1bb0: 6a 64 20 6a 64 29 0a 20 20 20 20 28 2a 20 28 2d jd jd). (* (-
1bc0: 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 61 63 74 (inexact->exact
1bd0: 20 6a 64 29 20 74 6d 3a 74 61 69 2d 65 70 6f 63 jd) tm:tai-epoc
1be0: 68 2d 69 6e 2d 6a 64 29 20 74 6d 3a 73 69 64 29 h-in-jd) tm:sid)
1bf0: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 63 6f 6e ). (define (con
1c00: 76 65 72 74 2d 73 65 63 20 73 65 63 29 0a 20 20 vert-sec sec).
1c10: 20 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 61 63 (inexact->exac
1c20: 74 20 73 65 63 29 29 0a 20 20 28 6c 65 74 20 28 t sec)). (let (
1c30: 20 28 70 6f 72 74 20 28 6f 70 65 6e 2d 69 6e 70 (port (open-inp
1c40: 75 74 2d 66 69 6c 65 20 66 69 6c 65 6e 61 6d 65 ut-file filename
1c50: 29 29 0a 09 20 28 74 61 62 6c 65 20 27 28 29 29 )).. (table '())
1c60: 20 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ). (let loop
1c70: 20 28 28 6c 69 6e 65 20 28 72 65 61 64 2d 6c 69 ((line (read-li
1c80: 6e 65 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 ne port))).
1c90: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 6c (if (not (eq? l
1ca0: 69 6e 65 20 65 6f 66 29 29 0a 09 20 20 28 62 65 ine eof)).. (be
1cb0: 67 69 6e 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 gin.. (let* (
1cc0: 20 28 64 61 74 61 20 28 72 65 61 64 20 28 6f 70 (data (read (op
1cd0: 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 en-input-string
1ce0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 (string-append "
1cf0: 28 22 20 6c 69 6e 65 20 22 29 22 29 29 29 29 20 (" line ")"))))
1d00: 0a 09 09 20 20 20 20 28 79 65 61 72 20 28 63 61 ... (year (ca
1d10: 72 20 64 61 74 61 29 29 0a 09 09 20 20 20 20 28 r data))... (
1d20: 6a 64 20 20 20 28 63 61 64 64 64 72 20 28 63 64 jd (cadddr (cd
1d30: 72 20 64 61 74 61 29 29 29 0a 09 09 20 20 20 20 r data)))...
1d40: 28 73 65 63 73 20 28 63 61 64 64 64 72 20 28 63 (secs (cadddr (c
1d50: 64 64 64 72 20 64 61 74 61 29 29 29 20 29 0a 09 dddr data))) )..
1d60: 20 20 20 20 20 20 28 69 66 20 28 3e 3d 20 79 65 (if (>= ye
1d70: 61 72 20 31 39 37 32 29 0a 09 09 20 20 28 73 65 ar 1972)... (se
1d80: 74 21 20 74 61 62 6c 65 20 28 63 6f 6e 73 20 28 t! table (cons (
1d90: 63 6f 6e 73 20 28 63 6f 6e 76 65 72 74 2d 6a 64 cons (convert-jd
1da0: 20 6a 64 29 20 28 63 6f 6e 76 65 72 74 2d 73 65 jd) (convert-se
1db0: 63 20 73 65 63 73 29 29 20 74 61 62 6c 65 29 29 c secs)) table))
1dc0: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
1dd0: 72 65 61 64 2d 6c 69 6e 65 20 70 6f 72 74 29 29 read-line port))
1de0: 29 29 29 29 0a 20 20 20 20 74 61 62 6c 65 29 29 )))). table))
1df0: 0a 0a 3b 3b 20 65 61 63 68 20 65 6e 74 72 79 20 ..;; each entry
1e00: 69 73 20 28 20 75 74 63 20 73 65 63 6f 6e 64 73 is ( utc seconds
1e10: 20 73 69 6e 63 65 20 65 70 6f 63 68 20 2e 20 23 since epoch . #
1e20: 20 73 65 63 6f 6e 64 73 20 74 6f 20 61 64 64 20 seconds to add
1e30: 66 6f 72 20 74 61 69 20 29 0a 3b 3b 20 6e 6f 74 for tai ).;; not
1e40: 65 20 74 68 65 79 20 67 6f 20 68 69 67 68 65 72 e they go higher
1e50: 20 74 6f 20 6c 6f 77 65 72 2c 20 61 6e 64 20 65 to lower, and e
1e60: 6e 64 20 69 6e 20 31 39 37 32 2e 0a 28 64 65 66 nd in 1972..(def
1e70: 69 6e 65 20 74 6d 3a 6c 65 61 70 2d 73 65 63 6f ine tm:leap-seco
1e80: 6e 64 2d 74 61 62 6c 65 0a 20 20 27 28 28 31 31 nd-table. '((11
1e90: 33 36 30 37 33 36 30 30 20 2e 20 33 33 29 0a 20 36073600 . 33).
1ea0: 20 20 20 28 39 31 35 31 34 38 38 30 30 20 2e 20 (915148800 .
1eb0: 33 32 29 0a 20 20 20 20 28 38 36 37 37 31 35 32 32). (8677152
1ec0: 30 30 20 2e 20 33 31 29 0a 20 20 20 20 28 38 32 00 . 31). (82
1ed0: 30 34 35 34 34 30 30 20 2e 20 33 30 29 0a 20 20 0454400 . 30).
1ee0: 20 20 28 37 37 33 30 32 30 38 30 30 20 2e 20 32 (773020800 . 2
1ef0: 39 29 0a 20 20 20 20 28 37 34 31 34 38 34 38 30 9). (74148480
1f00: 30 20 2e 20 32 38 29 0a 20 20 20 20 28 37 30 39 0 . 28). (709
1f10: 39 34 38 38 30 30 20 2e 20 32 37 29 0a 20 20 20 948800 . 27).
1f20: 20 28 36 36 32 36 38 38 30 30 30 20 2e 20 32 36 (662688000 . 26
1f30: 29 0a 20 20 20 20 28 36 33 31 31 35 32 30 30 30 ). (631152000
1f40: 20 2e 20 32 35 29 0a 20 20 20 20 28 35 36 37 39 . 25). (5679
1f50: 39 33 36 30 30 20 2e 20 32 34 29 0a 20 20 20 20 93600 . 24).
1f60: 28 34 38 39 30 32 34 30 30 30 20 2e 20 32 33 29 (489024000 . 23)
1f70: 0a 20 20 20 20 28 34 32 35 38 36 35 36 30 30 20 . (425865600
1f80: 2e 20 32 32 29 0a 20 20 20 20 28 33 39 34 33 32 . 22). (39432
1f90: 39 36 30 30 20 2e 20 32 31 29 0a 20 20 20 20 28 9600 . 21). (
1fa0: 33 36 32 37 39 33 36 30 30 20 2e 20 32 30 29 0a 362793600 . 20).
1fb0: 20 20 20 20 28 33 31 35 35 33 32 38 30 30 20 2e (315532800 .
1fc0: 20 31 39 29 0a 20 20 20 20 28 32 38 33 39 39 36 19). (283996
1fd0: 38 30 30 20 2e 20 31 38 29 0a 20 20 20 20 28 32 800 . 18). (2
1fe0: 35 32 34 36 30 38 30 30 20 2e 20 31 37 29 0a 20 52460800 . 17).
1ff0: 20 20 20 28 32 32 30 39 32 34 38 30 30 20 2e 20 (220924800 .
2000: 31 36 29 0a 20 20 20 20 28 31 38 39 33 30 32 34 16). (1893024
2010: 30 30 20 2e 20 31 35 29 0a 20 20 20 20 28 31 35 00 . 15). (15
2020: 37 37 36 36 34 30 30 20 2e 20 31 34 29 0a 20 20 7766400 . 14).
2030: 20 20 28 31 32 36 32 33 30 34 30 30 20 2e 20 31 (126230400 . 1
2040: 33 29 0a 20 20 20 20 28 39 34 36 39 34 34 30 30 3). (94694400
2050: 20 2e 20 31 32 29 0a 20 20 20 20 28 37 38 37 39 . 12). (7879
2060: 36 38 30 30 20 2e 20 31 31 29 0a 20 20 20 20 28 6800 . 11). (
2070: 36 33 30 37 32 30 30 30 20 2e 20 31 30 29 29 29 63072000 . 10)))
2080: 0a 0a 28 64 65 66 69 6e 65 20 28 72 65 61 64 2d ..(define (read-
2090: 6c 65 61 70 2d 73 65 63 6f 6e 64 2d 74 61 62 6c leap-second-tabl
20a0: 65 20 66 69 6c 65 6e 61 6d 65 29 0a 20 20 28 73 e filename). (s
20b0: 65 74 21 20 74 6d 3a 6c 65 61 70 2d 73 65 63 6f et! tm:leap-seco
20c0: 6e 64 2d 74 61 62 6c 65 20 28 74 6d 3a 72 65 61 nd-table (tm:rea
20d0: 64 2d 74 61 69 2d 75 74 63 2d 64 61 74 61 20 66 d-tai-utc-data f
20e0: 69 6c 65 6e 61 6d 65 29 29 0a 20 20 28 76 61 6c ilename)). (val
20f0: 75 65 73 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 ues))...(define
2100: 28 74 6d 3a 6c 65 61 70 2d 73 65 63 6f 6e 64 2d (tm:leap-second-
2110: 64 65 6c 74 61 20 75 74 63 2d 73 65 63 6f 6e 64 delta utc-second
2120: 73 29 0a 20 20 28 6c 65 74 72 65 63 20 28 20 28 s). (letrec ( (
2130: 6c 73 64 20 28 6c 61 6d 62 64 61 20 28 74 61 62 lsd (lambda (tab
2140: 6c 65 29 20 0a 09 09 20 20 20 28 63 6f 6e 64 0a le) ... (cond.
2150: 09 09 20 20 20 20 28 28 3e 3d 20 75 74 63 2d 73 .. ((>= utc-s
2160: 65 63 6f 6e 64 73 20 28 63 61 61 72 20 74 61 62 econds (caar tab
2170: 6c 65 29 29 0a 09 09 20 20 20 20 20 28 63 64 61 le))... (cda
2180: 72 20 74 61 62 6c 65 29 29 0a 09 09 20 20 20 20 r table))...
2190: 28 65 6c 73 65 20 28 6c 73 64 20 28 63 64 72 20 (else (lsd (cdr
21a0: 74 61 62 6c 65 29 29 29 29 29 29 20 29 0a 20 20 table)))))) ).
21b0: 20 20 28 69 66 20 28 3c 20 75 74 63 2d 73 65 63 (if (< utc-sec
21c0: 6f 6e 64 73 20 20 28 2a 20 28 2d 20 31 39 37 32 onds (* (- 1972
21d0: 20 31 39 37 30 29 20 33 36 35 20 74 6d 3a 73 69 1970) 365 tm:si
21e0: 64 29 29 20 30 0a 09 28 6c 73 64 20 20 74 6d 3a d)) 0..(lsd tm:
21f0: 6c 65 61 70 2d 73 65 63 6f 6e 64 2d 74 61 62 6c leap-second-tabl
2200: 65 29 29 29 29 0a 0a 3b 3b 20 67 6f 69 6e 67 20 e))))..;; going
2210: 66 72 6f 6d 20 74 61 69 20 73 65 63 6f 6e 64 73 from tai seconds
2220: 20 74 6f 20 75 74 63 20 73 65 63 6f 6e 64 73 20 to utc seconds
2230: 2e 2e 2e 20 0a 28 64 65 66 69 6e 65 20 28 74 6d ... .(define (tm
2240: 3a 6c 65 61 70 2d 73 65 63 6f 6e 64 2d 6e 65 67 :leap-second-neg
2250: 2d 64 65 6c 74 61 20 74 61 69 2d 73 65 63 6f 6e -delta tai-secon
2260: 64 73 29 0a 20 20 28 6c 65 74 72 65 63 20 28 20 ds). (letrec (
2270: 28 6c 73 64 20 28 6c 61 6d 62 64 61 20 28 74 61 (lsd (lambda (ta
2280: 62 6c 65 29 0a 09 09 20 20 20 28 63 6f 6e 64 20 ble)... (cond
2290: 28 28 6e 75 6c 6c 3f 20 74 61 62 6c 65 29 20 30 ((null? table) 0
22a0: 29 0a 09 09 09 20 28 28 3c 3d 20 28 63 64 61 72 ).... ((<= (cdar
22b0: 20 74 61 62 6c 65 29 20 28 2d 20 74 61 69 2d 73 table) (- tai-s
22c0: 65 63 6f 6e 64 73 20 28 63 61 61 72 20 74 61 62 econds (caar tab
22d0: 6c 65 29 29 29 0a 09 09 09 20 20 28 63 64 61 72 le))).... (cdar
22e0: 20 74 61 62 6c 65 29 29 0a 09 09 09 20 28 65 6c table)).... (el
22f0: 73 65 20 28 6c 73 64 20 28 63 64 72 20 74 61 62 se (lsd (cdr tab
2300: 6c 65 29 29 29 29 29 29 20 29 0a 20 20 20 20 28 le)))))) ). (
2310: 69 66 20 28 3c 20 74 61 69 2d 73 65 63 6f 6e 64 if (< tai-second
2320: 73 20 20 28 2a 20 28 2d 20 31 39 37 32 20 31 39 s (* (- 1972 19
2330: 37 30 29 20 33 36 35 20 74 6d 3a 73 69 64 29 29 70) 365 tm:sid))
2340: 20 30 0a 09 28 6c 73 64 20 20 74 6d 3a 6c 65 61 0..(lsd tm:lea
2350: 70 2d 73 65 63 6f 6e 64 2d 74 61 62 6c 65 29 29 p-second-table))
2360: 29 29 0a 0a 0a 3b 3b 3b 20 74 68 65 20 74 69 6d ))...;;; the tim
2370: 65 20 73 74 72 75 63 74 75 72 65 3b 20 63 72 65 e structure; cre
2380: 61 74 65 73 20 74 68 65 20 61 63 63 65 73 73 6f ates the accesso
2390: 72 73 2c 20 74 6f 6f 2e 0a 3b 3b 3b 20 77 66 3a rs, too..;;; wf:
23a0: 20 63 68 61 6e 67 65 64 20 74 6f 20 6d 61 74 63 changed to matc
23b0: 68 20 73 72 66 69 20 64 6f 63 75 6d 65 6e 74 61 h srfi documenta
23c0: 74 69 6f 6e 2e 0a 0a 28 64 65 66 69 6e 65 2d 72 tion...(define-r
23d0: 65 63 6f 72 64 2d 74 79 70 65 20 74 69 6d 65 20 ecord-type time
23e0: 0a 20 20 28 66 69 65 6c 64 73 20 0a 20 20 20 20 . (fields .
23f0: 28 6d 75 74 61 62 6c 65 20 74 79 70 65 29 20 0a (mutable type) .
2400: 20 20 20 20 28 6d 75 74 61 62 6c 65 20 6e 61 6e (mutable nan
2410: 6f 73 65 63 6f 6e 64 29 0a 20 20 20 20 28 6d 75 osecond). (mu
2420: 74 61 62 6c 65 20 73 65 63 6f 6e 64 29 29 29 0a table second))).
2430: 0a 3b 3b 20 74 68 61 6e 6b 73 2c 20 4d 61 72 74 .;; thanks, Mart
2440: 69 6e 20 47 61 73 62 69 63 68 6c 65 72 20 2e 2e in Gasbichler ..
2450: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 70 79 ...(define (copy
2460: 2d 74 69 6d 65 20 74 69 6d 65 29 0a 20 20 28 6d -time time). (m
2470: 61 6b 65 2d 74 69 6d 65 20 28 74 69 6d 65 2d 74 ake-time (time-t
2480: 79 70 65 20 74 69 6d 65 29 0a 09 20 20 20 20 20 ype time)..
2490: 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 (time-nanosecond
24a0: 20 74 69 6d 65 29 20 20 3b 20 6f 72 69 67 69 6e time) ; origin
24b0: 61 6c 20 68 61 64 20 74 68 69 73 20 6d 69 73 74 al had this mist
24c0: 61 6b 65 6e 6c 79 20 73 77 61 70 70 65 64 20 77 akenly swapped w
24d0: 69 74 68 20 74 69 6d 65 2d 73 65 63 6f 6e 64 0a ith time-second.
24e0: 09 20 20 20 20 20 28 74 69 6d 65 2d 73 65 63 6f . (time-seco
24f0: 6e 64 20 74 69 6d 65 29 29 29 0a 0a 0a 3b 3b 3b nd time)))...;;;
2500: 20 63 75 72 72 65 6e 74 2d 74 69 6d 65 0a 0a 3b current-time..;
2510: 3b 3b 20 73 70 65 63 69 66 69 63 20 74 69 6d 65 ;; specific time
2520: 20 67 65 74 74 65 72 73 2e 0a 0a 3b 3b 20 49 27 getters...;; I'
2530: 6d 20 6e 6f 74 20 73 75 72 65 20 77 68 79 20 74 m not sure why t
2540: 68 65 20 6f 72 69 67 69 6e 61 6c 20 77 61 73 20 he original was
2550: 75 73 69 6e 67 20 74 69 6d 65 2d 6e 61 6e 6f 73 using time-nanos
2560: 65 63 6f 6e 64 73 0a 3b 3b 20 61 73 20 31 30 30 econds.;; as 100
2570: 30 30 20 2a 20 74 68 65 20 6d 69 6c 6c 69 73 65 00 * the millise
2580: 63 6f 6e 64 73 0a 0a 28 64 65 66 69 6e 65 20 28 conds..(define (
2590: 74 6d 3a 67 65 74 2d 74 69 6d 65 2d 6f 66 2d 64 tm:get-time-of-d
25a0: 61 79 29 0a 20 20 28 6c 65 74 20 28 5b 63 74 20 ay). (let ([ct
25b0: 28 68 6f 73 74 3a 63 75 72 72 65 6e 74 2d 74 69 (host:current-ti
25c0: 6d 65 29 5d 29 0a 20 20 20 20 28 76 61 6c 75 65 me)]). (value
25d0: 73 20 28 68 6f 73 74 3a 74 69 6d 65 2d 73 65 63 s (host:time-sec
25e0: 6f 6e 64 20 63 74 29 0a 20 20 20 20 20 20 20 20 ond ct).
25f0: 20 20 20 20 28 68 6f 73 74 3a 74 69 6d 65 2d 6e (host:time-n
2600: 61 6e 6f 73 65 63 6f 6e 64 20 63 74 29 29 29 29 anosecond ct))))
2610: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 63 75 ..(define (tm:cu
2620: 72 72 65 6e 74 2d 74 69 6d 65 2d 75 74 63 29 0a rrent-time-utc).
2630: 20 20 28 72 65 63 65 69 76 65 20 28 73 65 63 6f (receive (seco
2640: 6e 64 73 20 6e 61 6e 6f 73 29 20 28 74 6d 3a 67 nds nanos) (tm:g
2650: 65 74 2d 74 69 6d 65 2d 6f 66 2d 64 61 79 29 0a et-time-of-day).
2660: 09 20 20 20 28 6d 61 6b 65 2d 74 69 6d 65 20 74 . (make-time t
2670: 69 6d 65 2d 75 74 63 20 6e 61 6e 6f 73 20 73 65 ime-utc nanos se
2680: 63 6f 6e 64 73 29 29 29 0a 0a 28 64 65 66 69 6e conds)))..(defin
2690: 65 20 28 74 6d 3a 63 75 72 72 65 6e 74 2d 74 69 e (tm:current-ti
26a0: 6d 65 2d 74 61 69 29 0a 20 20 28 72 65 63 65 69 me-tai). (recei
26b0: 76 65 20 28 73 65 63 6f 6e 64 73 20 6e 61 6e 6f ve (seconds nano
26c0: 73 29 20 28 74 6d 3a 67 65 74 2d 74 69 6d 65 2d s) (tm:get-time-
26d0: 6f 66 2d 64 61 79 29 0a 09 20 20 20 28 6d 61 6b of-day).. (mak
26e0: 65 2d 74 69 6d 65 20 74 69 6d 65 2d 74 61 69 0a e-time time-tai.
26f0: 09 09 20 20 20 20 20 20 6e 61 6e 6f 73 0a 09 09 .. nanos...
2700: 20 20 20 20 20 20 28 2b 20 73 65 63 6f 6e 64 73 (+ seconds
2710: 20 28 74 6d 3a 6c 65 61 70 2d 73 65 63 6f 6e 64 (tm:leap-second
2720: 2d 64 65 6c 74 61 20 73 65 63 6f 6e 64 73 29 29 -delta seconds))
2730: 20 29 29 29 0a 0a 23 7c 28 64 65 66 69 6e 65 20 )))..#|(define
2740: 28 74 6d 3a 63 75 72 72 65 6e 74 2d 74 69 6d 65 (tm:current-time
2750: 2d 6d 73 2d 74 69 6d 65 20 74 69 6d 65 2d 74 79 -ms-time time-ty
2760: 70 65 20 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 pe proc). (let
2770: 28 28 63 75 72 72 65 6e 74 2d 6d 73 20 28 70 72 ((current-ms (pr
2780: 6f 63 29 29 29 0a 20 20 20 20 28 6d 61 6b 65 2d oc))). (make-
2790: 74 69 6d 65 20 74 69 6d 65 2d 74 79 70 65 20 0a time time-type .
27a0: 09 20 20 20 20 20 20 20 58 58 58 0a 09 20 20 20 . XXX..
27b0: 20 20 20 20 5a 5a 5a 0a 09 20 20 20 20 20 20 20 ZZZ..
27c0: 29 29 29 20 7c 23 0a 0a 3b 3b 20 2d 2d 20 77 65 ))) |#..;; -- we
27d0: 20 64 65 66 69 6e 65 20 69 74 20 74 6f 20 62 65 define it to be
27e0: 20 74 68 65 20 73 61 6d 65 20 61 73 20 74 61 69 the same as tai
27f0: 2e 0a 3b 3b 20 20 20 20 61 20 64 69 66 66 65 72 ..;; a differ
2800: 65 6e 74 20 69 6d 70 6c 65 6d 61 74 69 6f 6e 20 ent implemation
2810: 6f 66 20 63 75 72 72 65 6e 74 2d 74 69 6d 65 2d of current-time-
2820: 6d 6f 6e 74 6f 6e 69 63 0a 3b 3b 20 20 20 20 77 montonic.;; w
2830: 69 6c 6c 20 72 65 71 75 69 72 65 20 72 65 77 72 ill require rewr
2840: 69 74 69 6e 67 20 61 6c 6c 20 6f 66 20 74 68 65 iting all of the
2850: 20 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 20 time-monotonic
2860: 63 6f 6e 76 65 72 74 65 72 73 2c 0a 3b 3b 20 20 converters,.;;
2870: 20 20 6f 66 20 63 6f 75 72 73 65 2e 0a 0a 28 64 of course...(d
2880: 65 66 69 6e 65 20 28 74 6d 3a 63 75 72 72 65 6e efine (tm:curren
2890: 74 2d 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 t-time-monotonic
28a0: 29 0a 20 20 28 72 65 63 65 69 76 65 20 28 73 65 ). (receive (se
28b0: 63 6f 6e 64 73 20 6e 61 6e 6f 73 29 20 28 74 6d conds nanos) (tm
28c0: 3a 67 65 74 2d 74 69 6d 65 2d 6f 66 2d 64 61 79 :get-time-of-day
28d0: 29 0a 09 20 20 20 28 6d 61 6b 65 2d 74 69 6d 65 ).. (make-time
28e0: 20 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 0a time-monotonic.
28f0: 09 09 20 20 20 20 20 20 6e 61 6e 6f 73 0a 09 09 .. nanos...
2900: 20 20 20 20 20 20 28 2b 20 73 65 63 6f 6e 64 73 (+ seconds
2910: 20 28 74 6d 3a 6c 65 61 70 2d 73 65 63 6f 6e 64 (tm:leap-second
2920: 2d 64 65 6c 74 61 20 73 65 63 6f 6e 64 73 29 29 -delta seconds))
2930: 20 29 29 29 0a 0a 0a 23 7c 28 64 65 66 69 6e 65 )))...#|(define
2940: 20 28 74 6d 3a 63 75 72 72 65 6e 74 2d 74 69 6d (tm:current-tim
2950: 65 2d 74 68 72 65 61 64 29 0a 20 20 28 74 6d 3a e-thread). (tm:
2960: 63 75 72 72 65 6e 74 2d 74 69 6d 65 2d 6d 73 2d current-time-ms-
2970: 74 69 6d 65 20 74 69 6d 65 2d 70 72 6f 63 65 73 time time-proces
2980: 73 20 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 s current-proces
2990: 73 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 s-milliseconds))
29a0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 63 75 ..(define (tm:cu
29b0: 72 72 65 6e 74 2d 74 69 6d 65 2d 70 72 6f 63 65 rrent-time-proce
29c0: 73 73 29 0a 20 20 28 74 6d 3a 63 75 72 72 65 6e ss). (tm:curren
29d0: 74 2d 74 69 6d 65 2d 6d 73 2d 74 69 6d 65 20 74 t-time-ms-time t
29e0: 69 6d 65 2d 70 72 6f 63 65 73 73 20 63 75 72 72 ime-process curr
29f0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 6d 69 6c 6c ent-process-mill
2a00: 69 73 65 63 6f 6e 64 73 29 29 0a 0a 28 64 65 66 iseconds))..(def
2a10: 69 6e 65 20 28 74 6d 3a 63 75 72 72 65 6e 74 2d ine (tm:current-
2a20: 74 69 6d 65 2d 67 63 29 0a 20 20 28 74 6d 3a 63 time-gc). (tm:c
2a30: 75 72 72 65 6e 74 2d 74 69 6d 65 2d 6d 73 2d 74 urrent-time-ms-t
2a40: 69 6d 65 20 74 69 6d 65 2d 67 63 20 63 75 72 72 ime time-gc curr
2a50: 65 6e 74 2d 67 63 2d 6d 69 6c 6c 69 73 65 63 6f ent-gc-milliseco
2a60: 6e 64 73 29 29 20 7c 23 0a 0a 28 64 65 66 69 6e nds)) |#..(defin
2a70: 65 20 28 63 75 72 72 65 6e 74 2d 74 69 6d 65 20 e (current-time
2a80: 2e 20 63 6c 6f 63 6b 2d 74 79 70 65 29 0a 20 20 . clock-type).
2a90: 28 6c 65 74 20 28 20 28 63 6c 6f 63 6b 2d 74 79 (let ( (clock-ty
2aa0: 70 65 20 28 3a 6f 70 74 69 6f 6e 61 6c 20 63 6c pe (:optional cl
2ab0: 6f 63 6b 2d 74 79 70 65 20 74 69 6d 65 2d 75 74 ock-type time-ut
2ac0: 63 29 29 20 29 0a 20 20 20 20 28 63 6f 6e 64 0a c)) ). (cond.
2ad0: 20 20 20 20 20 20 28 28 65 71 3f 20 63 6c 6f 63 ((eq? cloc
2ae0: 6b 2d 74 79 70 65 20 74 69 6d 65 2d 74 61 69 29 k-type time-tai)
2af0: 20 28 74 6d 3a 63 75 72 72 65 6e 74 2d 74 69 6d (tm:current-tim
2b00: 65 2d 74 61 69 29 29 0a 20 20 20 20 20 20 28 28 e-tai)). ((
2b10: 65 71 3f 20 63 6c 6f 63 6b 2d 74 79 70 65 20 74 eq? clock-type t
2b20: 69 6d 65 2d 75 74 63 29 20 28 74 6d 3a 63 75 72 ime-utc) (tm:cur
2b30: 72 65 6e 74 2d 74 69 6d 65 2d 75 74 63 29 29 0a rent-time-utc)).
2b40: 20 20 20 20 20 20 28 28 65 71 3f 20 63 6c 6f 63 ((eq? cloc
2b50: 6b 2d 74 79 70 65 20 74 69 6d 65 2d 6d 6f 6e 6f k-type time-mono
2b60: 74 6f 6e 69 63 29 20 28 74 6d 3a 63 75 72 72 65 tonic) (tm:curre
2b70: 6e 74 2d 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 nt-time-monotoni
2b80: 63 29 29 0a 20 20 20 20 20 20 23 7c 28 28 65 71 c)). #|((eq
2b90: 3f 20 63 6c 6f 63 6b 2d 74 79 70 65 20 74 69 6d ? clock-type tim
2ba0: 65 2d 74 68 72 65 61 64 29 20 28 74 6d 3a 63 75 e-thread) (tm:cu
2bb0: 72 72 65 6e 74 2d 74 69 6d 65 2d 74 68 72 65 61 rrent-time-threa
2bc0: 64 29 29 0a 20 20 20 20 20 20 28 28 65 71 3f 20 d)). ((eq?
2bd0: 63 6c 6f 63 6b 2d 74 79 70 65 20 74 69 6d 65 2d clock-type time-
2be0: 70 72 6f 63 65 73 73 29 20 28 74 6d 3a 63 75 72 process) (tm:cur
2bf0: 72 65 6e 74 2d 74 69 6d 65 2d 70 72 6f 63 65 73 rent-time-proces
2c00: 73 29 29 0a 20 20 20 20 20 20 28 28 65 71 3f 20 s)). ((eq?
2c10: 63 6c 6f 63 6b 2d 74 79 70 65 20 74 69 6d 65 2d clock-type time-
2c20: 67 63 29 20 28 74 6d 3a 63 75 72 72 65 6e 74 2d gc) (tm:current-
2c30: 74 69 6d 65 2d 67 63 29 29 7c 23 0a 20 20 20 20 time-gc))|#.
2c40: 20 20 28 65 6c 73 65 20 28 74 6d 3a 74 69 6d 65 (else (tm:time
2c50: 2d 65 72 72 6f 72 20 27 63 75 72 72 65 6e 74 2d -error 'current-
2c60: 74 69 6d 65 20 27 69 6e 76 61 6c 69 64 2d 63 6c time 'invalid-cl
2c70: 6f 63 6b 2d 74 79 70 65 20 63 6c 6f 63 6b 2d 74 ock-type clock-t
2c80: 79 70 65 29 29 29 29 29 0a 0a 0a 3b 3b 20 2d 2d ype)))))...;; --
2c90: 20 74 69 6d 65 20 72 65 73 6f 6c 75 74 69 6f 6e time resolution
2ca0: 0a 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 .;; this is the
2cb0: 72 65 73 6f 6c 75 74 69 6f 6e 20 6f 66 20 74 68 resolution of th
2cc0: 65 20 63 6c 6f 63 6b 20 69 6e 20 6e 61 6e 6f 73 e clock in nanos
2cd0: 65 63 6f 6e 64 73 2e 0a 3b 3b 20 74 68 69 73 20 econds..;; this
2ce0: 77 69 6c 6c 20 62 65 20 69 6d 70 6c 65 6d 65 6e will be implemen
2cf0: 74 61 74 69 6f 6e 20 73 70 65 63 69 66 69 63 2e tation specific.
2d00: 0a 28 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 72 .(define (time-r
2d10: 65 73 6f 6c 75 74 69 6f 6e 20 2e 20 63 6c 6f 63 esolution . cloc
2d20: 6b 2d 74 79 70 65 29 0a 20 20 28 6c 65 74 20 28 k-type). (let (
2d30: 28 63 6c 6f 63 6b 2d 74 79 70 65 20 28 3a 6f 70 (clock-type (:op
2d40: 74 69 6f 6e 61 6c 20 63 6c 6f 63 6b 2d 74 79 70 tional clock-typ
2d50: 65 20 74 69 6d 65 2d 75 74 63 29 29 29 0a 20 20 e time-utc))).
2d60: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 28 28 (cond. ((
2d70: 65 71 3f 20 63 6c 6f 63 6b 2d 74 79 70 65 20 74 eq? clock-type t
2d80: 69 6d 65 2d 74 61 69 29 20 68 6f 73 74 3a 74 69 ime-tai) host:ti
2d90: 6d 65 2d 72 65 73 6f 6c 75 74 69 6f 6e 29 0a 20 me-resolution).
2da0: 20 20 20 20 20 28 28 65 71 3f 20 63 6c 6f 63 6b ((eq? clock
2db0: 2d 74 79 70 65 20 74 69 6d 65 2d 75 74 63 29 20 -type time-utc)
2dc0: 68 6f 73 74 3a 74 69 6d 65 2d 72 65 73 6f 6c 75 host:time-resolu
2dd0: 74 69 6f 6e 29 0a 20 20 20 20 20 20 28 28 65 71 tion). ((eq
2de0: 3f 20 63 6c 6f 63 6b 2d 74 79 70 65 20 74 69 6d ? clock-type tim
2df0: 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 29 20 68 6f 73 e-monotonic) hos
2e00: 74 3a 74 69 6d 65 2d 72 65 73 6f 6c 75 74 69 6f t:time-resolutio
2e10: 6e 29 0a 20 20 20 20 20 20 23 7c 28 28 65 71 3f n). #|((eq?
2e20: 20 63 6c 6f 63 6b 2d 74 79 70 65 20 74 69 6d 65 clock-type time
2e30: 2d 74 68 72 65 61 64 29 20 68 6f 73 74 3a 74 69 -thread) host:ti
2e40: 6d 65 2d 72 65 73 6f 6c 75 74 69 6f 6e 29 0a 20 me-resolution).
2e50: 20 20 20 20 20 28 28 65 71 3f 20 63 6c 6f 63 6b ((eq? clock
2e60: 2d 74 79 70 65 20 74 69 6d 65 2d 70 72 6f 63 65 -type time-proce
2e70: 73 73 29 20 68 6f 73 74 3a 74 69 6d 65 2d 72 65 ss) host:time-re
2e80: 73 6f 6c 75 74 69 6f 6e 29 0a 20 20 20 20 20 20 solution).
2e90: 28 28 65 71 3f 20 63 6c 6f 63 6b 2d 74 79 70 65 ((eq? clock-type
2ea0: 20 74 69 6d 65 2d 67 63 29 20 68 6f 73 74 3a 74 time-gc) host:t
2eb0: 69 6d 65 2d 72 65 73 6f 6c 75 74 69 6f 6e 29 7c ime-resolution)|
2ec0: 23 0a 20 20 20 20 20 20 28 65 6c 73 65 20 28 74 #. (else (t
2ed0: 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 74 69 m:time-error 'ti
2ee0: 6d 65 2d 72 65 73 6f 6c 75 74 69 6f 6e 20 27 69 me-resolution 'i
2ef0: 6e 76 61 6c 69 64 2d 63 6c 6f 63 6b 2d 74 79 70 nvalid-clock-typ
2f00: 65 20 63 6c 6f 63 6b 2d 74 79 70 65 29 29 29 29 e clock-type))))
2f10: 29 0a 0a 3b 3b 20 2d 2d 20 74 69 6d 65 20 63 6f )..;; -- time co
2f20: 6d 70 61 72 69 73 6f 6e 73 0a 0a 28 64 65 66 69 mparisons..(defi
2f30: 6e 65 20 28 74 6d 3a 74 69 6d 65 2d 63 6f 6d 70 ne (tm:time-comp
2f40: 61 72 65 2d 63 68 65 63 6b 20 74 69 6d 65 31 20 are-check time1
2f50: 74 69 6d 65 32 20 63 61 6c 6c 65 72 29 0a 20 20 time2 caller).
2f60: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 61 6e (if (or (not (an
2f70: 64 20 28 74 69 6d 65 3f 20 74 69 6d 65 31 29 20 d (time? time1)
2f80: 28 74 69 6d 65 3f 20 74 69 6d 65 32 29 29 29 0a (time? time2))).
2f90: 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 28 74 69 . (not (eq? (ti
2fa0: 6d 65 2d 74 79 70 65 20 74 69 6d 65 31 29 20 28 me-type time1) (
2fb0: 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 32 29 time-type time2)
2fc0: 29 29 29 0a 20 20 20 20 20 20 28 74 6d 3a 74 69 ))). (tm:ti
2fd0: 6d 65 2d 65 72 72 6f 72 20 63 61 6c 6c 65 72 20 me-error caller
2fe0: 27 69 6e 63 6f 6d 70 61 74 69 62 6c 65 2d 74 69 'incompatible-ti
2ff0: 6d 65 2d 74 79 70 65 73 20 23 66 29 0a 20 20 20 me-types #f).
3000: 20 20 20 23 74 29 29 0a 0a 28 64 65 66 69 6e 65 #t))..(define
3010: 20 28 74 69 6d 65 3d 3f 20 74 69 6d 65 31 20 74 (time=? time1 t
3020: 69 6d 65 32 29 0a 20 20 28 74 6d 3a 74 69 6d 65 ime2). (tm:time
3030: 2d 63 6f 6d 70 61 72 65 2d 63 68 65 63 6b 20 74 -compare-check t
3040: 69 6d 65 31 20 74 69 6d 65 32 20 27 74 69 6d 65 ime1 time2 'time
3050: 3d 3f 29 0a 20 20 28 61 6e 64 20 28 3d 20 28 74 =?). (and (= (t
3060: 69 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d 65 31 ime-second time1
3070: 29 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 ) (time-second t
3080: 69 6d 65 32 29 29 0a 20 20 20 20 20 20 20 28 3d ime2)). (=
3090: 20 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e (time-nanosecon
30a0: 64 20 74 69 6d 65 31 29 20 28 74 69 6d 65 2d 6e d time1) (time-n
30b0: 61 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 32 29 anosecond time2)
30c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 )))..(define (ti
30d0: 6d 65 3e 3f 20 74 69 6d 65 31 20 74 69 6d 65 32 me>? time1 time2
30e0: 29 0a 20 20 28 74 6d 3a 74 69 6d 65 2d 63 6f 6d ). (tm:time-com
30f0: 70 61 72 65 2d 63 68 65 63 6b 20 74 69 6d 65 31 pare-check time1
3100: 20 74 69 6d 65 32 20 27 74 69 6d 65 3e 3f 29 0a time2 'time>?).
3110: 20 20 28 6f 72 20 28 3e 20 28 74 69 6d 65 2d 73 (or (> (time-s
3120: 65 63 6f 6e 64 20 74 69 6d 65 31 29 20 28 74 69 econd time1) (ti
3130: 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d 65 32 29 me-second time2)
3140: 29 0a 20 20 20 20 20 20 28 61 6e 64 20 28 3d 20 ). (and (=
3150: 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d (time-second tim
3160: 65 31 29 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 e1) (time-second
3170: 20 74 69 6d 65 32 29 29 0a 09 20 20 20 28 3e 20 time2)).. (>
3180: 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 (time-nanosecond
3190: 20 74 69 6d 65 31 29 20 28 74 69 6d 65 2d 6e 61 time1) (time-na
31a0: 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 32 29 29 nosecond time2))
31b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 )))..(define (ti
31c0: 6d 65 3c 3f 20 74 69 6d 65 31 20 74 69 6d 65 32 me<? time1 time2
31d0: 29 0a 20 20 28 74 6d 3a 74 69 6d 65 2d 63 6f 6d ). (tm:time-com
31e0: 70 61 72 65 2d 63 68 65 63 6b 20 74 69 6d 65 31 pare-check time1
31f0: 20 74 69 6d 65 32 20 27 74 69 6d 65 3c 3f 29 0a time2 'time<?).
3200: 20 20 28 6f 72 20 28 3c 20 28 74 69 6d 65 2d 73 (or (< (time-s
3210: 65 63 6f 6e 64 20 74 69 6d 65 31 29 20 28 74 69 econd time1) (ti
3220: 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d 65 32 29 me-second time2)
3230: 29 0a 20 20 20 20 20 20 28 61 6e 64 20 28 3d 20 ). (and (=
3240: 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d (time-second tim
3250: 65 31 29 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 e1) (time-second
3260: 20 74 69 6d 65 32 29 29 0a 09 20 20 20 28 3c 20 time2)).. (<
3270: 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 (time-nanosecond
3280: 20 74 69 6d 65 31 29 20 28 74 69 6d 65 2d 6e 61 time1) (time-na
3290: 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 32 29 29 nosecond time2))
32a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 )))..(define (ti
32b0: 6d 65 3e 3d 3f 20 74 69 6d 65 31 20 74 69 6d 65 me>=? time1 time
32c0: 32 29 0a 20 20 28 74 6d 3a 74 69 6d 65 2d 63 6f 2). (tm:time-co
32d0: 6d 70 61 72 65 2d 63 68 65 63 6b 20 74 69 6d 65 mpare-check time
32e0: 31 20 74 69 6d 65 32 20 27 74 69 6d 65 3e 3d 3f 1 time2 'time>=?
32f0: 29 0a 20 20 28 6f 72 20 28 3e 3d 20 28 74 69 6d ). (or (>= (tim
3300: 65 2d 73 65 63 6f 6e 64 20 74 69 6d 65 31 29 20 e-second time1)
3310: 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d (time-second tim
3320: 65 32 29 29 0a 20 20 20 20 20 20 28 61 6e 64 20 e2)). (and
3330: 28 3d 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 (= (time-second
3340: 74 69 6d 65 31 29 20 28 74 69 6d 65 2d 73 65 63 time1) (time-sec
3350: 6f 6e 64 20 74 69 6d 65 32 29 29 0a 09 20 20 20 ond time2))..
3360: 28 3e 3d 20 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 (>= (time-nanose
3370: 63 6f 6e 64 20 74 69 6d 65 31 29 20 28 74 69 6d cond time1) (tim
3380: 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 74 69 6d e-nanosecond tim
3390: 65 32 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 e2)))))..(define
33a0: 20 28 74 69 6d 65 3c 3d 3f 20 74 69 6d 65 31 20 (time<=? time1
33b0: 74 69 6d 65 32 29 0a 20 20 28 74 6d 3a 74 69 6d time2). (tm:tim
33c0: 65 2d 63 6f 6d 70 61 72 65 2d 63 68 65 63 6b 20 e-compare-check
33d0: 74 69 6d 65 31 20 74 69 6d 65 32 20 27 74 69 6d time1 time2 'tim
33e0: 65 3c 3d 3f 29 0a 20 20 28 6f 72 20 28 3c 3d 20 e<=?). (or (<=
33f0: 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 69 6d (time-second tim
3400: 65 31 29 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 e1) (time-second
3410: 20 74 69 6d 65 32 29 29 0a 20 20 20 20 20 20 28 time2)). (
3420: 61 6e 64 20 28 3d 20 28 74 69 6d 65 2d 73 65 63 and (= (time-sec
3430: 6f 6e 64 20 74 69 6d 65 31 29 20 28 74 69 6d 65 ond time1) (time
3440: 2d 73 65 63 6f 6e 64 20 74 69 6d 65 32 29 29 0a -second time2)).
3450: 09 20 20 20 28 3c 3d 20 28 74 69 6d 65 2d 6e 61 . (<= (time-na
3460: 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 31 29 20 nosecond time1)
3470: 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 (time-nanosecond
3480: 20 74 69 6d 65 32 29 29 29 29 29 0a 0a 3b 3b 20 time2)))))..;;
3490: 2d 2d 20 74 69 6d 65 20 61 72 69 74 68 6d 65 74 -- time arithmet
34a0: 69 63 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a ic..(define (tm:
34b0: 74 69 6d 65 2d 3e 6e 61 6e 6f 73 65 63 6f 6e 64 time->nanosecond
34c0: 73 20 74 69 6d 65 29 0a 20 20 23 7c 28 64 65 66 s time). #|(def
34d0: 69 6e 65 20 28 73 69 67 6e 31 20 6e 29 20 20 20 ine (sign1 n)
34e0: 3b 20 6d 75 73 74 20 62 65 20 63 6f 64 65 20 72 ; must be code r
34f0: 6f 74 0a 20 20 20 20 28 69 66 20 28 6e 65 67 61 ot. (if (nega
3500: 74 69 76 65 3f 20 6e 29 20 2d 31 20 31 29 29 7c tive? n) -1 1))|
3510: 23 0a 20 20 28 2b 20 28 2a 20 28 74 69 6d 65 2d #. (+ (* (time-
3520: 73 65 63 6f 6e 64 20 74 69 6d 65 29 20 74 6d 3a second time) tm:
3530: 6e 61 6e 6f 29 0a 20 20 20 20 20 28 74 69 6d 65 nano). (time
3540: 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 -nanosecond time
3550: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d )))..(define (tm
3560: 3a 6e 61 6e 6f 73 65 63 6f 6e 64 73 2d 3e 74 69 :nanoseconds->ti
3570: 6d 65 20 74 69 6d 65 2d 74 79 70 65 20 6e 61 6e me time-type nan
3580: 6f 73 65 63 6f 6e 64 73 29 0a 20 20 28 6d 61 6b oseconds). (mak
3590: 65 2d 74 69 6d 65 20 74 69 6d 65 2d 74 79 70 65 e-time time-type
35a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 . (r
35b0: 65 6d 61 69 6e 64 65 72 20 6e 61 6e 6f 73 65 63 emainder nanosec
35c0: 6f 6e 64 73 20 74 6d 3a 6e 61 6e 6f 29 0a 20 20 onds tm:nano).
35d0: 20 20 20 20 20 20 20 20 20 20 20 28 71 75 6f 74 (quot
35e0: 69 65 6e 74 20 6e 61 6e 6f 73 65 63 6f 6e 64 73 ient nanoseconds
35f0: 20 74 6d 3a 6e 61 6e 6f 29 29 29 0a 0a 28 64 65 tm:nano)))..(de
3600: 66 69 6e 65 20 28 74 6d 3a 6e 61 6e 6f 73 65 63 fine (tm:nanosec
3610: 6f 6e 64 73 2d 3e 76 61 6c 75 65 73 20 6e 61 6e onds->values nan
3620: 6f 73 65 63 6f 6e 64 73 29 0a 20 20 28 64 69 76 oseconds). (div
3630: 2d 61 6e 64 2d 6d 6f 64 20 6e 61 6e 6f 73 65 63 -and-mod nanosec
3640: 6f 6e 64 73 20 74 6d 3a 6e 61 6e 6f 29 29 0a 0a onds tm:nano))..
3650: 28 64 65 66 69 6e 65 20 28 74 6d 3a 74 69 6d 65 (define (tm:time
3660: 2d 64 69 66 66 65 72 65 6e 63 65 20 74 69 6d 65 -difference time
3670: 31 20 74 69 6d 65 32 20 74 69 6d 65 33 29 0a 20 1 time2 time3).
3680: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 61 (if (or (not (a
3690: 6e 64 20 28 74 69 6d 65 3f 20 74 69 6d 65 31 29 nd (time? time1)
36a0: 20 28 74 69 6d 65 3f 20 74 69 6d 65 32 29 29 29 (time? time2)))
36b0: 0a 09 20 20 28 6e 6f 74 20 28 65 71 3f 20 28 74 .. (not (eq? (t
36c0: 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 31 29 20 ime-type time1)
36d0: 28 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 32 (time-type time2
36e0: 29 29 29 29 0a 20 20 20 20 20 20 28 74 6d 3a 74 )))). (tm:t
36f0: 69 6d 65 2d 65 72 72 6f 72 20 27 74 69 6d 65 2d ime-error 'time-
3700: 64 69 66 66 65 72 65 6e 63 65 20 27 69 6e 63 6f difference 'inco
3710: 6d 70 61 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 mpatible-time-ty
3720: 70 65 73 20 23 66 29 29 0a 20 20 28 74 69 6d 65 pes #f)). (time
3730: 2d 74 79 70 65 2d 73 65 74 21 20 74 69 6d 65 33 -type-set! time3
3740: 20 74 69 6d 65 2d 64 75 72 61 74 69 6f 6e 29 0a time-duration).
3750: 20 20 28 69 66 20 28 74 69 6d 65 3d 3f 20 74 69 (if (time=? ti
3760: 6d 65 31 20 74 69 6d 65 32 29 0a 20 20 20 20 20 me1 time2).
3770: 20 28 62 65 67 69 6e 0a 09 28 74 69 6d 65 2d 73 (begin..(time-s
3780: 65 63 6f 6e 64 2d 73 65 74 21 20 74 69 6d 65 33 econd-set! time3
3790: 20 30 29 0a 09 28 74 69 6d 65 2d 6e 61 6e 6f 73 0)..(time-nanos
37a0: 65 63 6f 6e 64 2d 73 65 74 21 20 74 69 6d 65 33 econd-set! time3
37b0: 20 30 29 29 0a 20 20 20 20 20 20 28 72 65 63 65 0)). (rece
37c0: 69 76 65 20 0a 20 20 20 20 20 20 20 28 73 65 63 ive . (sec
37d0: 73 20 6e 61 6e 6f 73 29 0a 20 20 20 20 20 20 20 s nanos).
37e0: 28 74 6d 3a 6e 61 6e 6f 73 65 63 6f 6e 64 73 2d (tm:nanoseconds-
37f0: 3e 76 61 6c 75 65 73 20 28 2d 20 28 74 6d 3a 74 >values (- (tm:t
3800: 69 6d 65 2d 3e 6e 61 6e 6f 73 65 63 6f 6e 64 73 ime->nanoseconds
3810: 20 74 69 6d 65 31 29 0a 20 20 20 20 20 20 20 20 time1).
3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3830: 20 20 20 20 20 20 20 20 20 20 28 74 6d 3a 74 69 (tm:ti
3840: 6d 65 2d 3e 6e 61 6e 6f 73 65 63 6f 6e 64 73 20 me->nanoseconds
3850: 74 69 6d 65 32 29 29 29 0a 20 20 20 20 20 20 20 time2))).
3860: 28 74 69 6d 65 2d 73 65 63 6f 6e 64 2d 73 65 74 (time-second-set
3870: 21 20 74 69 6d 65 33 20 73 65 63 73 29 0a 20 20 ! time3 secs).
3880: 20 20 20 20 20 28 74 69 6d 65 2d 6e 61 6e 6f 73 (time-nanos
3890: 65 63 6f 6e 64 2d 73 65 74 21 20 74 69 6d 65 33 econd-set! time3
38a0: 20 6e 61 6e 6f 73 29 29 29 0a 20 20 74 69 6d 65 nanos))). time
38b0: 33 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 6d 3)..(define (tim
38c0: 65 2d 64 69 66 66 65 72 65 6e 63 65 20 74 69 6d e-difference tim
38d0: 65 31 20 74 69 6d 65 32 29 0a 20 20 28 74 6d 3a e1 time2). (tm:
38e0: 74 69 6d 65 2d 64 69 66 66 65 72 65 6e 63 65 20 time-difference
38f0: 74 69 6d 65 31 20 74 69 6d 65 32 20 28 6d 61 6b time1 time2 (mak
3900: 65 2d 74 69 6d 65 20 23 66 20 23 66 20 23 66 29 e-time #f #f #f)
3910: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 6d ))..(define (tim
3920: 65 2d 64 69 66 66 65 72 65 6e 63 65 21 20 74 69 e-difference! ti
3930: 6d 65 31 20 74 69 6d 65 32 29 0a 20 20 28 74 6d me1 time2). (tm
3940: 3a 74 69 6d 65 2d 64 69 66 66 65 72 65 6e 63 65 :time-difference
3950: 20 74 69 6d 65 31 20 74 69 6d 65 32 20 74 69 6d time1 time2 tim
3960: 65 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 e1))..(define (t
3970: 6d 3a 61 64 64 2d 64 75 72 61 74 69 6f 6e 20 74 m:add-duration t
3980: 69 6d 65 31 20 64 75 72 61 74 69 6f 6e 20 74 69 ime1 duration ti
3990: 6d 65 33 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 me3). (if (not
39a0: 28 61 6e 64 20 28 74 69 6d 65 3f 20 74 69 6d 65 (and (time? time
39b0: 31 29 20 28 74 69 6d 65 3f 20 64 75 72 61 74 69 1) (time? durati
39c0: 6f 6e 29 29 29 0a 20 20 20 20 20 20 28 74 6d 3a on))). (tm:
39d0: 74 69 6d 65 2d 65 72 72 6f 72 20 27 61 64 64 2d time-error 'add-
39e0: 64 75 72 61 74 69 6f 6e 20 27 69 6e 63 6f 6d 70 duration 'incomp
39f0: 61 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 65 atible-time-type
3a00: 73 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e 6f s #f)). (if (no
3a10: 74 20 28 65 71 3f 20 28 74 69 6d 65 2d 74 79 70 t (eq? (time-typ
3a20: 65 20 64 75 72 61 74 69 6f 6e 29 20 74 69 6d 65 e duration) time
3a30: 2d 64 75 72 61 74 69 6f 6e 29 29 0a 20 20 20 20 -duration)).
3a40: 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 (tm:time-error
3a50: 20 27 61 64 64 2d 64 75 72 61 74 69 6f 6e 20 27 'add-duration '
3a60: 6e 6f 74 2d 64 75 72 61 74 69 6f 6e 20 64 75 72 not-duration dur
3a70: 61 74 69 6f 6e 29 0a 20 20 20 20 20 20 28 6c 65 ation). (le
3a80: 74 20 28 20 28 73 65 63 2d 70 6c 75 73 20 28 2b t ( (sec-plus (+
3a90: 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 69 (time-second ti
3aa0: 6d 65 31 29 20 28 74 69 6d 65 2d 73 65 63 6f 6e me1) (time-secon
3ab0: 64 20 64 75 72 61 74 69 6f 6e 29 29 29 0a 09 20 d duration)))..
3ac0: 20 20 20 20 28 6e 73 65 63 2d 70 6c 75 73 20 28 (nsec-plus (
3ad0: 2b 20 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f + (time-nanoseco
3ae0: 6e 64 20 74 69 6d 65 31 29 20 28 74 69 6d 65 2d nd time1) (time-
3af0: 6e 61 6e 6f 73 65 63 6f 6e 64 20 64 75 72 61 74 nanosecond durat
3b00: 69 6f 6e 29 29 29 20 29 0a 09 28 6c 65 74 20 28 ion))) )..(let (
3b10: 28 72 20 28 72 65 6d 61 69 6e 64 65 72 20 6e 73 (r (remainder ns
3b20: 65 63 2d 70 6c 75 73 20 74 6d 3a 6e 61 6e 6f 29 ec-plus tm:nano)
3b30: 29 0a 09 20 20 20 20 20 20 28 71 20 28 71 75 6f ).. (q (quo
3b40: 74 69 65 6e 74 20 6e 73 65 63 2d 70 6c 75 73 20 tient nsec-plus
3b50: 74 6d 3a 6e 61 6e 6f 29 29 29 0a 20 20 20 20 20 tm:nano))).
3b60: 20 20 20 20 20 3b 20 28 74 69 6d 65 2d 74 79 70 ; (time-typ
3b70: 65 2d 73 65 74 21 20 74 69 6d 65 33 20 28 74 69 e-set! time3 (ti
3b80: 6d 65 2d 74 79 70 65 20 74 69 6d 65 31 29 29 0a me-type time1)).
3b90: 09 20 20 28 69 66 20 28 6e 65 67 61 74 69 76 65 . (if (negative
3ba0: 3f 20 72 29 0a 09 20 20 20 20 20 20 28 62 65 67 ? r).. (beg
3bb0: 69 6e 0a 09 09 28 74 69 6d 65 2d 73 65 63 6f 6e in...(time-secon
3bc0: 64 2d 73 65 74 21 20 74 69 6d 65 33 20 28 2b 20 d-set! time3 (+
3bd0: 73 65 63 2d 70 6c 75 73 20 71 20 2d 31 29 29 0a sec-plus q -1)).
3be0: 09 09 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f ..(time-nanoseco
3bf0: 6e 64 2d 73 65 74 21 20 74 69 6d 65 33 20 28 2b nd-set! time3 (+
3c00: 20 74 6d 3a 6e 61 6e 6f 20 72 29 29 29 0a 09 20 tm:nano r)))..
3c10: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 74 (begin...(t
3c20: 69 6d 65 2d 73 65 63 6f 6e 64 2d 73 65 74 21 20 ime-second-set!
3c30: 74 69 6d 65 33 20 28 2b 20 73 65 63 2d 70 6c 75 time3 (+ sec-plu
3c40: 73 20 71 29 29 0a 09 09 28 74 69 6d 65 2d 6e 61 s q))...(time-na
3c50: 6e 6f 73 65 63 6f 6e 64 2d 73 65 74 21 20 74 69 nosecond-set! ti
3c60: 6d 65 33 20 72 29 29 29 0a 09 20 20 74 69 6d 65 me3 r))).. time
3c70: 33 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 3))))..(define (
3c80: 61 64 64 2d 64 75 72 61 74 69 6f 6e 20 74 69 6d add-duration tim
3c90: 65 31 20 64 75 72 61 74 69 6f 6e 29 0a 20 20 28 e1 duration). (
3ca0: 74 6d 3a 61 64 64 2d 64 75 72 61 74 69 6f 6e 20 tm:add-duration
3cb0: 74 69 6d 65 31 20 64 75 72 61 74 69 6f 6e 20 28 time1 duration (
3cc0: 6d 61 6b 65 2d 74 69 6d 65 20 28 74 69 6d 65 2d make-time (time-
3cd0: 74 79 70 65 20 74 69 6d 65 31 29 20 23 66 20 23 type time1) #f #
3ce0: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 f)))..(define (a
3cf0: 64 64 2d 64 75 72 61 74 69 6f 6e 21 20 74 69 6d dd-duration! tim
3d00: 65 31 20 64 75 72 61 74 69 6f 6e 29 0a 20 20 28 e1 duration). (
3d10: 74 6d 3a 61 64 64 2d 64 75 72 61 74 69 6f 6e 20 tm:add-duration
3d20: 74 69 6d 65 31 20 64 75 72 61 74 69 6f 6e 20 74 time1 duration t
3d30: 69 6d 65 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 ime1))..(define
3d40: 28 74 6d 3a 73 75 62 74 72 61 63 74 2d 64 75 72 (tm:subtract-dur
3d50: 61 74 69 6f 6e 20 74 69 6d 65 31 20 64 75 72 61 ation time1 dura
3d60: 74 69 6f 6e 20 74 69 6d 65 33 29 0a 20 20 28 69 tion time3). (i
3d70: 66 20 28 6e 6f 74 20 28 61 6e 64 20 28 74 69 6d f (not (and (tim
3d80: 65 3f 20 74 69 6d 65 31 29 20 28 74 69 6d 65 3f e? time1) (time?
3d90: 20 64 75 72 61 74 69 6f 6e 29 29 29 0a 20 20 20 duration))).
3da0: 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f (tm:time-erro
3db0: 72 20 27 61 64 64 2d 64 75 72 61 74 69 6f 6e 20 r 'add-duration
3dc0: 27 69 6e 63 6f 6d 70 61 74 69 62 6c 65 2d 74 69 'incompatible-ti
3dd0: 6d 65 2d 74 79 70 65 73 20 23 66 29 29 0a 20 20 me-types #f)).
3de0: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 74 (if (not (eq? (t
3df0: 69 6d 65 2d 74 79 70 65 20 64 75 72 61 74 69 6f ime-type duratio
3e00: 6e 29 20 74 69 6d 65 2d 64 75 72 61 74 69 6f 6e n) time-duration
3e10: 29 29 0a 20 20 20 20 20 20 28 74 6d 3a 74 69 6d )). (tm:tim
3e20: 65 2d 65 72 72 6f 72 20 27 74 6d 3a 73 75 62 74 e-error 'tm:subt
3e30: 72 61 63 74 2d 64 75 72 61 74 69 6f 6e 20 27 6e ract-duration 'n
3e40: 6f 74 2d 64 75 72 61 74 69 6f 6e 20 64 75 72 61 ot-duration dura
3e50: 74 69 6f 6e 29 0a 20 20 20 20 20 20 28 6c 65 74 tion). (let
3e60: 20 28 20 28 73 65 63 2d 6d 69 6e 75 73 20 20 28 ( (sec-minus (
3e70: 2d 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 74 - (time-second t
3e80: 69 6d 65 31 29 20 28 74 69 6d 65 2d 73 65 63 6f ime1) (time-seco
3e90: 6e 64 20 64 75 72 61 74 69 6f 6e 29 29 29 0a 09 nd duration)))..
3ea0: 20 20 20 20 20 28 6e 73 65 63 2d 6d 69 6e 75 73 (nsec-minus
3eb0: 20 28 2d 20 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 (- (time-nanose
3ec0: 63 6f 6e 64 20 74 69 6d 65 31 29 20 28 74 69 6d cond time1) (tim
3ed0: 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 64 75 72 e-nanosecond dur
3ee0: 61 74 69 6f 6e 29 29 29 20 29 0a 09 28 6c 65 74 ation))) )..(let
3ef0: 20 28 28 72 20 28 72 65 6d 61 69 6e 64 65 72 20 ((r (remainder
3f00: 6e 73 65 63 2d 6d 69 6e 75 73 20 74 6d 3a 6e 61 nsec-minus tm:na
3f10: 6e 6f 29 29 0a 09 20 20 20 20 20 20 28 71 20 28 no)).. (q (
3f20: 71 75 6f 74 69 65 6e 74 20 6e 73 65 63 2d 6d 69 quotient nsec-mi
3f30: 6e 75 73 20 74 6d 3a 6e 61 6e 6f 29 29 29 0a 09 nus tm:nano)))..
3f40: 20 20 28 69 66 20 28 6e 65 67 61 74 69 76 65 3f (if (negative?
3f50: 20 72 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 r).. (begi
3f60: 6e 0a 09 09 28 74 69 6d 65 2d 73 65 63 6f 6e 64 n...(time-second
3f70: 2d 73 65 74 21 20 74 69 6d 65 33 20 28 2d 20 73 -set! time3 (- s
3f80: 65 63 2d 6d 69 6e 75 73 20 71 20 31 29 29 0a 09 ec-minus q 1))..
3f90: 09 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e .(time-nanosecon
3fa0: 64 2d 73 65 74 21 20 74 69 6d 65 33 20 28 2b 20 d-set! time3 (+
3fb0: 74 6d 3a 6e 61 6e 6f 20 72 29 29 29 0a 09 20 20 tm:nano r)))..
3fc0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 74 69 (begin...(ti
3fd0: 6d 65 2d 73 65 63 6f 6e 64 2d 73 65 74 21 20 74 me-second-set! t
3fe0: 69 6d 65 33 20 28 2d 20 73 65 63 2d 6d 69 6e 75 ime3 (- sec-minu
3ff0: 73 20 71 29 29 0a 09 09 28 74 69 6d 65 2d 6e 61 s q))...(time-na
4000: 6e 6f 73 65 63 6f 6e 64 2d 73 65 74 21 20 74 69 nosecond-set! ti
4010: 6d 65 33 20 72 29 29 29 0a 09 20 20 74 69 6d 65 me3 r))).. time
4020: 33 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 3))))..(define (
4030: 73 75 62 74 72 61 63 74 2d 64 75 72 61 74 69 6f subtract-duratio
4040: 6e 20 74 69 6d 65 31 20 64 75 72 61 74 69 6f 6e n time1 duration
4050: 29 0a 20 20 28 74 6d 3a 73 75 62 74 72 61 63 74 ). (tm:subtract
4060: 2d 64 75 72 61 74 69 6f 6e 20 74 69 6d 65 31 20 -duration time1
4070: 64 75 72 61 74 69 6f 6e 20 28 6d 61 6b 65 2d 74 duration (make-t
4080: 69 6d 65 20 28 74 69 6d 65 2d 74 79 70 65 20 74 ime (time-type t
4090: 69 6d 65 31 29 20 23 66 20 23 66 29 29 29 0a 0a ime1) #f #f)))..
40a0: 28 64 65 66 69 6e 65 20 28 73 75 62 74 72 61 63 (define (subtrac
40b0: 74 2d 64 75 72 61 74 69 6f 6e 21 20 74 69 6d 65 t-duration! time
40c0: 31 20 64 75 72 61 74 69 6f 6e 29 0a 20 20 28 74 1 duration). (t
40d0: 6d 3a 73 75 62 74 72 61 63 74 2d 64 75 72 61 74 m:subtract-durat
40e0: 69 6f 6e 20 74 69 6d 65 31 20 64 75 72 61 74 69 ion time1 durati
40f0: 6f 6e 20 74 69 6d 65 31 29 29 0a 0a 0a 3b 3b 20 on time1))...;;
4100: 2d 2d 20 63 6f 6e 76 65 72 74 65 72 73 20 62 65 -- converters be
4110: 74 77 65 65 6e 20 74 79 70 65 73 2e 0a 0a 28 64 tween types...(d
4120: 65 66 69 6e 65 20 28 74 6d 3a 74 69 6d 65 2d 74 efine (tm:time-t
4130: 61 69 2d 3e 74 69 6d 65 2d 75 74 63 21 20 74 69 ai->time-utc! ti
4140: 6d 65 2d 69 6e 20 74 69 6d 65 2d 6f 75 74 20 63 me-in time-out c
4150: 61 6c 6c 65 72 29 0a 20 20 28 69 66 20 28 6e 6f aller). (if (no
4160: 74 20 28 65 71 3f 20 28 74 69 6d 65 2d 74 79 70 t (eq? (time-typ
4170: 65 20 74 69 6d 65 2d 69 6e 29 20 74 69 6d 65 2d e time-in) time-
4180: 74 61 69 29 29 0a 20 20 20 20 20 20 28 74 6d 3a tai)). (tm:
4190: 74 69 6d 65 2d 65 72 72 6f 72 20 63 61 6c 6c 65 time-error calle
41a0: 72 20 27 69 6e 63 6f 6d 70 61 74 69 62 6c 65 2d r 'incompatible-
41b0: 74 69 6d 65 2d 74 79 70 65 73 20 74 69 6d 65 2d time-types time-
41c0: 69 6e 29 29 0a 20 20 28 74 69 6d 65 2d 74 79 70 in)). (time-typ
41d0: 65 2d 73 65 74 21 20 74 69 6d 65 2d 6f 75 74 20 e-set! time-out
41e0: 74 69 6d 65 2d 75 74 63 29 0a 20 20 28 74 69 6d time-utc). (tim
41f0: 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 2d 73 65 74 e-nanosecond-set
4200: 21 20 74 69 6d 65 2d 6f 75 74 20 28 74 69 6d 65 ! time-out (time
4210: 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 -nanosecond time
4220: 2d 69 6e 29 29 0a 20 20 28 74 69 6d 65 2d 73 65 -in)). (time-se
4230: 63 6f 6e 64 2d 73 65 74 21 20 20 20 20 20 74 69 cond-set! ti
4240: 6d 65 2d 6f 75 74 20 28 2d 20 28 74 69 6d 65 2d me-out (- (time-
4250: 73 65 63 6f 6e 64 20 74 69 6d 65 2d 69 6e 29 0a second time-in).
4260: 09 09 09 09 20 20 20 20 28 74 6d 3a 6c 65 61 70 .... (tm:leap
4270: 2d 73 65 63 6f 6e 64 2d 6e 65 67 2d 64 65 6c 74 -second-neg-delt
4280: 61 20 0a 09 09 09 09 20 20 20 20 20 28 74 69 6d a ..... (tim
4290: 65 2d 73 65 63 6f 6e 64 20 74 69 6d 65 2d 69 6e e-second time-in
42a0: 29 29 29 29 0a 20 20 74 69 6d 65 2d 6f 75 74 29 )))). time-out)
42b0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 6d 65 2d ..(define (time-
42c0: 74 61 69 2d 3e 74 69 6d 65 2d 75 74 63 20 74 69 tai->time-utc ti
42d0: 6d 65 2d 69 6e 29 0a 20 20 28 74 6d 3a 74 69 6d me-in). (tm:tim
42e0: 65 2d 74 61 69 2d 3e 74 69 6d 65 2d 75 74 63 21 e-tai->time-utc!
42f0: 20 74 69 6d 65 2d 69 6e 20 28 6d 61 6b 65 2d 74 time-in (make-t
4300: 69 6d 65 20 23 66 20 23 66 20 23 66 29 20 27 74 ime #f #f #f) 't
4310: 69 6d 65 2d 74 61 69 2d 3e 74 69 6d 65 2d 75 74 ime-tai->time-ut
4320: 63 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 c))...(define (t
4330: 69 6d 65 2d 74 61 69 2d 3e 74 69 6d 65 2d 75 74 ime-tai->time-ut
4340: 63 21 20 74 69 6d 65 2d 69 6e 29 0a 20 20 28 74 c! time-in). (t
4350: 6d 3a 74 69 6d 65 2d 74 61 69 2d 3e 74 69 6d 65 m:time-tai->time
4360: 2d 75 74 63 21 20 74 69 6d 65 2d 69 6e 20 74 69 -utc! time-in ti
4370: 6d 65 2d 69 6e 20 27 74 69 6d 65 2d 74 61 69 2d me-in 'time-tai-
4380: 3e 74 69 6d 65 2d 75 74 63 21 29 29 0a 0a 0a 28 >time-utc!))...(
4390: 64 65 66 69 6e 65 20 28 74 6d 3a 74 69 6d 65 2d define (tm:time-
43a0: 75 74 63 2d 3e 74 69 6d 65 2d 74 61 69 21 20 74 utc->time-tai! t
43b0: 69 6d 65 2d 69 6e 20 74 69 6d 65 2d 6f 75 74 20 ime-in time-out
43c0: 63 61 6c 6c 65 72 29 0a 20 20 28 69 66 20 28 6e caller). (if (n
43d0: 6f 74 20 28 65 71 3f 20 28 74 69 6d 65 2d 74 79 ot (eq? (time-ty
43e0: 70 65 20 74 69 6d 65 2d 69 6e 29 20 74 69 6d 65 pe time-in) time
43f0: 2d 75 74 63 29 29 0a 20 20 20 20 20 20 28 74 6d -utc)). (tm
4400: 3a 74 69 6d 65 2d 65 72 72 6f 72 20 63 61 6c 6c :time-error call
4410: 65 72 20 27 69 6e 63 6f 6d 70 61 74 69 62 6c 65 er 'incompatible
4420: 2d 74 69 6d 65 2d 74 79 70 65 73 20 74 69 6d 65 -time-types time
4430: 2d 69 6e 29 29 0a 20 20 28 74 69 6d 65 2d 74 79 -in)). (time-ty
4440: 70 65 2d 73 65 74 21 20 74 69 6d 65 2d 6f 75 74 pe-set! time-out
4450: 20 74 69 6d 65 2d 74 61 69 29 0a 20 20 28 74 69 time-tai). (ti
4460: 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 2d 73 65 me-nanosecond-se
4470: 74 21 20 74 69 6d 65 2d 6f 75 74 20 28 74 69 6d t! time-out (tim
4480: 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 74 69 6d e-nanosecond tim
4490: 65 2d 69 6e 29 29 0a 20 20 28 74 69 6d 65 2d 73 e-in)). (time-s
44a0: 65 63 6f 6e 64 2d 73 65 74 21 20 20 20 20 20 74 econd-set! t
44b0: 69 6d 65 2d 6f 75 74 20 28 2b 20 28 74 69 6d 65 ime-out (+ (time
44c0: 2d 73 65 63 6f 6e 64 20 74 69 6d 65 2d 69 6e 29 -second time-in)
44d0: 0a 09 09 09 09 20 20 20 20 28 74 6d 3a 6c 65 61 ..... (tm:lea
44e0: 70 2d 73 65 63 6f 6e 64 2d 64 65 6c 74 61 20 0a p-second-delta .
44f0: 09 09 09 09 20 20 20 20 20 28 74 69 6d 65 2d 73 .... (time-s
4500: 65 63 6f 6e 64 20 74 69 6d 65 2d 69 6e 29 29 29 econd time-in)))
4510: 29 0a 20 20 74 69 6d 65 2d 6f 75 74 29 0a 0a 0a ). time-out)...
4520: 28 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 75 74 (define (time-ut
4530: 63 2d 3e 74 69 6d 65 2d 74 61 69 20 74 69 6d 65 c->time-tai time
4540: 2d 69 6e 29 0a 20 20 28 74 6d 3a 74 69 6d 65 2d -in). (tm:time-
4550: 75 74 63 2d 3e 74 69 6d 65 2d 74 61 69 21 20 74 utc->time-tai! t
4560: 69 6d 65 2d 69 6e 20 28 6d 61 6b 65 2d 74 69 6d ime-in (make-tim
4570: 65 20 23 66 20 23 66 20 23 66 29 20 27 74 69 6d e #f #f #f) 'tim
4580: 65 2d 75 74 63 2d 3e 74 69 6d 65 2d 74 61 69 29 e-utc->time-tai)
4590: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 6d 65 )..(define (time
45a0: 2d 75 74 63 2d 3e 74 69 6d 65 2d 74 61 69 21 20 -utc->time-tai!
45b0: 74 69 6d 65 2d 69 6e 29 0a 20 20 28 74 6d 3a 74 time-in). (tm:t
45c0: 69 6d 65 2d 75 74 63 2d 3e 74 69 6d 65 2d 74 61 ime-utc->time-ta
45d0: 69 21 20 74 69 6d 65 2d 69 6e 20 74 69 6d 65 2d i! time-in time-
45e0: 69 6e 20 27 74 69 6d 65 2d 75 74 63 2d 3e 74 69 in 'time-utc->ti
45f0: 6d 65 2d 74 61 69 21 29 29 0a 0a 3b 3b 20 2d 2d me-tai!))..;; --
4600: 20 74 68 65 73 65 20 64 65 70 65 6e 64 20 6f 6e these depend on
4610: 20 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 20 time-monotonic
4620: 68 61 76 69 6e 67 20 74 68 65 20 73 61 6d 65 20 having the same
4630: 64 65 66 69 6e 69 74 69 6f 6e 20 61 73 20 74 69 definition as ti
4640: 6d 65 2d 74 61 69 21 0a 28 64 65 66 69 6e 65 20 me-tai!.(define
4650: 28 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d (time-monotonic-
4660: 3e 74 69 6d 65 2d 75 74 63 20 74 69 6d 65 2d 69 >time-utc time-i
4670: 6e 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 65 n). (if (not (e
4680: 71 3f 20 28 74 69 6d 65 2d 74 79 70 65 20 74 69 q? (time-type ti
4690: 6d 65 2d 69 6e 29 20 74 69 6d 65 2d 6d 6f 6e 6f me-in) time-mono
46a0: 74 6f 6e 69 63 29 29 0a 20 20 20 20 20 20 28 74 tonic)). (t
46b0: 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 74 69 m:time-error 'ti
46c0: 6d 65 2d 6d 6f 6e 6f 74 6f 69 6e 63 2d 3e 74 69 me-monotoinc->ti
46d0: 6d 65 2d 75 74 63 20 27 69 6e 63 6f 6d 70 61 74 me-utc 'incompat
46e0: 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 65 73 20 ible-time-types
46f0: 74 69 6d 65 2d 69 6e 29 29 0a 20 20 28 6c 65 74 time-in)). (let
4700: 20 28 28 6e 74 69 6d 65 20 28 63 6f 70 79 2d 74 ((ntime (copy-t
4710: 69 6d 65 20 74 69 6d 65 2d 69 6e 29 29 29 0a 20 ime time-in))).
4720: 20 20 20 28 74 69 6d 65 2d 74 79 70 65 2d 73 65 (time-type-se
4730: 74 21 20 6e 74 69 6d 65 20 74 69 6d 65 2d 74 61 t! ntime time-ta
4740: 69 29 0a 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d i). (tm:time-
4750: 74 61 69 2d 3e 74 69 6d 65 2d 75 74 63 21 20 6e tai->time-utc! n
4760: 74 69 6d 65 20 6e 74 69 6d 65 20 27 74 69 6d 65 time ntime 'time
4770: 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e 74 69 6d 65 -monotonic->time
4780: 2d 75 74 63 29 29 29 0a 0a 28 64 65 66 69 6e 65 -utc)))..(define
4790: 20 28 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 (time-monotonic
47a0: 2d 3e 74 69 6d 65 2d 75 74 63 21 20 74 69 6d 65 ->time-utc! time
47b0: 2d 69 6e 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 -in). (if (not
47c0: 28 65 71 3f 20 28 74 69 6d 65 2d 74 79 70 65 20 (eq? (time-type
47d0: 74 69 6d 65 2d 69 6e 29 20 74 69 6d 65 2d 6d 6f time-in) time-mo
47e0: 6e 6f 74 6f 6e 69 63 29 29 0a 20 20 20 20 20 20 notonic)).
47f0: 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 (tm:time-error '
4800: 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e time-monotonic->
4810: 74 69 6d 65 2d 75 74 63 21 20 27 69 6e 63 6f 6d time-utc! 'incom
4820: 70 61 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 patible-time-typ
4830: 65 73 20 74 69 6d 65 2d 69 6e 29 29 0a 20 20 28 es time-in)). (
4840: 74 69 6d 65 2d 74 79 70 65 2d 73 65 74 21 20 74 time-type-set! t
4850: 69 6d 65 2d 69 6e 20 74 69 6d 65 2d 74 61 69 29 ime-in time-tai)
4860: 0a 20 20 28 74 6d 3a 74 69 6d 65 2d 74 61 69 2d . (tm:time-tai-
4870: 3e 74 69 6d 65 2d 75 74 63 21 20 74 69 6d 65 2d >time-utc! time-
4880: 69 6e 20 74 69 6d 65 2d 69 6e 20 27 74 69 6d 65 in time-in 'time
4890: 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e 74 69 6d 65 -monotonic->time
48a0: 2d 75 74 63 29 29 0a 0a 28 64 65 66 69 6e 65 20 -utc))..(define
48b0: 28 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d (time-monotonic-
48c0: 3e 74 69 6d 65 2d 74 61 69 20 74 69 6d 65 2d 69 >time-tai time-i
48d0: 6e 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 65 n). (if (not (e
48e0: 71 3f 20 28 74 69 6d 65 2d 74 79 70 65 20 74 69 q? (time-type ti
48f0: 6d 65 2d 69 6e 29 20 74 69 6d 65 2d 6d 6f 6e 6f me-in) time-mono
4900: 74 6f 6e 69 63 29 29 0a 20 20 20 20 20 20 28 74 tonic)). (t
4910: 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 74 69 m:time-error 'ti
4920: 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e 74 69 me-monotonic->ti
4930: 6d 65 2d 74 61 69 20 27 69 6e 63 6f 6d 70 61 74 me-tai 'incompat
4940: 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 65 73 20 ible-time-types
4950: 74 69 6d 65 2d 69 6e 29 29 0a 20 20 28 6c 65 74 time-in)). (let
4960: 20 28 28 6e 74 69 6d 65 20 28 63 6f 70 79 2d 74 ((ntime (copy-t
4970: 69 6d 65 20 74 69 6d 65 2d 69 6e 29 29 29 0a 20 ime time-in))).
4980: 20 20 20 28 74 69 6d 65 2d 74 79 70 65 2d 73 65 (time-type-se
4990: 74 21 20 6e 74 69 6d 65 20 74 69 6d 65 2d 74 61 t! ntime time-ta
49a0: 69 29 0a 20 20 20 20 6e 74 69 6d 65 29 29 0a 0a i). ntime))..
49b0: 28 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 6d 6f (define (time-mo
49c0: 6e 6f 74 6f 6e 69 63 2d 3e 74 69 6d 65 2d 74 61 notonic->time-ta
49d0: 69 21 20 74 69 6d 65 2d 69 6e 29 0a 20 20 28 69 i! time-in). (i
49e0: 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 74 69 6d f (not (eq? (tim
49f0: 65 2d 74 79 70 65 20 74 69 6d 65 2d 69 6e 29 20 e-type time-in)
4a00: 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 29 29 time-monotonic))
4a10: 0a 20 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d . (tm:time-
4a20: 65 72 72 6f 72 20 27 74 69 6d 65 2d 6d 6f 6e 6f error 'time-mono
4a30: 74 6f 6e 69 63 2d 3e 74 69 6d 65 2d 74 61 69 21 tonic->time-tai!
4a40: 20 27 69 6e 63 6f 6d 70 61 74 69 62 6c 65 2d 74 'incompatible-t
4a50: 69 6d 65 2d 74 79 70 65 73 20 74 69 6d 65 2d 69 ime-types time-i
4a60: 6e 29 29 0a 20 20 28 74 69 6d 65 2d 74 79 70 65 n)). (time-type
4a70: 2d 73 65 74 21 20 74 69 6d 65 2d 69 6e 20 74 69 -set! time-in ti
4a80: 6d 65 2d 74 61 69 29 0a 20 20 74 69 6d 65 2d 69 me-tai). time-i
4a90: 6e 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 6d n)..(define (tim
4aa0: 65 2d 75 74 63 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f e-utc->time-mono
4ab0: 74 6f 6e 69 63 20 74 69 6d 65 2d 69 6e 29 0a 20 tonic time-in).
4ac0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
4ad0: 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 2d 69 time-type time-i
4ae0: 6e 29 20 74 69 6d 65 2d 75 74 63 29 29 0a 20 20 n) time-utc)).
4af0: 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 (tm:time-err
4b00: 6f 72 20 27 74 69 6d 65 2d 75 74 63 2d 3e 74 69 or 'time-utc->ti
4b10: 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 20 27 69 6e me-monotonic 'in
4b20: 63 6f 6d 70 61 74 69 62 6c 65 2d 74 69 6d 65 2d compatible-time-
4b30: 74 79 70 65 73 20 74 69 6d 65 2d 69 6e 29 29 0a types time-in)).
4b40: 20 20 28 6c 65 74 20 28 28 6e 74 69 6d 65 20 28 (let ((ntime (
4b50: 74 6d 3a 74 69 6d 65 2d 75 74 63 2d 3e 74 69 6d tm:time-utc->tim
4b60: 65 2d 74 61 69 21 20 74 69 6d 65 2d 69 6e 20 28 e-tai! time-in (
4b70: 6d 61 6b 65 2d 74 69 6d 65 20 23 66 20 23 66 20 make-time #f #f
4b80: 23 66 29 0a 09 09 09 09 20 20 20 20 20 20 20 27 #f)..... '
4b90: 74 69 6d 65 2d 75 74 63 2d 3e 74 69 6d 65 2d 6d time-utc->time-m
4ba0: 6f 6e 6f 74 6f 6e 69 63 29 29 29 0a 20 20 20 20 onotonic))).
4bb0: 28 74 69 6d 65 2d 74 79 70 65 2d 73 65 74 21 20 (time-type-set!
4bc0: 6e 74 69 6d 65 20 74 69 6d 65 2d 6d 6f 6e 6f 74 ntime time-monot
4bd0: 6f 6e 69 63 29 0a 20 20 20 20 6e 74 69 6d 65 29 onic). ntime)
4be0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 69 6d )...(define (tim
4bf0: 65 2d 75 74 63 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f e-utc->time-mono
4c00: 74 6f 6e 69 63 21 20 74 69 6d 65 2d 69 6e 29 0a tonic! time-in).
4c10: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
4c20: 28 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 2d (time-type time-
4c30: 69 6e 29 20 74 69 6d 65 2d 75 74 63 29 29 0a 20 in) time-utc)).
4c40: 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 (tm:time-er
4c50: 72 6f 72 20 27 74 69 6d 65 2d 75 74 63 2d 3e 74 ror 'time-utc->t
4c60: 69 6d 65 2d 6d 6f 6e 74 6f 6e 69 63 21 20 27 69 ime-montonic! 'i
4c70: 6e 63 6f 6d 70 61 74 69 62 6c 65 2d 74 69 6d 65 ncompatible-time
4c80: 2d 74 79 70 65 73 20 74 69 6d 65 2d 69 6e 29 29 -types time-in))
4c90: 0a 20 20 28 6c 65 74 20 28 28 6e 74 69 6d 65 20 . (let ((ntime
4ca0: 28 74 6d 3a 74 69 6d 65 2d 75 74 63 2d 3e 74 69 (tm:time-utc->ti
4cb0: 6d 65 2d 74 61 69 21 20 74 69 6d 65 2d 69 6e 20 me-tai! time-in
4cc0: 74 69 6d 65 2d 69 6e 0a 09 09 09 09 20 20 20 20 time-in.....
4cd0: 20 20 20 27 74 69 6d 65 2d 75 74 63 2d 3e 74 69 'time-utc->ti
4ce0: 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 21 29 29 29 me-monotonic!)))
4cf0: 0a 20 20 20 20 28 74 69 6d 65 2d 74 79 70 65 2d . (time-type-
4d00: 73 65 74 21 20 6e 74 69 6d 65 20 74 69 6d 65 2d set! ntime time-
4d10: 6d 6f 6e 6f 74 6f 6e 69 63 29 0a 20 20 20 20 6e monotonic). n
4d20: 74 69 6d 65 29 29 0a 0a 0a 28 64 65 66 69 6e 65 time))...(define
4d30: 20 28 74 69 6d 65 2d 74 61 69 2d 3e 74 69 6d 65 (time-tai->time
4d40: 2d 6d 6f 6e 6f 74 6f 6e 69 63 20 74 69 6d 65 2d -monotonic time-
4d50: 69 6e 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 in). (if (not (
4d60: 65 71 3f 20 28 74 69 6d 65 2d 74 79 70 65 20 74 eq? (time-type t
4d70: 69 6d 65 2d 69 6e 29 20 74 69 6d 65 2d 74 61 69 ime-in) time-tai
4d80: 29 29 0a 20 20 20 20 20 20 28 74 6d 3a 74 69 6d )). (tm:tim
4d90: 65 2d 65 72 72 6f 72 20 27 74 69 6d 65 2d 74 61 e-error 'time-ta
4da0: 69 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 i->time-monotoni
4db0: 63 20 27 69 6e 63 6f 6d 70 61 74 69 62 6c 65 2d c 'incompatible-
4dc0: 74 69 6d 65 2d 74 79 70 65 73 20 74 69 6d 65 2d time-types time-
4dd0: 69 6e 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 74 in)). (let ((nt
4de0: 69 6d 65 20 28 63 6f 70 79 2d 74 69 6d 65 20 74 ime (copy-time t
4df0: 69 6d 65 2d 69 6e 29 29 29 0a 20 20 20 20 28 74 ime-in))). (t
4e00: 69 6d 65 2d 74 79 70 65 2d 73 65 74 21 20 6e 74 ime-type-set! nt
4e10: 69 6d 65 20 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e ime time-monoton
4e20: 69 63 29 0a 20 20 20 20 6e 74 69 6d 65 29 29 0a ic). ntime)).
4e30: 0a 28 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 74 .(define (time-t
4e40: 61 69 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e ai->time-monoton
4e50: 69 63 21 20 74 69 6d 65 2d 69 6e 29 0a 20 20 28 ic! time-in). (
4e60: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 74 69 if (not (eq? (ti
4e70: 6d 65 2d 74 79 70 65 20 74 69 6d 65 2d 69 6e 29 me-type time-in)
4e80: 20 74 69 6d 65 2d 74 61 69 29 29 0a 20 20 20 20 time-tai)).
4e90: 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 (tm:time-error
4ea0: 20 27 74 69 6d 65 2d 74 61 69 2d 3e 74 69 6d 65 'time-tai->time
4eb0: 2d 6d 6f 6e 6f 74 6f 6e 69 63 21 20 20 27 69 6e -monotonic! 'in
4ec0: 63 6f 6d 70 61 74 69 62 6c 65 2d 74 69 6d 65 2d compatible-time-
4ed0: 74 79 70 65 73 20 74 69 6d 65 2d 69 6e 29 29 0a types time-in)).
4ee0: 20 20 28 74 69 6d 65 2d 74 79 70 65 2d 73 65 74 (time-type-set
4ef0: 21 20 74 69 6d 65 2d 69 6e 20 74 69 6d 65 2d 6d ! time-in time-m
4f00: 6f 6e 6f 74 6f 6e 69 63 29 0a 20 20 74 69 6d 65 onotonic). time
4f10: 2d 69 6e 29 0a 0a 0a 3b 3b 20 2d 2d 20 64 61 74 -in)...;; -- dat
4f20: 65 20 73 74 72 75 63 74 75 72 65 73 0a 0a 28 64 e structures..(d
4f30: 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 79 70 efine-record-typ
4f40: 65 20 64 61 74 65 20 0a 20 20 28 66 69 65 6c 64 e date . (field
4f50: 73 0a 20 20 20 20 28 6d 75 74 61 62 6c 65 20 6e s. (mutable n
4f60: 61 6e 6f 73 65 63 6f 6e 64 29 0a 20 20 20 20 28 anosecond). (
4f70: 6d 75 74 61 62 6c 65 20 73 65 63 6f 6e 64 29 0a mutable second).
4f80: 20 20 20 20 28 6d 75 74 61 62 6c 65 20 6d 69 6e (mutable min
4f90: 75 74 65 29 0a 20 20 20 20 28 6d 75 74 61 62 6c ute). (mutabl
4fa0: 65 20 68 6f 75 72 29 0a 20 20 20 20 28 6d 75 74 e hour). (mut
4fb0: 61 62 6c 65 20 64 61 79 29 0a 20 20 20 20 28 6d able day). (m
4fc0: 75 74 61 62 6c 65 20 6d 6f 6e 74 68 29 0a 20 20 utable month).
4fd0: 20 20 28 6d 75 74 61 62 6c 65 20 79 65 61 72 29 (mutable year)
4fe0: 0a 20 20 20 20 28 6d 75 74 61 62 6c 65 20 7a 6f . (mutable zo
4ff0: 6e 65 2d 6f 66 66 73 65 74 29 29 29 0a 0a 3b 3b ne-offset)))..;;
5000: 20 72 65 64 65 66 69 6e 65 20 73 65 74 74 65 72 redefine setter
5010: 73 20 28 69 6e 20 49 6b 61 72 75 73 20 76 65 72 s (in Ikarus ver
5020: 73 69 6f 6e 2c 20 6f 6e 6c 79 20 74 6f 20 6b 65 sion, only to ke
5030: 65 70 20 6e 61 6d 65 73 20 74 68 65 20 73 61 6d ep names the sam
5040: 65 20 69 6e 20 62 65 6c 6f 77 20 63 6f 64 65 29 e in below code)
5050: 0a 28 64 65 66 69 6e 65 20 74 6d 3a 73 65 74 2d .(define tm:set-
5060: 64 61 74 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 21 date-nanosecond!
5070: 20 64 61 74 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 date-nanosecond
5080: 2d 73 65 74 21 29 0a 28 64 65 66 69 6e 65 20 74 -set!).(define t
5090: 6d 3a 73 65 74 2d 64 61 74 65 2d 73 65 63 6f 6e m:set-date-secon
50a0: 64 21 20 64 61 74 65 2d 73 65 63 6f 6e 64 2d 73 d! date-second-s
50b0: 65 74 21 29 0a 28 64 65 66 69 6e 65 20 74 6d 3a et!).(define tm:
50c0: 73 65 74 2d 64 61 74 65 2d 6d 69 6e 75 74 65 21 set-date-minute!
50d0: 20 64 61 74 65 2d 6d 69 6e 75 74 65 2d 73 65 74 date-minute-set
50e0: 21 29 0a 28 64 65 66 69 6e 65 20 74 6d 3a 73 65 !).(define tm:se
50f0: 74 2d 64 61 74 65 2d 68 6f 75 72 21 20 64 61 74 t-date-hour! dat
5100: 65 2d 68 6f 75 72 2d 73 65 74 21 29 0a 28 64 65 e-hour-set!).(de
5110: 66 69 6e 65 20 74 6d 3a 73 65 74 2d 64 61 74 65 fine tm:set-date
5120: 2d 64 61 79 21 20 64 61 74 65 2d 64 61 79 2d 73 -day! date-day-s
5130: 65 74 21 29 0a 28 64 65 66 69 6e 65 20 74 6d 3a et!).(define tm:
5140: 73 65 74 2d 64 61 74 65 2d 6d 6f 6e 74 68 21 20 set-date-month!
5150: 64 61 74 65 2d 6d 6f 6e 74 68 2d 73 65 74 21 29 date-month-set!)
5160: 0a 28 64 65 66 69 6e 65 20 74 6d 3a 73 65 74 2d .(define tm:set-
5170: 64 61 74 65 2d 79 65 61 72 21 20 64 61 74 65 2d date-year! date-
5180: 79 65 61 72 2d 73 65 74 21 29 0a 28 64 65 66 69 year-set!).(defi
5190: 6e 65 20 74 6d 3a 73 65 74 2d 64 61 74 65 2d 7a ne tm:set-date-z
51a0: 6f 6e 65 2d 6f 66 66 73 65 74 21 20 64 61 74 65 one-offset! date
51b0: 2d 7a 6f 6e 65 2d 6f 66 66 73 65 74 2d 73 65 74 -zone-offset-set
51c0: 21 29 0a 0a 3b 3b 20 67 69 76 65 73 20 74 68 65 !)..;; gives the
51d0: 20 6a 75 6c 69 61 6e 20 64 61 79 20 77 68 69 63 julian day whic
51e0: 68 20 73 74 61 72 74 73 20 61 74 20 6e 6f 6f 6e h starts at noon
51f0: 2e 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 65 6e ..(define (tm:en
5200: 63 6f 64 65 2d 6a 75 6c 69 61 6e 2d 64 61 79 2d code-julian-day-
5210: 6e 75 6d 62 65 72 20 64 61 79 20 6d 6f 6e 74 68 number day month
5220: 20 79 65 61 72 29 0a 20 20 28 6c 65 74 2a 20 28 year). (let* (
5230: 28 61 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 (a (quotient (-
5240: 31 34 20 6d 6f 6e 74 68 29 20 31 32 29 29 0a 09 14 month) 12))..
5250: 20 28 79 20 28 2d 20 28 2d 20 28 2b 20 79 65 61 (y (- (- (+ yea
5260: 72 20 34 38 30 30 29 20 61 29 20 28 69 66 20 28 r 4800) a) (if (
5270: 6e 65 67 61 74 69 76 65 3f 20 79 65 61 72 29 20 negative? year)
5280: 2d 31 20 30 29 29 29 0a 09 20 28 6d 20 28 2d 20 -1 0))).. (m (-
5290: 28 2b 20 6d 6f 6e 74 68 20 28 2a 20 31 32 20 61 (+ month (* 12 a
52a0: 29 29 20 33 29 29 29 0a 20 20 20 20 28 2b 20 64 )) 3))). (+ d
52b0: 61 79 0a 20 20 20 20 20 20 20 28 71 75 6f 74 69 ay. (quoti
52c0: 65 6e 74 20 28 2b 20 28 2a 20 31 35 33 20 6d 29 ent (+ (* 153 m)
52d0: 20 32 29 20 35 29 0a 20 20 20 20 20 20 20 28 2a 2) 5). (*
52e0: 20 33 36 35 20 79 29 0a 20 20 20 20 20 20 20 28 365 y). (
52f0: 71 75 6f 74 69 65 6e 74 20 79 20 34 29 0a 20 20 quotient y 4).
5300: 20 20 20 20 20 28 2d 20 28 71 75 6f 74 69 65 6e (- (quotien
5310: 74 20 79 20 31 30 30 29 29 0a 20 20 20 20 20 20 t y 100)).
5320: 20 28 71 75 6f 74 69 65 6e 74 20 79 20 34 30 30 (quotient y 400
5330: 29 0a 20 20 20 20 20 20 20 2d 33 32 30 34 35 29 ). -32045)
5340: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a ))..(define (tm:
5350: 63 68 61 72 2d 70 6f 73 20 63 68 61 72 20 73 74 char-pos char st
5360: 72 20 69 6e 64 65 78 20 6c 65 6e 29 0a 20 20 28 r index len). (
5370: 63 6f 6e 64 0a 20 20 20 28 28 3e 3d 20 69 6e 64 cond. ((>= ind
5380: 65 78 20 6c 65 6e 29 20 23 66 29 0a 20 20 20 28 ex len) #f). (
5390: 28 63 68 61 72 3d 3f 20 28 73 74 72 69 6e 67 2d (char=? (string-
53a0: 72 65 66 20 73 74 72 20 69 6e 64 65 78 29 20 63 ref str index) c
53b0: 68 61 72 29 0a 20 20 20 20 69 6e 64 65 78 29 0a har). index).
53c0: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 74 6d (else. (tm
53d0: 3a 63 68 61 72 2d 70 6f 73 20 63 68 61 72 20 73 :char-pos char s
53e0: 74 72 20 28 2b 20 69 6e 64 65 78 20 31 29 20 6c tr (+ index 1) l
53f0: 65 6e 29 29 29 29 0a 20 20 0a 0a 28 64 65 66 69 en)))). ..(defi
5400: 6e 65 20 28 74 6d 3a 66 72 61 63 74 69 6f 6e 61 ne (tm:fractiona
5410: 6c 2d 70 61 72 74 20 72 29 0a 20 20 28 69 66 20 l-part r). (if
5420: 28 69 6e 74 65 67 65 72 3f 20 72 29 20 22 30 22 (integer? r) "0"
5430: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 . (let ((st
5440: 72 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e r (number->strin
5450: 67 20 28 65 78 61 63 74 2d 3e 69 6e 65 78 61 63 g (exact->inexac
5460: 74 20 72 29 29 29 29 0a 09 28 6c 65 74 20 28 28 t r))))..(let ((
5470: 70 70 6f 73 20 28 74 6d 3a 63 68 61 72 2d 70 6f ppos (tm:char-po
5480: 73 20 23 5c 2e 20 73 74 72 20 30 20 28 73 74 72 s #\. str 0 (str
5490: 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 29 29 ing-length str))
54a0: 29 29 0a 09 20 20 28 73 75 62 73 74 72 69 6e 67 )).. (substring
54b0: 20 73 74 72 20 20 28 2b 20 70 70 6f 73 20 31 29 str (+ ppos 1)
54c0: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
54d0: 73 74 72 29 29 29 29 29 29 0a 0a 0a 3b 3b 20 67 str))))))...;; g
54e0: 69 76 65 73 20 74 68 65 20 73 65 63 6f 6e 64 73 ives the seconds
54f0: 2f 64 61 74 65 2f 6d 6f 6e 74 68 2f 79 65 61 72 /date/month/year
5500: 20 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 64 65 .(define (tm:de
5510: 63 6f 64 65 2d 6a 75 6c 69 61 6e 2d 64 61 79 2d code-julian-day-
5520: 6e 75 6d 62 65 72 20 6a 64 6e 29 0a 20 20 28 6c number jdn). (l
5530: 65 74 2a 20 28 28 64 61 79 73 20 28 74 72 75 6e et* ((days (trun
5540: 63 61 74 65 20 6a 64 6e 29 29 0a 09 20 28 61 20 cate jdn)).. (a
5550: 28 2b 20 64 61 79 73 20 33 32 30 34 34 29 29 0a (+ days 32044)).
5560: 09 20 28 62 20 28 71 75 6f 74 69 65 6e 74 20 28 . (b (quotient (
5570: 2b 20 28 2a 20 34 20 61 29 20 33 29 20 31 34 36 + (* 4 a) 3) 146
5580: 30 39 37 29 29 0a 09 20 28 63 20 28 2d 20 61 20 097)).. (c (- a
5590: 28 71 75 6f 74 69 65 6e 74 20 28 2a 20 31 34 36 (quotient (* 146
55a0: 30 39 37 20 62 29 20 34 29 29 29 0a 09 20 28 64 097 b) 4))).. (d
55b0: 20 28 71 75 6f 74 69 65 6e 74 20 28 2b 20 28 2a (quotient (+ (*
55c0: 20 34 20 63 29 20 33 29 20 31 34 36 31 29 29 0a 4 c) 3) 1461)).
55d0: 09 20 28 65 20 28 2d 20 63 20 28 71 75 6f 74 69 . (e (- c (quoti
55e0: 65 6e 74 20 28 2a 20 31 34 36 31 20 64 29 20 34 ent (* 1461 d) 4
55f0: 29 29 29 0a 09 20 28 6d 20 28 71 75 6f 74 69 65 ))).. (m (quotie
5600: 6e 74 20 28 2b 20 28 2a 20 35 20 65 29 20 32 29 nt (+ (* 5 e) 2)
5610: 20 31 35 33 29 29 0a 09 20 28 79 20 28 2b 20 28 153)).. (y (+ (
5620: 2a 20 31 30 30 20 62 29 20 64 20 2d 34 38 30 30 * 100 b) d -4800
5630: 20 28 71 75 6f 74 69 65 6e 74 20 6d 20 31 30 29 (quotient m 10)
5640: 29 29 29 0a 20 20 20 20 28 76 61 6c 75 65 73 20 ))). (values
5650: 3b 20 73 65 63 6f 6e 64 73 20 64 61 74 65 20 6d ; seconds date m
5660: 6f 6e 74 68 20 79 65 61 72 0a 20 20 20 20 20 28 onth year. (
5670: 2a 20 28 2d 20 6a 64 6e 20 64 61 79 73 29 20 74 * (- jdn days) t
5680: 6d 3a 73 69 64 29 0a 20 20 20 20 20 28 2b 20 65 m:sid). (+ e
5690: 20 28 2d 20 28 71 75 6f 74 69 65 6e 74 20 28 2b (- (quotient (+
56a0: 20 28 2a 20 31 35 33 20 6d 29 20 32 29 20 35 29 (* 153 m) 2) 5)
56b0: 29 20 31 29 0a 20 20 20 20 20 28 2b 20 6d 20 33 ) 1). (+ m 3
56c0: 20 28 2a 20 2d 31 32 20 28 71 75 6f 74 69 65 6e (* -12 (quotien
56d0: 74 20 6d 20 31 30 29 29 29 0a 20 20 20 20 20 28 t m 10))). (
56e0: 69 66 20 28 3e 3d 20 30 20 79 29 20 28 2d 20 79 if (>= 0 y) (- y
56f0: 20 31 29 20 79 29 29 0a 20 20 20 20 29 29 0a 0a 1) y)). ))..
5700: 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 .(define (tm:loc
5710: 61 6c 2d 74 7a 2d 6f 66 66 73 65 74 29 0a 20 20 al-tz-offset).
5720: 28 68 6f 73 74 3a 74 69 6d 65 2d 67 6d 74 2d 6f (host:time-gmt-o
5730: 66 66 73 65 74 20 28 68 6f 73 74 3a 63 75 72 72 ffset (host:curr
5740: 65 6e 74 2d 74 69 6d 65 29 29 29 0a 0a 3b 3b 20 ent-time)))..;;
5750: 73 70 65 63 69 61 6c 20 74 68 69 6e 67 20 2d 2d special thing --
5760: 20 69 67 6e 6f 72 65 73 20 6e 61 6e 6f 73 0a 28 ignores nanos.(
5770: 64 65 66 69 6e 65 20 28 74 6d 3a 74 69 6d 65 2d define (tm:time-
5780: 3e 6a 75 6c 69 61 6e 2d 64 61 79 2d 6e 75 6d 62 >julian-day-numb
5790: 65 72 20 73 65 63 6f 6e 64 73 20 74 7a 2d 6f 66 er seconds tz-of
57a0: 66 73 65 74 29 0a 20 20 28 2b 20 28 2f 20 28 2b fset). (+ (/ (+
57b0: 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 74 7a 2d seconds.. tz-
57c0: 6f 66 66 73 65 74 0a 09 20 20 20 74 6d 3a 73 69 offset.. tm:si
57d0: 68 64 29 0a 09 74 6d 3a 73 69 64 29 0a 20 20 20 hd)..tm:sid).
57e0: 20 20 74 6d 3a 74 61 69 2d 65 70 6f 63 68 2d 69 tm:tai-epoch-i
57f0: 6e 2d 6a 64 29 29 0a 0a 28 64 65 66 69 6e 65 20 n-jd))..(define
5800: 28 74 6d 3a 66 69 6e 64 20 70 72 6f 63 20 6c 29 (tm:find proc l)
5810: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 29 . (if (null? l)
5820: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
5830: 28 69 66 20 28 70 72 6f 63 20 28 63 61 72 20 6c (if (proc (car l
5840: 29 29 0a 09 20 20 23 74 0a 09 20 20 28 74 6d 3a )).. #t.. (tm:
5850: 66 69 6e 64 20 70 72 6f 63 20 28 63 64 72 20 6c find proc (cdr l
5860: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
5870: 74 6d 3a 74 61 69 2d 62 65 66 6f 72 65 2d 6c 65 tm:tai-before-le
5880: 61 70 2d 73 65 63 6f 6e 64 3f 20 73 65 63 6f 6e ap-second? secon
5890: 64 29 0a 20 20 28 74 6d 3a 66 69 6e 64 20 28 6c d). (tm:find (l
58a0: 61 6d 62 64 61 20 28 78 29 0a 09 20 20 20 20 20 ambda (x)..
58b0: 28 3d 20 73 65 63 6f 6e 64 20 28 2d 20 28 2b 20 (= second (- (+
58c0: 28 63 61 72 20 78 29 20 28 63 64 72 20 78 29 29 (car x) (cdr x))
58d0: 20 31 29 29 29 0a 09 20 20 20 74 6d 3a 6c 65 61 1))).. tm:lea
58e0: 70 2d 73 65 63 6f 6e 64 2d 74 61 62 6c 65 29 29 p-second-table))
58f0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 74 69 ..(define (tm:ti
5900: 6d 65 2d 3e 64 61 74 65 20 74 69 6d 65 20 74 7a me->date time tz
5910: 2d 6f 66 66 73 65 74 20 74 74 79 70 65 29 0a 20 -offset ttype).
5920: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
5930: 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 29 20 time-type time)
5940: 74 74 79 70 65 29 29 0a 20 20 20 20 20 20 28 74 ttype)). (t
5950: 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 74 69 m:time-error 'ti
5960: 6d 65 2d 3e 64 61 74 65 20 27 69 6e 63 6f 6d 70 me->date 'incomp
5970: 61 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 65 atible-time-type
5980: 73 20 20 74 69 6d 65 29 29 0a 20 20 28 6c 65 74 s time)). (let
5990: 2a 20 28 20 28 6f 66 66 73 65 74 20 28 3a 6f 70 * ( (offset (:op
59a0: 74 69 6f 6e 61 6c 20 74 7a 2d 6f 66 66 73 65 74 tional tz-offset
59b0: 20 28 74 6d 3a 6c 6f 63 61 6c 2d 74 7a 2d 6f 66 (tm:local-tz-of
59c0: 66 73 65 74 29 29 29 20 29 0a 20 20 20 20 28 72 fset))) ). (r
59d0: 65 63 65 69 76 65 20 28 73 65 63 73 20 64 61 74 eceive (secs dat
59e0: 65 20 6d 6f 6e 74 68 20 79 65 61 72 29 0a 09 20 e month year)..
59f0: 20 20 20 20 28 74 6d 3a 64 65 63 6f 64 65 2d 6a (tm:decode-j
5a00: 75 6c 69 61 6e 2d 64 61 79 2d 6e 75 6d 62 65 72 ulian-day-number
5a10: 0a 09 20 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 .. (tm:time
5a20: 2d 3e 6a 75 6c 69 61 6e 2d 64 61 79 2d 6e 75 6d ->julian-day-num
5a30: 62 65 72 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 ber (time-second
5a40: 20 74 69 6d 65 29 20 6f 66 66 73 65 74 29 29 0a time) offset)).
5a50: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 20 28 68 . (let* ( (h
5a60: 6f 75 72 73 20 20 20 20 28 71 75 6f 74 69 65 6e ours (quotien
5a70: 74 20 73 65 63 73 20 28 2a 20 36 30 20 36 30 29 t secs (* 60 60)
5a80: 29 29 0a 09 09 20 20 20 20 20 28 72 65 6d 20 20 ))... (rem
5a90: 20 20 20 20 28 72 65 6d 61 69 6e 64 65 72 20 73 (remainder s
5aa0: 65 63 73 20 28 2a 20 36 30 20 36 30 29 29 29 0a ecs (* 60 60))).
5ab0: 09 09 20 20 20 20 20 28 6d 69 6e 75 74 65 73 20 .. (minutes
5ac0: 20 28 71 75 6f 74 69 65 6e 74 20 72 65 6d 20 36 (quotient rem 6
5ad0: 30 29 29 0a 09 09 20 20 20 20 20 28 73 65 63 6f 0))... (seco
5ae0: 6e 64 73 20 20 28 72 65 6d 61 69 6e 64 65 72 20 nds (remainder
5af0: 72 65 6d 20 36 30 29 29 20 29 0a 09 20 20 20 20 rem 60)) )..
5b00: 20 20 20 28 6d 61 6b 65 2d 64 61 74 65 20 28 74 (make-date (t
5b10: 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 74 ime-nanosecond t
5b20: 69 6d 65 29 0a 09 09 09 20 20 73 65 63 6f 6e 64 ime).... second
5b30: 73 0a 09 09 09 20 20 6d 69 6e 75 74 65 73 0a 09 s.... minutes..
5b40: 09 09 20 20 68 6f 75 72 73 0a 09 09 09 20 20 64 .. hours.... d
5b50: 61 74 65 0a 09 09 09 20 20 6d 6f 6e 74 68 0a 09 ate.... month..
5b60: 09 09 20 20 79 65 61 72 0a 09 09 09 20 20 6f 66 .. year.... of
5b70: 66 73 65 74 29 29 29 29 29 0a 0a 28 64 65 66 69 fset)))))..(defi
5b80: 6e 65 20 28 74 69 6d 65 2d 74 61 69 2d 3e 64 61 ne (time-tai->da
5b90: 74 65 20 74 69 6d 65 20 2e 20 74 7a 2d 6f 66 66 te time . tz-off
5ba0: 73 65 74 29 0a 20 20 28 69 66 20 28 74 6d 3a 74 set). (if (tm:t
5bb0: 61 69 2d 62 65 66 6f 72 65 2d 6c 65 61 70 2d 73 ai-before-leap-s
5bc0: 65 63 6f 6e 64 3f 20 28 74 69 6d 65 2d 73 65 63 econd? (time-sec
5bd0: 6f 6e 64 20 74 69 6d 65 29 29 0a 20 20 20 20 20 ond time)).
5be0: 20 3b 3b 20 69 66 20 69 74 27 73 20 2a 72 69 67 ;; if it's *rig
5bf0: 68 74 2a 20 62 65 66 6f 72 65 20 74 68 65 20 6c ht* before the l
5c00: 65 61 70 2c 20 77 65 20 6e 65 65 64 20 74 6f 20 eap, we need to
5c10: 70 72 65 74 65 6e 64 20 74 6f 20 73 75 62 74 72 pretend to subtr
5c20: 61 63 74 20 61 20 73 65 63 6f 6e 64 20 2e 2e 2e act a second ...
5c30: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 20 . (let ((d
5c40: 28 74 6d 3a 74 69 6d 65 2d 3e 64 61 74 65 20 28 (tm:time->date (
5c50: 73 75 62 74 72 61 63 74 2d 64 75 72 61 74 69 6f subtract-duratio
5c60: 6e 21 20 28 74 69 6d 65 2d 74 61 69 2d 3e 74 69 n! (time-tai->ti
5c70: 6d 65 2d 75 74 63 20 74 69 6d 65 29 20 28 6d 61 me-utc time) (ma
5c80: 6b 65 2d 74 69 6d 65 20 74 69 6d 65 2d 64 75 72 ke-time time-dur
5c90: 61 74 69 6f 6e 20 30 20 31 29 29 20 74 7a 2d 6f ation 0 1)) tz-o
5ca0: 66 66 73 65 74 20 74 69 6d 65 2d 75 74 63 29 29 ffset time-utc))
5cb0: 29 0a 09 28 74 6d 3a 73 65 74 2d 64 61 74 65 2d )..(tm:set-date-
5cc0: 73 65 63 6f 6e 64 21 20 64 20 36 30 29 0a 09 64 second! d 60)..d
5cd0: 29 0a 20 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 ). (tm:time
5ce0: 2d 3e 64 61 74 65 20 28 74 69 6d 65 2d 74 61 69 ->date (time-tai
5cf0: 2d 3e 74 69 6d 65 2d 75 74 63 20 74 69 6d 65 29 ->time-utc time)
5d00: 20 74 7a 2d 6f 66 66 73 65 74 20 74 69 6d 65 2d tz-offset time-
5d10: 75 74 63 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 utc)))..(define
5d20: 28 74 69 6d 65 2d 75 74 63 2d 3e 64 61 74 65 20 (time-utc->date
5d30: 74 69 6d 65 20 2e 20 74 7a 2d 6f 66 66 73 65 74 time . tz-offset
5d40: 29 0a 20 20 28 74 6d 3a 74 69 6d 65 2d 3e 64 61 ). (tm:time->da
5d50: 74 65 20 74 69 6d 65 20 74 7a 2d 6f 66 66 73 65 te time tz-offse
5d60: 74 20 74 69 6d 65 2d 75 74 63 29 29 0a 0a 3b 3b t time-utc))..;;
5d70: 20 61 67 61 69 6e 2c 20 74 69 6d 65 2d 6d 6f 6e again, time-mon
5d80: 6f 74 6f 6e 69 63 20 69 73 20 74 68 65 20 73 61 otonic is the sa
5d90: 6d 65 20 61 73 20 74 69 6d 65 20 74 61 69 0a 28 me as time tai.(
5da0: 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 6d 6f 6e define (time-mon
5db0: 6f 74 6f 6e 69 63 2d 3e 64 61 74 65 20 74 69 6d otonic->date tim
5dc0: 65 20 2e 20 74 7a 2d 6f 66 66 73 65 74 29 0a 20 e . tz-offset).
5dd0: 20 28 74 6d 3a 74 69 6d 65 2d 3e 64 61 74 65 20 (tm:time->date
5de0: 74 69 6d 65 20 74 7a 2d 6f 66 66 73 65 74 20 74 time tz-offset t
5df0: 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 29 29 0a ime-monotonic)).
5e00: 0a 28 64 65 66 69 6e 65 20 28 64 61 74 65 2d 3e .(define (date->
5e10: 74 69 6d 65 2d 75 74 63 20 64 61 74 65 29 0a 20 time-utc date).
5e20: 20 28 6c 65 74 20 28 20 28 6e 61 6e 6f 73 65 63 (let ( (nanosec
5e30: 6f 6e 64 20 28 64 61 74 65 2d 6e 61 6e 6f 73 65 ond (date-nanose
5e40: 63 6f 6e 64 20 64 61 74 65 29 29 0a 09 20 28 73 cond date)).. (s
5e50: 65 63 6f 6e 64 20 28 64 61 74 65 2d 73 65 63 6f econd (date-seco
5e60: 6e 64 20 64 61 74 65 29 29 0a 09 20 28 6d 69 6e nd date)).. (min
5e70: 75 74 65 20 28 64 61 74 65 2d 6d 69 6e 75 74 65 ute (date-minute
5e80: 20 64 61 74 65 29 29 0a 09 20 28 68 6f 75 72 20 date)).. (hour
5e90: 28 64 61 74 65 2d 68 6f 75 72 20 64 61 74 65 29 (date-hour date)
5ea0: 29 0a 09 20 28 64 61 79 20 28 64 61 74 65 2d 64 ).. (day (date-d
5eb0: 61 79 20 64 61 74 65 29 29 0a 09 20 28 6d 6f 6e ay date)).. (mon
5ec0: 74 68 20 28 64 61 74 65 2d 6d 6f 6e 74 68 20 64 th (date-month d
5ed0: 61 74 65 29 29 0a 09 20 28 79 65 61 72 20 28 64 ate)).. (year (d
5ee0: 61 74 65 2d 79 65 61 72 20 64 61 74 65 29 29 0a ate-year date)).
5ef0: 09 20 28 6f 66 66 73 65 74 20 28 64 61 74 65 2d . (offset (date-
5f00: 7a 6f 6e 65 2d 6f 66 66 73 65 74 20 64 61 74 65 zone-offset date
5f10: 29 29 20 29 0a 20 20 20 20 28 6c 65 74 20 28 20 )) ). (let (
5f20: 28 6a 64 61 79 73 20 28 2d 20 28 74 6d 3a 65 6e (jdays (- (tm:en
5f30: 63 6f 64 65 2d 6a 75 6c 69 61 6e 2d 64 61 79 2d code-julian-day-
5f40: 6e 75 6d 62 65 72 20 64 61 79 20 6d 6f 6e 74 68 number day month
5f50: 20 79 65 61 72 29 0a 09 09 20 20 20 20 20 74 6d year)... tm
5f60: 3a 74 61 69 2d 65 70 6f 63 68 2d 69 6e 2d 6a 64 :tai-epoch-in-jd
5f70: 29 29 20 29 0a 20 20 20 20 20 20 28 6d 61 6b 65 )) ). (make
5f80: 2d 74 69 6d 65 20 0a 20 20 20 20 20 20 20 74 69 -time . ti
5f90: 6d 65 2d 75 74 63 0a 20 20 20 20 20 20 20 6e 61 me-utc. na
5fa0: 6e 6f 73 65 63 6f 6e 64 0a 20 20 20 20 20 20 20 nosecond.
5fb0: 28 2b 20 28 2a 20 28 2d 20 6a 64 61 79 73 20 31 (+ (* (- jdays 1
5fc0: 2f 32 29 20 32 34 20 36 30 20 36 30 29 0a 09 20 /2) 24 60 60)..
5fd0: 20 28 2a 20 68 6f 75 72 20 36 30 20 36 30 29 0a (* hour 60 60).
5fe0: 09 20 20 28 2a 20 6d 69 6e 75 74 65 20 36 30 29 . (* minute 60)
5ff0: 0a 09 20 20 73 65 63 6f 6e 64 0a 09 20 20 28 2d .. second.. (-
6000: 20 6f 66 66 73 65 74 29 29 0a 20 20 20 20 20 20 offset)).
6010: 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ))))..(define (
6020: 64 61 74 65 2d 3e 74 69 6d 65 2d 74 61 69 20 64 date->time-tai d
6030: 29 0a 20 20 28 69 66 20 28 3d 20 28 64 61 74 65 ). (if (= (date
6040: 2d 73 65 63 6f 6e 64 20 64 29 20 36 30 29 0a 20 -second d) 60).
6050: 20 20 20 20 20 28 73 75 62 74 72 61 63 74 2d 64 (subtract-d
6060: 75 72 61 74 69 6f 6e 21 20 28 74 69 6d 65 2d 75 uration! (time-u
6070: 74 63 2d 3e 74 69 6d 65 2d 74 61 69 21 20 28 64 tc->time-tai! (d
6080: 61 74 65 2d 3e 74 69 6d 65 2d 75 74 63 20 64 29 ate->time-utc d)
6090: 29 20 28 6d 61 6b 65 2d 74 69 6d 65 20 74 69 6d ) (make-time tim
60a0: 65 2d 64 75 72 61 74 69 6f 6e 20 30 20 31 29 29 e-duration 0 1))
60b0: 0a 20 20 20 20 20 20 28 74 69 6d 65 2d 75 74 63 . (time-utc
60c0: 2d 3e 74 69 6d 65 2d 74 61 69 21 20 28 64 61 74 ->time-tai! (dat
60d0: 65 2d 3e 74 69 6d 65 2d 75 74 63 20 64 29 29 29 e->time-utc d)))
60e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 65 )..(define (date
60f0: 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 ->time-monotonic
6100: 20 64 61 74 65 29 0a 20 20 28 74 69 6d 65 2d 75 date). (time-u
6110: 74 63 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e tc->time-monoton
6120: 69 63 21 20 28 64 61 74 65 2d 3e 74 69 6d 65 2d ic! (date->time-
6130: 75 74 63 20 64 61 74 65 29 29 29 0a 0a 0a 28 64 utc date)))...(d
6140: 65 66 69 6e 65 20 28 74 6d 3a 6c 65 61 70 2d 79 efine (tm:leap-y
6150: 65 61 72 3f 20 79 65 61 72 29 0a 20 20 28 6f 72 ear? year). (or
6160: 20 28 3d 20 28 6d 6f 64 75 6c 6f 20 79 65 61 72 (= (modulo year
6170: 20 34 30 30 29 20 30 29 0a 20 20 20 20 20 20 28 400) 0). (
6180: 61 6e 64 20 28 3d 20 28 6d 6f 64 75 6c 6f 20 79 and (= (modulo y
6190: 65 61 72 20 34 29 20 30 29 20 28 6e 6f 74 20 28 ear 4) 0) (not (
61a0: 3d 20 28 6d 6f 64 75 6c 6f 20 79 65 61 72 20 31 = (modulo year 1
61b0: 30 30 29 20 30 29 29 29 29 29 0a 0a 28 64 65 66 00) 0)))))..(def
61c0: 69 6e 65 20 28 6c 65 61 70 2d 79 65 61 72 3f 20 ine (leap-year?
61d0: 64 61 74 65 29 0a 20 20 28 74 6d 3a 6c 65 61 70 date). (tm:leap
61e0: 2d 79 65 61 72 3f 20 28 64 61 74 65 2d 79 65 61 -year? (date-yea
61f0: 72 20 64 61 74 65 29 29 29 0a 0a 3b 3b 20 74 6d r date)))..;; tm
6200: 3a 79 65 61 72 2d 64 61 79 20 66 69 78 65 64 3a :year-day fixed:
6210: 20 61 64 64 69 6e 67 20 77 72 6f 6e 67 20 6e 75 adding wrong nu
6220: 6d 62 65 72 20 6f 66 20 64 61 79 73 2e 0a 28 64 mber of days..(d
6230: 65 66 69 6e 65 20 20 74 6d 3a 6d 6f 6e 74 68 2d efine tm:month-
6240: 61 73 73 6f 63 20 27 28 28 30 20 2e 20 30 29 20 assoc '((0 . 0)
6250: 28 31 20 2e 20 33 31 29 20 20 28 32 20 2e 20 35 (1 . 31) (2 . 5
6260: 39 29 20 20 20 28 33 20 2e 20 39 30 29 20 20 20 9) (3 . 90)
6270: 28 34 20 2e 20 31 32 30 29 20 0a 09 09 09 20 20 (4 . 120) ....
6280: 28 35 20 2e 20 31 35 31 29 20 28 36 20 2e 20 31 (5 . 151) (6 . 1
6290: 38 31 29 20 20 28 37 20 2e 20 32 31 32 29 20 20 81) (7 . 212)
62a0: 28 38 20 2e 20 32 34 33 29 0a 09 09 09 20 20 28 (8 . 243).... (
62b0: 39 20 2e 20 32 37 33 29 20 28 31 30 20 2e 20 33 9 . 273) (10 . 3
62c0: 30 34 29 20 28 31 31 20 2e 20 33 33 34 29 29 29 04) (11 . 334)))
62d0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 79 65 ..(define (tm:ye
62e0: 61 72 2d 64 61 79 20 64 61 79 20 6d 6f 6e 74 68 ar-day day month
62f0: 20 79 65 61 72 29 0a 20 20 28 6c 65 74 20 28 28 year). (let ((
6300: 64 61 79 73 2d 70 72 20 28 61 73 73 6f 63 20 28 days-pr (assoc (
6310: 2d 20 6d 6f 6e 74 68 20 31 29 20 74 6d 3a 6d 6f - month 1) tm:mo
6320: 6e 74 68 2d 61 73 73 6f 63 29 29 29 0a 20 20 20 nth-assoc))).
6330: 20 28 69 66 20 28 6e 6f 74 20 64 61 79 73 2d 70 (if (not days-p
6340: 72 29 0a 09 28 74 6d 3a 74 69 6d 65 2d 65 72 72 r)..(tm:time-err
6350: 6f 72 20 27 64 61 74 65 2d 79 65 61 72 2d 64 61 or 'date-year-da
6360: 79 20 27 69 6e 76 61 6c 69 64 2d 6d 6f 6e 74 68 y 'invalid-month
6370: 2d 73 70 65 63 69 66 69 63 61 74 69 6f 6e 20 6d -specification m
6380: 6f 6e 74 68 29 29 0a 20 20 20 20 28 69 66 20 28 onth)). (if (
6390: 61 6e 64 20 28 74 6d 3a 6c 65 61 70 2d 79 65 61 and (tm:leap-yea
63a0: 72 3f 20 79 65 61 72 29 20 28 3e 20 6d 6f 6e 74 r? year) (> mont
63b0: 68 20 32 29 29 0a 09 28 2b 20 64 61 79 20 28 63 h 2))..(+ day (c
63c0: 64 72 20 64 61 79 73 2d 70 72 29 20 31 29 0a 09 dr days-pr) 1)..
63d0: 28 2b 20 64 61 79 20 28 63 64 72 20 64 61 79 73 (+ day (cdr days
63e0: 2d 70 72 29 29 29 29 29 0a 0a 28 64 65 66 69 6e -pr)))))..(defin
63f0: 65 20 28 64 61 74 65 2d 79 65 61 72 2d 64 61 79 e (date-year-day
6400: 20 64 61 74 65 29 0a 20 20 28 74 6d 3a 79 65 61 date). (tm:yea
6410: 72 2d 64 61 79 20 28 64 61 74 65 2d 64 61 79 20 r-day (date-day
6420: 64 61 74 65 29 20 28 64 61 74 65 2d 6d 6f 6e 74 date) (date-mont
6430: 68 20 64 61 74 65 29 20 28 64 61 74 65 2d 79 65 h date) (date-ye
6440: 61 72 20 64 61 74 65 29 29 29 0a 0a 3b 3b 20 66 ar date)))..;; f
6450: 72 6f 6d 20 63 61 6c 65 6e 64 61 72 20 66 61 71 rom calendar faq
6460: 20 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 77 65 .(define (tm:we
6470: 65 6b 2d 64 61 79 20 64 61 79 20 6d 6f 6e 74 68 ek-day day month
6480: 20 79 65 61 72 29 0a 20 20 28 6c 65 74 2a 20 28 year). (let* (
6490: 28 61 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 (a (quotient (-
64a0: 31 34 20 6d 6f 6e 74 68 29 20 31 32 29 29 0a 09 14 month) 12))..
64b0: 20 28 79 20 28 2d 20 79 65 61 72 20 61 29 29 0a (y (- year a)).
64c0: 09 20 28 6d 20 28 2b 20 6d 6f 6e 74 68 20 28 2a . (m (+ month (*
64d0: 20 31 32 20 61 29 20 2d 32 29 29 29 0a 20 20 20 12 a) -2))).
64e0: 20 28 6d 6f 64 75 6c 6f 20 28 2b 20 64 61 79 20 (modulo (+ day
64f0: 79 20 28 71 75 6f 74 69 65 6e 74 20 79 20 34 29 y (quotient y 4)
6500: 20 28 2d 20 28 71 75 6f 74 69 65 6e 74 20 79 20 (- (quotient y
6510: 31 30 30 29 29 0a 09 20 20 20 20 20 20 20 28 71 100)).. (q
6520: 75 6f 74 69 65 6e 74 20 79 20 34 30 30 29 20 28 uotient y 400) (
6530: 71 75 6f 74 69 65 6e 74 20 28 2a 20 33 31 20 6d quotient (* 31 m
6540: 29 20 31 32 29 29 0a 09 20 20 20 20 37 29 29 29 ) 12)).. 7)))
6550: 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 65 2d ..(define (date-
6560: 77 65 65 6b 2d 64 61 79 20 64 61 74 65 29 0a 20 week-day date).
6570: 20 28 74 6d 3a 77 65 65 6b 2d 64 61 79 20 28 64 (tm:week-day (d
6580: 61 74 65 2d 64 61 79 20 64 61 74 65 29 20 28 64 ate-day date) (d
6590: 61 74 65 2d 6d 6f 6e 74 68 20 64 61 74 65 29 20 ate-month date)
65a0: 28 64 61 74 65 2d 79 65 61 72 20 64 61 74 65 29 (date-year date)
65b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a ))..(define (tm:
65c0: 64 61 79 73 2d 62 65 66 6f 72 65 2d 66 69 72 73 days-before-firs
65d0: 74 2d 77 65 65 6b 20 64 61 74 65 20 64 61 79 2d t-week date day-
65e0: 6f 66 2d 77 65 65 6b 2d 73 74 61 72 74 69 6e 67 of-week-starting
65f0: 2d 77 65 65 6b 29 0a 20 20 28 6c 65 74 2a 20 28 -week). (let* (
6600: 20 28 66 69 72 73 74 2d 64 61 79 20 28 6d 61 6b (first-day (mak
6610: 65 2d 64 61 74 65 20 30 20 30 20 30 20 30 0a 20 e-date 0 0 0 0.
6620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 31 1
6640: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6660: 20 31 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1.
6670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6680: 20 20 20 28 64 61 74 65 2d 79 65 61 72 20 64 61 (date-year da
6690: 74 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 te).
66a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66b0: 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 #f)).
66c0: 20 20 20 28 66 64 77 65 65 6b 2d 64 61 79 20 28 (fdweek-day (
66d0: 64 61 74 65 2d 77 65 65 6b 2d 64 61 79 20 66 69 date-week-day fi
66e0: 72 73 74 2d 64 61 79 29 29 20 20 29 0a 20 20 20 rst-day)) ).
66f0: 20 28 6d 6f 64 75 6c 6f 20 28 2d 20 64 61 79 2d (modulo (- day-
6700: 6f 66 2d 77 65 65 6b 2d 73 74 61 72 74 69 6e 67 of-week-starting
6710: 2d 77 65 65 6b 20 66 64 77 65 65 6b 2d 64 61 79 -week fdweek-day
6720: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 37 29 ). 7)
6730: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 ))..(define (dat
6740: 65 2d 77 65 65 6b 2d 6e 75 6d 62 65 72 20 64 61 e-week-number da
6750: 74 65 20 64 61 79 2d 6f 66 2d 77 65 65 6b 2d 73 te day-of-week-s
6760: 74 61 72 74 69 6e 67 2d 77 65 65 6b 29 0a 20 20 tarting-week).
6770: 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 28 64 61 (quotient (- (da
6780: 74 65 2d 79 65 61 72 2d 64 61 79 20 64 61 74 65 te-year-day date
6790: 29 0a 09 20 20 20 20 20 20 20 28 74 6d 3a 64 61 ).. (tm:da
67a0: 79 73 2d 62 65 66 6f 72 65 2d 66 69 72 73 74 2d ys-before-first-
67b0: 77 65 65 6b 20 20 64 61 74 65 20 64 61 79 2d 6f week date day-o
67c0: 66 2d 77 65 65 6b 2d 73 74 61 72 74 69 6e 67 2d f-week-starting-
67d0: 77 65 65 6b 29 29 0a 09 20 20 20 20 37 29 29 0a week)).. 7)).
67e0: 0a 28 64 65 66 69 6e 65 20 28 63 75 72 72 65 6e .(define (curren
67f0: 74 2d 64 61 74 65 20 2e 20 74 7a 2d 6f 66 66 73 t-date . tz-offs
6800: 65 74 29 20 0a 20 20 28 74 69 6d 65 2d 75 74 63 et) . (time-utc
6810: 2d 3e 64 61 74 65 20 28 63 75 72 72 65 6e 74 2d ->date (current-
6820: 74 69 6d 65 20 74 69 6d 65 2d 75 74 63 29 0a 09 time time-utc)..
6830: 09 20 20 28 3a 6f 70 74 69 6f 6e 61 6c 20 74 7a . (:optional tz
6840: 2d 6f 66 66 73 65 74 20 28 74 6d 3a 6c 6f 63 61 -offset (tm:loca
6850: 6c 2d 74 7a 2d 6f 66 66 73 65 74 29 29 29 29 0a l-tz-offset)))).
6860: 0a 3b 3b 20 67 69 76 65 6e 20 61 20 27 74 77 6f .;; given a 'two
6870: 20 64 69 67 69 74 27 20 6e 75 6d 62 65 72 2c 20 digit' number,
6880: 66 69 6e 64 20 74 68 65 20 79 65 61 72 20 77 69 find the year wi
6890: 74 68 69 6e 20 35 30 20 79 65 61 72 73 20 2b 2f thin 50 years +/
68a0: 2d 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 6e 61 -.(define (tm:na
68b0: 74 75 72 61 6c 2d 79 65 61 72 20 6e 29 0a 20 20 tural-year n).
68c0: 28 6c 65 74 2a 20 28 20 28 63 75 72 72 65 6e 74 (let* ( (current
68d0: 2d 79 65 61 72 20 28 64 61 74 65 2d 79 65 61 72 -year (date-year
68e0: 20 28 63 75 72 72 65 6e 74 2d 64 61 74 65 29 29 (current-date))
68f0: 29 0a 09 20 20 28 63 75 72 72 65 6e 74 2d 63 65 ).. (current-ce
6900: 6e 74 75 72 79 20 28 2a 20 28 71 75 6f 74 69 65 ntury (* (quotie
6910: 6e 74 20 63 75 72 72 65 6e 74 2d 79 65 61 72 20 nt current-year
6920: 31 30 30 29 20 31 30 30 29 29 20 29 0a 20 20 20 100) 100)) ).
6930: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 28 28 3e (cond. ((>
6940: 3d 20 6e 20 31 30 30 29 20 6e 29 0a 20 20 20 20 = n 100) n).
6950: 20 20 28 28 3c 20 20 6e 20 30 29 20 6e 29 0a 20 ((< n 0) n).
6960: 20 20 20 20 20 28 28 3c 3d 20 20 28 2d 20 28 2b ((<= (- (+
6970: 20 63 75 72 72 65 6e 74 2d 63 65 6e 74 75 72 79 current-century
6980: 20 6e 29 20 63 75 72 72 65 6e 74 2d 79 65 61 72 n) current-year
6990: 29 20 35 30 29 0a 20 20 20 20 20 20 20 28 2b 20 ) 50). (+
69a0: 63 75 72 72 65 6e 74 2d 63 65 6e 74 75 72 79 20 current-century
69b0: 6e 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a n)). (else.
69c0: 20 20 20 20 20 20 20 28 2b 20 28 2d 20 63 75 72 (+ (- cur
69d0: 72 65 6e 74 2d 63 65 6e 74 75 72 79 20 31 30 30 rent-century 100
69e0: 29 20 6e 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ) n)))))..(defin
69f0: 65 20 28 64 61 74 65 2d 3e 6a 75 6c 69 61 6e 2d e (date->julian-
6a00: 64 61 79 20 64 61 74 65 29 0a 20 20 28 6c 65 74 day date). (let
6a10: 20 28 20 28 6e 61 6e 6f 73 65 63 6f 6e 64 20 28 ( (nanosecond (
6a20: 64 61 74 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 date-nanosecond
6a30: 64 61 74 65 29 29 0a 09 20 28 73 65 63 6f 6e 64 date)).. (second
6a40: 20 28 64 61 74 65 2d 73 65 63 6f 6e 64 20 64 61 (date-second da
6a50: 74 65 29 29 0a 09 20 28 6d 69 6e 75 74 65 20 28 te)).. (minute (
6a60: 64 61 74 65 2d 6d 69 6e 75 74 65 20 64 61 74 65 date-minute date
6a70: 29 29 0a 09 20 28 68 6f 75 72 20 28 64 61 74 65 )).. (hour (date
6a80: 2d 68 6f 75 72 20 64 61 74 65 29 29 0a 09 20 28 -hour date)).. (
6a90: 64 61 79 20 28 64 61 74 65 2d 64 61 79 20 64 61 day (date-day da
6aa0: 74 65 29 29 0a 09 20 28 6d 6f 6e 74 68 20 28 64 te)).. (month (d
6ab0: 61 74 65 2d 6d 6f 6e 74 68 20 64 61 74 65 29 29 ate-month date))
6ac0: 0a 09 20 28 79 65 61 72 20 28 64 61 74 65 2d 79 .. (year (date-y
6ad0: 65 61 72 20 64 61 74 65 29 29 0a 09 20 28 6f 66 ear date)).. (of
6ae0: 66 73 65 74 20 28 64 61 74 65 2d 7a 6f 6e 65 2d fset (date-zone-
6af0: 6f 66 66 73 65 74 20 64 61 74 65 29 29 20 29 0a offset date)) ).
6b00: 20 20 20 20 28 2b 20 28 74 6d 3a 65 6e 63 6f 64 (+ (tm:encod
6b10: 65 2d 6a 75 6c 69 61 6e 2d 64 61 79 2d 6e 75 6d e-julian-day-num
6b20: 62 65 72 20 64 61 79 20 6d 6f 6e 74 68 20 79 65 ber day month ye
6b30: 61 72 29 0a 20 20 20 20 20 20 20 28 2d 20 31 2f ar). (- 1/
6b40: 32 29 0a 20 20 20 20 20 20 20 28 2b 20 28 2f 20 2). (+ (/
6b50: 28 2b 20 28 2a 20 68 6f 75 72 20 36 30 20 36 30 (+ (* hour 60 60
6b60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6b70: 20 20 28 2a 20 6d 69 6e 75 74 65 20 36 30 29 0a (* minute 60).
6b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b90: 73 65 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 second.
6ba0: 20 20 20 20 20 20 20 28 2f 20 6e 61 6e 6f 73 65 (/ nanose
6bb0: 63 6f 6e 64 20 74 6d 3a 6e 61 6e 6f 29 0a 20 20 cond tm:nano).
6bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 2d (-
6bd0: 20 6f 66 66 73 65 74 29 29 0a 20 20 20 20 20 20 offset)).
6be0: 20 20 20 20 20 20 20 74 6d 3a 73 69 64 29 29 29 tm:sid)))
6bf0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 61 74 ))..(define (dat
6c00: 65 2d 3e 6d 6f 64 69 66 69 65 64 2d 6a 75 6c 69 e->modified-juli
6c10: 61 6e 2d 64 61 79 20 64 61 74 65 29 0a 20 20 28 an-day date). (
6c20: 2d 20 28 64 61 74 65 2d 3e 6a 75 6c 69 61 6e 2d - (date->julian-
6c30: 64 61 79 20 64 61 74 65 29 0a 20 20 20 20 20 34 day date). 4
6c40: 38 30 30 30 30 31 2f 32 29 29 0a 0a 0a 28 64 65 800001/2))...(de
6c50: 66 69 6e 65 20 28 74 69 6d 65 2d 75 74 63 2d 3e fine (time-utc->
6c60: 6a 75 6c 69 61 6e 2d 64 61 79 20 74 69 6d 65 29 julian-day time)
6c70: 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f . (if (not (eq?
6c80: 20 28 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 (time-type time
6c90: 29 20 74 69 6d 65 2d 75 74 63 29 29 0a 20 20 20 ) time-utc)).
6ca0: 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f (tm:time-erro
6cb0: 72 20 27 74 69 6d 65 2d 75 74 63 2d 3e 6a 75 6c r 'time-utc->jul
6cc0: 69 61 6e 2d 64 61 79 20 27 69 6e 63 6f 6d 70 61 ian-day 'incompa
6cd0: 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 65 73 tible-time-types
6ce0: 20 20 74 69 6d 65 29 29 0a 20 20 28 2b 20 28 2f time)). (+ (/
6cf0: 20 28 2b 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 (+ (time-second
6d00: 20 74 69 6d 65 29 20 28 2f 20 28 74 69 6d 65 2d time) (/ (time-
6d10: 6e 61 6e 6f 73 65 63 6f 6e 64 20 74 69 6d 65 29 nanosecond time)
6d20: 20 74 6d 3a 6e 61 6e 6f 29 29 0a 09 74 6d 3a 73 tm:nano))..tm:s
6d30: 69 64 29 0a 20 20 20 20 20 74 6d 3a 74 61 69 2d id). tm:tai-
6d40: 65 70 6f 63 68 2d 69 6e 2d 6a 64 29 29 0a 0a 28 epoch-in-jd))..(
6d50: 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 75 74 63 define (time-utc
6d60: 2d 3e 6d 6f 64 69 66 69 65 64 2d 6a 75 6c 69 61 ->modified-julia
6d70: 6e 2d 64 61 79 20 74 69 6d 65 29 0a 20 20 28 2d n-day time). (-
6d80: 20 28 74 69 6d 65 2d 75 74 63 2d 3e 6a 75 6c 69 (time-utc->juli
6d90: 61 6e 2d 64 61 79 20 74 69 6d 65 29 0a 20 20 20 an-day time).
6da0: 20 20 34 38 30 30 30 30 31 2f 32 29 29 0a 0a 28 4800001/2))..(
6db0: 64 65 66 69 6e 65 20 28 74 69 6d 65 2d 74 61 69 define (time-tai
6dc0: 2d 3e 6a 75 6c 69 61 6e 2d 64 61 79 20 74 69 6d ->julian-day tim
6dd0: 65 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 65 e). (if (not (e
6de0: 71 3f 20 28 74 69 6d 65 2d 74 79 70 65 20 74 69 q? (time-type ti
6df0: 6d 65 29 20 74 69 6d 65 2d 74 61 69 29 29 0a 20 me) time-tai)).
6e00: 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 (tm:time-er
6e10: 72 6f 72 20 27 74 69 6d 65 2d 74 61 69 2d 3e 6a ror 'time-tai->j
6e20: 75 6c 69 61 6e 2d 64 61 79 20 27 69 6e 63 6f 6d ulian-day 'incom
6e30: 70 61 74 69 62 6c 65 2d 74 69 6d 65 2d 74 79 70 patible-time-typ
6e40: 65 73 20 20 74 69 6d 65 29 29 0a 20 20 28 2b 20 es time)). (+
6e50: 28 2f 20 28 2b 20 28 2d 20 28 74 69 6d 65 2d 73 (/ (+ (- (time-s
6e60: 65 63 6f 6e 64 20 74 69 6d 65 29 20 0a 09 20 20 econd time) ..
6e70: 20 20 20 20 28 74 6d 3a 6c 65 61 70 2d 73 65 63 (tm:leap-sec
6e80: 6f 6e 64 2d 64 65 6c 74 61 20 28 74 69 6d 65 2d ond-delta (time-
6e90: 73 65 63 6f 6e 64 20 74 69 6d 65 29 29 29 0a 09 second time)))..
6ea0: 20 20 20 28 2f 20 28 74 69 6d 65 2d 6e 61 6e 6f (/ (time-nano
6eb0: 73 65 63 6f 6e 64 20 74 69 6d 65 29 20 74 6d 3a second time) tm:
6ec0: 6e 61 6e 6f 29 29 0a 09 74 6d 3a 73 69 64 29 0a nano))..tm:sid).
6ed0: 20 20 20 20 20 74 6d 3a 74 61 69 2d 65 70 6f 63 tm:tai-epoc
6ee0: 68 2d 69 6e 2d 6a 64 29 29 0a 0a 28 64 65 66 69 h-in-jd))..(defi
6ef0: 6e 65 20 28 74 69 6d 65 2d 74 61 69 2d 3e 6d 6f ne (time-tai->mo
6f00: 64 69 66 69 65 64 2d 6a 75 6c 69 61 6e 2d 64 61 dified-julian-da
6f10: 79 20 74 69 6d 65 29 0a 20 20 28 2d 20 28 74 69 y time). (- (ti
6f20: 6d 65 2d 74 61 69 2d 3e 6a 75 6c 69 61 6e 2d 64 me-tai->julian-d
6f30: 61 79 20 74 69 6d 65 29 0a 20 20 20 20 20 34 38 ay time). 48
6f40: 30 30 30 30 31 2f 32 29 29 0a 0a 3b 3b 20 74 68 00001/2))..;; th
6f50: 69 73 20 69 73 20 74 68 65 20 73 61 6d 65 20 61 is is the same a
6f60: 73 20 74 69 6d 65 2d 74 61 69 2d 3e 6a 75 6c 69 s time-tai->juli
6f70: 61 6e 2d 64 61 79 0a 28 64 65 66 69 6e 65 20 28 an-day.(define (
6f80: 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e time-monotonic->
6f90: 6a 75 6c 69 61 6e 2d 64 61 79 20 74 69 6d 65 29 julian-day time)
6fa0: 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f . (if (not (eq?
6fb0: 20 28 74 69 6d 65 2d 74 79 70 65 20 74 69 6d 65 (time-type time
6fc0: 29 20 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 ) time-monotonic
6fd0: 29 29 0a 20 20 20 20 20 20 28 74 6d 3a 74 69 6d )). (tm:tim
6fe0: 65 2d 65 72 72 6f 72 20 27 74 69 6d 65 2d 6d 6f e-error 'time-mo
6ff0: 6e 6f 74 6f 6e 69 63 2d 3e 6a 75 6c 69 61 6e 2d notonic->julian-
7000: 64 61 79 20 27 69 6e 63 6f 6d 70 61 74 69 62 6c day 'incompatibl
7010: 65 2d 74 69 6d 65 2d 74 79 70 65 73 20 20 74 69 e-time-types ti
7020: 6d 65 29 29 0a 20 20 28 2b 20 28 2f 20 28 2b 20 me)). (+ (/ (+
7030: 28 2d 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 20 (- (time-second
7040: 74 69 6d 65 29 20 0a 09 20 20 20 20 20 20 28 74 time) .. (t
7050: 6d 3a 6c 65 61 70 2d 73 65 63 6f 6e 64 2d 64 65 m:leap-second-de
7060: 6c 74 61 20 28 74 69 6d 65 2d 73 65 63 6f 6e 64 lta (time-second
7070: 20 74 69 6d 65 29 29 29 0a 09 20 20 20 28 2f 20 time))).. (/
7080: 28 74 69 6d 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 (time-nanosecond
7090: 20 74 69 6d 65 29 20 74 6d 3a 6e 61 6e 6f 29 29 time) tm:nano))
70a0: 0a 09 74 6d 3a 73 69 64 29 0a 20 20 20 20 20 74 ..tm:sid). t
70b0: 6d 3a 74 61 69 2d 65 70 6f 63 68 2d 69 6e 2d 6a m:tai-epoch-in-j
70c0: 64 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 d))...(define (t
70d0: 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e 6d ime-monotonic->m
70e0: 6f 64 69 66 69 65 64 2d 6a 75 6c 69 61 6e 2d 64 odified-julian-d
70f0: 61 79 20 74 69 6d 65 29 0a 20 20 28 2d 20 28 74 ay time). (- (t
7100: 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 2d 3e 6a ime-monotonic->j
7110: 75 6c 69 61 6e 2d 64 61 79 20 74 69 6d 65 29 0a ulian-day time).
7120: 20 20 20 20 20 34 38 30 30 30 30 31 2f 32 29 29 4800001/2))
7130: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6a 75 6c 69 ...(define (juli
7140: 61 6e 2d 64 61 79 2d 3e 74 69 6d 65 2d 75 74 63 an-day->time-utc
7150: 20 6a 64 6e 29 0a 20 20 28 6c 65 74 20 28 20 28 jdn). (let ( (
7160: 6e 61 6e 6f 73 65 63 73 20 28 2a 20 74 6d 3a 6e nanosecs (* tm:n
7170: 61 6e 6f 20 74 6d 3a 73 69 64 20 28 2d 20 6a 64 ano tm:sid (- jd
7180: 6e 20 74 6d 3a 74 61 69 2d 65 70 6f 63 68 2d 69 n tm:tai-epoch-i
7190: 6e 2d 6a 64 29 29 29 20 29 0a 20 20 20 20 28 6d n-jd))) ). (m
71a0: 61 6b 65 2d 74 69 6d 65 20 74 69 6d 65 2d 75 74 ake-time time-ut
71b0: 63 0a 09 20 20 20 20 20 20 20 28 72 65 6d 61 69 c.. (remai
71c0: 6e 64 65 72 20 6e 61 6e 6f 73 65 63 73 20 74 6d nder nanosecs tm
71d0: 3a 6e 61 6e 6f 29 0a 09 20 20 20 20 20 20 20 28 :nano).. (
71e0: 66 6c 6f 6f 72 20 28 2f 20 6e 61 6e 6f 73 65 63 floor (/ nanosec
71f0: 73 20 74 6d 3a 6e 61 6e 6f 29 29 29 29 29 0a 0a s tm:nano)))))..
7200: 28 64 65 66 69 6e 65 20 28 6a 75 6c 69 61 6e 2d (define (julian-
7210: 64 61 79 2d 3e 74 69 6d 65 2d 74 61 69 20 6a 64 day->time-tai jd
7220: 6e 29 0a 20 20 28 74 69 6d 65 2d 75 74 63 2d 3e n). (time-utc->
7230: 74 69 6d 65 2d 74 61 69 21 20 28 6a 75 6c 69 61 time-tai! (julia
7240: 6e 2d 64 61 79 2d 3e 74 69 6d 65 2d 75 74 63 20 n-day->time-utc
7250: 6a 64 6e 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 jdn)))..(define
7260: 28 6a 75 6c 69 61 6e 2d 64 61 79 2d 3e 74 69 6d (julian-day->tim
7270: 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 20 6a 64 6e 29 e-monotonic jdn)
7280: 0a 20 20 28 74 69 6d 65 2d 75 74 63 2d 3e 74 69 . (time-utc->ti
7290: 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 21 20 28 6a me-monotonic! (j
72a0: 75 6c 69 61 6e 2d 64 61 79 2d 3e 74 69 6d 65 2d ulian-day->time-
72b0: 75 74 63 20 6a 64 6e 29 29 29 0a 0a 28 64 65 66 utc jdn)))..(def
72c0: 69 6e 65 20 28 6a 75 6c 69 61 6e 2d 64 61 79 2d ine (julian-day-
72d0: 3e 64 61 74 65 20 6a 64 6e 20 2e 20 74 7a 2d 6f >date jdn . tz-o
72e0: 66 66 73 65 74 29 0a 20 20 28 6c 65 74 20 28 28 ffset). (let ((
72f0: 6f 66 66 73 65 74 20 28 3a 6f 70 74 69 6f 6e 61 offset (:optiona
7300: 6c 20 74 7a 2d 6f 66 66 73 65 74 20 28 74 6d 3a l tz-offset (tm:
7310: 6c 6f 63 61 6c 2d 74 7a 2d 6f 66 66 73 65 74 29 local-tz-offset)
7320: 29 29 29 0a 20 20 20 20 28 74 69 6d 65 2d 75 74 ))). (time-ut
7330: 63 2d 3e 64 61 74 65 20 28 6a 75 6c 69 61 6e 2d c->date (julian-
7340: 64 61 79 2d 3e 74 69 6d 65 2d 75 74 63 20 6a 64 day->time-utc jd
7350: 6e 29 20 6f 66 66 73 65 74 29 29 29 0a 0a 28 64 n) offset)))..(d
7360: 65 66 69 6e 65 20 28 6d 6f 64 69 66 69 65 64 2d efine (modified-
7370: 6a 75 6c 69 61 6e 2d 64 61 79 2d 3e 64 61 74 65 julian-day->date
7380: 20 6a 64 6e 20 2e 20 74 7a 2d 6f 66 66 73 65 74 jdn . tz-offset
7390: 29 0a 20 20 28 6c 65 74 20 28 28 6f 66 66 73 65 ). (let ((offse
73a0: 74 20 28 3a 6f 70 74 69 6f 6e 61 6c 20 74 7a 2d t (:optional tz-
73b0: 6f 66 66 73 65 74 20 28 74 6d 3a 6c 6f 63 61 6c offset (tm:local
73c0: 2d 74 7a 2d 6f 66 66 73 65 74 29 29 29 29 0a 20 -tz-offset)))).
73d0: 20 20 20 28 6a 75 6c 69 61 6e 2d 64 61 79 2d 3e (julian-day->
73e0: 64 61 74 65 20 28 2b 20 6a 64 6e 20 34 38 30 30 date (+ jdn 4800
73f0: 30 30 31 2f 32 29 20 6f 66 66 73 65 74 29 29 29 001/2) offset)))
7400: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 6f 64 69 66 ..(define (modif
7410: 69 65 64 2d 6a 75 6c 69 61 6e 2d 64 61 79 2d 3e ied-julian-day->
7420: 74 69 6d 65 2d 75 74 63 20 6a 64 6e 29 0a 20 20 time-utc jdn).
7430: 28 6a 75 6c 69 61 6e 2d 64 61 79 2d 3e 74 69 6d (julian-day->tim
7440: 65 2d 75 74 63 20 28 2b 20 6a 64 6e 20 34 38 30 e-utc (+ jdn 480
7450: 30 30 30 31 2f 32 29 29 29 0a 0a 28 64 65 66 69 0001/2)))..(defi
7460: 6e 65 20 28 6d 6f 64 69 66 69 65 64 2d 6a 75 6c ne (modified-jul
7470: 69 61 6e 2d 64 61 79 2d 3e 74 69 6d 65 2d 74 61 ian-day->time-ta
7480: 69 20 6a 64 6e 29 0a 20 20 28 6a 75 6c 69 61 6e i jdn). (julian
7490: 2d 64 61 79 2d 3e 74 69 6d 65 2d 74 61 69 20 28 -day->time-tai (
74a0: 2b 20 6a 64 6e 20 34 38 30 30 30 30 31 2f 32 29 + jdn 4800001/2)
74b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 6f 64 ))..(define (mod
74c0: 69 66 69 65 64 2d 6a 75 6c 69 61 6e 2d 64 61 79 ified-julian-day
74d0: 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f 74 6f 6e 69 63 ->time-monotonic
74e0: 20 6a 64 6e 29 0a 20 20 28 6a 75 6c 69 61 6e 2d jdn). (julian-
74f0: 64 61 79 2d 3e 74 69 6d 65 2d 6d 6f 6e 6f 74 6f day->time-monoto
7500: 6e 69 63 20 28 2b 20 6a 64 6e 20 34 38 30 30 30 nic (+ jdn 48000
7510: 30 31 2f 32 29 29 29 0a 0a 28 64 65 66 69 6e 65 01/2)))..(define
7520: 20 28 63 75 72 72 65 6e 74 2d 6a 75 6c 69 61 6e (current-julian
7530: 2d 64 61 79 29 0a 20 20 28 74 69 6d 65 2d 75 74 -day). (time-ut
7540: 63 2d 3e 6a 75 6c 69 61 6e 2d 64 61 79 20 28 63 c->julian-day (c
7550: 75 72 72 65 6e 74 2d 74 69 6d 65 20 74 69 6d 65 urrent-time time
7560: 2d 75 74 63 29 29 29 0a 0a 28 64 65 66 69 6e 65 -utc)))..(define
7570: 20 28 63 75 72 72 65 6e 74 2d 6d 6f 64 69 66 69 (current-modifi
7580: 65 64 2d 6a 75 6c 69 61 6e 2d 64 61 79 29 0a 20 ed-julian-day).
7590: 20 28 74 69 6d 65 2d 75 74 63 2d 3e 6d 6f 64 69 (time-utc->modi
75a0: 66 69 65 64 2d 6a 75 6c 69 61 6e 2d 64 61 79 20 fied-julian-day
75b0: 28 63 75 72 72 65 6e 74 2d 74 69 6d 65 20 74 69 (current-time ti
75c0: 6d 65 2d 75 74 63 29 29 29 0a 0a 3b 3b 20 72 65 me-utc)))..;; re
75d0: 74 75 72 6e 73 20 61 20 73 74 72 69 6e 67 20 72 turns a string r
75e0: 65 70 2e 20 6f 66 20 6e 75 6d 62 65 72 20 4e 2c ep. of number N,
75f0: 20 6f 66 20 6d 69 6e 69 6d 75 6d 20 4c 45 4e 47 of minimum LENG
7600: 54 48 2c 0a 3b 3b 20 70 61 64 64 65 64 20 77 69 TH,.;; padded wi
7610: 74 68 20 63 68 61 72 61 63 74 65 72 20 50 41 44 th character PAD
7620: 2d 57 49 54 48 2e 20 49 66 20 50 41 44 2d 57 49 -WITH. If PAD-WI
7630: 54 48 20 69 66 20 23 66 2c 20 0a 3b 3b 20 6e 6f TH if #f, .;; no
7640: 20 70 61 64 64 69 6e 67 20 69 73 20 64 6f 6e 65 padding is done
7650: 2c 20 61 6e 64 20 69 74 27 73 20 61 73 20 69 66 , and it's as if
7660: 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 number->string
7670: 77 61 73 20 75 73 65 64 2e 0a 3b 3b 20 69 66 20 was used..;; if
7680: 73 74 72 69 6e 67 20 69 73 20 6c 6f 6e 67 65 72 string is longer
7690: 20 74 68 61 6e 20 4c 45 4e 47 54 48 2c 20 69 74 than LENGTH, it
76a0: 27 73 20 61 73 20 69 66 20 6e 75 6d 62 65 72 2d 's as if number-
76b0: 3e 73 74 72 69 6e 67 20 77 61 73 20 75 73 65 64 >string was used
76c0: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 70 ...(define (tm:p
76d0: 61 64 64 69 6e 67 20 6e 20 70 61 64 2d 77 69 74 adding n pad-wit
76e0: 68 20 6c 65 6e 67 74 68 29 0a 20 20 28 6c 65 74 h length). (let
76f0: 2a 20 28 20 28 73 74 72 20 28 6e 75 6d 62 65 72 * ( (str (number
7700: 2d 3e 73 74 72 69 6e 67 20 6e 29 29 0a 09 20 20 ->string n))..
7710: 28 73 74 72 2d 6c 65 6e 20 28 73 74 72 69 6e 67 (str-len (string
7720: 2d 6c 65 6e 67 74 68 20 73 74 72 29 29 20 29 0a -length str)) ).
7730: 20 20 20 20 28 69 66 20 28 6f 72 20 28 3e 20 73 (if (or (> s
7740: 74 72 2d 6c 65 6e 20 6c 65 6e 67 74 68 29 0a 20 tr-len length).
7750: 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 (not
7760: 70 61 64 2d 77 69 74 68 29 29 0a 09 73 74 72 0a pad-with))..str.
7770: 09 28 6c 65 74 2a 20 28 20 28 6e 65 77 2d 73 74 .(let* ( (new-st
7780: 72 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 6c r (make-string l
7790: 65 6e 67 74 68 20 70 61 64 2d 77 69 74 68 29 29 ength pad-with))
77a0: 0a 09 09 28 6e 65 77 2d 73 74 72 2d 6f 66 66 73 ...(new-str-offs
77b0: 65 74 20 28 2d 20 28 73 74 72 69 6e 67 2d 6c 65 et (- (string-le
77c0: 6e 67 74 68 20 6e 65 77 2d 73 74 72 29 0a 09 09 ngth new-str)...
77d0: 09 09 20 20 20 73 74 72 2d 6c 65 6e 29 29 20 29 .. str-len)) )
77e0: 0a 09 20 20 28 64 6f 20 28 28 69 20 30 20 28 2b .. (do ((i 0 (+
77f0: 20 69 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 i 1))).
7800: 20 20 20 20 28 28 3e 3d 20 69 20 28 73 74 72 69 ((>= i (stri
7810: 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 29 29 29 ng-length str)))
7820: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 . (st
7830: 72 69 6e 67 2d 73 65 74 21 20 6e 65 77 2d 73 74 ring-set! new-st
7840: 72 20 28 2b 20 6e 65 77 2d 73 74 72 2d 6f 66 66 r (+ new-str-off
7850: 73 65 74 20 69 29 20 0a 20 20 20 20 20 20 20 20 set i) .
7860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7870: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 74 72 (string-ref str
7880: 20 69 29 29 29 0a 09 20 20 6e 65 77 2d 73 74 72 i))).. new-str
7890: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
78a0: 6d 3a 6c 61 73 74 2d 6e 2d 64 69 67 69 74 73 20 m:last-n-digits
78b0: 69 20 6e 29 0a 20 20 28 61 62 73 20 28 72 65 6d i n). (abs (rem
78c0: 61 69 6e 64 65 72 20 69 20 28 65 78 70 74 20 31 ainder i (expt 1
78d0: 30 20 6e 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 0 n))))..(define
78e0: 20 28 74 6d 3a 6c 6f 63 61 6c 65 2d 61 62 62 72 (tm:locale-abbr
78f0: 2d 77 65 65 6b 64 61 79 20 6e 29 20 0a 20 20 28 -weekday n) . (
7900: 76 65 63 74 6f 72 2d 72 65 66 20 74 6d 3a 6c 6f vector-ref tm:lo
7910: 63 61 6c 65 2d 61 62 62 72 2d 77 65 65 6b 64 61 cale-abbr-weekda
7920: 79 2d 76 65 63 74 6f 72 20 6e 29 29 0a 0a 28 64 y-vector n))..(d
7930: 65 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 61 6c 65 efine (tm:locale
7940: 2d 6c 6f 6e 67 2d 77 65 65 6b 64 61 79 20 6e 29 -long-weekday n)
7950: 0a 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 . (vector-ref t
7960: 6d 3a 6c 6f 63 61 6c 65 2d 6c 6f 6e 67 2d 77 65 m:locale-long-we
7970: 65 6b 64 61 79 2d 76 65 63 74 6f 72 20 6e 29 29 ekday-vector n))
7980: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 6c 6f ..(define (tm:lo
7990: 63 61 6c 65 2d 61 62 62 72 2d 6d 6f 6e 74 68 20 cale-abbr-month
79a0: 6e 29 0a 20 20 28 76 65 63 74 6f 72 2d 72 65 66 n). (vector-ref
79b0: 20 74 6d 3a 6c 6f 63 61 6c 65 2d 61 62 62 72 2d tm:locale-abbr-
79c0: 6d 6f 6e 74 68 2d 76 65 63 74 6f 72 20 6e 29 29 month-vector n))
79d0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 6c 6f ..(define (tm:lo
79e0: 63 61 6c 65 2d 6c 6f 6e 67 2d 6d 6f 6e 74 68 20 cale-long-month
79f0: 6e 29 0a 20 20 28 76 65 63 74 6f 72 2d 72 65 66 n). (vector-ref
7a00: 20 74 6d 3a 6c 6f 63 61 6c 65 2d 6c 6f 6e 67 2d tm:locale-long-
7a10: 6d 6f 6e 74 68 2d 76 65 63 74 6f 72 20 6e 29 29 month-vector n))
7a20: 0a 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 76 65 ..(define (tm:ve
7a30: 63 74 6f 72 2d 66 69 6e 64 20 6e 65 65 64 6c 65 ctor-find needle
7a40: 20 68 61 79 73 74 61 63 6b 20 63 6f 6d 70 61 72 haystack compar
7a50: 61 74 6f 72 29 0a 20 20 28 6c 65 74 20 28 28 6c ator). (let ((l
7a60: 65 6e 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 en (vector-lengt
7a70: 68 20 68 61 79 73 74 61 63 6b 29 29 29 0a 20 20 h haystack))).
7a80: 20 20 28 64 65 66 69 6e 65 20 28 74 6d 3a 76 65 (define (tm:ve
7a90: 63 74 6f 72 2d 66 69 6e 64 2d 69 6e 74 20 69 6e ctor-find-int in
7aa0: 64 65 78 29 0a 20 20 20 20 20 20 28 63 6f 6e 64 dex). (cond
7ab0: 0a 20 20 20 20 20 20 20 20 28 28 3e 3d 20 69 6e . ((>= in
7ac0: 64 65 78 20 6c 65 6e 29 20 23 66 29 0a 20 20 20 dex len) #f).
7ad0: 20 20 20 20 20 28 28 63 6f 6d 70 61 72 61 74 6f ((comparato
7ae0: 72 20 6e 65 65 64 6c 65 20 28 76 65 63 74 6f 72 r needle (vector
7af0: 2d 72 65 66 20 68 61 79 73 74 61 63 6b 20 69 6e -ref haystack in
7b00: 64 65 78 29 29 20 69 6e 64 65 78 29 0a 20 20 20 dex)) index).
7b10: 20 20 20 20 20 28 65 6c 73 65 20 28 74 6d 3a 76 (else (tm:v
7b20: 65 63 74 6f 72 2d 66 69 6e 64 2d 69 6e 74 20 28 ector-find-int (
7b30: 2b 20 69 6e 64 65 78 20 31 29 29 29 29 29 0a 20 + index 1))))).
7b40: 20 20 20 28 74 6d 3a 76 65 63 74 6f 72 2d 66 69 (tm:vector-fi
7b50: 6e 64 2d 69 6e 74 20 30 29 29 29 0a 0a 28 64 65 nd-int 0)))..(de
7b60: 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 61 6c 65 2d fine (tm:locale-
7b70: 61 62 62 72 2d 77 65 65 6b 64 61 79 2d 3e 69 6e abbr-weekday->in
7b80: 64 65 78 20 73 74 72 69 6e 67 29 0a 20 20 28 74 dex string). (t
7b90: 6d 3a 76 65 63 74 6f 72 2d 66 69 6e 64 20 73 74 m:vector-find st
7ba0: 72 69 6e 67 20 74 6d 3a 6c 6f 63 61 6c 65 2d 61 ring tm:locale-a
7bb0: 62 62 72 2d 77 65 65 6b 64 61 79 2d 76 65 63 74 bbr-weekday-vect
7bc0: 6f 72 20 73 74 72 69 6e 67 3d 3f 29 29 0a 0a 28 or string=?))..(
7bd0: 64 65 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 61 6c define (tm:local
7be0: 65 2d 6c 6f 6e 67 2d 77 65 65 6b 64 61 79 2d 3e e-long-weekday->
7bf0: 69 6e 64 65 78 20 73 74 72 69 6e 67 29 0a 20 20 index string).
7c00: 28 74 6d 3a 76 65 63 74 6f 72 2d 66 69 6e 64 20 (tm:vector-find
7c10: 73 74 72 69 6e 67 20 74 6d 3a 6c 6f 63 61 6c 65 string tm:locale
7c20: 2d 6c 6f 6e 67 2d 77 65 65 6b 64 61 79 2d 76 65 -long-weekday-ve
7c30: 63 74 6f 72 20 73 74 72 69 6e 67 3d 3f 29 29 0a ctor string=?)).
7c40: 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 .(define (tm:loc
7c50: 61 6c 65 2d 61 62 62 72 2d 6d 6f 6e 74 68 2d 3e ale-abbr-month->
7c60: 69 6e 64 65 78 20 73 74 72 69 6e 67 29 0a 20 20 index string).
7c70: 28 74 6d 3a 76 65 63 74 6f 72 2d 66 69 6e 64 20 (tm:vector-find
7c80: 73 74 72 69 6e 67 20 74 6d 3a 6c 6f 63 61 6c 65 string tm:locale
7c90: 2d 61 62 62 72 2d 6d 6f 6e 74 68 2d 76 65 63 74 -abbr-month-vect
7ca0: 6f 72 20 73 74 72 69 6e 67 3d 3f 29 29 0a 0a 28 or string=?))..(
7cb0: 64 65 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 61 6c define (tm:local
7cc0: 65 2d 6c 6f 6e 67 2d 6d 6f 6e 74 68 2d 3e 69 6e e-long-month->in
7cd0: 64 65 78 20 73 74 72 69 6e 67 29 0a 20 20 28 74 dex string). (t
7ce0: 6d 3a 76 65 63 74 6f 72 2d 66 69 6e 64 20 73 74 m:vector-find st
7cf0: 72 69 6e 67 20 74 6d 3a 6c 6f 63 61 6c 65 2d 6c ring tm:locale-l
7d00: 6f 6e 67 2d 6d 6f 6e 74 68 2d 76 65 63 74 6f 72 ong-month-vector
7d10: 20 73 74 72 69 6e 67 3d 3f 29 29 0a 0a 0a 0a 3b string=?))....;
7d20: 3b 20 64 6f 20 6e 6f 74 68 69 6e 67 2e 20 0a 3b ; do nothing. .;
7d30: 3b 20 59 6f 75 72 20 69 6d 70 6c 65 6d 65 6e 74 ; Your implement
7d40: 61 74 69 6f 6e 20 6d 69 67 68 74 20 77 61 6e 74 ation might want
7d50: 20 74 6f 20 64 6f 20 73 6f 6d 65 74 68 69 6e 67 to do something
7d60: 2e 2e 2e 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 ....;; .(define
7d70: 28 74 6d 3a 6c 6f 63 61 6c 65 2d 70 72 69 6e 74 (tm:locale-print
7d80: 2d 74 69 6d 65 2d 7a 6f 6e 65 20 64 61 74 65 20 -time-zone date
7d90: 70 6f 72 74 29 0a 20 20 28 76 61 6c 75 65 73 29 port). (values)
7da0: 29 0a 0a 3b 3b 20 41 67 61 69 6e 2c 20 6c 6f 63 )..;; Again, loc
7db0: 61 6c 65 20 73 70 65 63 69 66 69 63 2e 0a 28 64 ale specific..(d
7dc0: 65 66 69 6e 65 20 28 74 6d 3a 6c 6f 63 61 6c 65 efine (tm:locale
7dd0: 2d 61 6d 2f 70 6d 20 68 72 29 0a 20 20 28 69 66 -am/pm hr). (if
7de0: 20 28 3e 20 68 72 20 31 31 29 20 74 6d 3a 6c 6f (> hr 11) tm:lo
7df0: 63 61 6c 65 2d 70 6d 20 74 6d 3a 6c 6f 63 61 6c cale-pm tm:local
7e00: 65 2d 61 6d 29 29 0a 0a 28 64 65 66 69 6e 65 20 e-am))..(define
7e10: 28 74 6d 3a 74 7a 2d 70 72 69 6e 74 65 72 20 6f (tm:tz-printer o
7e20: 66 66 73 65 74 20 70 6f 72 74 29 0a 20 20 28 63 ffset port). (c
7e30: 6f 6e 64 0a 20 20 20 20 28 28 3d 20 6f 66 66 73 ond. ((= offs
7e40: 65 74 20 30 29 20 28 64 69 73 70 6c 61 79 20 22 et 0) (display "
7e50: 5a 22 20 70 6f 72 74 29 29 0a 20 20 20 20 28 28 Z" port)). ((
7e60: 6e 65 67 61 74 69 76 65 3f 20 6f 66 66 73 65 74 negative? offset
7e70: 29 20 28 64 69 73 70 6c 61 79 20 22 2d 22 20 70 ) (display "-" p
7e80: 6f 72 74 29 29 0a 20 20 20 20 28 65 6c 73 65 20 ort)). (else
7e90: 28 64 69 73 70 6c 61 79 20 22 2b 22 20 70 6f 72 (display "+" por
7ea0: 74 29 29 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 t))). (if (not
7eb0: 28 3d 20 6f 66 66 73 65 74 20 30 29 29 0a 20 20 (= offset 0)).
7ec0: 20 20 20 20 28 6c 65 74 20 28 20 28 68 6f 75 72 (let ( (hour
7ed0: 73 20 20 20 28 61 62 73 20 28 71 75 6f 74 69 65 s (abs (quotie
7ee0: 6e 74 20 6f 66 66 73 65 74 20 28 2a 20 36 30 20 nt offset (* 60
7ef0: 36 30 29 29 29 29 0a 09 20 20 20 20 20 28 6d 69 60)))).. (mi
7f00: 6e 75 74 65 73 20 28 61 62 73 20 28 71 75 6f 74 nutes (abs (quot
7f10: 69 65 6e 74 20 28 72 65 6d 61 69 6e 64 65 72 20 ient (remainder
7f20: 6f 66 66 73 65 74 20 28 2a 20 36 30 20 36 30 29 offset (* 60 60)
7f30: 29 20 36 30 29 29 29 20 29 0a 09 28 64 69 73 70 ) 60))) )..(disp
7f40: 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 lay (tm:padding
7f50: 68 6f 75 72 73 20 23 5c 30 20 32 29 20 70 6f 72 hours #\0 2) por
7f60: 74 29 0a 09 28 64 69 73 70 6c 61 79 20 28 74 6d t)..(display (tm
7f70: 3a 70 61 64 64 69 6e 67 20 6d 69 6e 75 74 65 73 :padding minutes
7f80: 20 23 5c 30 20 32 29 20 70 6f 72 74 29 29 29 29 #\0 2) port))))
7f90: 0a 0a 3b 3b 20 41 20 74 61 62 6c 65 20 6f 66 20 ..;; A table of
7fa0: 6f 75 74 70 75 74 20 66 6f 72 6d 61 74 74 69 6e output formattin
7fb0: 67 20 64 69 72 65 63 74 69 76 65 73 2e 0a 3b 3b g directives..;;
7fc0: 20 74 68 65 20 66 69 72 73 74 20 74 69 6d 65 20 the first time
7fd0: 69 73 20 74 68 65 20 66 6f 72 6d 61 74 20 63 68 is the format ch
7fe0: 61 72 2e 0a 3b 3b 20 74 68 65 20 73 65 63 6f 6e ar..;; the secon
7ff0: 64 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 d is a procedure
8000: 20 74 68 61 74 20 74 61 6b 65 73 20 74 68 65 20 that takes the
8010: 64 61 74 65 2c 20 61 20 70 61 64 64 69 6e 67 20 date, a padding
8020: 63 68 61 72 61 63 74 65 72 0a 3b 3b 20 28 77 68 character.;; (wh
8030: 69 63 68 20 6d 69 67 68 74 20 62 65 20 23 66 29 ich might be #f)
8040: 2c 20 61 6e 64 20 74 68 65 20 6f 75 74 70 75 74 , and the output
8050: 20 70 6f 72 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e port..;;.(defin
8060: 65 20 74 6d 3a 64 69 72 65 63 74 69 76 65 73 20 e tm:directives
8070: 0a 20 20 28 6c 69 73 74 0a 20 20 20 28 63 6f 6e . (list. (con
8080: 73 20 23 5c 7e 20 28 6c 61 6d 62 64 61 20 28 64 s #\~ (lambda (d
8090: 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f 72 ate pad-with por
80a0: 74 29 20 28 64 69 73 70 6c 61 79 20 23 5c 7e 20 t) (display #\~
80b0: 70 6f 72 74 29 29 29 0a 20 20 20 0a 20 20 20 28 port))). . (
80c0: 63 6f 6e 73 20 23 5c 61 20 28 6c 61 6d 62 64 61 cons #\a (lambda
80d0: 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 (date pad-with
80e0: 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 port).. (d
80f0: 69 73 70 6c 61 79 20 28 74 6d 3a 6c 6f 63 61 6c isplay (tm:local
8100: 65 2d 61 62 62 72 2d 77 65 65 6b 64 61 79 20 28 e-abbr-weekday (
8110: 64 61 74 65 2d 77 65 65 6b 2d 64 61 79 20 64 61 date-week-day da
8120: 74 65 29 29 0a 09 09 09 70 6f 72 74 29 29 29 0a te))....port))).
8130: 20 20 20 28 63 6f 6e 73 20 23 5c 41 20 28 6c 61 (cons #\A (la
8140: 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 mbda (date pad-w
8150: 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 ith port)..
8160: 20 20 28 64 69 73 70 6c 61 79 20 28 74 6d 3a 6c (display (tm:l
8170: 6f 63 61 6c 65 2d 6c 6f 6e 67 2d 77 65 65 6b 64 ocale-long-weekd
8180: 61 79 20 28 64 61 74 65 2d 77 65 65 6b 2d 64 61 ay (date-week-da
8190: 79 20 64 61 74 65 29 29 0a 09 09 09 70 6f 72 74 y date))....port
81a0: 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 62 ))). (cons #\b
81b0: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 (lambda (date p
81c0: 61 64 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 ad-with port)..
81d0: 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 (display (
81e0: 74 6d 3a 6c 6f 63 61 6c 65 2d 61 62 62 72 2d 6d tm:locale-abbr-m
81f0: 6f 6e 74 68 20 28 64 61 74 65 2d 6d 6f 6e 74 68 onth (date-month
8200: 20 64 61 74 65 29 29 0a 09 09 09 70 6f 72 74 29 date))....port)
8210: 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 42 20 )). (cons #\B
8220: 28 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 (lambda (date pa
8230: 64 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 d-with port)..
8240: 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 74 (display (t
8250: 6d 3a 6c 6f 63 61 6c 65 2d 6c 6f 6e 67 2d 6d 6f m:locale-long-mo
8260: 6e 74 68 20 28 64 61 74 65 2d 6d 6f 6e 74 68 20 nth (date-month
8270: 64 61 74 65 29 29 0a 09 09 09 70 6f 72 74 29 29 date))....port))
8280: 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 63 20 28 ). (cons #\c (
8290: 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 lambda (date pad
82a0: 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 -with port)..
82b0: 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 64 61 (display (da
82c0: 74 65 2d 3e 73 74 72 69 6e 67 20 64 61 74 65 20 te->string date
82d0: 74 6d 3a 6c 6f 63 61 6c 65 2d 64 61 74 65 2d 74 tm:locale-date-t
82e0: 69 6d 65 2d 66 6f 72 6d 61 74 29 20 70 6f 72 74 ime-format) port
82f0: 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 64 ))). (cons #\d
8300: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 (lambda (date p
8310: 61 64 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 ad-with port)..
8320: 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 (display (
8330: 74 6d 3a 70 61 64 64 69 6e 67 20 28 64 61 74 65 tm:padding (date
8340: 2d 64 61 79 20 64 61 74 65 29 0a 09 09 09 09 20 -day date).....
8350: 20 20 20 23 5c 30 20 32 29 0a 20 20 20 20 20 20 #\0 2).
8360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8370: 20 20 70 6f 72 74 29 29 29 0a 20 20 20 28 63 6f port))). (co
8380: 6e 73 20 23 5c 44 20 28 6c 61 6d 62 64 61 20 28 ns #\D (lambda (
8390: 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f date pad-with po
83a0: 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 rt).. (dis
83b0: 70 6c 61 79 20 28 64 61 74 65 2d 3e 73 74 72 69 play (date->stri
83c0: 6e 67 20 64 61 74 65 20 22 7e 6d 2f 7e 64 2f 7e ng date "~m/~d/~
83d0: 79 22 29 20 70 6f 72 74 29 29 29 0a 20 20 20 28 y") port))). (
83e0: 63 6f 6e 73 20 23 5c 65 20 28 6c 61 6d 62 64 61 cons #\e (lambda
83f0: 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 (date pad-with
8400: 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 port).. (d
8410: 69 73 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 isplay (tm:paddi
8420: 6e 67 20 28 64 61 74 65 2d 64 61 79 20 64 61 74 ng (date-day dat
8430: 65 29 0a 09 09 09 09 20 20 20 20 23 5c 73 70 61 e)..... #\spa
8440: 63 65 20 32 29 0a 09 09 09 70 6f 72 74 29 29 29 ce 2)....port)))
8450: 0a 20 20 20 28 63 6f 6e 73 20 23 5c 66 20 28 6c . (cons #\f (l
8460: 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 2d ambda (date pad-
8470: 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 with port)..
8480: 20 20 20 28 69 66 20 28 3e 20 28 64 61 74 65 2d (if (> (date-
8490: 6e 61 6e 6f 73 65 63 6f 6e 64 20 64 61 74 65 29 nanosecond date)
84a0: 0a 09 09 20 20 20 20 20 20 74 6d 3a 6e 61 6e 6f ... tm:nano
84b0: 29 0a 09 09 20 20 20 28 64 69 73 70 6c 61 79 20 )... (display
84c0: 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 2b 20 28 (tm:padding (+ (
84d0: 64 61 74 65 2d 73 65 63 6f 6e 64 20 64 61 74 65 date-second date
84e0: 29 20 31 29 0a 09 09 09 09 09 70 61 64 2d 77 69 ) 1)......pad-wi
84f0: 74 68 20 32 29 0a 09 09 09 20 20 20 20 70 6f 72 th 2).... por
8500: 74 29 0a 09 09 20 20 20 28 64 69 73 70 6c 61 79 t)... (display
8510: 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 64 61 (tm:padding (da
8520: 74 65 2d 73 65 63 6f 6e 64 20 64 61 74 65 29 0a te-second date).
8530: 09 09 09 09 09 70 61 64 2d 77 69 74 68 20 32 29 .....pad-with 2)
8540: 0a 09 09 09 20 20 20 20 70 6f 72 74 29 29 0a 09 .... port))..
8550: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e (let* ((n
8560: 73 20 28 74 6d 3a 66 72 61 63 74 69 6f 6e 61 6c s (tm:fractional
8570: 2d 70 61 72 74 20 28 2f 20 0a 09 09 09 09 09 20 -part (/ ......
8580: 20 20 20 20 20 20 28 64 61 74 65 2d 6e 61 6e 6f (date-nano
8590: 73 65 63 6f 6e 64 20 64 61 74 65 29 0a 09 09 09 second date)....
85a0: 09 09 20 20 20 20 20 20 20 74 6d 3a 6e 61 6e 6f .. tm:nano
85b0: 20 31 2e 30 29 29 29 0a 09 09 20 20 20 20 20 20 1.0)))...
85c0: 28 6c 65 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (le (string-leng
85d0: 74 68 20 6e 73 29 29 29 0a 09 09 20 28 69 66 20 th ns)))... (if
85e0: 28 3e 20 6c 65 20 32 29 0a 09 09 20 20 20 20 20 (> le 2)...
85f0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 (begin...
8600: 28 64 69 73 70 6c 61 79 20 74 6d 3a 6c 6f 63 61 (display tm:loca
8610: 6c 65 2d 6e 75 6d 62 65 72 2d 73 65 70 61 72 61 le-number-separa
8620: 74 6f 72 20 70 6f 72 74 29 0a 09 09 20 20 20 20 tor port)...
8630: 20 20 20 28 64 69 73 70 6c 61 79 20 28 73 75 62 (display (sub
8640: 73 74 72 69 6e 67 20 6e 73 20 32 20 6c 65 29 20 string ns 2 le)
8650: 70 6f 72 74 29 29 29 29 29 29 0a 20 20 20 28 63 port)))))). (c
8660: 6f 6e 73 20 23 5c 68 20 28 6c 61 6d 62 64 61 20 ons #\h (lambda
8670: 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 (date pad-with p
8680: 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 ort).. (di
8690: 73 70 6c 61 79 20 28 64 61 74 65 2d 3e 73 74 72 splay (date->str
86a0: 69 6e 67 20 64 61 74 65 20 22 7e 62 22 29 20 70 ing date "~b") p
86b0: 6f 72 74 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 ort))). (cons
86c0: 23 5c 48 20 28 6c 61 6d 62 64 61 20 28 64 61 74 #\H (lambda (dat
86d0: 65 20 70 61 64 2d 77 69 74 68 20 70 6f 72 74 29 e pad-with port)
86e0: 0a 09 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 .. (displa
86f0: 79 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 64 y (tm:padding (d
8700: 61 74 65 2d 68 6f 75 72 20 64 61 74 65 29 0a 09 ate-hour date)..
8710: 09 09 09 20 20 20 20 70 61 64 2d 77 69 74 68 20 ... pad-with
8720: 32 29 0a 09 09 09 70 6f 72 74 29 29 29 0a 20 20 2)....port))).
8730: 20 28 63 6f 6e 73 20 23 5c 49 20 28 6c 61 6d 62 (cons #\I (lamb
8740: 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 da (date pad-wit
8750: 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 h port)..
8760: 28 6c 65 74 20 28 28 68 72 20 28 64 61 74 65 2d (let ((hr (date-
8770: 68 6f 75 72 20 64 61 74 65 29 29 29 0a 09 09 20 hour date)))...
8780: 28 69 66 20 28 3e 20 68 72 20 31 32 29 0a 09 09 (if (> hr 12)...
8790: 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 74 (display (t
87a0: 6d 3a 70 61 64 64 69 6e 67 20 28 2d 20 68 72 20 m:padding (- hr
87b0: 31 32 29 0a 09 09 09 09 09 20 20 70 61 64 2d 77 12)...... pad-w
87c0: 69 74 68 20 32 29 0a 09 09 09 20 20 20 20 20 20 ith 2)....
87d0: 70 6f 72 74 29 0a 09 09 20 20 20 20 20 28 64 69 port)... (di
87e0: 73 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 6e splay (tm:paddin
87f0: 67 20 68 72 0a 09 09 09 09 09 20 20 70 61 64 2d g hr...... pad-
8800: 77 69 74 68 20 32 29 0a 09 09 09 20 20 20 20 20 with 2)....
8810: 20 70 6f 72 74 29 29 29 29 29 0a 20 20 20 28 63 port))))). (c
8820: 6f 6e 73 20 23 5c 6a 20 28 6c 61 6d 62 64 61 20 ons #\j (lambda
8830: 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 (date pad-with p
8840: 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 ort).. (di
8850: 73 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 6e splay (tm:paddin
8860: 67 20 28 64 61 74 65 2d 79 65 61 72 2d 64 61 79 g (date-year-day
8870: 20 64 61 74 65 29 0a 09 09 09 09 20 20 20 20 70 date)..... p
8880: 61 64 2d 77 69 74 68 20 33 29 0a 09 09 09 70 6f ad-with 3)....po
8890: 72 74 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 rt))). (cons #
88a0: 5c 6b 20 28 6c 61 6d 62 64 61 20 28 64 61 74 65 \k (lambda (date
88b0: 20 70 61 64 2d 77 69 74 68 20 70 6f 72 74 29 0a pad-with port).
88c0: 09 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 . (display
88d0: 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 64 61 (tm:padding (da
88e0: 74 65 2d 68 6f 75 72 20 64 61 74 65 29 0a 09 09 te-hour date)...
88f0: 09 09 20 20 20 20 23 5c 30 20 32 29 0a 20 20 20 .. #\0 2).
8900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8910: 20 20 20 20 20 70 6f 72 74 29 29 29 0a 20 20 20 port))).
8920: 28 63 6f 6e 73 20 23 5c 6c 20 28 6c 61 6d 62 64 (cons #\l (lambd
8930: 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 a (date pad-with
8940: 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 port).. (
8950: 6c 65 74 20 28 28 68 72 20 28 69 66 20 28 3e 20 let ((hr (if (>
8960: 28 64 61 74 65 2d 68 6f 75 72 20 64 61 74 65 29 (date-hour date)
8970: 20 31 32 29 0a 09 09 09 20 20 20 20 20 28 2d 20 12).... (-
8980: 28 64 61 74 65 2d 68 6f 75 72 20 64 61 74 65 29 (date-hour date)
8990: 20 31 32 29 20 28 64 61 74 65 2d 68 6f 75 72 20 12) (date-hour
89a0: 64 61 74 65 29 29 29 29 0a 09 09 20 28 64 69 73 date))))... (dis
89b0: 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 6e 67 play (tm:padding
89c0: 20 68 72 20 20 23 5c 73 70 61 63 65 20 32 29 0a hr #\space 2).
89d0: 09 09 09 20 20 70 6f 72 74 29 29 29 29 0a 20 20 ... port)))).
89e0: 20 28 63 6f 6e 73 20 23 5c 6d 20 28 6c 61 6d 62 (cons #\m (lamb
89f0: 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 da (date pad-wit
8a00: 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 h port)..
8a10: 28 64 69 73 70 6c 61 79 20 28 74 6d 3a 70 61 64 (display (tm:pad
8a20: 64 69 6e 67 20 28 64 61 74 65 2d 6d 6f 6e 74 68 ding (date-month
8a30: 20 64 61 74 65 29 0a 09 09 09 09 20 20 20 20 70 date)..... p
8a40: 61 64 2d 77 69 74 68 20 32 29 0a 09 09 09 70 6f ad-with 2)....po
8a50: 72 74 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 rt))). (cons #
8a60: 5c 4d 20 28 6c 61 6d 62 64 61 20 28 64 61 74 65 \M (lambda (date
8a70: 20 70 61 64 2d 77 69 74 68 20 70 6f 72 74 29 0a pad-with port).
8a80: 09 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 . (display
8a90: 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 64 61 (tm:padding (da
8aa0: 74 65 2d 6d 69 6e 75 74 65 20 64 61 74 65 29 0a te-minute date).
8ab0: 09 09 09 09 20 20 20 20 70 61 64 2d 77 69 74 68 .... pad-with
8ac0: 20 32 29 0a 09 09 09 70 6f 72 74 29 29 29 0a 20 2)....port))).
8ad0: 20 20 28 63 6f 6e 73 20 23 5c 6e 20 28 6c 61 6d (cons #\n (lam
8ae0: 62 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 bda (date pad-wi
8af0: 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 th port)..
8b00: 20 28 6e 65 77 6c 69 6e 65 20 70 6f 72 74 29 29 (newline port))
8b10: 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 4e 20 28 ). (cons #\N (
8b20: 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 lambda (date pad
8b30: 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 -with port)..
8b40: 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 74 6d (display (tm
8b50: 3a 70 61 64 64 69 6e 67 20 28 64 61 74 65 2d 6e :padding (date-n
8b60: 61 6e 6f 73 65 63 6f 6e 64 20 64 61 74 65 29 0a anosecond date).
8b70: 09 09 09 09 20 20 20 20 70 61 64 2d 77 69 74 68 .... pad-with
8b80: 20 39 29 0a 09 09 09 70 6f 72 74 29 29 29 0a 20 9)....port))).
8b90: 20 20 28 63 6f 6e 73 20 23 5c 70 20 28 6c 61 6d (cons #\p (lam
8ba0: 62 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 bda (date pad-wi
8bb0: 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 th port)..
8bc0: 20 28 64 69 73 70 6c 61 79 20 28 74 6d 3a 6c 6f (display (tm:lo
8bd0: 63 61 6c 65 2d 61 6d 2f 70 6d 20 28 64 61 74 65 cale-am/pm (date
8be0: 2d 68 6f 75 72 20 64 61 74 65 29 29 20 70 6f 72 -hour date)) por
8bf0: 74 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c t))). (cons #\
8c00: 72 20 28 6c 61 6d 62 64 61 20 28 64 61 74 65 20 r (lambda (date
8c10: 70 61 64 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 pad-with port)..
8c20: 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 (display
8c30: 28 64 61 74 65 2d 3e 73 74 72 69 6e 67 20 64 61 (date->string da
8c40: 74 65 20 22 7e 49 3a 7e 4d 3a 7e 53 20 7e 70 22 te "~I:~M:~S ~p"
8c50: 29 20 70 6f 72 74 29 29 29 0a 20 20 20 28 63 6f ) port))). (co
8c60: 6e 73 20 23 5c 73 20 28 6c 61 6d 62 64 61 20 28 ns #\s (lambda (
8c70: 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f date pad-with po
8c80: 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 rt).. (dis
8c90: 70 6c 61 79 20 28 74 69 6d 65 2d 73 65 63 6f 6e play (time-secon
8ca0: 64 20 28 64 61 74 65 2d 3e 74 69 6d 65 2d 75 74 d (date->time-ut
8cb0: 63 20 64 61 74 65 29 29 20 70 6f 72 74 29 29 29 c date)) port)))
8cc0: 0a 20 20 20 28 63 6f 6e 73 20 23 5c 53 20 28 6c . (cons #\S (l
8cd0: 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 2d ambda (date pad-
8ce0: 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 with port)..
8cf0: 20 20 20 28 69 66 20 28 3e 20 28 64 61 74 65 2d (if (> (date-
8d00: 6e 61 6e 6f 73 65 63 6f 6e 64 20 64 61 74 65 29 nanosecond date)
8d10: 0a 09 09 20 20 20 20 20 20 74 6d 3a 6e 61 6e 6f ... tm:nano
8d20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8d30: 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 74 (display (t
8d40: 6d 3a 70 61 64 64 69 6e 67 20 28 2b 20 28 64 61 m:padding (+ (da
8d50: 74 65 2d 73 65 63 6f 6e 64 20 64 61 74 65 29 20 te-second date)
8d60: 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1).
8d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d80: 20 20 20 20 20 20 20 20 20 20 20 70 61 64 2d 77 pad-w
8d90: 69 74 68 20 32 29 0a 20 20 20 20 20 20 20 20 20 ith 2).
8da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8db0: 20 20 20 70 6f 72 74 29 0a 20 20 20 20 20 20 20 port).
8dc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 73 (dis
8dd0: 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 6e 67 play (tm:padding
8de0: 20 28 64 61 74 65 2d 73 65 63 6f 6e 64 20 64 61 (date-second da
8df0: 74 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 te).
8e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e10: 20 20 20 20 20 20 20 20 20 20 20 20 70 61 64 2d pad-
8e20: 77 69 74 68 20 32 29 0a 20 20 20 20 20 20 20 20 with 2).
8e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8e40: 20 20 20 20 70 6f 72 74 29 29 29 29 0a 20 20 20 port)))).
8e50: 28 63 6f 6e 73 20 23 5c 74 20 28 6c 61 6d 62 64 (cons #\t (lambd
8e60: 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 a (date pad-with
8e70: 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 port).. (
8e80: 64 69 73 70 6c 61 79 20 28 69 6e 74 65 67 65 72 display (integer
8e90: 2d 3e 63 68 61 72 20 39 29 20 70 6f 72 74 29 29 ->char 9) port))
8ea0: 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 54 20 28 ). (cons #\T (
8eb0: 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 lambda (date pad
8ec0: 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 -with port)..
8ed0: 20 20 20 20 28 64 69 73 70 6c 61 79 20 28 64 61 (display (da
8ee0: 74 65 2d 3e 73 74 72 69 6e 67 20 64 61 74 65 20 te->string date
8ef0: 22 7e 48 3a 7e 4d 3a 7e 53 22 29 20 70 6f 72 74 "~H:~M:~S") port
8f00: 29 29 29 0a 20 20 20 28 63 6f 6e 73 20 23 5c 55 ))). (cons #\U
8f10: 20 28 6c 61 6d 62 64 61 20 28 64 61 74 65 20 70 (lambda (date p
8f20: 61 64 2d 77 69 74 68 20 70 6f 72 74 29 0a 09 20 ad-with port)..
8f30: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 74 6d (if (> (tm
8f40: 3a 64 61 79 73 2d 62 65 66 6f 72 65 2d 66 69 72 :days-before-fir
8f50: 73 74 2d 77 65 65 6b 20 64 61 74 65 20 30 29 20 st-week date 0)
8f60: 30 29 0a 09 09 20 20 20 28 64 69 73 70 6c 61 79 0)... (display
8f70: 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 2b 20 (tm:padding (+
8f80: 28 64 61 74 65 2d 77 65 65 6b 2d 6e 75 6d 62 65 (date-week-numbe
8f90: 72 20 64 61 74 65 20 30 29 20 31 29 0a 09 09 09 r date 0) 1)....
8fa0: 09 09 23 5c 30 20 32 29 20 70 6f 72 74 29 0a 09 ..#\0 2) port)..
8fb0: 09 20 20 20 28 64 69 73 70 6c 61 79 20 28 74 6d . (display (tm
8fc0: 3a 70 61 64 64 69 6e 67 20 28 64 61 74 65 2d 77 :padding (date-w
8fd0: 65 65 6b 2d 6e 75 6d 62 65 72 20 64 61 74 65 20 eek-number date
8fe0: 30 29 0a 09 09 09 09 09 23 5c 30 20 32 29 20 70 0)......#\0 2) p
8ff0: 6f 72 74 29 29 29 29 0a 20 20 20 28 63 6f 6e 73 ort)))). (cons
9000: 20 23 5c 56 20 28 6c 61 6d 62 64 61 20 28 64 61 #\V (lambda (da
9010: 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f 72 74 te pad-with port
9020: 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 70 6c ).. (displ
9030: 61 79 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 ay (tm:padding (
9040: 64 61 74 65 2d 77 65 65 6b 2d 6e 75 6d 62 65 72 date-week-number
9050: 20 64 61 74 65 20 31 29 0a 09 09 09 09 20 20 20 date 1).....
9060: 20 23 5c 30 20 32 29 20 70 6f 72 74 29 29 29 0a #\0 2) port))).
9070: 20 20 20 28 63 6f 6e 73 20 23 5c 77 20 28 6c 61 (cons #\w (la
9080: 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 mbda (date pad-w
9090: 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 ith port)..
90a0: 20 20 28 64 69 73 70 6c 61 79 20 28 64 61 74 65 (display (date
90b0: 2d 77 65 65 6b 2d 64 61 79 20 64 61 74 65 29 20 -week-day date)
90c0: 70 6f 72 74 29 29 29 0a 20 20 20 28 63 6f 6e 73 port))). (cons
90d0: 20 23 5c 78 20 28 6c 61 6d 62 64 61 20 28 64 61 #\x (lambda (da
90e0: 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f 72 74 te pad-with port
90f0: 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 70 6c ).. (displ
9100: 61 79 20 28 64 61 74 65 2d 3e 73 74 72 69 6e 67 ay (date->string
9110: 20 64 61 74 65 20 74 6d 3a 6c 6f 63 61 6c 65 2d date tm:locale-
9120: 73 68 6f 72 74 2d 64 61 74 65 2d 66 6f 72 6d 61 short-date-forma
9130: 74 29 20 70 6f 72 74 29 29 29 0a 20 20 20 28 63 t) port))). (c
9140: 6f 6e 73 20 23 5c 58 20 28 6c 61 6d 62 64 61 20 ons #\X (lambda
9150: 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 (date pad-with p
9160: 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 ort).. (di
9170: 73 70 6c 61 79 20 28 64 61 74 65 2d 3e 73 74 72 splay (date->str
9180: 69 6e 67 20 64 61 74 65 20 74 6d 3a 6c 6f 63 61 ing date tm:loca
9190: 6c 65 2d 74 69 6d 65 2d 66 6f 72 6d 61 74 29 20 le-time-format)
91a0: 70 6f 72 74 29 29 29 0a 20 20 20 28 63 6f 6e 73 port))). (cons
91b0: 20 23 5c 57 20 28 6c 61 6d 62 64 61 20 28 64 61 #\W (lambda (da
91c0: 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f 72 74 te pad-with port
91d0: 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 3e ).. (if (>
91e0: 20 28 74 6d 3a 64 61 79 73 2d 62 65 66 6f 72 65 (tm:days-before
91f0: 2d 66 69 72 73 74 2d 77 65 65 6b 20 64 61 74 65 -first-week date
9200: 20 31 29 20 30 29 0a 09 09 20 20 20 28 64 69 73 1) 0)... (dis
9210: 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 6e 67 play (tm:padding
9220: 20 28 2b 20 28 64 61 74 65 2d 77 65 65 6b 2d 6e (+ (date-week-n
9230: 75 6d 62 65 72 20 64 61 74 65 20 31 29 20 31 29 umber date 1) 1)
9240: 0a 09 09 09 09 09 23 5c 30 20 32 29 20 70 6f 72 ......#\0 2) por
9250: 74 29 0a 09 09 20 20 20 28 64 69 73 70 6c 61 79 t)... (display
9260: 20 28 74 6d 3a 70 61 64 64 69 6e 67 20 28 64 61 (tm:padding (da
9270: 74 65 2d 77 65 65 6b 2d 6e 75 6d 62 65 72 20 64 te-week-number d
9280: 61 74 65 20 31 29 0a 09 09 09 09 09 23 5c 30 20 ate 1)......#\0
9290: 32 29 20 70 6f 72 74 29 29 29 29 0a 20 20 20 28 2) port)))). (
92a0: 63 6f 6e 73 20 23 5c 79 20 28 6c 61 6d 62 64 61 cons #\y (lambda
92b0: 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 (date pad-with
92c0: 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 port).. (d
92d0: 69 73 70 6c 61 79 20 28 74 6d 3a 70 61 64 64 69 isplay (tm:paddi
92e0: 6e 67 20 28 74 6d 3a 6c 61 73 74 2d 6e 2d 64 69 ng (tm:last-n-di
92f0: 67 69 74 73 20 0a 09 09 09 09 20 20 20 20 20 28 gits ..... (
9300: 64 61 74 65 2d 79 65 61 72 20 64 61 74 65 29 20 date-year date)
9310: 32 29 0a 09 09 09 09 20 20 20 20 70 61 64 2d 77 2)..... pad-w
9320: 69 74 68 0a 09 09 09 09 20 20 20 20 32 29 0a 09 ith..... 2)..
9330: 09 09 70 6f 72 74 29 29 29 0a 20 20 20 28 63 6f ..port))). (co
9340: 6e 73 20 23 5c 59 20 28 6c 61 6d 62 64 61 20 28 ns #\Y (lambda (
9350: 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f date pad-with po
9360: 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 rt).. (dis
9370: 70 6c 61 79 20 28 64 61 74 65 2d 79 65 61 72 20 play (date-year
9380: 64 61 74 65 29 20 70 6f 72 74 29 29 29 0a 20 20 date) port))).
9390: 20 28 63 6f 6e 73 20 23 5c 7a 20 28 6c 61 6d 62 (cons #\z (lamb
93a0: 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 da (date pad-wit
93b0: 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 h port)..
93c0: 28 74 6d 3a 74 7a 2d 70 72 69 6e 74 65 72 20 28 (tm:tz-printer (
93d0: 64 61 74 65 2d 7a 6f 6e 65 2d 6f 66 66 73 65 74 date-zone-offset
93e0: 20 64 61 74 65 29 20 70 6f 72 74 29 29 29 0a 20 date) port))).
93f0: 20 20 28 63 6f 6e 73 20 23 5c 5a 20 28 6c 61 6d (cons #\Z (lam
9400: 62 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 bda (date pad-wi
9410: 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 th port)..
9420: 20 28 74 6d 3a 6c 6f 63 61 6c 65 2d 70 72 69 6e (tm:locale-prin
9430: 74 2d 74 69 6d 65 2d 7a 6f 6e 65 20 64 61 74 65 t-time-zone date
9440: 20 70 6f 72 74 29 29 29 0a 20 20 20 28 63 6f 6e port))). (con
9450: 73 20 23 5c 31 20 28 6c 61 6d 62 64 61 20 28 64 s #\1 (lambda (d
9460: 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 6f 72 ate pad-with por
9470: 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 70 t).. (disp
9480: 6c 61 79 20 28 64 61 74 65 2d 3e 73 74 72 69 6e lay (date->strin
9490: 67 20 64 61 74 65 20 22 7e 59 2d 7e 6d 2d 7e 64 g date "~Y-~m-~d
94a0: 22 29 20 70 6f 72 74 29 29 29 0a 20 20 20 28 63 ") port))). (c
94b0: 6f 6e 73 20 23 5c 32 20 28 6c 61 6d 62 64 61 20 ons #\2 (lambda
94c0: 28 64 61 74 65 20 70 61 64 2d 77 69 74 68 20 70 (date pad-with p
94d0: 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 64 69 ort).. (di
94e0: 73 70 6c 61 79 20 28 64 61 74 65 2d 3e 73 74 72 splay (date->str
94f0: 69 6e 67 20 64 61 74 65 20 22 7e 6b 3a 7e 4d 3a ing date "~k:~M:
9500: 7e 53 7e 7a 22 29 20 70 6f 72 74 29 29 29 0a 20 ~S~z") port))).
9510: 20 20 28 63 6f 6e 73 20 23 5c 33 20 28 6c 61 6d (cons #\3 (lam
9520: 62 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 bda (date pad-wi
9530: 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 th port)..
9540: 20 28 64 69 73 70 6c 61 79 20 28 64 61 74 65 2d (display (date-
9550: 3e 73 74 72 69 6e 67 20 64 61 74 65 20 22 7e 6b >string date "~k
9560: 3a 7e 4d 3a 7e 53 22 29 20 70 6f 72 74 29 29 29 :~M:~S") port)))
9570: 0a 20 20 20 28 63 6f 6e 73 20 23 5c 34 20 28 6c . (cons #\4 (l
9580: 61 6d 62 64 61 20 28 64 61 74 65 20 70 61 64 2d ambda (date pad-
9590: 77 69 74 68 20 70 6f 72 74 29 0a 09 20 20 20 20 with port)..
95a0: 20 20 20 28 64 69 73 70 6c 61 79 20 28 64 61 74 (display (dat
95b0: 65 2d 3e 73 74 72 69 6e 67 20 64 61 74 65 20 22 e->string date "
95c0: 7e 59 2d 7e 6d 2d 7e 64 54 7e 6b 3a 7e 4d 3a 7e ~Y-~m-~dT~k:~M:~
95d0: 53 7e 7a 22 29 20 70 6f 72 74 29 29 29 0a 20 20 S~z") port))).
95e0: 20 28 63 6f 6e 73 20 23 5c 35 20 28 6c 61 6d 62 (cons #\5 (lamb
95f0: 64 61 20 28 64 61 74 65 20 70 61 64 2d 77 69 74 da (date pad-wit
9600: 68 20 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 h port)..
9610: 28 64 69 73 70 6c 61 79 20 28 64 61 74 65 2d 3e (display (date->
9620: 73 74 72 69 6e 67 20 64 61 74 65 20 22 7e 59 2d string date "~Y-
9630: 7e 6d 2d 7e 64 54 7e 6b 3a 7e 4d 3a 7e 53 22 29 ~m-~dT~k:~M:~S")
9640: 20 70 6f 72 74 29 29 29 0a 20 20 20 29 29 0a 0a port))). ))..
9650: 0a 28 64 65 66 69 6e 65 20 28 74 6d 3a 67 65 74 .(define (tm:get
9660: 2d 66 6f 72 6d 61 74 74 65 72 20 63 68 61 72 29 -formatter char)
9670: 0a 20 20 28 6c 65 74 20 28 20 28 61 73 73 6f 63 . (let ( (assoc
9680: 69 61 74 65 64 20 28 61 73 73 6f 63 20 63 68 61 iated (assoc cha
9690: 72 20 74 6d 3a 64 69 72 65 63 74 69 76 65 73 29 r tm:directives)
96a0: 29 20 29 0a 20 20 20 20 28 69 66 20 61 73 73 6f ) ). (if asso
96b0: 63 69 61 74 65 64 20 28 63 64 72 20 61 73 73 6f ciated (cdr asso
96c0: 63 69 61 74 65 64 29 20 23 66 29 29 29 0a 0a 28 ciated) #f)))..(
96d0: 64 65 66 69 6e 65 20 28 74 6d 3a 64 61 74 65 2d define (tm:date-
96e0: 70 72 69 6e 74 65 72 20 64 61 74 65 20 69 6e 64 printer date ind
96f0: 65 78 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 ex format-string
9700: 20 73 74 72 2d 6c 65 6e 20 70 6f 72 74 29 0a 20 str-len port).
9710: 20 28 69 66 20 28 3e 3d 20 69 6e 64 65 78 20 73 (if (>= index s
9720: 74 72 2d 6c 65 6e 29 0a 20 20 20 20 20 20 28 76 tr-len). (v
9730: 61 6c 75 65 73 29 0a 20 20 20 20 20 20 28 6c 65 alues). (le
9740: 74 20 28 20 28 63 75 72 72 65 6e 74 2d 63 68 61 t ( (current-cha
9750: 72 20 28 73 74 72 69 6e 67 2d 72 65 66 20 66 6f r (string-ref fo
9760: 72 6d 61 74 2d 73 74 72 69 6e 67 20 69 6e 64 65 rmat-string inde
9770: 78 29 29 20 29 0a 09 28 69 66 20 28 6e 6f 74 20 x)) )..(if (not
9780: 28 63 68 61 72 3d 3f 20 63 75 72 72 65 6e 74 2d (char=? current-
9790: 63 68 61 72 20 23 5c 7e 29 29 0a 09 20 20 20 20 char #\~))..
97a0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
97b0: 69 73 70 6c 61 79 20 63 75 72 72 65 6e 74 2d 63 isplay current-c
97c0: 68 61 72 20 70 6f 72 74 29 0a 09 20 20 20 20 20 har port)..
97d0: 20 28 74 6d 3a 64 61 74 65 2d 70 72 69 6e 74 65 (tm:date-printe
97e0: 72 20 64 61 74 65 20 28 2b 20 69 6e 64 65 78 20 r date (+ index
97f0: 31 29 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 1) format-string
9800: 20 73 74 72 2d 6c 65 6e 20 70 6f 72 74 29 29 0a str-len port)).
9810: 0a 09 20 20 20 20 28 69 66 20 28 3d 20 28 2b 20 .. (if (= (+
9820: 69 6e 64 65 78 20 31 29 20 73 74 72 2d 6c 65 6e index 1) str-len
9830: 29 20 3b 20 62 61 64 20 66 6f 72 6d 61 74 20 73 ) ; bad format s
9840: 74 72 69 6e 67 2e 0a 09 09 28 74 6d 3a 74 69 6d tring....(tm:tim
9850: 65 2d 65 72 72 6f 72 20 27 74 6d 3a 64 61 74 65 e-error 'tm:date
9860: 2d 70 72 69 6e 74 65 72 20 27 62 61 64 2d 64 61 -printer 'bad-da
9870: 74 65 2d 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 te-format-string
9880: 20 0a 09 09 09 20 20 20 20 20 20 20 66 6f 72 6d .... form
9890: 61 74 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 at-string).
98a0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
98b0: 28 20 28 70 61 64 2d 63 68 61 72 3f 20 28 73 74 ( (pad-char? (st
98c0: 72 69 6e 67 2d 72 65 66 20 66 6f 72 6d 61 74 2d ring-ref format-
98d0: 73 74 72 69 6e 67 20 28 2b 20 69 6e 64 65 78 20 string (+ index
98e0: 31 29 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 1))) ).
98f0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
9900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9910: 20 20 20 28 28 63 68 61 72 3d 3f 20 70 61 64 2d ((char=? pad-
9920: 63 68 61 72 3f 20 23 5c 2d 29 0a 20 20 20 20 20 char? #\-).
9930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9940: 28 69 66 20 28 3d 20 28 2b 20 69 6e 64 65 78 20 (if (= (+ index
9950: 32 29 20 73 74 72 2d 6c 65 6e 29 20 3b 20 62 61 2) str-len) ; ba
9960: 64 20 66 6f 72 6d 61 74 20 73 74 72 69 6e 67 2e d format string.
9970: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9980: 20 20 20 20 20 20 20 20 20 20 28 74 6d 3a 74 69 (tm:ti
9990: 6d 65 2d 65 72 72 6f 72 20 27 74 6d 3a 64 61 74 me-error 'tm:dat
99a0: 65 2d 70 72 69 6e 74 65 72 20 27 62 61 64 2d 64 e-printer 'bad-d
99b0: 61 74 65 2d 66 6f 72 6d 61 74 2d 73 74 72 69 6e ate-format-strin
99c0: 67 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 g .
99d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99e0: 20 20 20 20 20 20 20 20 20 20 20 66 6f 72 6d 61 forma
99f0: 74 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 t-string).
9a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a10: 20 20 20 28 6c 65 74 20 28 20 28 66 6f 72 6d 61 (let ( (forma
9a20: 74 74 65 72 20 28 74 6d 3a 67 65 74 2d 66 6f 72 tter (tm:get-for
9a30: 6d 61 74 74 65 72 20 0a 20 20 20 20 20 20 20 20 matter .
9a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a60: 20 20 20 20 28 73 74 72 69 6e 67 2d 72 65 66 20 (string-ref
9a70: 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 0a 20 20 format-string.
9a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ab0: 20 20 20 20 20 20 28 2b 20 69 6e 64 65 78 20 32 (+ index 2
9ac0: 29 29 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 )))) ).
9ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ae0: 20 20 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 61 (if (not forma
9af0: 74 74 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 tter).
9b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b10: 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 (tm:time-er
9b20: 72 6f 72 20 27 74 6d 3a 64 61 74 65 2d 70 72 69 ror 'tm:date-pri
9b30: 6e 74 65 72 20 27 62 61 64 2d 64 61 74 65 2d 66 nter 'bad-date-f
9b40: 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 0a 20 20 ormat-string .
9b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b70: 20 20 20 20 20 20 20 20 20 20 20 20 66 6f 72 6d form
9b80: 61 74 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 at-string).
9b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ba0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
9bb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bd0: 20 20 28 66 6f 72 6d 61 74 74 65 72 20 64 61 74 (formatter dat
9be0: 65 20 23 66 20 70 6f 72 74 29 0a 20 20 20 20 20 e #f port).
9bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c00: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 6d 3a (tm:
9c10: 64 61 74 65 2d 70 72 69 6e 74 65 72 20 64 61 74 date-printer dat
9c20: 65 20 28 2b 20 69 6e 64 65 78 20 33 29 0a 20 20 e (+ index 3).
9c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c60: 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 73 74 format-string st
9c70: 72 2d 6c 65 6e 20 70 6f 72 74 29 29 29 29 29 29 r-len port))))))
9c80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9c90: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
9ca0: 20 20 20 20 20 20 20 20 20 20 28 28 63 68 61 72 ((char
9cb0: 3d 3f 20 70 61 64 2d 63 68 61 72 3f 20 23 5c 5f =? pad-char? #\_
9cc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9cd0: 20 20 20 20 20 20 20 28 69 66 20 28 3d 20 28 2b (if (= (+
9ce0: 20 69 6e 64 65 78 20 32 29 20 73 74 72 2d 6c 65 index 2) str-le
9cf0: 6e 29 20 3b 20 62 61 64 20 66 6f 72 6d 61 74 20 n) ; bad format
9d00: 73 74 72 69 6e 67 2e 0a 20 20 20 20 20 20 20 20 string..
9d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d20: 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 (tm:time-error
9d30: 27 74 6d 3a 64 61 74 65 2d 70 72 69 6e 74 65 72 'tm:date-printer
9d40: 20 27 62 61 64 2d 64 61 74 65 2d 66 6f 72 6d 61 'bad-date-forma
9d50: 74 2d 73 74 72 69 6e 67 20 0a 20 20 20 20 20 20 t-string .
9d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9d80: 20 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 29 format-string)
9d90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9da0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
9db0: 20 28 66 6f 72 6d 61 74 74 65 72 20 28 74 6d 3a (formatter (tm:
9dc0: 67 65 74 2d 66 6f 72 6d 61 74 74 65 72 20 0a 20 get-formatter .
9dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9df0: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
9e00: 6e 67 2d 72 65 66 20 66 6f 72 6d 61 74 2d 73 74 ng-ref format-st
9e10: 72 69 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 ring.
9e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 (+
9e50: 69 6e 64 65 78 20 32 29 29 29 29 20 29 0a 20 20 index 2)))) ).
9e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e70: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
9e80: 74 20 66 6f 72 6d 61 74 74 65 72 29 0a 20 20 20 t formatter).
9e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 6d 3a (tm:
9eb0: 74 69 6d 65 2d 65 72 72 6f 72 20 27 74 6d 3a 64 time-error 'tm:d
9ec0: 61 74 65 2d 70 72 69 6e 74 65 72 20 27 62 61 64 ate-printer 'bad
9ed0: 2d 64 61 74 65 2d 66 6f 72 6d 61 74 2d 73 74 72 -date-format-str
9ee0: 69 6e 67 20 0a 20 20 20 20 20 20 20 20 20 20 20 ing .
9ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f10: 20 20 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 format-string
9f20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f40: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
9f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f60: 20 20 20 20 20 20 20 20 20 28 66 6f 72 6d 61 74 (format
9f70: 74 65 72 20 64 61 74 65 20 23 5c 73 70 61 63 65 ter date #\space
9f80: 20 70 6f 72 74 29 0a 20 20 20 20 20 20 20 20 20 port).
9f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fa0: 20 20 20 20 20 20 20 20 28 74 6d 3a 64 61 74 65 (tm:date
9fb0: 2d 70 72 69 6e 74 65 72 20 64 61 74 65 20 28 2b -printer date (+
9fc0: 20 69 6e 64 65 78 20 33 29 0a 20 20 20 20 20 20 index 3).
9fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ff0: 20 20 20 20 20 20 20 20 20 20 20 20 66 6f 72 6d form
a000: 61 74 2d 73 74 72 69 6e 67 20 73 74 72 2d 6c 65 at-string str-le
a010: 6e 20 70 6f 72 74 29 29 29 29 29 29 0a 20 20 20 n port)))))).
a020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a030: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
a040: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
a050: 20 28 20 28 66 6f 72 6d 61 74 74 65 72 20 28 74 ( (formatter (t
a060: 6d 3a 67 65 74 2d 66 6f 72 6d 61 74 74 65 72 20 m:get-formatter
a070: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a090: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
a0a0: 2d 72 65 66 20 66 6f 72 6d 61 74 2d 73 74 72 69 -ref format-stri
a0b0: 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ng.
a0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0e0: 20 20 20 20 20 20 20 28 2b 20 69 6e 64 65 78 20 (+ index
a0f0: 31 29 29 29 29 20 29 0a 20 20 20 20 20 20 20 20 1)))) ).
a100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a110: 69 66 20 28 6e 6f 74 20 66 6f 72 6d 61 74 74 65 if (not formatte
a120: 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 r).
a130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
a140: 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 74 6d m:time-error 'tm
a150: 3a 64 61 74 65 2d 70 72 69 6e 74 65 72 20 27 62 :date-printer 'b
a160: 61 64 2d 64 61 74 65 2d 66 6f 72 6d 61 74 2d 73 ad-date-format-s
a170: 74 72 69 6e 67 20 0a 20 20 20 20 20 20 20 20 20 tring .
a180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1a0: 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 29 0a format-string).
a1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1c0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
a1d0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
a1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a1f0: 66 6f 72 6d 61 74 74 65 72 20 64 61 74 65 20 23 formatter date #
a200: 5c 30 20 70 6f 72 74 29 0a 20 20 20 20 20 20 20 \0 port).
a210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a220: 20 20 20 20 20 20 28 74 6d 3a 64 61 74 65 2d 70 (tm:date-p
a230: 72 69 6e 74 65 72 20 64 61 74 65 20 28 2b 20 69 rinter date (+ i
a240: 6e 64 65 78 20 32 29 0a 20 20 20 20 20 20 20 20 ndex 2).
a250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a270: 20 20 20 20 20 20 66 6f 72 6d 61 74 2d 73 74 72 format-str
a280: 69 6e 67 20 73 74 72 2d 6c 65 6e 20 70 6f 72 74 ing str-len port
a290: 29 29 29 29 29 29 29 29 29 29 29 29 0a 0a 0a 28 ))))))))))))...(
a2a0: 64 65 66 69 6e 65 20 28 64 61 74 65 2d 3e 73 74 define (date->st
a2b0: 72 69 6e 67 20 64 61 74 65 20 2e 20 20 66 6f 72 ring date . for
a2c0: 6d 61 74 2d 73 74 72 69 6e 67 29 0a 20 20 28 6c mat-string). (l
a2d0: 65 74 20 28 20 28 73 74 72 2d 70 6f 72 74 20 28 et ( (str-port (
a2e0: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 open-output-stri
a2f0: 6e 67 29 29 0a 09 20 28 66 6d 74 2d 73 74 72 20 ng)).. (fmt-str
a300: 28 3a 6f 70 74 69 6f 6e 61 6c 20 66 6f 72 6d 61 (:optional forma
a310: 74 2d 73 74 72 69 6e 67 20 22 7e 63 22 29 29 20 t-string "~c"))
a320: 29 0a 20 20 20 20 28 74 6d 3a 64 61 74 65 2d 70 ). (tm:date-p
a330: 72 69 6e 74 65 72 20 64 61 74 65 20 30 20 66 6d rinter date 0 fm
a340: 74 2d 73 74 72 20 28 73 74 72 69 6e 67 2d 6c 65 t-str (string-le
a350: 6e 67 74 68 20 66 6d 74 2d 73 74 72 29 20 73 74 ngth fmt-str) st
a360: 72 2d 70 6f 72 74 29 0a 20 20 20 20 28 67 65 74 r-port). (get
a370: 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 20 73 -output-string s
a380: 74 72 2d 70 6f 72 74 29 29 29 0a 0a 28 64 65 66 tr-port)))..(def
a390: 69 6e 65 20 28 74 6d 3a 63 68 61 72 2d 3e 69 6e ine (tm:char->in
a3a0: 74 20 63 68 29 0a 20 20 28 63 6f 6e 64 0a 20 20 t ch). (cond.
a3b0: 20 20 28 28 63 68 61 72 3d 3f 20 63 68 20 23 5c ((char=? ch #\
a3c0: 30 29 20 30 29 0a 20 20 20 20 28 28 63 68 61 72 0) 0). ((char
a3d0: 3d 3f 20 63 68 20 23 5c 31 29 20 31 29 0a 20 20 =? ch #\1) 1).
a3e0: 20 20 28 28 63 68 61 72 3d 3f 20 63 68 20 23 5c ((char=? ch #\
a3f0: 32 29 20 32 29 0a 20 20 20 20 28 28 63 68 61 72 2) 2). ((char
a400: 3d 3f 20 63 68 20 23 5c 33 29 20 33 29 0a 20 20 =? ch #\3) 3).
a410: 20 20 28 28 63 68 61 72 3d 3f 20 63 68 20 23 5c ((char=? ch #\
a420: 34 29 20 34 29 0a 20 20 20 20 28 28 63 68 61 72 4) 4). ((char
a430: 3d 3f 20 63 68 20 23 5c 35 29 20 35 29 0a 20 20 =? ch #\5) 5).
a440: 20 20 28 28 63 68 61 72 3d 3f 20 63 68 20 23 5c ((char=? ch #\
a450: 36 29 20 36 29 0a 20 20 20 20 28 28 63 68 61 72 6) 6). ((char
a460: 3d 3f 20 63 68 20 23 5c 37 29 20 37 29 0a 20 20 =? ch #\7) 7).
a470: 20 20 28 28 63 68 61 72 3d 3f 20 63 68 20 23 5c ((char=? ch #\
a480: 38 29 20 38 29 0a 20 20 20 20 28 28 63 68 61 72 8) 8). ((char
a490: 3d 3f 20 63 68 20 23 5c 39 29 20 39 29 0a 20 20 =? ch #\9) 9).
a4a0: 20 20 28 65 6c 73 65 20 28 74 6d 3a 74 69 6d 65 (else (tm:time
a4b0: 2d 65 72 72 6f 72 20 27 73 74 72 69 6e 67 2d 3e -error 'string->
a4c0: 64 61 74 65 20 27 62 61 64 2d 64 61 74 65 2d 74 date 'bad-date-t
a4d0: 65 6d 70 6c 61 74 65 2d 73 74 72 69 6e 67 0a 20 emplate-string.
a4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4f0: 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 4e (list "N
a500: 6f 6e 2d 69 6e 74 65 67 65 72 20 63 68 61 72 61 on-integer chara
a510: 63 74 65 72 22 20 63 68 20 29 29 29 29 29 0a 0a cter" ch )))))..
a520: 3b 3b 20 72 65 61 64 20 61 6e 20 69 6e 74 65 67 ;; read an integ
a530: 65 72 20 75 70 74 6f 20 6e 20 63 68 61 72 61 63 er upto n charac
a540: 74 65 72 73 20 6c 6f 6e 67 20 6f 6e 20 70 6f 72 ters long on por
a550: 74 3b 20 75 70 74 6f 20 2d 3e 20 23 66 20 69 66 t; upto -> #f if
a560: 20 61 6e 79 20 6c 65 6e 67 74 68 0a 28 64 65 66 any length.(def
a570: 69 6e 65 20 28 74 6d 3a 69 6e 74 65 67 65 72 2d ine (tm:integer-
a580: 72 65 61 64 65 72 20 75 70 74 6f 20 70 6f 72 74 reader upto port
a590: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 61 63 63 ). (define (acc
a5a0: 75 6d 2d 69 6e 74 20 70 6f 72 74 20 61 63 63 75 um-int port accu
a5b0: 6d 20 6e 63 68 61 72 73 29 0a 20 20 20 20 28 6c m nchars). (l
a5c0: 65 74 20 28 28 63 68 20 28 70 65 65 6b 2d 63 68 et ((ch (peek-ch
a5d0: 61 72 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 ar port))).
a5e0: 20 28 69 66 20 28 6f 72 20 28 65 6f 66 2d 6f 62 (if (or (eof-ob
a5f0: 6a 65 63 74 3f 20 63 68 29 0a 20 20 20 20 20 20 ject? ch).
a600: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 63 68 (not (ch
a610: 61 72 2d 6e 75 6d 65 72 69 63 3f 20 63 68 29 29 ar-numeric? ch))
a620: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
a630: 61 6e 64 20 75 70 74 6f 20 28 3e 3d 20 6e 63 68 and upto (>= nch
a640: 61 72 73 20 20 75 70 74 6f 20 29 29 29 0a 20 20 ars upto ))).
a650: 20 20 20 20 20 20 20 20 61 63 63 75 6d 0a 20 20 accum.
a660: 20 20 20 20 20 20 20 20 28 61 63 63 75 6d 2d 69 (accum-i
a670: 6e 74 20 70 6f 72 74 20 28 2b 20 28 2a 20 61 63 nt port (+ (* ac
a680: 63 75 6d 20 31 30 29 20 28 74 6d 3a 63 68 61 72 cum 10) (tm:char
a690: 2d 3e 69 6e 74 20 28 72 65 61 64 2d 63 68 61 72 ->int (read-char
a6a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a6b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6d0: 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 29 29 port))
a6e0: 29 20 28 2b 0a 20 20 20 20 20 20 20 20 20 20 20 ) (+.
a6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a720: 20 20 20 20 20 20 20 6e 63 68 61 72 73 20 31 29 nchars 1)
a730: 29 29 29 29 0a 20 20 28 61 63 63 75 6d 2d 69 6e )))). (accum-in
a740: 74 20 70 6f 72 74 20 30 20 30 29 29 0a 0a 28 64 t port 0 0))..(d
a750: 65 66 69 6e 65 20 28 74 6d 3a 6d 61 6b 65 2d 69 efine (tm:make-i
a760: 6e 74 65 67 65 72 2d 72 65 61 64 65 72 20 75 70 nteger-reader up
a770: 74 6f 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 70 to). (lambda (p
a780: 6f 72 74 29 0a 20 20 20 20 28 74 6d 3a 69 6e 74 ort). (tm:int
a790: 65 67 65 72 2d 72 65 61 64 65 72 20 75 70 74 6f eger-reader upto
a7a0: 20 70 6f 72 74 29 29 29 0a 0a 3b 3b 20 72 65 61 port)))..;; rea
a7b0: 64 20 61 6e 20 66 72 61 63 74 69 6f 6e 61 6c 20 d an fractional
a7c0: 69 6e 74 65 67 65 72 20 75 70 74 6f 20 6e 20 63 integer upto n c
a7d0: 68 61 72 61 63 74 65 72 73 20 6c 6f 6e 67 20 6f haracters long o
a7e0: 6e 20 70 6f 72 74 3b 20 75 70 74 6f 20 2d 3e 20 n port; upto ->
a7f0: 23 66 20 69 66 20 61 6e 79 20 6c 65 6e 67 74 68 #f if any length
a800: 0a 3b 3b 0a 3b 3b 20 54 68 65 20 72 65 74 75 72 .;;.;; The retur
a810: 6e 20 76 61 6c 75 65 20 69 73 20 6e 6f 72 6d 61 n value is norma
a820: 6c 69 7a 65 64 20 74 6f 20 75 70 74 6f 20 64 65 lized to upto de
a830: 63 69 6d 61 6c 20 70 6c 61 63 65 73 2e 20 46 6f cimal places. Fo
a840: 72 20 65 78 61 6d 70 6c 65 2c 20 69 66 20 75 70 r example, if up
a850: 74 6f 20 69 73 20 39 20 61 6e 64 20 0a 3b 3b 20 to is 9 and .;;
a860: 74 68 65 20 73 74 72 69 6e 67 20 72 65 61 64 20 the string read
a870: 69 73 20 22 31 32 33 22 2c 20 74 68 65 20 72 65 is "123", the re
a880: 74 75 72 6e 20 76 61 6c 75 65 20 69 73 20 31 32 turn value is 12
a890: 33 30 30 30 30 30 30 2e 0a 28 64 65 66 69 6e 65 3000000..(define
a8a0: 20 28 74 6d 3a 66 72 61 63 74 69 6f 6e 61 6c 2d (tm:fractional-
a8b0: 69 6e 74 65 67 65 72 2d 72 65 61 64 65 72 20 75 integer-reader u
a8c0: 70 74 6f 20 70 6f 72 74 29 0a 20 20 28 64 65 66 pto port). (def
a8d0: 69 6e 65 20 28 61 63 63 75 6d 2d 69 6e 74 20 70 ine (accum-int p
a8e0: 6f 72 74 20 61 63 63 75 6d 20 6e 63 68 61 72 73 ort accum nchars
a8f0: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 63 68 20 ). (let ((ch
a900: 28 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 (peek-char port)
a910: 29 29 0a 20 20 20 20 20 28 69 66 20 28 6f 72 20 )). (if (or
a920: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 68 29 (eof-object? ch)
a930: 0a 20 20 20 20 20 09 28 6e 6f 74 20 28 63 68 61 . .(not (cha
a940: 72 2d 6e 75 6d 65 72 69 63 3f 20 63 68 29 29 0a r-numeric? ch)).
a950: 20 20 20 20 20 09 28 61 6e 64 20 75 70 74 6f 20 .(and upto
a960: 28 3e 3d 20 6e 63 68 61 72 73 20 20 75 70 74 6f (>= nchars upto
a970: 20 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 2a ))). (*
a980: 20 61 63 63 75 6d 20 28 65 78 70 74 20 31 30 20 accum (expt 10
a990: 28 2d 20 75 70 74 6f 20 6e 63 68 61 72 73 29 29 (- upto nchars))
a9a0: 29 0a 20 20 20 20 20 20 20 20 20 28 61 63 63 75 ). (accu
a9b0: 6d 2d 69 6e 74 20 70 6f 72 74 20 28 2b 20 28 2a m-int port (+ (*
a9c0: 20 61 63 63 75 6d 20 31 30 29 20 28 74 6d 3a 63 accum 10) (tm:c
a9d0: 68 61 72 2d 3e 69 6e 74 20 28 72 65 61 64 2d 63 har->int (read-c
a9e0: 68 61 72 20 70 6f 72 74 29 29 29 20 28 2b 20 6e har port))) (+ n
a9f0: 63 68 61 72 73 20 31 29 29 29 29 29 0a 20 20 28 chars 1))))). (
aa00: 61 63 63 75 6d 2d 69 6e 74 20 70 6f 72 74 20 30 accum-int port 0
aa10: 20 30 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 0))..(define (t
aa20: 6d 3a 6d 61 6b 65 2d 66 72 61 63 74 69 6f 6e 61 m:make-fractiona
aa30: 6c 2d 69 6e 74 65 67 65 72 2d 72 65 61 64 65 72 l-integer-reader
aa40: 20 75 70 74 6f 29 0a 20 20 28 6c 61 6d 62 64 61 upto). (lambda
aa50: 20 28 70 6f 72 74 29 0a 20 20 20 20 28 74 6d 3a (port). (tm:
aa60: 66 72 61 63 74 69 6f 6e 61 6c 2d 69 6e 74 65 67 fractional-integ
aa70: 65 72 2d 72 65 61 64 65 72 20 75 70 74 6f 20 70 er-reader upto p
aa80: 6f 72 74 29 29 29 0a 0a 0a 3b 3b 20 72 65 61 64 ort)))...;; read
aa90: 20 2a 65 78 61 63 74 6c 79 2a 20 6e 20 63 68 61 *exactly* n cha
aaa0: 72 61 63 74 65 72 73 20 61 6e 64 20 63 6f 6e 76 racters and conv
aab0: 65 72 74 20 74 6f 20 69 6e 74 65 67 65 72 3b 20 ert to integer;
aac0: 63 6f 75 6c 64 20 62 65 20 70 61 64 64 65 64 0a could be padded.
aad0: 28 64 65 66 69 6e 65 20 28 74 6d 3a 69 6e 74 65 (define (tm:inte
aae0: 67 65 72 2d 72 65 61 64 65 72 2d 65 78 61 63 74 ger-reader-exact
aaf0: 20 6e 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 20 n port). (let
ab00: 28 20 28 70 61 64 64 69 6e 67 2d 6f 6b 20 23 74 ( (padding-ok #t
ab10: 29 20 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 ) ). (define
ab20: 28 61 63 63 75 6d 2d 69 6e 74 20 70 6f 72 74 20 (accum-int port
ab30: 61 63 63 75 6d 20 6e 63 68 61 72 73 29 0a 20 20 accum nchars).
ab40: 20 20 20 20 28 6c 65 74 20 28 28 63 68 20 28 70 (let ((ch (p
ab50: 65 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 29 29 eek-char port)))
ab60: 0a 09 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 ..(cond.
ab70: 20 20 28 28 3e 3d 20 6e 63 68 61 72 73 20 6e 29 ((>= nchars n)
ab80: 20 61 63 63 75 6d 29 0a 20 20 20 20 20 20 20 20 accum).
ab90: 20 20 28 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 ((eof-object?
aba0: 63 68 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ch) .
abb0: 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 (tm:time-error '
abc0: 73 74 72 69 6e 67 2d 3e 64 61 74 65 20 27 62 61 string->date 'ba
abd0: 64 2d 64 61 74 65 2d 74 65 6d 70 6c 61 74 65 2d d-date-template-
abe0: 73 74 72 69 6e 67 20 0a 20 20 20 20 20 20 20 20 string .
abf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac00: 20 20 22 50 72 65 6d 61 74 75 72 65 20 65 6e 64 "Premature end
ac10: 69 6e 67 20 74 6f 20 69 6e 74 65 67 65 72 20 72 ing to integer r
ac20: 65 61 64 2e 22 29 29 0a 20 20 20 20 20 20 20 20 ead.")).
ac30: 20 20 28 28 63 68 61 72 2d 6e 75 6d 65 72 69 63 ((char-numeric
ac40: 3f 20 63 68 29 0a 20 20 20 20 20 20 20 20 20 20 ? ch).
ac50: 20 28 73 65 74 21 20 70 61 64 64 69 6e 67 2d 6f (set! padding-o
ac60: 6b 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 k #f).
ac70: 20 28 61 63 63 75 6d 2d 69 6e 74 20 70 6f 72 74 (accum-int port
ac80: 20 28 2b 20 28 2a 20 61 63 63 75 6d 20 31 30 29 (+ (* accum 10)
ac90: 20 28 74 6d 3a 63 68 61 72 2d 3e 69 6e 74 20 28 (tm:char->int (
aca0: 72 65 61 64 2d 63 68 61 72 0a 20 20 20 20 20 20 read-char.
acb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
acc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
acd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ace0: 20 20 20 20 70 6f 72 74 29 29 29 0a 20 20 20 20 port))).
acf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad00: 20 20 28 2b 20 6e 63 68 61 72 73 20 31 29 29 29 (+ nchars 1)))
ad10: 0a 20 20 20 20 20 20 20 20 20 20 28 70 61 64 64 . (padd
ad20: 69 6e 67 2d 6f 6b 0a 20 20 20 20 20 20 20 20 20 ing-ok.
ad30: 20 20 28 72 65 61 64 2d 63 68 61 72 20 70 6f 72 (read-char por
ad40: 74 29 20 3b 20 63 6f 6e 73 75 6d 65 20 70 61 64 t) ; consume pad
ad50: 64 69 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 ding.
ad60: 28 61 63 63 75 6d 2d 69 6e 74 20 70 6f 72 74 20 (accum-int port
ad70: 61 63 63 75 6d 20 28 2b 20 6e 63 68 61 72 73 20 accum (+ nchars
ad80: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 1))). (
ad90: 65 6c 73 65 20 3b 20 70 61 64 64 69 6e 67 20 77 else ; padding w
ada0: 68 65 72 65 20 69 74 20 73 68 6f 75 6c 64 6e 27 here it shouldn'
adb0: 74 20 62 65 0a 20 20 20 20 20 20 20 20 20 20 20 t be.
adc0: 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 (tm:time-error '
add0: 73 74 72 69 6e 67 2d 3e 64 61 74 65 20 27 62 61 string->date 'ba
ade0: 64 2d 64 61 74 65 2d 74 65 6d 70 6c 61 74 65 2d d-date-template-
adf0: 73 74 72 69 6e 67 20 0a 09 09 09 20 20 22 4e 6f string .... "No
ae00: 6e 2d 6e 75 6d 65 72 69 63 20 63 68 61 72 61 63 n-numeric charac
ae10: 74 65 72 73 20 69 6e 20 69 6e 74 65 67 65 72 20 ters in integer
ae20: 72 65 61 64 2e 22 29 29 29 29 29 0a 20 20 20 20 read."))))).
ae30: 28 61 63 63 75 6d 2d 69 6e 74 20 70 6f 72 74 20 (accum-int port
ae40: 30 20 30 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 0 0)))...(define
ae50: 20 28 74 6d 3a 6d 61 6b 65 2d 69 6e 74 65 67 65 (tm:make-intege
ae60: 72 2d 65 78 61 63 74 2d 72 65 61 64 65 72 20 6e r-exact-reader n
ae70: 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 70 6f 72 ). (lambda (por
ae80: 74 29 0a 20 20 20 20 28 74 6d 3a 69 6e 74 65 67 t). (tm:integ
ae90: 65 72 2d 72 65 61 64 65 72 2d 65 78 61 63 74 20 er-reader-exact
aea0: 6e 20 70 6f 72 74 29 29 29 0a 0a 28 64 65 66 69 n port)))..(defi
aeb0: 6e 65 20 28 74 6d 3a 7a 6f 6e 65 2d 72 65 61 64 ne (tm:zone-read
aec0: 65 72 20 70 6f 72 74 29 20 0a 20 20 28 6c 65 74 er port) . (let
aed0: 20 28 20 28 6f 66 66 73 65 74 20 30 29 20 0a 09 ( (offset 0) ..
aee0: 20 28 70 6f 73 69 74 69 76 65 3f 20 23 66 29 20 (positive? #f)
aef0: 29 0a 20 20 20 20 28 6c 65 74 20 28 20 28 63 68 ). (let ( (ch
af00: 20 28 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 (read-char port
af10: 29 29 20 29 0a 20 20 20 20 20 20 28 69 66 20 28 )) ). (if (
af20: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 68 29 0a eof-object? ch).
af30: 09 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f . (tm:time-erro
af40: 72 20 27 73 74 72 69 6e 67 2d 3e 64 61 74 65 20 r 'string->date
af50: 27 62 61 64 2d 64 61 74 65 2d 74 65 6d 70 6c 61 'bad-date-templa
af60: 74 65 2d 73 74 72 69 6e 67 0a 09 09 09 20 28 6c te-string.... (l
af70: 69 73 74 20 22 49 6e 76 61 6c 69 64 20 74 69 6d ist "Invalid tim
af80: 65 20 7a 6f 6e 65 20 2b 2f 2d 22 20 63 68 29 29 e zone +/-" ch))
af90: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 ). (if (or
afa0: 28 63 68 61 72 3d 3f 20 63 68 20 23 5c 5a 29 20 (char=? ch #\Z)
afb0: 28 63 68 61 72 3d 3f 20 63 68 20 23 5c 7a 29 29 (char=? ch #\z))
afc0: 0a 09 20 20 30 0a 09 20 20 28 62 65 67 69 6e 0a .. 0.. (begin.
afd0: 09 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
afe0: 20 20 20 20 20 20 20 20 20 28 28 63 68 61 72 3d ((char=
aff0: 3f 20 63 68 20 23 5c 2b 29 20 28 73 65 74 21 20 ? ch #\+) (set!
b000: 70 6f 73 69 74 69 76 65 3f 20 23 74 29 29 0a 20 positive? #t)).
b010: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
b020: 68 61 72 3d 3f 20 63 68 20 23 5c 2d 29 20 28 73 har=? ch #\-) (s
b030: 65 74 21 20 70 6f 73 69 74 69 76 65 3f 20 23 66 et! positive? #f
b040: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b050: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
b060: 20 20 20 20 20 20 28 74 6d 3a 74 69 6d 65 2d 65 (tm:time-e
b070: 72 72 6f 72 20 27 73 74 72 69 6e 67 2d 3e 64 61 rror 'string->da
b080: 74 65 20 27 62 61 64 2d 64 61 74 65 2d 74 65 6d te 'bad-date-tem
b090: 70 6c 61 74 65 2d 73 74 72 69 6e 67 0a 20 20 20 plate-string.
b0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0b0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
b0c0: 20 22 49 6e 76 61 6c 69 64 20 74 69 6d 65 20 7a "Invalid time z
b0d0: 6f 6e 65 20 2b 2f 2d 22 20 63 68 29 29 29 29 0a one +/-" ch)))).
b0e0: 09 20 20 20 20 28 6c 65 74 20 28 28 63 68 20 28 . (let ((ch (
b0f0: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 29 read-char port))
b100: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 65 6f ).. (if (eo
b110: 66 2d 6f 62 6a 65 63 74 3f 20 63 68 29 0a 09 09 f-object? ch)...
b120: 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 (tm:time-error
b130: 20 27 73 74 72 69 6e 67 2d 3e 64 61 74 65 20 27 'string->date '
b140: 62 61 64 2d 64 61 74 65 2d 74 65 6d 70 6c 61 74 bad-date-templat
b150: 65 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 e-string.
b160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b170: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
b180: 22 49 6e 76 61 6c 69 64 20 74 69 6d 65 20 7a 6f "Invalid time zo
b190: 6e 65 20 6e 75 6d 62 65 72 22 20 63 68 29 29 29 ne number" ch)))
b1a0: 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 6f 66 .. (set! of
b1b0: 66 73 65 74 20 28 2a 20 28 74 6d 3a 63 68 61 72 fset (* (tm:char
b1c0: 2d 3e 69 6e 74 20 63 68 29 0a 09 09 09 20 20 20 ->int ch)....
b1d0: 20 20 20 31 30 20 36 30 20 36 30 29 29 29 0a 09 10 60 60)))..
b1e0: 20 20 20 20 28 6c 65 74 20 28 28 63 68 20 28 72 (let ((ch (r
b1f0: 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 29 29 ead-char port)))
b200: 0a 09 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 .. (if (eof
b210: 2d 6f 62 6a 65 63 74 3f 20 63 68 29 0a 09 09 20 -object? ch)...
b220: 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 (tm:time-error
b230: 27 73 74 72 69 6e 67 2d 3e 64 61 74 65 20 27 62 'string->date 'b
b240: 61 64 2d 64 61 74 65 2d 74 65 6d 70 6c 61 74 65 ad-date-template
b250: 2d 73 74 72 69 6e 67 0a 09 09 09 09 20 28 6c 69 -string..... (li
b260: 73 74 20 22 49 6e 76 61 6c 69 64 20 74 69 6d 65 st "Invalid time
b270: 20 7a 6f 6e 65 20 6e 75 6d 62 65 72 22 20 63 68 zone number" ch
b280: 29 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 ))).. (set!
b290: 20 6f 66 66 73 65 74 20 28 2b 20 6f 66 66 73 65 offset (+ offse
b2a0: 74 20 28 2a 20 28 74 6d 3a 63 68 61 72 2d 3e 69 t (* (tm:char->i
b2b0: 6e 74 20 63 68 29 0a 09 09 09 09 09 36 30 20 36 nt ch)......60 6
b2c0: 30 29 29 29 29 0a 09 20 20 20 20 28 6c 65 74 20 0)))).. (let
b2d0: 28 28 63 68 20 28 72 65 61 64 2d 63 68 61 72 20 ((ch (read-char
b2e0: 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 20 28 port))).. (
b2f0: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
b300: 63 68 29 0a 09 09 20 20 28 74 6d 3a 74 69 6d 65 ch)... (tm:time
b310: 2d 65 72 72 6f 72 20 27 73 74 72 69 6e 67 2d 3e -error 'string->
b320: 64 61 74 65 20 27 62 61 64 2d 64 61 74 65 2d 74 date 'bad-date-t
b330: 65 6d 70 6c 61 74 65 2d 73 74 72 69 6e 67 0a 09 emplate-string..
b340: 09 09 09 20 28 6c 69 73 74 20 22 49 6e 76 61 6c ... (list "Inval
b350: 69 64 20 74 69 6d 65 20 7a 6f 6e 65 20 6e 75 6d id time zone num
b360: 62 65 72 22 20 63 68 29 29 29 0a 09 20 20 20 20 ber" ch)))..
b370: 20 20 28 73 65 74 21 20 6f 66 66 73 65 74 20 28 (set! offset (
b380: 2b 20 6f 66 66 73 65 74 20 28 2a 20 28 74 6d 3a + offset (* (tm:
b390: 63 68 61 72 2d 3e 69 6e 74 20 63 68 29 0a 09 09 char->int ch)...
b3a0: 09 09 09 31 30 20 36 30 29 29 29 29 0a 09 20 20 ...10 60))))..
b3b0: 20 20 28 6c 65 74 20 28 28 63 68 20 28 72 65 61 (let ((ch (rea
b3c0: 64 2d 63 68 61 72 20 70 6f 72 74 29 29 29 0a 09 d-char port)))..
b3d0: 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
b3e0: 62 6a 65 63 74 3f 20 63 68 29 0a 09 09 20 20 28 bject? ch)... (
b3f0: 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 73 tm:time-error 's
b400: 74 72 69 6e 67 2d 3e 64 61 74 65 20 27 62 61 64 tring->date 'bad
b410: 2d 64 61 74 65 2d 74 65 6d 70 6c 61 74 65 2d 73 -date-template-s
b420: 74 72 69 6e 67 0a 09 09 09 09 20 28 6c 69 73 74 tring..... (list
b430: 20 22 49 6e 76 61 6c 69 64 20 74 69 6d 65 20 7a "Invalid time z
b440: 6f 6e 65 20 6e 75 6d 62 65 72 22 20 63 68 29 29 one number" ch))
b450: 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 6f ).. (set! o
b460: 66 66 73 65 74 20 28 2b 20 6f 66 66 73 65 74 20 ffset (+ offset
b470: 28 2a 20 28 74 6d 3a 63 68 61 72 2d 3e 69 6e 74 (* (tm:char->int
b480: 20 63 68 29 0a 09 09 09 09 09 36 30 29 29 29 29 ch)......60))))
b490: 0a 09 20 20 20 20 28 69 66 20 70 6f 73 69 74 69 .. (if positi
b4a0: 76 65 3f 20 6f 66 66 73 65 74 20 28 2d 20 6f 66 ve? offset (- of
b4b0: 66 73 65 74 29 29 29 29 29 29 29 0a 0a 3b 3b 20 fset)))))))..;;
b4c0: 6c 6f 6f 6b 69 6e 67 20 61 74 20 61 20 63 68 61 looking at a cha
b4d0: 72 2c 20 72 65 61 64 20 74 68 65 20 63 68 61 72 r, read the char
b4e0: 20 73 74 72 69 6e 67 2c 20 72 75 6e 20 74 68 72 string, run thr
b4f0: 75 20 69 6e 64 65 78 65 72 2c 20 72 65 74 75 72 u indexer, retur
b500: 6e 20 69 6e 64 65 78 0a 28 64 65 66 69 6e 65 20 n index.(define
b510: 28 74 6d 3a 6c 6f 63 61 6c 65 2d 72 65 61 64 65 (tm:locale-reade
b520: 72 20 70 6f 72 74 20 69 6e 64 65 78 65 72 29 0a r port indexer).
b530: 20 20 28 6c 65 74 20 28 20 28 73 74 72 69 6e 67 (let ( (string
b540: 2d 70 6f 72 74 20 28 6f 70 65 6e 2d 6f 75 74 70 -port (open-outp
b550: 75 74 2d 73 74 72 69 6e 67 29 29 20 29 0a 20 20 ut-string)) ).
b560: 20 20 28 64 65 66 69 6e 65 20 28 72 65 61 64 2d (define (read-
b570: 63 68 61 72 2d 73 74 72 69 6e 67 29 0a 20 20 20 char-string).
b580: 20 20 20 28 6c 65 74 20 28 28 63 68 20 28 70 65 (let ((ch (pe
b590: 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 29 29 0a ek-char port))).
b5a0: 09 28 69 66 20 28 63 68 61 72 2d 61 6c 70 68 61 .(if (char-alpha
b5b0: 62 65 74 69 63 3f 20 63 68 29 0a 09 20 20 20 20 betic? ch)..
b5c0: 28 62 65 67 69 6e 20 28 77 72 69 74 65 2d 63 68 (begin (write-ch
b5d0: 61 72 20 28 72 65 61 64 2d 63 68 61 72 20 70 6f ar (read-char po
b5e0: 72 74 29 20 73 74 72 69 6e 67 2d 70 6f 72 74 29 rt) string-port)
b5f0: 20 0a 09 09 20 20 20 28 72 65 61 64 2d 63 68 61 ... (read-cha
b600: 72 2d 73 74 72 69 6e 67 29 29 0a 09 20 20 20 20 r-string))..
b610: 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 69 (get-output-stri
b620: 6e 67 20 73 74 72 69 6e 67 2d 70 6f 72 74 29 29 ng string-port))
b630: 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 20 28 )). (let* ( (
b640: 73 74 72 20 28 72 65 61 64 2d 63 68 61 72 2d 73 str (read-char-s
b650: 74 72 69 6e 67 29 29 20 0a 09 20 20 20 20 28 69 tring)) .. (i
b660: 6e 64 65 78 20 28 69 6e 64 65 78 65 72 20 73 74 ndex (indexer st
b670: 72 29 29 20 29 0a 20 20 20 20 20 20 28 69 66 20 r)) ). (if
b680: 69 6e 64 65 78 20 69 6e 64 65 78 20 28 74 6d 3a index index (tm:
b690: 74 69 6d 65 2d 65 72 72 6f 72 20 27 73 74 72 69 time-error 'stri
b6a0: 6e 67 2d 3e 64 61 74 65 0a 09 09 09 09 20 20 20 ng->date.....
b6b0: 20 20 27 62 61 64 2d 64 61 74 65 2d 74 65 6d 70 'bad-date-temp
b6c0: 6c 61 74 65 2d 73 74 72 69 6e 67 0a 09 09 09 09 late-string.....
b6d0: 20 20 20 20 20 28 6c 69 73 74 20 22 49 6e 76 61 (list "Inva
b6e0: 6c 69 64 20 73 74 72 69 6e 67 20 66 6f 72 20 22 lid string for "
b6f0: 20 69 6e 64 65 78 65 72 29 29 29 29 29 29 0a 0a indexer))))))..
b700: 28 64 65 66 69 6e 65 20 28 74 6d 3a 6d 61 6b 65 (define (tm:make
b710: 2d 6c 6f 63 61 6c 65 2d 72 65 61 64 65 72 20 69 -locale-reader i
b720: 6e 64 65 78 65 72 29 0a 20 20 28 6c 61 6d 62 64 ndexer). (lambd
b730: 61 20 28 70 6f 72 74 29 0a 20 20 20 20 28 74 6d a (port). (tm
b740: 3a 6c 6f 63 61 6c 65 2d 72 65 61 64 65 72 20 70 :locale-reader p
b750: 6f 72 74 20 69 6e 64 65 78 65 72 29 29 29 0a 0a ort indexer)))..
b760: 28 64 65 66 69 6e 65 20 28 74 6d 3a 6d 61 6b 65 (define (tm:make
b770: 2d 63 68 61 72 2d 69 64 2d 72 65 61 64 65 72 20 -char-id-reader
b780: 63 68 61 72 29 0a 20 20 28 6c 61 6d 62 64 61 20 char). (lambda
b790: 28 70 6f 72 74 29 0a 20 20 20 20 28 69 66 20 28 (port). (if (
b7a0: 63 68 61 72 3d 3f 20 63 68 61 72 20 28 72 65 61 char=? char (rea
b7b0: 64 2d 63 68 61 72 20 70 6f 72 74 29 29 0a 09 63 d-char port))..c
b7c0: 68 61 72 0a 09 28 74 6d 3a 74 69 6d 65 2d 65 72 har..(tm:time-er
b7d0: 72 6f 72 20 27 73 74 72 69 6e 67 2d 3e 64 61 74 ror 'string->dat
b7e0: 65 0a 09 09 20 20 20 20 20 20 20 27 62 61 64 2d e... 'bad-
b7f0: 64 61 74 65 2d 74 65 6d 70 6c 61 74 65 2d 73 74 date-template-st
b800: 72 69 6e 67 0a 09 09 20 20 20 20 20 20 20 22 49 ring... "I
b810: 6e 76 61 6c 69 64 20 63 68 61 72 61 63 74 65 72 nvalid character
b820: 20 6d 61 74 63 68 2e 22 29 29 29 29 0a 0a 3b 3b match."))))..;;
b830: 20 41 20 4c 69 73 74 20 6f 66 20 66 6f 72 6d 61 A List of forma
b840: 74 74 65 64 20 72 65 61 64 20 64 69 72 65 63 74 tted read direct
b850: 69 76 65 73 2e 0a 3b 3b 20 45 61 63 68 20 65 6e ives..;; Each en
b860: 74 72 79 20 69 73 20 61 20 6c 69 73 74 2e 0a 3b try is a list..;
b870: 3b 20 31 2e 20 74 68 65 20 63 68 61 72 61 63 74 ; 1. the charact
b880: 65 72 20 64 69 72 65 63 74 69 76 65 3b 20 0a 3b er directive; .;
b890: 3b 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 ; a procedure, w
b8a0: 68 69 63 68 20 74 61 6b 65 73 20 61 20 63 68 61 hich takes a cha
b8b0: 72 61 63 74 65 72 20 61 73 20 69 6e 70 75 74 20 racter as input
b8c0: 26 20 72 65 74 75 72 6e 73 0a 3b 3b 20 32 2e 20 & returns.;; 2.
b8d0: 23 74 20 61 73 20 73 6f 6f 6e 20 61 73 20 61 20 #t as soon as a
b8e0: 63 68 61 72 61 63 74 65 72 20 6f 6e 20 74 68 65 character on the
b8f0: 20 69 6e 70 75 74 20 70 6f 72 74 20 69 73 20 61 input port is a
b900: 63 63 65 70 74 61 62 6c 65 0a 3b 3b 20 66 6f 72 cceptable.;; for
b910: 20 69 6e 70 75 74 2c 0a 3b 3b 20 33 2e 20 61 20 input,.;; 3. a
b920: 70 6f 72 74 20 72 65 61 64 65 72 20 70 72 6f 63 port reader proc
b930: 65 64 75 72 65 20 74 68 61 74 20 6b 6e 6f 77 73 edure that knows
b940: 20 68 6f 77 20 74 6f 20 72 65 61 64 20 74 68 65 how to read the
b950: 20 63 75 72 72 65 6e 74 20 70 6f 72 74 0a 3b 3b current port.;;
b960: 20 66 6f 72 20 61 20 76 61 6c 75 65 2e 20 49 74 for a value. It
b970: 73 20 6f 6e 65 20 70 61 72 61 6d 65 74 65 72 20 s one parameter
b980: 69 73 20 74 68 65 20 70 6f 72 74 2e 0a 3b 3b 20 is the port..;;
b990: 34 2e 20 61 20 61 63 74 69 6f 6e 20 70 72 6f 63 4. a action proc
b9a0: 65 64 75 72 65 2c 20 74 68 61 74 20 74 61 6b 65 edure, that take
b9b0: 73 20 74 68 65 20 76 61 6c 75 65 20 28 66 72 6f s the value (fro
b9c0: 6d 20 33 2e 29 20 61 6e 64 20 73 6f 6d 65 0a 3b m 3.) and some.;
b9d0: 3b 20 6f 62 6a 65 63 74 20 28 68 65 72 65 2c 20 ; object (here,
b9e0: 61 6c 77 61 79 73 20 74 68 65 20 64 61 74 65 29 always the date)
b9f0: 20 61 6e 64 20 28 70 72 6f 62 61 62 6c 79 29 20 and (probably)
ba00: 73 69 64 65 2d 65 66 66 65 63 74 73 20 69 74 2e side-effects it.
ba10: 0a 3b 3b 20 49 6e 20 73 6f 6d 65 20 63 61 73 65 .;; In some case
ba20: 73 20 28 65 2e 67 2e 2c 20 7e 41 29 20 74 68 65 s (e.g., ~A) the
ba30: 20 61 63 74 69 6f 6e 20 69 73 20 74 6f 20 64 6f action is to do
ba40: 20 6e 6f 74 68 69 6e 67 0a 0a 28 64 65 66 69 6e nothing..(defin
ba50: 65 20 74 6d 3a 72 65 61 64 2d 64 69 72 65 63 74 e tm:read-direct
ba60: 69 76 65 73 20 0a 20 20 28 6c 65 74 20 28 20 28 ives . (let ( (
ba70: 69 72 65 61 64 65 72 34 20 28 74 6d 3a 6d 61 6b ireader4 (tm:mak
ba80: 65 2d 69 6e 74 65 67 65 72 2d 72 65 61 64 65 72 e-integer-reader
ba90: 20 34 29 29 0a 09 20 28 69 72 65 61 64 65 72 32 4)).. (ireader2
baa0: 20 28 74 6d 3a 6d 61 6b 65 2d 69 6e 74 65 67 65 (tm:make-intege
bab0: 72 2d 72 65 61 64 65 72 20 32 29 29 0a 09 20 28 r-reader 2)).. (
bac0: 66 69 72 65 61 64 65 72 39 20 28 74 6d 3a 6d 61 fireader9 (tm:ma
bad0: 6b 65 2d 66 72 61 63 74 69 6f 6e 61 6c 2d 69 6e ke-fractional-in
bae0: 74 65 67 65 72 2d 72 65 61 64 65 72 20 39 29 29 teger-reader 9))
baf0: 0a 09 20 28 69 72 65 61 64 65 72 66 20 28 74 6d .. (ireaderf (tm
bb00: 3a 6d 61 6b 65 2d 69 6e 74 65 67 65 72 2d 72 65 :make-integer-re
bb10: 61 64 65 72 20 23 66 29 29 0a 09 20 28 65 69 72 ader #f)).. (eir
bb20: 65 61 64 65 72 32 20 28 74 6d 3a 6d 61 6b 65 2d eader2 (tm:make-
bb30: 69 6e 74 65 67 65 72 2d 65 78 61 63 74 2d 72 65 integer-exact-re
bb40: 61 64 65 72 20 32 29 29 0a 09 20 28 65 69 72 65 ader 2)).. (eire
bb50: 61 64 65 72 34 20 28 74 6d 3a 6d 61 6b 65 2d 69 ader4 (tm:make-i
bb60: 6e 74 65 67 65 72 2d 65 78 61 63 74 2d 72 65 61 nteger-exact-rea
bb70: 64 65 72 20 34 29 29 0a 09 20 28 6c 6f 63 61 6c der 4)).. (local
bb80: 65 2d 72 65 61 64 65 72 2d 61 62 62 72 2d 77 65 e-reader-abbr-we
bb90: 65 6b 64 61 79 20 28 74 6d 3a 6d 61 6b 65 2d 6c ekday (tm:make-l
bba0: 6f 63 61 6c 65 2d 72 65 61 64 65 72 0a 09 09 09 ocale-reader....
bbb0: 09 20 20 20 20 20 20 74 6d 3a 6c 6f 63 61 6c 65 . tm:locale
bbc0: 2d 61 62 62 72 2d 77 65 65 6b 64 61 79 2d 3e 69 -abbr-weekday->i
bbd0: 6e 64 65 78 29 29 0a 09 20 28 6c 6f 63 61 6c 65 ndex)).. (locale
bbe0: 2d 72 65 61 64 65 72 2d 6c 6f 6e 67 2d 77 65 65 -reader-long-wee
bbf0: 6b 64 61 79 20 28 74 6d 3a 6d 61 6b 65 2d 6c 6f kday (tm:make-lo
bc00: 63 61 6c 65 2d 72 65 61 64 65 72 0a 09 09 09 09 cale-reader.....
bc10: 20 20 20 20 20 20 74 6d 3a 6c 6f 63 61 6c 65 2d tm:locale-
bc20: 6c 6f 6e 67 2d 77 65 65 6b 64 61 79 2d 3e 69 6e long-weekday->in
bc30: 64 65 78 29 29 0a 09 20 28 6c 6f 63 61 6c 65 2d dex)).. (locale-
bc40: 72 65 61 64 65 72 2d 61 62 62 72 2d 6d 6f 6e 74 reader-abbr-mont
bc50: 68 20 20 20 28 74 6d 3a 6d 61 6b 65 2d 6c 6f 63 h (tm:make-loc
bc60: 61 6c 65 2d 72 65 61 64 65 72 0a 09 09 09 09 20 ale-reader.....
bc70: 20 20 20 20 20 74 6d 3a 6c 6f 63 61 6c 65 2d 61 tm:locale-a
bc80: 62 62 72 2d 6d 6f 6e 74 68 2d 3e 69 6e 64 65 78 bbr-month->index
bc90: 29 29 0a 09 20 28 6c 6f 63 61 6c 65 2d 72 65 61 )).. (locale-rea
bca0: 64 65 72 2d 6c 6f 6e 67 2d 6d 6f 6e 74 68 20 20 der-long-month
bcb0: 20 28 74 6d 3a 6d 61 6b 65 2d 6c 6f 63 61 6c 65 (tm:make-locale
bcc0: 2d 72 65 61 64 65 72 0a 09 09 09 09 20 20 20 20 -reader.....
bcd0: 20 20 74 6d 3a 6c 6f 63 61 6c 65 2d 6c 6f 6e 67 tm:locale-long
bce0: 2d 6d 6f 6e 74 68 2d 3e 69 6e 64 65 78 29 29 0a -month->index)).
bcf0: 09 20 28 63 68 61 72 2d 66 61 69 6c 20 28 6c 61 . (char-fail (la
bd00: 6d 62 64 61 20 28 63 68 29 20 23 74 29 29 0a 09 mbda (ch) #t))..
bd10: 20 28 64 6f 2d 6e 6f 74 68 69 6e 67 20 28 6c 61 (do-nothing (la
bd20: 6d 62 64 61 20 28 76 61 6c 20 6f 62 6a 65 63 74 mbda (val object
bd30: 29 20 28 76 61 6c 75 65 73 29 29 29 0a 09 20 29 ) (values))).. )
bd40: 0a 20 20 20 20 0a 20 20 20 20 28 6c 69 73 74 0a . . (list.
bd50: 20 20 20 20 20 28 6c 69 73 74 20 23 5c 7e 20 63 (list #\~ c
bd60: 68 61 72 2d 66 61 69 6c 20 28 74 6d 3a 6d 61 6b har-fail (tm:mak
bd70: 65 2d 63 68 61 72 2d 69 64 2d 72 65 61 64 65 72 e-char-id-reader
bd80: 20 23 5c 7e 29 20 64 6f 2d 6e 6f 74 68 69 6e 67 #\~) do-nothing
bd90: 29 0a 20 20 20 20 20 28 6c 69 73 74 20 23 5c 61 ). (list #\a
bda0: 20 63 68 61 72 2d 61 6c 70 68 61 62 65 74 69 63 char-alphabetic
bdb0: 3f 20 6c 6f 63 61 6c 65 2d 72 65 61 64 65 72 2d ? locale-reader-
bdc0: 61 62 62 72 2d 77 65 65 6b 64 61 79 20 64 6f 2d abbr-weekday do-
bdd0: 6e 6f 74 68 69 6e 67 29 0a 20 20 20 20 20 28 6c nothing). (l
bde0: 69 73 74 20 23 5c 41 20 63 68 61 72 2d 61 6c 70 ist #\A char-alp
bdf0: 68 61 62 65 74 69 63 3f 20 6c 6f 63 61 6c 65 2d habetic? locale-
be00: 72 65 61 64 65 72 2d 6c 6f 6e 67 2d 77 65 65 6b reader-long-week
be10: 64 61 79 20 64 6f 2d 6e 6f 74 68 69 6e 67 29 0a day do-nothing).
be20: 20 20 20 20 20 28 6c 69 73 74 20 23 5c 62 20 63 (list #\b c
be30: 68 61 72 2d 61 6c 70 68 61 62 65 74 69 63 3f 20 har-alphabetic?
be40: 6c 6f 63 61 6c 65 2d 72 65 61 64 65 72 2d 61 62 locale-reader-ab
be50: 62 72 2d 6d 6f 6e 74 68 0a 20 20 20 20 20 20 20 br-month.
be60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 6c (lambda (val
be70: 20 6f 62 6a 65 63 74 29 0a 20 20 20 20 20 20 20 object).
be80: 20 20 20 20 20 20 28 74 6d 3a 73 65 74 2d 64 61 (tm:set-da
be90: 74 65 2d 6d 6f 6e 74 68 21 20 6f 62 6a 65 63 74 te-month! object
bea0: 20 76 61 6c 29 29 29 0a 20 20 20 20 20 28 6c 69 val))). (li
beb0: 73 74 20 23 5c 42 20 63 68 61 72 2d 61 6c 70 68 st #\B char-alph
bec0: 61 62 65 74 69 63 3f 20 6c 6f 63 61 6c 65 2d 72 abetic? locale-r
bed0: 65 61 64 65 72 2d 6c 6f 6e 67 2d 6d 6f 6e 74 68 eader-long-month
bee0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d . (lam
bef0: 62 64 61 20 28 76 61 6c 20 6f 62 6a 65 63 74 29 bda (val object)
bf00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 . (t
bf10: 6d 3a 73 65 74 2d 64 61 74 65 2d 6d 6f 6e 74 68 m:set-date-month
bf20: 21 20 6f 62 6a 65 63 74 20 76 61 6c 29 29 29 0a ! object val))).
bf30: 20 20 20 20 20 28 6c 69 73 74 20 23 5c 64 20 63 (list #\d c
bf40: 68 61 72 2d 6e 75 6d 65 72 69 63 3f 20 69 72 65 har-numeric? ire
bf50: 61 64 65 72 32 20 28 6c 61 6d 62 64 61 20 28 76 ader2 (lambda (v
bf60: 61 6c 20 6f 62 6a 65 63 74 29 0a 20 20 20 20 20 al object).
bf70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf90: 20 20 20 28 74 6d 3a 73 65 74 2d 64 61 74 65 2d (tm:set-date-
bfa0: 64 61 79 21 0a 20 20 20 20 20 20 20 20 20 20 20 day!.
bfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 62 ob
bfd0: 6a 65 63 74 20 76 61 6c 29 29 29 0a 20 20 20 20 ject val))).
bfe0: 20 28 6c 69 73 74 20 23 5c 65 20 63 68 61 72 2d (list #\e char-
bff0: 66 61 69 6c 20 65 69 72 65 61 64 65 72 32 20 28 fail eireader2 (
c000: 6c 61 6d 62 64 61 20 28 76 61 6c 20 6f 62 6a 65 lambda (val obje
c010: 63 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ct).
c020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c030: 20 20 20 20 20 20 20 20 20 28 74 6d 3a 73 65 74 (tm:set
c040: 2d 64 61 74 65 2d 64 61 79 21 20 6f 62 6a 65 63 -date-day! objec
c050: 74 20 76 61 6c 29 29 29 0a 20 20 20 20 20 28 6c t val))). (l
c060: 69 73 74 20 23 5c 68 20 63 68 61 72 2d 61 6c 70 ist #\h char-alp
c070: 68 61 62 65 74 69 63 3f 20 6c 6f 63 61 6c 65 2d habetic? locale-
c080: 72 65 61 64 65 72 2d 61 62 62 72 2d 6d 6f 6e 74 reader-abbr-mont
c090: 68 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 h. (la
c0a0: 6d 62 64 61 20 28 76 61 6c 20 6f 62 6a 65 63 74 mbda (val object
c0b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
c0c0: 74 6d 3a 73 65 74 2d 64 61 74 65 2d 6d 6f 6e 74 tm:set-date-mont
c0d0: 68 21 20 6f 62 6a 65 63 74 20 76 61 6c 29 29 29 h! object val)))
c0e0: 0a 20 20 20 20 20 28 6c 69 73 74 20 23 5c 48 20 . (list #\H
c0f0: 63 68 61 72 2d 6e 75 6d 65 72 69 63 3f 20 69 72 char-numeric? ir
c100: 65 61 64 65 72 32 20 28 6c 61 6d 62 64 61 20 28 eader2 (lambda (
c110: 76 61 6c 20 6f 62 6a 65 63 74 29 0a 20 20 20 20 val object).
c120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c140: 20 20 20 20 28 74 6d 3a 73 65 74 2d 64 61 74 65 (tm:set-date
c150: 2d 68 6f 75 72 21 20 6f 62 6a 65 63 74 20 76 61 -hour! object va
c160: 6c 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 l))). (list
c170: 23 5c 6b 20 63 68 61 72 2d 66 61 69 6c 20 65 69 #\k char-fail ei
c180: 72 65 61 64 65 72 32 20 28 6c 61 6d 62 64 61 20 reader2 (lambda
c190: 28 76 61 6c 20 6f 62 6a 65 63 74 29 0a 20 20 20 (val object).
c1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1c0: 20 20 28 74 6d 3a 73 65 74 2d 64 61 74 65 2d 68 (tm:set-date-h
c1d0: 6f 75 72 21 20 6f 62 6a 65 63 74 20 76 61 6c 29 our! object val)
c1e0: 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 23 5c )). (list #\
c1f0: 6d 20 63 68 61 72 2d 6e 75 6d 65 72 69 63 3f 20 m char-numeric?
c200: 69 72 65 61 64 65 72 32 20 28 6c 61 6d 62 64 61 ireader2 (lambda
c210: 20 28 76 61 6c 20 6f 62 6a 65 63 74 29 0a 20 20 (val object).
c220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c240: 20 20 20 20 20 20 28 74 6d 3a 73 65 74 2d 64 61 (tm:set-da
c250: 74 65 2d 6d 6f 6e 74 68 21 20 6f 62 6a 65 63 74 te-month! object
c260: 20 76 61 6c 29 29 29 0a 20 20 20 20 20 28 6c 69 val))). (li
c270: 73 74 20 23 5c 4d 20 63 68 61 72 2d 6e 75 6d 65 st #\M char-nume
c280: 72 69 63 3f 20 69 72 65 61 64 65 72 32 20 28 6c ric? ireader2 (l
c290: 61 6d 62 64 61 20 28 76 61 6c 20 6f 62 6a 65 63 ambda (val objec
c2a0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
c2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c2c0: 20 20 20 20 20 20 20 20 20 20 20 28 74 6d 3a 73 (tm:s
c2d0: 65 74 2d 64 61 74 65 2d 6d 69 6e 75 74 65 21 0a et-date-minute!.
c2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c300: 20 20 20 20 20 20 20 20 20 6f 62 6a 65 63 74 20 object
c310: 76 61 6c 29 29 29 0a 20 20 20 20 20 28 6c 69 73 val))). (lis
c320: 74 20 23 5c 4e 20 63 68 61 72 2d 6e 75 6d 65 72 t #\N char-numer
c330: 69 63 3f 20 66 69 72 65 61 64 65 72 39 20 28 6c ic? fireader9 (l
c340: 61 6d 62 64 61 20 28 76 61 6c 20 6f 62 6a 65 63 ambda (val objec
c350: 74 29 0a 09 09 09 09 09 20 28 74 6d 3a 73 65 74 t)...... (tm:set
c360: 2d 64 61 74 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 -date-nanosecond
c370: 21 20 6f 62 6a 65 63 74 20 76 61 6c 29 29 29 0a ! object val))).
c380: 20 20 20 20 20 28 6c 69 73 74 20 23 5c 53 20 63 (list #\S c
c390: 68 61 72 2d 6e 75 6d 65 72 69 63 3f 20 69 72 65 har-numeric? ire
c3a0: 61 64 65 72 32 20 28 6c 61 6d 62 64 61 20 28 76 ader2 (lambda (v
c3b0: 61 6c 20 6f 62 6a 65 63 74 29 0a 20 20 20 20 20 al object).
c3c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c3e0: 20 20 20 28 74 6d 3a 73 65 74 2d 64 61 74 65 2d (tm:set-date-
c3f0: 73 65 63 6f 6e 64 21 20 6f 62 6a 65 63 74 20 76 second! object v
c400: 61 6c 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 al))). (list
c410: 20 23 5c 79 20 63 68 61 72 2d 66 61 69 6c 20 65 #\y char-fail e
c420: 69 72 65 61 64 65 72 32 20 0a 20 20 20 20 20 20 ireader2 .
c430: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 (lambda (va
c440: 6c 20 6f 62 6a 65 63 74 29 0a 20 20 20 20 20 20 l object).
c450: 20 20 20 20 20 20 20 28 74 6d 3a 73 65 74 2d 64 (tm:set-d
c460: 61 74 65 2d 79 65 61 72 21 20 6f 62 6a 65 63 74 ate-year! object
c470: 20 28 74 6d 3a 6e 61 74 75 72 61 6c 2d 79 65 61 (tm:natural-yea
c480: 72 20 76 61 6c 29 29 29 29 0a 20 20 20 20 20 28 r val)))). (
c490: 6c 69 73 74 20 23 5c 59 20 63 68 61 72 2d 6e 75 list #\Y char-nu
c4a0: 6d 65 72 69 63 3f 20 69 72 65 61 64 65 72 34 20 meric? ireader4
c4b0: 28 6c 61 6d 62 64 61 20 28 76 61 6c 20 6f 62 6a (lambda (val obj
c4c0: 65 63 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ect).
c4d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 6d (tm
c4f0: 3a 73 65 74 2d 64 61 74 65 2d 79 65 61 72 21 20 :set-date-year!
c500: 6f 62 6a 65 63 74 20 76 61 6c 29 29 29 0a 20 20 object val))).
c510: 20 20 20 28 6c 69 73 74 20 23 5c 7a 20 28 6c 61 (list #\z (la
c520: 6d 62 64 61 20 28 63 29 0a 20 20 20 20 20 20 20 mbda (c).
c530: 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 63 (or (c
c540: 68 61 72 3d 3f 20 63 20 23 5c 5a 29 0a 20 20 20 har=? c #\Z).
c550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c560: 20 20 28 63 68 61 72 3d 3f 20 63 20 23 5c 7a 29 (char=? c #\z)
c570: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c580: 20 20 20 20 20 20 28 63 68 61 72 3d 3f 20 63 20 (char=? c
c590: 23 5c 2b 29 0a 20 20 20 20 20 20 20 20 20 20 20 #\+).
c5a0: 20 20 20 20 20 20 20 20 20 20 28 63 68 61 72 3d (char=
c5b0: 3f 20 63 20 23 5c 2d 29 29 29 0a 20 20 20 20 20 ? c #\-))).
c5c0: 20 20 20 20 20 20 74 6d 3a 7a 6f 6e 65 2d 72 65 tm:zone-re
c5d0: 61 64 65 72 20 28 6c 61 6d 62 64 61 20 28 76 61 ader (lambda (va
c5e0: 6c 20 6f 62 6a 65 63 74 29 0a 20 20 20 20 20 20 l object).
c5f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c600: 20 20 20 20 20 20 28 74 6d 3a 73 65 74 2d 64 61 (tm:set-da
c610: 74 65 2d 7a 6f 6e 65 2d 6f 66 66 73 65 74 21 20 te-zone-offset!
c620: 6f 62 6a 65 63 74 20 76 61 6c 29 29 29 0a 20 20 object val))).
c630: 20 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 )))..(define
c640: 28 74 6d 3a 73 74 72 69 6e 67 2d 3e 64 61 74 65 (tm:string->date
c650: 20 64 61 74 65 20 69 6e 64 65 78 20 66 6f 72 6d date index form
c660: 61 74 2d 73 74 72 69 6e 67 20 73 74 72 2d 6c 65 at-string str-le
c670: 6e 20 70 6f 72 74 20 74 65 6d 70 6c 61 74 65 2d n port template-
c680: 73 74 72 69 6e 67 29 0a 20 20 28 64 65 66 69 6e string). (defin
c690: 65 20 28 73 6b 69 70 2d 75 6e 74 69 6c 20 70 6f e (skip-until po
c6a0: 72 74 20 73 6b 69 70 70 65 72 29 0a 20 20 20 20 rt skipper).
c6b0: 28 6c 65 74 20 28 28 63 68 20 28 70 65 65 6b 2d (let ((ch (peek-
c6c0: 63 68 61 72 20 70 6f 72 74 29 29 29 0a 20 20 20 char port))).
c6d0: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
c6e0: 63 74 3f 20 63 68 29 0a 09 20 20 28 74 6d 3a 74 ct? ch).. (tm:t
c6f0: 69 6d 65 2d 65 72 72 6f 72 20 27 73 74 72 69 6e ime-error 'strin
c700: 67 2d 3e 64 61 74 65 20 27 62 61 64 2d 64 61 74 g->date 'bad-dat
c710: 65 2d 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 e-format-string
c720: 74 65 6d 70 6c 61 74 65 2d 73 74 72 69 6e 67 29 template-string)
c730: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 73 6b .. (if (not (sk
c740: 69 70 70 65 72 20 63 68 29 29 0a 09 20 20 20 20 ipper ch))..
c750: 20 20 28 62 65 67 69 6e 20 28 72 65 61 64 2d 63 (begin (read-c
c760: 68 61 72 20 70 6f 72 74 29 20 28 73 6b 69 70 2d har port) (skip-
c770: 75 6e 74 69 6c 20 70 6f 72 74 20 73 6b 69 70 70 until port skipp
c780: 65 72 29 29 29 29 29 29 0a 20 20 28 69 66 20 28 er)))))). (if (
c790: 3e 3d 20 69 6e 64 65 78 20 73 74 72 2d 6c 65 6e >= index str-len
c7a0: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a ). (begin .
c7b0: 09 28 76 61 6c 75 65 73 29 29 0a 20 20 20 20 20 .(values)).
c7c0: 20 28 6c 65 74 20 28 20 28 63 75 72 72 65 6e 74 (let ( (current
c7d0: 2d 63 68 61 72 20 28 73 74 72 69 6e 67 2d 72 65 -char (string-re
c7e0: 66 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 f format-string
c7f0: 69 6e 64 65 78 29 29 20 29 0a 09 28 69 66 20 28 index)) )..(if (
c800: 6e 6f 74 20 28 63 68 61 72 3d 3f 20 63 75 72 72 not (char=? curr
c810: 65 6e 74 2d 63 68 61 72 20 23 5c 7e 29 29 0a 09 ent-char #\~))..
c820: 20 20 20 20 28 6c 65 74 20 28 28 70 6f 72 74 2d (let ((port-
c830: 63 68 61 72 20 28 72 65 61 64 2d 63 68 61 72 20 char (read-char
c840: 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 20 28 port))).. (
c850: 69 66 20 28 6f 72 20 28 65 6f 66 2d 6f 62 6a 65 if (or (eof-obje
c860: 63 74 3f 20 70 6f 72 74 2d 63 68 61 72 29 0a 09 ct? port-char)..
c870: 09 20 20 20 20 20 20 28 6e 6f 74 20 28 63 68 61 . (not (cha
c880: 72 3d 3f 20 63 75 72 72 65 6e 74 2d 63 68 61 72 r=? current-char
c890: 20 70 6f 72 74 2d 63 68 61 72 29 29 29 0a 09 09 port-char)))...
c8a0: 20 20 28 74 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 (tm:time-error
c8b0: 20 27 73 74 72 69 6e 67 2d 3e 64 61 74 65 20 27 'string->date '
c8c0: 62 61 64 2d 64 61 74 65 2d 66 6f 72 6d 61 74 2d bad-date-format-
c8d0: 73 74 72 69 6e 67 20 74 65 6d 70 6c 61 74 65 2d string template-
c8e0: 73 74 72 69 6e 67 29 29 0a 09 20 20 20 20 20 20 string))..
c8f0: 28 74 6d 3a 73 74 72 69 6e 67 2d 3e 64 61 74 65 (tm:string->date
c900: 20 64 61 74 65 20 28 2b 20 69 6e 64 65 78 20 31 date (+ index 1
c910: 29 20 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 ) format-string
c920: 73 74 72 2d 6c 65 6e 20 70 6f 72 74 20 74 65 6d str-len port tem
c930: 70 6c 61 74 65 2d 73 74 72 69 6e 67 29 29 0a 09 plate-string))..
c940: 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 ;; otherwise
c950: 2c 20 69 74 27 73 20 61 6e 20 65 73 63 61 70 65 , it's an escape
c960: 2c 20 77 65 20 68 6f 70 65 0a 09 20 20 20 20 28 , we hope.. (
c970: 69 66 20 28 3e 20 28 2b 20 69 6e 64 65 78 20 31 if (> (+ index 1
c980: 29 20 73 74 72 2d 6c 65 6e 29 0a 09 09 28 74 6d ) str-len)...(tm
c990: 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 73 74 72 :time-error 'str
c9a0: 69 6e 67 2d 3e 64 61 74 65 20 27 62 61 64 2d 64 ing->date 'bad-d
c9b0: 61 74 65 2d 66 6f 72 6d 61 74 2d 73 74 72 69 6e ate-format-strin
c9c0: 67 20 74 65 6d 70 6c 61 74 65 2d 73 74 72 69 6e g template-strin
c9d0: 67 29 0a 09 09 28 6c 65 74 2a 20 28 20 28 66 6f g)...(let* ( (fo
c9e0: 72 6d 61 74 2d 63 68 61 72 20 28 73 74 72 69 6e rmat-char (strin
c9f0: 67 2d 72 65 66 20 66 6f 72 6d 61 74 2d 73 74 72 g-ref format-str
ca00: 69 6e 67 20 28 2b 20 69 6e 64 65 78 20 31 29 29 ing (+ index 1))
ca10: 29 0a 09 09 09 28 66 6f 72 6d 61 74 2d 69 6e 66 )....(format-inf
ca20: 6f 20 28 61 73 73 6f 63 20 66 6f 72 6d 61 74 2d o (assoc format-
ca30: 63 68 61 72 20 74 6d 3a 72 65 61 64 2d 64 69 72 char tm:read-dir
ca40: 65 63 74 69 76 65 73 29 29 20 29 0a 09 09 20 20 ectives)) )...
ca50: 28 69 66 20 28 6e 6f 74 20 66 6f 72 6d 61 74 2d (if (not format-
ca60: 69 6e 66 6f 29 0a 09 09 20 20 20 20 20 20 28 74 info)... (t
ca70: 6d 3a 74 69 6d 65 2d 65 72 72 6f 72 20 27 73 74 m:time-error 'st
ca80: 72 69 6e 67 2d 3e 64 61 74 65 20 27 62 61 64 2d ring->date 'bad-
ca90: 64 61 74 65 2d 66 6f 72 6d 61 74 2d 73 74 72 69 date-format-stri
caa0: 6e 67 20 74 65 6d 70 6c 61 74 65 2d 73 74 72 69 ng template-stri
cab0: 6e 67 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 ng)... (beg
cac0: 69 6e 0a 09 09 09 28 6c 65 74 20 28 28 73 6b 69 in....(let ((ski
cad0: 70 70 65 72 20 28 63 61 64 72 20 66 6f 72 6d 61 pper (cadr forma
cae0: 74 2d 69 6e 66 6f 29 29 0a 09 09 09 20 20 20 20 t-info))....
caf0: 20 20 28 72 65 61 64 65 72 20 20 28 63 61 64 64 (reader (cadd
cb00: 72 20 66 6f 72 6d 61 74 2d 69 6e 66 6f 29 29 0a r format-info)).
cb10: 09 09 09 20 20 20 20 20 20 28 61 63 74 6f 72 20 ... (actor
cb20: 20 20 28 63 61 64 64 64 72 20 66 6f 72 6d 61 74 (cadddr format
cb30: 2d 69 6e 66 6f 29 29 29 0a 09 09 09 20 20 28 73 -info))).... (s
cb40: 6b 69 70 2d 75 6e 74 69 6c 20 70 6f 72 74 20 73 kip-until port s
cb50: 6b 69 70 70 65 72 29 0a 09 09 09 20 20 28 6c 65 kipper).... (le
cb60: 74 20 28 28 76 61 6c 20 28 72 65 61 64 65 72 20 t ((val (reader
cb70: 70 6f 72 74 29 29 29 0a 09 09 09 20 20 20 20 28 port))).... (
cb80: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
cb90: 76 61 6c 29 0a 09 09 09 09 28 74 6d 3a 74 69 6d val).....(tm:tim
cba0: 65 2d 65 72 72 6f 72 20 27 73 74 72 69 6e 67 2d e-error 'string-
cbb0: 3e 64 61 74 65 20 27 62 61 64 2d 64 61 74 65 2d >date 'bad-date-
cbc0: 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 74 65 format-string te
cbd0: 6d 70 6c 61 74 65 2d 73 74 72 69 6e 67 29 0a 09 mplate-string)..
cbe0: 09 09 09 28 61 63 74 6f 72 20 76 61 6c 20 64 61 ...(actor val da
cbf0: 74 65 29 29 29 0a 09 09 09 20 20 28 74 6d 3a 73 te))).... (tm:s
cc00: 74 72 69 6e 67 2d 3e 64 61 74 65 20 64 61 74 65 tring->date date
cc10: 20 28 2b 20 69 6e 64 65 78 20 32 29 20 66 6f 72 (+ index 2) for
cc20: 6d 61 74 2d 73 74 72 69 6e 67 20 20 73 74 72 2d mat-string str-
cc30: 6c 65 6e 20 70 6f 72 74 20 74 65 6d 70 6c 61 74 len port templat
cc40: 65 2d 73 74 72 69 6e 67 29 29 29 29 29 29 29 29 e-string))))))))
cc50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 ))..(define (str
cc60: 69 6e 67 2d 3e 64 61 74 65 20 69 6e 70 75 74 2d ing->date input-
cc70: 73 74 72 69 6e 67 20 74 65 6d 70 6c 61 74 65 2d string template-
cc80: 73 74 72 69 6e 67 29 0a 20 20 28 64 65 66 69 6e string). (defin
cc90: 65 20 28 74 6d 3a 64 61 74 65 2d 6f 6b 3f 20 64 e (tm:date-ok? d
cca0: 61 74 65 29 0a 20 20 20 20 28 61 6e 64 20 28 64 ate). (and (d
ccb0: 61 74 65 2d 6e 61 6e 6f 73 65 63 6f 6e 64 20 64 ate-nanosecond d
ccc0: 61 74 65 29 0a 09 20 28 64 61 74 65 2d 73 65 63 ate).. (date-sec
ccd0: 6f 6e 64 20 64 61 74 65 29 0a 09 20 28 64 61 74 ond date).. (dat
cce0: 65 2d 6d 69 6e 75 74 65 20 64 61 74 65 29 0a 09 e-minute date)..
ccf0: 20 28 64 61 74 65 2d 68 6f 75 72 20 64 61 74 65 (date-hour date
cd00: 29 0a 09 20 28 64 61 74 65 2d 64 61 79 20 64 61 ).. (date-day da
cd10: 74 65 29 0a 09 20 28 64 61 74 65 2d 6d 6f 6e 74 te).. (date-mont
cd20: 68 20 64 61 74 65 29 0a 09 20 28 64 61 74 65 2d h date).. (date-
cd30: 79 65 61 72 20 64 61 74 65 29 0a 09 20 28 64 61 year date).. (da
cd40: 74 65 2d 7a 6f 6e 65 2d 6f 66 66 73 65 74 20 64 te-zone-offset d
cd50: 61 74 65 29 29 29 0a 20 20 28 6c 65 74 20 28 20 ate))). (let (
cd60: 28 6e 65 77 64 61 74 65 20 28 6d 61 6b 65 2d 64 (newdate (make-d
cd70: 61 74 65 20 30 20 30 20 30 20 30 20 23 66 20 23 ate 0 0 0 0 #f #
cd80: 66 20 23 66 20 28 74 6d 3a 6c 6f 63 61 6c 2d 74 f #f (tm:local-t
cd90: 7a 2d 6f 66 66 73 65 74 29 29 29 20 29 0a 20 20 z-offset))) ).
cda0: 20 20 28 74 6d 3a 73 74 72 69 6e 67 2d 3e 64 61 (tm:string->da
cdb0: 74 65 20 6e 65 77 64 61 74 65 0a 09 09 20 20 20 te newdate...
cdc0: 20 20 30 0a 09 09 20 20 20 20 20 74 65 6d 70 6c 0... templ
cdd0: 61 74 65 2d 73 74 72 69 6e 67 0a 09 09 20 20 20 ate-string...
cde0: 20 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 (string-length
cdf0: 20 74 65 6d 70 6c 61 74 65 2d 73 74 72 69 6e 67 template-string
ce00: 29 0a 09 09 20 20 20 20 20 28 6f 70 65 6e 2d 69 )... (open-i
ce10: 6e 70 75 74 2d 73 74 72 69 6e 67 20 69 6e 70 75 nput-string inpu
ce20: 74 2d 73 74 72 69 6e 67 29 0a 09 09 20 20 20 20 t-string)...
ce30: 20 74 65 6d 70 6c 61 74 65 2d 73 74 72 69 6e 67 template-string
ce40: 29 0a 20 20 20 20 28 69 66 20 28 74 6d 3a 64 61 ). (if (tm:da
ce50: 74 65 2d 6f 6b 3f 20 6e 65 77 64 61 74 65 29 0a te-ok? newdate).
ce60: 09 6e 65 77 64 61 74 65 0a 09 28 74 6d 3a 74 69 .newdate..(tm:ti
ce70: 6d 65 2d 65 72 72 6f 72 20 27 73 74 72 69 6e 67 me-error 'string
ce80: 2d 3e 64 61 74 65 20 27 62 61 64 2d 64 61 74 65 ->date 'bad-date
ce90: 2d 66 6f 72 6d 61 74 2d 73 74 72 69 6e 67 20 28 -format-string (
cea0: 6c 69 73 74 20 22 49 6e 63 6f 6d 70 6c 65 74 65 list "Incomplete
ceb0: 20 64 61 74 65 20 72 65 61 64 2e 20 22 20 6e 65 date read. " ne
cec0: 77 64 61 74 65 20 74 65 6d 70 6c 61 74 65 2d 73 wdate template-s
ced0: 74 72 69 6e 67 29 29 29 29 29 0a 0a tring)))))..