2 lily-guile.cc -- implement assorted Guile bindings
4 source file of the GNU LilyPond music typesetter
6 (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
7 Han-Wen Nienhuys <hanwen@xs4all.nl>
13 #include <cstring> /* memset */
16 #include "international.hh"
17 #include "libc-extension.hh"
18 #include "lily-guile.hh"
22 #include "dimensions.hh"
24 #include "file-path.hh"
26 LY_DEFINE (ly_find_file, "ly:find-file",
28 "Return the absolute file name of @var{name}, "
29 "or @code{#f} if not found.")
31 SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
33 string nm = ly_scm2string (name);
34 string file_name = global_path.find (nm);
35 if (file_name.empty ())
38 return scm_makfrom0str (file_name.c_str ());
42 Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
45 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
46 1, 1, 0, (SCM name, SCM size),
47 "Read the file @var{name}, and return its contents in a string. "
48 "The file is looked up using the search path. ")
50 SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
52 if (size != SCM_UNDEFINED)
54 SCM_ASSERT_TYPE (scm_is_number (size), size, SCM_ARG2, __FUNCTION__, "number");
55 sz = scm_to_int (size);
58 string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
59 return scm_from_locale_stringn (contents.c_str (), contents.length ());
62 LY_DEFINE (ly_error, "ly:error",
63 1, 0, 1, (SCM str, SCM rest),
64 "Scheme callable function to issue the error @code{msg}. "
65 "The error is formatted with @code{format} and @code{rest}.")
67 SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
68 str = scm_simple_format (SCM_BOOL_F, str, rest);
69 error (ly_scm2string (str));
70 return SCM_UNSPECIFIED;
73 LY_DEFINE (ly_message, "ly:message",
74 1, 0, 1, (SCM str, SCM rest),
75 "Scheme callable function to issue the message @code{msg}. "
76 "The message is formatted with @code{format} and @code{rest}.")
78 SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
79 str = scm_simple_format (SCM_BOOL_F, str, rest);
80 message (ly_scm2string (str));
81 return SCM_UNSPECIFIED;
84 LY_DEFINE (ly_progress, "ly:progress",
85 1, 0, 1, (SCM str, SCM rest),
86 "Scheme callable function to print progress @code{str}. "
87 "The message is formatted with @code{format} and @code{rest}.")
89 SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
90 str = scm_simple_format (SCM_BOOL_F, str, rest);
91 progress_indication (ly_scm2string (str));
92 return SCM_UNSPECIFIED;
95 LY_DEFINE (ly_programming_error, "ly:programming-error",
96 1, 0, 1, (SCM str, SCM rest),
97 "Scheme callable function to issue the warning @code{msg}. "
98 "The message is formatted with @code{format} and @code{rest}.")
100 SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
101 str = scm_simple_format (SCM_BOOL_F, str, rest);
102 programming_error (ly_scm2string (str));
103 return SCM_UNSPECIFIED;
106 LY_DEFINE (ly_warning, "ly:warning",
107 1, 0, 1, (SCM str, SCM rest),
108 "Scheme callable function to issue the warning @code{str}. "
109 "The message is formatted with @code{format} and @code{rest}.")
111 SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
112 str = scm_simple_format (SCM_BOOL_F, str, rest);
113 warning (ly_scm2string (str));
114 return SCM_UNSPECIFIED;
117 LY_DEFINE (ly_dir_p, "ly:dir?",
119 "type predicate. A direction is @code{-1}, @code{0} or "
120 "@code{1}, where @code{-1} represents "
121 "left or down and @code{1} represents right or up.")
123 if (scm_is_number (s))
125 int i = scm_to_int (s);
126 return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
131 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
133 (SCM key, SCM alist, SCM default_value),
134 "Return value if KEY in ALIST, else DEFAULT-VALUE "
135 "(or #f if not specified).")
137 SCM handle = scm_assoc (key, alist);
139 if (default_value == SCM_UNDEFINED)
140 default_value = SCM_BOOL_F;
142 if (scm_is_pair (handle))
143 return scm_cdr (handle);
144 return default_value;
147 LY_DEFINE (ly_number2string, "ly:number->string",
149 "Convert @var{num} to a string without generating many decimals.")
151 SCM_ASSERT_TYPE (scm_is_number (s), s, SCM_ARG1, __FUNCTION__, "number");
153 char str[400]; // ugh.
155 if (scm_exact_p (s) == SCM_BOOL_F)
157 Real r (scm_to_double (s));
158 if (isinf (r) || isnan (r))
160 programming_error (_ ("infinity or NaN encountered while converting Real number"));
161 programming_error (_ ("setting to zero"));
166 snprintf (str, sizeof (str), "%08.4f", r);
169 snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
171 return scm_makfrom0str (str);
174 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
175 "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
177 char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
179 return scm_c_eval_string ((char *)vs);
182 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
183 "Return the unit used for lengths as a string.")
185 return scm_makfrom0str (INTERNAL_UNIT);
188 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
189 "Return @var{d} is a number. Used to distinguish length "
190 "variables from normal numbers.")
192 return scm_number_p (d);
198 LY_DEFINE (ly_protects, "ly:protects",
200 "Return hash of protected objects.")
205 LY_DEFINE (ly_gettext, "ly:gettext",
206 1, 0, 0, (SCM string),
209 SCM_ASSERT_TYPE (scm_is_string (string), string, SCM_ARG1,
210 __FUNCTION__, "string");
211 return scm_makfrom0str (_ (scm_i_string_chars (string)).c_str ());
214 LY_DEFINE (ly_output_backend, "ly:output-backend",
216 "Return name of output backend.")
218 return scm_makfrom0str (output_backend_global.c_str ());
221 LY_DEFINE (ly_output_formats, "ly:output-formats",
223 "Formats passed to --format as a list of strings, "
224 "used for the output.")
226 vector<string> output_formats = string_split (output_format_global, ',');
229 int output_formats_count = output_formats.size ();
230 for (int i = 0; i < output_formats_count; i++)
231 lst = scm_cons (scm_makfrom0str (output_formats[i].c_str ()), lst);
236 LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
238 "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8")
242 SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
243 unsigned wide_char = (unsigned) scm_to_int (wc);
246 if (wide_char < 0x0080)
247 *p++ = (char)wide_char;
248 else if (wide_char < 0x0800)
250 *p++ = (char) (((wide_char >> 6)) | 0xC0);
251 *p++ = (char) (((wide_char) & 0x3F) | 0x80);
253 else if (wide_char < 0x10000)
255 *p++ = (char) (((wide_char >> 12)) | 0xE0);
256 *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
257 *p++ = (char) (((wide_char) & 0x3F) | 0x80);
261 *p++ = (char) (((wide_char >> 18)) | 0xF0);
262 *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
263 *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
264 *p++ = (char) (((wide_char) & 0x3F) | 0x80);
268 return scm_makfrom0str (buf);
271 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
273 "Return effective prefix.")
275 return scm_makfrom0str (prefix_directory.c_str ());
278 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
279 2, 1, 0, (SCM key, SCM achain, SCM dfault),
280 "Return value for @var{key} from a list of alists @var{achain}. "
281 "If no if no entry is found, return DFAULT, "
282 "or #f if no DFAULT not specified.")
284 if (scm_is_pair (achain))
286 SCM handle = scm_assoc (key, scm_car (achain));
287 if (scm_is_pair (handle))
288 return scm_cdr (handle);
290 return ly_chain_assoc_get (key, scm_cdr (achain), dfault);
292 return dfault == SCM_UNDEFINED ? SCM_BOOL_F : dfault;
295 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
296 1, 1, 0, (SCM file_name, SCM mode),
297 "Redirect stderr to FILE-NAME, opened with MODE.")
299 SCM_ASSERT_TYPE (scm_string_p (file_name), file_name, SCM_ARG1,
300 __FUNCTION__, "file_name");
302 if (mode != SCM_UNDEFINED && scm_string_p (mode))
303 m = ly_scm2newstr (mode, 0);
304 /* dup2 and (fileno (current-error-port)) do not work with mingw'c
306 freopen (ly_scm2newstr (file_name, 0), m, stderr);
307 return SCM_UNSPECIFIED;
311 accumulate_symbol (void *closure, SCM key, SCM val, SCM result)
315 return scm_cons (key, result);
318 LY_DEFINE(ly_hash_table_keys, "ly:hash-table-keys",
320 "return a list of keys in @var{tab}")
322 return scm_internal_hash_fold ((Hash_closure_function) & accumulate_symbol,
326 LY_DEFINE (ly_camel_case_to_lisp_identifier, "ly:camel-case->lisp-identifier",
327 1, 0, 0, (SCM name_sym),
328 "Convert FooBar_Bla to foo-bar-bla style symbol.")
330 SCM_ASSERT_TYPE(scm_is_symbol (name_sym), name_sym,
331 SCM_ARG1, __FUNCTION__, "symbol");
334 TODO: should use strings instead?
337 const string in = ly_symbol2string (name_sym);
338 string result = camel_case_to_lisp_identifier (in);
340 return ly_symbol2scm (result.c_str ());