[uim-commit] r2807 - in branches/r5rs/sigscheme: . test

[yamaken at freedesktop.org]

Author: yamaken
Date: 2006-01-06 07:43:13 -0800 (Fri, 06 Jan 2006)
New Revision: 2807

Modified:
   branches/r5rs/sigscheme/operations-nonstd.c
   branches/r5rs/sigscheme/operations.c
   branches/r5rs/sigscheme/sigscheme.h
   branches/r5rs/sigscheme/sigschemeinternal.h
   branches/r5rs/sigscheme/test/test-list.scm
Log:
* sigscheme/sigschemeinternal.h
  - (SCM_LISTLEN_PROPERP, SCM_LISTLEN_DOT): New macro
* sigscheme/operations.c
  - (LISTLEN_ENCODE_DOT): Revert r2802
  - (scm_length):
    * Return -1 for non-list, as zero length improper list, as
      originally intended
    * Fix the bug fixed in r2802, but as originally intended
* sigscheme/sigscheme.h
  - (scm_p_lengthstar): New function decl
* sigscheme/operations-nonstd.c
  - (scm_p_lengthstar): New function
* sigscheme/test/test-list.scm
  - Add tests for length*


Modified: branches/r5rs/sigscheme/operations-nonstd.c
===================================================================
--- branches/r5rs/sigscheme/operations-nonstd.c	2006-01-06 13:55:30 UTC (rev 2806)
+++ branches/r5rs/sigscheme/operations-nonstd.c	2006-01-06 15:43:13 UTC (rev 2807)
@@ -241,3 +241,22 @@
 
     return SCM_TRUE;
 }
+
+/* to avoid being typo of length+, this procedure did not name as length++ */
+/* FIXME: replace with a SRFI or de facto standard equivalent if exist */
+ScmObj
+scm_p_lengthstar(ScmObj lst)
+{
+    int len;
+    DECLARE_FUNCTION("length*", procedure_fixed_1);
+
+    len = scm_length(lst);
+    if (!SCM_LISTLEN_PROPERP(len)) { /* make fast path for proper list */
+        if (SCM_LISTLEN_DOTP(len))
+            len = -SCM_LISTLEN_DOT(len);
+        else if (SCM_LISTLEN_CIRCULARP(len))
+            return SCM_FALSE;
+    }
+
+    return MAKE_INT(len);
+}

Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c	2006-01-06 13:55:30 UTC (rev 2806)
+++ branches/r5rs/sigscheme/operations.c	2006-01-06 15:43:13 UTC (rev 2807)
@@ -808,13 +808,14 @@
  * 2006-01-05 YamaKen  Return dot list length and circular indication.
  *
  */
+/* Returns -1 for non-list, as zero length improper list. */
 int
 scm_length(ScmObj lst)
 {
     ScmObj slow;
     int len;
 
-#define LISTLEN_ENCODE_DOT(len)      (-(len)-1)
+#define LISTLEN_ENCODE_DOT(len)      (-(len))
 #define LISTLEN_ENCODE_CIRCULAR(len) (INT_MIN)
 
     slow = lst;
@@ -822,13 +823,13 @@
 
     for (;;) {
         if (NULLP(lst)) break;
-        if (!CONSP(lst)) return LISTLEN_ENCODE_DOT(len);
+        if (!CONSP(lst)) return LISTLEN_ENCODE_DOT(len + 1);
         if (len != 0 && lst == slow) return LISTLEN_ENCODE_CIRCULAR(len);
 
         lst = CDR(lst);
         len++;
         if (NULLP(lst)) break;
-        if (!CONSP(lst)) return LISTLEN_ENCODE_DOT(len);
+        if (!CONSP(lst)) return LISTLEN_ENCODE_DOT(len + 1);
         if (lst == slow) return LISTLEN_ENCODE_CIRCULAR(len);
 
         lst = CDR(lst);

Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2006-01-06 13:55:30 UTC (rev 2806)
+++ branches/r5rs/sigscheme/sigscheme.h	2006-01-06 15:43:13 UTC (rev 2807)
@@ -928,6 +928,7 @@
 ScmObj scm_p_providedp(ScmObj feature);
 ScmObj scm_p_file_existsp(ScmObj filepath);
 ScmObj scm_p_delete_file(ScmObj filepath);
+ScmObj scm_p_lengthstar(ScmObj lst);
 #endif
 
 /* io.c */

Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h	2006-01-06 13:55:30 UTC (rev 2806)
+++ branches/r5rs/sigscheme/sigschemeinternal.h	2006-01-06 15:43:13 UTC (rev 2807)
@@ -38,6 +38,7 @@
    System Include
 =======================================*/
 #include <limits.h>
+#include <stdlib.h>
 #include <stdarg.h>
 
 /*=======================================
@@ -348,9 +349,11 @@
 #define SCM_ERR_HEADER "Error: "
 
 /* result decoders for scm_length() */
+#define SCM_LISTLEN_PROPERP(len)     (0 <= (len))
 #define SCM_LISTLEN_CIRCULARP(len)   ((len) == INT_MIN)
 #define SCM_LISTLEN_DOTP(len)        ((len) < 0                              \
                                       && !SCM_LISTLEN_CIRCULARP(len))
+#define SCM_LISTLEN_DOT(len)         (abs(len))
 #define SCM_LISTLEN_BEFORE_DOT(len)  (~(len))  /* abs(len) - 1 */
 
 /*=======================================

Modified: branches/r5rs/sigscheme/test/test-list.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-list.scm	2006-01-06 13:55:30 UTC (rev 2806)
+++ branches/r5rs/sigscheme/test/test-list.scm	2006-01-06 15:43:13 UTC (rev 2807)
@@ -32,6 +32,7 @@
 
 (load "test/unittest.scm")
 
+(define tn test-name)
 
 (define elm0 (lambda () #f))
 (define elm1 (lambda () #f))
@@ -146,4 +147,33 @@
 ; assoc
 (assert-equal? "assoc test1" '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
 
+(if (provided? "sigscheme")
+    (begin
+      (use sscm)
+      (tn "length* proper list")
+      (assert-equal? (tn) 0 (length* '()))
+      (assert-equal? (tn) 1 (length* '(1)))
+      (assert-equal? (tn) 2 (length* '(1 2)))
+      (assert-equal? (tn) 3 (length* '(1 2 3)))
+      (assert-equal? (tn) 4 (length* '(1 2 3 4)))
+      (tn "length* improper list")
+      (assert-equal? (tn) -1 (length* 1))
+      (assert-equal? (tn) -2 (length* '(1 . 2)))
+      (assert-equal? (tn) -3 (length* '(1 2 . 3)))
+      (assert-equal? (tn) -4 (length* '(1 2 3 . 4)))
+      (assert-equal? (tn) -5 (length* '(1 2 3 4 . 5)))
+      (tn "length* circular list")
+      (define lst1 '(1))
+      (set-cdr! lst1 lst1)
+      (define lst2 '(1 2))
+      (set-cdr! (list-tail lst2 1) lst2)
+      (define lst3 '(1 2 3))
+      (set-cdr! (list-tail lst3 2) lst3)
+      (define lst4 '(1 2 3 4))
+      (set-cdr! (list-tail lst4 3) lst4)
+      (assert-false (tn) (length* lst1))
+      (assert-false (tn) (length* lst2))
+      (assert-false (tn) (length* lst3))
+      (assert-false (tn) (length* lst4))))
+
 (total-report)