if (beam_
&& !scm_is_number (info.grob ()->get_property_data ("staff-position")))
chain_offset_callback (info.grob (),
- ly_make_unpure_pure_container
+ Unpure_pure_container::make_smob
(Beam::rest_collision_callback_proc,
Beam::pure_rest_collision_callback_proc),
Y_AXIS);
bool
typecheck_grob (SCM symbol, SCM value)
{
- if (is_unpure_pure_container (value))
- return typecheck_grob (symbol, unpure_pure_container_unpure_part (value))
- && typecheck_grob (symbol, unpure_pure_container_pure_part (value));
+ if (Unpure_pure_container *upc = Unpure_pure_container::unsmob (value))
+ return typecheck_grob (symbol, upc->unpure_part ())
+ && typecheck_grob (symbol, upc->pure_part ());
return ly_is_procedure (value)
|| Simple_closure::unsmob (value)
|| type_check_assignment (symbol, value, ly_symbol2scm ("backend-type?"));
ly_add_type_predicate ((void *) &Moment::unsmob, "Moment");
ly_add_type_predicate ((void *) &Paper_score::unsmob, "Paper_score");
ly_add_type_predicate ((void *) &Performance::unsmob, "Performance");
- ly_add_type_predicate ((void *) &is_unpure_pure_container, "unpure pure container");
-
+ ly_add_type_predicate ((void *) &Unpure_pure_container::unsmob, "unpure pure container");
ly_add_type_predicate ((void *) &is_axis, "axis");
ly_add_type_predicate ((void *) &is_number_pair, "number pair");
ly_add_type_predicate ((void *) &ly_is_list, "list");
return;
}
- if (ly_is_procedure (data) || is_unpure_pure_container (data))
+ if (ly_is_procedure (data) || Unpure_pure_container::unsmob (data))
data = Simple_closure::make_smob (scm_list_1 (data));
else if (Simple_closure *sc = Simple_closure::unsmob (data))
data = sc->expression ();
{
SCM data = g->get_property_data (sym);
- if (ly_is_procedure (data) || is_unpure_pure_container (data))
+ if (ly_is_procedure (data) || Unpure_pure_container::unsmob (data))
data = Simple_closure::make_smob (scm_list_1 (data));
else if (Simple_closure *sc = Simple_closure::unsmob (data))
data = sc->expression ();
{
if (!ly_is_procedure (v)
&& !Simple_closure::unsmob (v)
- && !is_unpure_pure_container (v)
+ && !Unpure_pure_container::unsmob (v)
&& v != ly_symbol2scm ("calculation-in-progress"))
type_check_assignment (sym, v, ly_symbol2scm ("backend-type?"));
{
SCM val = scm_cdr (handle);
if (!ly_is_procedure (val) && !Simple_closure::unsmob (val)
- && !is_unpure_pure_container (val))
+ && !Unpure_pure_container::unsmob (val))
type_check_assignment (sym, val, ly_symbol2scm ("backend-type?"));
check_interfaces_for_property (this, sym);
}
#endif
- if (is_unpure_pure_container (val))
- val = unpure_pure_container_unpure_part (val);
+ if (Unpure_pure_container *upc = Unpure_pure_container::unsmob (val))
+ val = upc->unpure_part ();
if (ly_is_procedure (val)
|| Simple_closure::unsmob (val))
if (ly_is_procedure (val))
return call_pure_function (val, scm_list_1 (self_scm ()), start, end);
- if (is_unpure_pure_container (val)) {
+ if (Unpure_pure_container *upc = Unpure_pure_container::unsmob (val)) {
// Do cache, if the function ignores 'start' and 'end'
- if (is_unchanging_unpure_pure_container (val))
+ if (upc->is_unchanging ())
return internal_get_property (sym);
else
return call_pure_function (val, scm_list_1 (self_scm ()), start, end);
SCM val = scm_cdr (s);
if (ly_is_procedure (val)
|| Simple_closure::unsmob (val)
- || is_unpure_pure_container (val))
+ || Unpure_pure_container::unsmob (val))
{
Grob *me = ((Grob *)this);
val = me->try_callback_on_alist (&me->object_alist_, sym, val);
SCM
call_pure_function (SCM unpure, SCM args, int start, int end)
{
- if (is_unpure_pure_container (unpure))
+ if (Unpure_pure_container *upc = Unpure_pure_container::unsmob (unpure))
{
- SCM pure = unpure_pure_container_pure_part (unpure);
+ SCM pure = upc->pure_part ();
if (Simple_closure *sc = Simple_closure::unsmob (pure))
{
Grob *gr = Grob::unsmob (grob);
LY_ASSERT_SMOB (Grob, grob, 1);
- SCM_ASSERT_TYPE (ly_is_procedure (proc) || is_unpure_pure_container (proc), proc, SCM_ARG2, __FUNCTION__, "procedure or unpure pure container");
+ SCM_ASSERT_TYPE (ly_is_procedure (proc) || Unpure_pure_container::unsmob (proc), proc, SCM_ARG2, __FUNCTION__, "procedure or unpure pure container");
LY_ASSERT_TYPE (ly_is_symbol, sym, 3);
chain_callback (gr, proc, sym);
set_property ("X-extent", Grob::stencil_width_proc);
if (get_property_data ("Y-extent") == SCM_EOL)
set_property ("Y-extent",
- ly_make_unpure_pure_container (Grob::stencil_height_proc,
- Grob::pure_stencil_height_proc));
+ Unpure_pure_container::make_smob (Grob::stencil_height_proc,
+ Grob::pure_stencil_height_proc));
if (get_property_data ("vertical-skylines") == SCM_EOL)
set_property ("vertical-skylines",
- ly_make_unpure_pure_container (Grob::simple_vertical_skylines_from_extents_proc,
- Grob::pure_simple_vertical_skylines_from_extents_proc));
+ Unpure_pure_container::make_smob (Grob::simple_vertical_skylines_from_extents_proc,
+ Grob::pure_simple_vertical_skylines_from_extents_proc));
if (get_property_data ("horizontal-skylines") == SCM_EOL)
set_property ("horizontal-skylines",
- ly_make_unpure_pure_container (Grob::simple_horizontal_skylines_from_extents_proc,
- Grob::pure_simple_horizontal_skylines_from_extents_proc));
+ Unpure_pure_container::make_smob (Grob::simple_horizontal_skylines_from_extents_proc,
+ Grob::pure_simple_horizontal_skylines_from_extents_proc));
}
Grob::Grob (Grob const &s)
#define UNPURE_PURE_CONTAINER_HH
#include "lily-guile.hh"
-
-bool is_unpure_pure_container (SCM s);
-bool is_unchanging_unpure_pure_container (SCM s);
-SCM unpure_pure_container_unpure_part (SCM smob);
-SCM unpure_pure_container_pure_part (SCM smob);
-SCM ly_make_unpure_pure_container (SCM, SCM);
+#include "small-smobs.hh"
+
+class Unpure_pure_container : public Smob2<Unpure_pure_container>
+{
+public:
+ static const char type_p_name_ [];
+ SCM unpure_part () const { return scm1 (); }
+ // A container that has the same callback for both 'pure' and 'unpure' lookups
+ // and which ignores the 'start' and 'end' columnns.
+ // Such a callback will give the same answer for tentative or final layouts.
+ bool is_unchanging () const { return SCM_UNBNDP (scm2 ()); }
+ SCM pure_part () const;
+ static SCM make_smob (SCM a, SCM b = SCM_UNDEFINED)
+ {
+ if (SCM_UNBNDP (b) && !ly_is_procedure (a))
+ return Smob2::make_smob (a, a);
+ return Smob2::make_smob (a, b);
+ }
+ static int print_smob (SCM, SCM, scm_print_state *);
+};
#endif /* UNPURE_PURE_CONTAINER_HH */
if (rest)
{
chain_offset_callback (rest,
- ly_make_unpure_pure_container
- (Rest_collision::force_shift_callback_rest_proc,
- ly_lily_module_constant ("pure-chain-offset-callback")),
- Y_AXIS);
+ Unpure_pure_container::make_smob
+ (Rest_collision::force_shift_callback_rest_proc,
+ ly_lily_module_constant ("pure-chain-offset-callback")),
+ Y_AXIS);
}
}
chain_offset_callback (me,
(a == X_AXIS)
? x_aligned_side_proc
- : ly_make_unpure_pure_container (y_aligned_side_proc, pure_y_aligned_side_proc),
+ : Unpure_pure_container::make_smob (y_aligned_side_proc, pure_y_aligned_side_proc),
a);
}
}
if (Simple_closure *sc = Simple_closure::unsmob (expr))
{
SCM inside = sc->expression ();
- SCM proc = is_unpure_pure_container (scm_car (inside))
- ? (pure ? scm_car (inside) : unpure_pure_container_unpure_part (scm_car (inside)))
- : scm_car (inside);
+ SCM proc = !pure && Unpure_pure_container::unsmob (scm_car (inside))
+ ? Unpure_pure_container::unsmob (scm_car (inside))->unpure_part ()
+ : scm_car (inside);
SCM args = scm_cons (delayed_argument,
evaluate_args (delayed_argument, scm_cdr (inside),
pure, start, end));
return expr;
else if (scm_car (expr) == ly_symbol2scm ("quote"))
return scm_cadr (expr);
- else if (is_unpure_pure_container (scm_car (expr))
+ else if (Unpure_pure_container::unsmob (scm_car (expr))
|| ly_is_procedure (scm_car (expr)))
{
- SCM proc = is_unpure_pure_container (scm_car (expr))
- ? (pure ? scm_car (expr) : unpure_pure_container_unpure_part (scm_car (expr)))
- : scm_car (expr);
+ SCM proc = !pure && Unpure_pure_container::unsmob (scm_car (expr))
+ ? Unpure_pure_container::unsmob (scm_car (expr))->unpure_part ()
+ : scm_car (expr);
SCM args = evaluate_args (delayed_argument, scm_cdr (expr), pure, start, end);
if (args == SCM_UNSPECIFIED)
return SCM_UNSPECIFIED;
if (slur)
{
chain_offset_callback (e,
- ly_make_unpure_pure_container (outside_slur_callback_proc,
- pure_outside_slur_callback_proc),
+ Unpure_pure_container::make_smob (outside_slur_callback_proc,
+ pure_outside_slur_callback_proc),
Y_AXIS);
chain_callback (e, outside_slur_cross_staff_proc, ly_symbol2scm ("cross-staff"));
e->set_object ("slur", slur->self_scm ());
#include "grob.hh"
-static scm_t_bits unpure_pure_container_tag;
-static scm_t_bits unpure_pure_call_tag;
-// Used for rerouting a function of (grob start end) to one of
-// (grob)
-
-bool
-is_unpure_pure_container (SCM s)
-{
- return (SCM_NIMP (s) && SCM_CELL_TYPE (s) == unpure_pure_container_tag);
-}
-
-bool
-is_unchanging_unpure_pure_container (SCM s)
-// A container that has the same callback for both 'pure' and 'unpure' lookups
-// and which ignores the 'start' and 'end' columnns.
-// Such a callback will give the same answer for tentative or final layouts.
-{
- LY_ASSERT_TYPE (is_unpure_pure_container, s, 1);
- SCM pure_part = SCM_SMOB_OBJECT_2 (s);
- return (SCM_UNBNDP (pure_part));
-}
-
-SCM
-unpure_pure_container_unpure_part (SCM smob)
+// Reroutes a call to the contained function after dropping last two
+// arguments. Used for applying an "unpure" function in a "pure"
+// context.
+class Unpure_pure_call : public Smob1<Unpure_pure_call>
{
- LY_ASSERT_TYPE (is_unpure_pure_container, smob, 1);
- return SCM_SMOB_OBJECT (smob);
-}
+public:
+ LY_DECLARE_SMOB_PROC (2, 0, 1, (SCM self, SCM arg1, SCM arg2, SCM rest))
+ {
+ return scm_apply_0 (Unpure_pure_call::unsmob (self)->scm1 (),
+ scm_call_2 (ly_lily_module_constant ("drop-right"),
+ scm_cons2 (arg1, arg2, rest),
+ scm_from_int (2)));
+ }
+};
SCM
-unpure_pure_container_pure_part (SCM smob)
+Unpure_pure_container::pure_part () const
{
- LY_ASSERT_TYPE (is_unpure_pure_container, smob, 1);
- SCM res = SCM_SMOB_OBJECT_2 (smob);
-
- if (!SCM_UNBNDP (res))
- return res;
-
- SCM_NEWSMOB (res, unpure_pure_call_tag,
- SCM_UNPACK (unpure_pure_container_unpure_part (smob)));
- return res;
+ return SCM_UNBNDP (scm2 ())
+ ? Unpure_pure_call::make_smob (scm1 ())
+ : scm2 ();
}
-LY_DEFINE (ly_unpure_pure_container_p, "ly:unpure-pure-container?",
- 1, 0, 0, (SCM clos),
- "Is @var{clos} an unpure pure container?")
-{
- return scm_from_bool (is_unpure_pure_container (clos));
-}
+const char Unpure_pure_container::type_p_name_[] = "ly:unpure-pure-container?";
LY_DEFINE (ly_make_unpure_pure_container, "ly:make-unpure-pure-container",
1, 1, 0, (SCM unpure, SCM pure),
" except that a callback is given two extra arguments"
" that are ignored for the sake of pure calculations.")
{
- SCM z;
-
- if (SCM_UNBNDP (pure) && !ly_is_procedure (unpure))
- pure = unpure;
-
- SCM_NEWSMOB2 (z, unpure_pure_container_tag, SCM_UNPACK (unpure), SCM_UNPACK (pure));
- return z;
+ return Unpure_pure_container::make_smob (unpure, pure);
}
LY_DEFINE (ly_unpure_pure_container_unpure_part, "ly:unpure-pure-container-unpure-part",
1, 0, 0, (SCM pc),
"Return the unpure part of @var{pc}.")
{
- LY_ASSERT_TYPE (is_unpure_pure_container, pc, 1);
- return unpure_pure_container_unpure_part (pc);
+ LY_ASSERT_TYPE (Unpure_pure_container::unsmob, pc, 1);
+ return Unpure_pure_container::unsmob (pc)->unpure_part ();
}
LY_DEFINE (ly_unpure_pure_container_pure_part, "ly:unpure-pure-container-pure-part",
1, 0, 0, (SCM pc),
"Return the pure part of @var{pc}.")
{
- LY_ASSERT_TYPE (is_unpure_pure_container, pc, 1);
- return unpure_pure_container_pure_part (pc);
+ LY_ASSERT_TYPE (Unpure_pure_container::unsmob, pc, 1);
+ return Unpure_pure_container::unsmob (pc)->pure_part ();
}
int
-print_unpure_pure_container (SCM s, SCM port, scm_print_state *)
+Unpure_pure_container::print_smob (SCM s, SCM port, scm_print_state *)
{
+ Unpure_pure_container *p = Unpure_pure_container::unsmob (s);
scm_puts ("#<unpure-pure-container ", port);
- scm_display (unpure_pure_container_unpure_part (s), port);
- if (!SCM_UNBNDP (SCM_SMOB_OBJECT_2 (s)))
+ scm_display (p->unpure_part (), port);
+ if (!p->is_unchanging ())
{
scm_puts (" ", port);
- scm_display (unpure_pure_container_pure_part (s), port);
+ scm_display (p->pure_part (), port);
}
scm_puts (" >", port);
return 1;
}
-
-SCM
-pure_mark (SCM smob)
-{
- scm_gc_mark (SCM_SMOB_OBJECT (smob));
- return SCM_SMOB_OBJECT_2 (smob);
-}
-
-// Function signature has two fixed arguments so that dropping two
-// will always work: if we have fewer to start with, it will trigger
-// wrong-number-of-args in a sensible location rather than making
-// drop-right barf.
-
-SCM
-apply_unpure_pure (SCM clo, SCM arg1, SCM arg2, SCM rest)
-{
- return scm_apply_0 (SCM_SMOB_OBJECT (clo),
- scm_call_2 (ly_lily_module_constant ("drop-right"),
- scm_cons2 (arg1, arg2, rest),
- scm_from_int (2)));
-}
-
-
-void init_unpure_pure_container ()
-{
- unpure_pure_container_tag = scm_make_smob_type ("unpure-pure-container", 0);
- scm_set_smob_mark (unpure_pure_container_tag, pure_mark);
- scm_set_smob_print (unpure_pure_container_tag, print_unpure_pure_container);
- unpure_pure_call_tag = scm_make_smob_type ("unpure-pure-call", 0);
- scm_set_smob_mark (unpure_pure_call_tag, scm_markcdr);
- scm_set_smob_apply (unpure_pure_call_tag,
- (scm_t_subr) apply_unpure_pure, 2, 0, 1);
-};
-
-ADD_SCM_INIT_FUNC (unpure_pure_container, init_unpure_pure_container);
projects / lilypond.git / commitdiff