Changeset 38290 in project


Ignore:
Timestamp:
03/17/20 05:32:44 (3 weeks ago)
Author:
Kon Lovett
Message:

add date/time literals module, common struct tags

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

Legend:

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

    r38149 r38290  
    2929(define-constant MN/YR 12)  ;months per year
    3030
     31;;
     32
     33;MUST be a constant!
     34
     35(define-constant *date-tag* 'srfi-19#date)
     36(define-constant *time-tag* 'srfi-19#time)
     37
     38(define-constant *date-timezone-info-tag* 'srfi-19#date-timezone-info)
     39
    3140;; misc-utils
    3241
  • release/5/srfi-19/trunk/srfi-19-date.scm

    r38289 r38290  
    100100  time->julian-day
    101101  time->modified-julian-day
    102   date-compare
    103   date-record-printer-format
    104   read-date-literal
    105   write-date-literal)
     102  date-compare)
    106103
    107104(import scheme)
     
    185182;; Date CTOR
    186183
    187 (define make-date-unique (cons #t #f))
     184(define *unique* (cons #t #f))
    188185
    189186(define (make-date ns sec min hr dy mn yr . args)
     
    191188    (tzo (timezone-locale-offset))
    192189    (tzn #f)
    193     (dstf make-date-unique) )
     190    (dstf *unique*) )
    194191    (let (
    195       (no-dstf (eq? make-date-unique dstf)) )
     192      (no-dstf (eq? *unique* dstf)) )
    196193      (cond
    197194        ((timezone-components? tzo)
     
    651648    (list-index (cut eq? b <>) +date-key-lexographic-order+)) )
    652649
    653 ;;; Literal Syntax
    654 
    655 (define date-record-printer-format
    656   (make-parameter #t
    657     (lambda (x)
    658       (cond
    659         ((not x)
    660           (bracket-date-literals)
    661           #f )
    662         ((or (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
    663           (srfi-10-date-literals)
    664           'SRFI-10 )
    665         ((or (eq? '|#@| x) (eq? #t x))
    666           (date-literals)
    667           '|#@|)
    668         (else
    669           (warning 'date-record-printer-format "invalid format" x)
    670           (date-record-printer-format) ) ) ) ) )
    671 
    672 ;;
    673 
    674 (import (only (chicken format) format))
    675 (import (only (chicken read-syntax) define-reader-ctor))
    676 (import (only (chicken read-syntax) set-sharp-read-syntax!))
    677 
    678 (define (bracket-date-literals)
    679   ;default output form
    680   (define-record-printer (date dat out)
    681     (date-record-formatter dat out) ) )
    682 
    683 (define (srfi-10-date-literals)
    684   ;srfi-10 output form
    685   (define-record-printer (date dat out)
    686     (date-record-formatter dat out) )
    687   ;srfi-10 input handler
    688   (define-reader-ctor 'srfi-19-date
    689     (lambda (ns sec min hr dy mn yr tzo tzn dstf)
    690       (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f))) )
    691 
    692 (define (date-literals)
    693   ;
    694   (define-record-printer (date dat out)
    695     (write-date-literal dat out) )
    696   ;
    697   (set-sharp-read-syntax! #\@ (cut read-date-literal <>)) )
    698 
    699 ;;
    700 
    701 (define-constant DATE-FORMAT-SRFI-10 "#,(date ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S)")
    702 (define-constant DATE-FORMAT-BRACKET "#<date ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S>")
    703 
    704 (define (date-record-printer-format-string)
    705   (case (date-record-printer-format)
    706     ((SRFI-10)
    707       DATE-FORMAT-SRFI-10 )
    708     (else
    709       DATE-FORMAT-BRACKET ) ) )
    710 
    711 (define (date-record-formatter dat out)
    712   (format out (date-record-printer-format-string)
    713     (tm:date-nanosecond dat)
    714     (tm:date-second dat) (tm:date-minute dat) (tm:date-hour dat)
    715     (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
    716     (tm:date-zone-offset dat)
    717     (tm:date-zone-name dat) (tm:date-dst? dat)) )
    718 
    719 ;portions from C4 "date-literals.scm"
    720 
    721 ;;
    722 ;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
    723 ;;
    724 ;; Permission is hereby granted, free of charge, to any person obtaining a copy
    725 ;; of this software and associated documentation files (the "Software"), to
    726 ;; deal in the Software without restriction, including without limitation the
    727 ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
    728 ;; sell copies of the Software, and to permit persons to whom the Software is
    729 ;; furnished to do so, subject to the following conditions:
    730 ;;
    731 ;; The above copyright notice and this permission notice shall be included in
    732 ;; all copies or substantial portions of the Software.
    733 ;;
    734 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
    735 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
    736 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
    737 ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
    738 ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
    739 ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
    740 ;; IN THE SOFTWARE.
    741 
    742 (import (only (chicken condition) handle-exceptions))
    743 (import (only (chicken io) read-token))
    744 (import (only srfi-13 string-index))
    745 (import srfi-19-io)
    746 
    747 ;; Constants
    748 
    749 (define-constant *date-literal-chars* "0123456789TZ:+-")
    750 
    751 (define-constant *date-iso-format* "~Y-~m-~dT~H:~M:~S~z")
    752 
    753 (define-constant *date-literal-formats* `(
    754   ,*date-iso-format* "~Y-~m-~dT~H:~M:~S" "~Y-~m-~d"
    755   "~H:~M:~S~z" "~H:~M:~S"))
    756 
    757 (define-constant *date-iso-literal-format* (string-append "#" "@" *date-iso-format*))
    758 
    759 ;; Internal helper procedures
    760 
    761 (define (parse-date-literal dat fmt)
    762   (handle-exceptions exn #f (string->date dat fmt)) )
    763 
    764 (define (read-date-literal-string port)
    765   (read-token (lambda (c) (string-index *date-literal-chars* c)) port) )
    766 
    767 (define (make-quoted-date dat)
    768   `(make-date ,(tm:date-nanosecond dat)
    769               ,(tm:date-second dat) ,(tm:date-minute dat) ,(tm:date-hour dat)
    770               ,(tm:date-day dat) ,(tm:date-month dat) ,(tm:date-year dat)
    771               ,(tm:date-zone-offset dat) ) )
    772 
    773 ;;;; Exported procedures
    774 
    775 (define (read-date-literal #!optional (port (current-input-port)))
    776   (let ((date (read-date-literal-string port)))
    777     (let loop ((fmts *date-literal-formats*))
    778       (cond
    779         ((null? fmts) (error 'srfi-19-date "invalid date/time literal" date))
    780         ((parse-date-literal date (car fmts)) => make-quoted-date)
    781         (else (loop (cdr fmts))) ) ) ) )
    782 
    783 (define (write-date-literal date #!optional (port (current-output-port)))
    784   (format-date port *date-iso-literal-format* date) )
    785 
    786650) ;module srfi-19-date
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38289 r38290  
    705705    ;
    706706    (date-reader newdat (string->list fmt) (string-length fmt) inp)
    707     ;missing d-m-y filled in w/ current; probable time only format
    708     (when (not (and (tm:date-day newdat) (tm:date-month newdat) (tm:date-year newdat)))
     707    ;missing (all-of) d-m-y filled in w/ current; probable time only format
     708    (when (not (or (tm:date-day newdat) (tm:date-month newdat) (tm:date-year newdat)))
    709709      (let (
    710710        (curdat (tm:current-date (tm:date-timezone-info newdat))) )
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38289 r38290  
    436436  (tm:time-monotonic->time-tai tim tim) )
    437437
    438 ;;; Literal Syntax
    439 
    440 (import (only (chicken read-syntax) define-reader-ctor))
    441 (import (only (chicken format) format))
    442 
    443 (define-constant TIME-FORMAT-SRFI-10 "#,(time ~S ~S ~S)")
    444 (define-constant TIME-FORMAT-BRACKET "#<time ~S ~S ~S>")
    445 #;(define-constant TIME-FORMAT-LITERAL "##~S_~S_~S")
    446 
    447 (define time-record-printer-format
    448   (make-parameter #f
    449     (lambda (x)
    450       (cond
    451         ((not x)
    452           (bracket-time-literals)
    453           #f )
    454         ((or (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
    455           (srfi-10-time-literals)
    456           'SRFI-10 )
    457         #; ;TBD
    458         ((or (eq? '|##| x) (eq? #t x))
    459           (time-literals)
    460           '|##|)
    461         (else
    462           (warning 'time-record-printer-format "invalid format" x)
    463           (time-record-printer-format) ) ) ) ) )
    464 
    465 (define (bracket-time-literals)
    466   ;default output form
    467   (define-record-printer (time tim out)
    468     (time-record-formatter tim out) ) )
    469 
    470 (define (srfi-10-time-literals)
    471   ;srfi-10 output form
    472   (define-record-printer (time tim out)
    473     (time-record-formatter tim out) )
    474   ;srfi-10 input handler
    475   (define-reader-ctor 'time
    476     (lambda (tt ns sec)
    477       (tm:make-time tt ns sec))) )
    478 
    479 #; ;TBD
    480 (define (time-literals)
    481   ;
    482   (define-record-printer (time tim out)
    483     (write-time-literal tim out) )
    484   ;
    485   (set-sharp-read-syntax! #\# (cut read-time-literal <>)) )
    486 
    487 (define (time-record-printer-format-string)
    488   (case (time-record-printer-format)
    489     ((srfi-10 SRFI-10)
    490       TIME-FORMAT-SRFI-10 )
    491     (else
    492       TIME-FORMAT-BRACKET ) ) )
    493 
    494 (define (time-record-formatter tim out)
    495   (format out (time-record-printer-format-string)
    496     (tm:time-type tim)
    497     (tm:time-nanosecond tim)
    498     (tm:time-second tim)) )
    499 
    500438) ;module srfi-19-time
  • release/5/srfi-19/trunk/srfi-19-tm.scm

    r38289 r38290  
    245245;;; Date TZ information extract
    246246
    247 ;Belongs in srfi-19-timezone (does it? not used & private.)
    248 ;but won't fit since needs srfi-19-support (%date-*)
    249 
    250247;#: ;dependency
    251 (define-constant date-timezone-info 'srfi-19-date#date-timezone-info)
    252 (define-record-type-variant date-timezone-info (unchecked inline unsafe)
     248(define-record-type-variant *date-timezone-info-tag* (unchecked inline unsafe)
    253249  (%make-date-timezone-info n o d)
    254250  %date-timezone-info?
     
    258254;|#
    259255#; ;no dependency
    260 (define-record-type date-timezone-info
     256(define-record-type *date-timezone-info-tag*
    261257  (%make-date-timezone-info n o d)
    262258  %date-timezone-info?
     
    462458
    463459;#| ;dependency
    464 (define-constant srfi-19-time 'srfi-19-time#time)
    465 (define-record-type-variant srfi-19-time (unchecked inline unsafe)
     460(define-record-type-variant *time-tag* (unchecked inline unsafe)
    466461  (%make-time tt ns sec)
    467462  %time?
     
    471466;|#
    472467#; ;no (define-record-type srfi-19-time
    473 (define-record-type srfi-19-time
     468(define-record-type *time-tag*
    474469  (%make-time tt ns sec)
    475470  %time?
     
    864859
    865860;#| ;dependency
    866 (define-constant srfi-19-date 'srfi-19-date#date)
    867 (define-record-type-variant srfi-19-date (unchecked inline unsafe)
     861(define-record-type-variant *date-tag* (unchecked inline unsafe)
    868862  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    869863  %date?
     
    884878;|#
    885879#; ;no dependency
    886 (define-record-type srfi-19-date
     880(define-record-type *date-tag*
    887881  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    888882  %date?
  • release/5/srfi-19/trunk/srfi-19.egg

    r38289 r38290  
    2525    #;(inline-file)
    2626    (types-file)
    27     (component-dependencies srfi-19-core srfi-19-io)
     27    (component-dependencies srfi-19-core srfi-19-io srfi-19-literals)
    2828    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
    2929  (extension srfi-19-period
     
    3131    (types-file)
    3232    (component-dependencies srfi-19-tm srfi-19-core)
     33    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     34  (extension srfi-19-literals
     35    #;(inline-file)
     36    (types-file)
     37    (component-dependencies srfi-19-tm srfi-19-core srfi-19-io)
    3338    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
    3439  (extension srfi-19-core
  • release/5/srfi-19/trunk/srfi-19.scm

    r38130 r38290  
    77(import srfi-19-core)
    88(import srfi-19-io)
     9(import srfi-19-literals)
    910(reexport srfi-19-core)
    1011(reexport srfi-19-io)
     12(reexport srfi-19-literals)
    1113
    1214) ;module srfi-19
  • release/5/srfi-19/trunk/tests/srfi-19-test.scm

    r38270 r38290  
    447447  (current-date))
    448448
     449;; Literals
     450
     451(import (only (chicken port) with-input-from-string))
     452(import srfi-19-literals)
     453
     454(test-assert "Read Literal"
     455  (equal?
     456    '(make-date 0 16 28 18 16 3 2020 -25200)
     457    (with-input-from-string "2020-03-16T18:28:16-0700" read-date-literal)))
     458
     459;; TBD
     460
     461(import srfi-19-literals)
     462
    449463; Duration
    450464; Time Aritmetic (+ - * /)
Note: See TracChangeset for help on using the changeset viewer.