2 lily-guile.cc -- implement assorted Guile bindings
4 source file of the GNU LilyPond music typesetter
6 (c) 1998--2005 Jan Nieuwenhuizen <janneke@gnu.org>
7 Han-Wen Nienhuys <hanwen@cs.uu.nl>
12 #include <math.h> /* isinf */
14 #include <string.h> /* memset */
16 #include "international.hh"
17 #include "libc-extension.hh"
18 #include "lily-guile.hh"
23 #include "dimensions.hh"
25 #include "file-path.hh"
28 source-file.hh includes cmath which undefines isinf and isnan
31 inline int my_isinf (Real r
) { return isinf (r
); }
32 inline int my_isnan (Real r
) { return isnan (r
); }
35 LY_DEFINE (ly_find_file
, "ly:find-file",
37 "Return the absolute file name of @var{name}, "
38 "or @code{#f} if not found.")
40 SCM_ASSERT_TYPE (scm_is_string (name
), name
, SCM_ARG1
, __FUNCTION__
, "string");
42 String nm
= ly_scm2string (name
);
43 String file_name
= global_path
.find (nm
);
44 if (file_name
.is_empty ())
47 return scm_makfrom0str (file_name
.to_str0 ());
51 Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
54 LY_DEFINE (ly_gulp_file
, "ly:gulp-file",
56 "Read the file @var{name}, and return its contents in a string. "
57 "The file is looked up using the search path.")
59 SCM_ASSERT_TYPE (scm_is_string (name
), name
, SCM_ARG1
, __FUNCTION__
, "string");
60 String contents
= gulp_file_to_string (ly_scm2string (name
), true);
61 return scm_from_locale_stringn (contents
.get_str0 (), contents
.length ());
64 LY_DEFINE (ly_error
, "ly:error",
65 1, 0, 1, (SCM str
, SCM rest
),
66 "Scheme callable function to issue the error @code{msg}. "
67 "The error is formatted with @code{format} and @code{rest}.")
69 SCM_ASSERT_TYPE (scm_is_string (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
70 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
71 error (ly_scm2string (str
));
72 return SCM_UNSPECIFIED
;
75 LY_DEFINE (ly_message
, "ly:message",
76 1, 0, 1, (SCM str
, SCM rest
),
77 "Scheme callable function to issue the message @code{msg}. "
78 "The message is formatted with @code{format} and @code{rest}.")
80 SCM_ASSERT_TYPE (scm_is_string (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
81 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
82 message (ly_scm2string (str
));
83 return SCM_UNSPECIFIED
;
86 LY_DEFINE (ly_progress
, "ly:progress",
87 1, 0, 1, (SCM str
, SCM rest
),
88 "Scheme callable function to print progress @code{str}. "
89 "The message is formatted with @code{format} and @code{rest}.")
91 SCM_ASSERT_TYPE (scm_is_string (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
92 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
93 progress_indication (ly_scm2string (str
));
94 return SCM_UNSPECIFIED
;
97 LY_DEFINE (ly_programming_error
, "ly:programming-error",
98 1, 0, 1, (SCM str
, SCM rest
),
99 "Scheme callable function to issue the warning @code{msg}. "
100 "The message is formatted with @code{format} and @code{rest}.")
102 SCM_ASSERT_TYPE (scm_is_string (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
103 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
104 programming_error (ly_scm2string (str
));
105 return SCM_UNSPECIFIED
;
108 LY_DEFINE (ly_warning
, "ly:warning",
109 1, 0, 1, (SCM str
, SCM rest
),
110 "Scheme callable function to issue the warning @code{str}. "
111 "The message is formatted with @code{format} and @code{rest}.")
113 SCM_ASSERT_TYPE (scm_is_string (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
114 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
115 warning (ly_scm2string (str
));
116 return SCM_UNSPECIFIED
;
119 LY_DEFINE (ly_dir_p
, "ly:dir?",
121 "type predicate. A direction is @code{-1}, @code{0} or "
122 "@code{1}, where @code{-1} represents "
123 "left or down and @code{1} represents right or up.")
125 if (scm_is_number (s
))
127 int i
= scm_to_int (s
);
128 return (i
>= -1 && i
<= 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
133 LY_DEFINE (ly_assoc_get
, "ly:assoc-get",
135 (SCM key
, SCM alist
, SCM default_value
),
136 "Return value if KEY in ALIST, else DEFAULT-VALUE "
137 "(or #f if not specified).")
139 SCM handle
= scm_assoc (key
, alist
);
141 if (default_value
== SCM_UNDEFINED
)
142 default_value
= SCM_BOOL_F
;
144 if (scm_is_pair (handle
))
145 return scm_cdr (handle
);
146 return default_value
;
149 LY_DEFINE (ly_number2string
, "ly:number->string",
151 "Convert @var{num} to a string without generating many decimals.")
153 SCM_ASSERT_TYPE (scm_is_number (s
), s
, SCM_ARG1
, __FUNCTION__
, "number");
155 char str
[400]; // ugh.
157 if (scm_exact_p (s
) == SCM_BOOL_F
)
159 Real
r (scm_to_double (s
));
161 if (my_isinf (r
) || my_isnan (r
))
163 if (isinf (r
) || isnan (r
))
166 programming_error (_ ("infinity or NaN encountered while converting Real number"));
167 programming_error (_ ("setting to zero"));
172 snprintf (str
, sizeof (str
), "%08.4f", r
);
175 snprintf (str
, sizeof (str
), "%d", scm_to_int (s
));
177 return scm_makfrom0str (str
);
180 LY_DEFINE (ly_version
, "ly:version", 0, 0, 0, (),
181 "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
183 char const *vs
= "\'(" MAJOR_VERSION
" " MINOR_VERSION
" " PATCH_LEVEL
" " MY_PATCH_LEVEL
")";
185 return scm_c_eval_string ((char *)vs
);
188 LY_DEFINE (ly_unit
, "ly:unit", 0, 0, 0, (),
189 "Return the unit used for lengths as a string.")
191 return scm_makfrom0str (INTERNAL_UNIT
);
194 LY_DEFINE (ly_dimension_p
, "ly:dimension?", 1, 0, 0, (SCM d
),
195 "Return @var{d} is a number. Used to distinguish length "
196 "variables from normal numbers.")
198 return scm_number_p (d
);
204 LY_DEFINE (ly_protects
, "ly:protects",
206 "Return hash of protected objects.")
211 LY_DEFINE (ly_gettext
, "ly:gettext",
212 1, 0, 0, (SCM string
),
215 SCM_ASSERT_TYPE (scm_is_string (string
), string
, SCM_ARG1
,
216 __FUNCTION__
, "string");
217 return scm_makfrom0str (_ (scm_i_string_chars (string
)).to_str0 ());
220 LY_DEFINE (ly_output_backend
, "ly:output-backend",
222 "Return name of output backend.")
224 return scm_makfrom0str (output_backend_global
.to_str0 ());
227 LY_DEFINE (ly_output_formats
, "ly:output-formats",
229 "Formats passed to --format as a list of strings, "
230 "used for the output.")
232 Array
<String
> output_formats
= split_string (output_format_global
, ',');
235 int output_formats_count
= output_formats
.size ();
236 for (int i
= 0; i
< output_formats_count
; i
++)
237 lst
= scm_cons (scm_makfrom0str (output_formats
[i
].to_str0 ()), lst
);
242 LY_DEFINE (ly_wchar_to_utf_8
, "ly:wide-char->utf-8",
244 "Encode the Unicode codepoint @var{wc} as UTF-8")
248 SCM_ASSERT_TYPE (scm_is_integer (wc
), wc
, SCM_ARG1
, __FUNCTION__
, "integer");
249 unsigned wide_char
= (unsigned) scm_to_int (wc
);
252 if (wide_char
< 0x0080)
254 *p
++ = (char)wide_char
;
256 else if (wide_char
< 0x0800)
258 *p
++ = (char) (((wide_char
>> 6)) | 0xC0);
259 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
261 else if (wide_char
< 0x10000)
263 *p
++ = (char) (((wide_char
>> 12)) | 0xE0);
264 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
265 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
269 *p
++ = (char) (((wide_char
>> 18)) | 0xF0);
270 *p
++ = (char) (((wide_char
>> 12) & 0x3F) | 0x80);
271 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
272 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
276 return scm_makfrom0str (buf
);
279 LY_DEFINE (ly_effective_prefix
, "ly:effective-prefix",
281 "Return effective prefix.")
283 return scm_makfrom0str (prefix_directory
.to_str0 ());
286 LY_DEFINE (ly_chain_assoc_get
, "ly:chain-assoc-get",
287 2, 1, 0, (SCM key
, SCM achain
, SCM dfault
),
288 "Return value for @var{key} from a list of alists @var{achain}. "
289 "If no if no entry is found, return DFAULT, "
290 "or #f if no DFAULT not specified.")
292 if (scm_is_pair (achain
))
294 SCM handle
= scm_assoc (key
, scm_car (achain
));
295 if (scm_is_pair (handle
))
296 return scm_cdr (handle
);
298 return ly_chain_assoc_get (key
, scm_cdr (achain
), dfault
);
300 return dfault
== SCM_UNDEFINED
? SCM_BOOL_F
: dfault
;
303 LY_DEFINE (ly_stderr_redirect
, "ly:stderr-redirect",
304 1, 1, 0, (SCM file_name
, SCM mode
),
305 "Redirect stderr to FILE-NAME, opened with MODE.")
307 SCM_ASSERT_TYPE (scm_string_p (file_name
), file_name
, SCM_ARG1
,
308 __FUNCTION__
, "file_name");
310 if (mode
!= SCM_UNDEFINED
&& scm_string_p (mode
))
311 m
= ly_scm2newstr (mode
, 0);
312 /* dup2 and (fileno (current-error-port)) do not work with mingw'c
314 freopen (ly_scm2newstr (file_name
, 0), m
, stderr
);
315 return SCM_UNSPECIFIED
;