2 lily-guile.cc -- implement assorted Guile bindings
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>
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
, string (scm_i_string_chars (a
)),
184 string (scm_i_string_chars (b
)));
185 return ly_string2scm (ss
);
188 LY_DEFINE (ly_number_2_string
, "ly:number->string",
190 "Convert @var{num} to a string without generating many decimals.")
192 LY_ASSERT_TYPE (scm_is_number
, s
, 1);
194 char str
[400]; // ugh.
196 if (scm_exact_p (s
) == SCM_BOOL_F
)
198 Real
r (scm_to_double (s
));
199 if (isinf (r
) || isnan (r
))
201 programming_error (_ ("infinity or NaN encountered while converting Real number"));
202 programming_error (_ ("setting to zero"));
207 snprintf (str
, sizeof (str
), "%.4f", r
);
210 snprintf (str
, sizeof (str
), "%d", int (scm_to_int (s
)));
212 return scm_from_locale_string (str
);
215 LY_DEFINE (ly_version
, "ly:version", 0, 0, 0, (),
216 "Return the current lilypond version as a list, e.g.,"
217 " @code{(1 3 127 uu1)}.")
219 char const *vs
= "\'(" MAJOR_VERSION
" " MINOR_VERSION
" " PATCH_LEVEL
" " MY_PATCH_LEVEL
")";
221 return scm_c_eval_string ((char *)vs
);
224 LY_DEFINE (ly_unit
, "ly:unit", 0, 0, 0, (),
225 "Return the unit used for lengths as a string.")
227 return scm_from_locale_string (INTERNAL_UNIT
);
230 LY_DEFINE (ly_dimension_p
, "ly:dimension?", 1, 0, 0, (SCM d
),
231 "Return @var{d} as a number. Used to distinguish length"
232 " variables from normal numbers.")
234 return scm_number_p (d
);
240 LY_DEFINE (ly_protects
, "ly:protects",
242 "Return hash of protected objects.")
247 LY_DEFINE (ly_gettext
, "ly:gettext",
248 1, 0, 0, (SCM string
),
249 "A Scheme wrapper function for @code{gettext}.")
251 LY_ASSERT_TYPE (scm_is_string
, string
, 1);
252 return ly_string2scm (_ (scm_i_string_chars (string
)));
255 LY_DEFINE (ly_output_formats
, "ly:output-formats",
257 "Formats passed to @option{--format} as a list of strings,"
258 " used for the output.")
260 vector
<string
> output_formats
= string_split (output_format_global
, ',');
263 int output_formats_count
= output_formats
.size ();
264 for (int i
= 0; i
< output_formats_count
; i
++)
265 lst
= scm_cons (ly_string2scm (output_formats
[i
]), lst
);
270 LY_DEFINE (ly_wide_char_2_utf_8
, "ly:wide-char->utf-8",
272 "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
276 LY_ASSERT_TYPE (scm_is_integer
, wc
, 1);
277 unsigned wide_char
= (unsigned) scm_to_int (wc
);
280 if (wide_char
< 0x0080)
281 *p
++ = (char)wide_char
;
282 else if (wide_char
< 0x0800)
284 *p
++ = (char) (((wide_char
>> 6)) | 0xC0);
285 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
287 else if (wide_char
< 0x10000)
289 *p
++ = (char) (((wide_char
>> 12)) | 0xE0);
290 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
291 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
295 *p
++ = (char) (((wide_char
>> 18)) | 0xF0);
296 *p
++ = (char) (((wide_char
>> 12) & 0x3F) | 0x80);
297 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
298 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
302 return scm_from_locale_string (buf
);
305 LY_DEFINE (ly_effective_prefix
, "ly:effective-prefix",
307 "Return effective prefix.")
309 return ly_string2scm (lilypond_datadir
);
312 LY_DEFINE (ly_chain_assoc_get
, "ly:chain-assoc-get",
313 2, 1, 0, (SCM key
, SCM achain
, SCM dfault
),
314 "Return value for @var{key} from a list of alists @var{achain}."
315 " If no entry is found, return @var{dfault} or @code{#f} if no"
316 " @var{dfault} is specified.")
318 if (scm_is_pair (achain
))
320 SCM handle
= scm_assoc (key
, scm_car (achain
));
321 if (scm_is_pair (handle
))
322 return scm_cdr (handle
);
324 return ly_chain_assoc_get (key
, scm_cdr (achain
), dfault
);
326 return dfault
== SCM_UNDEFINED
? SCM_BOOL_F
: dfault
;
330 LY_DEFINE (ly_stderr_redirect
, "ly:stderr-redirect",
331 1, 1, 0, (SCM file_name
, SCM mode
),
332 "Redirect stderr to @var{file-name}, opened with @var{mode}.")
334 LY_ASSERT_TYPE (scm_is_string
, file_name
, 1);
337 if (mode
!= SCM_UNDEFINED
&& scm_string_p (mode
))
338 m
= ly_scm2string (mode
);
339 /* dup2 and (fileno (current-error-port)) do not work with mingw'c
342 freopen (ly_scm2string (file_name
).c_str (), m
.c_str (), stderr
);
343 return SCM_UNSPECIFIED
;
347 accumulate_symbol (void *closure
, SCM key
, SCM val
, SCM result
)
351 return scm_cons (key
, result
);
354 LY_DEFINE (ly_hash_table_keys
, "ly:hash-table-keys",
356 "Return a list of keys in @var{tab}.")
358 return scm_internal_hash_fold ((Hash_closure_function
) & accumulate_symbol
,
362 LY_DEFINE (ly_camel_case_2_lisp_identifier
, "ly:camel-case->lisp-identifier",
363 1, 0, 0, (SCM name_sym
),
364 "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
366 LY_ASSERT_TYPE (ly_is_symbol
, name_sym
, 1);
369 TODO: should use strings instead?
372 const string in
= ly_symbol2string (name_sym
);
373 string result
= camel_case_to_lisp_identifier (in
);
375 return ly_symbol2scm (result
.c_str ());
378 LY_DEFINE (ly_expand_environment
, "ly:expand-environment",
380 "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
382 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
384 return ly_string2scm (expand_environment_variables (ly_scm2string (str
)));
388 LY_DEFINE (ly_truncate_list_x
, "ly:truncate-list!",
389 2, 0, 0, (SCM lst
, SCM i
),
390 "Take at most the first @var{i} of list @var{lst}.")
392 LY_ASSERT_TYPE (scm_is_integer
, i
, 1);
394 int k
= scm_to_int (i
);
401 for (; scm_is_pair (s
) && k
--; s
= scm_cdr (s
))
405 scm_set_cdr_x (s
, SCM_EOL
);
411 format_single_argument (SCM arg
, int precision
)
413 if (scm_is_integer (arg
) && scm_exact_p (arg
) == SCM_BOOL_T
)
414 return (String_convert::int_string (scm_to_int (arg
)));
415 else if (scm_is_number (arg
))
417 Real val
= scm_to_double (arg
);
419 if (isnan (val
) || isinf (val
))
421 warning (_ ("Found infinity or nan in output. Substituting 0.0"));
423 if (strict_infinity_checking
)
427 return (String_convert::form_string ("%.*lf", precision
, val
));
429 else if (scm_is_string (arg
))
430 return (ly_scm2string (arg
));
431 else if (scm_is_symbol (arg
))
432 return (ly_symbol2string (arg
));
435 ly_progress (scm_from_locale_string ("Unsupported SCM value for format: ~a"),
443 LY_DEFINE (ly_format
, "ly:format",
444 1, 0, 1, (SCM str
, SCM rest
),
445 "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}.")
447 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
449 string format
= ly_scm2string (str
);
450 vector
<string
> results
;
453 while (i
< format
.size ())
455 vsize tilde
= format
.find ('~', i
);
457 results
.push_back (format
.substr (i
, (tilde
-i
)));
464 char spec
= format
.at (tilde
++);
466 results
.push_back ("~");
469 if (!scm_is_pair (rest
))
471 programming_error (string (__FUNCTION__
)
472 + ": not enough arguments for format.");
473 return ly_string2scm ("");
476 SCM arg
= scm_car (rest
);
477 rest
= scm_cdr (rest
);
483 else if (isdigit (spec
))
485 precision
= spec
- '0';
486 spec
= format
.at (tilde
++);
489 if (spec
== 'a' || spec
== 'A' || spec
== 'f' || spec
== '$')
490 results
.push_back (format_single_argument (arg
, precision
));
491 else if (spec
== 'l')
494 for (; scm_is_pair (s
); s
= scm_cdr (s
))
496 results
.push_back (format_single_argument (scm_car (s
), precision
));
497 if (scm_cdr (s
) != SCM_EOL
)
498 results
.push_back (" ");
502 results
.push_back (format_single_argument (s
, precision
));
510 if (scm_is_pair (rest
))
511 programming_error (string (__FUNCTION__
)
512 + ": too many arguments");
515 for (vsize i
= 0; i
< results
.size (); i
++)
516 len
+= results
[i
].size ();
518 char *result
= (char*) scm_malloc (len
+ 1);
520 for (vsize i
= 0; i
< results
.size (); i
++)
522 strncpy (ptr
, results
[i
].c_str (), results
[i
].size ());
523 ptr
+= results
[i
].size ();
527 return scm_take_locale_stringn (result
, len
);