]> git.donarmstrong.com Git - lilypond.git/blob - lily/lily-guile.cc
Patch for auto-beam; Fix issue 511
[lilypond.git] / 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--2007 Jan Nieuwenhuizen <janneke@gnu.org>
7   Han-Wen Nienhuys <hanwen@xs4all.nl>
8 */
9
10 #include "lily-guile.hh"
11
12 #include <cstdio>
13 #include <cstdlib>
14 #include <cstring> /* strdup, strchr */
15 #include <cctype>
16
17 using namespace std;
18
19 #include "dimensions.hh"
20 #include "direction.hh"
21 #include "file-path.hh"
22 #include "international.hh"
23 #include "libc-extension.hh"
24 #include "main.hh"
25 #include "misc.hh"
26 #include "offset.hh"
27 #include "pitch.hh"
28 #include "string-convert.hh"
29 #include "source-file.hh"
30 #include "version.hh"
31 #include "warn.hh"
32
33
34 /*
35   symbols/strings.
36  */
37 string
38 ly_scm_write_string (SCM s)
39 {
40   SCM port = scm_mkstrport (SCM_INUM0,
41                             scm_make_string (SCM_INUM0, SCM_UNDEFINED),
42                             SCM_OPN | SCM_WRTNG,
43                             "ly_write2string");
44   //  SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
45   SCM write = scm_primitive_eval (ly_symbol2scm ("write"));
46
47   // scm_apply (write, port, SCM_EOL);
48   scm_call_2 (write, s, port);
49   return ly_scm2string (scm_strport_to_string (port));
50 }
51
52 SCM
53 ly_quote_scm (SCM s)
54 {
55   return scm_list_n (ly_symbol2scm ("quote"), s, SCM_UNDEFINED);
56 }
57
58 string
59 ly_symbol2string (SCM s)
60 {
61   /*
62     Ugh. this is not very efficient.
63   */
64   SCM str = scm_symbol_to_string (s);
65   return ly_scm2string (str);
66 }
67
68 string
69 gulp_file_to_string (string fn, bool must_exist, int size)
70 {
71   string s = global_path.find (fn);
72   if (s == "")
73     {
74       if (must_exist)
75         {
76           string e = _f ("cannot find file: `%s'", fn);
77           e += " ";
78           e += _f ("(load path: `%s')", global_path.to_string ());
79           error (e);
80           /* unreachable */
81         }
82       return s;
83     }
84
85   if (be_verbose_global)
86     progress_indication ("[" + s);
87
88   vector<char> chars = gulp_file (s, size);
89   string result (&chars[0], chars.size ());
90
91   if (be_verbose_global)
92     progress_indication ("]");
93
94   return result;
95 }
96
97 extern "C" {
98   // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
99   void
100   ly_display_scm (SCM s)
101   {
102     scm_display (s, scm_current_output_port ());
103     scm_newline (scm_current_output_port ());
104   }
105 };
106
107 /*
108   STRINGS
109  */
110 string
111 ly_scm2string (SCM str)
112 {
113   assert (scm_is_string (str));
114   string result;
115   size_t len = scm_c_string_length (str);
116   if (len) {
117     result.resize(len);
118     scm_to_locale_stringbuf(str, &result.at(0), len);
119   }
120   return result;
121 }
122
123 SCM
124 ly_string2scm (string const &str)
125 {
126   return scm_from_locale_stringn (str.c_str (),
127                                   str.length ());
128 }
129
130
131 char *
132 ly_scm2newstr (SCM str, size_t *lenp)
133 {
134   char* p = scm_to_locale_stringn(str, lenp);
135   return p;
136 }
137
138 /*
139   PAIRS
140 */
141 SCM 
142 index_get_cell (SCM s, Direction d)
143 {
144   assert (d);
145   return (d == LEFT) ? scm_car (s) : scm_cdr (s);
146 }
147
148 SCM
149 index_set_cell (SCM s, Direction d, SCM v)
150 {
151   if (d == LEFT)
152     scm_set_car_x (s, v);
153   else if (d == RIGHT)
154     scm_set_cdr_x (s, v);
155   return s;
156 }
157
158 bool
159 is_number_pair (SCM p)
160 {
161   return scm_is_pair (p)
162     && scm_is_number (scm_car (p)) && scm_is_number (scm_cdr (p));
163 }
164
165
166 unsigned int
167 ly_scm_hash (SCM s)
168 {
169   return scm_ihashv (s, ~1u);
170 }
171
172 bool
173 is_axis (SCM s)
174 {
175   if (scm_is_number (s))
176     {
177       int i = scm_to_int (s);
178       return i == 0 || i == 1;
179     }
180   return false;
181 }
182
183 bool
184 to_boolean (SCM s)
185 {
186   return scm_is_bool (s) && ly_scm2bool (s);
187 }
188
189 /*
190   DIRECTIONS
191  */
192 Direction
193 to_dir (SCM s)
194 {
195   return scm_is_integer (s) ? (Direction) scm_to_int (s) : CENTER;
196 }
197
198 Direction
199 robust_scm2dir (SCM d, Direction def)
200 {
201   if (is_direction (d))
202     def = to_dir (d);
203   return def;
204 }
205
206 bool
207 is_direction (SCM s)
208 {
209   if (scm_is_number (s))
210     {
211       int i = scm_to_int (s);
212       return i >= -1 && i <= 1;
213     }
214   return false;
215 }
216
217 /*
218   INTERVALS
219  */
220 Interval
221 ly_scm2interval (SCM p)
222 {
223   return Interval (scm_to_double (scm_car (p)), scm_to_double (scm_cdr (p)));
224 }
225
226 Drul_array<Real>
227 ly_scm2realdrul (SCM p)
228 {
229   return Drul_array<Real> (scm_to_double (scm_car (p)),
230                            scm_to_double (scm_cdr (p)));
231 }
232
233 SCM
234 ly_interval2scm (Drul_array<Real> i)
235 {
236   return scm_cons (scm_from_double (i[LEFT]), scm_from_double (i[RIGHT]));
237 }
238
239
240 Interval
241 robust_scm2interval (SCM k, Drul_array<Real> v)
242 {
243   Interval i;
244   i[LEFT] = v[LEFT];
245   i[RIGHT] = v[RIGHT];
246   if (is_number_pair (k))
247     i = ly_scm2interval (k);
248   return i;
249 }
250
251 Drul_array<Real>
252 robust_scm2drul (SCM k, Drul_array<Real> v)
253 {
254   if (is_number_pair (k))
255     v = ly_scm2interval (k);
256   return v;
257 }
258
259 Drul_array<bool>
260 robust_scm2booldrul (SCM k, Drul_array<bool> def)
261 {
262   if (scm_is_pair (k))
263     {
264       def[LEFT] = to_boolean (scm_car (k));
265       def[RIGHT] = to_boolean (scm_cdr (k));
266     }
267   return def;
268 }
269
270 /*
271   OFFSET
272 */
273 SCM
274 ly_offset2scm (Offset o)
275 {
276   return scm_cons (scm_from_double (o[X_AXIS]), scm_from_double (o[Y_AXIS]));
277 }
278
279 Offset
280 ly_scm2offset (SCM s)
281 {
282   return Offset (scm_to_double (scm_car (s)),
283                  scm_to_double (scm_cdr (s)));
284 }
285
286 Offset
287 robust_scm2offset (SCM k, Offset o)
288 {
289   if (is_number_pair (k))
290     o = ly_scm2offset (k);
291   return o;
292 }
293 SCM
294 ly_offsets2scm (vector<Offset> os)
295 {
296   SCM l = SCM_EOL;
297   SCM *tail = &l;
298   for (vsize i = 0; i < os.size (); i++)
299     {
300       *tail = scm_cons (ly_offset2scm (os[i]), SCM_EOL);
301       tail = SCM_CDRLOC (*tail);
302     }
303   return l;
304 }
305
306 vector<Offset>
307 ly_scm2offsets (SCM s)
308 {
309   vector<Offset> os;
310   for (; scm_is_pair (s); s = scm_cdr (s))
311     os.push_back (ly_scm2offset (scm_car (s)));
312   return os;
313 }
314
315
316
317
318 /*
319   ALIST
320 */
321
322 bool
323 alist_equal_p (SCM a, SCM b)
324 {
325   for (SCM s = a;
326        scm_is_pair (s); s = scm_cdr (s))
327     {
328       SCM key = scm_caar (s);
329       SCM val = scm_cdar (s);
330       SCM l = scm_assoc (key, b);
331
332       if (l == SCM_BOOL_F
333           || !ly_is_equal (scm_cdr (l), val))
334
335         return false;
336     }
337   return true;
338 }
339
340 SCM
341 ly_alist_vals (SCM alist)
342 {
343   SCM x = SCM_EOL;
344   for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p))
345     x = scm_cons (scm_cdar (p), x);
346   return x;
347 }
348
349 /*
350   LISTS
351  */
352
353 /* Return I-th element, or last elt L. If I < 0, then we take the first
354    element.
355
356    PRE: length (L) > 0  */
357 SCM
358 robust_list_ref (int i, SCM l)
359 {
360   while (i-- > 0 && scm_is_pair (scm_cdr (l)))
361     l = scm_cdr (l);
362   return scm_car (l);
363 }
364
365
366 SCM
367 ly_deep_copy (SCM src)
368 {
369   if (scm_is_pair (src))
370     return scm_cons (ly_deep_copy (scm_car (src)), ly_deep_copy (scm_cdr (src)));
371   else if (scm_is_vector (src))
372     {
373       int len = scm_c_vector_length (src);
374       SCM nv = scm_c_make_vector (len, SCM_UNDEFINED);
375       for (int i = 0;i < len; i++)
376         {
377           SCM si = scm_from_int (i);
378           scm_vector_set_x (nv, si, ly_deep_copy (scm_vector_ref (src, si)));
379         }
380     }
381   return src;
382 }
383
384 string
385 print_scm_val (SCM val)
386 {
387   string realval = ly_scm_write_string (val);
388   if (realval.length () > 200)
389     realval = realval.substr (0, 100)
390       + "\n :\n :\n"
391       + realval.substr (realval.length () - 100);
392   return realval;
393 }
394
395 bool
396 type_check_assignment (SCM sym, SCM val, SCM type_symbol)
397 {
398   bool ok = true;
399
400   /*
401     Always succeeds.
402
403
404     TODO: should remove #f from allowed vals?
405   */
406   if (val == SCM_EOL || val == SCM_BOOL_F)
407     return ok;
408
409   if (!scm_is_symbol (sym))
410 #if 0
411     return false;
412 #else
413   /*
414     This is used for autoBeamSettings.
415
416     TODO: deprecate the use of \override and \revert for
417     autoBeamSettings?
418
419     or use a symbol autoBeamSettingS?
420   */
421   return true;
422 #endif
423
424   SCM type = scm_object_property (sym, type_symbol);
425
426   if (type != SCM_EOL && !ly_is_procedure (type))
427     {
428       warning (_f ("cannot find property type-check for `%s' (%s).",
429                    ly_symbol2string (sym).c_str (),
430                    ly_symbol2string (type_symbol).c_str ())
431                + "  " + _ ("perhaps a typing error?"));
432
433       /* Be strict when being anal :) */
434       if (do_internal_type_checking_global)
435         scm_throw (ly_symbol2scm ("ly-file-failed"), scm_list_3 (ly_symbol2scm ("typecheck"),
436                                                                  sym, val));
437
438       warning (_ ("doing assignment anyway"));
439     }
440   else
441     {
442       if (val != SCM_EOL
443           && ly_is_procedure (type)
444           && scm_call_1 (type, val) == SCM_BOOL_F)
445         {
446           ok = false;
447           SCM typefunc = ly_lily_module_constant ("type-name");
448           SCM type_name = scm_call_1 (typefunc, type);
449
450           warning (_f ("type check for `%s' failed; value `%s' must be of type `%s'",
451                        ly_symbol2string (sym).c_str (),
452                        print_scm_val (val),
453                        ly_scm2string (type_name).c_str ()));
454           progress_indication ("\n");
455         }
456     }
457   return ok;
458 }
459
460 /* some SCM abbrevs
461
462 zijn deze nou handig?
463 zijn ze er al in scheme, maar heten ze anders? */
464
465 /* Remove doubles from (sorted) list */
466 SCM
467 ly_unique (SCM list)
468 {
469   SCM unique = SCM_EOL;
470   for (SCM i = list; scm_is_pair (i); i = scm_cdr (i))
471     {
472       if (!scm_is_pair (scm_cdr (i))
473           || !ly_is_equal (scm_car (i), scm_cadr (i)))
474         unique = scm_cons (scm_car (i), unique);
475     }
476   return scm_reverse_x (unique, SCM_EOL);
477 }
478
479
480 /* Split list at member s, removing s.
481    Return (BEFORE . AFTER)  */
482 SCM
483 ly_split_list (SCM s, SCM list)
484 {
485   SCM before = SCM_EOL;
486   SCM after = list;
487   for (; scm_is_pair (after);)
488     {
489       SCM i = scm_car (after);
490       after = scm_cdr (after);
491       if (ly_is_equal (i, s))
492         break;
493       before = scm_cons (i, before);
494     }
495   return scm_cons (scm_reverse_x (before, SCM_EOL), after);
496 }
497
498 void
499 taint (SCM *)
500 {
501   /*
502     nop.
503   */
504 }
505
506 /*
507   display stuff without using stack
508 */
509 SCM
510 display_list (SCM s)
511 {
512   SCM p = scm_current_output_port ();
513
514   scm_puts ("(", p);
515   for (; scm_is_pair (s); s = scm_cdr (s))
516     {
517       scm_display (scm_car (s), p);
518       scm_puts (" ", p);
519     }
520   scm_puts (")", p);
521   return SCM_UNSPECIFIED;
522 }
523
524 Slice
525 int_list_to_slice (SCM l)
526 {
527   Slice s;
528   s.set_empty ();
529   for (; scm_is_pair (l); l = scm_cdr (l))
530     if (scm_is_number (scm_car (l)))
531       s.add_point (scm_to_int (scm_car (l)));
532   return s;
533 }
534
535 Real
536 robust_scm2double (SCM k, double x)
537 {
538   if (scm_is_number (k))
539     x = scm_to_double (k);
540   return x;
541 }
542
543
544 string
545 robust_scm2string (SCM k, string s)
546 {
547   if (scm_is_string (k))
548     s = ly_scm2string (k);
549   return s;
550 }
551
552 int
553 robust_scm2int (SCM k, int o)
554 {
555   if (scm_integer_p (k) == SCM_BOOL_T)
556     o = scm_to_int (k);
557   return o;
558 }
559
560
561 SCM
562 ly_rational2scm (Rational r)
563 {
564   return scm_divide (scm_from_int (r.numerator ()), scm_from_int (r.denominator ()));
565 }
566
567
568 Rational
569 ly_scm2rational (SCM r)
570 {
571   return Rational (scm_to_int (scm_numerator (r)),
572                    scm_to_int (scm_denominator (r)));
573 }
574
575 Rational
576 robust_scm2rational (SCM n, Rational rat)
577 {
578   if (ly_is_fraction (n))
579     return ly_scm2rational (n);
580   else
581     return rat;
582 }
583
584 SCM
585 alist_to_hashq (SCM alist)
586 {
587   int i = scm_ilength (alist);
588   if (i < 0)
589     return scm_c_make_hash_table (0);
590
591   SCM tab = scm_c_make_hash_table (i);
592   for (SCM s = alist; scm_is_pair (s); s = scm_cdr (s))
593     {
594       SCM pt = scm_cdar (s);
595       scm_hashq_set_x (tab, scm_caar (s), pt);
596     }
597   return tab;
598 }
599
600 SCM
601 ly_hash2alist (SCM tab)
602 {
603   SCM func = ly_lily_module_constant ("hash-table->alist");
604   return scm_call_1 (func, tab);
605 }
606
607
608 /*
609   C++ interfacing.
610  */
611
612 string
613 mangle_cxx_identifier (string cxx_id)
614 {
615   if (cxx_id.substr (0, 3) == "ly_")
616     cxx_id = cxx_id.replace (0, 3, "ly:");
617   else
618     {
619       cxx_id = String_convert::to_lower (cxx_id);
620       cxx_id = "ly:" + cxx_id;
621     }
622   if (cxx_id.substr (cxx_id.length () - 2) == "_p")
623     cxx_id = cxx_id.replace (cxx_id.length () - 2, 2, "?");
624   else if (cxx_id.substr (cxx_id.length () - 2) == "_x")
625     cxx_id = cxx_id.replace (cxx_id.length () - 2, 2, "!");
626
627   replace_all (&cxx_id, "_less?", "<?");
628   replace_all (&cxx_id, "_2_", "->");
629   replace_all (&cxx_id, "__", "::");
630   replace_all (&cxx_id, '_', '-');
631
632
633   return cxx_id;
634 }
635
636
637
638 SCM
639 ly_string_array_to_scm (vector<string> a)
640 {
641   SCM s = SCM_EOL;
642   for (vsize i = a.size (); i ; i--)
643     s = scm_cons (ly_symbol2scm (a[i - 1].c_str ()), s);
644   return s;
645 }
646
647 /* SYMBOLS is a whitespace separated list.  */
648 SCM
649 parse_symbol_list (char const *symbols)
650 {
651   while (isspace (*symbols))
652     *symbols++;
653   string s = symbols;
654   replace_all (&s, '\n', ' ');
655   replace_all (&s, '\t', ' ');
656   replace_all (&s, "  ", " ");
657   return ly_string_array_to_scm (string_split (s, ' '));
658 }
659
660 /* GDB debugging. */
661 struct ly_t_double_cell
662 {
663   SCM a;
664   SCM b;
665   SCM c;
666   SCM d;
667 };
668
669 /* inserts at front, removing duplicates */
670 SCM ly_assoc_prepend_x (SCM alist, SCM key, SCM val)
671 {
672   return scm_acons (key, val, scm_assoc_remove_x (alist, key));
673 }
674