Changeset 34652 in project


Ignore:
Timestamp:
09/29/17 06:59:48 (3 months ago)
Author:
kon
Message:

better arg order

Location:
release/4/list-utils/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/list-utils/trunk/list-utils.scm

    r34649 r34652  
    11;;;; list-utils.scm
    22;;;; Kon Lovett, Jul '07
     3;;;; Kon Lovett, Sep '17
    34
    45(module list-utils
     
    3637  alist-delete!/count)
    3738
    38 (import scheme chicken)
     39(import scheme)
     40
     41(import chicken)
    3942
    4043(import
    4144  (only data-structures
    42     rassoc)
     45    rassoc))
     46(require-library
     47  data-structures)
     48
     49(import
    4350  (only (srfi 1)
    4451    cons* reverse! append-reverse!
    45     proper-list? every)
     52    proper-list? every))
     53(require-library
     54  (srfi 1))
     55
     56(import
    4657  (only type-checks
    4758    check-list check-alist check-pair check-procedure check-fixnum check-positive-fixnum)
     
    4960    error-alist define-error-type))
    5061(require-library
    51   data-structures (srfi 1)
    5262  type-checks type-errors)
    5363
     
    103113              (else
    104114                ;Skip over "between" elements and continue sectioning the list.
    105                 (let ((ls
    106                         (cond
    107                           ;step = n
    108                           ((fx= 0 inc)
    109                             nls )
    110                           ;step < n so skip from starting this section element
    111                           ((fx> 0 inc)
    112                             (*skip+ ls (+ n inc)) )
    113                           ;step > n so skip remaining elements in between
    114                           (else
    115                             (*skip+ nls inc) ) ) ) )
     115                (let (
     116                    (ls
     117                      (cond
     118                        ;step = n
     119                        ((fx= 0 inc)
     120                          nls )
     121                        ;step < n so skip from starting this section element
     122                        ((fx> 0 inc)
     123                          (*skip+ ls (+ n inc)) )
     124                        ;step > n so skip remaining elements in between
     125                        (else
     126                          (*skip+ nls inc) ) ) ) )
    116127                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )
    117128
     
    191202      (alist-delete-first ?key ?als eqv?) )
    192203                ((_ ?key ?als ?=)
    193       (alist-delete-for-count ?key ?als ?= 1) ) ) )
     204      (alist-delete-with-count ?key ?als 1 ?=) ) ) )
    194205
    195206;; Remove 1st matching elements from the alist (destructive)
     
    200211      (alist-delete-first ?key ?als eqv?) )
    201212                ((_ ?key ?als ?=)
    202       (alist-delete-for-count! ?key ?als ?= 1) ) ) )
     213      (alist-delete-with-count! ?key ?als 1 ?=) ) ) )
    203214
    204215;; Some alist search macros.
     
    293304  (*alist-delete-for-count 'alist-delete-for-count key al cmp cnt) )
    294305
    295 (define (*alist-delete-for-count loc key al cmp cnt)
    296   (check-procedure loc cmp)
    297   (let loop ((cal (check-list loc al)) (cnt (check-fixnum loc cnt)) (oal '()))
    298     (cond
    299       ((null? cal)
    300         (reverse! oal) )
    301       ((pair? cal)
    302         (let ((elt (car cal))
    303               (nxt (cdr cal)))
    304           (if (not (pair? elt))
    305             (error-alist loc  al)
    306             (if (positive? cnt)
    307               ; then more deletion to attempt
    308               (if (cmp key (car elt))
    309                 (loop nxt (sub1 cnt) oal)
    310                 (loop nxt cnt (cons elt oal)) )
    311               ; else copy rest of spine
    312               (loop nxt 0 (cons elt oal)) ) ) ) )
    313       (else
    314         (error-alist loc al) ) ) ) )
     306(define (alist-delete-with-count key al #!optional (cnt most-positive-fixnum) (cmp eqv?))
     307  (*alist-delete-for-count 'alist-delete-for-count key al cmp cnt) )
    315308
    316309;; Remove 1st N matching elements from the alist (destructive)
     
    319312  (*alist-delete-for-count! 'alist-delete-for-count! key al cmp cnt) )
    320313
    321 (define (*alist-delete-for-count! loc key al cmp cnt)
    322   (check-procedure loc cmp)
    323   (let ((ral (check-list loc al)))
    324     (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
    325       (cond
    326         ((or (null? cal) (fx>= 0 cnt))
    327           ral )
    328         ((pair? cal)
    329           (let ((elt (car cal))
    330                 (nxt (cdr cal)))
    331             (if (not (pair? elt))
    332               (error-alist loc al)
    333               (cond
    334                 ((cmp key (car elt))
    335                   (if pal
    336                     (set-cdr! pal nxt)
    337                     (set! ral nxt) )
    338                   (loop nxt pal (fx- cnt 1)) )
    339                  (else
    340                    (loop nxt cal cnt) ) ) ) ) )
    341         (else
    342           (error-alist loc al) ) ) ) ) )
     314(define (alist-delete-with-count! key al #!optional (cnt most-positive-fixnum) (cmp eqv?))
     315  (*alist-delete-for-count! 'alist-delete-for-count! key al cmp cnt) )
    343316
    344317;; Returns alist of improper lists
     
    420393        (apply ormap func (map cdr rest)) ) ) ) )
    421394
    422 ;;
     395;;;
    423396
    424397(define (*skip+ ls n)
     
    447420          (loop (cdr ls) (fx- n 1) (cons (car ls) part)) ) ) ) ) )
    448421
     422(define (*alist-delete-for-count loc key al cmp cnt)
     423  (check-procedure loc cmp)
     424  (let loop ((cal (check-list loc al)) (cnt (check-fixnum loc cnt)) (oal '()))
     425    (cond
     426      ((null? cal)
     427        (reverse! oal) )
     428      ((pair? cal)
     429        (let ((elt (car cal))
     430              (nxt (cdr cal)))
     431          (if (not (pair? elt))
     432            (error-alist loc  al)
     433            (if (positive? cnt)
     434              ; then more deletion to attempt
     435              (if (cmp key (car elt))
     436                (loop nxt (sub1 cnt) oal)
     437                (loop nxt cnt (cons elt oal)) )
     438              ; else copy rest of spine
     439              (loop nxt 0 (cons elt oal)) ) ) ) )
     440      (else
     441        (error-alist loc al) ) ) ) )
     442
     443(define (*alist-delete-for-count! loc key al cmp cnt)
     444  (check-procedure loc cmp)
     445  (let ((ral (check-list loc al)))
     446    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
     447      (cond
     448        ((or (null? cal) (fx>= 0 cnt))
     449          ral )
     450        ((pair? cal)
     451          (let ((elt (car cal))
     452                (nxt (cdr cal)))
     453            (if (not (pair? elt))
     454              (error-alist loc al)
     455              (cond
     456                ((cmp key (car elt))
     457                  (if pal
     458                    (set-cdr! pal nxt)
     459                    (set! ral nxt) )
     460                  (loop nxt pal (fx- cnt 1)) )
     461                 (else
     462                   (loop nxt cal cnt) ) ) ) ) )
     463        (else
     464          (error-alist loc al) ) ) ) ) )
     465
    449466;;;DEPRECATED
    450467
  • release/4/list-utils/trunk/list-utils.setup

    r34649 r34652  
    55(verify-extension-name "list-utils")
    66
    7 (setup-shared-extension-module 'list-utils (extension-version "1.2.0")
     7(setup-shared-extension-module 'list-utils (extension-version "1.3.0")
    88  #:inline? #t
    99  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.