2 This file is part of LilyPond, the GNU music typesetter.
4 Copyright (C) 1998--2011 Jan Nieuwenhuizen <janneke@gnu.org>
5 Han-Wen Nienhuys <hanwen@xs4all.nl>
7 LilyPond is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 LilyPond is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
21 #include "lily-guile.hh"
25 #include <cstring> /* strdup, strchr */
30 #include "dimensions.hh"
31 #include "direction.hh"
32 #include "file-path.hh"
33 #include "international.hh"
34 #include "libc-extension.hh"
39 #include "string-convert.hh"
40 #include "source-file.hh"
49 ly_scm_write_string (SCM s
)
51 SCM port
= scm_mkstrport (SCM_INUM0
,
52 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
55 // SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
56 SCM write
= scm_primitive_eval (ly_symbol2scm ("write"));
58 // scm_apply (write, port, SCM_EOL);
59 scm_call_2 (write
, s
, port
);
60 return ly_scm2string (scm_strport_to_string (port
));
66 return scm_list_n (ly_symbol2scm ("quote"), s
, SCM_UNDEFINED
);
70 ly_symbol2string (SCM s
)
73 Ugh. this is not very efficient.
75 SCM str
= scm_symbol_to_string (s
);
76 return ly_scm2string (str
);
80 gulp_file_to_string (string fn
, bool must_exist
, int size
)
82 string s
= global_path
.find (fn
);
87 string e
= _f ("cannot find file: `%s'", fn
);
89 e
+= _f ("(load path: `%s')", global_path
.to_string ());
96 if (be_verbose_global
)
97 progress_indication ("[" + s
);
99 vector
<char> chars
= gulp_file (s
, size
);
100 string
result (&chars
[0], chars
.size ());
102 if (be_verbose_global
)
103 progress_indication ("]\n");
109 // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
111 ly_display_scm (SCM s
)
113 scm_display (s
, scm_current_output_port ());
114 scm_newline (scm_current_output_port ());
122 ly_scm2string (SCM str
)
124 assert (scm_is_string (str
));
126 size_t len
= scm_c_string_length (str
);
129 scm_to_locale_stringbuf(str
, &result
.at(0), len
);
135 ly_string2scm (string
const &str
)
137 return scm_from_locale_stringn (str
.c_str (),
142 ly_scm2str0 (SCM str
)
144 return scm_to_locale_string (str
);
151 index_get_cell (SCM s
, Direction d
)
154 return (d
== LEFT
) ? scm_car (s
) : scm_cdr (s
);
158 index_set_cell (SCM s
, Direction d
, SCM v
)
161 scm_set_car_x (s
, v
);
163 scm_set_cdr_x (s
, v
);
168 is_number_pair (SCM p
)
170 return scm_is_pair (p
)
171 && scm_is_number (scm_car (p
)) && scm_is_number (scm_cdr (p
));
178 return scm_ihashv (s
, ~1u);
184 if (scm_is_number (s
))
186 int i
= scm_to_int (s
);
187 return i
== 0 || i
== 1;
195 return scm_is_bool (s
) && ly_scm2bool (s
);
204 return scm_is_integer (s
) ? (Direction
) scm_to_int (s
) : CENTER
;
208 robust_scm2dir (SCM d
, Direction def
)
210 if (is_direction (d
))
218 if (scm_is_number (s
))
220 int i
= scm_to_int (s
);
221 return i
>= -1 && i
<= 1;
230 ly_scm2interval (SCM p
)
232 return Interval (scm_to_double (scm_car (p
)), scm_to_double (scm_cdr (p
)));
236 ly_scm2realdrul (SCM p
)
238 return Drul_array
<Real
> (scm_to_double (scm_car (p
)),
239 scm_to_double (scm_cdr (p
)));
243 ly_interval2scm (Drul_array
<Real
> i
)
245 return scm_cons (scm_from_double (i
[LEFT
]), scm_from_double (i
[RIGHT
]));
250 robust_scm2interval (SCM k
, Drul_array
<Real
> v
)
255 if (is_number_pair (k
))
256 i
= ly_scm2interval (k
);
261 robust_scm2drul (SCM k
, Drul_array
<Real
> v
)
263 if (is_number_pair (k
))
264 v
= ly_scm2interval (k
);
269 robust_scm2booldrul (SCM k
, Drul_array
<bool> def
)
273 def
[LEFT
] = to_boolean (scm_car (k
));
274 def
[RIGHT
] = to_boolean (scm_cdr (k
));
283 ly_offset2scm (Offset o
)
285 return scm_cons (scm_from_double (o
[X_AXIS
]), scm_from_double (o
[Y_AXIS
]));
289 ly_scm2offset (SCM s
)
291 return Offset (scm_to_double (scm_car (s
)),
292 scm_to_double (scm_cdr (s
)));
296 robust_scm2offset (SCM k
, Offset o
)
298 if (is_number_pair (k
))
299 o
= ly_scm2offset (k
);
303 ly_offsets2scm (vector
<Offset
> os
)
307 for (vsize i
= 0; i
< os
.size (); i
++)
309 *tail
= scm_cons (ly_offset2scm (os
[i
]), SCM_EOL
);
310 tail
= SCM_CDRLOC (*tail
);
316 ly_scm2offsets (SCM s
)
319 for (; scm_is_pair (s
); s
= scm_cdr (s
))
320 os
.push_back (ly_scm2offset (scm_car (s
)));
332 alist_equal_p (SCM a
, SCM b
)
335 scm_is_pair (s
); s
= scm_cdr (s
))
337 SCM key
= scm_caar (s
);
338 SCM val
= scm_cdar (s
);
339 SCM l
= scm_assoc (key
, b
);
342 || !ly_is_equal (scm_cdr (l
), val
))
350 ly_alist_vals (SCM alist
)
353 for (SCM p
= alist
; scm_is_pair (p
); p
= scm_cdr (p
))
354 x
= scm_cons (scm_cdar (p
), x
);
362 /* Return I-th element, or last elt L. If I < 0, then we take the first
365 PRE: length (L) > 0 */
367 robust_list_ref (int i
, SCM l
)
369 while (i
-- > 0 && scm_is_pair (scm_cdr (l
)))
376 ly_deep_copy (SCM src
)
378 if (scm_is_pair (src
))
379 return scm_cons (ly_deep_copy (scm_car (src
)), ly_deep_copy (scm_cdr (src
)));
380 else if (scm_is_vector (src
))
382 int len
= scm_c_vector_length (src
);
383 SCM nv
= scm_c_make_vector (len
, SCM_UNDEFINED
);
384 for (int i
= 0;i
< len
; i
++)
386 SCM si
= scm_from_int (i
);
387 scm_vector_set_x (nv
, si
, ly_deep_copy (scm_vector_ref (src
, si
)));
394 print_scm_val (SCM val
)
396 string realval
= ly_scm_write_string (val
);
397 if (realval
.length () > 200)
398 realval
= realval
.substr (0, 100)
400 + realval
.substr (realval
.length () - 100);
405 type_check_assignment (SCM sym
, SCM val
, SCM type_symbol
)
413 TODO: should remove #f from allowed vals?
415 if (val
== SCM_EOL
|| val
== SCM_BOOL_F
)
418 if (!scm_is_symbol (sym
))
423 This is used for autoBeamSettings.
425 TODO: deprecate the use of \override and \revert for
428 or use a symbol autoBeamSettingS?
433 SCM type
= scm_object_property (sym
, type_symbol
);
435 if (type
!= SCM_EOL
&& !ly_is_procedure (type
))
437 warning (_f ("cannot find property type-check for `%s' (%s).",
438 ly_symbol2string (sym
).c_str (),
439 ly_symbol2string (type_symbol
).c_str ())
440 + " " + _ ("perhaps a typing error?"));
442 /* Be strict when being anal :) */
443 if (do_internal_type_checking_global
)
444 scm_throw (ly_symbol2scm ("ly-file-failed"), scm_list_3 (ly_symbol2scm ("typecheck"),
447 warning (_ ("doing assignment anyway"));
452 && ly_is_procedure (type
)
453 && scm_call_1 (type
, val
) == SCM_BOOL_F
)
456 SCM typefunc
= ly_lily_module_constant ("type-name");
457 SCM type_name
= scm_call_1 (typefunc
, type
);
459 warning (_f ("type check for `%s' failed; value `%s' must be of type `%s'",
460 ly_symbol2string (sym
).c_str (),
462 ly_scm2string (type_name
).c_str ()));
463 progress_indication ("\n");
471 zijn deze nou handig?
472 zijn ze er al in scheme, maar heten ze anders? */
474 /* Remove doubles from (sorted) list */
478 SCM unique
= SCM_EOL
;
479 for (SCM i
= list
; scm_is_pair (i
); i
= scm_cdr (i
))
481 if (!scm_is_pair (scm_cdr (i
))
482 || !ly_is_equal (scm_car (i
), scm_cadr (i
)))
483 unique
= scm_cons (scm_car (i
), unique
);
485 return scm_reverse_x (unique
, SCM_EOL
);
489 /* Split list at member s, removing s.
490 Return (BEFORE . AFTER) */
492 ly_split_list (SCM s
, SCM list
)
494 SCM before
= SCM_EOL
;
496 for (; scm_is_pair (after
);)
498 SCM i
= scm_car (after
);
499 after
= scm_cdr (after
);
500 if (ly_is_equal (i
, s
))
502 before
= scm_cons (i
, before
);
504 return scm_cons (scm_reverse_x (before
, SCM_EOL
), after
);
516 display stuff without using stack
521 SCM p
= scm_current_output_port ();
524 for (; scm_is_pair (s
); s
= scm_cdr (s
))
526 scm_display (scm_car (s
), p
);
530 return SCM_UNSPECIFIED
;
534 int_list_to_slice (SCM l
)
538 for (; scm_is_pair (l
); l
= scm_cdr (l
))
539 if (scm_is_number (scm_car (l
)))
540 s
.add_point (scm_to_int (scm_car (l
)));
545 robust_scm2double (SCM k
, double x
)
547 if (scm_is_number (k
))
548 x
= scm_to_double (k
);
554 robust_scm2string (SCM k
, string s
)
556 if (scm_is_string (k
))
557 s
= ly_scm2string (k
);
562 robust_scm2int (SCM k
, int o
)
564 if (scm_integer_p (k
) == SCM_BOOL_T
)
571 ly_rational2scm (Rational r
)
573 return scm_divide (scm_from_int64 (r
.numerator ()),
574 scm_from_int64 (r
.denominator ()));
579 ly_scm2rational (SCM r
)
581 return Rational (scm_to_int64 (scm_numerator (r
)),
582 scm_to_int64 (scm_denominator (r
)));
586 robust_scm2rational (SCM n
, Rational rat
)
588 if (ly_is_fraction (n
))
589 return ly_scm2rational (n
);
595 alist_to_hashq (SCM alist
)
597 int i
= scm_ilength (alist
);
599 return scm_c_make_hash_table (0);
601 SCM tab
= scm_c_make_hash_table (i
);
602 for (SCM s
= alist
; scm_is_pair (s
); s
= scm_cdr (s
))
604 SCM pt
= scm_cdar (s
);
605 scm_hashq_set_x (tab
, scm_caar (s
), pt
);
611 ly_hash2alist (SCM tab
)
613 SCM func
= ly_lily_module_constant ("hash-table->alist");
614 return scm_call_1 (func
, tab
);
623 mangle_cxx_identifier (string cxx_id
)
625 if (cxx_id
.substr (0, 3) == "ly_")
626 cxx_id
= cxx_id
.replace (0, 3, "ly:");
629 cxx_id
= String_convert::to_lower (cxx_id
);
630 cxx_id
= "ly:" + cxx_id
;
632 if (cxx_id
.substr (cxx_id
.length () - 2) == "_p")
633 cxx_id
= cxx_id
.replace (cxx_id
.length () - 2, 2, "?");
634 else if (cxx_id
.substr (cxx_id
.length () - 2) == "_x")
635 cxx_id
= cxx_id
.replace (cxx_id
.length () - 2, 2, "!");
637 replace_all (&cxx_id
, "_less?", "<?");
638 replace_all (&cxx_id
, "_2_", "->");
639 replace_all (&cxx_id
, "__", "::");
640 replace_all (&cxx_id
, '_', '-');
649 ly_string_array_to_scm (vector
<string
> a
)
652 for (vsize i
= a
.size (); i
; i
--)
653 s
= scm_cons (ly_symbol2scm (a
[i
- 1].c_str ()), s
);
657 /* SYMBOLS is a whitespace separated list. */
659 parse_symbol_list (char const *symbols
)
661 while (isspace (*symbols
))
664 replace_all (&s
, '\n', ' ');
665 replace_all (&s
, '\t', ' ');
666 replace_all (&s
, " ", " ");
667 return ly_string_array_to_scm (string_split (s
, ' '));
671 struct ly_t_double_cell
679 /* inserts at front, removing duplicates */
680 SCM
ly_assoc_prepend_x (SCM alist
, SCM key
, SCM val
)
682 return scm_acons (key
, val
, scm_assoc_remove_x (alist
, key
));