Changeset 6202 in project for misc-extn/trunk/misc-extn-list.scm


Ignore:
Timestamp:
09/30/07 05:36:48 (14 years ago)
Author:
Kon Lovett
Message:

Rmvd extra dsssl-fixup, put test of dsssl-fixup back in testbase test, works w/ hygienic macros.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • misc-extn/trunk/misc-extn-list.scm

    r6200 r6202  
    4040       (and (not (null? ,lstvar))
    4141            ,lstvar) ) ) )
     42
     43;; Remove 1st matching elements from the alist [functional]
     44
     45(define-macro (alist-delete-first ?key ?al . ?rest)
     46  (let-optionals ?rest ([?cmp 'eqv?])
     47    `(alist-delete/count ,?key ,?al ,?cmp 1) ) )
     48
     49;; Remove 1st matching elements from the alist [destructive]
     50
     51(define-macro (alist-delete-first! ?key ?al . ?rest)
     52  (let-optionals ?rest ([?cmp 'eqv?])
     53    `(alist-delete!/count ,?key ,?al ,?cmp 1) ) )
    4254
    4355;; shift! with a variable
     
    90102              `(error 'assv-def "key not found" ,key))])
    91103    `(or (assv ,key ,alist) ,default-action) ) )
    92 
    93 ;; Remove 1st matching elements from the alist [functional]
    94 
    95 (define-macro (alist-delete-first ?key ?al . ?rest)
    96   (let-optionals ?rest ([?cmp 'eqv?])
    97     `(alist-delete/count ,?key ,?al ,?cmp 1) ) )
    98 
    99 ;; Remove 1st matching elements from the alist [destructive]
    100 
    101 (define-macro (alist-delete-first! ?key ?al . ?rest)
    102   (let-optionals ?rest ([?cmp 'eqv?])
    103     `(alist-delete!/count ,?key ,?al ,?cmp 1) ) )
    104 
    105 ;;
    106 
    107 (define-macro (dsssl-fixup ?keys ?opts ?rest . ?body)
    108   (let-values (
    109       [(optvars optvals)
    110         (let loop ([opts ?opts]
    111                    [varlst '()]
    112                    [vallst '()])
    113           (if (null? opts)
    114               (values (reverse varlst) (reverse vallst))
    115               (let* ([opt (car opts)]
    116                      [var (car opt)])
    117                 (loop (cdr opts)
    118                       (cons var varlst)
    119                       (cons `(list ,var ,(cadr opt)) vallst)))))])
    120     `(let-values ([(,?rest ,@optvars) (fixup-extended-lambda-list ,?keys ,?rest ,@optvals)])
    121        ,@?body ) ) )
Note: See TracChangeset for help on using the changeset viewer.