Sorry, silly me. :)
I think we're nearly there. I'm just about to do a regtest check just
to be sure.
Just a few remaining nitpicks:
- trailing spaces
- long lines
That should be fixed now.
Is there a default for maximum line length?
Regards,
Michael
>From baaffd7f66ef05e6adb9562272b480542a72495f Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Michael=20K=C3=A4ppler?= <xmichae...@web.de>
Date: Sun, 13 Sep 2009 12:31:47 +0200
Subject: [PATCH] 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
---
lily/general-scheme.cc | 88 +++++++++++++++++++++++++++++--------------
lily/include/lily-guile.hh | 4 +-
scm/lily-library.scm | 17 +-------
3 files changed, 63 insertions(+), 46 deletions(-)
diff --git a/lily/general-scheme.cc b/lily/general-scheme.cc
index 43ff745..5d4901f 100644
--- 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 88c7fe8..859131a 100644
--- 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 335c345..827fb24 100644
--- 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)
--
1.6.0.2
_______________________________________________
lilypond-devel mailing list
lilypond-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/lilypond-devel
