guile/guile-core/ice-9 ChangeLog boot-9.scm

[Martin Grabmueller]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Martin Grabmueller <address@hidden>     01/05/10 22:41:05

Modified files:
        guile-core/ice-9: ChangeLog boot-9.scm 

Log message:
        * boot-9.scm: Added `cond-expand' (SRFI-0) for portable feature
        checking.

CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/ChangeLog.diff?cvsroot=OldCVS&tr1=1.420&tr2=1.421&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/boot-9.scm.diff?cvsroot=OldCVS&tr1=1.241&tr2=1.242&r1=text&r2=text

Patches:
Index: guile/guile-core/ice-9/ChangeLog
diff -u guile/guile-core/ice-9/ChangeLog:1.420 
guile/guile-core/ice-9/ChangeLog:1.421
--- guile/guile-core/ice-9/ChangeLog:1.420      Thu May 10 15:03:48 2001
+++ guile/guile-core/ice-9/ChangeLog    Thu May 10 22:41:03 2001
@@ -1,3 +1,8 @@
+2001-05-11  Martin Grabmueller  <address@hidden>
+
+       * boot-9.scm: Added `cond-expand' (SRFI-0) for portable feature
+       checking.
+
 2001-05-10  Thien-Thi Nguyen  <address@hidden>
 
        * boot-9.scm (resolve-module): Abstraction maintenance: Use
Index: guile/guile-core/ice-9/boot-9.scm
diff -u guile/guile-core/ice-9/boot-9.scm:1.241 
guile/guile-core/ice-9/boot-9.scm:1.242
--- guile/guile-core/ice-9/boot-9.scm:1.241     Thu May 10 15:00:22 2001
+++ guile/guile-core/ice-9/boot-9.scm   Thu May 10 22:41:03 2001
@@ -2686,6 +2686,97 @@
 
 (define load load-module)
 
+
+
+;;; {`cond-expand' for SRFI-0 support.}
+;;;
+;;; This syntactic form expands into different commands or
+;;; definitions, depending on the features provided by the Scheme
+;;; implementation.
+;;;
+;;; Syntax:
+;;;
+;;; <cond-expand>
+;;;   --> (cond-expand <cond-expand-clause>+)
+;;;     | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
+;;; <cond-expand-clause>
+;;;   --> (<feature-requirement> <command-or-definition>*)
+;;; <feature-requirement>
+;;;   --> <feature-identifier>
+;;;     | (and <feature-requirement>*)
+;;;     | (or <feature-requirement>*)
+;;;     | (not <feature-requirement>)
+;;; <feature-identifier>
+;;;   --> <a symbol which is the name or alias of a SRFI>
+;;;
+;;; Additionally, this implementation provides the
+;;; <feature-identifier>s `guile' and `r5rs', so that programs can
+;;; determine the implementation type and the supported standard.
+;;;
+;;; Currently, the following feature identifiers are supported:
+;;;
+;;;   guile r5rs srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-11 srfi-13
+;;;   srfi-14 srfi-17 srfi-19
+;;;
+;;; Remember to update the features list when adding more SRFIs.
+
+(define-macro (cond-expand clause . clauses)
+  (define features
+    '(guile r5rs srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-11 srfi-13
+           srfi-14 srfi-17 srfi-19))
+  (let ((clauses (cons clause clauses))
+       (syntax-error (lambda (cl)
+                       (error "invalid clause in `cond-expand'" cl))))
+    (letrec
+       ((test-clause
+         (lambda (clause)
+           (cond
+             ((symbol? clause)
+              (memq clause features))
+             ((pair? clause)
+              (cond
+                ((eq? 'and (car clause))
+                 (let lp ((l (cdr clause)))
+                   (cond ((null? l)
+                          #t)
+                         ((pair? l)
+                          (and (test-clause (car l)) (lp (cdr l))))
+                         (else
+                          (syntax-error clause)))))
+                ((eq? 'or (car clause))
+                 (let lp ((l (cdr clause)))
+                   (cond ((null? l)
+                          #f)
+                         ((pair? l)
+                          (or (test-clause (car l)) (lp (cdr l))))
+                         (else
+                          (syntax-error clause)))))
+                ((eq? 'not (car clause))
+                 (cond ((not (pair? (cdr clause)))
+                        (syntax-error clause))
+                       ((pair? (cddr clause))
+                        ((syntax-error clause))))
+                 (not (test-clause (cadr clause))))
+                (else
+                 (syntax-error clause))))
+             (else
+              (syntax-error clause))))))
+      (let lp ((c clauses))
+       (cond
+         ((null? c)
+          (error "Unfulfilled `cond-expand'"))
+         ((not (pair? c))
+          (syntax-error c))
+         ((not (pair? (car c)))
+          (syntax-error (car c)))
+         ((test-clause (caar c))
+          `(begin ,@(cdar c)))
+         ((eq? (caar c) 'else)
+          (if (pair? (cdr c))
+            (syntax-error c))
+          `(begin ,@(cdar c)))
+         (else
+          (lp (cdr c))))))))