2 lily-guile.cc -- implement assorted Guile bindings
4 source file of the GNU LilyPond music typesetter
6 (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
7 Han-Wen Nienhuys <hanwen@xs4all.nl>
14 #include <cstring> /* memset */
17 #include "international.hh"
18 #include "libc-extension.hh"
19 #include "lily-guile.hh"
23 #include "dimensions.hh"
25 #include "file-path.hh"
26 #include "relocate.hh"
27 #include "file-name.hh"
28 #include "string-convert.hh"
30 LY_DEFINE (ly_start_environment
, "ly:start-environment",
32 "Return the environment (a list of strings) that was in"
33 " effect at program start.")
38 for (vsize i
= 0; i
< start_environment_global
.size (); i
++)
40 *tail
= scm_cons (ly_string2scm (start_environment_global
[i
]),
42 tail
= SCM_CDRLOC(*tail
);
49 LY_DEFINE (ly_find_file
, "ly:find-file",
51 "Return the absolute file name of @var{name},"
52 " or @code{#f} if not found.")
54 LY_ASSERT_TYPE (scm_is_string
, name
, 1);
56 string nm
= ly_scm2string (name
);
57 string file_name
= global_path
.find (nm
);
58 if (file_name
.empty ())
61 return ly_string2scm (file_name
);
65 Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
68 LY_DEFINE (ly_gulp_file
, "ly:gulp-file",
69 1, 1, 0, (SCM name
, SCM size
),
70 "Read the file @var{name}, and return its contents in a string."
71 " The file is looked up using the search path.")
73 LY_ASSERT_TYPE (scm_is_string
, name
, 1);
75 if (size
!= SCM_UNDEFINED
)
77 LY_ASSERT_TYPE (scm_is_number
, size
, 2);
78 sz
= scm_to_int (size
);
81 string contents
= gulp_file_to_string (ly_scm2string (name
), true, sz
);
82 return scm_from_locale_stringn (contents
.c_str (), contents
.length ());
85 LY_DEFINE (ly_error
, "ly:error",
86 1, 0, 1, (SCM str
, SCM rest
),
87 "A Scheme callable function to issue the error @var{str}."
88 " The error is formatted with @code{format} and @var{rest}.")
90 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
91 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
92 error (ly_scm2string (str
));
93 return SCM_UNSPECIFIED
;
96 LY_DEFINE (ly_message
, "ly:message",
97 1, 0, 1, (SCM str
, SCM rest
),
98 "A Scheme callable function to issue the message @var{str}."
99 " The message is formatted with @code{format} and @var{rest}.")
101 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
102 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
103 message (ly_scm2string (str
));
104 return SCM_UNSPECIFIED
;
107 LY_DEFINE (ly_progress
, "ly:progress",
108 1, 0, 1, (SCM str
, SCM rest
),
109 "A Scheme callable function to print progress @var{str}."
110 " The message is formatted with @code{format} and @var{rest}.")
112 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
113 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
114 progress_indication (ly_scm2string (str
));
115 return SCM_UNSPECIFIED
;
118 LY_DEFINE (ly_programming_error
, "ly:programming-error",
119 1, 0, 1, (SCM str
, SCM rest
),
120 "A Scheme callable function to issue the internal warning"
121 " @var{str}. The message is formatted with @code{format}"
124 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
125 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
126 programming_error (ly_scm2string (str
));
127 return SCM_UNSPECIFIED
;
130 LY_DEFINE (ly_warning
, "ly:warning",
131 1, 0, 1, (SCM str
, SCM rest
),
132 "A Scheme callable function to issue the warning @code{str}."
133 " The message is formatted with @code{format} and @code{rest}.")
135 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
136 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
137 warning (ly_scm2string (str
));
138 return SCM_UNSPECIFIED
;
141 LY_DEFINE (ly_dir_p
, "ly:dir?",
143 "A type predicate. The direction@tie{}@code{s} is @code{-1},"
144 " @code{0} or@tie{}@code{1}, where @code{-1} represents"
145 " left or down and @code{1} represents right or up.")
147 if (scm_is_number (s
))
149 int i
= scm_to_int (s
);
150 return (i
>= -1 && i
<= 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
155 LY_DEFINE (ly_assoc_get
, "ly:assoc-get",
157 (SCM key
, SCM alist
, SCM default_value
),
158 "Return value if @var{key} in @var{alist}, else @code{default-value}"
159 " (or @code{#f} if not specified).")
161 LY_ASSERT_TYPE(ly_cheap_is_list
, alist
, 2);
163 SCM handle
= scm_assoc (key
, alist
);
164 if (scm_is_pair (handle
))
165 return scm_cdr (handle
);
167 if (default_value
== SCM_UNDEFINED
)
168 default_value
= SCM_BOOL_F
;
170 return default_value
;
173 LY_DEFINE (ly_string_substitute
, "ly:string-substitute",
174 3, 0, 0, (SCM a
, SCM b
, SCM s
),
175 "Replace string@tie{}@var{a} by string@tie{}@var{b} in"
176 " string@tie{}@var{s}.")
178 LY_ASSERT_TYPE (scm_is_string
, s
, 1);
179 LY_ASSERT_TYPE (scm_is_string
, b
, 2);
180 LY_ASSERT_TYPE (scm_is_string
, s
, 3);
182 string ss
= ly_scm2string (s
);
183 replace_all (&ss
, ly_scm2string (a
),
186 return ly_string2scm (ss
);
189 LY_DEFINE (ly_number_2_string
, "ly:number->string",
191 "Convert @var{num} to a string without generating many decimals.")
193 LY_ASSERT_TYPE (scm_is_number
, s
, 1);
195 char str
[400]; // ugh.
197 if (scm_exact_p (s
) == SCM_BOOL_F
)
199 Real
r (scm_to_double (s
));
200 if (isinf (r
) || isnan (r
))
202 programming_error (_ ("infinity or NaN encountered while converting Real number"));
203 programming_error (_ ("setting to zero"));
208 snprintf (str
, sizeof (str
), "%.4f", r
);
211 snprintf (str
, sizeof (str
), "%d", int (scm_to_int (s
)));
213 return scm_from_locale_string (str
);
216 LY_DEFINE (ly_version
, "ly:version", 0, 0, 0, (),
217 "Return the current lilypond version as a list, e.g.,"
218 " @code{(1 3 127 uu1)}.")
220 char const *vs
= "\'(" MAJOR_VERSION
" " MINOR_VERSION
" " PATCH_LEVEL
" " MY_PATCH_LEVEL
")";
222 return scm_c_eval_string ((char *)vs
);
225 LY_DEFINE (ly_unit
, "ly:unit", 0, 0, 0, (),
226 "Return the unit used for lengths as a string.")
228 return scm_from_locale_string (INTERNAL_UNIT
);
231 LY_DEFINE (ly_dimension_p
, "ly:dimension?", 1, 0, 0, (SCM d
),
232 "Return @var{d} as a number. Used to distinguish length"
233 " variables from normal numbers.")
235 return scm_number_p (d
);
241 LY_DEFINE (ly_protects
, "ly:protects",
243 "Return hash of protected objects.")
248 LY_DEFINE (ly_gettext
, "ly:gettext",
249 1, 0, 0, (SCM original
),
250 "A Scheme wrapper function for @code{gettext}.")
252 LY_ASSERT_TYPE (scm_is_string
, original
, 1);
253 return ly_string2scm (_ (ly_scm2string (original
).c_str ()));
256 LY_DEFINE (ly_output_formats
, "ly:output-formats",
258 "Formats passed to @option{--format} as a list of strings,"
259 " used for the output.")
261 vector
<string
> output_formats
= string_split (output_format_global
, ',');
264 int output_formats_count
= output_formats
.size ();
265 for (int i
= 0; i
< output_formats_count
; i
++)
266 lst
= scm_cons (ly_string2scm (output_formats
[i
]), lst
);
271 LY_DEFINE (ly_wide_char_2_utf_8
, "ly:wide-char->utf-8",
273 "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
277 LY_ASSERT_TYPE (scm_is_integer
, wc
, 1);
278 unsigned wide_char
= (unsigned) scm_to_int (wc
);
281 if (wide_char
< 0x0080)
282 *p
++ = (char)wide_char
;
283 else if (wide_char
< 0x0800)
285 *p
++ = (char) (((wide_char
>> 6)) | 0xC0);
286 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
288 else if (wide_char
< 0x10000)
290 *p
++ = (char) (((wide_char
>> 12)) | 0xE0);
291 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
292 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
296 *p
++ = (char) (((wide_char
>> 18)) | 0xF0);
297 *p
++ = (char) (((wide_char
>> 12) & 0x3F) | 0x80);
298 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
299 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
303 return scm_from_locale_string (buf
);
306 LY_DEFINE (ly_effective_prefix
, "ly:effective-prefix",
308 "Return effective prefix.")
310 return ly_string2scm (lilypond_datadir
);
313 LY_DEFINE (ly_chain_assoc_get
, "ly:chain-assoc-get",
314 2, 1, 0, (SCM key
, SCM achain
, SCM dfault
),
315 "Return value for @var{key} from a list of alists @var{achain}."
316 " If no entry is found, return @var{dfault} or @code{#f} if no"
317 " @var{dfault} is specified.")
319 if (scm_is_pair (achain
))
321 SCM handle
= scm_assoc (key
, scm_car (achain
));
322 if (scm_is_pair (handle
))
323 return scm_cdr (handle
);
325 return ly_chain_assoc_get (key
, scm_cdr (achain
), dfault
);
327 return dfault
== SCM_UNDEFINED
? SCM_BOOL_F
: dfault
;
331 LY_DEFINE (ly_stderr_redirect
, "ly:stderr-redirect",
332 1, 1, 0, (SCM file_name
, SCM mode
),
333 "Redirect stderr to @var{file-name}, opened with @var{mode}.")
335 LY_ASSERT_TYPE (scm_is_string
, file_name
, 1);
338 if (mode
!= SCM_UNDEFINED
&& scm_string_p (mode
))
339 m
= ly_scm2string (mode
);
340 /* dup2 and (fileno (current-error-port)) do not work with mingw'c
343 freopen (ly_scm2string (file_name
).c_str (), m
.c_str (), stderr
);
344 return SCM_UNSPECIFIED
;
348 accumulate_symbol (void * /* closure */,
353 return scm_cons (key
, result
);
356 LY_DEFINE (ly_hash_table_keys
, "ly:hash-table-keys",
358 "Return a list of keys in @var{tab}.")
360 return scm_internal_hash_fold ((Hash_closure_function
) & accumulate_symbol
,
364 LY_DEFINE (ly_camel_case_2_lisp_identifier
, "ly:camel-case->lisp-identifier",
365 1, 0, 0, (SCM name_sym
),
366 "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
368 LY_ASSERT_TYPE (ly_is_symbol
, name_sym
, 1);
371 TODO: should use strings instead?
374 const string in
= ly_symbol2string (name_sym
);
375 string result
= camel_case_to_lisp_identifier (in
);
377 return ly_symbol2scm (result
.c_str ());
380 LY_DEFINE (ly_expand_environment
, "ly:expand-environment",
382 "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
384 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
386 return ly_string2scm (expand_environment_variables (ly_scm2string (str
)));
390 LY_DEFINE (ly_truncate_list_x
, "ly:truncate-list!",
391 2, 0, 0, (SCM lst
, SCM i
),
392 "Take at most the first @var{i} of list @var{lst}.")
394 LY_ASSERT_TYPE (scm_is_integer
, i
, 1);
396 int k
= scm_to_int (i
);
403 for (; scm_is_pair (s
) && k
--; s
= scm_cdr (s
))
407 scm_set_cdr_x (s
, SCM_EOL
);
413 format_single_argument (SCM arg
, int precision
)
415 if (scm_is_integer (arg
) && scm_exact_p (arg
) == SCM_BOOL_T
)
416 return (String_convert::int_string (scm_to_int (arg
)));
417 else if (scm_is_number (arg
))
419 Real val
= scm_to_double (arg
);
421 if (isnan (val
) || isinf (val
))
423 warning (_ ("Found infinity or nan in output. Substituting 0.0"));
425 if (strict_infinity_checking
)
429 return (String_convert::form_string ("%.*lf", precision
, val
));
431 else if (scm_is_string (arg
))
432 return (ly_scm2string (arg
));
433 else if (scm_is_symbol (arg
))
434 return (ly_symbol2string (arg
));
437 ly_progress (scm_from_locale_string ("Unsupported SCM value for format: ~a"),
445 LY_DEFINE (ly_format
, "ly:format",
446 1, 0, 1, (SCM str
, SCM rest
),
447 "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}.")
449 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
451 string format
= ly_scm2string (str
);
452 vector
<string
> results
;
455 while (i
< format
.size ())
457 vsize tilde
= format
.find ('~', i
);
459 results
.push_back (format
.substr (i
, (tilde
-i
)));
466 char spec
= format
.at (tilde
++);
468 results
.push_back ("~");
471 if (!scm_is_pair (rest
))
473 programming_error (string (__FUNCTION__
)
474 + ": not enough arguments for format.");
475 return ly_string2scm ("");
478 SCM arg
= scm_car (rest
);
479 rest
= scm_cdr (rest
);
485 else if (isdigit (spec
))
487 precision
= spec
- '0';
488 spec
= format
.at (tilde
++);
491 if (spec
== 'a' || spec
== 'A' || spec
== 'f' || spec
== '$')
492 results
.push_back (format_single_argument (arg
, precision
));
493 else if (spec
== 'l')
496 for (; scm_is_pair (s
); s
= scm_cdr (s
))
498 results
.push_back (format_single_argument (scm_car (s
), precision
));
499 if (scm_cdr (s
) != SCM_EOL
)
500 results
.push_back (" ");
504 results
.push_back (format_single_argument (s
, precision
));
512 if (scm_is_pair (rest
))
513 programming_error (string (__FUNCTION__
)
514 + ": too many arguments");
517 for (vsize i
= 0; i
< results
.size (); i
++)
518 len
+= results
[i
].size ();
520 char *result
= (char*) scm_malloc (len
+ 1);
522 for (vsize i
= 0; i
< results
.size (); i
++)
524 strncpy (ptr
, results
[i
].c_str (), results
[i
].size ());
525 ptr
+= results
[i
].size ();
529 return scm_take_locale_stringn (result
, len
);