Changeset 6202 in project


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.

Location:
misc-extn/trunk
Files:
1 deleted
8 edited

Legend:

Unmodified
Added
Removed
  • misc-extn/trunk/misc-extn-dsssl-support.scm

    r6200 r6202  
    1111    (no-bound-checks)
    1212    (export
    13       filter-rest-argument!
    1413      fixup-extended-lambda-list-rest
    1514      fixup-extended-lambda-list-optional
     
    1716
    1817;;; DSSSL Extended Lambda List
    19 
    20 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    21 
    22 (define (filter-rest-argument! args #!optional testarg)
    23   (let* (
    24       [make-pred
    25         (lambda (itmtst)
    26           (let ([key? #f])
    27             (lambda (arg)
    28               (cond [key?
    29                       (set! key? #f)
    30                       #f]
    31                     [(keyword? arg)
    32                       (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
    33                     [else
    34                       #t]))))]
    35       [pred
    36         (cond [(procedure? testarg)   testarg]
    37               [(list? testarg)        (make-pred memq)]
    38               [(not testarg)          (make-pred (lambda (arg lst) #t))]
    39               [else
    40                 (error 'filter-rest-argument!
    41                   "test argument not a procedure or list" testarg)])])
    42     (filter! pred args) ) )
    4318
    4419;; Remove any keywords & keyword-value pairs from a #!rest argument.
  • misc-extn/trunk/misc-extn-dsssl.scm

    r6200 r6202  
    44;;; DSSSL Extended Lambda List
    55
    6 (cond-expand
    7   [hygienic-macros
    8 (syntax-error 'dsssl-fixup "unsupported by hygienic macros") ]
    9   [else
    106(define-macro (dsssl-fixup ?keys ?opts ?rest . ?body)
    117  (let-values (
     
    2319    `(let-values ([(,?rest ,@optvars)
    2420                   (fixup-extended-lambda-list ',?keys ,?rest ,@optvals)])
    25        ,@?body ) ) ) ] )
     21       ,@?body ) ) )
  • misc-extn/trunk/misc-extn-eggdoc.scm

    r6200 r6202  
    260260
    261261        (usage "(require-extension misc-extn-dsssl)")
    262 
    263         (procedure "(filter-rest-argument! REST-LIST [PREDICATE | LIST-OF-KEYWORD])"
    264           (p "Destructively remove any keywords & keyword+value items from a "
    265           (code "#!rest") " argument list.")
    266 
    267           (p "When the optional predicate is supplied it must return "
    268           (code "#t") " or " (code "#f") " indicating whether the item "
    269           "is to kept or removed. The predicate takes the current item.")
    270 
    271           (p "When the optional keyword list is supplied only keywords & "
    272           "keyword+value items from the list are removed."))
    273262
    274263        (procedure "(fixup-extended-lambda-list-rest LIST-OF-KEYWORD REST-LIST)"
     
    702691
    703692    (history
    704       (version "3.003" "Added list macros. Deprecated alist-delete*. Added misc-extn-dsssl.")
     693      (version "3.003" "Added list macros. Deprecated alist-delete*, filter-rest-argument!. Added misc-extn-dsssl.")
    705694      (version "3.002" "Reverted to 3.0 behavior for unbound Wasn't a bug.")
    706695      (version "3.001" "Bugfix for unbound")
  • misc-extn/trunk/misc-extn-list-support.scm

    r6200 r6202  
    1111    (no-bound-checks)
    1212    (export
     13      ;; Deprecated
     14      filter-rest-argument!
     15      ;;
    1316      length=0? length=1? length=2? length>1?
    1417      ensure-list
     
    195198(define unzip-alist unzip2)
    196199(define zip-alist zip)
     200
     201;;; Deprecated
     202
     203;; Remove any keywords & keyword-value pairs from a #!rest argument.
     204
     205(define (filter-rest-argument! args #!optional testarg)
     206  (let* (
     207      [make-pred
     208        (lambda (itmtst)
     209          (let ([key? #f])
     210            (lambda (arg)
     211              (cond [key?
     212                      (set! key? #f)
     213                      #f]
     214                    [(keyword? arg)
     215                      (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
     216                    [else
     217                      #t]))))]
     218      [pred
     219        (cond [(procedure? testarg)   testarg]
     220              [(list? testarg)        (make-pred memq)]
     221              [(not testarg)          (make-pred (lambda (arg lst) #t))]
     222              [else
     223                (error 'filter-rest-argument!
     224                  "test argument not a procedure or list" testarg)])])
     225    (filter! pred args) ) )
  • 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 ) ) )
  • misc-extn/trunk/misc-extn.html

    r6200 r6202  
    284284<div class="section">
    285285<h3>Usage</h3>(require-extension misc-extn-dsssl)</div>
    286 <dt class="definition"><strong>procedure:</strong> (filter-rest-argument! REST-LIST [PREDICATE | LIST-OF-KEYWORD])</dt>
    287 <dd>
    288 <p>Destructively remove any keywords &amp; keyword+value items from a <code>#!rest</code> argument list.</p>
    289 <p>When the optional predicate is supplied it must return <code>#t</code> or <code>#f</code> indicating whether the item is to kept or removed. The predicate takes the current item.</p>
    290 <p>When the optional keyword list is supplied only keywords &amp; keyword+value items from the list are removed.</p></dd>
    291286<dt class="definition"><strong>procedure:</strong> (fixup-extended-lambda-list-rest LIST-OF-KEYWORD REST-LIST)</dt>
    292287<dd>
     
    668663<h3>Version</h3>
    669664<ul>
    670 <li>3.003 Added list macros. Deprecated alist-delete*. Added misc-extn-dsssl.</li>
     665<li>3.003 Added list macros. Deprecated alist-delete*, filter-rest-argument!. Added misc-extn-dsssl.</li>
    671666<li>3.002 Reverted to 3.0 behavior for unbound Wasn't a bug.</li>
    672667<li>3.001 Bugfix for unbound</li>
  • misc-extn/trunk/tests/misc-extn-test.scm

    r6200 r6202  
    11;;;; misc-extn-test.scm
    22
    3 (use testbase testbase-output-compact)
     3(use testbase testbase-output-human)
    44#;(use misc-extn-condition)
    55(use misc-extn-control)
     
    1010(use misc-extn-record)
    1111(use misc-extn-symbol)
     12(use misc-extn-dsssl)
    1213
    1314;;;
     
    101102)
    102103
     104;;
     105
     106(define-test misc-extn-dsssl-test "DSSSL"
     107  (initial
     108    (define (foo a1 a2 #!optional (o1 'x) (o2 'y) #!rest rest #!key (k1 100) (k2 200))
     109      (dsssl-fixup (#:k1 #:k2) ((o1 'x) (o2 'y)) rest
     110        (list a1 a2 o1 o2 k1 k2 rest) ) ) )
     111
     112  (expect-equal '(1 2 x y 100 200 ()) (foo 1 2))
     113  (expect-equal '(1 2 3 4 100 200 (5)) (foo 1 2 3 4 5))
     114  (expect-equal '(1 2 3 y 100 2000 (5)) (foo 1 2 3 #:k2 2000 5))
     115)
     116
    103117;;;
    104118
    105 (test::for-each (cut test::styler-set! <> test::output-style-compact))
     119(test::for-each (cut test::styler-set! <> test::output-style-human))
    106120(run-test "Misc-Extn Tests")
  • misc-extn/trunk/tests/run.scm

    r6200 r6202  
    1717
    1818(system* "~A ~A ~A" TESTBASE-TEST-DRIVER *test-driver-arguments* "*-test.scm")
    19 
    20 ;;
    21 
    22 (system "csi -s test-misc-extn-dssl.scm")
Note: See TracChangeset for help on using the changeset viewer.