Changeset 34121 in project


Ignore:
Timestamp:
05/30/17 04:26:22 (5 months ago)
Author:
kon
Message:

explicit fx arith, re-flow

Location:
release/4/list-utils
Files:
4 edited
1 copied

Legend:

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

    r20949 r34121  
    44(module list-utils
    55
    6   (;export
    7     skip+
    8     split-at+
    9     section
    10     length=0?
    11     length=1?
    12     length=2?
    13     length>1?
    14     ensure-list
    15     not-null?
    16     alist-delete-first
    17     alist-delete-first!
    18     assoc-def
    19     assq-def
    20     assv-def
    21     alist-inverse-ref
    22     alist-delete/count
    23     alist-delete!/count
    24     plist->alist
    25     alist->plist
    26     unzip-alist
    27     zip-alist
    28     shift!
    29     unshift!
    30     shift!/set
    31     andmap
    32     ormap)
    33 
    34   (import
    35     scheme
    36     chicken
    37     (only data-structures
    38       rassoc)
    39     (only srfi-1
    40       cons* reverse! append-reverse!)
    41     (only type-checks
    42       check-list check-pair check-procedure
    43       check-fixnum check-positive-fixnum)
    44     (only type-errors
    45       error-alist define-error-type))
    46 
    47   (require-library
    48     srfi-1 type-checks type-errors)
     6(;export
     7  skip+
     8  split-at+
     9  section
     10  length=0?
     11  length=1?
     12  length=2?
     13  length>1?
     14  ensure-list
     15  not-null?
     16  alist-delete-first
     17  alist-delete-first!
     18  assoc-def
     19  assq-def
     20  assv-def
     21  alist-inverse-ref
     22  alist-delete/count
     23  alist-delete!/count
     24  plist->alist
     25  alist->plist
     26  unzip-alist
     27  zip-alist
     28  shift!
     29  unshift!
     30  shift!/set
     31  andmap
     32  ormap)
     33
     34(import scheme chicken)
     35
     36(import
     37  (only data-structures
     38    rassoc)
     39  (only srfi-1
     40    cons* reverse! append-reverse!)
     41  (only type-checks
     42    check-list check-alist check-pair check-procedure check-fixnum check-positive-fixnum)
     43  (only type-errors
     44    error-alist define-error-type))
     45(require-library
     46  data-structures srfi-1
     47  type-checks type-errors)
     48
     49;;;
    4950
    5051;; Returns the original list starting at element n.
    5152
    5253(define (skip+ ls n)
    53   (if (or (null? ls) (<= n 0)) (values ls n)
    54     (skip+ (cdr ls) (sub1 n))) )
     54  (*skip+ (check-list 'skip+ ls 'ls) (check-fixnum 'skip+ n 'n)) )
    5555
    5656;; Returns new list with all elements [0 n-1] and original list from n.
     
    6060;; no padding & paritial section.
    6161
    62 (define (split-at+ ls n #!optional (pads '()))
    63   ;Do not attempt to padout when the primary list is empty.
    64   (if (null? ls) (values '() '())
    65     (let loop ((ls ls) (n n) (part '()))
    66       (cond
    67         ((<= n 0)
    68           (values (reverse! part) ls) )
    69         ((null? ls)
    70           (cond
    71             ;Unless padding is desired throw away the section
    72             ((not pads)   (values '() '()) )
    73             ((null? pads) (values (reverse! part) '()) )
    74             (else         (values (append-reverse! part (split-at+ pads n)) '()) ) ) )
    75         (else
    76           (loop (cdr ls) (sub1 n) (cons (car ls) part)) ) ) ) ) )
     62(define (split-at+ ls n #!optional pads)
     63  (*split-at+
     64    (check-list 'split-at+ ls 'ls)
     65    (check-fixnum 'split-at+ n 'size)
     66    (and pads (check-list 'split-at+ pads 'pads))) )
    7767
    7868;; Returns sublists of length n from the list, the last sublist padded, if
    7969;; necessary and possible, from pads. The sublists are constructed starting
    80 ;; at every step element. 
     70;; at every step element.
    8171
    8272;ls - list
     
    8676
    8777(define (section ls n #!optional (step n) (pads '()))
     78  (check-list 'section ls 'ls)
    8879  (check-positive-fixnum 'section n 'size)
    8980  (check-positive-fixnum 'section step 'step)
     
    9182    ;Do not attempt to section the padding list when
    9283    ;the primary list is empty.
    93     ((null? ls)   '() )
     84    ((null? ls)
     85      '() )
    9486    (else
    9587      ;Remaining elements between sections
    96       (let ((inc (- step n)))
     88      (let ((inc (fx- step n)))
    9789        (let loop ((ls ls) (parts '()))
    9890          ;Get this section
    9991          #;(assert (not (null? ls)))
    100           (let-values (((part nls) (split-at+ ls n pads)))
     92          (let-values (((part nls) (*split-at+ ls n pads)))
    10193            (cond
    10294              ((null? nls)
    10395                ;Possible empty section when no padding.
    104                 ;otherwise complete with this, the last,
    105                 ;section
    106                 (if (null? part) (reverse! parts)
     96                ;otherwise complete with this, the last, section
     97                (if (null? part)
     98                  (reverse! parts)
    10799                  (reverse! (cons part parts)) ) )
    108100              (else
    109                 ;Skip over "between" elements and
    110                 ;continue sectioning the list.
    111                 (let ((ls (cond
    112                             ;step = n
    113                             ((zero? inc)      nls )
    114                             ;step < n so skip from starting this section element
    115                             ((negative? inc)  (skip+ ls (+ n inc)) )
    116                             ;step > n so skip remaining elements in between
    117                             (else             (skip+ nls inc) ) ) ) )
     101                ;Skip over "between" elements and continue sectioning the list.
     102                (let (
     103                    (ls
     104                      (cond
     105                        ;step = n
     106                        ((fx= 0 inc)
     107                          nls )
     108                        ;step < n so skip from starting this section element
     109                        ((fx> 0 inc)
     110                          (*skip+ ls (+ n inc)) )
     111                        ;step > n so skip remaining elements in between
     112                        (else
     113                          (*skip+ nls inc) ) ) ) )
    118114                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )
    119115
     
    129125                  (shift!/set ?var #f) )
    130126                ((_ ?var ?empval)
    131       (if (not (pair? ?var)) ?empval
    132          (let ((_tmp (car ?var)))
    133            (set! ?var (cdr ?var))
    134            _tmp ) ) ) ) )
     127      (if (not (pair? ?var))
     128        ?empval
     129        (let ((_tmp (car ?var)))
     130          (set! ?var (cdr ?var))
     131          _tmp ) ) ) ) )
    135132
    136133;; List of length = 0?
     
    171168                ((_ ?obj)
    172169      (let ((_obj ?obj))
    173         (or (and (list? _obj) _obj)
    174             (list _obj)) ) ) ) )
     170        (or
     171          (and (list? _obj) _obj)
     172          (list _obj)) ) ) ) )
    175173
    176174;; Returns #f if given list is empty and the list itself otherwise
     
    182180                ((_ ?obj)
    183181      (let ((_obj ?obj))
    184         (and (not (null? _obj))
    185              _obj) ) ) ) )
     182        (and (not (null? _obj)) _obj) ) ) ) )
    186183
    187184;; Remove 1st matching elements from the alist (functional)
     
    212209                  (assoc-def ?key ?als equal?) )
    213210                ((_ ?key ?als ?=)
    214                   (or (assoc ?key ?als ?=)
    215                       (error 'assoc-def "key not found" ?key)) )
     211                  (or
     212                    (assoc ?key ?als ?=)
     213        (error 'assoc-def "key not found" ?key)) )
    216214                ((_ ?key ?als ?= ?def)
    217       (or (assoc ?key ?als ?=)
    218           (if (procedure? ?def) (?def) ?def)) ) ) )
     215      (or
     216        (assoc ?key ?als ?=)
     217        (if (procedure? ?def) (?def) ?def)) ) ) )
    219218
    220219(define-syntax assq-def
    221220        (syntax-rules ()
    222221                ((_ ?key ?als)
    223                   (or (assq ?key ?als)
    224                       (error 'assq-def "key not found" ?key)) )
     222                  (or
     223                    (assq ?key ?als)
     224        (error 'assq-def "key not found" ?key)) )
    225225                ((_ ?key ?als ?def)
    226       (or (assq ?key ?als)
    227           (if (procedure? ?def) (?def) ?def)) ) ) )
     226      (or
     227        (assq ?key ?als)
     228        (if (procedure? ?def) (?def) ?def)) ) ) )
    228229
    229230(define-syntax assv-def
    230231        (syntax-rules ()
    231232                ((_ ?key ?als)
    232                   (or (assv ?key ?als)
    233                       (error 'assv-def "key not found" ?key)) )
     233                  (or
     234                    (assv ?key ?als)
     235        (error 'assv-def "key not found" ?key)) )
    234236                ((_ ?key ?als ?def)
    235       (or (assv ?key ?als)
    236           (if (procedure? ?def) (?def) ?def)) ) ) )
     237      (or
     238        (assv ?key ?als)
     239        (if (procedure? ?def) (?def) ?def)) ) ) )
    237240
    238241;;
     
    243246
    244247(define (plist->alist pls)
    245   (let loop ((pls pls) (als '()))
    246     (if (null? pls) (reverse! als)
     248  (let loop ((pls (check-list 'plist->alist pls)) (als '()))
     249    (if (null? pls)
     250      (reverse! als)
    247251      (let ((hd (car pls))
    248252            (tl (cdr pls)) )
    249         (if (null? tl) (error-plist 'plist->alist pls)
     253        (if (null? tl)
     254          (error-plist 'plist->alist pls)
    250255          (loop (cdr tl) (cons (cons hd (car tl)) als)) ) ) ) ) )
    251256
     
    253258
    254259(define (alist->plist als)
    255   (let loop ((als als) (pls '()))
    256     (if (null? als) (reverse! pls)
     260  (let loop ((als (check-list 'alist->plist als)) (pls '()))
     261    (if (null? als)
     262      (reverse! pls)
    257263      (let ((elt (car als)))
    258         (if (not (pair? elt)) (error-alist 'alist->plist als)
     264        (if (not (pair? elt))
     265          (error-alist 'alist->plist als)
    259266          (loop (cdr als) (cons* (cdr elt) (car elt) pls)) ) ) ) ) )
    260267
     
    262269
    263270(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
    264   (let ((elt (rassoc val alist cmp)))
    265     (if elt (car elt)
     271  (let (
     272      (elt
     273        (rassoc
     274          val
     275          (check-alist 'alist-inverse-ref alist)
     276          (check-procedure  'alist-inverse-ref cmp))))
     277    (if elt
     278      (car elt)
    266279      default ) ) )
    267280
    268281;; Remove 1st N matching elements from the alist (functional)
     282
     283(define (alist-delete/count key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
     284  (*alist-delete/count 'alist-delete/count key al cmp cnt) )
    269285
    270286(define (*alist-delete/count loc key al cmp cnt)
    271287  (check-procedure loc cmp)
    272   (let loop ((cal al) (cnt (check-fixnum loc cnt)) (oal '()))
     288  (let loop ((cal (check-list loc al)) (cnt (check-fixnum loc cnt)) (oal '()))
    273289    (cond
    274290      ((null? cal)
     
    277293        (let ((elt (car cal))
    278294              (nxt (cdr cal)))
    279           (if (not (pair? elt)) (error-alist loc  al)
     295          (if (not (pair? elt))
     296            (error-alist loc  al)
    280297            (if (positive? cnt)
    281298              ; then more deletion to attempt
    282299              (if (cmp key (car elt))
    283                   (loop nxt (sub1 cnt) oal)
    284                   (loop nxt cnt (cons elt oal)) )
     300                (loop nxt (sub1 cnt) oal)
     301                (loop nxt cnt (cons elt oal)) )
    285302              ; else copy rest of spine
    286303              (loop nxt 0 (cons elt oal)) ) ) ) )
     
    288305        (error-alist loc al) ) ) ) )
    289306
    290 (define (alist-delete/count key al #!optional (cmp eqv?) (cnt 1073741823))
    291   (*alist-delete/count 'alist-delete/count key al cmp cnt) )
    292 
    293307;; Remove 1st N matching elements from the alist (destructive)
     308
     309(define (alist-delete!/count key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
     310  (*alist-delete!/count 'alist-delete!/count key al cmp cnt) )
    294311
    295312(define (*alist-delete!/count loc key al cmp cnt)
    296313  (check-procedure loc cmp)
    297   (let ((ral al))
     314  (let ((ral (check-list loc al)))
    298315    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
    299316      (cond
    300         ((or (null? cal) (not (positive? cnt)))
     317        ((or (null? cal) (fx>= 0 cnt))
    301318          ral )
    302319        ((pair? cal)
    303320          (let ((elt (car cal))
    304321                (nxt (cdr cal)))
    305             (if (not (pair? elt)) (error-alist loc al)
    306                 (cond
    307                   ((cmp key (car elt))
    308                     (if pal (set-cdr! pal nxt)
    309                       (set! ral nxt) )
    310                     (loop nxt pal (sub1 cnt)) )
    311                    (else
    312                      (loop nxt cal cnt) ) ) ) ) )
     322            (if (not (pair? elt))
     323              (error-alist loc al)
     324              (cond
     325                ((cmp key (car elt))
     326                  (if pal (set-cdr! pal nxt)
     327                    (set! ral nxt) )
     328                  (loop nxt pal (fx- cnt 1)) )
     329                 (else
     330                   (loop nxt cal cnt) ) ) ) ) )
    313331        (else
    314332          (error-alist loc al) ) ) ) ) )
    315333
    316 (define (alist-delete!/count key al #!optional (cmp eqv?) (cnt 1073741823))
    317   (*alist-delete!/count 'alist-delete!/count key al cmp cnt) )
    318 
    319334;; Returns alist of improper lists
    320335;; The keys & vals lists must be of the same length!
     
    322337; This works with any proper list, not just an alist.
    323338(define (zip-alist keys vals)
    324   (unless (= (length (check-list 'zip-alist keys))
    325             (length (check-list 'zip-alist vals)))
     339  (unless
     340      (= (length (check-list 'zip-alist keys)) (length (check-list 'zip-alist vals)))
    326341    (error 'zip-alist "lists are not of same length" keys vals) )
    327342  (map cons keys vals) )
     
    331346(define (unzip-alist al)
    332347  (let loop ((al (check-list 'unzip-alist al)) (keys '()) (vals '()))
    333     (if (null? al) (values (reverse! keys) (reverse! vals))
     348    (if (null? al)
     349      (values (reverse! keys) (reverse! vals))
    334350      (let ((elt (car al)))
    335         (if (not (pair? elt)) (error-alist 'unzip-alist al)
    336             (loop (cdr al) (cons (car elt) keys) (cons (cdr elt) vals)) ) ) ) ) )
     351        (unless (pair? elt)
     352          (error-alist 'unzip-alist al) )
     353        (loop (cdr al) (cons (car elt) keys) (cons (cdr elt) vals)) ) ) ) )
    337354
    338355;;; Handy little things:
    339356
    340357(define (shift! ls #!optional default)
    341   (if (null? ls) default
     358  (check-list 'shift! ls)
     359  (if (null? ls)
     360    default
    342361    (begin
    343       (check-pair 'shift! ls)
    344362      (let ((x (car ls))
    345363            (d (cdr ls)) )
     
    359377(define (andmap func ls0 . rest)
    360378  (cond
     379    ;1 list
    361380    ((null? rest)
    362381      (let mapf ((ls ls0))
    363         (or (null? ls)
    364             (and (func (car ls))
    365                  (mapf (cdr ls)))) ) )
     382        (or
     383          (null? ls)
     384          (and
     385            (func (car ls))
     386            (mapf (cdr ls)))) ) )
     387    ;2 lists
    366388    ((null? (cdr rest))
    367389      (let mapf ((ls1 ls0) (ls2 (car rest)))
    368         (or (null? ls1)
    369             (and (func (car ls1) (car ls2))
    370                  (mapf (cdr ls1) (cdr ls2)))) ) )
     390        (or
     391          (null? ls1)
     392          (and
     393            (func (car ls1) (car ls2))
     394            (mapf (cdr ls1) (cdr ls2)))) ) )
     395    ;>2 lists
    371396    (else
    372397      (let mapf ((ls0 ls0) (rest rest))
    373         (or (null? ls0)
    374             (and (apply func (car ls0) (map car rest))
    375                  (mapf (cdr ls0) (map cdr rest)))) ) ) ) )
     398        (or
     399          (null? ls0)
     400          (and
     401            (apply func (car ls0) (map car rest))
     402            (mapf (cdr ls0) (map cdr rest)))) ) ) ) )
    376403
    377404(define (ormap func ls0 . rest)
    378   (and (pair? ls0)
    379        (let ((rest (cons ls0 rest)))
    380          (or (apply func (map car rest))
    381              (apply ormap func (map cdr rest)) ) ) ) )
     405  (and
     406    (pair? ls0)
     407    (let ((rest (cons ls0 rest)))
     408      (or
     409        (apply func (map car rest))
     410        (apply ormap func (map cdr rest)) ) ) ) )
     411
     412;;
     413
     414(define (*skip+ ls n)
     415  (if (or (null? ls) (fx<= n 0))
     416    (values ls n)
     417    (*skip+ (cdr ls) (fx- n 1))) )
     418
     419(define (*split-at+ ls n pads)
     420  ;Do not attempt to padout when the primary list is empty.
     421  (if (null? ls)
     422    (values '() '())
     423    (let loop ((ls ls) (n n) (part '()))
     424      (cond
     425        ((fx<= n 0)
     426          (values (reverse! part) ls) )
     427        ((null? ls)
     428          (cond
     429            ;Unless padding is desired throw away the section
     430            ((not pads)
     431              (values '() '()) )
     432            ((null? pads)
     433              (values (reverse! part) '()) )
     434            (else
     435              (values (append-reverse! part (*split-at+ pads n '())) '()) ) ) )
     436        (else
     437          (loop (cdr ls) (fx- n 1) (cons (car ls) part)) ) ) ) ) )
    382438
    383439) ;module list-utils
  • release/4/list-utils/tags/1.1.2/list-utils.setup

    r28408 r34121  
    55(verify-extension-name "list-utils")
    66
    7 (setup-shared-extension-module 'list-utils (extension-version "1.1.1")
     7(setup-shared-extension-module 'list-utils (extension-version "1.1.2")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    1111    -scrutinize
    12     -fixnum-arithmetic
    1312    -optimize-level 3 -debug-level 1
    1413    -no-procedure-checks))
  • release/4/list-utils/trunk/list-utils.scm

    r20949 r34121  
    44(module list-utils
    55
    6   (;export
    7     skip+
    8     split-at+
    9     section
    10     length=0?
    11     length=1?
    12     length=2?
    13     length>1?
    14     ensure-list
    15     not-null?
    16     alist-delete-first
    17     alist-delete-first!
    18     assoc-def
    19     assq-def
    20     assv-def
    21     alist-inverse-ref
    22     alist-delete/count
    23     alist-delete!/count
    24     plist->alist
    25     alist->plist
    26     unzip-alist
    27     zip-alist
    28     shift!
    29     unshift!
    30     shift!/set
    31     andmap
    32     ormap)
    33 
    34   (import
    35     scheme
    36     chicken
    37     (only data-structures
    38       rassoc)
    39     (only srfi-1
    40       cons* reverse! append-reverse!)
    41     (only type-checks
    42       check-list check-pair check-procedure
    43       check-fixnum check-positive-fixnum)
    44     (only type-errors
    45       error-alist define-error-type))
    46 
    47   (require-library
    48     srfi-1 type-checks type-errors)
     6(;export
     7  skip+
     8  split-at+
     9  section
     10  length=0?
     11  length=1?
     12  length=2?
     13  length>1?
     14  ensure-list
     15  not-null?
     16  alist-delete-first
     17  alist-delete-first!
     18  assoc-def
     19  assq-def
     20  assv-def
     21  alist-inverse-ref
     22  alist-delete/count
     23  alist-delete!/count
     24  plist->alist
     25  alist->plist
     26  unzip-alist
     27  zip-alist
     28  shift!
     29  unshift!
     30  shift!/set
     31  andmap
     32  ormap)
     33
     34(import scheme chicken)
     35
     36(import
     37  (only data-structures
     38    rassoc)
     39  (only srfi-1
     40    cons* reverse! append-reverse!)
     41  (only type-checks
     42    check-list check-alist check-pair check-procedure check-fixnum check-positive-fixnum)
     43  (only type-errors
     44    error-alist define-error-type))
     45(require-library
     46  data-structures srfi-1
     47  type-checks type-errors)
     48
     49;;;
    4950
    5051;; Returns the original list starting at element n.
    5152
    5253(define (skip+ ls n)
    53   (if (or (null? ls) (<= n 0)) (values ls n)
    54     (skip+ (cdr ls) (sub1 n))) )
     54  (*skip+ (check-list 'skip+ ls 'ls) (check-fixnum 'skip+ n 'n)) )
    5555
    5656;; Returns new list with all elements [0 n-1] and original list from n.
     
    6060;; no padding & paritial section.
    6161
    62 (define (split-at+ ls n #!optional (pads '()))
    63   ;Do not attempt to padout when the primary list is empty.
    64   (if (null? ls) (values '() '())
    65     (let loop ((ls ls) (n n) (part '()))
    66       (cond
    67         ((<= n 0)
    68           (values (reverse! part) ls) )
    69         ((null? ls)
    70           (cond
    71             ;Unless padding is desired throw away the section
    72             ((not pads)   (values '() '()) )
    73             ((null? pads) (values (reverse! part) '()) )
    74             (else         (values (append-reverse! part (split-at+ pads n)) '()) ) ) )
    75         (else
    76           (loop (cdr ls) (sub1 n) (cons (car ls) part)) ) ) ) ) )
     62(define (split-at+ ls n #!optional pads)
     63  (*split-at+
     64    (check-list 'split-at+ ls 'ls)
     65    (check-fixnum 'split-at+ n 'size)
     66    (and pads (check-list 'split-at+ pads 'pads))) )
    7767
    7868;; Returns sublists of length n from the list, the last sublist padded, if
    7969;; necessary and possible, from pads. The sublists are constructed starting
    80 ;; at every step element. 
     70;; at every step element.
    8171
    8272;ls - list
     
    8676
    8777(define (section ls n #!optional (step n) (pads '()))
     78  (check-list 'section ls 'ls)
    8879  (check-positive-fixnum 'section n 'size)
    8980  (check-positive-fixnum 'section step 'step)
     
    9182    ;Do not attempt to section the padding list when
    9283    ;the primary list is empty.
    93     ((null? ls)   '() )
     84    ((null? ls)
     85      '() )
    9486    (else
    9587      ;Remaining elements between sections
    96       (let ((inc (- step n)))
     88      (let ((inc (fx- step n)))
    9789        (let loop ((ls ls) (parts '()))
    9890          ;Get this section
    9991          #;(assert (not (null? ls)))
    100           (let-values (((part nls) (split-at+ ls n pads)))
     92          (let-values (((part nls) (*split-at+ ls n pads)))
    10193            (cond
    10294              ((null? nls)
    10395                ;Possible empty section when no padding.
    104                 ;otherwise complete with this, the last,
    105                 ;section
    106                 (if (null? part) (reverse! parts)
     96                ;otherwise complete with this, the last, section
     97                (if (null? part)
     98                  (reverse! parts)
    10799                  (reverse! (cons part parts)) ) )
    108100              (else
    109                 ;Skip over "between" elements and
    110                 ;continue sectioning the list.
    111                 (let ((ls (cond
    112                             ;step = n
    113                             ((zero? inc)      nls )
    114                             ;step < n so skip from starting this section element
    115                             ((negative? inc)  (skip+ ls (+ n inc)) )
    116                             ;step > n so skip remaining elements in between
    117                             (else             (skip+ nls inc) ) ) ) )
     101                ;Skip over "between" elements and continue sectioning the list.
     102                (let (
     103                    (ls
     104                      (cond
     105                        ;step = n
     106                        ((fx= 0 inc)
     107                          nls )
     108                        ;step < n so skip from starting this section element
     109                        ((fx> 0 inc)
     110                          (*skip+ ls (+ n inc)) )
     111                        ;step > n so skip remaining elements in between
     112                        (else
     113                          (*skip+ nls inc) ) ) ) )
    118114                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )
    119115
     
    129125                  (shift!/set ?var #f) )
    130126                ((_ ?var ?empval)
    131       (if (not (pair? ?var)) ?empval
    132          (let ((_tmp (car ?var)))
    133            (set! ?var (cdr ?var))
    134            _tmp ) ) ) ) )
     127      (if (not (pair? ?var))
     128        ?empval
     129        (let ((_tmp (car ?var)))
     130          (set! ?var (cdr ?var))
     131          _tmp ) ) ) ) )
    135132
    136133;; List of length = 0?
     
    171168                ((_ ?obj)
    172169      (let ((_obj ?obj))
    173         (or (and (list? _obj) _obj)
    174             (list _obj)) ) ) ) )
     170        (or
     171          (and (list? _obj) _obj)
     172          (list _obj)) ) ) ) )
    175173
    176174;; Returns #f if given list is empty and the list itself otherwise
     
    182180                ((_ ?obj)
    183181      (let ((_obj ?obj))
    184         (and (not (null? _obj))
    185              _obj) ) ) ) )
     182        (and (not (null? _obj)) _obj) ) ) ) )
    186183
    187184;; Remove 1st matching elements from the alist (functional)
     
    212209                  (assoc-def ?key ?als equal?) )
    213210                ((_ ?key ?als ?=)
    214                   (or (assoc ?key ?als ?=)
    215                       (error 'assoc-def "key not found" ?key)) )
     211                  (or
     212                    (assoc ?key ?als ?=)
     213        (error 'assoc-def "key not found" ?key)) )
    216214                ((_ ?key ?als ?= ?def)
    217       (or (assoc ?key ?als ?=)
    218           (if (procedure? ?def) (?def) ?def)) ) ) )
     215      (or
     216        (assoc ?key ?als ?=)
     217        (if (procedure? ?def) (?def) ?def)) ) ) )
    219218
    220219(define-syntax assq-def
    221220        (syntax-rules ()
    222221                ((_ ?key ?als)
    223                   (or (assq ?key ?als)
    224                       (error 'assq-def "key not found" ?key)) )
     222                  (or
     223                    (assq ?key ?als)
     224        (error 'assq-def "key not found" ?key)) )
    225225                ((_ ?key ?als ?def)
    226       (or (assq ?key ?als)
    227           (if (procedure? ?def) (?def) ?def)) ) ) )
     226      (or
     227        (assq ?key ?als)
     228        (if (procedure? ?def) (?def) ?def)) ) ) )
    228229
    229230(define-syntax assv-def
    230231        (syntax-rules ()
    231232                ((_ ?key ?als)
    232                   (or (assv ?key ?als)
    233                       (error 'assv-def "key not found" ?key)) )
     233                  (or
     234                    (assv ?key ?als)
     235        (error 'assv-def "key not found" ?key)) )
    234236                ((_ ?key ?als ?def)
    235       (or (assv ?key ?als)
    236           (if (procedure? ?def) (?def) ?def)) ) ) )
     237      (or
     238        (assv ?key ?als)
     239        (if (procedure? ?def) (?def) ?def)) ) ) )
    237240
    238241;;
     
    243246
    244247(define (plist->alist pls)
    245   (let loop ((pls pls) (als '()))
    246     (if (null? pls) (reverse! als)
     248  (let loop ((pls (check-list 'plist->alist pls)) (als '()))
     249    (if (null? pls)
     250      (reverse! als)
    247251      (let ((hd (car pls))
    248252            (tl (cdr pls)) )
    249         (if (null? tl) (error-plist 'plist->alist pls)
     253        (if (null? tl)
     254          (error-plist 'plist->alist pls)
    250255          (loop (cdr tl) (cons (cons hd (car tl)) als)) ) ) ) ) )
    251256
     
    253258
    254259(define (alist->plist als)
    255   (let loop ((als als) (pls '()))
    256     (if (null? als) (reverse! pls)
     260  (let loop ((als (check-list 'alist->plist als)) (pls '()))
     261    (if (null? als)
     262      (reverse! pls)
    257263      (let ((elt (car als)))
    258         (if (not (pair? elt)) (error-alist 'alist->plist als)
     264        (if (not (pair? elt))
     265          (error-alist 'alist->plist als)
    259266          (loop (cdr als) (cons* (cdr elt) (car elt) pls)) ) ) ) ) )
    260267
     
    262269
    263270(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
    264   (let ((elt (rassoc val alist cmp)))
    265     (if elt (car elt)
     271  (let (
     272      (elt
     273        (rassoc
     274          val
     275          (check-alist 'alist-inverse-ref alist)
     276          (check-procedure  'alist-inverse-ref cmp))))
     277    (if elt
     278      (car elt)
    266279      default ) ) )
    267280
    268281;; Remove 1st N matching elements from the alist (functional)
     282
     283(define (alist-delete/count key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
     284  (*alist-delete/count 'alist-delete/count key al cmp cnt) )
    269285
    270286(define (*alist-delete/count loc key al cmp cnt)
    271287  (check-procedure loc cmp)
    272   (let loop ((cal al) (cnt (check-fixnum loc cnt)) (oal '()))
     288  (let loop ((cal (check-list loc al)) (cnt (check-fixnum loc cnt)) (oal '()))
    273289    (cond
    274290      ((null? cal)
     
    277293        (let ((elt (car cal))
    278294              (nxt (cdr cal)))
    279           (if (not (pair? elt)) (error-alist loc  al)
     295          (if (not (pair? elt))
     296            (error-alist loc  al)
    280297            (if (positive? cnt)
    281298              ; then more deletion to attempt
    282299              (if (cmp key (car elt))
    283                   (loop nxt (sub1 cnt) oal)
    284                   (loop nxt cnt (cons elt oal)) )
     300                (loop nxt (sub1 cnt) oal)
     301                (loop nxt cnt (cons elt oal)) )
    285302              ; else copy rest of spine
    286303              (loop nxt 0 (cons elt oal)) ) ) ) )
     
    288305        (error-alist loc al) ) ) ) )
    289306
    290 (define (alist-delete/count key al #!optional (cmp eqv?) (cnt 1073741823))
    291   (*alist-delete/count 'alist-delete/count key al cmp cnt) )
    292 
    293307;; Remove 1st N matching elements from the alist (destructive)
     308
     309(define (alist-delete!/count key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
     310  (*alist-delete!/count 'alist-delete!/count key al cmp cnt) )
    294311
    295312(define (*alist-delete!/count loc key al cmp cnt)
    296313  (check-procedure loc cmp)
    297   (let ((ral al))
     314  (let ((ral (check-list loc al)))
    298315    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
    299316      (cond
    300         ((or (null? cal) (not (positive? cnt)))
     317        ((or (null? cal) (fx>= 0 cnt))
    301318          ral )
    302319        ((pair? cal)
    303320          (let ((elt (car cal))
    304321                (nxt (cdr cal)))
    305             (if (not (pair? elt)) (error-alist loc al)
    306                 (cond
    307                   ((cmp key (car elt))
    308                     (if pal (set-cdr! pal nxt)
    309                       (set! ral nxt) )
    310                     (loop nxt pal (sub1 cnt)) )
    311                    (else
    312                      (loop nxt cal cnt) ) ) ) ) )
     322            (if (not (pair? elt))
     323              (error-alist loc al)
     324              (cond
     325                ((cmp key (car elt))
     326                  (if pal (set-cdr! pal nxt)
     327                    (set! ral nxt) )
     328                  (loop nxt pal (fx- cnt 1)) )
     329                 (else
     330                   (loop nxt cal cnt) ) ) ) ) )
    313331        (else
    314332          (error-alist loc al) ) ) ) ) )
    315333
    316 (define (alist-delete!/count key al #!optional (cmp eqv?) (cnt 1073741823))
    317   (*alist-delete!/count 'alist-delete!/count key al cmp cnt) )
    318 
    319334;; Returns alist of improper lists
    320335;; The keys & vals lists must be of the same length!
     
    322337; This works with any proper list, not just an alist.
    323338(define (zip-alist keys vals)
    324   (unless (= (length (check-list 'zip-alist keys))
    325             (length (check-list 'zip-alist vals)))
     339  (unless
     340      (= (length (check-list 'zip-alist keys)) (length (check-list 'zip-alist vals)))
    326341    (error 'zip-alist "lists are not of same length" keys vals) )
    327342  (map cons keys vals) )
     
    331346(define (unzip-alist al)
    332347  (let loop ((al (check-list 'unzip-alist al)) (keys '()) (vals '()))
    333     (if (null? al) (values (reverse! keys) (reverse! vals))
     348    (if (null? al)
     349      (values (reverse! keys) (reverse! vals))
    334350      (let ((elt (car al)))
    335         (if (not (pair? elt)) (error-alist 'unzip-alist al)
    336             (loop (cdr al) (cons (car elt) keys) (cons (cdr elt) vals)) ) ) ) ) )
     351        (unless (pair? elt)
     352          (error-alist 'unzip-alist al) )
     353        (loop (cdr al) (cons (car elt) keys) (cons (cdr elt) vals)) ) ) ) )
    337354
    338355;;; Handy little things:
    339356
    340357(define (shift! ls #!optional default)
    341   (if (null? ls) default
     358  (check-list 'shift! ls)
     359  (if (null? ls)
     360    default
    342361    (begin
    343       (check-pair 'shift! ls)
    344362      (let ((x (car ls))
    345363            (d (cdr ls)) )
     
    359377(define (andmap func ls0 . rest)
    360378  (cond
     379    ;1 list
    361380    ((null? rest)
    362381      (let mapf ((ls ls0))
    363         (or (null? ls)
    364             (and (func (car ls))
    365                  (mapf (cdr ls)))) ) )
     382        (or
     383          (null? ls)
     384          (and
     385            (func (car ls))
     386            (mapf (cdr ls)))) ) )
     387    ;2 lists
    366388    ((null? (cdr rest))
    367389      (let mapf ((ls1 ls0) (ls2 (car rest)))
    368         (or (null? ls1)
    369             (and (func (car ls1) (car ls2))
    370                  (mapf (cdr ls1) (cdr ls2)))) ) )
     390        (or
     391          (null? ls1)
     392          (and
     393            (func (car ls1) (car ls2))
     394            (mapf (cdr ls1) (cdr ls2)))) ) )
     395    ;>2 lists
    371396    (else
    372397      (let mapf ((ls0 ls0) (rest rest))
    373         (or (null? ls0)
    374             (and (apply func (car ls0) (map car rest))
    375                  (mapf (cdr ls0) (map cdr rest)))) ) ) ) )
     398        (or
     399          (null? ls0)
     400          (and
     401            (apply func (car ls0) (map car rest))
     402            (mapf (cdr ls0) (map cdr rest)))) ) ) ) )
    376403
    377404(define (ormap func ls0 . rest)
    378   (and (pair? ls0)
    379        (let ((rest (cons ls0 rest)))
    380          (or (apply func (map car rest))
    381              (apply ormap func (map cdr rest)) ) ) ) )
     405  (and
     406    (pair? ls0)
     407    (let ((rest (cons ls0 rest)))
     408      (or
     409        (apply func (map car rest))
     410        (apply ormap func (map cdr rest)) ) ) ) )
     411
     412;;
     413
     414(define (*skip+ ls n)
     415  (if (or (null? ls) (fx<= n 0))
     416    (values ls n)
     417    (*skip+ (cdr ls) (fx- n 1))) )
     418
     419(define (*split-at+ ls n pads)
     420  ;Do not attempt to padout when the primary list is empty.
     421  (if (null? ls)
     422    (values '() '())
     423    (let loop ((ls ls) (n n) (part '()))
     424      (cond
     425        ((fx<= n 0)
     426          (values (reverse! part) ls) )
     427        ((null? ls)
     428          (cond
     429            ;Unless padding is desired throw away the section
     430            ((not pads)
     431              (values '() '()) )
     432            ((null? pads)
     433              (values (reverse! part) '()) )
     434            (else
     435              (values (append-reverse! part (*split-at+ pads n '())) '()) ) ) )
     436        (else
     437          (loop (cdr ls) (fx- n 1) (cons (car ls) part)) ) ) ) ) )
    382438
    383439) ;module list-utils
  • release/4/list-utils/trunk/list-utils.setup

    r28408 r34121  
    55(verify-extension-name "list-utils")
    66
    7 (setup-shared-extension-module 'list-utils (extension-version "1.1.1")
     7(setup-shared-extension-module 'list-utils (extension-version "1.1.2")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    1111    -scrutinize
    12     -fixnum-arithmetic
    1312    -optimize-level 3 -debug-level 1
    1413    -no-procedure-checks))
Note: See TracChangeset for help on using the changeset viewer.