From 6d68afc85be2a9539ffb9594db2a382275fcfd89 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Tue, 20 Sep 2011 22:29:52 +0200 Subject: [PATCH] parser.yy et al: move parameter checks into the parser to allow non-checking of default args (handy for #f) lily/parser.yy --- lily/lexer.ll | 4 +-- lily/parser.yy | 74 ++++++++++++++++++++++++++++++++------------------ scm/lily.scm | 32 +++++++--------------- 3 files changed, 59 insertions(+), 51 deletions(-) diff --git a/lily/lexer.ll b/lily/lexer.ll index e88ed791c4..3445b6b784 100644 --- a/lily/lexer.ll +++ b/lily/lexer.ll @@ -590,7 +590,7 @@ BOM_UTF8 \357\273\277 else if (predicate == ly_lily_module_constant ("markup?")) push_extra_token(EXPECT_MARKUP); else - push_extra_token(EXPECT_SCM); + push_extra_token(EXPECT_SCM, predicate); } return token_type; } @@ -846,7 +846,7 @@ Lily_lexer::scan_escaped_word (string str) else if (cs == ly_lily_module_constant ("markup?")) push_extra_token (EXPECT_MARKUP); else if (ly_is_procedure (cs)) - push_extra_token (EXPECT_SCM); + push_extra_token (EXPECT_SCM, cs); else { programming_error ("Function parameter without type-checking predicate"); diff --git a/lily/parser.yy b/lily/parser.yy index a74587fd0e..4714f67326 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -158,6 +158,9 @@ SCM get_next_unique_lyrics_context_id (); static Music *make_music_with_input (SCM name, Input where); SCM make_music_relative (Pitch start, SCM music, Input loc); SCM run_music_function (Lily_parser *parser, Input loc, SCM func, SCM args); +SCM check_scheme_arg (Lily_parser *parser, Input loc, SCM fallback, + SCM arg, SCM args, SCM pred); +SCM loc_on_music (Input loc, SCM arg); SCM get_first_context_id (SCM type, Music *m); SCM make_chord_elements (SCM pitch, SCM dur, SCM modification_list); SCM make_chord_step (int step, Rational alter); @@ -279,7 +282,7 @@ If we give names, Bison complains. %token EXPECT_MUSIC "ly:music?" %token EXPECT_PITCH "ly:pitch?" %token EXPECT_DURATION "ly:duration?" -%token EXPECT_SCM "scheme?" +%token EXPECT_SCM "scheme?" %token EXPECT_MARKUP_LIST "markup-list?" %token EXPECT_OPTIONAL "optional?" /* After the last argument. */ @@ -1136,7 +1139,7 @@ function_arglist: } | EXPECT_SCM function_arglist_optional embedded_scm { - $$ = scm_cons ($3, $2); + $$ = check_scheme_arg (PARSER, @3, SCM_UNDEFINED, $3, $2, $1); } ; @@ -1144,7 +1147,7 @@ function_arglist_optional: function_arglist_keep %prec FUNCTION_ARGUMENTS | EXPECT_OPTIONAL EXPECT_MUSIC function_arglist_optional { - $$ = scm_cons ($1, $3); + $$ = scm_cons (loc_on_music (@3, $1), $3); } | EXPECT_OPTIONAL EXPECT_PITCH function_arglist_optional { @@ -1160,7 +1163,7 @@ function_arglist_optional: } | EXPECT_OPTIONAL EXPECT_SCM function_arglist_optional { - $$ = scm_cons ($1, $3); + $$ = scm_cons (loc_on_music (@3, $1), $3); } ; @@ -1179,7 +1182,7 @@ function_arglist_keep: } | EXPECT_OPTIONAL EXPECT_SCM function_arglist_keep simple_string { - $$ = scm_cons ($4, $3); + $$ = check_scheme_arg (PARSER, @4, $1, $4, $3, $2); } | EXPECT_OPTIONAL EXPECT_MUSIC function_arglist_keep closed_music { @@ -1187,7 +1190,7 @@ function_arglist_keep: } | EXPECT_OPTIONAL EXPECT_SCM function_arglist_keep embedded_scm { - $$ = scm_cons ($4, $3); + $$ = check_scheme_arg (PARSER, @4, $1, $4, $3, $2); } | function_arglist ; @@ -1201,7 +1204,7 @@ function_arglist_closed: } | EXPECT_SCM function_arglist_optional embedded_scm_closed { - $$ = scm_cons ($3, $2); + $$ = check_scheme_arg (PARSER, @3, SCM_UNDEFINED, $3, $2, $1); } ; @@ -1209,7 +1212,7 @@ function_arglist_closed_optional: function_arglist_closed_keep %prec FUNCTION_ARGUMENTS | EXPECT_OPTIONAL EXPECT_MUSIC function_arglist_closed_optional { - $$ = scm_cons ($1, $3); + $$ = scm_cons (loc_on_music (@3, $1), $3); } | EXPECT_OPTIONAL EXPECT_PITCH function_arglist_closed_optional { @@ -1225,7 +1228,7 @@ function_arglist_closed_optional: } | EXPECT_OPTIONAL EXPECT_SCM function_arglist_closed_optional { - $$ = scm_cons ($1, $3); + $$ = scm_cons (loc_on_music (@3, $1), $3); } ; @@ -1244,7 +1247,7 @@ function_arglist_closed_keep: } | EXPECT_OPTIONAL EXPECT_SCM function_arglist_keep simple_string { - $$ = scm_cons ($4, $3); + $$ = check_scheme_arg (PARSER, @4, $1, $4, $3, $2); } | EXPECT_OPTIONAL EXPECT_MUSIC function_arglist_keep closed_music { @@ -1252,7 +1255,7 @@ function_arglist_closed_keep: } | EXPECT_OPTIONAL EXPECT_SCM function_arglist_keep embedded_scm_closed { - $$ = scm_cons ($4, $3); + $$ = check_scheme_arg (PARSER, @4, $1, $4, $3, $2); } | function_arglist_closed ; @@ -1286,7 +1289,7 @@ function_arglist_bare: $$ = scm_cons ($3, $2); } | EXPECT_SCM function_arglist_optional simple_string { - $$ = scm_cons ($3, $2); + $$ = check_scheme_arg (PARSER, @3, SCM_UNDEFINED, $3, $2, $1); } ; @@ -1759,7 +1762,7 @@ music_function_chord_body_arglist: $$ = scm_cons ($3, $2); } | EXPECT_SCM function_arglist_optional embedded_scm_chord_body { - $$ = scm_cons ($3, $2); + $$ = check_scheme_arg (PARSER, @3, SCM_UNDEFINED, $3, $2, $1); } ; @@ -1789,7 +1792,7 @@ music_function_event_arglist: $$ = scm_cons ($3, $2); } | EXPECT_SCM function_arglist_optional embedded_scm_event { - $$ = scm_cons ($3, $2); + $$ = check_scheme_arg (PARSER, @3, SCM_UNDEFINED, $3, $2, $1); } ; @@ -2692,7 +2695,7 @@ markup_command_basic_arguments: $$ = scm_cons ($3, $2); } | EXPECT_SCM markup_command_list_arguments embedded_scm_closed { - $$ = scm_cons ($3, $2); + $$ = check_scheme_arg (PARSER, @3, SCM_UNDEFINED, $3, $2, $1); } | EXPECT_NO_MORE_ARGS { $$ = SCM_EOL; @@ -2873,8 +2876,6 @@ run_music_function (Lily_parser *parser, Input loc, SCM func, SCM args) { SCM sig = scm_object_property (func, ly_symbol2scm ("music-function-signature")); - SCM type_check_proc = ly_lily_module_constant ("type-check-list"); - args = scm_reverse_x (args, SCM_EOL); SCM fallback = SCM_BOOL_F; @@ -2882,23 +2883,42 @@ run_music_function (Lily_parser *parser, Input loc, SCM func, SCM args) if (scm_is_pair (pred)) { - fallback = scm_cdr (pred); - if (Music *m = unsmob_music (fallback)) { - m = m->clone (); - m->set_spot (loc); - fallback = m->unprotect (); - } + fallback = loc_on_music (loc, scm_cdr (pred)); pred = scm_car (pred); } - if (!to_boolean (scm_call_3 (type_check_proc, make_input (loc), scm_cdr (sig), args))) + SCM syntax_args = scm_list_n (parser->self_scm (), make_input (loc), pred, fallback, func, args, SCM_UNDEFINED); + return LOWLEVEL_MAKE_SYNTAX (ly_lily_module_constant ("music-function"), syntax_args); +} + +SCM check_scheme_arg (Lily_parser *parser, Input loc, SCM fallback, + SCM arg, SCM args, SCM pred) +{ + SCM type_check_arg = ly_lily_module_constant ("type-check-arg"); + if (scm_is_false (scm_call_4 (type_check_arg, make_input (loc), + arg, args, pred))) { + if (SCM_UNBNDP (fallback)) + fallback = SCM_BOOL_F; + else + fallback = loc_on_music (loc, fallback); + parser->error_level_ = 1; - return fallback; + + return scm_cons (fallback, args); } + return scm_cons (arg, args); +} - SCM syntax_args = scm_list_n (parser->self_scm (), make_input (loc), pred, fallback, func, args, SCM_UNDEFINED); - return LOWLEVEL_MAKE_SYNTAX (ly_lily_module_constant ("music-function"), syntax_args); +SCM loc_on_music (Input loc, SCM arg) +{ + if (Music *m = unsmob_music (arg)) + { + m = m->clone (); + m->set_spot (loc); + return m->unprotect (); + } + return arg; } bool diff --git a/scm/lily.scm b/scm/lily.scm index ec7aebfd43..193bf5df77 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -345,28 +345,16 @@ messages into errors.") (set-module-obarray! iface (module-obarray mod)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (type-check-list location signature arguments) - "Typecheck a list of arguments against a list of type predicates. -Print a message at LOCATION if any predicate failed." - (define (recursion-helper signature arguments count) - (define (helper pred? arg count) - (if (pair? pred?) - (set! pred? (car pred?))) - (if (not (pred? arg)) - (begin - (ly:input-warning - location - (_ "wrong type for argument ~a. Expecting ~a, found ~s") - count (type-name pred?) arg) - #f) - #t)) - - (if (null? signature) - #t - (and (helper (car signature) (car arguments) count) - (recursion-helper (cdr signature) (cdr arguments) (1+ count))))) - (recursion-helper signature arguments 1)) - +(define (type-check-arg location arg args pred?) + "Typecheck an argument after previous arguments. +Print a message at LOCATION if predicate fails and return #f" + (or (pred? arg) + (begin + (ly:input-warning + location + (_ "wrong type for argument ~a. Expecting ~a, found ~s") + (1+ (length args)) (type-name pred?) arg) + #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Safe definitions utility -- 2.39.5