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--2005 Jan Nieuwenhuizen <janneke@gnu.org>
   7   Han-Wen Nienhuys <hanwen@cs.uu.nl>
   8 */
   9
  10 #include "config.hh"
  11
  12 #include <libintl.h>  /* gettext on MacOS X */
  13 #include <math.h>  /* isinf */
  14 #include <stdio.h>
  15 #include <string.h>  /* memset */
  16 #if HAVE_UTF8_WCHAR_H
  17 #include <utf8/wchar.h>  /* wcrtomb */
  18 #else
  19 #include <wchar.h> /* wcrtomb */
  20 #endif
  21
  22 #include "libc-extension.hh"
  23 #include "lily-guile.hh"
  24 #include "string.hh"
  25 #include "misc.hh"
  26 #include "warn.hh"
  27 #include "version.hh"
  28 #include "dimensions.hh"
  29 #include "main.hh"
  30 #include "file-path.hh"
  31
  32 /* MacOS S fix:
  33    source-file.hh includes cmath which undefines isinf and isnan
  34 */
  35 #ifdef __APPLE__
  36 inline int my_isinf (Real r) { return isinf (r); }
  37 inline int my_isnan (Real r) { return isnan (r); }
  38 #endif
  39
  40 LY_DEFINE (ly_find_file, "ly:find-file",
  41            1, 0, 0, (SCM name),
  42            "Return the absolute file name of @var{name}, "
  43            "or @code{#f} if not found.")
  44 {
  45   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  46
  47   String nm = ly_scm2string (name);
  48   String file_name = global_path.find (nm);
  49   if (file_name.is_empty ())
  50     return SCM_BOOL_F;
  51
  52   return scm_makfrom0str (file_name.to_str0 ());
  53 }
  54
  55 /*
  56   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
  57   buffering.)
  58 */
  59 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
  60            1, 0, 0, (SCM name),
  61            "Read the file @var{name}, and return its contents in a string.  "
  62            "The file is looked up using the search path.")
  63 {
  64   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  65   String contents = gulp_file_to_string (ly_scm2string (name), true);
  66   return scm_from_locale_stringn (contents.get_str0 (), contents.length ());
  67 }
  68
  69 LY_DEFINE (ly_error, "ly:error",
  70            1, 0, 1, (SCM str, SCM rest),
  71            "Scheme callable function to issue the error @code{msg}. "
  72            "The error is formatted with @code{format} and @code{rest}.")
  73 {
  74   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  75   str = scm_simple_format (SCM_BOOL_F, str, rest);
  76   error (ly_scm2string (str));
  77   return SCM_UNSPECIFIED;
  78 }
  79
  80 LY_DEFINE (ly_message, "ly:message",
  81            1, 0, 1, (SCM str, SCM rest),
  82            "Scheme callable function to issue the message @code{msg}. "
  83            "The message is formatted with @code{format} and @code{rest}.")
  84 {
  85   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  86   str = scm_simple_format (SCM_BOOL_F, str, rest);
  87   message (ly_scm2string (str));
  88   return SCM_UNSPECIFIED;
  89 }
  90
  91 LY_DEFINE (ly_progress, "ly:progress",
  92            1, 0, 1, (SCM str, SCM rest),
  93            "Scheme callable function to print progress @code{str}. "
  94            "The message is formatted with @code{format} and @code{rest}.")
  95 {
  96   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  97   str = scm_simple_format (SCM_BOOL_F, str, rest);
  98   progress_indication (ly_scm2string (str));
  99   return SCM_UNSPECIFIED;
 100 }
 101
 102 LY_DEFINE (ly_programming_error, "ly:programming-error",
 103            1, 0, 1, (SCM str, SCM rest),
 104            "Scheme callable function to issue the warning @code{msg}. "
 105            "The message is formatted with @code{format} and @code{rest}.")
 106 {
 107   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
 108   str = scm_simple_format (SCM_BOOL_F, str, rest);
 109   programming_error (ly_scm2string (str));
 110   return SCM_UNSPECIFIED;
 111 }
 112
 113 LY_DEFINE (ly_warning, "ly:warning",
 114            1, 0, 1, (SCM str, SCM rest),
 115            "Scheme callable function to issue the warning @code{str}. "
 116            "The message is formatted with @code{format} and @code{rest}.")
 117 {
 118   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
 119   str = scm_simple_format (SCM_BOOL_F, str, rest);
 120   warning (ly_scm2string (str));
 121   return SCM_UNSPECIFIED;
 122 }
 123
 124 LY_DEFINE (ly_dir_p, "ly:dir?",
 125            1, 0, 0, (SCM s),
 126            "type predicate. A direction is @code{-1}, @code{0} or "
 127            "@code{1}, where @code{-1} represents "
 128            "left or down and @code{1} represents right or up.")
 129 {
 130   if (scm_is_number (s))
 131     {
 132       int i = scm_to_int (s);
 133       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 134     }
 135   return SCM_BOOL_F;
 136 }
 137
 138 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 139            2, 1, 0,
 140            (SCM key, SCM alist, SCM default_value),
 141            "Return value if KEY in ALIST, else DEFAULT-VALUE "
 142            "(or #f if not specified).")
 143 {
 144   SCM handle = scm_assoc (key, alist);
 145
 146   if (default_value == SCM_UNDEFINED)
 147     default_value = SCM_BOOL_F;
 148
 149   if (scm_is_pair (handle))
 150     return scm_cdr (handle);
 151   else
 152     return default_value;
 153 }
 154
 155 LY_DEFINE (ly_number2string, "ly:number->string",
 156            1, 0, 0, (SCM s),
 157            "Convert @var{num} to a string without generating many decimals.")
 158 {
 159   SCM_ASSERT_TYPE (scm_is_number (s), s, SCM_ARG1, __FUNCTION__, "number");
 160
 161   char str[400];                        // ugh.
 162
 163   if (scm_exact_p (s) == SCM_BOOL_F)
 164     {
 165       Real r (scm_to_double (s));
 166 #ifdef __APPLE__
 167       if (my_isinf (r) || my_isnan (r))
 168 #else
 169         if (isinf (r) || isnan (r))
 170 #endif
 171           {
 172             programming_error (_ ("infinity or NaN encountered while converting Real number"));
 173             programming_error (_ ("setting to zero"));
 174
 175             r = 0.0;
 176           }
 177
 178       snprintf (str, sizeof (str), "%08.4f", r);
 179     }
 180   else
 181     snprintf (str, sizeof (str), "%d", scm_to_int (s));
 182
 183   return scm_makfrom0str (str);
 184 }
 185
 186 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
 187            "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
 188 {
 189   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 190
 191   return scm_c_eval_string ((char *)vs);
 192 }
 193
 194 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 195            "Return the unit used for lengths as a string.")
 196 {
 197   return scm_makfrom0str (INTERNAL_UNIT);
 198 }
 199
 200 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
 201            "Return @var{d} is a number. Used to distinguish length "
 202            "variables from normal numbers.")
 203 {
 204   return scm_number_p (d);
 205 }
 206
 207 /*
 208   Debugging mem leaks:
 209 */
 210 LY_DEFINE (ly_protects, "ly:protects",
 211            0, 0, 0, (),
 212            "Return hash of protected objects.")
 213 {
 214   return scm_protects;
 215 }
 216
 217 LY_DEFINE (ly_gettext, "ly:gettext",
 218            1, 0, 0, (SCM string),
 219            "Gettext wrapper.")
 220 {
 221   SCM_ASSERT_TYPE (scm_is_string (string), string, SCM_ARG1,
 222                    __FUNCTION__, "string");
 223   return scm_makfrom0str (_ (scm_i_string_chars (string)).to_str0 ());
 224 }
 225
 226 LY_DEFINE (ly_output_backend, "ly:output-backend",
 227            0, 0, 0, (),
 228            "Return name of output backend.")
 229 {
 230   return scm_makfrom0str (output_backend_global.to_str0 ());
 231 }
 232
 233 LY_DEFINE (ly_output_formats, "ly:output-formats",
 234            0, 0, 0, (),
 235            "Formats passed to --format as a list of strings, "
 236            "used for the output.")
 237 {
 238   Array<String> output_formats = split_string (output_format_global, ',');
 239
 240   SCM lst = SCM_EOL;
 241   int output_formats_count = output_formats.size ();
 242   for (int i = 0; i < output_formats_count; i ++)
 243     lst = scm_cons (scm_makfrom0str (output_formats[i].to_str0 ()), lst);
 244
 245   return lst;
 246 }
 247
 248 LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
 249            1, 0, 0, (SCM wc),
 250            "Encode the Unicode codepoint @var{wc} as UTF-8")
 251 {
 252   char buf[100];
 253
 254   SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
 255   wchar_t wide_char = (wchar_t) scm_to_int (wc);
 256
 257   mbstate_t state;
 258   memset (&state, '\0', sizeof (state));
 259   memset (buf, '\0', sizeof (buf));
 260
 261   wcrtomb (buf, wide_char, &state);
 262
 263   return scm_makfrom0str (buf);
 264 }
 265
 266 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 267            0, 0, 0, (),
 268            "Return effective prefix.")
 269 {
 270   return scm_makfrom0str (prefix_directory.to_str0 ());
 271 }
 272
 273
 274
 275 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
 276            2, 1, 0, (SCM key, SCM achain, SCM dfault),
 277            "Return value for @var{key} from a list of alists @var{achain}. Return @var{dfault} "
 278            "if no entry is found, or #f if not specified. ")
 279 {
 280   if (scm_is_pair (achain))
 281     {
 282       SCM handle = scm_assoc (key, scm_car (achain));
 283       if (scm_is_pair (handle))
 284         return scm_cdr (handle);
 285       else
 286         return ly_chain_assoc_get (key, scm_cdr (achain), dfault);
 287     }
 288   else
 289     return dfault == SCM_UNDEFINED ? SCM_BOOL_F : dfault;
 290 }