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