lily/lily-guile.cc

   1 /*
   2   lily-guile.cc -- implement assorted SCM interface functions
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 1998--2005 Jan Nieuwenhuizen <janneke@gnu.org>
   7                  Han-Wen Nienhuys <hanwen@cs.uu.nl>
   8 */
   9
  10
  11 #include <cstdio>
  12 #include <cstdlib>
  13 #include <cstring> /* strdup, strchr */
  14 #include <cctype>
  15 #include <libintl.h>            // gettext on macos x
  16
  17 #include "config.hh"
  18 #include "version.hh"
  19 #include "lily-guile.hh"
  20 #include "libc-extension.hh"
  21 #include "main.hh"
  22 #include "file-path.hh"
  23 #include "warn.hh"
  24 #include "direction.hh"
  25 #include "offset.hh"
  26 #include "pitch.hh"
  27 #include "dimensions.hh"
  28 #include "source-file.hh"
  29 #include "misc.hh"
  30
  31 // #define TEST_GC
  32
  33 SCM
  34 ly_to_symbol (SCM scm)
  35 {
  36   return scm_string_to_symbol (ly_to_string (scm));
  37 }
  38
  39 SCM
  40 ly_to_string (SCM scm)
  41 {
  42   return scm_call_3 (ly_lily_module_constant ("format"), SCM_BOOL_F,
  43                      scm_makfrom0str ("~S"), scm);
  44 }
  45
  46 SCM
  47 ly_last (SCM list)
  48 {
  49   return scm_car (scm_last_pair (list));
  50 }
  51
  52 SCM
  53 ly_write2scm (SCM s)
  54 {
  55   SCM port = scm_mkstrport (SCM_INUM0,
  56                             scm_make_string (SCM_INUM0, SCM_UNDEFINED),
  57                             SCM_OPN | SCM_WRTNG,
  58                             "ly_write2string");
  59   //  SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
  60   SCM write = scm_primitive_eval (ly_symbol2scm ("write"));
  61
  62   // scm_apply (write, port, SCM_EOL);
  63   scm_call_2 (write, s, port);
  64   return scm_strport_to_string (port);
  65 }
  66
  67 SCM
  68 ly_quote_scm (SCM s)
  69 {
  70   return scm_list_n (ly_symbol2scm ("quote"), s, SCM_UNDEFINED);
  71 }
  72
  73 String
  74 ly_symbol2string (SCM s)
  75 {
  76   /*
  77     Ugh. this is not very efficient.
  78    */
  79   SCM str = scm_symbol_to_string (s);
  80   return ly_scm2string (str);
  81 }
  82
  83 String
  84 gulp_file_to_string (String fn, bool must_exist)
  85 {
  86   String s = global_path.find (fn);
  87   if (s == "")
  88     {
  89       if (must_exist)
  90         {
  91           String e = _f ("can't find file: `%s'", fn);
  92           e += " ";
  93           e += _f ("(load path: `%s')", global_path.to_string ());
  94           error (e);
  95           /* unreachable */
  96         }
  97       return s;
  98     }
  99
 100   if (be_verbose_global)
 101     progress_indication ("[" + s);
 102
 103   int n;
 104   char *str = gulp_file (s, &n);
 105   String result ((Byte*) str, n);
 106   delete[] str;
 107
 108   if (be_verbose_global)
 109     progress_indication ("]");
 110
 111   return result;
 112 }
 113
 114
 115
 116 extern "C" {
 117   // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
 118 void
 119 ly_display_scm (SCM s)
 120 {
 121   scm_display (s, scm_current_output_port ());
 122   scm_newline (scm_current_output_port ());
 123 }
 124 };
 125
 126 String
 127 ly_scm2string (SCM str)
 128 {
 129   assert (scm_is_string (str));
 130   return String ((Byte*)scm_i_string_chars (str),
 131                  (int) scm_i_string_length (str));
 132 }
 133
 134 char *
 135 ly_scm2newstr (SCM str, size_t *lenp)
 136 {
 137   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
 138
 139   size_t len = SCM_STRING_LENGTH (str);
 140   if (char *new_str = (char *) malloc ((len + 1) * sizeof (char)))
 141     {
 142       memcpy (new_str, scm_i_string_chars (str), len);
 143       new_str[len] = '\0';
 144
 145       if (lenp)
 146         *lenp = len;
 147
 148       return new_str;
 149     }
 150   return 0;
 151 }
 152
 153 SCM
 154 index_get_cell (SCM s, Direction d)
 155 {
 156
 157   assert (d);
 158   return (d == LEFT) ? scm_car (s) : scm_cdr (s);
 159 }
 160
 161 SCM
 162 index_set_cell (SCM s, Direction d, SCM v)
 163 {
 164   if (d == LEFT)
 165     scm_set_car_x (s, v);
 166   else if (d == RIGHT)
 167     scm_set_cdr_x (s, v);
 168   return s;
 169 }
 170
 171 bool
 172 is_number_pair (SCM p)
 173 {
 174   return scm_is_pair (p)
 175     && scm_is_number (scm_car (p)) && scm_is_number (scm_cdr (p));
 176 }
 177
 178 typedef void (*Void_fptr) ();
 179 Array<Void_fptr> *scm_init_funcs_;
 180
 181 void add_scm_init_func (void (*f) ())
 182 {
 183   if (!scm_init_funcs_)
 184     scm_init_funcs_ = new Array<Void_fptr>;
 185
 186   scm_init_funcs_->push (f);
 187 }
 188
 189 #if KPATHSEA
 190 extern "C" {
 191   void initialize_kpathsea ();
 192 }
 193 #endif
 194
 195 void
 196 ly_init_ly_module (void *)
 197 {
 198   for (int i = scm_init_funcs_->size () ; i--;)
 199     (scm_init_funcs_->elem (i)) ();
 200
 201   if (be_verbose_global)
 202     progress_indication ("\n");
 203
 204 #if KPATHSEA
 205   if (is_TeX_format_global)
 206     {
 207       /*
 208         TODO: load this dynamically
 209       */
 210       initialize_kpathsea ();
 211     }
 212 #endif
 213
 214   scm_primitive_load_path (scm_makfrom0str ("lily.scm"));
 215 }
 216
 217 SCM global_lily_module;
 218
 219 void
 220 ly_c_init_guile ()
 221 {
 222   global_lily_module = scm_c_define_module ("lily", ly_init_ly_module, 0);
 223   scm_c_use_module ("lily");
 224 }
 225
 226 unsigned int
 227 ly_scm_hash (SCM s)
 228 {
 229   return scm_ihashv (s, ~1u);
 230 }
 231
 232 bool
 233 is_direction (SCM s)
 234 {
 235   if (scm_is_number (s))
 236     {
 237       int i = scm_to_int (s);
 238       return i>= -1 && i <= 1;
 239     }
 240   return false;
 241 }
 242
 243 bool
 244 is_axis (SCM s)
 245 {
 246   if (scm_is_number (s))
 247     {
 248       int i = scm_to_int (s);
 249       return i == 0 || i == 1;
 250     }
 251   return false;
 252 }
 253
 254 Direction
 255 to_dir (SCM s)
 256 {
 257   return scm_is_integer (s) ? (Direction) scm_to_int (s) : CENTER;
 258 }
 259
 260 Interval
 261 ly_scm2interval (SCM p)
 262 {
 263   return Interval (scm_to_double (scm_car (p)), scm_to_double (scm_cdr (p)));
 264 }
 265
 266 Drul_array<Real>
 267 ly_scm2realdrul (SCM p)
 268 {
 269   return Drul_array<Real> (scm_to_double (scm_car (p)),
 270                            scm_to_double (scm_cdr (p)));
 271 }
 272
 273 SCM
 274 ly_interval2scm (Drul_array<Real> i)
 275 {
 276   return scm_cons (scm_make_real (i[LEFT]), scm_make_real (i[RIGHT]));
 277 }
 278
 279 bool
 280 to_boolean (SCM s)
 281 {
 282   return scm_is_bool (s) && ly_scm2bool (s);
 283 }
 284
 285 /* Appendable list L: the cdr contains the list, the car the last cons
 286    in the list.  */
 287 SCM
 288 appendable_list ()
 289 {
 290   SCM s = scm_cons (SCM_EOL, SCM_EOL);
 291   scm_set_car_x (s, s);
 292
 293   return s;
 294 }
 295
 296 void
 297 appendable_list_append (SCM l, SCM elt)
 298 {
 299   SCM newcons = scm_cons (elt, SCM_EOL);
 300
 301   scm_set_cdr_x (scm_car (l), newcons);
 302   scm_set_car_x (l, newcons);
 303 }
 304
 305 SCM
 306 ly_offset2scm (Offset o)
 307 {
 308   return scm_cons (scm_make_real (o[X_AXIS]), scm_make_real (o[Y_AXIS]));
 309 }
 310
 311 Offset
 312 ly_scm2offset (SCM s)
 313 {
 314   return Offset (scm_to_double (scm_car (s)),
 315                  scm_to_double (scm_cdr (s)));
 316 }
 317
 318 SCM
 319 ly_deep_copy (SCM src)
 320 {
 321   if (scm_is_pair (src))
 322     return scm_cons (ly_deep_copy (scm_car (src)), ly_deep_copy (scm_cdr (src)));
 323   else if (scm_is_vector (src))
 324     {
 325       int len = scm_c_vector_length (src);
 326       SCM nv = scm_c_make_vector (len, SCM_UNDEFINED);
 327       for (int i = 0 ;i < len ; i++)
 328         {
 329           SCM si = scm_int2num (i);
 330           scm_vector_set_x (nv, si, ly_deep_copy (scm_vector_ref (src, si)));
 331         }
 332     }
 333   return src;
 334 }
 335
 336 SCM
 337 ly_chain_assoc_get (SCM key, SCM achain, SCM dfault)
 338 {
 339   if (scm_is_pair (achain))
 340     {
 341       SCM handle = scm_assoc (key, scm_car (achain));
 342       if (scm_is_pair (handle))
 343         return scm_cdr (handle);
 344       else
 345         return ly_chain_assoc (key, scm_cdr (achain));
 346     }
 347   else
 348     return dfault;
 349 }
 350
 351 SCM
 352 ly_chain_assoc (SCM key, SCM achain)
 353 {
 354   if (scm_is_pair (achain))
 355     {
 356       SCM handle = scm_assoc (key, scm_car (achain));
 357       if (scm_is_pair (handle))
 358         return handle;
 359       else
 360         return ly_chain_assoc (key, scm_cdr (achain));
 361     }
 362   else
 363     return SCM_BOOL_F;
 364 }
 365
 366 /* looks the key up in the cdrs of the alist-keys
 367    - ignoring the car and ignoring non-pair keys.
 368    Returns first match found, i.e.
 369
 370    alist = ((1 . 10)
 371                    ((1 . 2) . 11)
 372                    ((2 . 1) . 12)
 373                    ((3 . 0) . 13)
 374                    ((4 . 1) . 14) )
 375
 376 I would like (ly_assoc_cdr 1) to return 12 - because it's the first
 377 element with the cdr of the key = 1.  In other words (alloc_cdr key)
 378 corresponds to call
 379
 380 (alloc (anything . key))
 381
 382
 383
 384 */
 385 SCM
 386 ly_assoc_cdr (SCM key, SCM alist)
 387 {
 388   if (scm_is_pair (alist))
 389     {
 390       SCM trykey = scm_caar (alist);
 391       if (scm_is_pair (trykey) && to_boolean (scm_equal_p (key, scm_cdr (trykey))))
 392         return scm_car (alist);
 393       else
 394         return ly_assoc_cdr (key, scm_cdr (alist));
 395     }
 396   return SCM_BOOL_F;
 397 }
 398
 399 /* LST has the form "sym1 sym2 sym3\nsym4\nsym5"
 400    i.e. \n and ' ' can be used interchangeably as separators.  */
 401 SCM
 402 parse_symbol_list (char const *lst)
 403 {
 404   char *s = strdup (lst);
 405   char *orig = s;
 406   SCM create_list = SCM_EOL;
 407
 408   char * e = s + strlen (s) - 1;
 409   while (e >= s && isspace (*e))
 410     *e-- = 0;
 411
 412   for (char * p = s; *p; p++)
 413     if (*p == '\n')
 414       *p = ' ';
 415
 416   if (!s[0])
 417     s = 0;
 418
 419   while (s)
 420     {
 421       char *next = strchr (s, ' ');
 422       if (next)
 423         *next++ = 0;
 424
 425       create_list = scm_cons (ly_symbol2scm (s), create_list);
 426       s = next;
 427     }
 428
 429   free (orig);
 430   return create_list;
 431 }
 432
 433 SCM
 434 ly_truncate_list (int k, SCM lst)
 435 {
 436   if (k == 0)
 437     lst = SCM_EOL;
 438   else
 439     {
 440       SCM s = lst;
 441       k--;
 442       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
 443         ;
 444
 445       if (scm_is_pair (s))
 446         scm_set_cdr_x (s, SCM_EOL);
 447     }
 448   return lst;
 449 }
 450
 451 String
 452 print_scm_val (SCM val)
 453 {
 454   String realval = ly_scm2string (ly_write2scm (val));
 455   if (realval.length () > 200)
 456     realval = realval.left_string (100)
 457       + "\n :\n :\n"
 458       + realval.right_string (100);
 459   return realval;
 460 }
 461
 462 bool
 463 type_check_assignment (SCM sym, SCM val,  SCM type_symbol)
 464 {
 465   bool ok = true;
 466
 467   /*
 468     Always succeeds.
 469
 470
 471     TODO: should remove #f from allowed vals?
 472    */
 473   if (val == SCM_EOL || val == SCM_BOOL_F)
 474     return ok;
 475
 476   if (!scm_is_symbol (sym))
 477 #if 0
 478     return false;
 479 #else
 480   /*
 481     This is used for autoBeamSettings.
 482
 483     TODO: deprecate the use of \override and \revert for
 484     autoBeamSettings?
 485
 486     or use a symbol autoBeamSettingS?
 487    */
 488   return true;
 489 #endif
 490
 491   SCM type = scm_object_property (sym, type_symbol);
 492
 493   if (type != SCM_EOL && !ly_c_procedure_p (type))
 494       {
 495         warning (_f ("Can't find property type-check for `%s' (%s).",
 496                      ly_symbol2string (sym).to_str0 (),
 497                      ly_symbol2string (type_symbol).to_str0 ())
 498                  + "  " + _ ("Perhaps you made a typing error?"));
 499
 500         /* Be strict when being anal :) */
 501         if (do_internal_type_checking_global)
 502           abort ();
 503
 504         warning (_ ("Doing assignment anyway."));
 505       }
 506   else
 507     {
 508       if (val != SCM_EOL
 509           && ly_c_procedure_p (type)
 510           && scm_call_1 (type, val) == SCM_BOOL_F)
 511         {
 512           SCM errport = scm_current_error_port ();
 513           ok = false;
 514           SCM typefunc = ly_lily_module_constant ("type-name");
 515           SCM type_name = scm_call_1 (typefunc, type);
 516
 517
 518           scm_puts (_f ("Type check for `%s' failed; value `%s' must be of type `%s'",
 519                         ly_symbol2string (sym).to_str0 (),
 520                         print_scm_val (val),
 521                         ly_scm2string (type_name).to_str0 ()).to_str0 (),
 522                     errport);
 523           scm_puts ("\n", errport);
 524         }
 525     }
 526   return ok;
 527 }
 528
 529
 530 /* some SCM abbrevs
 531
 532    zijn deze nou handig?
 533    zijn ze er al in scheme, maar heten ze anders? */
 534
 535
 536 /* Remove doubles from (sorted) list */
 537 SCM
 538 ly_unique (SCM list)
 539 {
 540   SCM unique = SCM_EOL;
 541   for (SCM i = list; scm_is_pair (i); i = scm_cdr (i))
 542     {
 543       if (!scm_is_pair (scm_cdr (i))
 544           || !ly_c_equal_p (scm_car (i), scm_cadr (i)))
 545         unique = scm_cons (scm_car (i), unique);
 546     }
 547   return scm_reverse_x (unique, SCM_EOL);
 548 }
 549
 550
 551 static int
 552 scm_default_compare (void const *a, void const *b)
 553 {
 554   SCM pa = *(SCM*) a;
 555   SCM pb = *(SCM*) b;
 556   if (pa == pb)
 557     return 0;
 558   return pa < pb ? -1 : 1;
 559 }
 560
 561 /*  Modify LST in place: qsort it.  */
 562 SCM
 563 ly_list_qsort_uniq_x (SCM lst)
 564 {
 565   int len = scm_ilength (lst);
 566   SCM *arr = new SCM[len];
 567   int k = 0;
 568   for (SCM s = lst; SCM_NNULLP (s); s = scm_cdr (s))
 569     arr[k++] = scm_car (s);
 570
 571   assert (k == len);
 572   qsort (arr, len, sizeof (SCM), &scm_default_compare);
 573
 574   SCM *tail = &lst;
 575   for (int i = 0; i < len; i++)
 576     if (!i || arr[i] != arr[i - 1])
 577       {
 578         SCM_SETCAR (*tail, arr[i]);
 579         tail = SCM_CDRLOC (*tail);
 580       }
 581
 582   *tail = SCM_EOL;
 583   delete[] arr;
 584
 585   return lst;
 586 }
 587
 588
 589 /* tail add */
 590 SCM
 591 ly_snoc (SCM s, SCM list)
 592 {
 593   return ly_append2 (list, scm_list_n (s, SCM_UNDEFINED));
 594 }
 595
 596 /* Split list at member s, removing s.
 597    Return (BEFORE . AFTER)  */
 598 SCM
 599 ly_split_list (SCM s, SCM list)
 600 {
 601   SCM before = SCM_EOL;
 602   SCM after = list;
 603   for (; scm_is_pair (after);)
 604     {
 605       SCM i = scm_car (after);
 606       after = scm_cdr (after);
 607       if (ly_c_equal_p (i, s))
 608         break;
 609       before = scm_cons (i, before);
 610     }
 611   return scm_cons ( scm_reverse_x (before, SCM_EOL),  after);
 612
 613 }
 614
 615
 616 void
 617 taint (SCM *)
 618 {
 619   /*
 620     nop.
 621    */
 622 }
 623
 624 /*
 625   display stuff without using stack
 626  */
 627 SCM
 628 display_list (SCM s)
 629 {
 630   SCM p = scm_current_output_port ();
 631
 632   scm_puts ("(", p);
 633   for (; scm_is_pair (s); s = scm_cdr (s))
 634     {
 635       scm_display (scm_car (s), p);
 636       scm_puts (" ", p);
 637     }
 638   scm_puts (")", p);
 639   return SCM_UNSPECIFIED;
 640 }
 641
 642 Slice
 643 int_list_to_slice (SCM l)
 644 {
 645   Slice s;
 646   s.set_empty ();
 647   for (; scm_is_pair (l); l = scm_cdr (l))
 648     if (scm_is_number (scm_car (l)))
 649       s.add_point (scm_to_int (scm_car (l)));
 650   return s;
 651 }
 652
 653 /* Return I-th element, or last elt L. If I < 0, then we take the first
 654    element.
 655
 656    PRE: length (L) > 0  */
 657 SCM
 658 robust_list_ref (int i, SCM l)
 659 {
 660   while (i-- > 0 && scm_is_pair (scm_cdr (l)))
 661     l = scm_cdr (l);
 662   return scm_car (l);
 663 }
 664
 665 Real
 666 robust_scm2double (SCM k, double x)
 667 {
 668   if (scm_is_number (k))
 669     x = scm_to_double (k);
 670   return x;
 671 }
 672
 673 Interval
 674 robust_scm2interval (SCM k, Drul_array<Real> v)
 675 {
 676   Interval i;
 677   i[LEFT]= v[LEFT];
 678   i[RIGHT]= v[RIGHT];
 679   if (is_number_pair (k))
 680     i = ly_scm2interval (k);
 681   return i;
 682 }
 683
 684 Drul_array<Real>
 685 robust_scm2drul (SCM k, Drul_array<Real> v)
 686 {
 687   if (is_number_pair (k))
 688     v = ly_scm2interval (k);
 689   return v;
 690 }
 691
 692 Offset
 693 robust_scm2offset (SCM k, Offset o)
 694 {
 695   if (is_number_pair (k))
 696     o = ly_scm2offset (k);
 697   return o;
 698 }
 699
 700 int
 701 robust_scm2int (SCM k, int o)
 702 {
 703   if (scm_integer_p (k) == SCM_BOOL_T)
 704     o = scm_to_int (k);
 705   return o;
 706 }
 707
 708 SCM
 709 alist_to_hashq (SCM alist)
 710 {
 711   int i = scm_ilength (alist);
 712   if (i < 0)
 713     return scm_c_make_hash_table (0);
 714
 715   SCM tab = scm_c_make_hash_table (i);
 716   for (SCM s = alist; scm_is_pair (s); s = scm_cdr (s))
 717     {
 718       SCM pt = scm_cdar (s);
 719       scm_hashq_set_x (tab, scm_caar (s), pt);
 720     }
 721   return tab;
 722 }
 723
 724
 725 bool
 726 alist_equal_p (SCM a, SCM b)
 727 {
 728   for (SCM s = a;
 729        scm_is_pair (s); s = scm_cdr (s))
 730     {
 731       SCM key = scm_caar (s);
 732       SCM val = scm_cdar (s);
 733       SCM l = scm_assoc (key, b);
 734
 735       if (l == SCM_BOOL_F
 736           || !ly_c_equal_p ( scm_cdr (l), val))
 737
 738         return false;
 739     }
 740   return true;
 741 }
 742
 743
 744
 745 SCM
 746 ly_alist_vals (SCM alist)
 747 {
 748   SCM x = SCM_EOL;
 749   for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p))
 750     {
 751       x = scm_cons (scm_cdar (p), x);
 752     }
 753   return x;
 754 }
 755
 756 SCM
 757 ly_hash2alist (SCM tab)
 758 {
 759   SCM func = ly_lily_module_constant ("hash-table->alist");
 760   return scm_call_1 (func, tab);
 761 }
 762
 763
 764