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