From ef96995c66220cf1f49a98e43b5fcfe9a2f1bac1 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Sun, 31 Aug 2014 09:51:55 +0200 Subject: [PATCH] Issue 4086/6: Reimplement unpure-pure-containers in terms of Simple_smob and Smob1 --- lily/beam-engraver.cc | 2 +- lily/context-property.cc | 6 +- lily/function-documentation.cc | 3 +- lily/grob-closure.cc | 4 +- lily/grob-property.cc | 18 ++-- lily/grob-scheme.cc | 2 +- lily/grob.cc | 12 +-- lily/include/unpure-pure-container.hh | 26 ++++-- lily/rest-collision.cc | 8 +- lily/side-position-interface.cc | 2 +- lily/simple-closure.cc | 14 +-- lily/slur.cc | 4 +- lily/unpure-pure-container.cc | 121 ++++++-------------------- 13 files changed, 85 insertions(+), 137 deletions(-) diff --git a/lily/beam-engraver.cc b/lily/beam-engraver.cc index 9ab1d99847..b8e17fe2b1 100644 --- a/lily/beam-engraver.cc +++ b/lily/beam-engraver.cc @@ -248,7 +248,7 @@ Beam_engraver::acknowledge_rest (Grob_info info) 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); diff --git a/lily/context-property.cc b/lily/context-property.cc index cc98feeba0..000bd0b5cc 100644 --- a/lily/context-property.cc +++ b/lily/context-property.cc @@ -55,9 +55,9 @@ general_pushpop_property (Context *context, 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?")); diff --git a/lily/function-documentation.cc b/lily/function-documentation.cc index 7bb4543d2f..9cddf41b74 100644 --- a/lily/function-documentation.cc +++ b/lily/function-documentation.cc @@ -111,8 +111,7 @@ init_func_doc () 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"); diff --git a/lily/grob-closure.cc b/lily/grob-closure.cc index 06a947d0de..03c68684c7 100644 --- a/lily/grob-closure.cc +++ b/lily/grob-closure.cc @@ -39,7 +39,7 @@ add_offset_callback (Grob *g, SCM proc, Axis a) 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 (); @@ -67,7 +67,7 @@ chain_callback (Grob *g, SCM proc, SCM sym) { 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 (); diff --git a/lily/grob-property.cc b/lily/grob-property.cc index e88e6e3406..2c099a256b 100644 --- a/lily/grob-property.cc +++ b/lily/grob-property.cc @@ -124,7 +124,7 @@ Grob::internal_set_value_on_alist (SCM *alist, SCM sym, SCM v) { 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?")); @@ -152,7 +152,7 @@ Grob::internal_get_property_data (SCM sym) const { 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); @@ -180,8 +180,8 @@ Grob::internal_get_property (SCM sym) const } #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)) @@ -201,9 +201,9 @@ Grob::internal_get_pure_property (SCM sym, int start, int end) const 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); @@ -305,7 +305,7 @@ Grob::internal_get_object (SCM sym) const 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); @@ -332,9 +332,9 @@ Grob::internal_has_interface (SCM k) 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)) { diff --git a/lily/grob-scheme.cc b/lily/grob-scheme.cc index c9b7bdaccb..3c9d1bb241 100644 --- a/lily/grob-scheme.cc +++ b/lily/grob-scheme.cc @@ -451,7 +451,7 @@ LY_DEFINE (ly_grob_chain_callback, "ly:grob-chain-callback", 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); diff --git a/lily/grob.cc b/lily/grob.cc index 63b7565035..e4c1fd4a89 100644 --- a/lily/grob.cc +++ b/lily/grob.cc @@ -79,16 +79,16 @@ Grob::Grob (SCM basicprops) 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) diff --git a/lily/include/unpure-pure-container.hh b/lily/include/unpure-pure-container.hh index 1fd32d40bb..5db80adec1 100644 --- a/lily/include/unpure-pure-container.hh +++ b/lily/include/unpure-pure-container.hh @@ -21,11 +21,25 @@ #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 +{ +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 */ diff --git a/lily/rest-collision.cc b/lily/rest-collision.cc index 743f14ad79..ac79df4fbd 100644 --- a/lily/rest-collision.cc +++ b/lily/rest-collision.cc @@ -73,10 +73,10 @@ Rest_collision::add_column (Grob *me, Grob *p) 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); } } diff --git a/lily/side-position-interface.cc b/lily/side-position-interface.cc index 30856416d8..cb77eda02f 100644 --- a/lily/side-position-interface.cc +++ b/lily/side-position-interface.cc @@ -419,7 +419,7 @@ Side_position_interface::set_axis (Grob *me, Axis a) 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); } } diff --git a/lily/simple-closure.cc b/lily/simple-closure.cc index bfc4b34bb8..a4204cddc4 100644 --- a/lily/simple-closure.cc +++ b/lily/simple-closure.cc @@ -50,9 +50,9 @@ evaluate_with_simple_closure (SCM delayed_argument, 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)); @@ -66,12 +66,12 @@ evaluate_with_simple_closure (SCM delayed_argument, 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; diff --git a/lily/slur.cc b/lily/slur.cc index 9179e1e560..9313437279 100644 --- a/lily/slur.cc +++ b/lily/slur.cc @@ -423,8 +423,8 @@ Slur::auxiliary_acknowledge_extra_object (Grob_info const &info, 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 ()); diff --git a/lily/unpure-pure-container.cc b/lily/unpure-pure-container.cc index 1aefe920af..5d5fe38235 100644 --- a/lily/unpure-pure-container.cc +++ b/lily/unpure-pure-container.cc @@ -21,55 +21,30 @@ #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 { - 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), @@ -79,76 +54,36 @@ LY_DEFINE (ly_make_unpure_pure_container, "ly:make-unpure-pure-container", " 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_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); -- 2.39.2