Permalink
Browse files

SRFI-61

  • Loading branch information...
1 parent ffafe66 commit d6d085797d01a788afc28603ff46b52560de5846 Álvaro Castro-Castilla committed May 27, 2010
Showing with 66 additions and 3 deletions.
  1. +47 −0 srfi/61.scm
  2. +2 −2 srfi/{test-2.scm → test/2.scm}
  3. +16 −0 srfi/test/61.scm
  4. +1 −1 srfi/{test-64.scm → test/64.scm}
View
@@ -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 ...)))))
@@ -1,5 +1,5 @@
-(import ./64)
-(import ./2)
+(import ../64)
+(import ../2)
(test-begin "srfi-2" 31)
View
@@ -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")
@@ -1,4 +1,4 @@
-(import ./64)
+(import ../64)
(define my-simple-runner (test-runner-simple))
(test-runner-factory

0 comments on commit d6d0857

Please sign in to comment.