more generic SCM arg typechecking

diff --git a/lily/book.cc b/lily/book.cc
index f4d4dd790e1310b31cc53223b3e23f4b6f4e9404..01e52ce9cdce87151b731a9301e653813a399af1 100644 (file)
--- a/lily/book.cc
+++ b/lily/book.cc
@@ -83,11 +83,6 @@ Book::mark_smob (SCM s)
 {
   Book *book = (Book *) SCM_CELL_WORD_1 (s);
 
-#if 0
-  if (book->key_)
-    scm_gc_mark (book->key_->self_scm ());
-#endif
-
   if (book->paper_)
     scm_gc_mark (book->paper_->self_scm ());
   scm_gc_mark (book->scores_);

diff --git a/lily/function-documentation.cc b/lily/function-documentation.cc
index e59df6219272ab45ec88ab364464c453d93f3828..622d3140bc1a5402fc39e6e54918676f6c349b0d 100644 (file)
--- a/lily/function-documentation.cc
+++ b/lily/function-documentation.cc
@@ -53,3 +53,24 @@ LY_DEFINE (ly_get_all_function_documentation, "ly:get-all-function-documentation
 {
   return doc_hash_table;
 }
+
+
+#include <map>
+
+map<void *, string>  type_names;
+  
+void
+ly_add_type_predicate (void *ptr,
+                      string name)
+{
+  type_names[ptr] = name; 
+}
+
+string
+predicate_to_typename (void *ptr)
+{
+  if (type_names.find (ptr) == type_names.end ())
+    return "unknown type";
+  else
+    return type_names[ptr];
+}

diff --git a/lily/grob-scheme.cc b/lily/grob-scheme.cc
index 6938ee25a1ecb14c8134bd6d27b46fb23d08bfbc..b9ca2d8aa2fcb0ee6b7ecc32df5ae4ec01f5105e 100644 (file)
--- a/lily/grob-scheme.cc
+++ b/lily/grob-scheme.cc
@@ -20,7 +20,10 @@ LY_DEFINE (ly_grob_property_data, "ly:grob-property-data",
           "Retrieve @var{sym} for @var{grob} but don't process callbacks.")
 {
   Grob *sc = unsmob_grob (grob);
-  SCM_ASSERT_TYPE (sc, grob, SCM_ARG1, __FUNCTION__, "grob");
+
+  LY_FUNC_NOTE_FIRST_ARG(grob);
+  LY_ASSERT_SMOB(Grob, 1);
+
   SCM_ASSERT_TYPE (scm_is_symbol (sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 
   return sc->get_property_data (sym);

diff --git a/lily/include/lily-guile-macros.hh b/lily/include/lily-guile-macros.hh
index 400ead26ea857b299895fc3ee72b69106ddc9870..8026eded97743e2d1aa42ef82ea7c26b268fb599 100644 (file)
--- a/lily/include/lily-guile-macros.hh
+++ b/lily/include/lily-guile-macros.hh
@@ -1,5 +1,5 @@
 /*
-  lily-guile-macros.hh -- declare
+  lily-guile-macros.hh -- declare GUILE interaction macros.
 
   source file of the GNU LilyPond music typesetter
 
@@ -25,9 +25,6 @@
    FIXME: should add check for x86 as well?  */
 #define CACHE_SYMBOLS
 
-
-
-
 #ifdef CACHE_SYMBOLS
 
 /* this lets us "overload" macros such as get_property to take
@@ -94,11 +91,31 @@ inline SCM ly_symbol2scm (char const *x) { return scm_str2symbol ((x)); }
 #define DECLARE_SCHEME_CALLBACK(NAME, ARGS)    \
   static SCM NAME ARGS;                                \
   static SCM NAME ## _proc
- 
+#define ADD_TYPE_PREDICATE(func, type_name) \
+  void \
+  func ## _type_adder ()                       \
+  {\
+    ly_add_type_predicate ((Type_predicate_ptr)func, type_name);       \
+  }\
+  ADD_SCM_INIT_FUNC(func ## _type_adder_ctor, \
+                   func ## _type_adder);
+#define ADD_TYPE_PREDICATE(func, type_name) \
+  void \
+  func ## _type_adder ()                       \
+  {\
+    ly_add_type_predicate ((Type_predicate_ptr)func, type_name);       \
+  }\
+  ADD_SCM_INIT_FUNC(func ## _type_adder_ctor, \
+                   func ## _type_adder);
+
+string mangle_cxx_identifier (string);
+
+void ly_add_type_predicate (void *ptr, string name);
+string predicate_to_typename (void *ptr);
+
 /*
   Make TYPE::FUNC available as a Scheme function.
 */
-string mangle_cxx_identifier (string);
 #define MAKE_SCHEME_CALLBACK_WITH_OPTARGS(TYPE, FUNC, ARGCOUNT, OPTIONAL_COUNT, DOC) \
   SCM TYPE ::FUNC ## _proc;                                            \
   void                                                                 \
@@ -183,4 +200,24 @@ void ly_check_name (string cxx, string fname);
 #define set_property(x, y) internal_set_property (ly_symbol2scm (x), y)
 #endif
 
+
+
+#define LY_FUNC_NOTE_FIRST_ARG(a)  \
+  SCM *first_arg_ptr = &a; \
+  int stack_grow_dir = 0;  \
+  stack_grow_dir = ((void*) &first_arg_ptr < (void*) &stack_grow_dir) ? -1 : 1;
+
+#define LY_ASSERT_TYPE(pred, number) \
+  {                                                                    \
+    if (!pred (first_arg_ptr[(number-1)*stack_grow_dir]))              \
+      {                                                                        \
+       scm_wrong_type_arg_msg(mangle_cxx_identifier (__FUNCTION__).c_str(), \
+                              number, first_arg_ptr[(number-1)*stack_grow_dir], \
+                              predicate_to_typename ((void*) &pred).c_str()); \
+      }                                                                        \
+  }
+
+#define LY_ASSERT_SMOB(klass, number) LY_ASSERT_TYPE(klass::unsmob, number)
+
+
 #endif /* LILY_GUILE_MACROS_HH */

diff --git a/lily/include/ly-smobs.icc b/lily/include/ly-smobs.icc
index a77da17fc82733cfa708c9fc33cd13e3c0007e69..af8035644c1fcbc762a47ab2a91d546c48a386c4 100644 (file)
--- a/lily/include/ly-smobs.icc
+++ b/lily/include/ly-smobs.icc
@@ -25,6 +25,14 @@
   ADD_SCM_INIT_FUNC (init_type_ ## CL, init_type_ ## CL)
 
 #define IMPLEMENT_BASE_SMOBS(CL)                                       \
+  void \
+  CL ## _type_adder ()                 \
+  {\
+    ly_add_type_predicate ((void*) &CL::unsmob, #CL);  \
+  }\
+  ADD_SCM_INIT_FUNC(CL ## _type_adder_ctor, \
+                   CL ## _type_adder);\
+  const char *CL::smob_name_ = #CL;                                    \
   scm_t_bits CL::smob_tag_;                                            \
   SCM                                                                  \
   CL::smob_p (SCM s)                                                   \

diff --git a/lily/include/smobs.hh b/lily/include/smobs.hh
index 5bd403bce45364763f307fb2014960034e146b58..61b8ae37fd2e64fc3e0f3f0c7111f0910738131b 100644 (file)
--- a/lily/include/smobs.hh
+++ b/lily/include/smobs.hh
@@ -96,6 +96,7 @@
 #define DECLARE_BASE_SMOBS(CL)                                 \
   friend class Non_existent_class;                             \
   private:                                                     \
+  static const char* smob_name_; \
   static scm_t_bits smob_tag_;                                 \
   static SCM mark_smob (SCM);                                  \
   static size_t free_smob (SCM s);                             \

diff --git a/lily/input-scheme.cc b/lily/input-scheme.cc
index 3f1423675940f30e42aebce21da2f4d7f8260116..b2d5d84b9208b62ff19949bea2b5b8aeffd2f4ee 100644 (file)
--- a/lily/input-scheme.cc
+++ b/lily/input-scheme.cc
@@ -23,7 +23,7 @@ LY_DEFINE (ly_input_message, "ly:input-message", 2, 0, 1, (SCM sip, SCM msg, SCM
           "location in @var{sip}. @var{msg} is interpreted similar to @code{format}'s argument\n")
 {
   Input *ip = unsmob_input (sip);
-  SCM_ASSERT_TYPE (ip, sip, SCM_ARG1, __FUNCTION__, "input location");
+  
   SCM_ASSERT_TYPE (scm_is_string (msg), msg, SCM_ARG2, __FUNCTION__, "string");
 
   msg = scm_simple_format (SCM_BOOL_F, msg, rest);