lily/general-scheme.cc

   1 /*
   2   lily-guile.cc -- implement assorted Guile bindings
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
   7   Han-Wen Nienhuys <hanwen@xs4all.nl>
   8 */
   9
  10 #include "config.hh"
  11
  12 #include <cstdio>
  13 #include <cstring>  /* memset */
  14 using namespace std;
  15
  16 #include "international.hh"
  17 #include "libc-extension.hh"
  18 #include "lily-guile.hh"
  19 #include "misc.hh"
  20 #include "warn.hh"
  21 #include "version.hh"
  22 #include "dimensions.hh"
  23 #include "main.hh"
  24 #include "file-path.hh"
  25
  26 LY_DEFINE (ly_find_file, "ly:find-file",
  27            1, 0, 0, (SCM name),
  28            "Return the absolute file name of @var{name}, "
  29            "or @code{#f} if not found.")
  30 {
  31   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  32
  33   string nm = ly_scm2string (name);
  34   string file_name = global_path.find (nm);
  35   if (file_name.empty ())
  36     return SCM_BOOL_F;
  37
  38   return scm_makfrom0str (file_name.c_str ());
  39 }
  40
  41 /*
  42   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
  43   buffering.)
  44 */
  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. ")
  49 {
  50   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  51   int sz = INT_MAX;
  52   if (size != SCM_UNDEFINED)
  53     {
  54       SCM_ASSERT_TYPE (scm_is_number (size), size, SCM_ARG2, __FUNCTION__, "number");
  55       sz = scm_to_int (size);
  56     }
  57
  58   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
  59   return scm_from_locale_stringn (contents.c_str (), contents.length ());
  60 }
  61
  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}.")
  66 {
  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;
  71 }
  72
  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}.")
  77 {
  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;
  82 }
  83
  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}.")
  88 {
  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;
  93 }
  94
  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}.")
  99 {
 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;
 104 }
 105
 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}.")
 110 {
 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;
 115 }
 116
 117 LY_DEFINE (ly_dir_p, "ly:dir?",
 118            1, 0, 0, (SCM s),
 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.")
 122 {
 123   if (scm_is_number (s))
 124     {
 125       int i = scm_to_int (s);
 126       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 127     }
 128   return SCM_BOOL_F;
 129 }
 130
 131 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 132            2, 1, 0,
 133            (SCM key, SCM alist, SCM default_value),
 134            "Return value if KEY in ALIST, else DEFAULT-VALUE "
 135            "(or #f if not specified).")
 136 {
 137   SCM handle = scm_assoc (key, alist);
 138   if (scm_is_pair (handle))
 139     return scm_cdr (handle);
 140
 141   if (default_value == SCM_UNDEFINED)
 142     default_value = SCM_BOOL_F;
 143
 144   return default_value;
 145 }
 146
 147 LY_DEFINE (ly_number2string, "ly:number->string",
 148            1, 0, 0, (SCM s),
 149            "Convert @var{num} to a string without generating many decimals.")
 150 {
 151   SCM_ASSERT_TYPE (scm_is_number (s), s, SCM_ARG1, __FUNCTION__, "number");
 152
 153   char str[400];                        // ugh.
 154
 155   if (scm_exact_p (s) == SCM_BOOL_F)
 156     {
 157       Real r (scm_to_double (s));
 158         if (isinf (r) || isnan (r))
 159           {
 160             programming_error (_ ("infinity or NaN encountered while converting Real number"));
 161             programming_error (_ ("setting to zero"));
 162
 163             r = 0.0;
 164           }
 165
 166       snprintf (str, sizeof (str), "%08.4f", r);
 167     }
 168   else
 169     snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
 170
 171   return scm_makfrom0str (str);
 172 }
 173
 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)}. ")
 176 {
 177   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 178
 179   return scm_c_eval_string ((char *)vs);
 180 }
 181
 182 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 183            "Return the unit used for lengths as a string.")
 184 {
 185   return scm_makfrom0str (INTERNAL_UNIT);
 186 }
 187
 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.")
 191 {
 192   return scm_number_p (d);
 193 }
 194
 195 /*
 196   Debugging mem leaks:
 197 */
 198 LY_DEFINE (ly_protects, "ly:protects",
 199            0, 0, 0, (),
 200            "Return hash of protected objects.")
 201 {
 202   return scm_protects;
 203 }
 204
 205 LY_DEFINE (ly_gettext, "ly:gettext",
 206            1, 0, 0, (SCM string),
 207            "Gettext wrapper.")
 208 {
 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 ());
 212 }
 213
 214 LY_DEFINE (ly_output_backend, "ly:output-backend",
 215            0, 0, 0, (),
 216            "Return name of output backend.")
 217 {
 218   return scm_makfrom0str (output_backend_global.c_str ());
 219 }
 220
 221 LY_DEFINE (ly_output_formats, "ly:output-formats",
 222            0, 0, 0, (),
 223            "Formats passed to --format as a list of strings, "
 224            "used for the output.")
 225 {
 226   vector<string> output_formats = string_split (output_format_global, ',');
 227
 228   SCM lst = SCM_EOL;
 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);
 232
 233   return lst;
 234 }
 235
 236 LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
 237            1, 0, 0, (SCM wc),
 238            "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8")
 239 {
 240   char buf[5];
 241
 242   SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
 243   unsigned wide_char = (unsigned) scm_to_int (wc);
 244   char *p = buf;
 245
 246   if (wide_char < 0x0080)
 247     *p++ = (char)wide_char;
 248   else if (wide_char < 0x0800)
 249     {
 250       *p++ = (char) (((wide_char >> 6)) | 0xC0);
 251       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 252     }
 253   else if (wide_char < 0x10000)
 254     {
 255       *p++ = (char) (((wide_char >> 12)) | 0xE0);
 256       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 257       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 258     }
 259   else
 260     {
 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);
 265     }
 266   *p = 0;
 267
 268   return scm_makfrom0str (buf);
 269 }
 270
 271 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 272            0, 0, 0, (),
 273            "Return effective prefix.")
 274 {
 275   return scm_makfrom0str (prefix_directory.c_str ());
 276 }
 277
 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.")
 283 {
 284   if (scm_is_pair (achain))
 285     {
 286       SCM handle = scm_assoc (key, scm_car (achain));
 287       if (scm_is_pair (handle))
 288         return scm_cdr (handle);
 289       else
 290         return ly_chain_assoc_get (key, scm_cdr (achain), dfault);
 291     }
 292   return dfault == SCM_UNDEFINED ? SCM_BOOL_F : dfault;
 293 }
 294
 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.")
 298 {
 299   SCM_ASSERT_TYPE (scm_is_string (file_name), file_name, SCM_ARG1,
 300                    __FUNCTION__, "file_name");
 301   char const *m = "w";
 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
 305      gcc -mwindows.  */
 306   freopen (ly_scm2newstr (file_name, 0), m, stderr);
 307   return SCM_UNSPECIFIED;
 308 }
 309
 310 static SCM
 311 accumulate_symbol (void *closure, SCM key, SCM val, SCM result)
 312 {
 313   (void) closure;
 314   (void) val;
 315   return scm_cons (key, result);
 316 }
 317
 318 LY_DEFINE(ly_hash_table_keys, "ly:hash-table-keys",
 319           1,0,0, (SCM tab),
 320           "return a list of keys in @var{tab}")
 321 {
 322   return scm_internal_hash_fold ((Hash_closure_function) & accumulate_symbol,
 323                                  NULL, SCM_EOL, tab);
 324 }
 325
 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.")
 329 {
 330   SCM_ASSERT_TYPE(scm_is_symbol (name_sym), name_sym,
 331                   SCM_ARG1, __FUNCTION__, "symbol");
 332
 333   /*
 334     TODO: should use strings instead?
 335   */
 336
 337   const string in = ly_symbol2string (name_sym);
 338   string result = camel_case_to_lisp_identifier (in);
 339
 340   return ly_symbol2scm (result.c_str ());
 341 }