Better identify functions that misuse COBJ-s and hashes.

In this patch, the cobj_handle, cobj_ops and variants of
gethash get an additional argument to identify the caller.
Many functions are updated to pass this down.

* buf.c (buf_strm): Pass self name to cobj_handle.

* eval.c (env_fbind, env_vbind, rt_defvarl, me_case): Pass
self name to gethash_c or gethash_e.
(load): Pass self name to read_eval_stream and
read_compiled_file.
(reg_symacro): Pass situation-identifying string to gethash_c.

* ffi.c (ffi_type_struct_checked, ffi_closure_struct_checked,
ffi_call_desc_checked, uni_struct_checked):
Take self name parameter, and pass down to cobj_handle.
(ffi_get_type, ffi_get_lisp_type): Take self name and pass
down to ffi_type_struct_checked.
(union_get_ptr): Take self name and pass to
uni_struct_checked.
(ffi_union_in, ffi_union_put): Pass self name to union_get_ptr.
(ffi_type_compile): Pass self name to ffi_get_lisp_type.
(ffi_make_call_desc): Pass self name to
ffi_type_struct_checked, ffi_get_type and
ffi_call_desc_checked.
(ffi_make_closure): Pass self name to ffi_call_desc_checked.
(ffi_closure_get_fptr): Take self name, pass to
ffi_closure_struct_checked.
(ffi_typedef, ffi_size, ffi_alignof, ffi_offsetof,
ffi_arraysize, ffi_elemsize, ffi_elemtype, ffi_put_into,
ffi_put, ffi_in, ffi_get, ffi_out, make_carray): Pass self
name to ffi_closure_struct_checked.
(carray_struct_checked): Take self name, pass to cobj_handle.
(carray_set_length, carray_dup, carray_own, carray_free,
carray_type, length_carray, copy_carray, carray_ptr,
buf_carray, vec_carray, list_carray, carray_ref,
carray_refset, carray_sub, carray_replace, carray_get_common,
carray_put_common, unum_carray, num_carray, put_carray,
fill_carray): Pass self name to carray_struct_checked.
(carray_blank, carray_buf, carray_cptr): Pass self name
ffi_type_struct_checked.
(carray_pun): Pass self name to carray_struct_checked and
ffi_type_struct_checked.
(make_union): Pass self name to ffi_type_struct_checked.
(union_members, union_get, union_put, union_in, union_out):
Pass self name to uni_struct_checked.
(make_zstruct, zero_fill, put_obj, get_obj, fill_obj): Pass
self-name to ffi_type_struct_checked.

* ffi.h (ffi_closure_get_fptr, union_get_ptr): Declarations
updated.

* filter.c (trie_add): Pass self-name to gethash_l.

* hash.c (make_similar_hash, copy_hash, hash_count,
get_hash_userdata, set_hash_userdata, hash_begin, hash_next,
hash_uni, hash_diff, hash_isec): Pass self name
to cobj_handle.
(gethash_c, gethash_e): Take self name parameter and pass down
to cobj_handle.
(gethash_f): Take self parameter and pass down to gethash_e.
(gethash, inhash, gethash_n, sethash, pushhash, remhash,
clearhash, hash_update_1): Pass self name to gethash_e or gethash_c.

* hash.h (gethash_c, gethash_e, gethash_f): Declarations
updated.
(gethash_l): Take self name, and pass down to gethash_c.

* lib.c (class_check): Take self name parameter and use in
type mismatch diagnostic.
(use_sym, unuse_sym, symbol_needs_prefix, find_symbol,
intern, unintern, intern_fallback, unique, in, sel,
obj_print_impl, populate_obj_hash, obj_hash_merge): Pass self
name to gethash_f or gethash_l.
(symbol_visible, obj_init): Pass situation-identifying string
to gethash_e.
(cobj_handle, cobj_ops): Take self name parameter and pass
down to class_check.

* lib.h (class_check, cobj_handle, cobj_ops): Declarations
updated.

* match.c (v_load): Pass self name to read_compiled_file and
read_eval_stream.

* parser.c (get_parser_impl): Take self name and pass to
cobj_handle.
(ensure_parser): Pass situation-identifying string to
gethash_c.
(parser_circ_def): Pass self-name to gethash_c.
(lisp_parser_impl): Pass self name to get_parser_impl and
class_check.
(lisp_parse, nread, iread): Pass self-name to lisp_parser_impl.
(read_file_common): Take self name parameter and pass down to
get_parser_impl.
(read_eval_stream, read_compiled_file): Take self name and
pass down to read_file_common.
(load_rcfile): Pass situation-identifying string to
read_eval_streem.
(get_visible_syms): Pass situation-identifying string to
gethash_c.
(parser_errors, parser_eof): Pass self name to cobj_handle.

* parser.h (read_eval_stream, read_compiled_file):
Declarations updated.

* parser.y (rlset): Pass self name to gethash_c.

* rand.c (make_random_state, random_state_get_vec,l
random_fixnum, random_float): Pass self name to cobj_handle.

* regex.c (regex_source, regex_print, regex_run): Pass
self-name to cobj_handle.
(regex_machine_init): Take self name param and pass to
cobj_handle.
(search_regex, match_regex, match_regex_right,
regex_prefix_match, read_until_match): Pass self-name to
regex_machine_init.

* stream.c (stdio_get_fd): Pass self name to cobj_handle.
(generic_get_line): Get COBJ operations via unsafe, diret
object access rather than cobj_ops.
(set_mode_props): Get object handle via unsafe, direct object
access.
(stream_fd, sock_family, sock_type, sock_peer, set_sock_peer,
get_string_from_stream, get_list_from_stream, stream_set_prop,
stream_get_prop, close_stream, get_error, get_error_str,
clear_error, get_line, get_char, get_byte, unget_char,
unget_byte, put_buf, fill_buf, put_string, put_char, put_byte,
flush_stream, seek_stream, truncate_stream, get_indent_mode,
test_set_indent_mode, set_indent_mode, get_indent, set_indent,
inc_indent, width_check, force_break, get_set_ctx, get_ctx):
Pass self name to cobj_ops.
(make_delegate_stream): Take self name parameter, pass down to
cobj_ops.
(record_adapter): Pass self name down to make_delegate_stream.
(format): Pass self name to class_check.

* struct.c (stype_handle): Pass self name to cobj_handle.
(make_struct_type): Pass self name to class_check.

* txr.c (read_eval_stream_noerr): Take self name parameter,
pass to read_eval_stream.
(txr_main): Pass istuation-identifying string to
read_compiled_file and read_eval_stream_noerr.

* unwind.c (revive_cont): Pass self-name to cobj_handle.

* vm.c (vm_desc_struct): Take self name parameter, pass to
cobj_handle.
(vm_desc_nlevels, vm_desc_nregs, vm_desc_bytecode,
vm_desc_datavec, vm_desc_symvec, vm_execute_toplevel,
vm_execute_closure, vm_closure_entry): Pass self name to
vm_desc_struct.
(vm_closure_struct): Take self name parameter, pass to
cobj_handle.

1 files changed, 48 insertions, 38 deletions

diff --git a/lib.c b/lib.c
index 5fc27cf8..33eddfe9 100644
--- a/lib.c
+++ b/lib.c
@@ -329,11 +329,11 @@ val throw_mismatch(val self, val obj, type_t t)
   type_mismatch(lit("~a: ~s is not of type ~s"), self, obj, code2type(t), nao);
 }
 
-val class_check(val cobj, val class_sym)
+val class_check(val self, val cobj, val class_sym)
 {
   type_assert (is_ptr(cobj) && cobj->t.type == COBJ &&
               (cobj->co.cls == class_sym || subtypep(cobj->co.cls, class_sym)),
-               (lit("~s is not of type ~s"), cobj, class_sym, nao));
+               (lit("~a: ~s is not of type ~s"), self, cobj, class_sym, nao));
   return t;
 }
 
@@ -5289,7 +5289,7 @@ val use_sym(val symbol, val package_in)
   if (symbol_package(symbol) != package) {
     val name = symbol_name(symbol);
     val found;
-    val existing = gethash_f(package->pk.symhash, name, mkcloc(found));
+    val existing = gethash_f(self, package->pk.symhash, name, mkcloc(found));
 
     if (found && symbol_package(existing) == package) {
       if (existing == nil)
@@ -5311,8 +5311,8 @@ val unuse_sym(val symbol, val package_in)
   val package = get_package(self, package_in, t);
   val name = symbol_name(symbol);
   val found_visible, found_hidden;
-  val visible = gethash_f(package->pk.symhash, name, mkcloc(found_visible));
-  val hidden = gethash_f(package->pk.hidhash, name, mkcloc(found_hidden));
+  val visible = gethash_f(self, package->pk.symhash, name, mkcloc(found_visible));
+  val hidden = gethash_f(self, package->pk.hidhash, name, mkcloc(found_hidden));
 
   if (!found_visible || visible != symbol)
     return nil;
@@ -5400,14 +5400,15 @@ val unuse_package(val unuse_list, val package_in)
  */
 val symbol_visible(val package, val sym)
 {
+  val self = lit("internal error");
   val name = symbol_name(sym);
-  type_check(lit("internal error"), package, PKG);
+  type_check(self, package, PKG);
 
   if (sym->s.package == package)
     return t;
 
   {
-    val cell = gethash_e(package->pk.symhash, name);
+    val cell = gethash_e(self, package->pk.symhash, name);
 
     if (cell)
       return eq(cdr(cell), sym);
@@ -5418,7 +5419,7 @@ val symbol_visible(val package, val sym)
 
     for (; fallback; fallback = cdr(fallback)) {
       val fb_pkg = car(fallback);
-      val cell = gethash_e(fb_pkg->pk.symhash, name);
+      val cell = gethash_e(self, fb_pkg->pk.symhash, name);
 
       if (cell)
         return eq(cdr(cell), sym);
@@ -5438,7 +5439,7 @@ val symbol_needs_prefix(val self, val package, val sym)
 
   {
     int homed_here = (sym->s.package == package);
-    val home_cell = gethash_e(package->pk.symhash, name);
+    val home_cell = gethash_e(self, package->pk.symhash, name);
     int present_here = (eq(cdr(home_cell), sym) != nil);
     val fallback = get_hash_userdata(package->pk.symhash);
     val fb_cell = nil;
@@ -5446,7 +5447,7 @@ val symbol_needs_prefix(val self, val package, val sym)
 
     for (; fallback; fallback = cdr(fallback)) {
       val fb_pkg = car(fallback);
-      val cell = gethash_e(fb_pkg->pk.symhash, name);
+      val cell = gethash_e(self, fb_pkg->pk.symhash, name);
 
       if (cell) {
         fb_cell = cell;
@@ -5479,7 +5480,7 @@ val find_symbol(val str, val package_in)
   if (!stringp(str))
     uw_throwf(error_s, lit("~a: name ~s isn't a string"), self, str, nao);
 
-  if ((sym = gethash_f(package->pk.symhash, str, mkcloc(found))) || found)
+  if ((sym = gethash_f(self, package->pk.symhash, str, mkcloc(found))) || found)
     return sym;
 
   return zero;
@@ -5487,14 +5488,15 @@ val find_symbol(val str, val package_in)
 
 val intern(val str, val package_in)
 {
+  val self = lit("intern");
   val new_p;
   loc place;
-  val package = get_package(lit("intern"), package_in, t);
+  val package = get_package(self, package_in, t);
 
   if (!stringp(str))
-    uw_throwf(error_s, lit("intern: name ~s isn't a string"), str, nao);
+    uw_throwf(error_s, lit("~a: name ~s isn't a string"), self, str, nao);
 
-  place = gethash_l(package->pk.symhash, str, mkcloc(new_p));
+  place = gethash_l(self, package->pk.symhash, str, mkcloc(new_p));
 
   if (!new_p) {
     return deref(place);
@@ -5507,14 +5509,14 @@ val intern(val str, val package_in)
 
 val unintern(val symbol, val package_in)
 {
-  val unint = lit("unintern");
-  val package = get_package(unint, package_in, t);
+  val self = lit("unintern");
+  val package = get_package(self, package_in, t);
   val name = symbol_name(symbol);
   val found_visible, found_hidden;
-  val visible = gethash_f(package->pk.symhash, name, mkcloc(found_visible));
-  val hidden = gethash_f(package->pk.hidhash, name, mkcloc(found_hidden));
+  val visible = gethash_f(self, package->pk.symhash, name, mkcloc(found_visible));
+  val hidden = gethash_f(self, package->pk.hidhash, name, mkcloc(found_hidden));
 
-  prot_sym_check(unint, name, package);
+  prot_sym_check(self, name, package);
 
   if (!found_visible || visible != symbol) {
     if (found_hidden && hidden == symbol) {
@@ -5594,12 +5596,12 @@ val intern_fallback(val str, val package_in)
     val found;
     val sym;
 
-    if ((sym = gethash_f(package->pk.symhash, str, mkcloc(found))) || found)
+    if ((sym = gethash_f(self, package->pk.symhash, str, mkcloc(found))) || found)
       return sym;
 
     for (; fblist; fblist = cdr(fblist)) {
       val otherpkg = car(fblist);
-      if ((sym = gethash_f(otherpkg->pk.symhash, str, mkcloc(found))) || found)
+      if ((sym = gethash_f(self, otherpkg->pk.symhash, str, mkcloc(found))) || found)
         return sym;
     }
   }
@@ -5608,7 +5610,7 @@ val intern_fallback(val str, val package_in)
     val new_p;
     loc place;
 
-    place = gethash_l(package->pk.symhash, str, mkcloc(new_p));
+    place = gethash_l(self, package->pk.symhash, str, mkcloc(new_p));
 
     if (!new_p) {
       return deref(place);
@@ -7788,15 +7790,15 @@ val cobjp(val obj)
   return type(obj) == COBJ ? t : nil;
 }
 
-mem_t *cobj_handle(val cobj, val cls_sym)
+mem_t *cobj_handle(val self, val cobj, val cls_sym)
 {
-  class_check(cobj, cls_sym);
+  class_check(self, cobj, cls_sym);
   return cobj->co.handle;
 }
 
-struct cobj_ops *cobj_ops(val cobj, val cls_sym)
+struct cobj_ops *cobj_ops(val self, val cobj, val cls_sym)
 {
-  class_check(cobj, cls_sym);
+  class_check(self, cobj, cls_sym);
   return cobj->co.ops;
 }
 
@@ -8638,7 +8640,7 @@ val unique(val seq, val keyfun, struct args *hashv_args)
       val new_p;
       val v = ref(seq, num_fast(i));
 
-      (void) gethash_c(hash, funcall1(kf, v), mkcloc(new_p));
+      (void) gethash_c(self, hash, funcall1(kf, v), mkcloc(new_p));
 
       if (new_p)
         ptail = list_collect(ptail, v);
@@ -8648,7 +8650,7 @@ val unique(val seq, val keyfun, struct args *hashv_args)
       val new_p;
       val v = car(seq);
 
-      (void) gethash_c(hash, funcall1(kf, v), mkcloc(new_p));
+      (void) gethash_c(self, hash, funcall1(kf, v), mkcloc(new_p));
 
       if (new_p)
         ptail = list_collect(ptail, v);
@@ -9739,13 +9741,14 @@ val drop_until(val pred, val seq, val keyfun)
 
 val in(val seq, val item, val testfun, val keyfun)
 {
+  val self = lit("in");
   switch (type(seq)) {
   case NIL:
     return nil;
   case COBJ:
     if (seq->co.cls == hash_s) {
       val found;
-      gethash_f(seq, item, mkcloc(found));
+      gethash_f(self, seq, item, mkcloc(found));
       return if3(found, t, nil);
     }
     /* fallthrough */
@@ -10499,6 +10502,7 @@ val where(val func, val seq)
 
 val sel(val seq_in, val where_in)
 {
+  val self = lit("sel");
   list_collect_decl (out, ptail);
   val seq = nullify(seq_in);
   val where = if3(functionp(where_in),
@@ -10517,7 +10521,7 @@ val sel(val seq_in, val where_in)
         val found;
         loc pfound = mkcloc(found);
         val key = car(where);
-        val value = gethash_f(seq, key, pfound);
+        val value = gethash_f(self, seq, key, pfound);
 
         if (found)
           sethash(newhash, key, value);
@@ -10660,6 +10664,8 @@ val env(void)
 
 static void obj_init(void)
 {
+  val self = lit("internal init");
+
   /*
    * No need to GC-protect the convenience variables which hold the interned
    * symbols, because the interned_syms list holds a reference to all the
@@ -10688,10 +10694,11 @@ static void obj_init(void)
   /* nil can't be interned because it's not a SYM object;
      it works as a symbol because the nil case is handled by
      symbol-manipulating function. */
-  rplacd(gethash_c(user_package->pk.symhash, nil_string, nulloc), nil);
+  rplacd(gethash_c(self, user_package->pk.symhash,
+                   nil_string, nulloc), nil);
 
   /* t can't be interned, because intern needs t in order to do its job. */
-  t = cdr(rplacd(gethash_c(user_package->pk.symhash,
+  t = cdr(rplacd(gethash_c(self, user_package->pk.symhash,
                            lit("t"), nulloc), make_sym(lit("t"))));
   set(mkloc(t->s.package, t), user_package);
 
@@ -11008,10 +11015,11 @@ static int unquote_star_check(val obj, val pretty)
 
 val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
 {
+  val self = lit("print");
   val ret = obj;
 
   if (ctx && circle_print_eligible(obj)) {
-    val cell = gethash_c(ctx->obj_hash, obj, nulloc);
+    val cell = gethash_c(self, ctx->obj_hash, obj, nulloc);
     val label = cdr(cell);
 
     if (label == t) {
@@ -11364,11 +11372,12 @@ dot:
 
 static void populate_obj_hash(val obj, struct strm_ctx *ctx)
 {
+  val self = lit("print");
 tail:
   if (circle_print_eligible(obj)) {
     if (ctx->obj_hash_prev) {
       val prev_cell;
-      val label = gethash_f(ctx->obj_hash_prev, obj, mkcloc(prev_cell));
+      val label = gethash_f(self, ctx->obj_hash_prev, obj, mkcloc(prev_cell));
 
       if (label == colon_k)
         uw_throwf(error_s, lit("print: unexpected duplicate object "
@@ -11377,7 +11386,7 @@ tail:
         return;
     } else {
       val new_p;
-      val cell = gethash_c(ctx->obj_hash, obj, mkcloc(new_p));
+      val cell = gethash_c(self, ctx->obj_hash, obj, mkcloc(new_p));
 
       if (!new_p) {
         rplacd(cell, t);
@@ -11448,16 +11457,17 @@ tail:
 
 static void obj_hash_merge(val parent_hash, val child_hash)
 {
+  val self = lit("print");
   val iter, cell;
 
   for (iter = hash_begin(child_hash); (cell = hash_next(iter));) {
     val new_p;
-    val pcell = gethash_c(parent_hash, car(cell), mkcloc(new_p));
+    val pcell = gethash_c(self, parent_hash, car(cell), mkcloc(new_p));
     if (new_p)
       rplacd(pcell, cdr(cell));
     else
-      uw_throwf(error_s, lit("print: unexpected duplicate object "
-                             "(internal error?)"), nao);
+      uw_throwf(error_s, lit("~a: unexpected duplicate object "
+                             "(internal error?)"), self, nao);
   }
 }