add pic_cstr

contrib/20.r7rs/src/system.c

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

lib/bool.c

@@ -42,7 +42,7 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
     if (xlen != ylen) {
       return false;
     }
-    return strcmp(xstr, ystr) == 0;
+    return memcmp(xstr, ystr, xlen) == 0;
   }
   case PIC_TYPE_BLOB: {
     int xlen, ylen;

lib/ext/write.c

@@ -104,6 +104,15 @@ is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) {
   return pic_int(pic, pic_attr_ref(pic, shared, obj)) > 0;
 }
 
+static void
+write_symbol(pic_state *pic, pic_value sym, pic_value port)
+{
+  int len;
+  const char *buf = pic_str(pic, pic_sym_name(pic, sym), &len);
+
+  pic_fwrite(pic, buf, len, 1, port);
+}
+
 static void
 write_blob(pic_state *pic, pic_value blob, pic_value port)
 {
@@ -147,21 +156,21 @@ write_char(pic_state *pic, pic_value ch, pic_value port, struct writer_control *
 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, NULL);
+  int i, len;
+  const char *buf = pic_str(pic, str, &len);
 
   if (p->mode == DISPLAY_MODE) {
-    pic_fprintf(pic, port, "%s", pic_str(pic, str, NULL));
+    pic_fwrite(pic, buf, len, 1, port);
     return;
   }
-  pic_fprintf(pic, port, "\"");
-  for (i = 0; i < pic_str_len(pic, str); ++i) {
-    if (cstr[i] == '"' || cstr[i] == '\\') {
+  pic_fputc(pic, '"', port);
+  for (i = 0; i < len; ++i) {
+    if (buf[i] == '"' || buf[i] == '\\') {
       pic_fputc(pic, '\\', port);
     }
-    pic_fputc(pic, cstr[i], port);
+    pic_fputc(pic, buf[i], port);
   }
-  pic_fprintf(pic, port, "\"");
+  pic_fputc(pic, '"', port);
 }
 
 static void
@@ -202,8 +211,7 @@ write_pair_help(pic_state *pic, pic_value pair, pic_value port, struct writer_co
   }
 }
 
-#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)
+#define EQ(sym, lit) (pic_eq_p(pic, sym, pic_intern_lit(pic, lit)))
 
 static void
 write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
@@ -281,7 +289,9 @@ write_dict(pic_state *pic, pic_value dict, pic_value port, struct writer_control
 
   pic_fprintf(pic, port, "#.(dictionary");
   while (pic_dict_next(pic, dict, &it, &key, &val)) {
-    pic_fprintf(pic, port, " '%s ", pic_sym(pic, key));
+    pic_fputs(pic, " '", port);
+    write_symbol(pic, key, port);
+    pic_fputc(pic, ' ', port);
     write_core(pic, val, port, p);
   }
   pic_fprintf(pic, port, ")");
@@ -387,7 +397,7 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
     pic_fprintf(pic, port, "%d", pic_int(pic, obj));
     break;
   case PIC_TYPE_SYMBOL:
-    pic_fprintf(pic, port, "%s", pic_sym(pic, obj));
+    write_symbol(pic, obj, port);
     break;
   case PIC_TYPE_FLOAT:
     write_float(pic, obj, port);

lib/include/picrin.h

@@ -125,6 +125,7 @@ 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, int *len);
+const char *pic_cstr(pic_state *, pic_value str, int *len);
 unsigned char *pic_blob(pic_state *, pic_value blob, int *len);
 void *pic_data(pic_state *, pic_value data);
 /* serialization */

lib/object.h

@@ -223,6 +223,8 @@ pic_value pic_make_record(pic_state *, pic_value type, pic_value datum);
 pic_value pic_record_type(pic_state *pic, pic_value record);
 pic_value pic_record_datum(pic_state *pic, pic_value record);
 pic_value pic_make_cont(pic_state *pic, pic_value k);
+int pic_str_hash(pic_state *pic, pic_value str);
+int pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2);
 
 struct rope *pic_rope_incref(struct rope *);
 void pic_rope_decref(pic_state *, struct rope *);

lib/port.c

@@ -338,13 +338,13 @@ pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap)
       case 'i': {
         int ival = va_arg(ap, int);
         pic_value str = pic_funcall(pic, "number->string", 1, pic_int_value(pic, ival));
-        pic_fputs(pic, pic_str(pic, str, 0), port);
+        pic_fputs(pic, pic_cstr(pic, str, 0), port);
         break;
       }
       case 'f': {
         double f = va_arg(ap, double);
         pic_value str = pic_funcall(pic, "number->string", 1, pic_float_value(pic, f));
-        pic_fputs(pic, pic_str(pic, str, 0), port);
+        pic_fputs(pic, pic_cstr(pic, str, 0), port);
         break;
       }
       case 'c': {

lib/proc.c

@@ -223,7 +223,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), NULL);
+  msg = pic_cstr(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected), NULL);
 
   pic_error(pic, msg, 0);
 }
@@ -343,7 +343,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), NULL);
+        msg = pic_cstr(pic, pic_strf_value(pic, "pic_get_args: data type \"%s\" required", type->type_name), NULL);
         pic_error(pic, msg, 1, v);
       }
       break;
@@ -412,7 +412,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, NULL))
+    VAL_CASE('z', str, const char *, pic_cstr(pic, v, NULL))
 
 #define OBJ_CASE(c, type) VAL_CASE(c, type, pic_value, v)
 

lib/state.c

@@ -310,7 +310,7 @@ pic_warnf(pic_state *PIC_UNUSED(pic), const char *PIC_UNUSED(fmt), ...)
   va_start(ap, fmt);
   err = pic_vstrf_value(pic, fmt, ap);
   va_end(ap);
-  pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL));
+  pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_cstr(pic, err, NULL));
 #endif
 }
 
@@ -352,7 +352,7 @@ pic_define(pic_state *pic, const char *name, pic_value val)
   pic_value sym = pic_intern_cstr(pic, name);
 
   if (pic_dict_has(pic, pic->globals, sym)) {
-    pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, sym), NULL));
+    pic_warnf(pic, "redefining variable: %s", name);
   }
   pic_dict_set(pic, pic->globals, sym, val);
 }

lib/string.c

@@ -267,6 +267,38 @@ pic_str_sub(pic_state *pic, pic_value str, int s, int e)
   return make_str(pic, slice(pic, str_ptr(pic, str)->rope, s, e));
 }
 
+int
+pic_str_hash(pic_state *pic, pic_value str)
+{
+  int len, h = 0;
+  const char *s;
+
+  s = pic_str(pic, str, &len);
+  while (len-- > 0) {
+    h = (h << 5) - h + *s++;
+  }
+  return h;
+}
+
+int
+pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2)
+{
+  int len1, len2, r;
+  const char *buf1, *buf2;
+
+  buf1 = pic_str(pic, str1, &len1);
+  buf2 = pic_str(pic, str2, &len2);
+
+  if (len1 == len2) {
+    return memcmp(buf1, buf2, len1);
+  }
+  r = memcmp(buf1, buf2, (len1 < len2 ? len1 : len2));
+  if (r != 0) {
+    return r;
+  }
+  return len1 - len2;
+}
+
 const char *
 pic_str(pic_state *pic, pic_value str, int *len)
 {
@@ -287,6 +319,22 @@ pic_str(pic_state *pic, pic_value str, int *len)
   return r->u.leaf.str;
 }
 
+const char *
+pic_cstr(pic_state *pic, pic_value str, int *len)
+{
+  const char *buf;
+  int l;
+
+  buf = pic_str(pic, str, &l);
+  if (strchr(buf, '\0') != buf + l) {
+    pic_error(pic, "casting scheme string containing null character to c string", 1, str);
+  }
+  if (len) {
+    *len = l;
+  }
+  return buf;
+}
+
 static pic_value
 pic_str_string_p(pic_state *pic)
 {
@@ -398,7 +446,7 @@ pic_str_string_set(pic_state *pic)
       if (! pic_str_p(pic, argv[i])) {                          \
         return pic_false_value(pic);                            \
       }                                                         \
-      if (! (strcmp(pic_str(pic, argv[i-1], NULL), pic_str(pic, argv[i], NULL)) op 0)) { \
+      if (! (pic_str_cmp(pic, argv[i-1], argv[i]) op 0)) {      \
         return pic_false_value(pic);                            \
       }                                                         \
     }                                                           \

lib/symbol.c

@@ -8,11 +8,10 @@
 #include "state.h"
 
 /* FIXME: arena is consumed every time hash/cmp is executed */
-#define to_cstr(a) (pic_str(pic, obj_value(pic, a), NULL))
-#define kh_pic_str_hash(a) (kh_str_hash_func(to_cstr(a)))
-#define kh_pic_str_cmp(a, b) (kh_str_cmp_func(to_cstr(a), to_cstr(b)))
+#define kh_pic_str_hash(a) (pic_str_hash(pic, obj_value(pic, (a))))
+#define kh_pic_str_equal(a,b) (pic_str_cmp(pic, obj_value(pic, (a)), obj_value(pic, (b))) == 0)
 
-KHASH_DEFINE(oblist, struct string *, struct symbol *, kh_pic_str_hash, kh_pic_str_cmp)
+KHASH_DEFINE(oblist, struct string *, struct symbol *, kh_pic_str_hash, kh_pic_str_equal)
 
 pic_value
 pic_intern(pic_state *pic, pic_value str)

lib/vector.c

@@ -369,11 +369,11 @@ pic_vec_string_to_vector(pic_state *pic)
 {
   pic_value str, vec;
   int n, start, end, len, i;
-  const char *cstr;
+  const char *buf;
 
   n = pic_get_args(pic, "s|ii", &str, &start, &end);
 
-  cstr = pic_str(pic, str, &len);
+  buf = pic_str(pic, str, &len);
 
   switch (n) {
   case 1:
@@ -387,7 +387,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, cstr[i + start]));
+    pic_vec_set(pic, vec, i, pic_char_value(pic, buf[i + start]));
   }
   return vec;
 }