Changeset 38846 in project


Ignore:
Timestamp:
08/16/20 18:09:10 (3 months ago)
Author:
Kon Lovett
Message:

fix *split-at+ type, strict-types, drop fx in favor of compiler, test optional arguments (a little) better, drop redundant local

Location:
release/5/list-utils/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/list-utils/trunk/list-utils.egg

    r38479 r38846  
    33
    44((synopsis "list-utils")
    5  (version "2.1.0")
     5 (version "2.1.1")
    66 (category data)
    77 (author "[[kon lovett]]")
    88 (license "BSD")
    9  (dependencies
    10   (srfi-1 "0.1")
    11   (check-errors "3.1.0"))
     9 (dependencies srfi-1 check-errors)
    1210 (test-dependencies test)
    1311 (components
    1412  (extension list-utils
    1513    (types-file)
    16     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks")) ) )
     14    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks")) ) )
  • release/5/list-utils/trunk/list-utils.scm

    r38479 r38846  
    3030(import scheme)
    3131(import (chicken base))
    32 (import (chicken fixnum))
     32(import (only (chicken fixnum) most-positive-fixnum))
    3333(import (chicken type))
    3434(import (only (srfi 1)
     
    115115      (let (
    116116        (bias
    117           (fx-
     117          (-
    118118            (check-positive-fixnum 'section step 'step)
    119             (check-positive-fixnum 'section n 'size))))
     119            (check-positive-fixnum 'section n 'size))) )
    120120        (let loop ((ls ls) (parts '()))
    121121          ;Get this section
     
    133133                      (cond
    134134                        ;step = n
    135                         ((fx= 0 bias)
     135                        ((= 0 bias)
    136136                          nls )
    137137                        ;step < n so skip from starting this section element
    138                         ((fx> 0 bias)
     138                        ((> 0 bias)
    139139                          (receive (ls _) (*skip+ ls (+ n bias)) ls) )
    140140                        ;step > n so skip remaining elements in between
     
    437437;
    438438(define (list-copy* ls #!optional (start 0) (end (length ls)) (fill (void)))
    439   (unless (fx<= start end)
     439  (unless (<= start end)
    440440    (error 'list-copy* "start > end" start end) )
    441441  (let* (
    442     (tot (fx- end start))
    443     (end (fxmin end (length ls)))
    444     (len (fx- end start))
     442    (tot (- end start))
     443    (end (min end (length ls)))
     444    (len (- end start))
    445445    (ls (take (drop ls start) len)) )
    446     ;(assert (fx<= tot len))
    447     (append! ls (make-list (fx- tot len) fill)) ) )
     446    ;(assert (<= tot len))
     447    (append! ls (make-list (- tot len) fill)) ) )
    448448
    449449;;;
     
    452452;
    453453(define (*skip+ ls n)
    454   (if (or (null? ls) (fx<= n 0))
     454  (if (or (null? ls) (<= n 0))
    455455    (values ls n)
    456     (*skip+ (cdr ls) (fx- n 1))) )
    457 
    458 (: *split-at+ (list fixnum list --> list list))
     456    (*skip+ (cdr ls) (- n 1))) )
     457
     458(: *split-at+ (list fixnum (or boolean list) --> list list))
    459459;
    460460(define (*split-at+ ls n pads)
     
    464464    (let loop ((ls ls) (n n) (part '()))
    465465      (cond
    466         ((fx<= n 0)
     466        ((<= n 0)
    467467          (values (reverse! part) ls) )
    468468        ((null? ls)
     
    477477                (values (append-reverse! part ls) '()) ) ) ) )
    478478        (else
    479           (loop (cdr ls) (fx- n 1) (cons (car ls) part)) ) ) ) ) )
     479          (loop (cdr ls) (- n 1) (cons (car ls) part)) ) ) ) ) )
    480480
    481481(: *alist-delete-duplicates (symbol * alist binary-predicate fixnum --> alist))
     
    509509    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
    510510      (cond
    511         ((or (null? cal) (fx>= 0 cnt))
     511        ((or (null? cal) (>= 0 cnt))
    512512          ral )
    513513        ((pair? cal)
     
    522522                    (set-cdr! pal nxt)
    523523                    (set! ral nxt) )
    524                   (loop nxt pal (fx- cnt 1)) )
     524                  (loop nxt pal (- cnt 1)) )
    525525                 (else
    526526                   (loop nxt cal cnt) ) ) ) ) )
  • release/5/list-utils/trunk/tests/list-utils-test.scm

    r35985 r38846  
    2525
    2626(test-group  "Split-at+"
    27   (test '(() ()) (receive (split-at+ '() -1 #f)))
    28   (test '(() ()) (receive (split-at+ '() 0 #f)))
    29   (test '(() ()) (receive (split-at+ '() 1 #f)))
     27  (test '(() ()) (receive (split-at+ '() -1 #f)))   ;should be same
     28  (test '(() ()) (receive (split-at+ '() -1)))
     29  (test '(() ()) (receive (split-at+ '() 0)))
     30  (test '(() ()) (receive (split-at+ '() 1)))
    3031  (test '(() ()) (receive (split-at+ '() -1 '())))
    3132  (test '(() ()) (receive (split-at+ '() 0 '())))
     
    3435  (test '(() ()) (receive (split-at+ '() 0 '(1))))
    3536  (test '(() ()) (receive (split-at+ '() 1 '(1))))
    36   (test '(() (1)) (receive (split-at+ '(1) -1 #f)))
    37   (test '(() (1)) (receive (split-at+ '(1) 0 #f)))
    38   (test '((1) ()) (receive (split-at+ '(1) 1 #f)))
    39   (test '(() ()) (receive (split-at+ '(1) 2 #f)))
     37  (test '(() (1)) (receive (split-at+ '(1) -1)))
     38  (test '(() (1)) (receive (split-at+ '(1) 0)))
     39  (test '((1) ()) (receive (split-at+ '(1) 1)))
     40  (test '(() ()) (receive (split-at+ '(1) 2)))
    4041  (test '(() (1)) (receive (split-at+ '(1) -1 '())))
    4142  (test '(() (1)) (receive (split-at+ '(1) 0 '())))
Note: See TracChangeset for help on using the changeset viewer.