Improve error checking in ly:assoc-get and ly:chain-assoc-get.

* Introduce a new optional argument strict_checking

* When strict_checking is set to true, output a programming_error
  if the given key is not found in the given alist / achain.

* This patch does not change the current behaviour. It prepares
  a greater modification to remove all assoc calls through
  secure assoc-get calls.

* Remove obsolete chain-assoc-get definition from lily-library.scm

diff --git a/lily/general-scheme.cc b/lily/general-scheme.cc
index 43ff7456238ba1fd8a6b9e602f21d2bb59fb610b..5d4901f7bf82c65818cfc593e0648c64c60fa852 100644 (file)
--- a/lily/general-scheme.cc
+++ b/lily/general-scheme.cc
@@ -77,7 +77,7 @@ LY_DEFINE (ly_gulp_file, "ly:gulp-file",
       LY_ASSERT_TYPE (scm_is_number, size, 2);
       sz = scm_to_int (size);
     }
-  
+
   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
   return scm_from_locale_stringn (contents.c_str (), contents.length ());
 }
@@ -154,20 +154,35 @@ LY_DEFINE (ly_dir_p, "ly:dir?",
 }
 
 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
-          2, 1, 0,
-          (SCM key, SCM alist, SCM default_value),
-          "Return value if @var{key} in @var{alist}, else @code{default-value}"
-          " (or @code{#f} if not specified).")
+          2, 2, 0,
+          (SCM key, SCM alist, SCM default_value, SCM strict_checking),
+          "Return value if @var{key} in @var{alist}, else @var{default-value}"
+          " (or @code{#f} if not specified).  If @var{strict-checking} is set"
+           " to @code{#t} and @var{key} is not in @var{alist}, a programming_error"
+           " is output.")
 {
   LY_ASSERT_TYPE(ly_cheap_is_list, alist, 2);
-  
+
   SCM handle = scm_assoc (key, alist);
   if (scm_is_pair (handle))
     return scm_cdr (handle);
-  
+
   if (default_value == SCM_UNDEFINED)
     default_value = SCM_BOOL_F;
 
+  if (strict_checking == SCM_BOOL_T)
+    {
+      string key_string = ly_scm2string
+                            (scm_object_to_string (key, SCM_UNDEFINED));
+      string default_value_string = ly_scm2string
+                                      (scm_object_to_string (default_value,
+                                                            SCM_UNDEFINED));
+      programming_error ("Cannot find key `" +
+                         key_string +
+                        "' in alist, setting to `" +
+                        default_value_string + "'.");
+    }
+
   return default_value;
 }
 
@@ -183,10 +198,10 @@ LY_DEFINE (ly_string_substitute, "ly:string-substitute",
   string ss = ly_scm2string (s);
   replace_all (&ss, ly_scm2string (a),
               ly_scm2string (b));
-  
+
   return ly_string2scm (ss);
 }
-  
+
 LY_DEFINE (ly_number_2_string, "ly:number->string",
           1, 0, 0, (SCM s),
           "Convert @var{num} to a string without generating many decimals.")
@@ -312,10 +327,11 @@ LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 }
 
 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
-          2, 1, 0, (SCM key, SCM achain, SCM val),
+          2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM strict_checking),
           "Return value for @var{key} from a list of alists @var{achain}."
-          "  If no entry is found, return @var{val} or @code{#f} if"
-          " @var{val} is not specified.")
+          "  If no entry is found, return @var{default-value} or @code{#f} if"
+          " @var{default-value} is not specified.  With @var{strict-checking}"
+           " set to @code{#t}, a programming_error is output in such cases.")
 {
   if (scm_is_pair (achain))
     {
@@ -323,9 +339,23 @@ LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
       if (scm_is_pair (handle))
        return scm_cdr (handle);
       else
-       return ly_chain_assoc_get (key, scm_cdr (achain), val);
+       return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
+    }
+
+  if (strict_checking == SCM_BOOL_T)
+    {
+      string key_string = ly_scm2string
+                            (scm_object_to_string (key, SCM_UNDEFINED));
+      string default_value_string = ly_scm2string
+                                      (scm_object_to_string (default_value,
+                                                            SCM_UNDEFINED));
+      programming_error ("Cannot find key `" +
+                         key_string +
+                        "' in achain, setting to `" +
+                        default_value_string + "'.");
     }
-  return val == SCM_UNDEFINED ? SCM_BOOL_F : val;
+
+  return default_value == SCM_UNDEFINED ? SCM_BOOL_F : default_value;
 }
 
 
@@ -340,7 +370,7 @@ LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
     m = ly_scm2string (mode);
   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
      gcc -mwindows.  */
-  fflush (stderr); 
+  fflush (stderr);
   freopen (ly_scm2string (file_name).c_str (), m.c_str (), stderr);
   return SCM_UNSPECIFIED;
 }
@@ -367,11 +397,11 @@ LY_DEFINE (ly_camel_case_2_lisp_identifier, "ly:camel-case->lisp-identifier",
           "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
 {
   LY_ASSERT_TYPE (ly_is_symbol, name_sym, 1);
-  
+
   /*
     TODO: should use strings instead?
   */
-  
+
   const string in = ly_symbol2string (name_sym);
   string result = camel_case_to_lisp_identifier (in);
 
@@ -386,7 +416,7 @@ LY_DEFINE (ly_expand_environment, "ly:expand-environment",
 
   return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
 }
-                
+
 
 LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
           2, 0, 0, (SCM lst, SCM i),
@@ -451,9 +481,9 @@ format_single_argument (SCM arg, int precision, bool escape = false)
       ly_progress (scm_from_locale_string ("Unsupported SCM value for format: ~a"),
                   scm_list_1 (arg));
     }
-  
-    
-  return "";    
+
+
+  return "";
 }
 
 LY_DEFINE (ly_format, "ly:format",
@@ -475,7 +505,7 @@ LY_DEFINE (ly_format, "ly:format",
 
       if (tilde == NPOS)
        break ;
-      
+
       tilde ++;
 
       char spec = format.at (tilde ++);
@@ -485,16 +515,16 @@ LY_DEFINE (ly_format, "ly:format",
        {
          if (!scm_is_pair (rest))
            {
-             programming_error (string (__FUNCTION__) 
+             programming_error (string (__FUNCTION__)
                                 + ": not enough arguments for format.");
              return ly_string2scm ("");
            }
-         
+
          SCM arg = scm_car (rest);
          rest = scm_cdr (rest);
 
          int precision = 8;
-         
+
          if (spec == '$')
            precision = 2;
          else if (isdigit (spec))
@@ -502,7 +532,7 @@ LY_DEFINE (ly_format, "ly:format",
              precision = spec - '0';
              spec = format.at (tilde ++);
            }
-                  
+
          if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
            results.push_back (format_single_argument (arg, precision));
          else if (spec == 's' || spec == 'S')
@@ -519,7 +549,7 @@ LY_DEFINE (ly_format, "ly:format",
 
              if (s != SCM_EOL)
                results.push_back (format_single_argument (s, precision));
-               
+
            }
        }
 
@@ -533,7 +563,7 @@ LY_DEFINE (ly_format, "ly:format",
   vsize len = 0;
   for (vsize i = 0; i < results.size (); i++)
     len += results[i].size ();
-  
+
   char *result = (char*) scm_malloc (len + 1);
   char *ptr = result;
   for (vsize i = 0; i < results.size (); i++)
@@ -542,6 +572,6 @@ LY_DEFINE (ly_format, "ly:format",
       ptr += results[i].size ();
     }
   *ptr = '\0';
-    
+
   return scm_take_locale_stringn (result, len);
 }

diff --git a/lily/include/lily-guile.hh b/lily/include/lily-guile.hh
index 88c7fe8a1ca9b5db3e90b2025bf89fcf99419319..859131a1f09cf0f6c6c93162fb43a195c98feb9e 100644 (file)
--- a/lily/include/lily-guile.hh
+++ b/lily/include/lily-guile.hh
@@ -48,9 +48,9 @@ SCM ly_rational2scm (Rational);
 SCM ly_offset2scm (Offset);
 Offset ly_scm2offset (SCM);
 SCM ly_chain_assoc (SCM key, SCM achain);
-SCM ly_chain_assoc_get (SCM key, SCM achain, SCM val);
+SCM ly_chain_assoc_get (SCM key, SCM achain, SCM default_value, SCM strict_checking = SCM_BOOL_F);
 SCM ly_assoc_cdr (SCM key, SCM alist);
-SCM ly_assoc_get (SCM key, SCM alist, SCM def);
+SCM ly_assoc_get (SCM key, SCM alist, SCM default_value, SCM strict_checking = SCM_BOOL_F);
 Interval ly_scm2interval (SCM);
 Drul_array<Real> ly_scm2realdrul (SCM);
 Slice int_list_to_slice (SCM l);

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 335c345c3c0e345f6fd7b2b7b493be9f421759d5..827fb24cabfa875f6b269a879bb089f33e272a08 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -197,6 +197,8 @@
 
 (define-public assoc-get ly:assoc-get)
 
+(define-public chain-assoc-get ly:chain-assoc-get)
+
 (define-public (uniqued-alist alist acc)
   (if (null? alist) acc
       (if (assoc (caar alist) acc)
@@ -207,21 +209,6 @@
   (string<? (symbol->string (car x))
            (symbol->string (car y))))
 
-(define-public (chain-assoc-get x alist-list . default)
-  "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
-found."
-
-  (define (helper x alist-list default)
-    (if (null? alist-list)
-       default
-       (let* ((handle (assoc x (car alist-list))))
-         (if (pair? handle)
-             (cdr handle)
-             (helper x (cdr alist-list) default)))))
-
-  (helper x alist-list
-         (if (pair? default) (car default) #f)))
-
 (define (map-alist-vals func list)
   "map FUNC over the vals of  LIST, leaving the keys."
   (if (null?  list)