From 69622b49b7a5a9c992e36ef11ba60c1fdd3c34b6 Mon Sep 17 00:00:00 2001 From: Mike Solomon Date: Thu, 1 Sep 2011 14:57:48 +0200 Subject: [PATCH] Implements unpure-pure-containers in LilyPond. These structures free functions from needing to be pre-registered as pure in define-grobs.scm. For example, if one has a function foo that is the unpure callback for a given property and bar that is the pure callback, the generalized syntax for these containers is: \override Grob #'property = #(ly:make-unpure-pure-container foo bar) All of the pure/unpure distinctions that require a back and forth between .scm and .cc files can, in theory, be eliminated by using these containers. Furthermore, all of the functions whose pure equivalents are hard-coded can now take different pure equivalents (see input/regression/unpure-pure-container.ly). --- input/regression/unpure-pure-container.ly | 25 +++++ lily/axis-group-interface.cc | 1 + lily/context-property.cc | 14 ++- lily/function-documentation.cc | 2 + lily/grob-property.cc | 11 ++- lily/include/unpure-pure-container.hh | 30 ++++++ lily/system.cc | 1 + lily/unpure-pure-container.cc | 110 ++++++++++++++++++++++ scm/define-grobs.scm | 38 +++++--- 9 files changed, 213 insertions(+), 19 deletions(-) create mode 100644 input/regression/unpure-pure-container.ly create mode 100644 lily/include/unpure-pure-container.hh create mode 100644 lily/unpure-pure-container.cc diff --git a/input/regression/unpure-pure-container.ly b/input/regression/unpure-pure-container.ly new file mode 100644 index 0000000000..0e95a43052 --- /dev/null +++ b/input/regression/unpure-pure-container.ly @@ -0,0 +1,25 @@ + +\version "2.15.10" + +\header { + texidoc = "unpure-pure containers take two arguments: an unpure property and +a pure property. The pure property is evaluated (and cached) for all +pure calculations, and the unpure is evaluated for all unpure calculations. +In this regtest, there are three groups of two eighth notes. In the first +group, the second note should move to accommodate the flag, whereas it should +not in the second group because it registers the flag as being higher. The +flag, however, remains at the Y-offset dictated by ly:flag::calc-y-offset. +In the third set of two 8th notes, the flag should be pushed up to a Y-offset +of 8. +" +} + +\relative c'' { + \stemUp \autoBeamOff + d,8 eis' + \once \override Flag #'Y-offset = + #(ly:make-unpure-pure-container ly:flag::calc-y-offset 8) + d,8 eis'! + \once \override Flag #'Y-offset = #8 + d,8 eis'! +} diff --git a/lily/axis-group-interface.cc b/lily/axis-group-interface.cc index ac778b0536..f3a099b5df 100644 --- a/lily/axis-group-interface.cc +++ b/lily/axis-group-interface.cc @@ -34,6 +34,7 @@ #include "stencil.hh" #include "system.hh" #include "warn.hh" +#include "unpure-pure-container.hh" static bool pure_staff_priority_less (Grob *const &g1, Grob *const &g2); diff --git a/lily/context-property.cc b/lily/context-property.cc index 7ee4b904d9..f4f5f07b5c 100644 --- a/lily/context-property.cc +++ b/lily/context-property.cc @@ -24,6 +24,7 @@ #include "main.hh" #include "simple-closure.hh" #include "spanner.hh" +#include "unpure-pure-container.hh" #include "warn.hh" /* @@ -113,10 +114,15 @@ execute_override_property (Context *context, target_alist = scm_acons (symbol, new_value, target_alist); bool ok = true; - if (!ly_is_procedure (new_value) - && !is_simple_closure (new_value)) - ok = type_check_assignment (symbol, new_value, - ly_symbol2scm ("backend-type?")); + bool pc = is_unpure_pure_container (new_value); + SCM vals[] = {pc ? unpure_pure_container_unpure_part (new_value) : new_value, + pc ? unpure_pure_container_pure_part (new_value) : SCM_BOOL_F}; + + for (int i = 0; i < 2; i++) + if (!ly_is_procedure (vals[i]) + && !is_simple_closure (vals[i])) + ok = ok && type_check_assignment (symbol, vals[i], + ly_symbol2scm ("backend-type?")); /* tack onto alist. We can use set_car, since diff --git a/lily/function-documentation.cc b/lily/function-documentation.cc index 480ea6b089..df73ddcefe 100644 --- a/lily/function-documentation.cc +++ b/lily/function-documentation.cc @@ -97,6 +97,7 @@ predicate_to_typename (void *ptr) #include "performance.hh" #include "spanner.hh" #include "stream-event.hh" +#include "unpure-pure-container.hh" void init_func_doc () @@ -110,6 +111,7 @@ init_func_doc () ly_add_type_predicate ((void *) &unsmob_moment, "Moment"); ly_add_type_predicate ((void *) &unsmob_paper_score, "Paper_score"); ly_add_type_predicate ((void *) &unsmob_performance, "Performance"); + ly_add_type_predicate ((void *) &is_unpure_pure_container, "unpure pure container"); ly_add_type_predicate ((void *) &is_axis, "axis"); ly_add_type_predicate ((void *) &is_number_pair, "number pair"); diff --git a/lily/grob-property.cc b/lily/grob-property.cc index 2a4368f9ab..de1e01b396 100644 --- a/lily/grob-property.cc +++ b/lily/grob-property.cc @@ -18,6 +18,7 @@ #include "program-option.hh" #include "profile.hh" #include "simple-closure.hh" +#include "unpure-pure-container.hh" #include "warn.hh" #include "protected-scm.hh" @@ -123,6 +124,7 @@ Grob::internal_set_value_on_alist (SCM *alist, SCM sym, SCM v) { if (!ly_is_procedure (v) && !is_simple_closure (v) + && !is_unpure_pure_container (v) && v != ly_symbol2scm ("calculation-in-progress")) type_check_assignment (sym, v, ly_symbol2scm ("backend-type?")); @@ -149,7 +151,7 @@ Grob::internal_get_property_data (SCM sym) const if (do_internal_type_checking_global && scm_is_pair (handle)) { SCM val = scm_cdr (handle); - if (!ly_is_procedure (val) && !is_simple_closure (val)) + if (!ly_is_procedure (val) && !is_simple_closure (val) && !is_unpure_pure_container (val)) type_check_assignment (sym, val, ly_symbol2scm ("backend-type?")); check_interfaces_for_property (this, sym); @@ -177,6 +179,8 @@ Grob::internal_get_property (SCM sym) const } #endif + if (is_unpure_pure_container (val)) + val = unpure_pure_container_unpure_part (val); if (ly_is_procedure (val) || is_simple_closure (val)) { @@ -192,7 +196,7 @@ SCM Grob::internal_get_pure_property (SCM sym, int start, int end) const { SCM val = internal_get_property_data (sym); - if (ly_is_procedure (val)) + if (ly_is_procedure (val) || is_unpure_pure_container (val)) return call_pure_function (val, scm_list_1 (self_scm ()), start, end); if (is_simple_closure (val)) return evaluate_with_simple_closure (self_scm (), @@ -294,7 +298,8 @@ Grob::internal_get_object (SCM sym) const { SCM val = scm_cdr (s); if (ly_is_procedure (val) - || is_simple_closure (val)) + || is_simple_closure (val) + || is_unpure_pure_container (val)) { Grob *me = ((Grob *)this); val = me->try_callback_on_alist (&me->object_alist_, sym, val); diff --git a/lily/include/unpure-pure-container.hh b/lily/include/unpure-pure-container.hh new file mode 100644 index 0000000000..a34afed9a1 --- /dev/null +++ b/lily/include/unpure-pure-container.hh @@ -0,0 +1,30 @@ +/* + This file is part of LilyPond, the GNU music typesetter. + + Copyright (C) 2005--2011 Han-Wen Nienhuys + + LilyPond is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + LilyPond is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with LilyPond. If not, see . +*/ + +#ifndef UNPURE_PURE_CONTAINER_HH +#define UNPURE_PURE_CONTAINER_HH + +#include "lily-guile.hh" + +bool is_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); + +#endif /* UNPURE_PURE_CONTAINER_HH */ diff --git a/lily/system.cc b/lily/system.cc index 5d3c0e3347..c20f244890 100644 --- a/lily/system.cc +++ b/lily/system.cc @@ -38,6 +38,7 @@ #include "staff-symbol-referencer.hh" #include "text-interface.hh" #include "warn.hh" +#include "unpure-pure-container.hh" System::System (System const &src) : Spanner (src) diff --git a/lily/unpure-pure-container.cc b/lily/unpure-pure-container.cc new file mode 100644 index 0000000000..9a8639dad0 --- /dev/null +++ b/lily/unpure-pure-container.cc @@ -0,0 +1,110 @@ +/* + This file is part of LilyPond, the GNU music typesetter. + + Copyright (C) 2011 Mike Solomon + + + LilyPond is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + LilyPond is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with LilyPond. If not, see . +*/ +#include "unpure-pure-container.hh" + +#include "grob.hh" + +static scm_t_bits unpure_pure_container_tag; + +bool +is_unpure_pure_container (SCM s) +{ + return (SCM_NIMP (s) && SCM_CELL_TYPE (s) == unpure_pure_container_tag); +} + +SCM +unpure_pure_container_unpure_part (SCM smob) +{ + LY_ASSERT_TYPE (is_unpure_pure_container, smob, 1); + return (SCM) SCM_CELL_WORD_1 (smob); +} + +SCM +unpure_pure_container_pure_part (SCM smob) +{ + LY_ASSERT_TYPE (is_unpure_pure_container, smob, 1); + return (SCM) SCM_CELL_WORD_2 (smob); +} + +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)); +} + +LY_DEFINE (ly_make_unpure_pure_container, "ly:make-unpure-pure-container", + 1, 1, 0, (SCM unpure, SCM pure), + "Make an unpure-pure container. @var{unpure} should be an unpure" + " expression, and @var{pure} should be a pure expression. If @var{pure}" + " is ommitted, the value of @var{unpure} will be used twice.") +{ + SCM z; + + if (pure == SCM_UNDEFINED) + pure = unpure; + + SCM_NEWSMOB2 (z, unpure_pure_container_tag, SCM_UNPACK (unpure), SCM_UNPACK (pure)); + return z; +} + +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_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); +} + +int +print_unpure_pure_container (SCM s, SCM port, scm_print_state *) +{ + scm_puts ("#", port); + return 1; +} + +SCM +pure_mark (SCM pure) +{ + scm_gc_mark (unpure_pure_container_unpure_part (pure)); + scm_gc_mark (unpure_pure_container_pure_part (pure)); + return pure; +} + +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); +}; + +ADD_SCM_INIT_FUNC (unpure_pure_container, init_unpure_pure_container); diff --git a/scm/define-grobs.scm b/scm/define-grobs.scm index b5315cfd93..586ed1f3b1 100644 --- a/scm/define-grobs.scm +++ b/scm/define-grobs.scm @@ -2666,6 +2666,7 @@ (let ((extent-callback (ly:grob-property-data grob 'Y-extent))) (not (eq? #f (or + (ly:unpure-pure-container? extent-callback) (pair? extent-callback) (memq extent-callback pure-functions) (and @@ -2677,16 +2678,29 @@ (assq stencil pure-print-to-height-conversions) (ly:stencil? stencil))))))))) +;; hideous code dup below - to be cleaned up when call pure functino +;; is eliminated and lilypond works entirely from unpure-pure-containers + (define-public (call-pure-function unpure args start end) - (if (ly:simple-closure? unpure) - (ly:eval-simple-closure (car args) unpure start end) - (if (not (procedure? unpure)) - unpure - (if (memq unpure pure-functions) - (apply unpure args) - (let ((pure (assq unpure pure-conversions-alist))) - (if pure - (apply (cdr pure) - (append - (list (car args) start end) - (cdr args))))))))) + (if (ly:unpure-pure-container? unpure) + (let ((unpure (ly:unpure-pure-container-pure-part unpure))) + (if (ly:simple-closure? unpure) + (ly:eval-simple-closure (car args) unpure start end) + (if (not (procedure? unpure)) + unpure + (apply (cdr pure) + (append + (list (car args) start end) + (cdr args)))))) + (if (ly:simple-closure? unpure) + (ly:eval-simple-closure (car args) unpure start end) + (if (not (procedure? unpure)) + unpure + (if (memq unpure pure-functions) + (apply unpure args) + (let ((pure (assq unpure pure-conversions-alist))) + (if pure + (apply (cdr pure) + (append + (list (car args) start end) + (cdr args)))))))))) -- 2.39.5