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       initialize_kpathsea ();
 208     }
 209 #endif
 210
 211   scm_primitive_load_path (scm_makfrom0str ("lily.scm"));
 212 }
 213
 214 SCM global_lily_module;
 215
 216 void
 217 ly_c_init_guile ()
 218 {
 219   global_lily_module = scm_c_define_module ("lily", ly_init_ly_module, 0);
 220   scm_c_use_module ("lily");
 221 }
 222
 223 unsigned int
 224 ly_scm_hash (SCM s)
 225 {
 226   return scm_ihashv (s, ~1u);
 227 }
 228
 229 bool
 230 is_direction (SCM s)
 231 {
 232   if (scm_is_number (s))
 233     {
 234       int i = scm_to_int (s);
 235       return i>= -1 && i <= 1;
 236     }
 237   return false;
 238 }
 239
 240 bool
 241 is_axis (SCM s)
 242 {
 243   if (scm_is_number (s))
 244     {
 245       int i = scm_to_int (s);
 246       return i == 0 || i == 1;
 247     }
 248   return false;
 249 }
 250
 251 Direction
 252 to_dir (SCM s)
 253 {
 254   return scm_is_integer (s) ? (Direction) scm_to_int (s) : CENTER;
 255 }
 256
 257 Interval
 258 ly_scm2interval (SCM p)
 259 {
 260   return Interval (scm_to_double (scm_car (p)), scm_to_double (scm_cdr (p)));
 261 }
 262
 263 Drul_array<Real>
 264 ly_scm2realdrul (SCM p)
 265 {
 266   return Drul_array<Real> (scm_to_double (scm_car (p)),
 267                            scm_to_double (scm_cdr (p)));
 268 }
 269
 270 SCM
 271 ly_interval2scm (Drul_array<Real> i)
 272 {
 273   return scm_cons (scm_make_real (i[LEFT]), scm_make_real (i[RIGHT]));
 274 }
 275
 276 bool
 277 to_boolean (SCM s)
 278 {
 279   return scm_is_bool (s) && ly_scm2bool (s);
 280 }
 281
 282 /* Appendable list L: the cdr contains the list, the car the last cons
 283    in the list.  */
 284 SCM
 285 appendable_list ()
 286 {
 287   SCM s = scm_cons (SCM_EOL, SCM_EOL);
 288   scm_set_car_x (s, s);
 289
 290   return s;
 291 }
 292
 293 void
 294 appendable_list_append (SCM l, SCM elt)
 295 {
 296   SCM newcons = scm_cons (elt, SCM_EOL);
 297
 298   scm_set_cdr_x (scm_car (l), newcons);
 299   scm_set_car_x (l, newcons);
 300 }
 301
 302 SCM
 303 ly_offset2scm (Offset o)
 304 {
 305   return scm_cons (scm_make_real (o[X_AXIS]), scm_make_real (o[Y_AXIS]));
 306 }
 307
 308 Offset
 309 ly_scm2offset (SCM s)
 310 {
 311   return Offset (scm_to_double (scm_car (s)),
 312                  scm_to_double (scm_cdr (s)));
 313 }
 314
 315 SCM
 316 ly_deep_copy (SCM src)
 317 {
 318   if (scm_is_pair (src))
 319     return scm_cons (ly_deep_copy (scm_car (src)), ly_deep_copy (scm_cdr (src)));
 320   else if (scm_is_vector (src))
 321     {
 322       int len = scm_c_vector_length (src);
 323       SCM nv = scm_c_make_vector (len, SCM_UNDEFINED);
 324       for (int i = 0 ;i < len ; i++)
 325         {
 326           SCM si = scm_int2num (i);
 327           scm_vector_set_x (nv, si, ly_deep_copy (scm_vector_ref (src, si)));
 328         }
 329     }
 330   return src;
 331 }
 332
 333 SCM
 334 ly_chain_assoc_get (SCM key, SCM achain, SCM dfault)
 335 {
 336   if (scm_is_pair (achain))
 337     {
 338       SCM handle = scm_assoc (key, scm_car (achain));
 339       if (scm_is_pair (handle))
 340         return scm_cdr (handle);
 341       else
 342         return ly_chain_assoc (key, scm_cdr (achain));
 343     }
 344   else
 345     return dfault;
 346 }
 347
 348 SCM
 349 ly_chain_assoc (SCM key, SCM achain)
 350 {
 351   if (scm_is_pair (achain))
 352     {
 353       SCM handle = scm_assoc (key, scm_car (achain));
 354       if (scm_is_pair (handle))
 355         return handle;
 356       else
 357         return ly_chain_assoc (key, scm_cdr (achain));
 358     }
 359   else
 360     return SCM_BOOL_F;
 361 }
 362
 363 /* looks the key up in the cdrs of the alist-keys
 364    - ignoring the car and ignoring non-pair keys.
 365    Returns first match found, i.e.
 366
 367    alist = ((1 . 10)
 368                    ((1 . 2) . 11)
 369                    ((2 . 1) . 12)
 370                    ((3 . 0) . 13)
 371                    ((4 . 1) . 14) )
 372
 373 I would like (ly_assoc_cdr 1) to return 12 - because it's the first
 374 element with the cdr of the key = 1.  In other words (alloc_cdr key)
 375 corresponds to call
 376
 377 (alloc (anything . key))
 378
 379
 380
 381 */
 382 SCM
 383 ly_assoc_cdr (SCM key, SCM alist)
 384 {
 385   if (scm_is_pair (alist))
 386     {
 387       SCM trykey = scm_caar (alist);
 388       if (scm_is_pair (trykey) && to_boolean (scm_equal_p (key, scm_cdr (trykey))))
 389         return scm_car (alist);
 390       else
 391         return ly_assoc_cdr (key, scm_cdr (alist));
 392     }
 393   return SCM_BOOL_F;
 394 }
 395
 396 /* LST has the form "sym1 sym2 sym3\nsym4\nsym5"
 397    i.e. \n and ' ' can be used interchangeably as separators.  */
 398 SCM
 399 parse_symbol_list (char const *lst)
 400 {
 401   char *s = strdup (lst);
 402   char *orig = s;
 403   SCM create_list = SCM_EOL;
 404
 405   char * e = s + strlen (s) - 1;
 406   while (e >= s && isspace (*e))
 407     *e-- = 0;
 408
 409   for (char * p = s; *p; p++)
 410     if (*p == '\n')
 411       *p = ' ';
 412
 413   if (!s[0])
 414     s = 0;
 415
 416   while (s)
 417     {
 418       char *next = strchr (s, ' ');
 419       if (next)
 420         *next++ = 0;
 421
 422       create_list = scm_cons (ly_symbol2scm (s), create_list);
 423       s = next;
 424     }
 425
 426   free (orig);
 427   return create_list;
 428 }
 429
 430 SCM
 431 ly_truncate_list (int k, SCM lst)
 432 {
 433   if (k == 0)
 434     lst = SCM_EOL;
 435   else
 436     {
 437       SCM s = lst;
 438       k--;
 439       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
 440         ;
 441
 442       if (scm_is_pair (s))
 443         scm_set_cdr_x (s, SCM_EOL);
 444     }
 445   return lst;
 446 }
 447
 448 String
 449 print_scm_val (SCM val)
 450 {
 451   String realval = ly_scm2string (ly_write2scm (val));
 452   if (realval.length () > 200)
 453     realval = realval.left_string (100)
 454       + "\n :\n :\n"
 455       + realval.right_string (100);
 456   return realval;
 457 }
 458
 459 bool
 460 type_check_assignment (SCM sym, SCM val,  SCM type_symbol)
 461 {
 462   bool ok = true;
 463
 464   /*
 465     Always succeeds.
 466
 467
 468     TODO: should remove #f from allowed vals?
 469    */
 470   if (val == SCM_EOL || val == SCM_BOOL_F)
 471     return ok;
 472
 473   if (!scm_is_symbol (sym))
 474 #if 0
 475     return false;
 476 #else
 477   /*
 478     This is used for autoBeamSettings.
 479
 480     TODO: deprecate the use of \override and \revert for
 481     autoBeamSettings?
 482
 483     or use a symbol autoBeamSettingS?
 484    */
 485   return true;
 486 #endif
 487
 488   SCM type = scm_object_property (sym, type_symbol);
 489
 490   if (type != SCM_EOL && !ly_c_procedure_p (type))
 491       {
 492         warning (_f ("Can't find property type-check for `%s' (%s).",
 493                      ly_symbol2string (sym).to_str0 (),
 494                      ly_symbol2string (type_symbol).to_str0 ())
 495                  + "  " + _ ("Perhaps you made a typing error?"));
 496
 497         /* Be strict when being anal :) */
 498         if (do_internal_type_checking_global)
 499           abort ();
 500
 501         warning (_ ("Doing assignment anyway."));
 502       }
 503   else
 504     {
 505       if (val != SCM_EOL
 506           && ly_c_procedure_p (type)
 507           && scm_call_1 (type, val) == SCM_BOOL_F)
 508         {
 509           SCM errport = scm_current_error_port ();
 510           ok = false;
 511           SCM typefunc = ly_lily_module_constant ("type-name");
 512           SCM type_name = scm_call_1 (typefunc, type);
 513
 514
 515           scm_puts (_f ("Type check for `%s' failed; value `%s' must be of type `%s'",
 516                         ly_symbol2string (sym).to_str0 (),
 517                         print_scm_val (val),
 518                         ly_scm2string (type_name).to_str0 ()).to_str0 (),
 519                     errport);
 520           scm_puts ("\n", errport);
 521         }
 522     }
 523   return ok;
 524 }
 525
 526
 527 /* some SCM abbrevs
 528
 529    zijn deze nou handig?
 530    zijn ze er al in scheme, maar heten ze anders? */
 531
 532
 533 /* Remove doubles from (sorted) list */
 534 SCM
 535 ly_unique (SCM list)
 536 {
 537   SCM unique = SCM_EOL;
 538   for (SCM i = list; scm_is_pair (i); i = scm_cdr (i))
 539     {
 540       if (!scm_is_pair (scm_cdr (i))
 541           || !ly_c_equal_p (scm_car (i), scm_cadr (i)))
 542         unique = scm_cons (scm_car (i), unique);
 543     }
 544   return scm_reverse_x (unique, SCM_EOL);
 545 }
 546
 547
 548 static int
 549 scm_default_compare (void const *a, void const *b)
 550 {
 551   SCM pa = *(SCM*) a;
 552   SCM pb = *(SCM*) b;
 553   if (pa == pb)
 554     return 0;
 555   return pa < pb ? -1 : 1;
 556 }
 557
 558 /*  Modify LST in place: qsort it.  */
 559 SCM
 560 ly_list_qsort_uniq_x (SCM lst)
 561 {
 562   int len = scm_ilength (lst);
 563   SCM *arr = new SCM[len];
 564   int k = 0;
 565   for (SCM s = lst; SCM_NNULLP (s); s = scm_cdr (s))
 566     arr[k++] = scm_car (s);
 567
 568   assert (k == len);
 569   qsort (arr, len, sizeof (SCM), &scm_default_compare);
 570
 571   SCM *tail = &lst;
 572   for (int i = 0; i < len; i++)
 573     if (!i || arr[i] != arr[i - 1])
 574       {
 575         SCM_SETCAR (*tail, arr[i]);
 576         tail = SCM_CDRLOC (*tail);
 577       }
 578
 579   *tail = SCM_EOL;
 580   delete[] arr;
 581
 582   return lst;
 583 }
 584
 585
 586 /* tail add */
 587 SCM
 588 ly_snoc (SCM s, SCM list)
 589 {
 590   return ly_append2 (list, scm_list_n (s, SCM_UNDEFINED));
 591 }
 592
 593 /* Split list at member s, removing s.
 594    Return (BEFORE . AFTER)  */
 595 SCM
 596 ly_split_list (SCM s, SCM list)
 597 {
 598   SCM before = SCM_EOL;
 599   SCM after = list;
 600   for (; scm_is_pair (after);)
 601     {
 602       SCM i = scm_car (after);
 603       after = scm_cdr (after);
 604       if (ly_c_equal_p (i, s))
 605         break;
 606       before = scm_cons (i, before);
 607     }
 608   return scm_cons ( scm_reverse_x (before, SCM_EOL),  after);
 609
 610 }
 611
 612
 613 void
 614 taint (SCM *)
 615 {
 616   /*
 617     nop.
 618    */
 619 }
 620
 621 /*
 622   display stuff without using stack
 623  */
 624 SCM
 625 display_list (SCM s)
 626 {
 627   SCM p = scm_current_output_port ();
 628
 629   scm_puts ("(", p);
 630   for (; scm_is_pair (s); s = scm_cdr (s))
 631     {
 632       scm_display (scm_car (s), p);
 633       scm_puts (" ", p);
 634     }
 635   scm_puts (")", p);
 636   return SCM_UNSPECIFIED;
 637 }
 638
 639 Slice
 640 int_list_to_slice (SCM l)
 641 {
 642   Slice s;
 643   s.set_empty ();
 644   for (; scm_is_pair (l); l = scm_cdr (l))
 645     if (scm_is_number (scm_car (l)))
 646       s.add_point (scm_to_int (scm_car (l)));
 647   return s;
 648 }
 649
 650 /* Return I-th element, or last elt L. If I < 0, then we take the first
 651    element.
 652
 653    PRE: length (L) > 0  */
 654 SCM
 655 robust_list_ref (int i, SCM l)
 656 {
 657   while (i-- > 0 && scm_is_pair (scm_cdr (l)))
 658     l = scm_cdr (l);
 659   return scm_car (l);
 660 }
 661
 662 Real
 663 robust_scm2double (SCM k, double x)
 664 {
 665   if (scm_is_number (k))
 666     x = scm_to_double (k);
 667   return x;
 668 }
 669
 670 Interval
 671 robust_scm2interval (SCM k, Drul_array<Real> v)
 672 {
 673   Interval i;
 674   i[LEFT]= v[LEFT];
 675   i[RIGHT]= v[RIGHT];
 676   if (is_number_pair (k))
 677     i = ly_scm2interval (k);
 678   return i;
 679 }
 680
 681 Drul_array<Real>
 682 robust_scm2drul (SCM k, Drul_array<Real> v)
 683 {
 684   if (is_number_pair (k))
 685     v = ly_scm2interval (k);
 686   return v;
 687 }
 688
 689 Offset
 690 robust_scm2offset (SCM k, Offset o)
 691 {
 692   if (is_number_pair (k))
 693     o = ly_scm2offset (k);
 694   return o;
 695 }
 696
 697 int
 698 robust_scm2int (SCM k, int o)
 699 {
 700   if (scm_integer_p (k) == SCM_BOOL_T)
 701     o = scm_to_int (k);
 702   return o;
 703 }
 704
 705 SCM
 706 alist_to_hashq (SCM alist)
 707 {
 708   int i = scm_ilength (alist);
 709   if (i < 0)
 710     return scm_c_make_hash_table (0);
 711
 712   SCM tab = scm_c_make_hash_table (i);
 713   for (SCM s = alist; scm_is_pair (s); s = scm_cdr (s))
 714     {
 715       SCM pt = scm_cdar (s);
 716       scm_hashq_set_x (tab, scm_caar (s), pt);
 717     }
 718   return tab;
 719 }
 720
 721
 722 bool
 723 alist_equal_p (SCM a, SCM b)
 724 {
 725   for (SCM s = a;
 726        scm_is_pair (s); s = scm_cdr (s))
 727     {
 728       SCM key = scm_caar (s);
 729       SCM val = scm_cdar (s);
 730       SCM l = scm_assoc (key, b);
 731
 732       if (l == SCM_BOOL_F
 733           || !ly_c_equal_p ( scm_cdr (l), val))
 734
 735         return false;
 736     }
 737   return true;
 738 }
 739
 740
 741
 742 SCM
 743 ly_alist_vals (SCM alist)
 744 {
 745   SCM x = SCM_EOL;
 746   for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p))
 747     {
 748       x = scm_cons (scm_cdar (p), x);
 749     }
 750   return x;
 751 }
 752
 753 SCM
 754 ly_hash2alist (SCM tab)
 755 {
 756   SCM func = ly_lily_module_constant ("hash-table->alist");
 757   return scm_call_1 (func, tab);
 758 }
 759
 760
 761