&CORE::foo() for nullary functions

This commit makes nullary subs in the CORE package callable with
ampersand syntax and through references--except for wantarray, which
is more complicated and will have its own commit.

It does this by creating an op tree like this:

$ ./perl -Ilib -MO=Concise,CORE::times -e 'BEGIN{\&CORE::times}'
CORE::times:
3  <1> leavesub[1 ref] K/REFC,1 ->(end)
-     <@> lineseq K ->3
1        <$> coreargs(IV 310) v ->2
2        <0> tms ->3
-e syntax OK

The coreargs op checks to make sure there are no arguments, for now.
The 310 is the op number for times (OP_TMS).

There is no nextstate op, because we want to inherit hints from
the caller.

The __FILE__, __LINE__ and __PACKAGE__ directives are implemented
like this:

$ ./perl -Ilib -MO=Concise,CORE::__FILE__ -e 'BEGIN{\&CORE::__FILE__}'
CORE::__FILE__:
7  <1> leavesub[1 ref] K/REFC,1 ->(end)
-     <@> lineseq K ->7
1        <$> coreargs(PV "__FILE__") v ->2
6        <2> lslice K/2 ->7
-           <1> ex-list lK ->4
2              <0> pushmark s ->3
3              <$> const(IV 1) s ->4
-           <1> ex-list lK ->6
4              <0> pushmark s ->5
5              <0> caller[t1] l ->6
-e syntax OK

The lslice op and its children are equivalent to (caller)[1].

5 files changed, 226 insertions, 11 deletions

diff --git a/MANIFEST b/MANIFEST
index 8e999d7ca4..9c81b29ace 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4918,6 +4918,7 @@ t/op/concat.t			See if string concatenation works
 t/op/cond.t			See if conditional expressions work
 t/op/context.t			See if context propagation works
 t/op/coreinline.t		Test inlining of \&CORE::subs
+t/op/coresubs.t			Test &CORE::subs()
 t/op/cproto.t			Check builtin prototypes
 t/op/crypt.t			See if crypt works
 t/op/dbm.t			See if dbmopen/dbmclose work
diff --git a/gv.c b/gv.c
index aa306c81a9..6c9cf936b4 100644
--- a/gv.c
+++ b/gv.c
@@ -1333,32 +1333,104 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	  if (strnEQ(stashname, "CORE", 4)) {
 	    const int code = keyword(name, len, 1);
 	    static const char file[] = __FILE__;
-	    CV *cv;
+	    CV *cv, *oldcompcv;
 	    int opnum = 0;
 	    SV *opnumsv;
+	    bool ampable = FALSE; /* &{}-able */
+	    OP *o;
+	    COP *oldcurcop;
+	    yy_parser *oldparser;
+	    I32 oldsavestack_ix;
+
 	    if (code >= 0) return gv; /* not overridable */
+	    switch (-code) {
 	     /* no support for \&CORE::infix;
 	        no support for funcs that take labels, as their parsing is
 	        weird  */
-	    switch (-code) {
 	    case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
 	    case KEY_eq: case KEY_ge:
 	    case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
 	    case KEY_or: case KEY_x: case KEY_xor:
 		return gv;
+	    case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
+	    case KEY_continue: case KEY_endgrent: case KEY_endhostent:
+	    case KEY_endnetent: case KEY_endprotoent: case KEY_endpwent:
+	    case KEY_endservent: case KEY_getgrent: case KEY_gethostent:
+	    case KEY_getlogin: case KEY_getnetent: case KEY_getppid:
+	    case KEY_getprotoent: case KEY_getservent: case KEY_setgrent:
+	    case KEY_setpwent: case KEY_time: case KEY_times:
+	    case KEY_wait:
+		ampable = TRUE;
 	    }
-	    /* Avoid calling newXS, as it calls us, and things start to
-	       get hairy. */
-	    cv = MUTABLE_CV(newSV_type(SVt_PVCV));
-	    GvCV_set(gv,cv);
-	    GvCVGEN(gv) = 0;
-	    mro_method_changed_in(GvSTASH(gv));
-	    CvGV_set(cv, gv);
+	    if (ampable) {
+		ENTER;
+		oldcurcop = PL_curcop;
+		oldparser = PL_parser;
+		lex_start(NULL, NULL, 0);
+		oldcompcv = PL_compcv;
+		PL_compcv = NULL; /* Prevent start_subparse from setting
+		                     CvOUTSIDE. */
+		oldsavestack_ix = start_subparse(FALSE,0);
+		cv = PL_compcv;
+	    }
+	    else {
+		/* Avoid calling newXS, as it calls us, and things start to
+		   get hairy. */
+		cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+		GvCV_set(gv,cv);
+		GvCVGEN(gv) = 0;
+		mro_method_changed_in(GvSTASH(gv));
+		CvISXSUB_on(cv);
+		CvXSUB(cv) = core_xsub;
+	    }
+	    CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
+	                         from PL_curcop. */
 	    (void)gv_fetchfile(file);
 	    CvFILE(cv) = (char *)file;
-	    CvISXSUB_on(cv);
-	    CvXSUB(cv) = core_xsub;
+	    /* XXX This is inefficient, as doing things this order causes
+	           a prototype check in newATTRSUB.  But we have to do
+	           it this order as we need an op number before calling
+	           new ATTRSUB. */
 	    (void)core_prototype((SV *)cv, name, code, &opnum);
+	    if (ampable) {
+		OP * const argop =
+		  newSVOP(OP_COREARGS,0,
+		          opnum ? newSVuv((UV)opnum) : newSVpvn(name,len));
+		switch(opnum) {
+		case 0:
+		    {
+			IV index = 0;
+			switch(-code) {
+			case KEY___FILE__   : index = 1; break;
+			case KEY___LINE__   : index = 2; break;
+			}
+			o = op_append_elem(OP_LINESEQ,
+			        argop,
+			        newSLICEOP(0,
+			                   newSVOP(OP_CONST, 0,
+			                           newSViv(index)
+		                                  ),
+			                   newOP(OP_CALLER,0)
+			        )
+			    );
+			break;
+		    }
+		default:
+		    o = op_append_elem(OP_LINESEQ, argop, newOP(opnum,0));
+		}
+		newATTRSUB(oldsavestack_ix,
+		           newSVOP(
+		                 OP_CONST, 0,
+		                 newSVpvn_share(nambeg,full_len,0)
+		           ),
+		           NULL,NULL,o
+		);
+		assert(GvCV(gv) == cv);
+		LEAVE;
+		PL_parser = oldparser;
+		PL_curcop = oldcurcop;
+		PL_compcv = oldcompcv;
+	    }
 	    opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
 	    cv_set_call_checker(
 	       cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
diff --git a/pp.c b/pp.c
index b1520bad6a..7bf6d6eda2 100644
--- a/pp.c
+++ b/pp.c
@@ -5967,6 +5967,34 @@ PP(pp_boolkeys)
 PP(pp_coreargs)
 {
     dSP;
+    int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
+    AV * const at_ = GvAV(PL_defgv);
+    I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
+    I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
+    const char *err = NULL;
+
+    /* Count how many args there are. */
+    while (oa) {
+	maxargs++;
+	oa >>= 4;
+    }
+
+    if(numargs < minargs) err = "Not enough";
+    else if(numargs > maxargs) err = "Too many";
+    if (err)
+	/* diag_listed_as: Too many arguments for %s */
+	Perl_croak(aTHX_
+	  "%s arguments for %s", err,
+	   opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
+	);
+
+    /* Reset the stack pointer.  Without this, we end up returning our own
+       arguments in list context, in addition to the values we are supposed
+       to return.  nextstate usually does this on sub entry, but we need
+       to run the next op with the caller’s hints, so we cannot have a
+       nextstate. */
+    SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+
     RETURN;
 }
 
diff --git a/t/op/coreinline.t b/t/op/coreinline.t
index fb5c44e564..34ae9e23ed 100644
--- a/t/op/coreinline.t
+++ b/t/op/coreinline.t
@@ -1,5 +1,9 @@
 #!./perl
 
+# This script tests the inlining of CORE:: subs.  Since it’s convenient
+# (this script reads the list in keywords.pl), we also test that prototypes
+# match the built-ins and check for undefinedness.
+
 BEGIN {
     chdir 't' if -d 't';
     @INC = qw(. ../lib);
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
new file mode 100644
index 0000000000..71e030a6f7
--- /dev/null
+++ b/t/op/coresubs.t
@@ -0,0 +1,110 @@
+#!./perl
+
+# This file tests the results of calling subroutines in the CORE::
+# namespace with ampersand syntax.  In other words, it tests the bodies of
+# the subroutines themselves, not the ops that they might inline themselves
+# as when called as barewords.
+
+# coreinline.t tests the inlining of these subs as ops.  Since it was
+# convenient, I also put the prototype and undefinedness checking in that
+# file, even though those have nothing to do with inlining.  (coreinline.t
+# reads the list in keywords.pl, which is why it’s convenient.)
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+    require "test.pl";
+    $^P |= 0x100;
+}
+# Since tests inside evals can too easily fail silently, we cannot rely
+# on done_testing. It’s much easier to count the tests as we go than to
+# declare the plan up front, so this script ends with a test that makes
+# sure the right number of tests have happened.
+
+sub lis($$;$) {
+  &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
+}
+
+# This tests that the &{} syntax respects the number of arguments implied
+# by the prototype.
+sub test_proto {
+  my($o) = shift;
+
+  # Create an alias, for the caller’s convenience.
+  *{"my$o"} = \&{"CORE::$o"};
+
+  my $p = prototype "CORE::$o";
+
+  if ($p eq '') {
+    $tests ++;
+
+    eval " &CORE::$o(1) ";
+    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+
+  }
+
+  else {
+    die "Please add tests for the $p prototype";
+  }
+}
+
+test_proto '__FILE__';
+test_proto '__LINE__';
+test_proto '__PACKAGE__';
+
+is file(), 'frob'    , '__FILE__ does check its caller'   ; ++ $tests;
+is line(),  5        , '__LINE__ does check its caller'   ; ++ $tests;
+is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
+
+test_proto 'continue';
+$tests ++;
+CORE::given(1) {
+  CORE::when(1) {
+    &mycontinue();
+  }
+  pass "&continue";
+}
+
+test_proto $_ for qw(
+ endgrent endhostent endnetent endprotoent endpwent endservent
+);
+
+test_proto "get$_" for qw '
+  grent hostent login
+  netent ppid protoent
+  servent
+';
+
+test_proto "set$_" for qw '
+  grent pwent
+';
+
+test_proto 'time';
+$tests += 2;
+like &mytime, '^\d+\z', '&time in scalar context';
+like join('-', &mytime), '^\d+\z', '&time in list context';
+
+test_proto 'times';
+$tests += 2;
+like &mytimes, '^[\d.]+\z', '&times in scalar context';
+like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
+   '&times in list context';
+
+test_proto 'wait';
+
+
+# Add new tests above this line.
+
+# ------------ END TESTING ----------- #
+
+is curr_test, $tests+1, 'right number of tests';
+done_testing;
+
+#line 3 frob
+
+sub file { &CORE::__FILE__ }
+sub line { &CORE::__LINE__ } # 5
+package stribble;
+sub main::pakg { &CORE::__PACKAGE__ }
+
+# Please do not add new tests here.