1;;  Filename : srfi-0.scm
2;;  About    : SRFI-0 Feature-based conditional expansion construct
3;;
4;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
5;;
6;;  All rights reserved.
7;;
8;;  Redistribution and use in source and binary forms, with or without
9;;  modification, are permitted provided that the following conditions
10;;  are met:
11;;
12;;  1. Redistributions of source code must retain the above copyright
13;;     notice, this list of conditions and the following disclaimer.
14;;  2. Redistributions in binary form must reproduce the above copyright
15;;     notice, this list of conditions and the following disclaimer in the
16;;     documentation and/or other materials provided with the distribution.
17;;  3. Neither the name of authors nor the names of its contributors
18;;     may be used to endorse or promote products derived from this software
19;;     without specific prior written permission.
20;;
21;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
25;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
34(require-extension (srfi 23))
35
36(define-macro %cond-expand-dummy
37  (lambda () #t))
38
39(define %cond-expand-feature?
40  (lambda (feature-exp)
41    (cond
42     ((symbol? feature-exp)
43      (or (eq? feature-exp 'else)
44          (provided? (symbol->string feature-exp))))
45     ((pair? feature-exp)
46      (let ((directive (car feature-exp))
47            (args (cdr feature-exp)))
48      (case directive
49        ((and)
50         ;;(every %cond-expand-feature? args))
51         (not (memq #f (map %cond-expand-feature? args))))
52        ((or)
53         ;;(any %cond-expand-feature? args))
54         (not (not (memq #t (map %cond-expand-feature? args)))))
55        ((not)
56         (if (not (null? (cdr args)))
57             (error "invalid feature expression"))
58         (not (%cond-expand-feature? (car args))))
59        (else
60         (error "invalid feature expression"))))))))
61
62(define-macro cond-expand
63  (lambda clauses
64    (if (null? clauses)
65        (error "unfulfilled cond-expand")
66;;        (let ((clause (find (lambda (clause)
67;;                              (%cond-expand-feature? (car clause)))
68;;                            clauses)))
69        (let ((clause (let rec ((rest clauses))
70                          (cond
71                           ((null? rest)
72                            #f)
73                           ((%cond-expand-feature? (caar rest))
74                            (car rest))
75                           (else
76                            (rec (cdr rest)))))))
77          (if clause
78              `(begin
79                 ;; raise error if cond-expand is placed in non-toplevel
80                 (define-macro %cond-expand-dummy (lambda () #t))
81                 . ,(cdr clause))
82              (error "unfulfilled cond-expand"))))))
83