Changeset 38286 in project


Ignore:
Timestamp:
03/16/20 23:41:16 (2 weeks ago)
Author:
Kon Lovett
Message:

remove unused imports, move date validation from io to support, do not show date struct cached fields in struct print, support only time formats in scan-date by filling in d-m-y from current-date

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

Legend:

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

    r38283 r38286  
    107107(import (chicken type))
    108108(import (only (chicken keyword) string->keyword))
    109 (import (only srfi-1 fold list-index))
    110 (import (only srfi-69
     109(import (only (srfi 1) fold list-index))
     110(import (only (srfi 69)
    111111  make-hash-table symbol-hash
    112112  hash-table-exists? hash-table-ref/default hash-table-set!))
     
    654654(import (only (chicken format) format))
    655655
    656 (define-constant DATE-FORMAT-SRFI-10 "#,(srfi-19-date ~A ~A ~A ~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 ~A ~A ~A>")
     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>")
    658658
    659659(define date-record-printer-format (make-parameter 'SRFI-10
     
    678678   (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
    679679   (tm:date-zone-offset dat)
    680    (tm:date-zone-name dat) (tm:date-dst? dat)
    681    (tm:date-wday dat) (tm:date-yday dat) (tm:date-jday dat)) )
     680   (tm:date-zone-name dat) (tm:date-dst? dat)) )
    682681
    683682(define-reader-ctor 'srfi-19-date
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38270 r38286  
    4141(import (chicken base))
    4242#;(import srfi-6)
    43 (import (only srfi-1 drop))
    44 (import (only srfi-13 string-pad))
     43(import (only (srfi 1) drop))
     44(import (only (srfi 13) string-pad))
    4545(import (only (chicken port) with-output-to-string))
    4646(import (only (chicken string) reverse-string-append))
    47 (import srfi-29)
     47(import (srfi 29))
    4848(import type-checks)
    4949(import srfi-19-timezone)
     
    6060  (error loc "bad date format" obj) )
    6161
     62(define *bad-date-template-message* "bad date template")
     63
    6264(define (error-bad-date-template loc msg . args)
    6365  (apply error
    6466    loc
    65     (if (string=? "" msg)
    66       "bad date template"
    67       (string-append "bad date template - " msg))
     67    (if (not msg)
     68      *bad-date-template-message*
     69      (string-append *bad-date-template-message* " - " msg))
    6870    args) )
    6971
     
    418420    (date-printer loc date (cdr fmt-rem) (- len-rem 1) port) ) )
    419421
    420 (define (format-date dest fmtstr . r)
     422(define (format-date dest fmt . r)
    421423  (let ((port #f)
    422424        (date (optional r #f)) )
     
    424426      ((not dest)       (set! port (open-output-string)) )
    425427      ((string? dest)
    426         (set! date fmtstr)
    427         (set! fmtstr dest)
     428        (set! date fmt)
     429        (set! fmt dest)
    428430        (set! port (open-output-string)) )
    429431      ((number? dest)   (set! port (current-error-port)) )
     
    431433      (else             (set! port (current-output-port)) ) )
    432434    (check-date 'format-date date)
    433     (check-string 'format-date fmtstr)
     435    (check-string 'format-date fmt)
    434436    (check-output-port 'format-date port)
    435     (date-printer 'format-date date (string->list fmtstr) (string-length fmtstr) port)
     437    (date-printer 'format-date date (string->list fmt) (string-length fmt) port)
    436438    (or (and dest (not (string? dest)))
    437439        (get-output-string port)) ) )
    438440
    439441(define (date->string date . args)
    440   (let-optionals args ((fmtstr "~c"))
     442  (let-optionals args ((fmt "~c"))
    441443    (check-date 'date->string date)
    442     (check-string 'date->string fmtstr)
     444    (check-string 'date->string fmt)
    443445    (let ((port (open-output-string)))
    444       (date-printer 'date->string date (string->list fmtstr) (string-length fmtstr) port)
     446      (date-printer 'date->string date (string->list fmt) (string-length fmt) port)
    445447      (get-output-string port) ) ) )
    446448
     
    654656             (let loop ((ch (peek-char port)))
    655657               (if (eof-object? ch)
    656                  (error-bad-date-template 'scan-date "" (list->string fmt-rem))
     658                 (error-bad-date-template 'scan-date #f (list->string fmt-rem))
    657659                 (unless (skipper ch)
    658660                   (read-char port)
     
    665667                (when (or (eof-object? port-char)
    666668                          (not (char=? cur-ch port-char)))
    667                   (error-bad-date-template 'scan-date "" (list->string fmt-rem))))
     669                  (error-bad-date-template 'scan-date #f (list->string fmt-rem))))
    668670              (loop (cdr fmt-rem) (- len-rem 1)))
    669671            ;otherwise, it's an escape, we hope
    670672            ((< len-rem 2)
    671               (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
     673              (error-bad-date-template 'scan-date #f (list->string fmt-rem)))
    672674            (else
    673675              (let* ((format-char (cadr fmt-rem))
    674676                     (format-info (assoc format-char read-directives)))
    675677                (unless format-info
    676                   (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
     678                  (error-bad-date-template 'scan-date #f (list->string fmt-rem)))
    677679                (let ((skipper (cadr format-info))
    678680                      (reader (caddr format-info))
     
    681683                  (let ((val (reader port)))
    682684                    (if (eof-object? val)
    683                       (error-bad-date-template 'scan-date "" (list->string fmt-rem))
     685                      (error-bad-date-template 'scan-date #f (list->string fmt-rem))
    684686                      (actor val date))))
    685687                (loop (cddr fmt-rem) (- len-rem 2))))) ) ) ) ) )
    686688
    687 (define (scan-date src fmtstr)
    688   (let ((port #f)
    689         (newdate (tm:make-incomplete-date)))
    690     (let ((date-complete?
    691             (lambda ()
    692               (and
    693                 (tm:date-nanosecond newdate)
    694                 (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
    695                 (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
    696                 (tm:date-zone-offset newdate))))
    697           (date-ok
    698            (lambda ()
    699              (check-date-elements
    700                'scan-date
    701                (tm:date-nanosecond newdate)
    702                (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
    703                (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
    704                (tm:date-zone-offset newdate)
    705                (tm:date-zone-name newdate)))))
    706       (cond
    707         ((string? src)  (set! port (open-input-string src)))
    708         ((port? src)    (set! port src))
    709         (src            (set! port (current-input-port))))
    710       (check-input-port 'scan-date port)
    711       (check-string 'scan-date fmtstr)
    712       (date-reader newdate (string->list fmtstr) (string-length fmtstr) port)
    713       (unless (date-complete?)
    714         (error-bad-date-template 'scan-date "date read incomplete" fmtstr newdate))
    715       (date-ok)
    716       newdate ) ) )
    717 
    718 (define (string->date src . fmtstr)
    719   (scan-date src (optional fmtstr (item@ LOCALE-DATE-TIME-FORMAT))) )
     689(define (scan-date src fmt)
     690  (check-string 'scan-date fmt)
     691  (let (
     692    (inp
     693      (check-input-port 'scan-date
     694        (cond
     695          ((string? src)  (open-input-string src))
     696          ((port? src)    src)
     697          (src            (current-input-port)))))
     698    (newdat
     699      (tm:make-incomplete-date)) )
     700    ;
     701    (date-reader newdat (string->list fmt) (string-length fmt) inp)
     702    ;missing d-m-y filled in w/ current; probable time only format
     703    (when (not (and (tm:date-day newdat) (tm:date-month newdat) (tm:date-year newdat)))
     704      (let (
     705        (curdat (tm:current-date (tm:date-timezone-info newdat))) )
     706        (tm:date-day-set! newdat (tm:date-day curdat))
     707        (tm:date-month-set! newdat (tm:date-month curdat))
     708        (tm:date-year-set! newdat (tm:date-year curdat)) ) )
     709    (unless (tm:date-complete? newdat)
     710      (error-bad-date-template 'scan-date "date read incomplete" fmt newdat) )
     711    ;final validation
     712    (check-date-by-elements 'scan-date newdat) ) )
     713
     714(define (string->date src . fmt)
     715  (scan-date src (optional fmt (item@ LOCALE-DATE-TIME-FORMAT))) )
    720716
    721717;;;
  • release/5/srfi-19/trunk/srfi-19-support.scm

    r38283 r38286  
    8383  check-time-and-type
    8484  check-duration
    85   check-time-elements
     85  check-time-elements check-time-by-elements
    8686  check-times
    8787  check-time-binop
    8888  check-time-compare
    8989  check-time-aritmetic
    90   check-date-elements
     90  check-date-elements check-date-by-elements
    9191  check-date-compatible-timezone-offsets
    9292  error-incompatible-time-types
     
    9797(import (chicken base))
    9898(import (chicken type))
    99 (import (only srfi-1 fold))
    100 (import (only (chicken io) read-line))
    101 (import (only (chicken read-syntax) define-reader-ctor))
    102 (import (only (chicken gc) current-gc-milliseconds))
    103 (import (only (chicken format) format))
    104 (import (only (chicken time) cpu-time current-seconds current-milliseconds))
    105 (import (only (chicken time posix) seconds->utc-time))
    10699(import (only (chicken string) conc))
    107 (import (only (chicken port) with-input-from-port with-input-from-string))
    108100(import locale)
    109101(import record-variants)
     
    174166  (check-time-seconds loc obj3) )
    175167
     168(define (check-time-by-elements loc tim)
     169  (check-time-elements loc
     170    (tm:time-type tim)
     171    (tm:time-nanosecond tim)
     172    (tm:time-second tim))
     173    tim )
     174
    176175(define (check-times loc objs)
    177176  (for-each (cut check-time loc <>) objs) )
     
    189188  (check-duration loc dur) )
    190189
    191 ;;
     190;;; Date Object
    192191
    193192(define (date? obj)
     
    246245  (check-timezone-name loc tzn "date-timezone-name") )
    247246
     247(define (check-date-by-elements loc dat)
     248  (check-date-elements loc
     249   (tm:date-nanosecond dat)
     250   (tm:date-second dat) (tm:date-minute dat) (tm:date-hour dat)
     251   (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
     252   (tm:date-zone-offset dat)
     253   (tm:date-zone-name dat))
     254  dat )
     255
    248256;;
    249257
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38283 r38286  
    105105(import scheme)
    106106(import (chicken base))
    107 (import (prefix (only srfi-18 seconds->time time->seconds) srfi-18:))
     107(import (prefix (only (srfi 18) seconds->time time->seconds) srfi-18:))
    108108#;(import srfi-8)
    109109(import miscmacros)
  • release/5/srfi-19/trunk/srfi-19-tm.scm

    r38283 r38286  
    150150  tm:make-date
    151151  tm:copy-date
     152  tm:date-complete?
    152153  tm:seconds->date/type
    153154  tm:current-date
     
    193194(import (chicken base))
    194195(import (chicken type))
    195 (import (only srfi-1 fold))
    196196(import (only (chicken io) read-line))
    197 (import (only (chicken read-syntax) define-reader-ctor))
    198197(import (only (chicken gc) current-gc-milliseconds))
    199198(import (only (chicken format) format))
    200199(import (only (chicken time) cpu-time current-seconds current-milliseconds))
    201200(import (only (chicken time posix) seconds->utc-time))
    202 (import (only (chicken string) conc))
    203201(import (only (chicken port) with-input-from-port with-input-from-string))
    204202(import locale)
     
    10141012    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    10151013
     1014(define (tm:date-complete? dat)
     1015  (and
     1016    (%date-nanosecond dat)
     1017    (%date-second dat) (%date-minute dat) (%date-hour dat)
     1018    (%date-day dat) (%date-month dat) (%date-year dat)
     1019    (%date-zone-offset dat)) )
     1020
    10161021(define (tm:seconds->date/type sec tzc)
    10171022  (let* (
     
    13231328    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
    13241329
    1325 #; ;inexact version
    1326 (define (tm:julian-day ns sec min hr dy mn yr tzo)
    1327   (let (
    1328     (time-seconds
    1329       (fx+
    1330         (fx+
    1331           (fx* hr SEC/HR)
    1332           (fx+ (fx* min SEC/MIN) sec))
    1333           (fxneg tzo)) ) )
    1334     (fp+
    1335       (fp-
    1336         (exact->inexact (tm:encode-julian-day-number dy mn yr))
    1337         (exact->inexact ONE-HALF))
    1338       (fp/
    1339         (fp+
    1340           (exact->inexact time-seconds)
    1341           (fp/ (exact->inexact ns) (exact->inexact NS/S)))
    1342         (exact->inexact SEC/DY))) ) )
    1343 
    13441330(define (tm:date->julian-day dat)
    13451331  (or
  • release/5/srfi-19/trunk/srfi-19.egg

    r38277 r38286  
    22
    33((synopsis "Time Data Types and Procedures")
    4  (version "4.3.1")
     4 (version "4.3.2")
    55 (category data)
    66 (author "Will Fitzgerald (for Chicken by [[/users/kon-lovett]])")
Note: See TracChangeset for help on using the changeset viewer.