Changeset 38668 in project for release


Ignore:
Timestamp:
05/01/20 18:18:42 (3 months ago)
Author:
Kon Lovett
Message:

remove redundant -local, use -strict-types (#t is-a type? see -io zone-reader NOTE), isolate tm:ctm

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

Legend:

Unmodified
Added
Removed

  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38336 r38668  
    4040(import scheme)
    4141(import (chicken base))
     42(import (chicken type))
    4243#;(import srfi-6)
    4344(import (only (srfi 1) drop))
    … …  
    425426(define (format-date dest fmt . r)
    426427  (let (
    427     (port #f)
     428    (port (the (or boolean output-port) #f))
    428429    (date (optional r #f)) )
    429430    (cond
    … …  
    517518
    518519(define (zone-reader port)
    519   (let ((offset 0)
    520         (is-pos #t)
    521         (ch (read-char port)) )
     520  ;NOTE original is-pos & offset were in top let, w/ is-pos value set!, w/
     521  ;-strict-types the compiler assumed is-pos didn't change its' value from the
     522  ;initial #t!
     523  (define (optdec off fac)
     524    (let ((ch (read-char port)))
     525      (if (eof-object? ch)
     526        off
     527        (+ off (* (digit->int ch) fac)))) )
     528  (let ((ch (read-char port)))
    522529    (when (eof-object? ch)
    523       (error-bad-date-template 'string->date
    524        "invalid time zone +/-" 'eof-object))
     530      (error-bad-date-template 'string->date "invalid time zone +/-" 'eof-object))
    525531    (if (or (char=? ch #\Z) (char=? ch #\z))
    526532      0
    527       (begin
    528         (cond
    529           ((char=? ch #\+) (set! is-pos #t))
    530           ((char=? ch #\-) (set! is-pos #f))
    531           (else
    532             (error-bad-date-template 'string->date "invalid time zone +/-" ch)))
    533         (let ((ch (read-char port)))
    534           (when (eof-object? ch)
    535             (error-bad-date-template 'string->date
    536              "invalid time zone number" 'eof-object))
    537           (set! offset (* (digit->int ch) (* 10 SEC/HR))))
     533      (let* (
     534        (is-pos
     535          (cond
     536            ((char=? ch #\+) #t)
     537            ((char=? ch #\-) #f)
     538            (else
     539              (error-bad-date-template 'string->date "invalid time zone +/-" ch))))
     540        (offset
     541          (let ((ch (read-char port)))
     542            (when (eof-object? ch)
     543              (error-bad-date-template 'string->date "invalid time zone number" 'eof-object))
     544            (* (digit->int ch) (* 10 SEC/HR))))
    538545        ;non-existing values are considered zero
    539         (let ((ch (read-char port)))
    540           (unless (eof-object? ch)
    541             (set! offset (+ offset (* (digit->int ch) SEC/HR)))))
    542         (let ((ch (read-char port)))
    543           (unless (eof-object? ch)
    544             (set! offset (+ offset (* (digit->int ch) 600)))))
    545         (let ((ch (read-char port)))
    546           (unless (eof-object? ch)
    547             (set! offset (+ offset (* (digit->int ch) 60)))))
     546        (offset (optdec offset SEC/HR))
     547        (offset (optdec offset (* 10 SEC/MIN)))
     548        (offset (optdec offset SEC/MIN)) )
    548549        (if is-pos offset (- offset)))) ) )
    549550

  • release/5/srfi-19/trunk/srfi-19-tm.scm

    r38336 r38668  
    597597;; Current time routines
    598598
    599 ; Throw away everything but the sub-second bit.
    600 ;
    601 (define (tm:current-sub-milliseconds)
    602         (inexact->exact (remainder (current-milliseconds) MS/S)) )
    603 
    604 (define (tm:current-nanoseconds)
    605   (* (tm:current-sub-milliseconds) NS/MS) )
    606 
    607 ;Use the 'official' seconds & nanoseconds values
    608 ;
    609 (define (tm:current-time-values)
    610   (values (tm:current-nanoseconds) (current-seconds)) )
     599(import (only srfi-19-tmctm tm:current-time-values))
    611600
    612601(define (tm:current-time-utc)

  • release/5/srfi-19/trunk/srfi-19.egg

    r38295 r38668  
    22
    33((synopsis "Time Data Types and Procedures")
    4  (version "4.4.1")
     4 (version "4.5.0")
    55 (category data)
    66 (author "Will Fitzgerald (for Chicken by [[/users/kon-lovett]])")
    … …  
    2323      "srfi-29-bundles/nl/srfi-19" "srfi-29-bundles/pt/br/srfi-19"))
    2424  (extension srfi-19
    25     #;(inline-file)
    2625    (types-file)
    2726    (component-dependencies srfi-19-core srfi-19-io srfi-19-literals)
    28     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     27    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    2928  (extension srfi-19-period
    30     #;(inline-file)
    3129    (types-file)
    3230    (component-dependencies srfi-19-tm srfi-19-core)
    33     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     31    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    3432  (extension srfi-19-literals
    35     #;(inline-file)
    3633    (types-file)
    3734    (component-dependencies srfi-19-tm srfi-19-core srfi-19-io)
    38     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     35    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    3936  (extension srfi-19-core
    40     #;(inline-file)
    4137    (types-file)
    4238    (component-dependencies srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
    43     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     39    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    4440  (extension srfi-19-io
    45     #;(inline-file)
    4641    (types-file)
    4742    (component-dependencies srfi-19-support srfi-19-tm srfi-19-timezone)
    48     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     43    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    4944  (extension srfi-19-support
    50     #;(inline-file)
    5145    (types-file)
    5246    (component-dependencies srfi-19-timezone srfi-19-tm)
    53     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     47    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    5448  (extension srfi-19-time
    55     #;(inline-file)
    5649    (types-file)
    5750    (component-dependencies srfi-19-support srfi-19-tm)
    58     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     51    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    5952  (extension srfi-19-date
    60     #;(inline-file)
    6153    (types-file)
    6254    (component-dependencies srfi-19-support srfi-19-tm srfi-19-io)
    63     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks"))
     55    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
     56  (extension srfi-19-tmctm
     57    (types-file)
     58    (csc-options "-O4" "-d0" "-strict-types" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
    6459  (extension srfi-19-tm
    65     #;(inline-file)
    6660    (types-file)
    67     (component-dependencies srfi-19-timezone)
    68     (csc-options "-O4" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
     61    (component-dependencies srfi-19-timezone srfi-19-tmctm)
     62    (csc-options "-O4" "-d0" "-strict-types" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
    6963  (extension srfi-19-timezone
    70     #;(inline-file)
    7164    (types-file)
    72     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks")) ) )
     65    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks")) ) )

  • release/5/srfi-19/trunk/tests/run.scm

    r38455 r38668  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    16 (define (test-filename test-name)
    17   (string-append test-name "-test") )
     19(define *args* (argv))
    1820
    1921(define (egg-name args #!optional (def EGG-NAME))
    2022  (cond
    21     ((<= 4 (length *args*))
    22       (cadddr *args*) )
    23     (def
    24       def )
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
    2525    (else
    26       (error 'test "cannot determine egg-name") ) ) )
    27 
    28 ;;
    29 
    30 (define *args* (argv))
    31 (define *egg* (egg-name *args*))
    32 (define *tests* `(,*egg*))
     26      (error 'run "cannot determine egg-name") ) ) )
    3327
    3428(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
    3530
    3631;no -disable-interrupts or -no-lambda-info
    3732(define *csc-options* "-inline-global -local -inline \
    3833  -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    4036
    41 (define (run-test-evaluated test-name test-source)
    42   (format #t "*** ~A - csi ***~%" test-name)
    43   (system (string-append "csi -s " test-source)) )
     37(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
     38(define (test-filename name) (string-append name "-test"))
     39(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4440
    45 (define (run-test-compiled test-name test-source csc-options)
    46   (format #t "*** ~A - csc ~A ***~%" test-name csc-options)
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    4752  ;csc output is in current directory
    48   (system (string-append "csc" " " csc-options " " test-source))
    49   (system (make-pathname *current-directory* (test-filename test-name))) )
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5055
    5156;;;
    5257
    53 (define (run-test #!optional (test-name *egg*) (csc-options *csc-options*))
    54   (let ((test-source (make-pathname #f (test-filename test-name) "scm")))
    55     (run-test-evaluated test-name test-source)
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
    5664    (newline)
    57     (run-test-compiled test-name test-source csc-options) ) )
     65    (run-test-compiled source csc-options) ) )
    5866
    59 (define (run-tests #!optional (test-names *tests*) (csc-options *csc-options*))
    60   (for-each (cut run-test <> csc-options) test-names) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    6169
    6270;;; Do Test

  • release/5/srfi-19/trunk/tests/test-gloss.incl.scm

    r38433 r38668  
    11
    2 ;;;test "Gloss" API
     2;;; test "Gloss" API
    33
    4 (define-constant TEST-GLOSS-MARKER "--> ")
    5 
    6 (define (test-group-ref group field . o)
    7   (define (assq-ref ls key . o)
    8     (cond
    9       ((assq key ls)    => cdr)
    10       ((pair? o)        (car o))
    11       (else             #f) ) )
    12   (apply assq-ref (cdr group) field o) )
     4;;
    135
    146(define test-indent-width)
    … …  
    179(define test-indentation-char)
    1810(let ()
    19   (import
    20     (chicken syntax)
    21     (only (chicken process-context) get-environment-variable))
     11  (import (chicken syntax))
     12  (import (only (chicken process-context) get-environment-variable))
    2213
    2314  (define get-environment-variable/default
    … …  
    9081      (checked-guard test-indentation-char char))) )
    9182
     83;;
     84
     85;from test?
     86(define (test-group-ref group field . o)
     87  (define (assq-ref ls key . o)
     88    (cond
     89      ((assq key ls)    => cdr)
     90      ((pair? o)        (car o))
     91      (else             #f) ) )
     92  (apply assq-ref (cdr group) field o) )
     93
     94;;
     95
     96(define-constant TEST-GLOSS-MARKER "--> ")
     97
    9298(define (test-group-indent-string group)
    9399  (define (*test-group-level group)
    … …  
    99105  (make-string (test-group-indent-width group) (test-indentation-char)) )
    100106
     107(define (display-gloss-marker)
     108  (display (test-group-indent-string (current-test-group)))
     109  (display TEST-GLOSS-MARKER) )
     110
     111;;
     112
     113(define-syntax glossn
     114  (syntax-rules ()
     115    ((glossn)
     116      (begin))
     117    ((glossn ?obj)
     118      (begin
     119        (display-gloss-marker)
     120        (display ?obj)
     121        (flush-output)) )
     122    ((glossn ?obj ...)
     123      (begin
     124        (display-gloss-marker)
     125        (for-each display (list ?obj ...))
     126        (flush-output)) ) ) )
     127
    101128(define-syntax gloss
    102129  (syntax-rules ()
    103130    ((gloss)
    104       (newline) )
     131      (newline))
    105132    ((gloss ?obj ...)
    106133      (begin
    107         (display (test-group-indent-string (current-test-group)))
    108         (display TEST-GLOSS-MARKER)
    109         (for-each display (list ?obj ...))
     134        (glossn ?obj ...)
    110135        (newline)) ) ) )
    111136
     137;Needs a format:
    112138;(import (only (chicken format) format)) ;builtin
    113139;(import format)                         ;egg
     140
     141(define-syntax glossnf
     142  (syntax-rules ()
     143    ((glossnf ?fmt ?arg0 ...)
     144      (glossn (format #f ?fmt ?arg0 ...)) ) ) )
     145
    114146(define-syntax glossf
    115147  (syntax-rules ()
    116148    ((glossf ?fmt ?arg0 ...)
    117       (gloss (format #f ?fmt ?arg0 ...)) ) ) )
     149      (begin
     150        (glossnf ?fmt ?arg0 ...)
     151        (newline)) ) ) )
Note: See TracChangeset for help on using the changeset viewer.