2 This file is part of LilyPond, the GNU music typesetter.
4 Copyright (C) 1998--2010 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 (),
143 ly_scm2newstr (SCM str
, size_t *lenp
)
145 char* p
= scm_to_locale_stringn(str
, lenp
);
153 index_get_cell (SCM s
, Direction d
)
156 return (d
== LEFT
) ? scm_car (s
) : scm_cdr (s
);
160 index_set_cell (SCM s
, Direction d
, SCM v
)
163 scm_set_car_x (s
, v
);
165 scm_set_cdr_x (s
, v
);
170 is_number_pair (SCM p
)
172 return scm_is_pair (p
)
173 && scm_is_number (scm_car (p
)) && scm_is_number (scm_cdr (p
));
180 return scm_ihashv (s
, ~1u);
186 if (scm_is_number (s
))
188 int i
= scm_to_int (s
);
189 return i
== 0 || i
== 1;
197 return scm_is_bool (s
) && ly_scm2bool (s
);
206 return scm_is_integer (s
) ? (Direction
) scm_to_int (s
) : CENTER
;
210 robust_scm2dir (SCM d
, Direction def
)
212 if (is_direction (d
))
220 if (scm_is_number (s
))
222 int i
= scm_to_int (s
);
223 return i
>= -1 && i
<= 1;
232 ly_scm2interval (SCM p
)
234 return Interval (scm_to_double (scm_car (p
)), scm_to_double (scm_cdr (p
)));
238 ly_scm2realdrul (SCM p
)
240 return Drul_array
<Real
> (scm_to_double (scm_car (p
)),
241 scm_to_double (scm_cdr (p
)));
245 ly_interval2scm (Drul_array
<Real
> i
)
247 return scm_cons (scm_from_double (i
[LEFT
]), scm_from_double (i
[RIGHT
]));
252 robust_scm2interval (SCM k
, Drul_array
<Real
> v
)
257 if (is_number_pair (k
))
258 i
= ly_scm2interval (k
);
263 robust_scm2drul (SCM k
, Drul_array
<Real
> v
)
265 if (is_number_pair (k
))
266 v
= ly_scm2interval (k
);
271 robust_scm2booldrul (SCM k
, Drul_array
<bool> def
)
275 def
[LEFT
] = to_boolean (scm_car (k
));
276 def
[RIGHT
] = to_boolean (scm_cdr (k
));
285 ly_offset2scm (Offset o
)
287 return scm_cons (scm_from_double (o
[X_AXIS
]), scm_from_double (o
[Y_AXIS
]));
291 ly_scm2offset (SCM s
)
293 return Offset (scm_to_double (scm_car (s
)),
294 scm_to_double (scm_cdr (s
)));
298 robust_scm2offset (SCM k
, Offset o
)
300 if (is_number_pair (k
))
301 o
= ly_scm2offset (k
);
305 ly_offsets2scm (vector
<Offset
> os
)
309 for (vsize i
= 0; i
< os
.size (); i
++)
311 *tail
= scm_cons (ly_offset2scm (os
[i
]), SCM_EOL
);
312 tail
= SCM_CDRLOC (*tail
);
318 ly_scm2offsets (SCM s
)
321 for (; scm_is_pair (s
); s
= scm_cdr (s
))
322 os
.push_back (ly_scm2offset (scm_car (s
)));
334 alist_equal_p (SCM a
, SCM b
)
337 scm_is_pair (s
); s
= scm_cdr (s
))
339 SCM key
= scm_caar (s
);
340 SCM val
= scm_cdar (s
);
341 SCM l
= scm_assoc (key
, b
);
344 || !ly_is_equal (scm_cdr (l
), val
))
352 ly_alist_vals (SCM alist
)
355 for (SCM p
= alist
; scm_is_pair (p
); p
= scm_cdr (p
))
356 x
= scm_cons (scm_cdar (p
), x
);
364 /* Return I-th element, or last elt L. If I < 0, then we take the first
367 PRE: length (L) > 0 */
369 robust_list_ref (int i
, SCM l
)
371 while (i
-- > 0 && scm_is_pair (scm_cdr (l
)))
378 ly_deep_copy (SCM src
)
380 if (scm_is_pair (src
))
381 return scm_cons (ly_deep_copy (scm_car (src
)), ly_deep_copy (scm_cdr (src
)));
382 else if (scm_is_vector (src
))
384 int len
= scm_c_vector_length (src
);
385 SCM nv
= scm_c_make_vector (len
, SCM_UNDEFINED
);
386 for (int i
= 0;i
< len
; i
++)
388 SCM si
= scm_from_int (i
);
389 scm_vector_set_x (nv
, si
, ly_deep_copy (scm_vector_ref (src
, si
)));
396 print_scm_val (SCM val
)
398 string realval
= ly_scm_write_string (val
);
399 if (realval
.length () > 200)
400 realval
= realval
.substr (0, 100)
402 + realval
.substr (realval
.length () - 100);
407 type_check_assignment (SCM sym
, SCM val
, SCM type_symbol
)
415 TODO: should remove #f from allowed vals?
417 if (val
== SCM_EOL
|| val
== SCM_BOOL_F
)
420 if (!scm_is_symbol (sym
))
425 This is used for autoBeamSettings.
427 TODO: deprecate the use of \override and \revert for
430 or use a symbol autoBeamSettingS?
435 SCM type
= scm_object_property (sym
, type_symbol
);
437 if (type
!= SCM_EOL
&& !ly_is_procedure (type
))
439 warning (_f ("cannot find property type-check for `%s' (%s).",
440 ly_symbol2string (sym
).c_str (),
441 ly_symbol2string (type_symbol
).c_str ())
442 + " " + _ ("perhaps a typing error?"));
444 /* Be strict when being anal :) */
445 if (do_internal_type_checking_global
)
446 scm_throw (ly_symbol2scm ("ly-file-failed"), scm_list_3 (ly_symbol2scm ("typecheck"),
449 warning (_ ("doing assignment anyway"));
454 && ly_is_procedure (type
)
455 && scm_call_1 (type
, val
) == SCM_BOOL_F
)
458 SCM typefunc
= ly_lily_module_constant ("type-name");
459 SCM type_name
= scm_call_1 (typefunc
, type
);
461 warning (_f ("type check for `%s' failed; value `%s' must be of type `%s'",
462 ly_symbol2string (sym
).c_str (),
464 ly_scm2string (type_name
).c_str ()));
465 progress_indication ("\n");
473 zijn deze nou handig?
474 zijn ze er al in scheme, maar heten ze anders? */
476 /* Remove doubles from (sorted) list */
480 SCM unique
= SCM_EOL
;
481 for (SCM i
= list
; scm_is_pair (i
); i
= scm_cdr (i
))
483 if (!scm_is_pair (scm_cdr (i
))
484 || !ly_is_equal (scm_car (i
), scm_cadr (i
)))
485 unique
= scm_cons (scm_car (i
), unique
);
487 return scm_reverse_x (unique
, SCM_EOL
);
491 /* Split list at member s, removing s.
492 Return (BEFORE . AFTER) */
494 ly_split_list (SCM s
, SCM list
)
496 SCM before
= SCM_EOL
;
498 for (; scm_is_pair (after
);)
500 SCM i
= scm_car (after
);
501 after
= scm_cdr (after
);
502 if (ly_is_equal (i
, s
))
504 before
= scm_cons (i
, before
);
506 return scm_cons (scm_reverse_x (before
, SCM_EOL
), after
);
518 display stuff without using stack
523 SCM p
= scm_current_output_port ();
526 for (; scm_is_pair (s
); s
= scm_cdr (s
))
528 scm_display (scm_car (s
), p
);
532 return SCM_UNSPECIFIED
;
536 int_list_to_slice (SCM l
)
540 for (; scm_is_pair (l
); l
= scm_cdr (l
))
541 if (scm_is_number (scm_car (l
)))
542 s
.add_point (scm_to_int (scm_car (l
)));
547 robust_scm2double (SCM k
, double x
)
549 if (scm_is_number (k
))
550 x
= scm_to_double (k
);
556 robust_scm2string (SCM k
, string s
)
558 if (scm_is_string (k
))
559 s
= ly_scm2string (k
);
564 robust_scm2int (SCM k
, int o
)
566 if (scm_integer_p (k
) == SCM_BOOL_T
)
573 ly_rational2scm (Rational r
)
575 return scm_divide (scm_from_int64 (r
.numerator ()),
576 scm_from_int64 (r
.denominator ()));
581 ly_scm2rational (SCM r
)
583 return Rational (scm_to_int64 (scm_numerator (r
)),
584 scm_to_int64 (scm_denominator (r
)));
588 robust_scm2rational (SCM n
, Rational rat
)
590 if (ly_is_fraction (n
))
591 return ly_scm2rational (n
);
597 alist_to_hashq (SCM alist
)
599 int i
= scm_ilength (alist
);
601 return scm_c_make_hash_table (0);
603 SCM tab
= scm_c_make_hash_table (i
);
604 for (SCM s
= alist
; scm_is_pair (s
); s
= scm_cdr (s
))
606 SCM pt
= scm_cdar (s
);
607 scm_hashq_set_x (tab
, scm_caar (s
), pt
);
613 ly_hash2alist (SCM tab
)
615 SCM func
= ly_lily_module_constant ("hash-table->alist");
616 return scm_call_1 (func
, tab
);
625 mangle_cxx_identifier (string cxx_id
)
627 if (cxx_id
.substr (0, 3) == "ly_")
628 cxx_id
= cxx_id
.replace (0, 3, "ly:");
631 cxx_id
= String_convert::to_lower (cxx_id
);
632 cxx_id
= "ly:" + cxx_id
;
634 if (cxx_id
.substr (cxx_id
.length () - 2) == "_p")
635 cxx_id
= cxx_id
.replace (cxx_id
.length () - 2, 2, "?");
636 else if (cxx_id
.substr (cxx_id
.length () - 2) == "_x")
637 cxx_id
= cxx_id
.replace (cxx_id
.length () - 2, 2, "!");
639 replace_all (&cxx_id
, "_less?", "<?");
640 replace_all (&cxx_id
, "_2_", "->");
641 replace_all (&cxx_id
, "__", "::");
642 replace_all (&cxx_id
, '_', '-');
651 ly_string_array_to_scm (vector
<string
> a
)
654 for (vsize i
= a
.size (); i
; i
--)
655 s
= scm_cons (ly_symbol2scm (a
[i
- 1].c_str ()), s
);
659 /* SYMBOLS is a whitespace separated list. */
661 parse_symbol_list (char const *symbols
)
663 while (isspace (*symbols
))
666 replace_all (&s
, '\n', ' ');
667 replace_all (&s
, '\t', ' ');
668 replace_all (&s
, " ", " ");
669 return ly_string_array_to_scm (string_split (s
, ' '));
673 struct ly_t_double_cell
681 /* inserts at front, removing duplicates */
682 SCM
ly_assoc_prepend_x (SCM alist
, SCM key
, SCM val
)
684 return scm_acons (key
, val
, scm_assoc_remove_x (alist
, key
));