[perl5.git] / builtin.c

/*    builtin.c
 *
 *    Copyright (C) 2021 by Paul Evans and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/* This file contains the code that implements functions in perl's "builtin::"
 * namespace
 */

#include "EXTERN.h"
#include "perl.h"

#include "XSUB.h"

struct BuiltinFuncDescriptor {
    const char *name;
    XSUBADDR_t xsub;
    OP *(*checker)(pTHX_ OP *, GV *, SV *);
    IV ckval;
};

#define warn_experimental_builtin(name, prefix) S_warn_experimental_builtin(aTHX_ name, prefix)
static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix)
{
    /* diag_listed_as: Built-in function '%s' is experimental */
    Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
                     "Built-in function '%s%s' is experimental",
                     prefix ? "builtin::" : "", name);
}

XS(XS_builtin_true);
XS(XS_builtin_true)
{
    dXSARGS;
    warn_experimental_builtin("true", true);
    if(items)
        croak_xs_usage(cv, "");
    XSRETURN_YES;
}

XS(XS_builtin_false);
XS(XS_builtin_false)
{
    dXSARGS;
    warn_experimental_builtin("false", true);
    if(items)
        croak_xs_usage(cv, "");
    XSRETURN_NO;
}

enum {
    BUILTIN_CONST_FALSE,
    BUILTIN_CONST_TRUE,
};

static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));

    warn_experimental_builtin(builtin->name, false);

    SV *prototype = newSVpvs("");
    SAVEFREESV(prototype);

    assert(entersubop->op_type == OP_ENTERSUB);

    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);

    SV *constval;
    switch(builtin->ckval) {
        case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
        case BUILTIN_CONST_TRUE:  constval = &PL_sv_yes; break;
        default:
            DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf,
                      builtin->ckval);
            break;
    }

    op_free(entersubop);

    return newSVOP(OP_CONST, 0, constval);
}

XS(XS_builtin_func1_scalar);
XS(XS_builtin_func1_scalar)
{
    dXSARGS;
    dXSI32;

    warn_experimental_builtin(PL_op_name[ix], true);

    if(items != 1)
        croak_xs_usage(cv, "arg");

    switch(ix) {
        case OP_ISBOOL:
            Perl_pp_isbool(aTHX);
            break;

        case OP_ISWEAK:
            Perl_pp_isweak(aTHX);
            break;

        case OP_BLESSED:
            Perl_pp_blessed(aTHX);
            break;

        case OP_REFADDR:
            Perl_pp_refaddr(aTHX);
            break;

        case OP_REFTYPE:
            Perl_pp_reftype(aTHX);
            break;

        case OP_CEIL:
            Perl_pp_ceil(aTHX);
            break;

        case OP_FLOOR:
            Perl_pp_floor(aTHX);
            break;

        default:
            Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
                           " for xs_builtin_func1_scalar()", (IV) ix);
    }

    XSRETURN(1);
}

XS(XS_builtin_func1_void);
XS(XS_builtin_func1_void)
{
    dXSARGS;
    dXSI32;

    warn_experimental_builtin(PL_op_name[ix], true);

    if(items != 1)
        croak_xs_usage(cv, "arg");

    switch(ix) {
        case OP_WEAKEN:
            Perl_pp_weaken(aTHX);
            break;

        case OP_UNWEAKEN:
            Perl_pp_unweaken(aTHX);
            break;

        default:
            Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
                           " for xs_builtin_func1_void()", (IV) ix);
    }

    XSRETURN(0);
}

static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));

    warn_experimental_builtin(builtin->name, false);

    SV *prototype = newSVpvs("$");
    SAVEFREESV(prototype);

    assert(entersubop->op_type == OP_ENTERSUB);

    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);

    OP *parent = entersubop, *pushop, *argop;

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) {
        pushop = cUNOPx(pushop)->op_first;
    }

    argop = OpSIBLING(pushop);

    if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop)))
        return entersubop;

    (void)op_sibling_splice(parent, pushop, 1, NULL);

    U8 wantflags = entersubop->op_flags & OPf_WANT;

    op_free(entersubop);

    OPCODE opcode = builtin->ckval;

    return newUNOP(opcode, wantflags, argop);
}

static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";

static const struct BuiltinFuncDescriptor builtins[] = {
    /* constants */
    { "builtin::true",   &XS_builtin_true,   &ck_builtin_const, BUILTIN_CONST_TRUE  },
    { "builtin::false",  &XS_builtin_false,  &ck_builtin_const, BUILTIN_CONST_FALSE },

    /* unary functions */
    { "builtin::isbool",   &XS_builtin_func1_scalar, &ck_builtin_func1, OP_ISBOOL   },
    { "builtin::weaken",   &XS_builtin_func1_void,   &ck_builtin_func1, OP_WEAKEN   },
    { "builtin::unweaken", &XS_builtin_func1_void,   &ck_builtin_func1, OP_UNWEAKEN },
    { "builtin::isweak",   &XS_builtin_func1_scalar, &ck_builtin_func1, OP_ISWEAK   },
    { "builtin::blessed",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED  },
    { "builtin::refaddr",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR  },
    { "builtin::reftype",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE  },
    { "builtin::ceil",     &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL     },
    { "builtin::floor",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR    },
    { 0 }
};

XS(XS_builtin_import);
XS(XS_builtin_import)
{
    dXSARGS;

    if(!PL_compcv)
        Perl_croak(aTHX_
                "builtin::import can only be called at compiletime");

    /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
    ENTER;
    SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
    SAVESPTR(PL_comppad);      PL_comppad      = PadlistARRAY(CvPADLIST(PL_compcv))[1];
    SAVESPTR(PL_curpad);       PL_curpad       = PadARRAY(PL_comppad);

    for(int i = 1; i < items; i++) {
        SV *sym = ST(i);
        if(strEQ(SvPV_nolen(sym), "import"))
            Perl_croak(aTHX_ builtin_not_recognised, sym);

        SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
        SV *fqname  = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));

        CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
        if(!cv)
            Perl_croak(aTHX_ builtin_not_recognised, sym);

        PADOFFSET off = pad_add_name_sv(ampname, padadd_STATE, 0, 0);
        SvREFCNT_dec(PL_curpad[off]);
        PL_curpad[off] = SvREFCNT_inc(cv);
    }

    intro_my();

    LEAVE;
}

void
Perl_boot_core_builtin(pTHX)
{
    I32 i;
    for(i = 0; builtins[i].name; i++) {
        const struct BuiltinFuncDescriptor *builtin = &builtins[i];

        const char *proto = NULL;
        if(builtin->checker == &ck_builtin_const)
            proto = "";
        else if(builtin->checker == &ck_builtin_func1)
            proto = "$";

        CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0);
        XSANY.any_i32 = builtin->ckval;

        if(builtin->checker) {
            cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
        }
    }

    newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
}

/*
 * ex: set ts=8 sts=4 sw=4 et:
 */
Commit	Line	Data
6a2e756f PE	1	/* builtin.c
	2	*
	3	* Copyright (C) 2021 by Paul Evans and others
	4	*
	5	* You may distribute under the terms of either the GNU General Public
	6	* License or the Artistic License, as specified in the README file.
	7	*
	8	*/
	9
	10	/* This file contains the code that implements functions in perl's "builtin::"
	11	* namespace
	12	*/
	13
	14	#include "EXTERN.h"
	15	#include "perl.h"
	16
	17	#include "XSUB.h"
	18
852c1a84 PE	19	struct BuiltinFuncDescriptor {
	20	const char *name;
	21	XSUBADDR_t xsub;
	22	OP (checker)(pTHX_ OP , GV , SV *);
	23	IV ckval;
	24	};
	25
929db505 DIM	26	#define warn_experimental_builtin(name, prefix) S_warn_experimental_builtin(aTHX_ name, prefix)
	27	static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix)
	28	{
	29	/* diag_listed_as: Built-in function '%s' is experimental */
	30	Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
	31	"Built-in function '%s%s' is experimental",
	32	prefix ? "builtin::" : "", name);
	33	}
	34
6a2e756f PE	35	XS(XS_builtin_true);
	36	XS(XS_builtin_true)
	37	{
	38	dXSARGS;
929db505	39	warn_experimental_builtin("true", true);
6a2e756f PE	40	if(items)
	41	croak_xs_usage(cv, "");
	42	XSRETURN_YES;
	43	}
	44
	45	XS(XS_builtin_false);
	46	XS(XS_builtin_false)
	47	{
	48	dXSARGS;
929db505	49	warn_experimental_builtin("false", true);
6a2e756f PE	50	if(items)
	51	croak_xs_usage(cv, "");
	52	XSRETURN_NO;
	53	}
	54
852c1a84 PE	55	enum {
	56	BUILTIN_CONST_FALSE,
	57	BUILTIN_CONST_TRUE,
	58	};
	59
	60	static OP ck_builtin_const(pTHX_ OP entersubop, GV namegv, SV ckobj)
	61	{
	62	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	63
929db505	64	warn_experimental_builtin(builtin->name, false);
cc4aa213	65
852c1a84 PE	66	SV *prototype = newSVpvs("");
	67	SAVEFREESV(prototype);
	68
	69	assert(entersubop->op_type == OP_ENTERSUB);
	70
	71	entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
	72
	73	SV *constval;
	74	switch(builtin->ckval) {
	75	case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
	76	case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break;
	77	default:
c0e63b13 KW	78	DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf,
c0e63b13 KW	79	builtin->ckval);
852c1a84 PE	80	break;
	81	}
	82
	83	op_free(entersubop);
	84
	85	return newSVOP(OP_CONST, 0, constval);
	86	}
	87
6ac93b49 PE	88	XS(XS_builtin_func1_scalar);
6ac93b49 PE	89	XS(XS_builtin_func1_scalar)
6a2e756f PE	90	{
6a2e756f PE	91	dXSARGS;
852c1a84 PE	92	dXSI32;
852c1a84 PE	93
929db505 DIM	94	warn_experimental_builtin(PL_op_name[ix], true);
929db505 DIM	95
6a2e756f	96	if(items != 1)
852c1a84 PE	97	croak_xs_usage(cv, "arg");
	98
	99	switch(ix) {
6ac93b49	100	case OP_ISBOOL:
852c1a84 PE	101	Perl_pp_isbool(aTHX);
852c1a84 PE	102	break;
6a2e756f	103
6ac93b49 PE	104	case OP_ISWEAK:
	105	Perl_pp_isweak(aTHX);
	106	break;
	107
d2817bd7 PE	108	case OP_BLESSED:
	109	Perl_pp_blessed(aTHX);
	110	break;
	111
	112	case OP_REFADDR:
	113	Perl_pp_refaddr(aTHX);
	114	break;
	115
	116	case OP_REFTYPE:
	117	Perl_pp_reftype(aTHX);
	118	break;
	119
17a8df70 JR	120	case OP_CEIL:
	121	Perl_pp_ceil(aTHX);
	122	break;
	123
	124	case OP_FLOOR:
	125	Perl_pp_floor(aTHX);
	126	break;
	127
852c1a84	128	default:
c0e63b13	129	Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
730f927d	130	" for xs_builtin_func1_scalar()", (IV) ix);
852c1a84 PE	131	}
	132
	133	XSRETURN(1);
	134	}
	135
6ac93b49 PE	136	XS(XS_builtin_func1_void);
	137	XS(XS_builtin_func1_void)
	138	{
	139	dXSARGS;
	140	dXSI32;
	141
929db505 DIM	142	warn_experimental_builtin(PL_op_name[ix], true);
929db505 DIM	143
6ac93b49 PE	144	if(items != 1)
	145	croak_xs_usage(cv, "arg");
	146
	147	switch(ix) {
	148	case OP_WEAKEN:
	149	Perl_pp_weaken(aTHX);
	150	break;
	151
	152	case OP_UNWEAKEN:
	153	Perl_pp_unweaken(aTHX);
	154	break;
	155
	156	default:
730f927d KW	157	Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
730f927d KW	158	" for xs_builtin_func1_void()", (IV) ix);
6ac93b49 PE	159	}
	160
	161	XSRETURN(0);
	162	}
	163
852c1a84 PE	164	static OP ck_builtin_func1(pTHX_ OP entersubop, GV namegv, SV ckobj)
	165	{
	166	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	167
929db505	168	warn_experimental_builtin(builtin->name, false);
cc4aa213	169
852c1a84 PE	170	SV *prototype = newSVpvs("$");
	171	SAVEFREESV(prototype);
	172
	173	assert(entersubop->op_type == OP_ENTERSUB);
	174
	175	entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
	176
	177	OP parent = entersubop, pushop, *argop;
	178
	179	pushop = cUNOPx(entersubop)->op_first;
	180	if (!OpHAS_SIBLING(pushop)) {
	181	pushop = cUNOPx(pushop)->op_first;
	182	}
	183
	184	argop = OpSIBLING(pushop);
	185
	186	if (!argop \|\| !OpHAS_SIBLING(argop) \|\| OpHAS_SIBLING(OpSIBLING(argop)))
	187	return entersubop;
	188
	189	(void)op_sibling_splice(parent, pushop, 1, NULL);
	190
1c57e396	191	U8 wantflags = entersubop->op_flags & OPf_WANT;
852c1a84 PE	192
	193	op_free(entersubop);
	194
6ac93b49	195	OPCODE opcode = builtin->ckval;
852c1a84	196
1c57e396	197	return newUNOP(opcode, wantflags, argop);
6a2e756f PE	198	}
6a2e756f PE	199
a64a1b91 DIM	200	static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
a64a1b91 DIM	201
852c1a84 PE	202	static const struct BuiltinFuncDescriptor builtins[] = {
	203	/* constants */
	204	{ "builtin::true", &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE },
	205	{ "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE },
	206
	207	/* unary functions */
6ac93b49 PE	208	{ "builtin::isbool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_ISBOOL },
	209	{ "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN },
	210	{ "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN },
	211	{ "builtin::isweak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_ISWEAK },
d2817bd7 PE	212	{ "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED },
	213	{ "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR },
	214	{ "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE },
17a8df70 JR	215	{ "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL },
17a8df70 JR	216	{ "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR },
852c1a84 PE	217	{ 0 }
	218	};
	219
6a2e756f PE	220	XS(XS_builtin_import);
	221	XS(XS_builtin_import)
	222	{
	223	dXSARGS;
	224
	225	if(!PL_compcv)
	226	Perl_croak(aTHX_
	227	"builtin::import can only be called at compiletime");
	228
	229	/* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
	230	ENTER;
	231	SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
	232	SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1];
	233	SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
	234
	235	for(int i = 1; i < items; i++) {
	236	SV *sym = ST(i);
a64a1b91 DIM	237	if(strEQ(SvPV_nolen(sym), "import"))
a64a1b91 DIM	238	Perl_croak(aTHX_ builtin_not_recognised, sym);
6a2e756f PE	239
	240	SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
	241	SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));
	242
	243	CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
a64a1b91 DIM	244	if(!cv)
a64a1b91 DIM	245	Perl_croak(aTHX_ builtin_not_recognised, sym);
6a2e756f PE	246
	247	PADOFFSET off = pad_add_name_sv(ampname, padadd_STATE, 0, 0);
	248	SvREFCNT_dec(PL_curpad[off]);
	249	PL_curpad[off] = SvREFCNT_inc(cv);
6a2e756f PE	250	}
	251
	252	intro_my();
	253
	254	LEAVE;
	255	}
	256
	257	void
	258	Perl_boot_core_builtin(pTHX)
	259	{
852c1a84 PE	260	I32 i;
	261	for(i = 0; builtins[i].name; i++) {
	262	const struct BuiltinFuncDescriptor *builtin = &builtins[i];
	263
	264	const char *proto = NULL;
	265	if(builtin->checker == &ck_builtin_const)
	266	proto = "";
	267	else if(builtin->checker == &ck_builtin_func1)
	268	proto = "$";
	269
	270	CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0);
	271	XSANY.any_i32 = builtin->ckval;
	272
	273	if(builtin->checker) {
	274	cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
	275	}
	276	}
6a2e756f PE	277
	278	newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
	279	}
	280
	281	/*
	282	* ex: set ts=8 sts=4 sw=4 et:
	283	*/