add length argument to pic_str()

contrib/20.r7rs/src/system.c

@@ -109,7 +109,7 @@ pic_system_getenvs(pic_state *pic)
       ;
 
     key = pic_str_value(pic, *envp, i);
-    val = pic_cstr_value(pic, getenv(pic_str(pic, key)));
+    val = pic_cstr_value(pic, getenv(pic_str(pic, key, NULL)));
 
     /* push */
     data = pic_cons(pic, pic_cons(pic, key, val), data);

lib/bool.c

@@ -106,7 +106,16 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
     return pic_eq_p(pic, s1, s2);
   }
   case PIC_TYPE_STRING: {
-    return pic_str_cmp(pic, x, y) == 0;
+    int xlen, ylen;
+    const char *xstr, *ystr;
+
+    xstr = pic_str(pic, x, &xlen);
+    ystr = pic_str(pic, y, &ylen);
+
+    if (xlen != ylen) {
+      return false;
+    }
+    return strcmp(xstr, ystr) == 0;
   }
   case PIC_TYPE_BLOB: {
     int xlen, ylen;
@@ -118,10 +127,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
     if (xlen != ylen) {
       return false;
     }
-    if (memcmp(xbuf, ybuf, xlen) != 0) {
+    return memcmp(xbuf, ybuf, xlen) == 0;
-      return false;
-    }
-    return true;
   }
   case PIC_TYPE_PAIR: {
     if (! internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, h))

lib/debug.c

@@ -54,7 +54,7 @@ pic_print_error(pic_state *pic, pic_value port, pic_value err)
     pic_for_each (elem, e->irrs, it) { /* print error irritants */
       pic_fprintf(pic, port, " ~s", elem);
     }
-    pic_fprintf(pic, port, "\n%s", pic_str(pic, pic_obj_value(e->stack)));
+    pic_fprintf(pic, port, "\n%s", pic_str(pic, pic_obj_value(e->stack), NULL));
   }
 }
 

lib/error.c

@@ -28,7 +28,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
   err = pic_vstrf_value(pic, fmt, ap);
   va_end(ap);
 
-  pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err));
+  pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL));
 }
 
 static pic_value

lib/ext/eval.c

@@ -13,6 +13,8 @@ static pic_value pic_compile(pic_state *, pic_value);
 #define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0)
 #define S(lit) (pic_intern_lit(pic, lit))
 
+#define pic_sym(pic,sym) pic_str(pic, pic_sym_name(pic, (sym)), NULL)
+
 static void
 define_macro(pic_state *pic, pic_value uid, pic_value mac)
 {

lib/ext/lib.c

@@ -84,10 +84,10 @@ pic_add_identifier(pic_state *pic, pic_value id, pic_value env)
     return uid;
   }
 
-  name = pic_str(pic, pic_id_name(pic, id));
+  name = pic_str(pic, pic_id_name(pic, id), NULL);
 
   if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) { /* toplevel & public */
-    lib = pic_str(pic, pic_obj_value(pic_env_ptr(pic, env)->lib));
+    lib = pic_str(pic, pic_obj_value(pic_env_ptr(pic, env)->lib), NULL);
     str = pic_strf_value(pic, "%s/%s", lib, name);
   } else {
     str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++);
@@ -168,7 +168,7 @@ pic_make_library(pic_state *pic, const char *lib)
   env = make_library_env(pic, name);
   exports = pic_make_dict(pic);
 
-  it = kh_put(ltable, h, pic_str(pic, name), &ret);
+  it = kh_put(ltable, h, pic_str(pic, name, NULL), &ret);
   if (ret == 0) {               /* if exists */
     pic_error(pic, "library name already in use", 1, pic_cstr_value(pic, lib));
   }

lib/ext/write.c

@@ -270,10 +270,10 @@ static void
 write_str(pic_state *pic, pic_value str, pic_value port, struct writer_control *p)
 {
   int i;
-  const char *cstr = pic_str(pic, str);
+  const char *cstr = pic_str(pic, str, NULL);
 
   if (p->mode == DISPLAY_MODE) {
-    pic_fprintf(pic, port, "%s", pic_str(pic, str));
+    pic_fprintf(pic, port, "%s", pic_str(pic, str, NULL));
     return;
   }
   pic_fprintf(pic, port, "\"");
@@ -324,7 +324,8 @@ write_pair_help(pic_state *pic, pic_value pair, pic_value port, struct writer_co
   }
 }
 
-#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0)
+#define EQ(sym, lit) (strcmp(pic_str(pic, pic_sym_name(pic, sym), NULL), lit) == 0)
+#define pic_sym(pic,sym) pic_str(pic, pic_sym_name(pic, (sym)), NULL)
 
 static void
 write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
@@ -439,7 +440,7 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
     pic_fprintf(pic, port, "#f");
     break;
   case PIC_TYPE_ID:
-    pic_fprintf(pic, port, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj)));
+    pic_fprintf(pic, port, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj), NULL));
     break;
   case PIC_TYPE_EOF:
     pic_fprintf(pic, port, "#.(eof-object)");

lib/include/picrin.h

@@ -114,8 +114,7 @@ int pic_int(pic_state *, pic_value i);
 double pic_float(pic_state *, pic_value f);
 char pic_char(pic_state *, pic_value c);
 #define pic_bool(pic,b) (! pic_false_p(pic, b))
-const char *pic_str(pic_state *, pic_value str);
+const char *pic_str(pic_state *, pic_value str, int *len);
-#define pic_sym(pic,s) (pic_str(pic, pic_sym_name(pic, (s))))
 unsigned char *pic_blob(pic_state *, pic_value blob, int *len);
 void *pic_data(pic_state *, pic_value data);
 

lib/proc.c

@@ -14,7 +14,7 @@ arg_error(pic_state *pic, int actual, bool varg, int expected)
 {
   const char *msg;
 
-  msg = pic_str(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected));
+  msg = pic_str(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected), NULL);
 
   pic_error(pic, msg, 0);
 }
@@ -131,7 +131,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
       }
       else {
         const char *msg;
-        msg = pic_str(pic, pic_strf_value(pic, "pic_get_args: data type \"%s\" required", type->type_name));
+        msg = pic_str(pic, pic_strf_value(pic, "pic_get_args: data type \"%s\" required", type->type_name), NULL);
         pic_error(pic, msg, 1, v);
       }
       break;
@@ -200,7 +200,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
       }
 
     VAL_CASE('c', char, char, pic_char(pic, v))
-    VAL_CASE('z', str, const char *, pic_str(pic, v))
+    VAL_CASE('z', str, const char *, pic_str(pic, v, NULL))
 
 #define OBJ_CASE(c, type) VAL_CASE(c, type, pic_value, v)
 
@@ -843,7 +843,7 @@ pic_define(pic_state *pic, const char *lib, const char *name, pic_value val)
 
   uid = pic_find_identifier(pic, sym, env);
   if (pic_weak_has(pic, pic->globals, uid)) {
-    pic_warnf(pic, "redefining variable: %s", pic_sym(pic, uid));
+    pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, uid), NULL));
   }
   pic_weak_set(pic, pic->globals, uid, val);
 }

lib/string.c

@@ -282,7 +282,7 @@ pic_str_sub(pic_state *pic, pic_value str, int s, int e)
 int
 pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2)
 {
-  return strcmp(pic_str(pic, str1), pic_str(pic, str2));
+  return strcmp(pic_str(pic, str1, NULL), pic_str(pic, str2, NULL));
 }
 
 int
@@ -291,7 +291,7 @@ pic_str_hash(pic_state *pic, pic_value str)
   const char *s;
   int h = 0;
 
-  s = pic_str(pic, str);
+  s = pic_str(pic, str, NULL);
   while (*s) {
     h = (h << 5) - h + *s++;
   }
@@ -299,10 +299,14 @@ pic_str_hash(pic_state *pic, pic_value str)
 }
 
 const char *
-pic_str(pic_state *pic, pic_value str)
+pic_str(pic_state *pic, pic_value str, int *len)
 {
   struct rope *rope = pic_str_ptr(pic, str)->rope, *r;
 
+  if (len) {
+    *len = rope->weight;
+  }
+
   if (rope->isleaf && rope->u.leaf.str[rope->weight] == '\0') {
     return rope->u.leaf.str;
   }

lib/vector.c

@@ -368,10 +368,11 @@ pic_vec_string_to_vector(pic_state *pic)
 {
   pic_value str, vec;
   int n, start, end, len, i;
+  const char *cstr;
 
   n = pic_get_args(pic, "s|ii", &str, &start, &end);
 
-  len = pic_str_len(pic, str);
+  cstr = pic_str(pic, str, &len);
 
   switch (n) {
   case 1:
@@ -385,7 +386,7 @@ pic_vec_string_to_vector(pic_state *pic)
   vec = pic_make_vec(pic, end - start, NULL);
 
   for (i = 0; i < end - start; ++i) {
-    pic_vec_set(pic, vec, i, pic_char_value(pic, pic_str_ref(pic, str, i + start)));
+    pic_vec_set(pic, vec, i, pic_char_value(pic, cstr[i + start]));
   }
   return vec;
 }