SRFI-61

srfi/61.scm

@@ -0,0 +1,47 @@
+;; Copyright (c) 2005 Taylor Campbell
+;; Reference implementation of SRFI-61
+;; 
+;; Adapted to Blackhole for Gambit by Álvaro Castro-Castilla
+
+(define-syntax cond
+  (syntax-rules (=> else)
+
+    ((cond (else else1 else2 ...))
+     ;; the (if #t (begin ...)) wrapper ensures that there may be no
+     ;; internal definitions in the body of the clause.  R5RS mandates
+     ;; this in text (by referring to each subform of the clauses as
+     ;; <expression>) but not in its reference implementation of cond,
+     ;; which just expands to (begin ...) with no (if #t ...) wrapper.
+     (if #t (begin else1 else2 ...)))
+
+    ((cond (test => receiver) more-clause ...)
+     (let ((t test))
+       (cond/maybe-more t
+                        (receiver t)
+                        more-clause ...)))
+
+    ((cond (generator guard => receiver) more-clause ...)
+     (call-with-values (lambda () generator)
+       (lambda t
+         (cond/maybe-more (apply guard    t)
+                          (apply receiver t)
+                          more-clause ...))))
+
+    ((cond (test) more-clause ...)
+     (let ((t test))
+       (cond/maybe-more t t more-clause ...)))
+
+    ((cond (test body1 body2 ...) more-clause ...)
+     (cond/maybe-more test
+                      (begin body1 body2 ...)
+                      more-clause ...))))
+
+(define-syntax cond/maybe-more
+  (syntax-rules ()
+    ((cond/maybe-more test consequent)
+     (if test
+         consequent))
+    ((cond/maybe-more test consequent clause ...)
+     (if test
+         consequent
+         (cond clause ...)))))

srfi/test-2.scm → srfi/test/2.scm

@@ -1,5 +1,5 @@
-(import ./64)
-(import ./2)
+(import ../64)
+(import ../2)
 
 (test-begin "srfi-2" 31)
 

srfi/test/61.scm

@@ -0,0 +1,16 @@
+(import ../64)
+(import ../61)
+
+(test-begin "srfi-61" 1)
+
+;; From SRFI-61 document
+(define (port->char-list port)
+  (cond
+    ((read-char port) char?
+     => (lambda (c) (cons c (port->char-list port))))
+    (else '())))
+
+(test-assert
+  (port->char-list (open-input-file "61.scm")))
+
+(test-end "srfi-61")

srfi/test-64.scm → srfi/test/64.scm

@@ -1,4 +1,4 @@
-(import ./64)
+(import ../64)
 
 (define my-simple-runner (test-runner-simple))
 (test-runner-factory