view release on metacpan or  search on metacpan

lib/C/Blocks.xs  view on Meta::CPAN

	
	count = call_pv("DynaLoader::dl_find_symbol", G_SCALAR);
	SPAGAIN;
	if (count != 1) croak("C::Blocks expected one return value from dl_find_symbol but got %d\n", count);
	SV * returned = POPs;
	void * to_return = NULL;
	if (SvOK(returned)) to_return = INT2PTR(void*, SvIV(returned));
	
	PUTBACK;
	FREETMPS;
	LEAVE;
	
	return to_return;
}

void * dynaloader_get_lib(pTHX_ char * name) {
	dSP;
	int count;
	
	ENTER;
	SAVETMPS;
	
	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(name, 0)));
	PUTBACK;
	
	count = call_pv("DynaLoader::dl_load_file", G_SCALAR);

	SPAGAIN;
	if (count != 1) croak("C::Blocks expected one return value from dl_load_file but got %d\n", count);
	void * to_return = INT2PTR(void*, POPi);
	
	PUTBACK;
	FREETMPS;
	LEAVE;
	
	return to_return;
}

/***************************/
/**** Testing Functions ****/
/***************************/

char * _c_blocks_get_msg() {
	dTHX;
	SV * msg_SV = get_sv("C::Blocks::_msg", 0);
	return SvPVbyte_nolen(msg_SV);
}
void _c_blocks_send_msg(char * msg) {
	dTHX;
	SV * msg_SV = get_sv("C::Blocks::_msg", 0);
	sv_setpv(msg_SV, msg);
}
void _c_blocks_send_bytes(char * msg, int bytes) {
	dTHX;
	SV * msg_SV = get_sv("C::Blocks::_msg", 0);
	sv_setpvn(msg_SV, msg, bytes);
}

/*****************************************/
/**** Extended symbol table callbacks ****/
/*****************************************/

TokenSym_p my_symtab_lookup_by_name(char * name, int len, void * data, extended_symtab_p* containing_symtab) {
	/* Unpack the callback data */
	extended_symtab_callback_data * callback_data = (extended_symtab_callback_data*)data;
	
	/* In all likelihood, name will *NOT* be null terminated */
	char name_to_find[len + 1];
	strncpy(name_to_find, name, len);
	name_to_find[len] = '\0';
	
	/* Run through all of the available extended symbol tables and look for this
	 * identifier. */
	int i;
	for (i = callback_data->N_tables - 1; i >= 0; i--) {
		extended_symtab_p my_symtab
			= callback_data->available_extended_symtabs[i].exsymtab;
		TokenSym_p ts = tcc_get_extended_tokensym(my_symtab, name_to_find);
		if (ts != NULL) {
			*containing_symtab = my_symtab;
			return ts;
		}
	}
	
	return NULL;
}

void my_symtab_sym_used(char * name, int len, void * data) {
	/* Unpack the callback data */
	extended_symtab_callback_data * callback_data = (extended_symtab_callback_data*)data;
	
	/* Name *IS* null terminated */
	
	/* Run through all of the available extended symbol tables and look for this
	 * identifier. If found, add the symbol to the state. */
	int i;
	void * pointer = NULL;
	for (i = callback_data->N_tables - 1; i >= 0; i--) {
		available_extended_symtab lookup_data
			= callback_data->available_extended_symtabs[i];
		
		/* Scan the dlls first */
		void ** curr_dll = lookup_data.dlls;
		if (curr_dll != NULL) {
			while (*curr_dll != NULL) {
				pointer = dynaloader_get_symbol(
					C_BLOCKS_CALLBACK_MY_PERL(callback_data) *curr_dll, name);
				if (pointer) break;
				curr_dll++;
			}
		}
		
		/* If we didn't find it, check if it's in the exsymtab */
		if (pointer == NULL) {
			pointer = tcc_get_extended_symbol(lookup_data.exsymtab, name);
		}
		
		/* found it? Then we're done */
		if (pointer != NULL) {
			tcc_add_symbol(callback_data->state, name, pointer);

lib/C/Blocks.xs  view on Meta::CPAN

	 * already initialized. */
	GV * glob = (GV*)HeVAL(entry);
	if (isGV(glob)) {
		my_warnif(aTHX_ "import", sv_2mortal(newSVpvf("Could not inject 'import' "
			"into package %s: 'import' method already found",
			SvPVbyte_nolen(PL_curstname))));
		SvREFCNT_dec(name);
		return;
	}
	
	/* initialize the glob */
	SvREFCNT_inc(glob);
	gv_init(glob, PL_curstash, "import", 6, 1);
	if (HeVAL(entry)) {
		SvREFCNT_dec(HeVAL(entry));
	}
	HeVAL(entry) = (SV*)glob;
	
	/* Add the method to the symbol table entry. See Package::Stash::XS
	 * GvSetCV preprocessor macro (specifically taken from v0.28) */
	SvREFCNT_dec(GvCV(glob));
	GvCV_set(glob, import_method_to_inject);
	GvIMPORTED_CV_on(glob);
	GvASSUMECV_on(glob);
	GvCVGEN(glob) = 0;
	mro_method_changed_in(GvSTASH(glob));

	SvREFCNT_dec(name);
	return;

fail:
	if (name != NULL) SvREFCNT_dec(name);
	warn("Internal error while injecting 'import' into package %s: %s",
		SvPVbyte_nolen(PL_curstname), warn_message);
}

void setup_compiler (pTHX_ TCCState * state, c_blocks_data * data) {
	/* Get and reset the compiler options */
	SV * compiler_options = get_sv("C::Blocks::compiler_options", 0);
	if (SvPOK(compiler_options)) tcc_set_options(state, SvPVbyte_nolen(compiler_options));
	SvSetMagicSV(compiler_options, get_sv("C::Blocks::default_compiler_options", 0));
	
	/* Ensure output goes to memory */
	tcc_set_output_type(state, TCC_OUTPUT_MEMORY);
	
	/* Set the error function to write to the error message SV */
	tcc_set_error_func(state, data->error_msg_sv, my_tcc_error_func);
}

void execute_compiler (pTHX_ TCCState * state, c_blocks_data * data, int keyword_type) {
	int len = (int)(data->end - PL_bufptr);
	
	/* Set the extended callback handling */
	extended_symtab_callback_data callback_data = { state, aTHX_ NULL, 0 };
	
	/* Set the extended symbol table lists if they exist */
	if (SvPOK(data->exsymtabs) && SvCUR(data->exsymtabs)) {
		callback_data.N_tables = SvCUR(data->exsymtabs) / sizeof(available_extended_symtab);
		callback_data.available_extended_symtabs = (available_extended_symtab*) SvPV_nolen(data->exsymtabs);
	}
	tcc_set_extended_symtab_callbacks(state, &my_symtab_lookup_by_name,
		&my_symtab_sym_used, &my_prep_table, &callback_data);
	
	/* set the block function's argument, if any */
	if (keyword_type == IS_CBLOCK) {
		/* If this is a block, we need to define C_BLOCKS_THX_DECL.
		 * This will be based on whether tTHX is available or not. */
		#ifdef PERL_IMPLICIT_CONTEXT
			void * return_value_ignored;
			if (my_symtab_lookup_by_name("aTHX", 4, &callback_data, (void*) &return_value_ignored))
				tcc_define_symbol(state, "C_BLOCKS_THX_DECL", "PerlInterpreter * my_perl");
			else
				tcc_define_symbol(state, "C_BLOCKS_THX_DECL", "void * my_perl_NOT_USED");
		#else
			tcc_define_symbol(state, "C_BLOCKS_THX_DECL", "");
		#endif
	}
	
	/* compile the code, which is (by this time) stored entirely in main */
	STRLEN main_len;
	char * to_compile = SvPVbyte(data->code_main, main_len);
	tcc_compile_string_ex(state, to_compile, main_len,
		CopFILE(PL_curcop), CopLINE(PL_curcop));
	
	/* Handle any compilation errors */
	if (SvPOK(data->error_msg_sv)) {
		/* rewrite implicit function declarations as errors */
		char * loc;
		while(loc = strstr(SvPV_nolen(data->error_msg_sv),
			"warning: implicit declaration of function")
		) {
			/* replace "warning: implicit declaration of" with an error */
			sv_insert(data->error_msg_sv, loc - SvPV_nolen(data->error_msg_sv),
				32, "error: undeclared", 17);
		}
		/* Look for errors and croak */
		if (strstr(SvPV_nolen(data->error_msg_sv), "error")) {
			croak("C::Blocks compiler error:\n%s", SvPV_nolen(data->error_msg_sv));
		}
		
		/* Otherwise, report and clear the compiler warnings */
		my_warnif(aTHX_ "compiler", sv_2mortal(newSVsv(data->error_msg_sv)));
		SvPOK_off(data->error_msg_sv);
	}
}

OP * build_op(pTHX_ TCCState * state, int keyword_type) {
	/* build a null op if not creating a cblock */
	if (keyword_type != IS_CBLOCK) return newOP(OP_NULL, 0);
	
	/* get the function pointer for the block */
	IV pointer_IV = PTR2IV(tcc_get_symbol(state, "op_func"));
	if (pointer_IV == 0) {
		croak("C::Blocks internal error: got null pointer for op function!");
	}
	
	/* Store the address of the function pointer on the stack */
	OP * o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(pointer_IV)));
	
	/* Create an op that pops the address off the stack and invokes it */
	o->op_ppaddr = Perl_tcc_pp;