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 #ifdef 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_warn, "ly:warn",
  70            1, 0, 1, (SCM str, SCM rest),
  71            "Scheme callable function to issue the warning @code{msg}. "
  72            "The message is formatted with @code{format} and @code{rest}.")
  73 {
  74   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  75   progress_indication ("\n");
  76
  77   str = scm_simple_format (SCM_BOOL_F, str, rest);
  78   warning (ly_scm2string (str));
  79   return SCM_UNSPECIFIED;
  80 }
  81
  82 LY_DEFINE (ly_programming_error, "ly:programming-error",
  83            1, 0, 1, (SCM str, SCM rest),
  84            "Scheme callable function to issue the warning @code{msg}. "
  85            "The message is formatted with @code{format} and @code{rest}.")
  86 {
  87   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  88   progress_indication ("\n");
  89
  90   str = scm_simple_format (SCM_BOOL_F, str, rest);
  91   programming_error (ly_scm2string (str));
  92   return SCM_UNSPECIFIED;
  93 }
  94
  95 LY_DEFINE (ly_dir_p, "ly:dir?",
  96            1, 0, 0, (SCM s),
  97            "type predicate. A direction is @code{-1}, @code{0} or "
  98            "@code{1}, where @code{-1} represents "
  99            "left or down and @code{1} represents right or up.")
 100 {
 101   if (scm_is_number (s))
 102     {
 103       int i = scm_to_int (s);
 104       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 105     }
 106   return SCM_BOOL_F;
 107 }
 108
 109 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 110            2, 1, 0,
 111            (SCM key, SCM alist, SCM default_value),
 112            "Return value if KEY in ALIST, else DEFAULT-VALUE "
 113            "(or #f if not specified).")
 114 {
 115   SCM handle = scm_assoc (key, alist);
 116
 117   if (default_value == SCM_UNDEFINED)
 118     default_value = SCM_BOOL_F;
 119
 120   if (scm_is_pair (handle))
 121     return scm_cdr (handle);
 122   else
 123     return default_value;
 124 }
 125
 126 LY_DEFINE (ly_number2string, "ly:number->string",
 127            1, 0, 0, (SCM s),
 128            "Convert @var{num} to a string without generating many decimals.")
 129 {
 130   SCM_ASSERT_TYPE (scm_is_number (s), s, SCM_ARG1, __FUNCTION__, "number");
 131
 132   char str[400];                        // ugh.
 133
 134   if (scm_exact_p (s) == SCM_BOOL_F)
 135     {
 136       Real r (scm_to_double (s));
 137 #ifdef __APPLE__
 138       if (my_isinf (r) || my_isnan (r))
 139 #else
 140         if (isinf (r) || isnan (r))
 141 #endif
 142           {
 143             programming_error ("Infinity or NaN encountered while converting Real number; setting to zero.");
 144             r = 0.0;
 145           }
 146
 147       snprintf (str, sizeof (str), "%08.4f", r);
 148     }
 149   else
 150     snprintf (str, sizeof (str), "%d", scm_to_int (s));
 151
 152   return scm_makfrom0str (str);
 153 }
 154
 155 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
 156            "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
 157 {
 158   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 159
 160   return scm_c_eval_string ((char *)vs);
 161 }
 162
 163 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 164            "Return the unit used for lengths as a string.")
 165 {
 166   return scm_makfrom0str (INTERNAL_UNIT);
 167 }
 168
 169 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
 170            "Return @var{d} is a number. Used to distinguish length "
 171            "variables from normal numbers.")
 172 {
 173   return scm_number_p (d);
 174 }
 175
 176 /*
 177   Debugging mem leaks:
 178 */
 179 LY_DEFINE (ly_protects, "ly:protects",
 180            0, 0, 0, (),
 181            "Return hash of protected objects.")
 182 {
 183   return scm_protects;
 184 }
 185
 186 LY_DEFINE (ly_gettext, "ly:gettext",
 187            1, 0, 0, (SCM string),
 188            "Gettext wrapper.")
 189 {
 190   SCM_ASSERT_TYPE (scm_is_string (string), string, SCM_ARG1,
 191                    __FUNCTION__, "string");
 192   return scm_makfrom0str (_ (scm_i_string_chars (string)).to_str0 ());
 193 }
 194
 195 LY_DEFINE (ly_output_backend, "ly:output-backend",
 196            0, 0, 0, (),
 197            "Return name of output backend.")
 198 {
 199   return scm_makfrom0str (output_backend_global.to_str0 ());
 200 }
 201
 202 LY_DEFINE (ly_output_formats, "ly:output-formats",
 203            0, 0, 0, (),
 204            "Formats passed to --format as a list of strings, "
 205            "used for the output.")
 206 {
 207   Array<String> output_formats = split_string (output_format_global, ',');
 208
 209   SCM lst = SCM_EOL;
 210   int output_formats_count = output_formats.size ();
 211   for (int i = 0; i < output_formats_count; i ++)
 212     lst = scm_cons (scm_makfrom0str (output_formats[i].to_str0 ()), lst);
 213
 214   return lst;
 215 }
 216
 217 LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
 218            1, 0, 0, (SCM wc),
 219            "Encode the Unicode codepoint @var{wc} as UTF-8")
 220 {
 221   char buf[100];
 222
 223   SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
 224   wchar_t wide_char = (wchar_t) scm_to_int (wc);
 225
 226   mbstate_t state;
 227   memset (&state, '\0', sizeof (state));
 228   memset (buf, '\0', sizeof (buf));
 229
 230   wcrtomb (buf, wide_char, &state);
 231
 232   return scm_makfrom0str (buf);
 233 }
 234
 235 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 236            0, 0, 0, (),
 237            "Return effective prefix.")
 238 {
 239   return scm_makfrom0str (prefix_directory.to_str0 ());
 240 }
 241