source: project/misc-extn/trunk/misc-extn-dsssl-support.scm @ 6202

Last change on this file since 6202 was 6202, checked in by Kon Lovett, 14 years ago

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

File size: 1.6 KB
Line 
1;;;; misc-extn-dsssl-support.scm
2;;;; Kon Lovett, Aug '07
3
4(use srfi-1)
5
6(eval-when (compile)
7  (declare
8    (fixnum)
9    (inline)
10    (no-procedure-checks)
11    (no-bound-checks)
12    (export
13      fixup-extended-lambda-list-rest
14      fixup-extended-lambda-list-optional
15      fixup-extended-lambda-list) ) )
16
17;;; DSSSL Extended Lambda List
18
19;; Remove any keywords & keyword-value pairs from a #!rest argument.
20
21(define (fixup-extended-lambda-list-rest keys rest #!optional (skip? #f))
22  (let loop ([rest rest] [skip? skip?] [lst '()])
23    (if (null? rest)
24        (reverse! lst)
25        (let ([arg (car rest)]
26              [nxt (cdr rest)])
27          (cond [skip?            (loop nxt #f lst)]
28                [(memq arg keys)  (loop nxt #t lst)]
29                [else             (loop nxt #f (cons arg lst))]) ) ) ) )
30
31;; Remove any keyword from #!optional argument.
32
33(define (fixup-extended-lambda-list-optional keys . opts)
34  (let loop ([opts opts] [skip? #f] [lst '()])
35    (if (null? opts)
36        (values skip? (reverse! lst))
37        (let ([opt (car opts)]
38              [nxt (cdr opts)])
39          (let ([val (car opt)]
40                [def (cadr opt)])
41            (cond [skip?            (loop nxt #f (cons def lst))]
42                  [(memq val keys)  (loop nxt #t (cons def lst))]
43                  [else             (loop nxt #f (cons val lst))]) ) ) ) ) )
44
45;; Remove any keywords & keyword-value pairs from a #!rest argument.
46
47(define (fixup-extended-lambda-list keys rest . opts)
48  (let-values ([(skip? fixed-opts) (apply fixup-extended-lambda-list-optional keys opts)])
49    (apply values (fixup-extended-lambda-list-rest keys rest skip?) fixed-opts) ) )
Note: See TracBrowser for help on using the repository browser.