X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Parameters.xs;h=1a4e58ec372efa51d3eb64fb8763f0c1438ae953;hb=0e5931eaf95baf2580df7bb8cb584dd2377a8763;hp=7129ddf2712948e25eb2fb24d8bdfcf05e933f6c;hpb=ee1790924d73742e27c3a760ce97c8b03fc8c9bb;p=p5sagit%2FFunction-Parameters.git

diff --git a/Parameters.xs b/Parameters.xs
index 7129ddf..1a4e58e 100644
--- a/Parameters.xs
+++ b/Parameters.xs
@@ -49,14 +49,9 @@ See http://dev.perl.org/licenses/ for more information.
 
 #include <string.h>
 
-WARNINGS_ENABLE
 
-#define MY_PKG "Function::Parameters"
+WARNINGS_ENABLE
 
-#define HINTK_KEYWORDS MY_PKG "/keywords"
-#define HINTK_NAME_    MY_PKG "/name:"
-#define HINTK_SHIFT_   MY_PKG "/shift:"
-#define HINTK_ATTRS_   MY_PKG "/attrs:"
 
 #define HAVE_PERL_VERSION(R, V, S) \
 	(PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
@@ -67,25 +62,45 @@ WARNINGS_ENABLE
  #define IF_HAVE_PERL_5_16(YES, NO) NO
 #endif
 
-typedef struct {
-	enum {
-		FLAG_NAME_OPTIONAL = 1,
-		FLAG_NAME_REQUIRED,
-		FLAG_NAME_PROHIBITED
-	} name;
+
+#define MY_PKG "Function::Parameters"
+
+#define HINTK_KEYWORDS MY_PKG "/keywords"
+#define HINTK_FLAGS_   MY_PKG "/flags:"
+#define HINTK_SHIFT_   MY_PKG "/shift:"
+#define HINTK_ATTRS_   MY_PKG "/attrs:"
+
+#define DEFSTRUCT(T) typedef struct T T; struct T
+
+DEFSTRUCT(DefaultParamSpec) {
+	DefaultParamSpec *next;
+	int limit;
+	SV *name;
+	OP *init;
+};
+
+enum {
+	FLAG_NAME_OK      = 0x01,
+	FLAG_ANON_OK      = 0x02,
+	FLAG_DEFAULT_ARGS = 0x04,
+	FLAG_CHECK_NARGS  = 0x08
+};
+
+DEFSTRUCT(KWSpec) {
+	unsigned flags;
 	SV *shift;
 	SV *attrs;
-} Spec;
+};
 
 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
 
-static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
+static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
 	HV *hints;
 	SV *sv, **psv;
 	const char *p, *kw_active;
 	STRLEN kw_active_len;
 
-	spec->name = 0;
+	spec->flags = 0;
 	spec->shift = sv_2mortal(newSVpvs(""));
 	spec->attrs = sv_2mortal(newSVpvs(""));
 
@@ -124,8 +139,8 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
 	} \
 } STMT_END
 
-			FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv);
-			spec->name = SvIV(*psv);
+			FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
+			spec->flags = SvIV(*psv);
 
 			FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
 			SvSetSV(spec->shift, *psv);
@@ -144,21 +159,24 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
 #include "toke_on_crack.c.inc"
 
 
+static void free_defspec(pTHX_ void *vp) {
+	DefaultParamSpec *dp = vp;
+	op_free(dp->init);
+	Safefree(dp);
+}
+
 static void free_ptr_op(pTHX_ void *vp) {
 	OP **pp = vp;
 	op_free(*pp);
 	Safefree(pp);
 }
 
-#define sv_eq_pvs(SV, S) sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
+#define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
 
-static int sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
+static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
 	STRLEN sv_len;
 	const char *sv_p = SvPV(sv, sv_len);
-	return
-		sv_len == n &&
-		memcmp(sv_p, p, n) == 0
-	;
+	return memcmp(sv_p, p, n) == 0;
 }
 
 
@@ -198,11 +216,15 @@ enum {
 	MY_ATTR_SPECIAL = 0x04
 };
 
-static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
+static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
 	SV *declarator;
 	I32 floor_ix;
+	int save_ix;
 	SV *saw_name;
+	OP **prelude_sentinel;
 	AV *params;
+	DefaultParamSpec *defaults;
+	int args_min, args_max;
 	SV *proto;
 	OP **attrs_sentinel, *body;
 	unsigned builtin_attrs;
@@ -219,7 +241,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 	/* function name */
 	saw_name = NULL;
 	s = PL_parser->bufptr;
-	if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
+	if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) {
 		saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 
 		if (PL_parser->expect != XSTATE) {
@@ -242,20 +264,46 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 
 		lex_read_to(s + len);
 		lex_read_space(0);
-	} else if (spec->name == FLAG_NAME_REQUIRED) {
+	} else if (!(spec->flags & FLAG_ANON_OK)) {
 		croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
 	} else {
 		sv_catpvs(declarator, " (anon)");
 	}
 
+	/* we're a subroutine declaration */
 	floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
 	SAVEFREESV(PL_compcv);
 
+	/* create outer block: '{' */
+	save_ix = S_block_start(aTHX_ TRUE);
+
+	/* initialize synthetic optree */
+	Newx(prelude_sentinel, 1, OP *);
+	*prelude_sentinel = NULL;
+	SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel);
+
 	/* parameters */
 	params = NULL;
+	defaults = NULL;
+	args_min = 0;
+	args_max = -1;
+
+	/* my $self; */
+	if (SvTRUE(spec->shift)) {
+		OP *var;
+
+		var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
+		var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL);
+
+		*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
+	}
+
 	c = lex_peek_unichar(0);
 	if (c == '(') {
+		DefaultParamSpec **pdefaults_tail = &defaults;
 		SV *saw_slurpy = NULL;
+		int param_count = 0;
+		args_max = 0;
 
 		lex_read_unichar(0);
 		lex_read_space(0);
@@ -266,8 +314,11 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 		for (;;) {
 			c = lex_peek_unichar(0);
 			if (c == '$' || c == '@' || c == '%') {
+				const char sigil = c;
 				SV *param;
 
+				param_count++;
+
 				lex_read_unichar(0);
 				lex_read_space(0);
 
@@ -275,11 +326,14 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 				if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 					croak("In %"SVf": missing identifier", SVfARG(declarator));
 				}
-				param = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
+				param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s));
 				if (saw_slurpy) {
 					croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param));
 				}
-				if (c != '$') {
+				if (sigil == '$') {
+					args_max++;
+				} else {
+					args_max = -1;
 					saw_slurpy = param;
 				}
 				av_push(params, SvREFCNT_inc_simple_NN(param));
@@ -287,6 +341,47 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 				lex_read_space(0);
 
 				c = lex_peek_unichar(0);
+
+				if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) {
+					if (sigil == '$' && !defaults) {
+						args_min++;
+					}
+				} else if (sigil != '$') {
+					croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy));
+				} else {
+					DefaultParamSpec *curdef;
+
+					lex_read_unichar(0);
+					lex_read_space(0);
+
+					Newx(curdef, 1, DefaultParamSpec);
+					curdef->next = NULL;
+					curdef->limit = param_count;
+					curdef->name = param;
+					curdef->init = NULL;
+					SAVEDESTRUCTOR_X(free_defspec, curdef);
+
+					curdef->next = *pdefaults_tail;
+					*pdefaults_tail = curdef;
+					pdefaults_tail = &curdef->next;
+
+					/* let perl parse the default parameter value */
+					curdef->init = parse_termexpr(0);
+
+					lex_read_space(0);
+					c = lex_peek_unichar(0);
+				}
+
+				/* my $param; */
+				{
+					OP *var;
+
+					var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
+					var->op_targ = pad_add_name_sv(param, 0, NULL, NULL);
+
+					*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
+				}
+
 				if (c == ',') {
 					lex_read_unichar(0);
 					lex_read_space(0);
@@ -329,31 +424,12 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 		}
 	}
 
-	/* surprise predeclaration! */
-	if (saw_name) {
-		/* 'sub NAME (PROTO);' to make name/proto known to perl before it
-		   starts parsing the body */
-		SvREFCNT_inc_simple_void(PL_compcv);
-
-		newATTRSUB(
-			floor_ix,
-			newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
-			proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
-			NULL,
-			NULL
-		);
-
-		floor_ix = start_subparse(FALSE, 0);
-		SAVEFREESV(PL_compcv);
-	}
-
-
 	/* attributes */
 	Newx(attrs_sentinel, 1, OP *);
 	*attrs_sentinel = NULL;
 	SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
 
-	if (c == ':' || c == '{') {
+	if (c == ':' || c == '{') /* '}' - hi, vim */ {
 
 		/* kludge default attributes in */
 		if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
@@ -413,10 +489,28 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 	}
 
 	/* body */
-	if (c != '{') {
+	if (c != '{') /* '}' - hi, vim */ {
 		croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
 	}
 
+	/* surprise predeclaration! */
+	if (saw_name) {
+		/* 'sub NAME (PROTO);' to make name/proto known to perl before it
+		   starts parsing the body */
+		const I32 sub_ix = start_subparse(FALSE, 0);
+		SAVEFREESV(PL_compcv);
+
+		SvREFCNT_inc_simple_void(PL_compcv);
+
+		newATTRSUB(
+			sub_ix,
+			newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
+			proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
+			NULL,
+			NULL
+		);
+	}
+
 	if (builtin_attrs & MY_ATTR_LVALUE) {
 		CvLVALUE_on(PL_compcv);
 	}
@@ -427,64 +521,141 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 		CvSPECIAL_on(PL_compcv);
 	}
 
-	/* munge */
-	{
-		/* create outer block: '{' */
-		const int save_ix = S_block_start(aTHX_ TRUE);
-		OP *init = NULL;
-
-		/* my $self = shift; */
+	/* min/max argument count checks */
+	if (spec->flags & FLAG_CHECK_NARGS) {
 		if (SvTRUE(spec->shift)) {
-			OP *const var = newOP(OP_PADSV, OPf_WANT_SCALAR | (OPpLVAL_INTRO << 8));
-			var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL);
+			args_min++;
+			if (args_max != -1) {
+				args_max++;
+			}
+		}
+
+		if (args_min > 0) {
+			OP *chk, *cond, *err, *croak;
+
+			err = newSVOP(OP_CONST, 0,
+				          newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator)));
+
+			croak = newCVREF(OPf_WANT_SCALAR,
+				             newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
+			err = newUNOP(OP_ENTERSUB, OPf_STACKED,
+				          op_append_elem(OP_LIST, err, croak));
 
-			init = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
-			init = newSTATEOP(0, NULL, init);
+			cond = newBINOP(OP_LT, 0,
+				            newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
+				            newSVOP(OP_CONST, 0, newSViv(args_min)));
+			chk = newLOGOP(OP_AND, 0, cond, err);
+
+			*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
 		}
+		if (args_max != -1) {
+			OP *chk, *cond, *err, *croak;
 
-		/* my (PARAMS) = @_; */
-		if (params && av_len(params) > -1) {
-			SV *param;
-			OP *init_param, *left, *right;
-
-			left = NULL;
-			while ((param = av_shift(params)) != &PL_sv_undef) {
-				OP *const var = newOP(OP_PADSV, OPf_WANT_LIST | (OPpLVAL_INTRO << 8));
-				var->op_targ = pad_add_name_sv(param, 0, NULL, NULL);
-				SvREFCNT_dec(param);
-				left = op_append_elem(OP_LIST, left, var);
-			}
+			err = newSVOP(OP_CONST, 0,
+				          newSVpvf("Too many arguments for %"SVf, SVfARG(declarator)));
 
-			left->op_flags |= OPf_PARENS;
-			right = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
-			init_param = newASSIGNOP(OPf_STACKED, left, 0, right);
-			init_param = newSTATEOP(0, NULL, init_param);
+			croak = newCVREF(OPf_WANT_SCALAR,
+				             newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
+			err = newUNOP(OP_ENTERSUB, OPf_STACKED,
+				          op_append_elem(OP_LIST, err, croak));
 
-			init = op_append_list(OP_LINESEQ, init, init_param);
+			cond = newBINOP(OP_GT, 0,
+				            newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
+				            newSVOP(OP_CONST, 0, newSViv(args_max)));
+			chk = newLOGOP(OP_AND, 0, cond, err);
+
+			*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
 		}
+	}
+
+	/* $self = shift; */
+	if (SvTRUE(spec->shift)) {
+		OP *var, *shift;
+
+		var = newOP(OP_PADSV, OPf_WANT_SCALAR);
+		var->op_targ = pad_findmy_sv(spec->shift, 0);
+
+		shift = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
+		*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, shift));
+	}
 
-		/* add '();' to make function return nothing by default */
-		/* (otherwise the invisible parameter initialization can "leak" into
-		   the return value: fun ($x) {}->("asdf", 0) == 2) */
-		if (init) {
-			init = op_append_list(OP_LINESEQ, init, newSTATEOP(0, NULL, newOP(OP_STUB, OPf_PARENS)));
+	/* (PARAMS) = @_; */
+	if (params && av_len(params) > -1) {
+		SV *param;
+		OP *init_param, *left, *right;
+
+		left = NULL;
+		while ((param = av_shift(params)) != &PL_sv_undef) {
+			OP *const var = newOP(OP_PADSV, OPf_WANT_LIST);
+			var->op_targ = pad_findmy_sv(param, 0);
+			SvREFCNT_dec(param);
+			left = op_append_elem(OP_LIST, left, var);
 		}
 
-		/* finally let perl parse the actual subroutine body */
-		body = parse_block(0);
+		left->op_flags |= OPf_PARENS;
+		right = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
+		init_param = newASSIGNOP(OPf_STACKED, left, 0, right);
+		init_param = newSTATEOP(0, NULL, init_param);
 
-		body = op_append_list(OP_LINESEQ, init, body);
+		*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, init_param);
+	}
 
-		/* close outer block: '}' */
-		S_block_end(aTHX_ save_ix, body);
+	/* defaults */
+	{
+		OP *gen = NULL;
+		DefaultParamSpec *dp;
+
+		for (dp = defaults; dp; dp = dp->next) {
+			OP *init = dp->init;
+			OP *var, *args, *cond;
+
+			/* var = `$,name */
+			var = newOP(OP_PADSV, 0);
+			var->op_targ = pad_findmy_sv(dp->name, 0);
+
+			/* init = `,var = ,init */
+			init = newASSIGNOP(OPf_STACKED, var, 0, init);
+
+			/* args = `@_ */
+			args = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
+
+			/* cond = `,args < ,index */
+			cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit)));
+
+			/* init = `,init if ,cond */
+			init = newLOGOP(OP_AND, 0, cond, init);
+
+			/* gen = `,gen ; ,init */
+			gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init));
+
+			dp->init = NULL;
+		}
+
+		*prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, gen);
 	}
 
+	/* finally let perl parse the actual subroutine body */
+	body = parse_block(0);
+
+	/* add '();' to make function return nothing by default */
+	/* (otherwise the invisible parameter initialization can "leak" into
+	   the return value: fun ($x) {}->("asdf", 0) == 2) */
+	if (*prelude_sentinel) {
+		body = newSTATEOP(0, NULL, body);
+	}
+
+	body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
+	*prelude_sentinel = NULL;
+
 	/* it's go time. */
 	{
 		OP *const attrs = *attrs_sentinel;
 		*attrs_sentinel = NULL;
 		SvREFCNT_inc_simple_void(PL_compcv);
 
+		/* close outer block: '}' */
+		S_block_end(aTHX_ save_ix, body);
+
 		if (!saw_name) {
 			*pop = newANONATTRSUB(
 				floor_ix,
@@ -508,7 +679,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
 }
 
 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
-	Spec spec;
+	KWSpec spec;
 	int ret;
 
 	SAVETMPS;
@@ -533,11 +704,12 @@ BOOT:
 WARNINGS_ENABLE {
 	HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
 	/**/
-	newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
-	newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
-	newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
+	newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK));
+	newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK));
+	newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
+	newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS));
 	newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
-	newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
+	newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
 	newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
 	newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
 	/**/