2 lily-guile.cc -- implement assorted SCM interface functions
4 source file of the GNU LilyPond music typesetter
6 (c) 1998--2007 Jan Nieuwenhuizen <janneke@gnu.org>
7 Han-Wen Nienhuys <hanwen@xs4all.nl>
10 #include "lily-guile.hh"
14 #include <cstring> /* strdup, strchr */
19 #include "dimensions.hh"
20 #include "direction.hh"
21 #include "file-path.hh"
22 #include "international.hh"
23 #include "libc-extension.hh"
28 #include "string-convert.hh"
29 #include "source-file.hh"
38 ly_scm_write_string (SCM s
)
40 SCM port
= scm_mkstrport (SCM_INUM0
,
41 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
44 // SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
45 SCM write
= scm_primitive_eval (ly_symbol2scm ("write"));
47 // scm_apply (write, port, SCM_EOL);
48 scm_call_2 (write
, s
, port
);
49 return ly_scm2string (scm_strport_to_string (port
));
55 return scm_list_n (ly_symbol2scm ("quote"), s
, SCM_UNDEFINED
);
59 ly_symbol2string (SCM s
)
62 Ugh. this is not very efficient.
64 SCM str
= scm_symbol_to_string (s
);
65 return ly_scm2string (str
);
69 gulp_file_to_string (string fn
, bool must_exist
, int size
)
71 string s
= global_path
.find (fn
);
76 string e
= _f ("cannot find file: `%s'", fn
);
78 e
+= _f ("(load path: `%s')", global_path
.to_string ());
85 if (be_verbose_global
)
86 progress_indication ("[" + s
);
88 vector
<char> chars
= gulp_file (s
, size
);
89 string
result (&chars
[0], chars
.size ());
91 if (be_verbose_global
)
92 progress_indication ("]");
98 // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
100 ly_display_scm (SCM s
)
102 scm_display (s
, scm_current_output_port ());
103 scm_newline (scm_current_output_port ());
111 ly_scm2string (SCM str
)
113 assert (scm_is_string (str
));
114 return string (scm_i_string_chars (str
),
115 (int) scm_i_string_length (str
));
119 ly_string2scm (string
const &str
)
121 return scm_from_locale_stringn (str
.c_str (),
127 ly_scm2newstr (SCM str
, size_t *lenp
)
129 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
131 size_t len
= scm_i_string_length (str
);
132 if (char *new_str
= (char *) malloc ((len
+ 1) * sizeof (char)))
134 memcpy (new_str
, scm_i_string_chars (str
), len
);
150 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);
185 if (scm_is_number (s
))
187 int i
= scm_to_int (s
);
188 return i
== 0 || i
== 1;
196 return scm_is_bool (s
) && ly_scm2bool (s
);
205 return scm_is_integer (s
) ? (Direction
) scm_to_int (s
) : CENTER
;
209 robust_scm2dir (SCM d
, Direction def
)
211 if (is_direction (d
))
219 if (scm_is_number (s
))
221 int i
= scm_to_int (s
);
222 return i
>= -1 && i
<= 1;
231 ly_scm2interval (SCM p
)
233 return Interval (scm_to_double (scm_car (p
)), scm_to_double (scm_cdr (p
)));
237 ly_scm2realdrul (SCM p
)
239 return Drul_array
<Real
> (scm_to_double (scm_car (p
)),
240 scm_to_double (scm_cdr (p
)));
244 ly_interval2scm (Drul_array
<Real
> i
)
246 return scm_cons (scm_from_double (i
[LEFT
]), scm_from_double (i
[RIGHT
]));
251 robust_scm2interval (SCM k
, Drul_array
<Real
> v
)
256 if (is_number_pair (k
))
257 i
= ly_scm2interval (k
);
262 robust_scm2drul (SCM k
, Drul_array
<Real
> v
)
264 if (is_number_pair (k
))
265 v
= ly_scm2interval (k
);
270 robust_scm2booldrul (SCM k
, Drul_array
<bool> def
)
274 def
[LEFT
] = to_boolean (scm_car (k
));
275 def
[RIGHT
] = to_boolean (scm_cdr (k
));
284 ly_offset2scm (Offset o
)
286 return scm_cons (scm_from_double (o
[X_AXIS
]), scm_from_double (o
[Y_AXIS
]));
290 ly_scm2offset (SCM s
)
292 return Offset (scm_to_double (scm_car (s
)),
293 scm_to_double (scm_cdr (s
)));
297 robust_scm2offset (SCM k
, Offset o
)
299 if (is_number_pair (k
))
300 o
= ly_scm2offset (k
);
304 ly_offsets2scm (vector
<Offset
> os
)
308 for (vsize i
= 0; i
< os
.size (); i
++)
310 *tail
= scm_cons (ly_offset2scm (os
[i
]), SCM_EOL
);
311 tail
= SCM_CDRLOC (*tail
);
317 ly_scm2offsets (SCM s
)
320 for (; scm_is_pair (s
); s
= scm_cdr (s
))
321 os
.push_back (ly_scm2offset (scm_car (s
)));
333 alist_equal_p (SCM a
, SCM b
)
336 scm_is_pair (s
); s
= scm_cdr (s
))
338 SCM key
= scm_caar (s
);
339 SCM val
= scm_cdar (s
);
340 SCM l
= scm_assoc (key
, b
);
343 || !ly_is_equal (scm_cdr (l
), val
))
351 ly_alist_vals (SCM alist
)
354 for (SCM p
= alist
; scm_is_pair (p
); p
= scm_cdr (p
))
355 x
= scm_cons (scm_cdar (p
), x
);
363 /* Return I-th element, or last elt L. If I < 0, then we take the first
366 PRE: length (L) > 0 */
368 robust_list_ref (int i
, SCM l
)
370 while (i
-- > 0 && scm_is_pair (scm_cdr (l
)))
377 ly_deep_copy (SCM src
)
379 if (scm_is_pair (src
))
380 return scm_cons (ly_deep_copy (scm_car (src
)), ly_deep_copy (scm_cdr (src
)));
381 else if (scm_is_vector (src
))
383 int len
= scm_c_vector_length (src
);
384 SCM nv
= scm_c_make_vector (len
, SCM_UNDEFINED
);
385 for (int i
= 0;i
< len
; i
++)
387 SCM si
= scm_from_int (i
);
388 scm_vector_set_x (nv
, si
, ly_deep_copy (scm_vector_ref (src
, si
)));
395 print_scm_val (SCM val
)
397 string realval
= ly_scm_write_string (val
);
398 if (realval
.length () > 200)
399 realval
= realval
.substr (0, 100)
401 + realval
.substr (realval
.length () - 100);
406 type_check_assignment (SCM sym
, SCM val
, SCM type_symbol
)
414 TODO: should remove #f from allowed vals?
416 if (val
== SCM_EOL
|| val
== SCM_BOOL_F
)
419 if (!scm_is_symbol (sym
))
424 This is used for autoBeamSettings.
426 TODO: deprecate the use of \override and \revert for
429 or use a symbol autoBeamSettingS?
434 SCM type
= scm_object_property (sym
, type_symbol
);
436 if (type
!= SCM_EOL
&& !ly_is_procedure (type
))
438 warning (_f ("cannot find property type-check for `%s' (%s).",
439 ly_symbol2string (sym
).c_str (),
440 ly_symbol2string (type_symbol
).c_str ())
441 + " " + _ ("perhaps a typing error?"));
443 /* Be strict when being anal :) */
444 if (do_internal_type_checking_global
)
445 scm_throw (ly_symbol2scm ("ly-file-failed"), scm_list_3 (ly_symbol2scm ("typecheck"),
448 warning (_ ("doing assignment anyway"));
453 && ly_is_procedure (type
)
454 && scm_call_1 (type
, val
) == SCM_BOOL_F
)
457 SCM typefunc
= ly_lily_module_constant ("type-name");
458 SCM type_name
= scm_call_1 (typefunc
, type
);
460 warning (_f ("type check for `%s' failed; value `%s' must be of type `%s'",
461 ly_symbol2string (sym
).c_str (),
463 ly_scm2string (type_name
).c_str ()));
464 progress_indication ("\n");
472 zijn deze nou handig?
473 zijn ze er al in scheme, maar heten ze anders? */
475 /* Remove doubles from (sorted) list */
479 SCM unique
= SCM_EOL
;
480 for (SCM i
= list
; scm_is_pair (i
); i
= scm_cdr (i
))
482 if (!scm_is_pair (scm_cdr (i
))
483 || !ly_is_equal (scm_car (i
), scm_cadr (i
)))
484 unique
= scm_cons (scm_car (i
), unique
);
486 return scm_reverse_x (unique
, SCM_EOL
);
490 /* Split list at member s, removing s.
491 Return (BEFORE . AFTER) */
493 ly_split_list (SCM s
, SCM list
)
495 SCM before
= SCM_EOL
;
497 for (; scm_is_pair (after
);)
499 SCM i
= scm_car (after
);
500 after
= scm_cdr (after
);
501 if (ly_is_equal (i
, s
))
503 before
= scm_cons (i
, before
);
505 return scm_cons (scm_reverse_x (before
, SCM_EOL
), after
);
517 display stuff without using stack
522 SCM p
= scm_current_output_port ();
525 for (; scm_is_pair (s
); s
= scm_cdr (s
))
527 scm_display (scm_car (s
), p
);
531 return SCM_UNSPECIFIED
;
535 int_list_to_slice (SCM l
)
539 for (; scm_is_pair (l
); l
= scm_cdr (l
))
540 if (scm_is_number (scm_car (l
)))
541 s
.add_point (scm_to_int (scm_car (l
)));
546 robust_scm2double (SCM k
, double x
)
548 if (scm_is_number (k
))
549 x
= scm_to_double (k
);
555 robust_scm2string (SCM k
, string s
)
557 if (scm_is_string (k
))
558 s
= ly_scm2string (k
);
563 robust_scm2int (SCM k
, int o
)
565 if (scm_integer_p (k
) == SCM_BOOL_T
)
572 ly_rational2scm (Rational r
)
574 return scm_divide (scm_from_int (r
.numerator ()), scm_from_int (r
.denominator ()));
579 ly_scm2rational (SCM r
)
581 return Rational (scm_to_int (scm_numerator (r
)),
582 scm_to_int (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 cxx_id
= replace_all (cxx_id
, "_less?", "<?");
638 cxx_id
= replace_all (cxx_id
, "_2_", "->");
639 cxx_id
= replace_all (cxx_id
, "__", "::");
640 cxx_id
= 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
));