]> git.donarmstrong.com Git - lilypond.git/blob - lily/general-scheme.cc
Merge branch 'lilypond/translation' of ssh://git.sv.gnu.org/srv/git/lilypond
[lilypond.git] / lily / general-scheme.cc
1 /*
2   This file is part of LilyPond, the GNU music typesetter.
3
4   Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org>
5   Han-Wen Nienhuys <hanwen@xs4all.nl>
6
7   LilyPond is free software: you can redistribute it and/or modify
8   it under the terms of the GNU General Public License as published by
9   the Free Software Foundation, either version 3 of the License, or
10   (at your option) any later version.
11
12   LilyPond is distributed in the hope that it will be useful,
13   but WITHOUT ANY WARRANTY; without even the implied warranty of
14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15   GNU General Public License for more details.
16
17   You should have received a copy of the GNU General Public License
18   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
19 */
20
21 #include "config.hh"
22
23 #include <cstdio>
24 #include <ctype.h>
25 #include <cstring>  /* memset */
26 using namespace std;
27
28 #include "dimensions.hh"
29 #include "file-name.hh"
30 #include "file-path.hh"
31 #include "international.hh"
32 #include "libc-extension.hh"
33 #include "lily-guile.hh"
34 #include "main.hh"
35 #include "misc.hh"
36 #include "program-option.hh"
37 #include "relocate.hh"
38 #include "string-convert.hh"
39 #include "version.hh"
40 #include "warn.hh"
41
42 LY_DEFINE (ly_start_environment, "ly:start-environment",
43            0, 0, 0, (),
44            "Return the environment (a list of strings) that was in"
45            " effect at program start.")
46 {
47   SCM l = SCM_EOL;
48   SCM *tail = &l;
49
50   for (vsize i = 0; i < start_environment_global.size (); i++)
51     {
52       *tail = scm_cons (ly_string2scm (start_environment_global[i]),
53                         SCM_EOL);
54       tail = SCM_CDRLOC(*tail);
55     }
56
57   return l;
58 }
59
60
61 LY_DEFINE (ly_find_file, "ly:find-file",
62            1, 0, 0, (SCM name),
63            "Return the absolute file name of @var{name},"
64            " or @code{#f} if not found.")
65 {
66   LY_ASSERT_TYPE (scm_is_string, name, 1);
67
68   string nm = ly_scm2string (name);
69   string file_name = global_path.find (nm);
70   if (file_name.empty ())
71     return SCM_BOOL_F;
72
73   return ly_string2scm (file_name);
74 }
75
76 /*
77   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
78   buffering.)
79 */
80 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
81            1, 1, 0, (SCM name, SCM size),
82            "Read the file @var{name}, and return its contents in a string."
83            "  The file is looked up using the search path.")
84 {
85   LY_ASSERT_TYPE (scm_is_string, name, 1);
86   int sz = INT_MAX;
87   if (size != SCM_UNDEFINED)
88     {
89       LY_ASSERT_TYPE (scm_is_number, size, 2);
90       sz = scm_to_int (size);
91     }
92
93   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
94   return scm_from_locale_stringn (contents.c_str (), contents.length ());
95 }
96
97 LY_DEFINE (ly_error, "ly:error",
98            1, 0, 1, (SCM str, SCM rest),
99            "A Scheme callable function to issue the error @var{str}."
100            "  The error is formatted with @code{format} and @var{rest}.")
101 {
102   LY_ASSERT_TYPE (scm_is_string, str, 1);
103   str = scm_simple_format (SCM_BOOL_F, str, rest);
104   error (ly_scm2string (str));
105   return SCM_UNSPECIFIED;
106 }
107
108 LY_DEFINE (ly_message, "ly:message",
109            1, 0, 1, (SCM str, SCM rest),
110            "A Scheme callable function to issue the message @var{str}."
111            "  The message is formatted with @code{format} and @var{rest}.")
112 {
113   LY_ASSERT_TYPE (scm_is_string, str, 1);
114   str = scm_simple_format (SCM_BOOL_F, str, rest);
115   message (ly_scm2string (str));
116   return SCM_UNSPECIFIED;
117 }
118
119 LY_DEFINE (ly_progress, "ly:progress",
120            1, 0, 1, (SCM str, SCM rest),
121            "A Scheme callable function to print progress @var{str}."
122            "  The message is formatted with @code{format} and @var{rest}.")
123 {
124   LY_ASSERT_TYPE (scm_is_string, str, 1);
125   str = scm_simple_format (SCM_BOOL_F, str, rest);
126   progress_indication (ly_scm2string (str));
127   return SCM_UNSPECIFIED;
128 }
129
130 LY_DEFINE (ly_programming_error, "ly:programming-error",
131            1, 0, 1, (SCM str, SCM rest),
132            "A Scheme callable function to issue the internal warning"
133            "  @var{str}.  The message is formatted with @code{format}"
134            " and @var{rest}.")
135 {
136   LY_ASSERT_TYPE (scm_is_string, str, 1);
137   str = scm_simple_format (SCM_BOOL_F, str, rest);
138
139   if (get_program_option ("warning-as-error"))
140     error (ly_scm2string (str));
141   else
142     programming_error (ly_scm2string (str));
143
144   return SCM_UNSPECIFIED;
145 }
146
147 LY_DEFINE (ly_warning, "ly:warning",
148            1, 0, 1, (SCM str, SCM rest),
149            "A Scheme callable function to issue the warning @code{str}."
150            "  The message is formatted with @code{format} and @code{rest}.")
151 {
152   LY_ASSERT_TYPE (scm_is_string, str, 1);
153   str = scm_simple_format (SCM_BOOL_F, str, rest);
154
155   if (get_program_option ("warning-as-error"))
156     error (ly_scm2string (str));
157   else
158     warning (ly_scm2string (str));
159
160   return SCM_UNSPECIFIED;
161 }
162
163 LY_DEFINE (ly_dir_p, "ly:dir?",
164            1, 0, 0, (SCM s),
165            "Is @var{s} a direction?  Valid directions are @code{-1},"
166            " @code{0}, or@tie{}@code{1}, where @code{-1} represents"
167            " left or down, @code{1}@tie{}represents right or up, and @code{0}"
168            " represents a neutral direction.")
169 {
170   if (scm_is_number (s))
171     {
172       int i = scm_to_int (s);
173       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
174     }
175   return SCM_BOOL_F;
176 }
177
178 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
179            2, 2, 0,
180            (SCM key, SCM alist, SCM default_value, SCM strict_checking),
181            "Return value if @var{key} in @var{alist}, else @var{default-value}"
182            " (or @code{#f} if not specified).  If @var{strict-checking} is set"
183            " to @code{#t} and @var{key} is not in @var{alist}, a programming_error"
184            " is output.")
185 {
186   LY_ASSERT_TYPE(ly_cheap_is_list, alist, 2);
187
188   SCM handle = scm_assoc (key, alist);
189   if (scm_is_pair (handle))
190     return scm_cdr (handle);
191
192   if (default_value == SCM_UNDEFINED)
193     default_value = SCM_BOOL_F;
194
195   if (strict_checking == SCM_BOOL_T)
196     {
197       string key_string = ly_scm2string
198                             (scm_object_to_string (key, SCM_UNDEFINED));
199       string default_value_string = ly_scm2string
200                                       (scm_object_to_string (default_value,
201                                                              SCM_UNDEFINED));
202       programming_error ("Cannot find key `" +
203                          key_string +
204                          "' in alist, setting to `" +
205                          default_value_string + "'.");
206     }
207
208   return default_value;
209 }
210
211 LY_DEFINE (ly_string_substitute, "ly:string-substitute",
212            3, 0, 0, (SCM a, SCM b, SCM s),
213            "Replace string@tie{}@var{a} by string@tie{}@var{b} in"
214            " string@tie{}@var{s}.")
215 {
216   LY_ASSERT_TYPE (scm_is_string, s, 1);
217   LY_ASSERT_TYPE (scm_is_string, b, 2);
218   LY_ASSERT_TYPE (scm_is_string, s, 3);
219
220   string ss = ly_scm2string (s);
221   replace_all (&ss, ly_scm2string (a),
222                ly_scm2string (b));
223
224   return ly_string2scm (ss);
225 }
226
227 bool
228 is_not_escape_character (Byte c)
229 {
230   switch (c)
231     {
232     case '-':
233     case '.':
234     case '/':
235     case '0'...'9':
236     case 'A'...'Z':
237     case '_':
238     case 'a'...'z':
239       return true;
240     }
241
242   return false;
243 }
244
245 LY_DEFINE (ly_string_percent_encode, "ly:string-percent-encode",
246            1, 0, 0, (SCM str),
247            "Encode all characters in string @var{str} with hexadecimal"
248            " percent escape sequences, with the following exceptions:"
249            " characters @code{-}, @code{.}, @code{/}, and @code{_}; and"
250            " characters in ranges @code{0-9}, @code{A-Z}, and @code{a-z}.")
251 {
252   LY_ASSERT_TYPE (scm_is_string, str, 1);
253
254   string orig_str = ly_scm2string (str);
255   string new_str = "";
256
257   vsize i = 0;
258   vsize n = orig_str.size ();
259
260   while (i < n)
261     {
262       Byte cur = orig_str[i];
263
264       if (is_not_escape_character (cur))
265         new_str += cur;
266       else
267         {
268           new_str += '%';
269           new_str += String_convert::bin2hex (cur);
270         }
271
272       i++;
273     }
274
275   return ly_string2scm (new_str);
276 }
277
278 LY_DEFINE (ly_number_2_string, "ly:number->string",
279            1, 0, 0, (SCM s),
280            "Convert @var{num} to a string without generating many decimals.")
281 {
282   LY_ASSERT_TYPE (scm_is_number, s, 1);
283
284   char str[400];                        // ugh.
285
286   if (scm_exact_p (s) == SCM_BOOL_F)
287     {
288       Real r (scm_to_double (s));
289         if (isinf (r) || isnan (r))
290           {
291             programming_error (_ ("infinity or NaN encountered while converting Real number"));
292             programming_error (_ ("setting to zero"));
293
294             r = 0.0;
295           }
296
297       snprintf (str, sizeof (str), "%.4f", r);
298     }
299   else
300     snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
301
302   return scm_from_locale_string (str);
303 }
304
305 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
306            "Return the current lilypond version as a list, e.g.,"
307            " @code{(1 3 127 uu1)}.")
308 {
309   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
310
311   return scm_c_eval_string ((char *)vs);
312 }
313
314 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
315            "Return the unit used for lengths as a string.")
316 {
317   return scm_from_locale_string (INTERNAL_UNIT);
318 }
319
320 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
321            "Return @var{d} as a number.  Used to distinguish length"
322            " variables from normal numbers.")
323 {
324   return scm_number_p (d);
325 }
326
327 /*
328   Debugging mem leaks:
329 */
330 LY_DEFINE (ly_protects, "ly:protects",
331            0, 0, 0, (),
332            "Return hash of protected objects.")
333 {
334   return scm_protects;
335 }
336
337 LY_DEFINE (ly_gettext, "ly:gettext",
338            1, 0, 0, (SCM original),
339            "A Scheme wrapper function for @code{gettext}.")
340 {
341   LY_ASSERT_TYPE (scm_is_string, original, 1);
342   return ly_string2scm (_ (ly_scm2string (original).c_str ()));
343 }
344
345 LY_DEFINE (ly_output_formats, "ly:output-formats",
346            0, 0, 0, (),
347            "Formats passed to @option{--format} as a list of strings,"
348            " used for the output.")
349 {
350   vector<string> output_formats = string_split (output_format_global, ',');
351
352   SCM lst = SCM_EOL;
353   int output_formats_count = output_formats.size ();
354   for (int i = 0; i < output_formats_count; i++)
355     lst = scm_cons (ly_string2scm (output_formats[i]), lst);
356
357   return lst;
358 }
359
360 LY_DEFINE (ly_wide_char_2_utf_8, "ly:wide-char->utf-8",
361            1, 0, 0, (SCM wc),
362            "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
363 {
364   char buf[5];
365
366   LY_ASSERT_TYPE (scm_is_integer, wc, 1);
367   unsigned wide_char = (unsigned) scm_to_int (wc);
368   char *p = buf;
369
370   if (wide_char < 0x0080)
371     *p++ = (char)wide_char;
372   else if (wide_char < 0x0800)
373     {
374       *p++ = (char) (((wide_char >> 6)) | 0xC0);
375       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
376     }
377   else if (wide_char < 0x10000)
378     {
379       *p++ = (char) (((wide_char >> 12)) | 0xE0);
380       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
381       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
382     }
383   else
384     {
385       *p++ = (char) (((wide_char >> 18)) | 0xF0);
386       *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
387       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
388       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
389     }
390   *p = 0;
391
392   return scm_from_locale_string (buf);
393 }
394
395 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
396            0, 0, 0, (),
397            "Return effective prefix.")
398 {
399   return ly_string2scm (lilypond_datadir);
400 }
401
402 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
403            2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM strict_checking),
404            "Return value for @var{key} from a list of alists @var{achain}."
405            "  If no entry is found, return @var{default-value} or @code{#f} if"
406            " @var{default-value} is not specified.  With @var{strict-checking}"
407            " set to @code{#t}, a programming_error is output in such cases.")
408 {
409   if (scm_is_pair (achain))
410     {
411       SCM handle = scm_assoc (key, scm_car (achain));
412       if (scm_is_pair (handle))
413         return scm_cdr (handle);
414       else
415         return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
416     }
417
418   if (strict_checking == SCM_BOOL_T)
419     {
420       string key_string = ly_scm2string
421                             (scm_object_to_string (key, SCM_UNDEFINED));
422       string default_value_string = ly_scm2string
423                                       (scm_object_to_string (default_value,
424                                                              SCM_UNDEFINED));
425       programming_error ("Cannot find key `" +
426                          key_string +
427                          "' in achain, setting to `" +
428                          default_value_string + "'.");
429     }
430
431   return default_value == SCM_UNDEFINED ? SCM_BOOL_F : default_value;
432 }
433
434
435 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
436            1, 1, 0, (SCM file_name, SCM mode),
437            "Redirect stderr to @var{file-name}, opened with @var{mode}.")
438 {
439   LY_ASSERT_TYPE (scm_is_string, file_name, 1);
440
441   string m = "w";
442   if (mode != SCM_UNDEFINED && scm_string_p (mode))
443     m = ly_scm2string (mode);
444   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
445      gcc -mwindows.  */
446   fflush (stderr);
447   freopen (ly_scm2string (file_name).c_str (), m.c_str (), stderr);
448   return SCM_UNSPECIFIED;
449 }
450
451 static SCM
452 accumulate_symbol (void * /* closure */,
453                    SCM key,
454                    SCM /* val */,
455                    SCM result)
456 {
457   return scm_cons (key, result);
458 }
459
460 LY_DEFINE (ly_hash_table_keys, "ly:hash-table-keys",
461           1,0,0, (SCM tab),
462           "Return a list of keys in @var{tab}.")
463 {
464   return scm_internal_hash_fold ((Hash_closure_function) & accumulate_symbol,
465                                  NULL, SCM_EOL, tab);
466 }
467
468 LY_DEFINE (ly_camel_case_2_lisp_identifier, "ly:camel-case->lisp-identifier",
469            1, 0, 0, (SCM name_sym),
470            "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
471 {
472   LY_ASSERT_TYPE (ly_is_symbol, name_sym, 1);
473
474   /*
475     TODO: should use strings instead?
476   */
477
478   const string in = ly_symbol2string (name_sym);
479   string result = camel_case_to_lisp_identifier (in);
480
481   return ly_symbol2scm (result.c_str ());
482 }
483
484 LY_DEFINE (ly_expand_environment, "ly:expand-environment",
485            1, 0, 0, (SCM str),
486            "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
487 {
488   LY_ASSERT_TYPE (scm_is_string, str, 1);
489
490   return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
491 }
492
493
494 LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
495            2, 0, 0, (SCM lst, SCM i),
496            "Take at most the first @var{i} of list @var{lst}.")
497 {
498   LY_ASSERT_TYPE (scm_is_integer, i, 1);
499
500   int k = scm_to_int (i);
501   if (k == 0)
502     lst = SCM_EOL;
503   else
504     {
505       SCM s = lst;
506       k--;
507       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
508         ;
509
510       if (scm_is_pair (s))
511         scm_set_cdr_x (s, SCM_EOL);
512     }
513   return lst;
514 }
515
516 string
517 format_single_argument (SCM arg, int precision, bool escape = false)
518 {
519   if (scm_is_integer (arg) && scm_exact_p (arg) == SCM_BOOL_T)
520     return (String_convert::int_string (scm_to_int (arg)));
521   else if (scm_is_number (arg))
522     {
523       Real val = scm_to_double (arg);
524
525       if (isnan (val) || isinf (val))
526         {
527           warning (_ ("Found infinity or nan in output. Substituting 0.0"));
528           return ("0.0");
529           if (strict_infinity_checking)
530             abort ();
531         }
532       else
533         return (String_convert::form_string ("%.*lf", precision, val));
534     }
535   else if (scm_is_string (arg))
536     {
537       string s = ly_scm2string (arg);
538       if (escape)
539         {
540           // Escape backslashes and double quotes, wrap it in double quotes
541           replace_all (&s, "\\", "\\\\");
542           replace_all (&s, "\"", "\\\"");
543           // don't replace percents, since the png backend uses %d as escape sequence
544           // replace_all (&s, "%", "\\%");
545           replace_all (&s, "$", "\\$");
546           s = "\"" + s + "\"";
547         }
548       return s;
549     }
550   else if (scm_is_symbol (arg))
551     return (ly_symbol2string (arg));
552   else
553     {
554       ly_progress (scm_from_locale_string ("Unsupported SCM value for format: ~a"),
555                    scm_list_1 (arg));
556     }
557
558
559   return "";
560 }
561
562 LY_DEFINE (ly_format, "ly:format",
563            1, 0, 1, (SCM str, SCM rest),
564            "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}. "
565            "Basic support for @code{~s} is also provided.")
566 {
567   LY_ASSERT_TYPE (scm_is_string, str, 1);
568
569   string format = ly_scm2string (str);
570   vector<string> results;
571
572   vsize i = 0;
573   while (i < format.size ())
574     {
575       vsize tilde = format.find ('~', i);
576
577       results.push_back (format.substr (i, (tilde-i)));
578
579       if (tilde == NPOS)
580         break ;
581
582       tilde ++;
583
584       char spec = format.at (tilde ++);
585       if (spec == '~')
586         results.push_back ("~");
587       else
588         {
589           if (!scm_is_pair (rest))
590             {
591               programming_error (string (__FUNCTION__)
592                                  + ": not enough arguments for format.");
593               return ly_string2scm ("");
594             }
595
596           SCM arg = scm_car (rest);
597           rest = scm_cdr (rest);
598
599           int precision = 8;
600
601           if (spec == '$')
602             precision = 2;
603           else if (isdigit (spec))
604             {
605               precision = spec - '0';
606               spec = format.at (tilde ++);
607             }
608
609           if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
610             results.push_back (format_single_argument (arg, precision));
611           else if (spec == 's' || spec == 'S')
612             results.push_back (format_single_argument (arg, precision, true));
613           else if (spec == 'l')
614             {
615               SCM s = arg;
616               for (; scm_is_pair (s); s = scm_cdr (s))
617                 {
618                   results.push_back (format_single_argument (scm_car (s), precision));
619                   if (scm_cdr (s) != SCM_EOL)
620                     results.push_back (" ");
621                 }
622
623               if (s != SCM_EOL)
624                 results.push_back (format_single_argument (s, precision));
625
626             }
627         }
628
629       i = tilde;
630     }
631
632   if (scm_is_pair (rest))
633     programming_error (string (__FUNCTION__)
634                        + ": too many  arguments");
635
636   vsize len = 0;
637   for (vsize i = 0; i < results.size (); i++)
638     len += results[i].size ();
639
640   char *result = (char*) scm_malloc (len + 1);
641   char *ptr = result;
642   for (vsize i = 0; i < results.size (); i++)
643     {
644       strncpy (ptr, results[i].c_str (), results[i].size ());
645       ptr += results[i].size ();
646     }
647   *ptr = '\0';
648
649   return scm_take_locale_stringn (result, len);
650 }