From ee4bc843ba15ebbedd8578cbb8e5e477925c413f Mon Sep 17 00:00:00 2001
From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Sat, 27 Jan 2007 00:31:30 +0100
Subject: [PATCH] more generic SCM arg typechecking
---
lily/book.cc | 5 ----
lily/function-documentation.cc | 21 +++++++++++++
lily/grob-scheme.cc | 5 +++-
lily/include/lily-guile-macros.hh | 49 +++++++++++++++++++++++++++----
lily/include/ly-smobs.icc | 8 +++++
lily/include/smobs.hh | 1 +
lily/input-scheme.cc | 2 +-
7 files changed, 78 insertions(+), 13 deletions(-)
diff --git a/lily/book.cc b/lily/book.cc
index f4d4dd790e..01e52ce9cd 100644
--- 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 e59df62192..622d3140bc 100644
--- 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 6938ee25a1..b9ca2d8aa2 100644
--- 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 400ead26ea..8026eded97 100644
--- 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 a77da17fc8..af8035644c 100644
--- 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 5bd403bce4..61b8ae37fd 100644
--- 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 3f14236759..b2d5d84b92 100644
--- 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);
--
2.39.5