Changeset 38289 in project


Ignore:
Timestamp:
03/17/20 03:40:01 (2 weeks ago)
Author:
Kon Lovett
Message:

add C4 date-literals, strip srfi-19 prefix from tags since in module

Location:
release/5/srfi-19/trunk
Files:
5 edited

Legend:

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

    r38286 r38289  
    7777  time-utc->modified-julian-day
    7878  ;;Extensions
    79   date-record-printer-format
    8079  seconds->date
    8180  read-leap-second-table
     
    101100  time->julian-day
    102101  time->modified-julian-day
    103   date-compare)
     102  date-compare
     103  date-record-printer-format
     104  read-date-literal
     105  write-date-literal)
    104106
    105107(import scheme)
     
    649651    (list-index (cut eq? b <>) +date-key-lexographic-order+)) )
    650652
    651 ;;
    652 
     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))
    653675(import (only (chicken read-syntax) define-reader-ctor))
    654 (import (only (chicken format) format))
    655 
    656 (define-constant DATE-FORMAT-SRFI-10 "#,(srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)")
    657 (define-constant DATE-FORMAT-BRACKET "#<srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A>")
    658 
    659 (define date-record-printer-format (make-parameter 'SRFI-10
    660   (lambda (x)
    661     (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
    662       x
    663       (begin
    664         (warning 'date-record-printer-format "invalid format" x)
    665         (date-record-printer-format) ) ) ) ) )
     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>")
    666703
    667704(define (date-record-printer-format-string)
    668705  (case (date-record-printer-format)
    669     ((srfi-10 SRFI-10)
     706    ((SRFI-10)
    670707      DATE-FORMAT-SRFI-10 )
    671708    (else
    672709      DATE-FORMAT-BRACKET ) ) )
    673710
    674 (define-record-printer (srfi-19-date dat out)
     711(define (date-record-formatter dat out)
    675712  (format out (date-record-printer-format-string)
    676    (tm:date-nanosecond dat)
    677    (tm:date-second dat) (tm:date-minute dat) (tm:date-hour dat)
    678    (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
    679    (tm:date-zone-offset dat)
    680    (tm:date-zone-name dat) (tm:date-dst? dat)) )
    681 
    682 (define-reader-ctor 'srfi-19-date
    683   (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    684     (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))
     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) )
    685785
    686786) ;module srfi-19-date
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38286 r38289  
    421421
    422422(define (format-date dest fmt . r)
    423   (let ((port #f)
    424         (date (optional r #f)) )
     423  (let (
     424    (port #f)
     425    (date (optional r #f)) )
    425426    (cond
    426       ((not dest)       (set! port (open-output-string)) )
     427      ((not dest)
     428        (set! port (open-output-string)) )
    427429      ((string? dest)
    428430        (set! date fmt)
    429431        (set! fmt dest)
    430432        (set! port (open-output-string)) )
    431       ((number? dest)   (set! port (current-error-port)) )
    432       ((port? dest)     (set! port dest) )
    433       (else             (set! port (current-output-port)) ) )
     433      ((number? dest)
     434        (set! port (current-error-port)) )
     435      ((port? dest)
     436        (set! port dest) )
     437      (else
     438        (set! port (current-output-port)) ) )
    434439    (check-date 'format-date date)
    435440    (check-string 'format-date fmt)
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38286 r38289  
    7373  time-utc->time-tai!
    7474  ;;Extensions
    75   time-record-printer-format
    7675  one-second-duration
    7776  one-nanosecond-duration
     
    437436  (tm:time-monotonic->time-tai tim tim) )
    438437
    439 ;;
     438;;; Literal Syntax
    440439
    441440(import (only (chicken read-syntax) define-reader-ctor))
    442441(import (only (chicken format) format))
    443442
    444 (define-constant TIME-FORMAT-SRFI-10 "#,(srfi-19-time ~A ~A ~A)")
    445 (define-constant TIME-FORMAT-BRACKET "#<srfi-19-time ~A ~A ~A>")
    446 
    447 (define time-record-printer-format (make-parameter 'SRFI-10
    448   (lambda (x)
    449     (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
    450       x
    451       (begin
    452         (warning 'time-record-printer-format "invalid format" x)
    453         (time-record-printer-format) ) ) ) ) )
     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 <>)) )
    454486
    455487(define (time-record-printer-format-string)
     
    460492      TIME-FORMAT-BRACKET ) ) )
    461493
    462 (define-record-printer (srfi-19-time tim out)
     494(define (time-record-formatter tim out)
    463495  (format out (time-record-printer-format-string)
    464496    (tm:time-type tim)
     
    466498    (tm:time-second tim)) )
    467499
    468 ;SRFI-10
    469 (define-reader-ctor 'srfi-19-time
    470   (lambda (tt ns sec)
    471     (tm:make-time tt ns sec)))
    472 
    473500) ;module srfi-19-time
  • release/5/srfi-19/trunk/srfi-19-tm.scm

    r38286 r38289  
    462462
    463463;#| ;dependency
    464 (define-constant srfi-19-time 'srfi-19-time#srfi-19-time)
     464(define-constant srfi-19-time 'srfi-19-time#time)
    465465(define-record-type-variant srfi-19-time (unchecked inline unsafe)
    466466  (%make-time tt ns sec)
     
    864864
    865865;#| ;dependency
    866 (define-constant srfi-19-date 'srfi-19-date#srfi-19-date)
     866(define-constant srfi-19-date 'srfi-19-date#date)
    867867(define-record-type-variant srfi-19-date (unchecked inline unsafe)
    868868  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
  • release/5/srfi-19/trunk/srfi-19.egg

    r38286 r38289  
    22
    33((synopsis "Time Data Types and Procedures")
    4  (version "4.3.2")
     4 (version "4.4.0")
    55 (category data)
    66 (author "Will Fitzgerald (for Chicken by [[/users/kon-lovett]])")
     
    2222      "srfi-29-bundles/es/srfi-19" "srfi-29-bundles/it/srfi-19"
    2323      "srfi-29-bundles/nl/srfi-19" "srfi-29-bundles/pt/br/srfi-19"))
    24   (extension srfi-19-timezone
     24  (extension srfi-19
    2525    #;(inline-file)
    2626    (types-file)
    27     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
     27    (component-dependencies srfi-19-core srfi-19-io)
     28    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     29  (extension srfi-19-period
     30    #;(inline-file)
     31    (types-file)
     32    (component-dependencies srfi-19-tm srfi-19-core)
     33    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     34  (extension srfi-19-core
     35    #;(inline-file)
     36    (types-file)
     37    (component-dependencies srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
     38    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     39  (extension srfi-19-io
     40    #;(inline-file)
     41    (types-file)
     42    (component-dependencies srfi-19-support srfi-19-tm srfi-19-timezone)
     43    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     44  (extension srfi-19-support
     45    #;(inline-file)
     46    (types-file)
     47    (component-dependencies srfi-19-timezone srfi-19-tm)
     48    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     49  (extension srfi-19-time
     50    #;(inline-file)
     51    (types-file)
     52    (component-dependencies srfi-19-support srfi-19-tm)
     53    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     54  (extension srfi-19-date
     55    #;(inline-file)
     56    (types-file)
     57    (component-dependencies srfi-19-support srfi-19-tm srfi-19-io)
     58    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
    2859  (extension srfi-19-tm
    2960    #;(inline-file)
     
    3162    (component-dependencies srfi-19-timezone)
    3263    (csc-options "-O4" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
    33   (extension srfi-19-support
     64  (extension srfi-19-timezone
    3465    #;(inline-file)
    3566    (types-file)
    36     (component-dependencies srfi-19-timezone srfi-19-tm)
    37     (csc-options "-O4" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
    38   (extension srfi-19-time
    39     #;(inline-file)
    40     (types-file)
    41     (component-dependencies srfi-19-support srfi-19-tm)
    42     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    43   (extension srfi-19-date
    44     #;(inline-file)
    45     (types-file)
    46     (component-dependencies srfi-19-support srfi-19-tm srfi-19-timezone)
    47     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    48   (extension srfi-19-io
    49     #;(inline-file)
    50     (types-file)
    51     (component-dependencies srfi-19-support srfi-19-tm srfi-19-timezone)
    52     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    53   (extension srfi-19-period
    54     #;(inline-file)
    55     (types-file)
    56     (component-dependencies srfi-19-tm srfi-19-core)
    57     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    58   (extension srfi-19-core
    59     #;(inline-file)
    60     (types-file)
    61     (component-dependencies srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
    62     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    63   (extension srfi-19
    64     #;(inline-file)
    65     (types-file)
    66     (component-dependencies srfi-19-core srfi-19-io)
    67     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))))
     67    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks")) ) )
Note: See TracChangeset for help on using the changeset viewer.