* scm/editor.scm: New module.

[lilypond.git] / lily / general-scheme.cc

diff --git a/lily/general-scheme.cc b/lily/general-scheme.cc
index ba66ad8715c8489ab688b85cdd98094331671965..11fb65790f4846027bcf7e134f99d54236777593 100644 (file)
--- a/lily/general-scheme.cc
+++ b/lily/general-scheme.cc
@@ -9,12 +9,11 @@
 
 #include "config.hh"
 
-#include <libintl.h>  /* gettext on MacOS X */
 #include <math.h>  /* isinf */
 #include <stdio.h>
 #include <string.h>  /* memset */
-#include <wchar.h>  /* wcrtomb */
 
+#include "international.hh"
 #include "libc-extension.hh"
 #include "lily-guile.hh"
 #include "string.hh"
@@ -62,16 +61,36 @@ LY_DEFINE (ly_gulp_file, "ly:gulp-file",
   return scm_from_locale_stringn (contents.get_str0 (), contents.length ());
 }
 
-LY_DEFINE (ly_warn, "ly:warn",
+LY_DEFINE (ly_error, "ly:error",
           1, 0, 1, (SCM str, SCM rest),
-          "Scheme callable function to issue the warning @code{msg}. "
+          "Scheme callable function to issue the error @code{msg}. "
+          "The error is formatted with @code{format} and @code{rest}.")
+{
+  SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
+  str = scm_simple_format (SCM_BOOL_F, str, rest);
+  error (ly_scm2string (str));
+  return SCM_UNSPECIFIED;
+}
+
+LY_DEFINE (ly_message, "ly:message",
+          1, 0, 1, (SCM str, SCM rest),
+          "Scheme callable function to issue the message @code{msg}. "
           "The message is formatted with @code{format} and @code{rest}.")
 {
   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
-  progress_indication ("\n");
+  str = scm_simple_format (SCM_BOOL_F, str, rest);
+  message (ly_scm2string (str));
+  return SCM_UNSPECIFIED;
+}
 
+LY_DEFINE (ly_progress, "ly:progress",
+          1, 0, 1, (SCM str, SCM rest),
+          "Scheme callable function to print progress @code{str}. "
+          "The message is formatted with @code{format} and @code{rest}.")
+{
+  SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
   str = scm_simple_format (SCM_BOOL_F, str, rest);
-  warning (ly_scm2string (str));
+  progress_indication (ly_scm2string (str));
   return SCM_UNSPECIFIED;
 }
 
@@ -81,13 +100,22 @@ LY_DEFINE (ly_programming_error, "ly:programming-error",
           "The message is formatted with @code{format} and @code{rest}.")
 {
   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
-  progress_indication ("\n");
-
   str = scm_simple_format (SCM_BOOL_F, str, rest);
   programming_error (ly_scm2string (str));
   return SCM_UNSPECIFIED;
 }
 
+LY_DEFINE (ly_warning, "ly:warning",
+          1, 0, 1, (SCM str, SCM rest),
+          "Scheme callable function to issue the warning @code{str}. "
+          "The message is formatted with @code{format} and @code{rest}.")
+{
+  SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
+  str = scm_simple_format (SCM_BOOL_F, str, rest);
+  warning (ly_scm2string (str));
+  return SCM_UNSPECIFIED;
+}
+
 LY_DEFINE (ly_dir_p, "ly:dir?",
           1, 0, 0, (SCM s),
           "type predicate. A direction is @code{-1}, @code{0} or "
@@ -97,7 +125,7 @@ LY_DEFINE (ly_dir_p, "ly:dir?",
   if (scm_is_number (s))
     {
       int i = scm_to_int (s);
-      return (i>= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
+      return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
     }
   return SCM_BOOL_F;
 }
@@ -136,7 +164,9 @@ LY_DEFINE (ly_number2string, "ly:number->string",
        if (isinf (r) || isnan (r))
 #endif
          {
-           programming_error ("Infinity or NaN encountered while converting Real number; setting to zero.");
+           programming_error (_ ("infinity or NaN encountered while converting Real number"));
+           programming_error (_ ("setting to zero"));
+                              
            r = 0.0;
          }
 
@@ -214,17 +244,63 @@ LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
           1, 0, 0, (SCM wc),
           "Encode the Unicode codepoint @var{wc} as UTF-8")
 {
-  char buf[100];
+  char buf[5];
 
   SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
-  wchar_t wide_char = (wchar_t) scm_to_int (wc);
-
-  mbstate_t state;
-  memset (&state, '\0', sizeof (state));
-  memset (buf, '\0', sizeof (buf));
+  unsigned wide_char = (unsigned) scm_to_int (wc);
+  char * p = buf;
+
+  if (wide_char < 0x0080) {
+    *p++ = (char)wide_char;
+  } else if (wide_char < 0x0800) {
+    *p++ = (char)(((wide_char >>  6)       ) | 0xC0);
+    *p++ = (char)(((wide_char      ) & 0x3F) | 0x80);
+  } else if (wide_char < 0x10000) {
+    *p++ = (char)(((wide_char >> 12)       ) | 0xE0);
+    *p++ = (char)(((wide_char >>  6) & 0x3F) | 0x80);
+    *p++ = (char)(((wide_char      ) & 0x3F) | 0x80);
+  } else {
+    *p++ = (char)(((wide_char >> 18)       ) | 0xF0);
+    *p++ = (char)(((wide_char >> 12) & 0x3F) | 0x80);
+    *p++ = (char)(((wide_char >>  6) & 0x3F) | 0x80);
+    *p++ = (char)(((wide_char      ) & 0x3F) | 0x80);
+  }
+  *p = 0;
 
-  wcrtomb (buf, wide_char, &state);
-  
   return scm_makfrom0str (buf);
 }
          
+LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
+          0, 0, 0, (),
+          "Return effective prefix.")
+{
+  return scm_makfrom0str (prefix_directory.to_str0 ());
+}
+
+LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
+          2, 1, 0, (SCM key, SCM achain, SCM dfault),
+          "Return value for @var{key} from a list of alists @var{achain}. Return @var{dfault} "
+          "if no entry is found, or #f if not specified. ")
+{
+  if (scm_is_pair (achain))
+    {
+      SCM handle = scm_assoc (key, scm_car (achain));
+      if (scm_is_pair (handle))
+       return scm_cdr (handle);
+      else
+       return ly_chain_assoc_get (key, scm_cdr (achain), dfault);
+    }
+  else
+    return dfault == SCM_UNDEFINED ? SCM_BOOL_F : dfault;
+}
+
+LY_DEFINE (ly_port_move, "ly:port-move",
+          2, 0, 0, (SCM fd, SCM port),
+          "Move file descriptor FD to PORT.")
+{
+  SCM_ASSERT_TYPE (scm_port_p (port), port, SCM_ARG1, __FUNCTION__, "port");
+  SCM_ASSERT_TYPE (scm_integer_p (fd), fd, SCM_ARG1, __FUNCTION__, "fd");
+  freopen (ly_scm2newstr (scm_port_filename (port), 0), "a",
+          fdopen (scm_to_int (fd), "a"));
+  return SCM_UNSPECIFIED;
+}