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--2002 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 "libc-extension.hh"
  17 #include "lily-guile.hh"
  18 #include "main.hh"
  19 #include "file-path.hh"
  20 #include "warn.hh"
  21 #include "direction.hh"
  22 #include "offset.hh"
  23 #include "interval.hh"
  24 #include "pitch.hh"
  25 #include "dimensions.hh"
  26 #include "source-file.hh"
  27
  28 // #define TEST_GC
  29
  30 #ifdef PARANOID
  31 #include <libguile/gc.h>
  32 #undef gh_pair_p
  33 bool
  34 ly_pair_p (SCM x)
  35 {
  36 #if 0
  37   assert (!SCM_CONSP (x) || (*(scm_t_bits*) SCM2PTR (SCM_CAR (x))) != scm_tc_free_cell);
  38   assert (!SCM_CONSP (x) || (*(scm_t_bits*) SCM2PTR (SCM_CDR (x))) != scm_tc_free_cell);
  39 #elif GUILE_MINOR_VERSION < 5
  40   assert (!SCM_CONSP (x) || !SCM_FREEP (SCM_CAR (x)));
  41   assert (!SCM_CONSP (x) || !SCM_FREEP (SCM_CDR (x)));
  42 #else
  43   assert (!SCM_CONSP (x) || !SCM_FREE_CELL_P (SCM_CAR (x)));
  44   assert (!SCM_CONSP (x) || !SCM_FREE_CELL_P (SCM_CDR (x)));
  45 #endif
  46   //return SCM_NFALSEP (scm_pair_p (x));
  47   return gh_pair_p (x);
  48 }
  49 #define gh_pair_p ly_pair_p
  50 #endif
  51
  52 SCM
  53 ly_last (SCM list)
  54 {
  55   return ly_car (scm_last_pair (list));
  56 }
  57
  58
  59 SCM
  60 ly_write2scm (SCM s)
  61 {
  62   SCM port = scm_mkstrport (SCM_INUM0,
  63                             scm_make_string (SCM_INUM0, SCM_UNDEFINED),
  64                             SCM_OPN | SCM_WRTNG,
  65                             "ly_write2string");
  66   //  SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
  67   SCM write = scm_primitive_eval (ly_symbol2scm ("write"));
  68
  69   // scm_apply (write, port, SCM_EOL);
  70   gh_call2 (write, s, port);
  71   return scm_strport_to_string (port);
  72 }
  73
  74
  75 SCM
  76 ly_quote_scm (SCM s)
  77 {
  78   return scm_list_n (ly_symbol2scm ("quote"), s, SCM_UNDEFINED);
  79 }
  80
  81
  82
  83 String
  84 ly_symbol2string (SCM s)
  85 {
  86   assert (gh_symbol_p (s));
  87   return String ((Byte*)SCM_STRING_CHARS (s), (int) SCM_STRING_LENGTH (s));
  88 }
  89
  90
  91 String
  92 gulp_file_to_string (String fn)
  93 {
  94   String s = global_path.find (fn);
  95   if (s == "")
  96     {
  97       String e = _f ("can't find file: `%s'", fn);
  98       e += " ";
  99       e += _f ("(load path: `%s')", global_path.string ());
 100       error (e);
 101     }
 102   else if (verbose_global_b)
 103     progress_indication ("[" + s);
 104
 105
 106   int n;
 107   char * str = gulp_file (s, &n);
 108   String result (str);
 109   delete str;
 110
 111   if (verbose_global_b)
 112     progress_indication ("]");
 113
 114   return result;
 115 }
 116
 117 LY_DEFINE(ly_gulp_file, "ly-gulp-file", 1,0, 0,
 118           (SCM name),
 119           "Read the file named @var{name}, and return its contents in a string. The
 120 file is looked up using the lilypond search path.
 121
 122 ")
 123 {
 124   return scm_makfrom0str (gulp_file_to_string (ly_scm2string (name)).to_str0 ());
 125 }
 126
 127
 128 extern "C" {
 129   // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
 130 void
 131 ly_display_scm (SCM s)
 132 {
 133   gh_display (s);
 134   gh_newline ();
 135 }
 136 };
 137
 138 String
 139 ly_scm2string (SCM s)
 140 {
 141   assert (gh_string_p (s));
 142
 143   char *p = SCM_STRING_CHARS(s);
 144   String r (p);
 145   return r;
 146 }
 147
 148 SCM
 149 index_get_cell (SCM s, Direction d)
 150 {
 151
 152   assert (d);
 153   return (d == LEFT) ? ly_car (s) : ly_cdr (s);
 154 }
 155
 156 SCM
 157 index_set_cell (SCM s, Direction d, SCM v)
 158 {
 159   if (d == LEFT)
 160     gh_set_car_x (s, v);
 161   else if (d == RIGHT)
 162     gh_set_cdr_x (s, v);
 163   return s;
 164 }
 165
 166 LY_DEFINE(ly_warning,"ly-warn", 1, 0, 0,
 167   (SCM str),"Scheme callable function to issue the warning @code{msg}.")
 168 {
 169   SCM_ASSERT_TYPE (gh_string_p (str), str, SCM_ARG1, __FUNCTION__, "string");
 170   warning ("lily-guile: " + ly_scm2string (str));
 171   return SCM_BOOL_T;
 172 }
 173
 174 LY_DEFINE(ly_isdir,  "dir?", 1,0, 0,  (SCM s),
 175           "type predicate. A direction is a -1, 0 or 1, where -1 represents left or
 176 down and 1 represents right or up.
 177 ")
 178 {
 179   if (gh_number_p (s))
 180     {
 181       int i = gh_scm2int (s);
 182       return (i>= -1 && i <= 1)  ? SCM_BOOL_T : SCM_BOOL_F;
 183     }
 184   return SCM_BOOL_F;
 185 }
 186
 187 bool
 188 ly_number_pair_p (SCM p)
 189 {
 190   return gh_pair_p (p) && gh_number_p (ly_car (p)) && gh_number_p (ly_cdr (p));
 191 }
 192
 193 typedef void (*Void_fptr) ();
 194 Array<Void_fptr> *scm_init_funcs_;
 195
 196 void add_scm_init_func (void (*f) ())
 197 {
 198   if (!scm_init_funcs_)
 199     scm_init_funcs_ = new Array<Void_fptr>;
 200
 201   scm_init_funcs_->push (f);
 202 }
 203
 204 extern void init_cxx_function_smobs ();
 205
 206
 207 void
 208 ly_init_guile ()
 209 {
 210   SCM last_mod = scm_current_module ();
 211   scm_set_current_module (scm_c_resolve_module ("guile"));
 212
 213   init_cxx_function_smobs ();
 214   for (int i=scm_init_funcs_->size () ; i--;)
 215     (scm_init_funcs_->elem (i)) ();
 216
 217   if (verbose_global_b)
 218     progress_indication ("\n");
 219
 220
 221   scm_primitive_load_path (scm_makfrom0str ("lily.scm"));
 222
 223   scm_set_current_module (last_mod);
 224 }
 225
 226 unsigned int ly_scm_hash (SCM s)
 227 {
 228   return scm_ihashv (s, ~1u);
 229 }
 230
 231
 232
 233 bool
 234 ly_dir_p (SCM s)
 235 {
 236   if (gh_number_p (s))
 237     {
 238       int i = gh_scm2int (s);
 239       return i>= -1 && i <= 1;
 240     }
 241   return false;
 242 }
 243
 244
 245 bool
 246 ly_axis_p (SCM s)
 247 {
 248   if (gh_number_p (s))
 249     {
 250       int i = gh_scm2int (s);
 251       return i== 0 || i == 1;
 252     }
 253   return false;
 254 }
 255
 256
 257 Direction
 258 to_dir (SCM s)
 259 {
 260   return SCM_INUMP (s) ?  (Direction) gh_scm2int (s) : CENTER;
 261 }
 262
 263 Interval
 264 ly_scm2interval (SCM p)
 265 {
 266   return  Interval (gh_scm2double (ly_car (p)),
 267                     gh_scm2double (ly_cdr (p)));
 268 }
 269
 270 SCM
 271 ly_interval2scm (Drul_array<Real> i)
 272 {
 273   return gh_cons (gh_double2scm (i[LEFT]),
 274                   gh_double2scm (i[RIGHT]));
 275 }
 276
 277
 278
 279
 280 bool
 281 to_boolean (SCM s)
 282 {
 283   return gh_boolean_p (s) && gh_scm2bool (s);
 284 }
 285
 286 /*
 287   Appendable list L: the cdr contains the list, the car the last cons
 288   in the list.
 289  */
 290 SCM
 291 appendable_list ()
 292 {
 293   SCM s = gh_cons (SCM_EOL, SCM_EOL);
 294   gh_set_car_x (s, s);
 295
 296   return s;
 297 }
 298
 299 void
 300 appendable_list_append (SCM l, SCM elt)
 301 {
 302   SCM newcons = gh_cons (elt, SCM_EOL);
 303
 304   gh_set_cdr_x (ly_car (l), newcons);
 305   gh_set_car_x (l, newcons);
 306 }
 307
 308
 309 SCM
 310 ly_offset2scm (Offset o)
 311 {
 312   return gh_cons (gh_double2scm (o[X_AXIS]), gh_double2scm (o[Y_AXIS]));
 313 }
 314
 315 Offset
 316 ly_scm2offset (SCM s)
 317 {
 318   return Offset (gh_scm2double (ly_car (s)),
 319                  gh_scm2double (ly_cdr (s)));
 320 }
 321
 322
 323 /*
 324   convert without too many decimals, and leave  a space at the end.
 325  */
 326
 327
 328 LY_DEFINE(ly_number2string,  "ly-number->string", 1, 0,0,
 329           (SCM s),
 330           " converts @var{num} to a string without generating many decimals. It
 331 leaves a space at the end.
 332 ")
 333 {
 334   SCM_ASSERT_TYPE (gh_number_p (s), s, SCM_ARG1, __FUNCTION__, "number");
 335
 336   char str[400];                        // ugh.
 337
 338   if (scm_exact_p (s) == SCM_BOOL_F)
 339     {
 340       Real r (gh_scm2double (s));
 341
 342       if (isinf (r) || isnan (r))
 343         {
 344           programming_error ("Infinity or NaN encountered while converting Real number; setting to zero.");
 345           r = 0.0;
 346         }
 347
 348       sprintf (str, "%8.4f ", r);
 349     }
 350   else
 351     {
 352       sprintf (str, "%d ", gh_scm2int (s));
 353     }
 354
 355   return scm_makfrom0str (str);
 356 }
 357
 358 /*
 359   Undef this to see if GUILE GC is causing too many swaps.
 360  */
 361
 362 // #define TEST_GC
 363
 364 #ifdef TEST_GC
 365 #include <libguile/gc.h>
 366
 367 static void *
 368 greet_sweep (void *dummy1, void *dummy2, void *dummy3)
 369 {
 370    fprintf (stderr, "entering sweep\n");
 371 }
 372
 373 static void *
 374 wave_sweep_goodbye (void *dummy1, void *dummy2, void *dummy3)
 375 {
 376    fprintf (stderr, "leaving sweep\n");
 377 }
 378 #endif
 379
 380
 381 #include "version.hh"
 382 LY_DEFINE(ly_version,  "ly-version", 0, 0, 0, (),
 383           "Return the current lilypond version as a list, e.g.
 384 @code{(1 3 127 uu1)}.
 385 ")
 386 {
 387   char const* vs =  "\' (" MAJOR_VERSION " " MINOR_VERSION " "  PATCH_LEVEL " " MY_PATCH_LEVEL ")" ;
 388
 389   return gh_eval_str ((char*)vs);
 390 }
 391
 392 LY_DEFINE(ly_unit,  "ly-unit", 0, 0, 0, (),
 393           "Return the unit used for lengths as a string.")
 394 {
 395   return scm_makfrom0str (INTERNAL_UNIT);
 396 }
 397
 398 LY_DEFINE(ly_verbose,  "ly-verbose", 0, 0, 0, (),
 399   "Return whether lilypond is being run in verbose mode.")
 400 {
 401   return gh_bool2scm (verbose_global_b);
 402 }
 403
 404 static void
 405 init_functions ()
 406 {
 407 #ifdef TEST_GC
 408   scm_c_hook_add (&scm_before_mark_c_hook, greet_sweep, 0, 0);
 409   scm_c_hook_add (&scm_before_sweep_c_hook, wave_sweep_goodbye, 0, 0);
 410 #endif
 411 }
 412
 413 ADD_SCM_INIT_FUNC (funcs, init_functions);
 414
 415 SCM
 416 ly_deep_copy (SCM src)
 417 {
 418   if (gh_pair_p (src))
 419     {
 420       return gh_cons (ly_deep_copy (ly_car (src)), ly_deep_copy (ly_cdr (src)));
 421     }
 422   else if (gh_vector_p (src))
 423     {
 424       int  l = SCM_VECTOR_LENGTH (src);
 425       SCM nv = scm_c_make_vector (l, SCM_UNDEFINED);
 426       for (int i  =0 ; i< l ; i++)
 427         {
 428           SCM si = gh_int2scm (i);
 429           scm_vector_set_x (nv, si, ly_deep_copy (scm_vector_ref (src, si)));
 430         }
 431     }
 432   else
 433     return src;
 434
 435   return src;
 436 }
 437
 438
 439
 440
 441 SCM
 442 ly_assoc_chain (SCM key, SCM achain)
 443 {
 444   if (gh_pair_p (achain))
 445     {
 446       SCM handle = scm_assoc (key, ly_car (achain));
 447       if (gh_pair_p (handle))
 448         return handle;
 449       else
 450         return ly_assoc_chain (key, ly_cdr (achain));
 451     }
 452   else
 453     return SCM_BOOL_F;
 454 }
 455
 456 /* looks the key up in the cdrs of the alist-keys
 457    - ignoring the car and ignoring non-pair keys.
 458    Returns first match found, i.e.
 459
 460    alist = ((1 . 10)
 461                    ((1 . 2) . 11)
 462                    ((2 . 1) . 12)
 463                    ((3 . 0) . 13)
 464                    ((4 . 1) . 14) )
 465
 466 I would like (ly_assoc_cdr 1) to return 12 - because it's the first
 467 element with the cdr of the key = 1.  In other words (alloc_cdr key)
 468 corresponds to call
 469
 470 (alloc (anything . key))
 471
 472
 473
 474 */
 475 SCM
 476 ly_assoc_cdr (SCM key, SCM alist)
 477 {
 478   if (gh_pair_p (alist)) {
 479     SCM trykey = ly_caar(alist);
 480     if(gh_pair_p(trykey) && to_boolean(scm_equal_p(key,ly_cdr(trykey))))
 481       return ly_car(alist);
 482     else
 483       return ly_assoc_cdr (key, ly_cdr (alist));
 484   }
 485   else
 486     return SCM_BOOL_F;
 487 }
 488
 489 /*
 490   LIST has the form "sym1 sym2 sym3\nsym4\nsym5"
 491
 492   i.e. \n and ' ' can be used interchangeably as separators.
 493  */
 494 SCM
 495 parse_symbol_list (const char * list)
 496 {
 497   char * s = strdup (list);
 498   char *orig = s;
 499   SCM create_list = SCM_EOL;
 500
 501   for (char * p = s; *p; p++)
 502     {
 503       if (*p == '\n')
 504         *p = ' ' ;
 505     }
 506
 507   if (!s[0] )
 508     s = 0;
 509
 510
 511
 512   while (s)
 513     {
 514       char *next = strchr (s, ' ');
 515       if (next)
 516         *next++ = 0;
 517
 518       create_list = gh_cons (ly_symbol2scm (s), create_list);
 519       s = next;
 520     }
 521
 522   free (orig);
 523   return create_list;
 524 }
 525
 526
 527 SCM
 528 ly_truncate_list (int k, SCM l )
 529 {
 530   if (k == 0)
 531     {
 532       l = SCM_EOL;
 533     }
 534   else
 535     {
 536       SCM s = l;
 537       k--;
 538       for (; gh_pair_p (s) && k--; s = ly_cdr (s))
 539         ;
 540
 541       if (gh_pair_p (s))
 542         {
 543           gh_set_cdr_x (s, SCM_EOL);
 544         }
 545     }
 546   return l;
 547 }
 548
 549
 550 String
 551 print_scm_val (SCM val)
 552 {
 553   String realval = ly_scm2string (ly_write2scm (val));
 554   if (realval.length () > 200)
 555     realval = realval.left_string (100) + "\n :\n :\n" + realval.right_string (100);
 556
 557   return realval;
 558 }
 559
 560 bool
 561 type_check_assignment (SCM sym, SCM val,  SCM type_symbol)
 562 {
 563   bool ok = true;
 564
 565   /*
 566     Always succeeds.
 567
 568
 569     TODO: should remove #f from allowed vals?
 570    */
 571   if (val == SCM_EOL || val == SCM_BOOL_F)
 572     return ok;
 573
 574
 575   SCM type = SCM_EOL;
 576
 577   if (gh_symbol_p (sym))
 578     type = scm_object_property (sym, type_symbol);
 579
 580   if (type != SCM_EOL && !gh_procedure_p (type))
 581       {
 582         warning (_f ("Can't find property type-check for `%s' (%s).",
 583                      ly_symbol2string (sym).to_str0 (),
 584                      ly_symbol2string (type_symbol).to_str0 ())
 585                  + "  " + _ ("Perhaps you made a typing error?"));
 586
 587         /* Be strict when being anal :) */
 588         if (internal_type_checking_global_b)
 589           abort ();
 590
 591         warning (_ ("Doing assignment anyway."));
 592       }
 593   else
 594     {
 595       if (val != SCM_EOL
 596           && gh_procedure_p (type)
 597           && gh_call1 (type, val) == SCM_BOOL_F)
 598         {
 599           SCM errport = scm_current_error_port ();
 600           ok = false;
 601           SCM typefunc = scm_primitive_eval (ly_symbol2scm ("type-name"));
 602           SCM type_name = gh_call1 (typefunc, type);
 603
 604
 605           scm_puts (_f ("Type check for `%s' failed; value `%s' must be of type `%s'",
 606                         ly_symbol2string (sym).to_str0 (),
 607                         print_scm_val (val),
 608                         ly_scm2string (type_name).to_str0 ()).to_str0 (),
 609                     errport);
 610           scm_puts ("\n", errport);
 611         }
 612     }
 613   return ok;
 614 }
 615
 616
 617 /* some SCM abbrevs
 618
 619    zijn deze nou handig?
 620    zijn ze er al in scheme, maar heten ze anders? */
 621
 622
 623 /* Remove doubles from (sorted) list */
 624 SCM
 625 ly_unique (SCM list)
 626 {
 627   SCM unique = SCM_EOL;
 628   for (SCM i = list; gh_pair_p (i); i = ly_cdr (i))
 629     {
 630       if (!gh_pair_p (ly_cdr (i))
 631           || !gh_equal_p (ly_car (i), ly_cadr (i)))
 632         unique = gh_cons (ly_car (i), unique);
 633     }
 634   return scm_reverse_x (unique, SCM_EOL);
 635 }
 636
 637 /* tail add */
 638 SCM
 639 ly_snoc (SCM s, SCM list)
 640 {
 641   return gh_append2 (list, scm_list_n (s, SCM_UNDEFINED));
 642 }
 643
 644
 645 /* Split list at member s, removing s.
 646    Return (BEFORE . AFTER) */
 647 SCM
 648 ly_split_list (SCM s, SCM list)
 649 {
 650   SCM before = SCM_EOL;
 651   SCM after = list;
 652   for (; gh_pair_p (after);)
 653     {
 654       SCM i = ly_car (after);
 655       after = ly_cdr (after);
 656       if (gh_equal_p (i, s))
 657         break;
 658       before = gh_cons (i, before);
 659     }
 660   return gh_cons ( scm_reverse_x (before, SCM_EOL),  after);
 661
 662 }
 663
 664
 665 void
 666 taint (SCM *)
 667 {
 668   /*
 669     nop.
 670    */
 671 }
 672
 673 /*
 674   display stuff without using stack
 675  */
 676 SCM
 677 display_list (SCM s)
 678 {
 679   SCM p = scm_current_output_port();
 680
 681   scm_puts ("(", p);
 682   for (; gh_pair_p(s); s =gh_cdr(s))
 683     {
 684       scm_display (gh_car(s), p);
 685       scm_puts (" ", p);
 686     }
 687   scm_puts (")", p);
 688   return SCM_UNSPECIFIED;
 689 }
 690
 691 Slice
 692 int_list_to_slice (SCM l)
 693 {
 694   Slice s;
 695   s.set_empty ();
 696   for (; gh_pair_p (l); l = gh_cdr (l))
 697     {
 698       if (gh_number_p (gh_car (l)))
 699         s.add_point (gh_scm2int (gh_car (l)));
 700     }
 701
 702   return s;
 703 }
 704
 705
 706
 707
 708 /*
 709   Return I-th element, or last elt L. If I < 0, then we take the first
 710   element.
 711
 712   PRE: length (L) > 0
 713  */
 714 SCM
 715 robust_list_ref(int i, SCM l)
 716 {
 717   while (i-- > 0 && gh_pair_p (gh_cdr(l)))
 718     l = gh_cdr (l);
 719
 720   return gh_car(l);
 721 }