lily/context.cc

   1 /*
   2   context.cc -- implement Context
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
   7 */
   8
   9 #include "context.hh"
  10
  11 #include "context-def.hh"
  12 #include "dispatcher.hh"
  13 #include "global-context.hh"
  14 #include "international.hh"
  15 #include "ly-smobs.icc"
  16 #include "main.hh"
  17 #include "output-def.hh"
  18 #include "profile.hh"
  19 #include "program-option.hh"
  20 #include "scm-hash.hh"
  21 #include "translator-group.hh"
  22 #include "warn.hh"
  23
  24 bool
  25 Context::is_removable () const
  26 {
  27   return context_list_ == SCM_EOL && ! iterator_count_
  28     && !dynamic_cast<Global_context const *> (daddy_context_);
  29 }
  30
  31 void
  32 Context::check_removal ()
  33 {
  34   for (SCM p = context_list_; scm_is_pair (p); p = scm_cdr (p))
  35     {
  36       Context *ctx = unsmob_context (scm_car (p));
  37
  38       ctx->check_removal ();
  39       if (ctx->is_removable ())
  40         {
  41           recurse_over_translators (ctx, &Translator::finalize,
  42                                     &Translator_group::finalize,
  43                                     UP);
  44           send_stream_event (ctx, "RemoveContext", 0, 0);
  45         }
  46     }
  47 }
  48
  49 Context::Context (Context const &src)
  50 {
  51   (void) src;
  52   assert (false);
  53 }
  54
  55 Scheme_hash_table *
  56 Context::properties_dict () const
  57 {
  58   return Scheme_hash_table::unsmob (properties_scm_);
  59 }
  60
  61 void
  62 Context::add_context (Context *child)
  63 {
  64   context_list_ = ly_append2 (context_list_,
  65                               scm_cons (child->self_scm (), SCM_EOL));
  66
  67   child->daddy_context_ = this;
  68   this->events_below_->register_as_listener (child->events_below_);
  69 }
  70
  71
  72 Context::Context ()
  73 {
  74   daddy_context_ = 0;
  75   aliases_ = SCM_EOL;
  76   iterator_count_ = 0;
  77   implementation_ = 0;
  78   properties_scm_ = SCM_EOL;
  79   accepts_list_ = SCM_EOL;
  80   context_list_ = SCM_EOL;
  81   definition_ = SCM_EOL;
  82   definition_mods_ = SCM_EOL;
  83   event_source_ = 0;
  84   events_below_ = 0;
  85
  86   smobify_self ();
  87
  88   Scheme_hash_table *tab = new Scheme_hash_table;
  89   properties_scm_ = tab->unprotect ();
  90   event_source_ = new Dispatcher ();
  91   event_source_->unprotect ();
  92   events_below_ = new Dispatcher ();
  93   events_below_->unprotect ();
  94 }
  95
  96 /* TODO:  this shares code with find_create_context ().  */
  97 Context *
  98 Context::create_unique_context (SCM name, string id, SCM operations)
  99 {
 100   /*
 101     Don't create multiple score contexts.
 102   */
 103   Global_context *gthis = dynamic_cast<Global_context *> (this);
 104   if (gthis && gthis->get_score_context ())
 105     return gthis->get_score_context ()->create_unique_context (name, id, operations);
 106
 107   vector<Context_def*> path = path_to_acceptable_context (name);
 108   if (path.size ())
 109     {
 110       Context *current = this;
 111
 112       // Iterate through the path and create all of the implicit contexts.
 113       for (vsize i = 0; i < path.size (); i++)
 114         {
 115           SCM ops = SCM_EOL;
 116           string id_str = "\\new";
 117           if (i == path.size () - 1)
 118             {
 119               ops = operations;
 120               id_str = id;
 121             }
 122           current = current->create_context (path[i],
 123                                              id_str,
 124                                              ops);
 125         }
 126
 127       return current;
 128     }
 129
 130   /*
 131     Don't go up to Global_context, because global goes down to the
 132     Score context
 133   */
 134   Context *ret = 0;
 135   if (daddy_context_ && !dynamic_cast<Global_context *> (daddy_context_))
 136     ret = daddy_context_->create_unique_context (name, id, operations);
 137   else
 138     {
 139       warning (_f ("cannot find or create new `%s'",
 140                    ly_symbol2string (name).c_str ()));
 141       ret = 0;
 142     }
 143   return ret;
 144 }
 145
 146 Context *
 147 Context::find_create_context (SCM n, string id, SCM operations)
 148 {
 149   /*
 150     Don't create multiple score contexts.
 151   */
 152   Global_context *gthis = dynamic_cast<Global_context *> (this);
 153   if (gthis && gthis->get_score_context ())
 154     return gthis->get_score_context ()->find_create_context (n, id, operations);
 155
 156   if (Context *existing = find_context_below (this, n, id))
 157     return existing;
 158
 159   if (n == ly_symbol2scm ("Bottom"))
 160     {
 161       Context *tg = get_default_interpreter ();
 162       return tg;
 163     }
 164
 165   /*
 166     TODO: use accepts_list_.
 167   */
 168   vector<Context_def*> path = path_to_acceptable_context (n);
 169
 170   if (path.size ())
 171     {
 172       Context *current = this;
 173
 174       // start at 1.  The first one (index 0) will be us.
 175       for (vsize i = 0; i < path.size (); i++)
 176         {
 177           SCM ops = (i == path.size () -1) ? operations : SCM_EOL;
 178
 179           string this_id = "";
 180           if (i == path.size () -1)
 181             this_id = id;
 182
 183           current = current->create_context (path[i],
 184                                              this_id,
 185                                              ops);
 186         }
 187
 188       return current;
 189     }
 190
 191   /*
 192     Don't go up to Global_context, because global goes down to the
 193     Score context
 194   */
 195   Context *ret = 0;
 196   if (daddy_context_ && !dynamic_cast<Global_context *> (daddy_context_))
 197     ret = daddy_context_->find_create_context (n, id, operations);
 198   else
 199     {
 200       warning (_f ("cannot find or create `%s' called `%s'",
 201                    ly_symbol2string (n).c_str (), id));
 202       ret = 0;
 203     }
 204   return ret;
 205 }
 206
 207 IMPLEMENT_LISTENER (Context, acknowledge_infant);
 208 void
 209 Context::acknowledge_infant (SCM sev)
 210 {
 211   infant_event_ = unsmob_stream_event (sev);
 212 }
 213
 214 IMPLEMENT_LISTENER (Context, set_property_from_event);
 215 void
 216 Context::set_property_from_event (SCM sev)
 217 {
 218   Stream_event *ev = unsmob_stream_event (sev);
 219
 220   SCM sym = ev->get_property ("symbol");
 221   if (scm_is_symbol (sym))
 222     {
 223       SCM val = ev->get_property ("value");
 224       bool ok = true;
 225       if (val != SCM_EOL)
 226         ok = type_check_assignment (sym, val, ly_symbol2scm ("translation-type?"));
 227       if (ok)
 228         set_property (sym, val);
 229     }
 230 }
 231
 232 IMPLEMENT_LISTENER (Context, unset_property_from_event);
 233 void
 234 Context::unset_property_from_event (SCM sev)
 235 {
 236   Stream_event *ev = unsmob_stream_event (sev);
 237
 238   SCM sym = ev->get_property ("symbol");
 239   type_check_assignment (sym, SCM_EOL, ly_symbol2scm ("translation-type?"));
 240   unset_property (sym);
 241 }
 242
 243 /*
 244   Creates a new context from a CreateContext event, and sends an
 245   AnnounceNewContext event to this context.
 246 */
 247 IMPLEMENT_LISTENER (Context, create_context_from_event);
 248 void
 249 Context::create_context_from_event (SCM sev)
 250 {
 251   Stream_event *ev = unsmob_stream_event (sev);
 252
 253   string id = ly_scm2string (ev->get_property ("id"));
 254   SCM ops = ev->get_property ("ops");
 255   SCM type_scm = ev->get_property ("type");
 256   string type = ly_symbol2string (type_scm);
 257
 258   vector<Context_def*> path = path_to_acceptable_context (type_scm);
 259
 260   if (path.size () != 1)
 261     {
 262       programming_error (_f ("Invalid CreateContext event: Cannot create %s context", type.c_str ()));
 263       return;
 264     }
 265   Context_def *cdef = path[0];
 266
 267   Context *new_context = cdef->instantiate (ops);
 268
 269   new_context->id_string_ = id;
 270
 271   /* Register various listeners:
 272       - Make the new context hear events that universally affect contexts
 273       - connect events_below etc. properly */
 274   /* We want to be the first ones to hear our own events. Therefore, wait
 275      before registering events_below_ */
 276   new_context->event_source ()->
 277     add_listener (GET_LISTENER (new_context->create_context_from_event),
 278                   ly_symbol2scm ("CreateContext"));
 279   new_context->event_source ()->
 280     add_listener (GET_LISTENER (new_context->remove_context),
 281                   ly_symbol2scm ("RemoveContext"));
 282   new_context->event_source ()->
 283     add_listener (GET_LISTENER (new_context->change_parent),
 284                   ly_symbol2scm ("ChangeParent"));
 285   new_context->event_source ()->
 286     add_listener (GET_LISTENER (new_context->set_property_from_event),
 287                   ly_symbol2scm ("SetProperty"));
 288   new_context->event_source ()->
 289     add_listener (GET_LISTENER (new_context->unset_property_from_event),
 290                   ly_symbol2scm ("UnsetProperty"));
 291
 292   new_context->events_below_->register_as_listener (new_context->event_source_);
 293   this->add_context (new_context);
 294
 295   new_context->unprotect ();
 296
 297   Context_def *td = unsmob_context_def (new_context->definition_);
 298
 299   /* This cannot move before add_context (), because \override
 300      operations require that we are in the hierarchy.  */
 301   td->apply_default_property_operations (new_context);
 302   apply_property_operations (new_context, ops);
 303
 304   send_stream_event (this, "AnnounceNewContext", 0,
 305                      ly_symbol2scm ("context"), new_context->self_scm (),
 306                      ly_symbol2scm ("creator"), sev);
 307 }
 308
 309 vector<Context_def*>
 310 Context::path_to_acceptable_context (SCM name) const
 311 {
 312   // definition_mods_ is a list of (symbol string), but the Context_def expects
 313   // to see a list of (symbol symbol).
 314   SCM accepts = SCM_EOL;
 315   for (SCM s = scm_reverse (definition_mods_); scm_is_pair (s); s = scm_cdr (s))
 316     if (scm_caar (s) == ly_symbol2scm ("accepts"))
 317       {
 318         SCM elt = scm_list_2 (scm_caar (s), scm_string_to_symbol (scm_cadar (s)));
 319         accepts = scm_cons (elt, accepts);
 320       }
 321
 322   return unsmob_context_def (definition_)->path_to_acceptable_context (name,
 323                                                                        get_output_def (),
 324                                                                        accepts);
 325
 326 }
 327
 328 Context *
 329 Context::create_context (Context_def *cdef,
 330                          string id,
 331                          SCM ops)
 332 {
 333   infant_event_ = 0;
 334   /* TODO: This is fairly misplaced. We can fix this when we have taken out all
 335      iterator specific stuff from the Context class */
 336   event_source_->
 337     add_listener (GET_LISTENER (acknowledge_infant),
 338                   ly_symbol2scm ("AnnounceNewContext"));
 339   /* The CreateContext creates a new context, and sends an announcement of the
 340      new context through another event. That event will be stored in
 341      infant_event_ to create a return value. */
 342   send_stream_event (this, "CreateContext", 0,
 343                      ly_symbol2scm ("ops"), ops,
 344                      ly_symbol2scm ("type"), cdef->get_context_name (),
 345                      ly_symbol2scm ("id"), ly_string2scm (id));
 346   event_source_->
 347     remove_listener (GET_LISTENER (acknowledge_infant),
 348                      ly_symbol2scm ("AnnounceNewContext"));
 349
 350   assert (infant_event_);
 351   SCM infant_scm = infant_event_->get_property ("context");
 352   Context *infant = unsmob_context (infant_scm);
 353
 354   if (!infant || infant->get_parent_context () != this)
 355     {
 356       programming_error ("create_context: can't locate newly created context");
 357       return 0;
 358     }
 359
 360   return infant;
 361 }
 362
 363 /*
 364   Default child context as a SCM string, or something else if there is
 365   none.
 366 */
 367 SCM
 368 Context::default_child_context_name () const
 369 {
 370   return scm_is_pair (accepts_list_)
 371     ? scm_car (accepts_list_)
 372     : SCM_EOL;
 373 }
 374
 375 bool
 376 Context::is_bottom_context () const
 377 {
 378   return !scm_is_symbol (default_child_context_name ());
 379 }
 380
 381 Context *
 382 Context::get_default_interpreter ()
 383 {
 384   if (!is_bottom_context ())
 385     {
 386       SCM nm = default_child_context_name ();
 387       SCM st = find_context_def (get_output_def (), nm);
 388
 389       string name = ly_symbol2string (nm);
 390       Context_def *t = unsmob_context_def (st);
 391       if (!t)
 392         {
 393           warning (_f ("cannot find or create: `%s'", name.c_str ()));
 394           t = unsmob_context_def (this->definition_);
 395         }
 396
 397       Context *tg = create_context (t, "", SCM_EOL);
 398       return tg->get_default_interpreter ();
 399     }
 400   return this;
 401 }
 402
 403 /*
 404   PROPERTIES
 405 */
 406 Context *
 407 Context::where_defined (SCM sym, SCM *value) const
 408 {
 409 #ifndef NDEBUG
 410   if (profile_property_accesses)
 411     note_property_access (&context_property_lookup_table, sym);
 412 #endif
 413
 414   if (properties_dict ()->try_retrieve (sym, value))
 415     return (Context *)this;
 416
 417   return (daddy_context_) ? daddy_context_->where_defined (sym, value) : 0;
 418 }
 419
 420 /*
 421   return SCM_EOL when not found.
 422 */
 423 SCM
 424 Context::internal_get_property (SCM sym) const
 425 {
 426 #ifndef NDEBUG
 427   if (profile_property_accesses)
 428     note_property_access (&context_property_lookup_table, sym);
 429 #endif
 430
 431   SCM val = SCM_EOL;
 432   if (properties_dict ()->try_retrieve (sym, &val))
 433     return val;
 434
 435   if (daddy_context_)
 436     return daddy_context_->internal_get_property (sym);
 437
 438   return val;
 439 }
 440
 441 /*
 442 Called by the send_stream_event macro. props is a 0-terminated array of
 443 properties and corresponding values, interleaved. This method should not
 444 be called from any other place than the send_stream_event macro.
 445 */
 446 void
 447 Context::internal_send_stream_event (SCM type, Input *origin, SCM props[])
 448 {
 449   Stream_event *e = new Stream_event (type, origin);
 450   for (int i = 0; props[i]; i += 2)
 451     {
 452       e->set_property (props[i], props[i+1]);
 453     }
 454   event_source_->broadcast (e);
 455   e->unprotect ();
 456 }
 457
 458 bool
 459 Context::is_alias (SCM sym) const
 460 {
 461   if (sym == ly_symbol2scm ("Bottom")
 462       && !scm_is_pair (accepts_list_))
 463     return true;
 464   if (sym == unsmob_context_def (definition_)->get_context_name ())
 465     return true;
 466
 467   return scm_c_memq (sym, aliases_) != SCM_BOOL_F;
 468 }
 469
 470 void
 471 Context::add_alias (SCM sym)
 472 {
 473   aliases_ = scm_cons (sym, aliases_);
 474 }
 475
 476 /* we don't (yet) instrument context properties */
 477 void
 478 Context::instrumented_set_property (SCM sym, SCM val, const char*, int, const char*)
 479 {
 480   internal_set_property (sym, val);
 481 }
 482
 483 void
 484 Context::internal_set_property (SCM sym, SCM val)
 485 {
 486   if (do_internal_type_checking_global)
 487     assert (type_check_assignment (sym, val, ly_symbol2scm ("translation-type?")));
 488
 489   properties_dict ()->set (sym, val);
 490 }
 491
 492 /*
 493   TODO: look up to check whether we have inherited var?
 494 */
 495 void
 496 Context::unset_property (SCM sym)
 497 {
 498   properties_dict ()->remove (sym);
 499 }
 500
 501 IMPLEMENT_LISTENER (Context, change_parent);
 502 void
 503 Context::change_parent (SCM sev)
 504 {
 505   Stream_event *ev = unsmob_stream_event (sev);
 506   Context *to = unsmob_context (ev->get_property ("context"));
 507
 508   disconnect_from_parent ();
 509   to->add_context (this);
 510 }
 511
 512 /*
 513   Die. The next GC sweep should take care of the actual death.
 514  */
 515 IMPLEMENT_LISTENER (Context, remove_context);
 516 void
 517 Context::remove_context (SCM)
 518 {
 519   /* ugh, the translator group should listen to RemoveContext events by itself */
 520   Translator_group *impl = implementation ();
 521   if (impl)
 522     impl->disconnect_from_context ();
 523   disconnect_from_parent ();
 524 }
 525
 526 void
 527 Context::disconnect_from_parent ()
 528 {
 529   daddy_context_->events_below_->unregister_as_listener (this->events_below_);
 530   daddy_context_->context_list_ = scm_delq_x (this->self_scm (), daddy_context_->context_list_);
 531   daddy_context_ = 0;
 532 }
 533
 534 /*
 535   ID == "" means accept any ID.
 536 */
 537 Context *
 538 find_context_below (Context *where,
 539                     SCM type, string id)
 540 {
 541   if (where->is_alias (type))
 542     {
 543       if (id == "" || where->id_string () == id)
 544         return where;
 545     }
 546
 547   Context *found = 0;
 548   for (SCM s = where->children_contexts ();
 549        !found && scm_is_pair (s); s = scm_cdr (s))
 550     {
 551       Context *tr = unsmob_context (scm_car (s));
 552
 553       found = find_context_below (tr, type, id);
 554     }
 555
 556   return found;
 557 }
 558
 559 SCM
 560 Context::properties_as_alist () const
 561 {
 562   return properties_dict ()->to_alist ();
 563 }
 564
 565 SCM
 566 Context::context_name_symbol () const
 567 {
 568   Context_def *td = unsmob_context_def (definition_);
 569   return td->get_context_name ();
 570 }
 571
 572 string
 573 Context::context_name () const
 574 {
 575   return ly_symbol2string (context_name_symbol ());
 576 }
 577
 578 Context *
 579 Context::get_score_context () const
 580 {
 581   if (daddy_context_)
 582     return daddy_context_->get_score_context ();
 583   else
 584     return 0;
 585 }
 586
 587 Output_def *
 588 Context::get_output_def () const
 589 {
 590   return daddy_context_ ? daddy_context_->get_output_def () : 0;
 591 }
 592
 593 Context::~Context ()
 594 {
 595 }
 596
 597 Moment
 598 Context::now_mom () const
 599 {
 600   Context const *p = this;
 601   while (p->daddy_context_)
 602     p = p->daddy_context_;
 603
 604   return p->now_mom ();
 605 }
 606
 607 int
 608 Context::print_smob (SCM s, SCM port, scm_print_state *)
 609 {
 610   Context *sc = (Context *) SCM_CELL_WORD_1 (s);
 611
 612   scm_puts ("#<", port);
 613   scm_puts (sc->class_name (), port);
 614   if (Context_def *d = unsmob_context_def (sc->definition_))
 615     {
 616       scm_puts (" ", port);
 617       scm_display (d->get_context_name (), port);
 618     }
 619
 620   if (!sc->id_string_.empty ())
 621     {
 622       scm_puts ("=", port);
 623       scm_puts (sc->id_string_.c_str (), port);
 624     }
 625
 626   scm_puts (" ", port);
 627
 628   scm_display (sc->context_list_, port);
 629   scm_puts (" >", port);
 630
 631   return 1;
 632 }
 633
 634 SCM
 635 Context::mark_smob (SCM sm)
 636 {
 637   Context *me = (Context *) SCM_CELL_WORD_1 (sm);
 638
 639   scm_gc_mark (me->context_list_);
 640   scm_gc_mark (me->aliases_);
 641   scm_gc_mark (me->definition_);
 642   scm_gc_mark (me->definition_mods_);
 643   scm_gc_mark (me->properties_scm_);
 644   scm_gc_mark (me->accepts_list_);
 645
 646   if (me->implementation_)
 647     scm_gc_mark (me->implementation_->self_scm ());
 648
 649   if (me->event_source_)
 650     scm_gc_mark (me->event_source_->self_scm ());
 651
 652   if (me->events_below_)
 653     scm_gc_mark (me->events_below_->self_scm ());
 654
 655   return me->properties_scm_;
 656 }
 657
 658 IMPLEMENT_SMOBS (Context);
 659 IMPLEMENT_DEFAULT_EQUAL_P (Context);
 660 IMPLEMENT_TYPE_P (Context, "ly:context?");
 661
 662 Global_context *
 663 Context::get_global_context () const
 664 {
 665   if (dynamic_cast<Global_context *> ((Context *) this))
 666     return dynamic_cast<Global_context *> ((Context *) this);
 667
 668   if (daddy_context_)
 669     return daddy_context_->get_global_context ();
 670
 671   programming_error ("no Global context");
 672   return 0;
 673 }
 674
 675 Context *
 676 Context::get_parent_context () const
 677 {
 678   return daddy_context_;
 679 }
 680
 681 /*
 682   Ugh. Where to put this?
 683 */
 684 Rational
 685 measure_length (Context const *context)
 686 {
 687   SCM l = context->get_property ("measureLength");
 688   Rational length (1);
 689   if (unsmob_moment (l))
 690     length = unsmob_moment (l)->main_part_;
 691   return length;
 692 }
 693
 694 Moment
 695 measure_position (Context const *context)
 696 {
 697   SCM sm = context->get_property ("measurePosition");
 698
 699   Moment m = 0;
 700   if (unsmob_moment (sm))
 701     {
 702       m = *unsmob_moment (sm);
 703
 704       if (m.main_part_ < Rational (0))
 705         {
 706           Rational length (measure_length (context));
 707           while (m.main_part_ < Rational (0))
 708             m.main_part_ += length;
 709         }
 710     }
 711
 712   return m;
 713 }
 714
 715
 716 void
 717 set_context_property_on_children (Context *trans, SCM sym, SCM val)
 718 {
 719   trans->set_property (sym, ly_deep_copy (val));
 720   for (SCM p = trans->children_contexts (); scm_is_pair (p); p = scm_cdr (p))
 721     {
 722       Context *trg = unsmob_context (scm_car (p));
 723       set_context_property_on_children (trg, sym, ly_deep_copy (val));
 724     }
 725 }
 726
 727 bool
 728 melisma_busy (Context *tr)
 729 {
 730   SCM melisma_properties = tr->get_property ("melismaBusyProperties");
 731   bool busy = false;
 732
 733   for (; !busy && scm_is_pair (melisma_properties);
 734        melisma_properties = scm_cdr (melisma_properties))
 735     busy = busy || to_boolean (tr->internal_get_property (scm_car (melisma_properties)));
 736
 737   return busy;
 738 }