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 <cmath>  /* isinf */
  13 #include <cstdio>
  14 #include <cstring>  /* memset */
  15 using namespace std;
  16
  17 #include "international.hh"
  18 #include "libc-extension.hh"
  19 #include "lily-guile.hh"
  20 #include "string.hh"
  21 #include "misc.hh"
  22 #include "warn.hh"
  23 #include "version.hh"
  24 #include "dimensions.hh"
  25 #include "main.hh"
  26 #include "file-path.hh"
  27
  28 LY_DEFINE (ly_find_file, "ly:find-file",
  29            1, 0, 0, (SCM name),
  30            "Return the absolute file name of @var{name}, "
  31            "or @code{#f} if not found.")
  32 {
  33   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  34
  35   String nm = ly_scm2string (name);
  36   String file_name = global_path.find (nm);
  37   if (file_name.is_empty ())
  38     return SCM_BOOL_F;
  39
  40   return scm_makfrom0str (file_name.to_str0 ());
  41 }
  42
  43 /*
  44   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
  45   buffering.)
  46 */
  47 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
  48            1, 1, 0, (SCM name, SCM size),
  49            "Read the file @var{name}, and return its contents in a string.  "
  50            "The file is looked up using the search path. ")
  51 {
  52   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  53   int sz = -1;
  54   if (size != SCM_UNDEFINED)
  55     {
  56       SCM_ASSERT_TYPE (scm_is_number (size), size, SCM_ARG2, __FUNCTION__, "number");
  57       sz = scm_to_int (size);
  58     }
  59
  60   String contents = gulp_file_to_string (ly_scm2string (name), true, sz);
  61   return scm_from_locale_stringn (contents.get_str0 (), contents.length ());
  62 }
  63
  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}.")
  68 {
  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;
  73 }
  74
  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}.")
  79 {
  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;
  84 }
  85
  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}.")
  90 {
  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;
  95 }
  96
  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}.")
 101 {
 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;
 106 }
 107
 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}.")
 112 {
 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;
 117 }
 118
 119 LY_DEFINE (ly_dir_p, "ly:dir?",
 120            1, 0, 0, (SCM s),
 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.")
 124 {
 125   if (scm_is_number (s))
 126     {
 127       int i = scm_to_int (s);
 128       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 129     }
 130   return SCM_BOOL_F;
 131 }
 132
 133 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 134            2, 1, 0,
 135            (SCM key, SCM alist, SCM default_value),
 136            "Return value if KEY in ALIST, else DEFAULT-VALUE "
 137            "(or #f if not specified).")
 138 {
 139   SCM handle = scm_assoc (key, alist);
 140
 141   if (default_value == SCM_UNDEFINED)
 142     default_value = SCM_BOOL_F;
 143
 144   if (scm_is_pair (handle))
 145     return scm_cdr (handle);
 146   return default_value;
 147 }
 148
 149 LY_DEFINE (ly_number2string, "ly:number->string",
 150            1, 0, 0, (SCM s),
 151            "Convert @var{num} to a string without generating many decimals.")
 152 {
 153   SCM_ASSERT_TYPE (scm_is_number (s), s, SCM_ARG1, __FUNCTION__, "number");
 154
 155   char str[400];                        // ugh.
 156
 157   if (scm_exact_p (s) == SCM_BOOL_F)
 158     {
 159       Real r (scm_to_double (s));
 160         if (isinf (r) || isnan (r))
 161           {
 162             programming_error (_ ("infinity or NaN encountered while converting Real number"));
 163             programming_error (_ ("setting to zero"));
 164
 165             r = 0.0;
 166           }
 167
 168       snprintf (str, sizeof (str), "%08.4f", r);
 169     }
 170   else
 171     snprintf (str, sizeof (str), "%d", scm_to_int (s));
 172
 173   return scm_makfrom0str (str);
 174 }
 175
 176 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
 177            "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
 178 {
 179   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 180
 181   return scm_c_eval_string ((char *)vs);
 182 }
 183
 184 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 185            "Return the unit used for lengths as a string.")
 186 {
 187   return scm_makfrom0str (INTERNAL_UNIT);
 188 }
 189
 190 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
 191            "Return @var{d} is a number. Used to distinguish length "
 192            "variables from normal numbers.")
 193 {
 194   return scm_number_p (d);
 195 }
 196
 197 /*
 198   Debugging mem leaks:
 199 */
 200 LY_DEFINE (ly_protects, "ly:protects",
 201            0, 0, 0, (),
 202            "Return hash of protected objects.")
 203 {
 204   return scm_protects;
 205 }
 206
 207 LY_DEFINE (ly_gettext, "ly:gettext",
 208            1, 0, 0, (SCM string),
 209            "Gettext wrapper.")
 210 {
 211   SCM_ASSERT_TYPE (scm_is_string (string), string, SCM_ARG1,
 212                    __FUNCTION__, "string");
 213   return scm_makfrom0str (_ (scm_i_string_chars (string)).to_str0 ());
 214 }
 215
 216 LY_DEFINE (ly_output_backend, "ly:output-backend",
 217            0, 0, 0, (),
 218            "Return name of output backend.")
 219 {
 220   return scm_makfrom0str (output_backend_global.to_str0 ());
 221 }
 222
 223 LY_DEFINE (ly_output_formats, "ly:output-formats",
 224            0, 0, 0, (),
 225            "Formats passed to --format as a list of strings, "
 226            "used for the output.")
 227 {
 228   Array<String> output_formats = split_string (output_format_global, ',');
 229
 230   SCM lst = SCM_EOL;
 231   int output_formats_count = output_formats.size ();
 232   for (int i = 0; i < output_formats_count; i++)
 233     lst = scm_cons (scm_makfrom0str (output_formats[i].to_str0 ()), lst);
 234
 235   return lst;
 236 }
 237
 238 LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
 239            1, 0, 0, (SCM wc),
 240            "Encode the Unicode codepoint @var{wc} as UTF-8")
 241 {
 242   char buf[5];
 243
 244   SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
 245   unsigned wide_char = (unsigned) scm_to_int (wc);
 246   char *p = buf;
 247
 248   if (wide_char < 0x0080)
 249     *p++ = (char)wide_char;
 250   else if (wide_char < 0x0800)
 251     {
 252       *p++ = (char) (((wide_char >> 6)) | 0xC0);
 253       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 254     }
 255   else if (wide_char < 0x10000)
 256     {
 257       *p++ = (char) (((wide_char >> 12)) | 0xE0);
 258       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 259       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 260     }
 261   else
 262     {
 263       *p++ = (char) (((wide_char >> 18)) | 0xF0);
 264       *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
 265       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 266       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 267     }
 268   *p = 0;
 269
 270   return scm_makfrom0str (buf);
 271 }
 272
 273 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 274            0, 0, 0, (),
 275            "Return effective prefix.")
 276 {
 277   return scm_makfrom0str (prefix_directory.to_str0 ());
 278 }
 279
 280 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
 281            2, 1, 0, (SCM key, SCM achain, SCM dfault),
 282            "Return value for @var{key} from a list of alists @var{achain}.  "
 283            "If no if no entry is found, return DFAULT, "
 284            "or #f if no DFAULT not specified.")
 285 {
 286   if (scm_is_pair (achain))
 287     {
 288       SCM handle = scm_assoc (key, scm_car (achain));
 289       if (scm_is_pair (handle))
 290         return scm_cdr (handle);
 291       else
 292         return ly_chain_assoc_get (key, scm_cdr (achain), dfault);
 293     }
 294   return dfault == SCM_UNDEFINED ? SCM_BOOL_F : dfault;
 295 }
 296
 297 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
 298            1, 1, 0, (SCM file_name, SCM mode),
 299            "Redirect stderr to FILE-NAME, opened with MODE.")
 300 {
 301   SCM_ASSERT_TYPE (scm_string_p (file_name), file_name, SCM_ARG1,
 302                    __FUNCTION__, "file_name");
 303   char const *m = "w";
 304   if (mode != SCM_UNDEFINED && scm_string_p (mode))
 305     m = ly_scm2newstr (mode, 0);
 306   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
 307      gcc -mwindows.  */
 308   freopen (ly_scm2newstr (file_name, 0), m, stderr);
 309   return SCM_UNSPECIFIED;
 310 }