unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* Two r6rs bugs
@ 2012-11-22 10:35 Ian Price
  2012-11-22 11:38 ` Mike Gran
                   ` (2 more replies)
  0 siblings, 3 replies; 9+ messages in thread
From: Ian Price @ 2012-11-22 10:35 UTC (permalink / raw)
  To: guile-devel; +Cc: Mark H. Weaver

[-- Attachment #1: Type: text/plain, Size: 1099 bytes --]


I've attached two patches.

The first replaces the definition of string-for-each in (rnrs
base). R6RS's version of string-for-each is not the same as srfi 13's
string for each (which guile provides by default). Rather, it is more
closely analogous to the usual multi-list definition of for-each. The
R6RS specifies that all arguments must have the same length, and so I've
thrown an &assertion in this case.

The second one is a change to resolve-r6rs-interface. Previously
mark-weaver [0], changes this so that it would correctly look up
submodules under the srfi namespace, but in doing so took into account
the srfi 97[1] library name, which it should not have done. I have added a
comment to this effect in the source.

I should have noticed this at the time, but I didn't until I rebuilt and my
.guile broke :)

0. https://lists.gnu.org/archive/html/guile-devel/2012-11/msg00011.html
1. http://srfi.schemers.org/srfi-97/srfi-97.html

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: string-for-each patch --]
[-- Type: text/x-patch, Size: 4246 bytes --]

From 5f06983d26ccbd7410891730664aa83bef79e763 Mon Sep 17 00:00:00 2001
From: Ian Price <ianprice90@googlemail.com>
Date: Thu, 22 Nov 2012 09:45:12 +0000
Subject: [PATCH 1/2] R6RS `string-for-each' should accept multiple string
 arguments

* module/rnrs/base.scm (string-for-each): Rewrite.
* test-suite/tests/r6rs-base.test ("string-for-each"): Add tests.
---
 module/rnrs/base.scm            |   39 +++++++++++++++++++++++++++++++++++++-
 test-suite/tests/r6rs-base.test |   40 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 78 insertions(+), 1 deletions(-)

diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 499a224..9fedac0 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -73,7 +73,7 @@
 	  let-syntax letrec-syntax
 
 	  syntax-rules identifier-syntax)
-  (import (rename (except (guile) error raise map)
+  (import (rename (except (guile) error raise map string-for-each)
                   (log log-internal)
                   (euclidean-quotient div)
                   (euclidean-remainder mod)
@@ -86,6 +86,43 @@
                   (inexact->exact exact))
           (srfi srfi-11))
 
+ (define string-for-each
+   (case-lambda
+     ((proc string)
+      (let ((end (string-length string)))
+        (let loop ((i 0))
+          (unless (= i end)
+            (proc (string-ref string i))
+            (loop (+ i 1))))))
+     ((proc string1 string2)
+      (let ((end1 (string-length string1))
+            (end2 (string-length string2)))
+        (unless (= end1 end2)
+          (assertion-violation 'string-for-each
+                               "string arguments must all have the same length"
+                               string1 string2))
+        (let loop ((i 0))
+          (unless (= i end1)
+            (proc (string-ref string1 i)
+                  (string-ref string2 i))
+            (loop (+ i 1))))))
+     ((proc string . strings)
+      (let ((end (string-length string))
+            (ends (map string-length strings)))
+        (for-each (lambda (x)
+                    (unless (= end x)
+                      (apply assertion-violation
+                             'string-for-each
+                             "string arguments must all have the same length"
+                             string strings)))
+                  ends)
+        (let loop ((i 0))
+          (unless (= i end)
+            (apply proc
+                   (string-ref string i)
+                   (map (lambda (s) (string-ref s i)) strings))
+            (loop (+ i 1))))))))
+
  (define map
    (case-lambda
      ((f l)
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index df11d67..fb49141 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -196,3 +196,43 @@
     (guard (condition ((assertion-violation? condition) #t))
       (assert #f)
       #f)))
+
+(with-test-prefix "string-for-each"
+  (pass-if "reverse string"
+    (let ((s "reverse me") (l '()))
+      (string-for-each (lambda (x) (set! l (cons x l))) s)
+      (equal? "em esrever" (list->string l))))
+  (pass-if "two strings good"
+    (let ((s1 "two legs good")
+          (s2 "four legs bad")
+          (c '()))
+      (string-for-each (lambda (c1 c2)
+                         (set! c (cons* c2 c1 c)))
+                       s1 s2)
+      (equal? (list->string c)
+              "ddaobo gs gsegle lr uoowft")))
+  (pass-if "two strings bad"
+    (let ((s1 "frotz")
+          (s2 "veeblefetzer"))
+      (guard (condition ((assertion-violation? condition) #t))
+        (string-for-each (lambda (s1 s2) #f) s1 s2)
+        #f)))
+  (pass-if "many strings good"
+    (let ((s1 "foo")
+          (s2 "bar")
+          (s3 "baz")
+          (s4 "zot")
+          (c '()))
+      (string-for-each (lambda (c1 c2 c3 c4)
+                         (set! c (cons* c4 c3 c2 c1 c)))
+                       s1 s2 s3 s4)
+      (equal? (list->string c)
+              "tzrooaaozbbf")))
+  (pass-if "many strings bad"
+    (let ((s1 "foo")
+          (s2 "bar")
+          (s3 "baz")
+          (s4 "quux"))
+      (guard (condition ((assertion-violation? condition) #t))
+        (string-for-each (lambda _ #f) s1 s2 s3 s4)
+        #f))))
-- 
1.7.7.6


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: r6rs libraries patch --]
[-- Type: text/x-patch, Size: 2004 bytes --]

From 3c73a30c89e005927dcd6239b54e752c05c2a48f Mon Sep 17 00:00:00 2001
From: Ian Price <ianprice90@googlemail.com>
Date: Thu, 22 Nov 2012 10:16:44 +0000
Subject: [PATCH 2/2] R6RS srfi library names should ignore first identifier
 after the :n

* module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface):
  (srfi :n name ids ...) -> (srfi srfi-n ids ...)
* test-suite/tests/rnrs-libraries.test ("srfi"): Add test.
---
 module/ice-9/r6rs-libraries.scm      |    6 +++++-
 test-suite/tests/rnrs-libraries.test |    4 +++-
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index 019a6a7..9fef7a2 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -40,7 +40,11 @@
                      (substring (symbol->string (syntax->datum #'colon-n))
                                 1)))))
        (resolve-r6rs-interface
-        #`(library (srfi #,srfi-n rest ... (version ...))))))
+        (if (null? #'(rest ...))
+            #`(library (srfi #,srfi-n (version ...)))
+            ;; SRFI 97 says that the first identifier after the colon-n
+            ;; is used for the libraries name, so it must be ignored.
+            #`(library (srfi #,srfi-n #,@(cdr #'(rest ...)) (version ...)))))))
     
     ((library (name name* ... (version ...)))
      (and-map sym? #'(name name* ...))
diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test
index e961c28..9add98a 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -183,7 +183,9 @@
   (with-test-prefix "srfi"
     (pass-if "renaming works"
       (eq? (resolve-interface '(srfi srfi-1))
-           (resolve-r6rs-interface '(srfi :1)))))
+           (resolve-r6rs-interface '(srfi :1)))
+      (eq? (resolve-interface '(srfi srfi-1))
+           (resolve-r6rs-interface '(srfi :1 lists)))))
 
   (with-test-prefix "macro"
     (pass-if "multiple clauses"
-- 
1.7.7.6


^ permalink raw reply related	[flat|nested] 9+ messages in thread

end of thread, other threads:[~2012-11-25 16:28 UTC | newest]

Thread overview: 9+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-11-22 10:35 Two r6rs bugs Ian Price
2012-11-22 11:38 ` Mike Gran
2012-11-22 12:05   ` Ian Price
2012-11-22 12:18   ` Mike Gran
2012-11-22 21:28 ` Ludovic Courtès
2012-11-23  6:29 ` Mark H Weaver
2012-11-25 12:30   ` Ian Price
2012-11-25 15:58     ` Mark H Weaver
2012-11-25 16:28       ` Ian Price

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).