lily/lily-guile.cc

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