コード例 #1
0
void getjobnum(void)
{
	uint4 	status;
	int4 	item_code;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	item_code = JPI$_PID;
	if (SS$_NORMAL !=(status = lib$getjpi(&item_code, 0, 0, &process_id, 0, 0)))
		rts_error(VARLSTCNT(1) status);
	get_proc_info(process_id, TADR(login_time), &image_count);
}
コード例 #2
0
void gtm_threadgbl_init(void)
{
	void	*lcl_gtm_threadgbl;

	if (SIZEOF(gtm_threadgbl_true_t) != size_gtm_threadgbl_struct)
	{	/* Size mismatch with gtm_threadgbl_deftypes.h - no error handling yet available so do
		 * the best we can.
		 */
		FPRINTF(stderr, "GTM-F-GTMASSERT gtm_threadgbl_true_t and gtm_threadgbl_t are different sizes\n");
		exit(ERR_GTMASSERT);
	}
	if (NULL != gtm_threadgbl)
	{	/* has already been initialized - don't re-init */
		FPRINTF(stderr, "GTM-F-GTMASSERT gtm_threadgbl is already initialized\n");
		exit(ERR_GTMASSERT);
	}
	gtm_threadgbl = lcl_gtm_threadgbl = malloc(size_gtm_threadgbl_struct);
	if (NULL == gtm_threadgbl)
	{	/* Storage was not allocated for some reason - no error handling yet still */
		perror("GTM-F-MEMORY Unable to allocate startup thread structure");
		exit(UNIX_ONLY(ERR_MEMORY) VMS_ONLY(ERR_VMSMEMORY));
	}
	memset(gtm_threadgbl, 0, size_gtm_threadgbl_struct);
	gtm_threadgbl_true = (gtm_threadgbl_true_t *)gtm_threadgbl;

	/* Add specific initializations if other than 0s here using the TREF() family of macros: */
	(TREF(director_ident)).addr = TADR(director_string);
	TREF(for_stack_ptr) = TADR(for_stack);
	(TREF(gtmprompt)).addr = TADR(prombuf);
	(TREF(gtmprompt)).len = SIZEOF(DEFAULT_PROMPT) - 1;
	TREF(lv_null_subs) = LVNULLSUBS_OK;	/* UNIX: set in gtm_env_init_sp(), VMS: set in gtm$startup() - init'd here
							 * in case alternative invocation methods bypass gtm_startup()
							 */
	MEMCPY_LIT(TADR(prombuf), DEFAULT_PROMPT);
	(TREF(replgbl)).jnl_release_timeout = DEFAULT_JNL_RELEASE_TIMEOUT;
	(TREF(window_ident)).addr = TADR(window_string);
}
コード例 #3
0
ファイル: m_break.c プロジェクト: CeperaCPP/fis-gtm
int m_break(void)
{
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if ((TK_SPACE != TREF(window_token)) && (TK_EOL != TREF(window_token)))
		if (!m_xecute())
			return FALSE;
	newtriple(OC_BREAK);
	if (TREF(for_stack_ptr) == TADR(for_stack))
		start_fetches (OC_FETCH);
	else
		start_for_fetches ();
	return TRUE;
}
コード例 #4
0
ファイル: gtm_startup.c プロジェクト: duck57/fis-gtm-freebsd
void gtm_startup(struct startup_vector *svec)
/* Note: various references to data copied from *svec could profitably be referenced directly */
{
	unsigned char	*mstack_ptr;
	void		gtm_ret_code();
	static readonly unsigned char init_break[1] = {'B'};
	int4		lct;
	int		i;
	static char 	other_mode_buf[] = "OTHER";
	mstr		log_name;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	assert(INVALID_IMAGE != image_type);
	assert(svec->argcnt == SIZEOF(*svec));
	IA64_ONLY(init_xfer_table());
	get_page_size();
	cache_table_relobjs = &cache_table_rebuild;
	ht_rhash_ch = &hashtab_rehash_ch;
	jbxm_dump_ch = &jobexam_dump_ch;
	heartbeat_timer_ptr = &heartbeat_timer;
	stpgc_ch = &stp_gcol_ch;
	rtn_fst_table = rtn_names = (rtn_tabent *)svec->rtn_start;
	rtn_names_end = rtn_names_top = (rtn_tabent *)svec->rtn_end;
	if (svec->user_stack_size < 4096)
		svec->user_stack_size = 4096;
	if (svec->user_stack_size > 8388608)
		svec->user_stack_size = 8388608;
	mstack_ptr = (unsigned char *)malloc(svec->user_stack_size);
	msp = stackbase = mstack_ptr + svec->user_stack_size - mvs_size[MVST_STORIG];
	/* mark the stack base so that if error occur during call-in gtm_init(), the unwind
	 * logic in gtmci_ch() will get rid of the stack completely
	 */
	fgncal_stack = stackbase;
	mv_chain = (mv_stent *)msp;
	mv_chain->mv_st_type = MVST_STORIG;	/* Initialize first (anchor) mv_stent so doesn't do anything */
	mv_chain->mv_st_next = 0;
	mv_chain->mv_st_cont.mvs_storig = 0;
	stacktop = mstack_ptr + 2 * mvs_size[MVST_NTAB];
	stackwarn = stacktop + (16 * 1024);
	break_message_mask = svec->break_message_mask;
	if (svec->user_strpl_size < STP_INITSIZE)
		svec->user_strpl_size = STP_INITSIZE;
	else if (svec->user_strpl_size > STP_MAXINITSIZE)
		svec->user_strpl_size = STP_MAXINITSIZE;
	stp_init(svec->user_strpl_size);
	if (svec->user_indrcache_size > MAX_INDIRECTION_NESTING || svec->user_indrcache_size < MIN_INDIRECTION_NESTING)
		svec->user_indrcache_size = MIN_INDIRECTION_NESTING;
	TREF(ind_result_array) = (mval **)malloc(SIZEOF(mval *) * svec->user_indrcache_size);
	TREF(ind_source_array) = (mval **)malloc(SIZEOF(mval *) * svec->user_indrcache_size);
	TREF(ind_result_sp) = TREF(ind_result_array);
	TREF(ind_result_top) = TREF(ind_result_sp) + svec->user_indrcache_size;
	TREF(ind_source_sp) = TREF(ind_source_array);
	TREF(ind_source_top) = TREF(ind_source_sp) + svec->user_indrcache_size;
	rts_stringpool = stringpool;
	TREF(compile_time) = FALSE;
	/* assert that is_replicator and run_time is properly set by gtm_imagetype_init invoked at process entry */
#	ifdef DEBUG
	switch (image_type)
	{
		case GTM_IMAGE:
		case GTM_SVC_DAL_IMAGE:
			assert(is_replicator && run_time);
			break;
		case MUPIP_IMAGE:
			assert(!is_replicator && !run_time);
			break;
		default:
			assert(FALSE);
	}
#	endif
	gtm_utf8_init(); /* Initialize the runtime for Unicode */
	/* Initialize alignment requirement for the runtime stringpool */
	log_name.addr = DISABLE_ALIGN_STRINGS;
	log_name.len = STR_LIT_LEN(DISABLE_ALIGN_STRINGS);
	/* mstr_native_align = logical_truth_value(&log_name, FALSE, NULL) ? FALSE : TRUE; */
	mstr_native_align = FALSE; /* TODO: remove this line and uncomment the above line */
	getjobname();
	INVOKE_INIT_SECSHR_ADDRS;
	getzprocess();
	getzmode();
	geteditor();
	zcall_init();
	cmd_qlf.qlf = glb_cmd_qlf.qlf;
	cache_init();
#	ifdef __sun
	if (NULL != GETENV(PACKAGE_ENV_TYPE))	/* chose xcall (default) or rpc zcall */
		xfer_table[xf_fnfgncal] = (xfer_entry_t)op_fnfgncal_rpc;  /* using RPC */
#	endif
	msp -= SIZEOF(stack_frame);
	frame_pointer = (stack_frame *)msp;
	memset(frame_pointer,0, SIZEOF(stack_frame));
	frame_pointer->temps_ptr = (unsigned char *)frame_pointer;
	frame_pointer->ctxt = GTM_CONTEXT(gtm_ret_code);
	frame_pointer->mpc = CODE_ADDRESS(gtm_ret_code);
	frame_pointer->type = SFT_COUNT;
	frame_pointer->rvector = (rhdtyp*)malloc(SIZEOF(rhdtyp));
	memset(frame_pointer->rvector, 0, SIZEOF(rhdtyp));
	symbinit();
	/* Variables for supporting $ZSEARCH sorting and wildcard expansion */
	TREF(zsearch_var) = lv_getslot(curr_symval);
	TREF(zsearch_dir1) = lv_getslot(curr_symval);
	TREF(zsearch_dir2) = lv_getslot(curr_symval);
	LVVAL_INIT((TREF(zsearch_var)), curr_symval);
	LVVAL_INIT((TREF(zsearch_dir1)), curr_symval);
	LVVAL_INIT((TREF(zsearch_dir2)), curr_symval);
	/* Initialize global pointer to control-C handler. Also used in iott_use */
	ctrlc_handler_ptr = &ctrlc_handler;
	io_init(IS_MUPIP_IMAGE);		/* starts with nocenable for GT.M runtime, enabled for MUPIP */
	if (!IS_MUPIP_IMAGE)
	{
		sig_init(generic_signal_handler, ctrlc_handler_ptr, suspsigs_handler, continue_handler);
		atexit(gtm_exit_handler);
		cenable();	/* cenable unless the environment indicates otherwise - 2 steps because this can report errors */
	}
	jobinterrupt_init();
	getzdir();
	dpzgbini();
	zco_init();
	/* a base addr of 0 indicates a gtm_init call from an rpc server */
	if ((GTM_IMAGE == image_type) && (NULL != svec->base_addr))
		jobchild_init();
	else
	{	/* Trigger enabled utilities will enable through here */
		(TREF(dollar_zmode)).mvtype = MV_STR;
		(TREF(dollar_zmode)).str.addr = other_mode_buf;
		(TREF(dollar_zmode)).str.len = SIZEOF(other_mode_buf) -1;
	}
	svec->frm_ptr = (unsigned char *)frame_pointer;
	dollar_ztrap.mvtype = MV_STR;
	dollar_ztrap.str.len = SIZEOF(init_break);
	dollar_ztrap.str.addr = (char *)init_break;
	dollar_zstatus.mvtype = MV_STR;
	dollar_zstatus.str.len = 0;
	dollar_zstatus.str.addr = NULL;
	ecode_init();
	zyerror_init();
	ztrap_form_init();
	ztrap_new_init();
	zdate_form_init(svec);
	dollar_system_init(svec);
	init_callin_functable();
	gtm_env_xlate_init();
	SET_LATCH_GLOBAL(&defer_latch, LOCK_AVAILABLE);
	curr_pattern = pattern_list = &mumps_pattern;
	pattern_typemask = mumps_pattern.typemask;
	initialize_pattern_table();
	ce_init();	/* initialize compiler escape processing */
	/* Initialize local collating sequence */
	TREF(transform) = TRUE;
	lct = find_local_colltype();
	if (lct != 0)
	{
		TREF(local_collseq) = ready_collseq(lct);
		if (!TREF(local_collseq))
		{
			exi_condition = -ERR_COLLATIONUNDEF;
			gtm_putmsg(VARLSTCNT(3) ERR_COLLATIONUNDEF, 1, lct);
			exit(exi_condition);
		}
	} else
		TREF(local_collseq) = 0;
	prealloc_gt_timers();
	gt_timers_add_safe_hndlrs();
	for (i = 0; FNPC_MAX > i; i++)
	{	/* Initialize cache structure for $Piece function */
		(TREF(fnpca)).fnpcs[i].pcoffmax = &(TREF(fnpca)).fnpcs[i].pstart[FNPC_ELEM_MAX];
		(TREF(fnpca)).fnpcs[i].indx = i;
	}
	(TREF(fnpca)).fnpcsteal = (TREF(fnpca)).fnpcs;		/* Starting place to look for cache reuse */
	(TREF(fnpca)).fnpcmax = &(TREF(fnpca)).fnpcs[FNPC_MAX - 1];	/* The last element */
	/* Initialize zwrite subsystem. Better to do it now when we have storage to allocate than
	 * if we fail and storage allocation may not be possible. To that end, pretend we have
	 * seen alias acitivity so those structures are initialized as well.
	 */
	assert(FALSE == curr_symval->alias_activity);
	curr_symval->alias_activity = TRUE;
	lvzwr_init((enum zwr_init_types)0, (mval *)NULL);
	curr_symval->alias_activity = FALSE;
	if ((NULL != (TREF(mprof_env_gbl_name)).str.addr))
		turn_tracing_on(TADR(mprof_env_gbl_name), TRUE, (TREF(mprof_env_gbl_name)).str.len > 0);
	return;
}
コード例 #5
0
ファイル: m_for.c プロジェクト: CeperaCPP/fis-gtm
int m_for(void)
{
	unsigned int	arg_cnt, arg_index, for_stack_level;
	oprtype		arg_eval_addr[MAX_FORARGS], increment[MAX_FORARGS], terminate[MAX_FORARGS],
			arg_next_addr, arg_value, dummy, control_variable,
			*iteration_start_addr, iteration_start_addr_indr, *not_even_once_addr;
	triple		*eval_next_addr[MAX_FORARGS], *control_ref,
			*forchk1opc, forpos_in_chain, *init_ref, *ref, *step_ref, *term_ref, *var_ref;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	forpos_in_chain = TREF(pos_in_chain);
	FOR_PUSH();
	if (TK_SPACE == TREF(window_token))
	{	/* "argumentless" form */
		FOR_END_OF_SCOPE(1, dummy);
		ref = newtriple(OC_FORCHK1);
		if (!linetail())
		{
			TREF(pos_in_chain) = forpos_in_chain;
			assert(TREF(source_error_found));
			stx_error(TREF(source_error_found));
			FOR_POP(BLOWN_FOR);
			return FALSE;
		}
		SAVE_FOR_OVER_ADDR();				/* stash address of next op in the for_stack array */
		newtriple(OC_JMP)->operand[0] = put_tjmp(ref);	/* transfer back to just before the begining of the body */
		FOR_POP(GOOD_FOR);				/* and pop the array */
		return TRUE;
	}
	for_stack_level = (TREF(for_stack_ptr) - TADR(for_stack));
	init_ref = newtriple(OC_FORNESTLVL);
	init_ref->operand[0] = put_ilit(for_stack_level);
	if (TK_ATSIGN == TREF(window_token))
	{
		if (!indirection(&control_variable))
		{
			FOR_POP(BLOWN_FOR);
			return FALSE;
		}
		ref = newtriple(OC_INDLVADR);
		ref->operand[0] = control_variable;
		control_variable = put_tref(ref);
		control_ref = NULL;
	} else
	{
		/* The following relies on the fact that lvn() always generates an OC_VAR triple first */
		control_ref = (TREF(curtchain))->exorder.bl;
		if (!lvn(&control_variable, OC_SAVPUTINDX, NULL))
		{
			FOR_POP(BLOWN_FOR);
			return FALSE;
		}
		assert(OC_VAR == control_ref->exorder.fl->opcode);
		assert(MVAR_REF == control_ref->exorder.fl->operand[0].oprclass);
	}
	if (TK_EQUAL != TREF(window_token))
	{
		stx_error(ERR_EQUAL);
		FOR_POP(BLOWN_FOR);
		return FALSE;
	}
	newtriple(OC_PASSTHRU)->operand[0] = control_variable;	/* make sure optimizer doesn't ditch control_variable */
	FOR_END_OF_SCOPE(1, dummy);
	assert((0 < for_stack_level) && (MAX_FOR_STACK >= for_stack_level));
	if ((OC_SAVPUTINDX == control_variable.oprval.tref->opcode) || (OC_INDLVADR == control_variable.oprval.tref->opcode))
		TAREF1(for_temps, for_stack_level) = TRUE_WITH_INDX;	/* most uses treat this as a boolean, but some need more */
	else
		init_ref->opcode = OC_NOOP;
	iteration_start_addr = (oprtype *)mcalloc(SIZEOF(oprtype));
	iteration_start_addr_indr = put_indr(iteration_start_addr);
	arg_next_addr.oprclass = NOCLASS;
	not_even_once_addr = NULL;	/* used to skip processing where the initial control exceeds the termination */
	for (arg_cnt = 0; ; ++arg_cnt)
	{
		if (MAX_FORARGS <= arg_cnt)
		{
			stx_error(ERR_MAXFORARGS);
			FOR_POP(BLOWN_FOR);
			return FALSE;
		}
		assert((TK_COMMA == TREF(window_token)) || (TK_EQUAL == TREF(window_token)));
		advancewindow();
		tnxtarg(&arg_eval_addr[arg_cnt]);		/* put location of this arg eval in arg_eval_addr array */
		if (NULL != not_even_once_addr)
		{
			*not_even_once_addr = arg_eval_addr[arg_cnt];
			not_even_once_addr = NULL;
		}
		if (EXPR_FAIL == expr(&arg_value, MUMPS_EXPR))	/* starting (possibly only) value */
		{
			FOR_POP(BLOWN_FOR);
			return FALSE;
		}
		assert(TRIP_REF == arg_value.oprclass);
		if (TK_COLON != TREF(window_token))
		{	/* list point value? */
			increment[arg_cnt].oprclass = terminate[arg_cnt].oprclass = 0;
			DEAL_WITH_DANGER(for_stack_level, control_variable, arg_value);
		} else
		{	/* stepping value */
			init_ref = newtriple(OC_STOTEMP);		/* tuck it in a temp undisturbed by coming evals */
			init_ref->operand[0] = arg_value;
			newtriple(OC_CONUM)->operand[0] = put_tref(init_ref);	/* make start numeric */
			advancewindow();				/* past the first colon */
			var_ref = (TREF(curtchain))->exorder.bl;
			if (EXPR_FAIL == expr(&increment[arg_cnt], MUMPS_EXPR))	/* pick up step */
			{
				FOR_POP(BLOWN_FOR);
				return FALSE;
			}
			assert(TRIP_REF == increment[arg_cnt].oprclass);
			ref = increment[arg_cnt].oprval.tref;
			if (OC_LIT != var_ref->exorder.fl->opcode)
			{
				if (!TAREF1(for_temps, for_stack_level))
					TAREF1(for_temps, for_stack_level) = TRUE;
				if (OC_VAR == var_ref->exorder.fl->opcode)
				{	/* The above relies on lvn() always generating an OC_VAR triple first - asserted earlier */
					step_ref = newtriple(OC_STOTEMP);
					step_ref->operand[0] = put_tref(ref);
					increment[arg_cnt] = put_tref(step_ref);
				}
			}
			if (TK_COLON != TREF(window_token))
			{
				DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref));
				terminate[arg_cnt].oprclass = 0;	/* no termination on iteration for this arg */
			} else
			{
				advancewindow();	/* past the second colon */
				var_ref = (TREF(curtchain))->exorder.bl;
				if (EXPR_FAIL == expr(&terminate[arg_cnt], MUMPS_EXPR))		/* termination control value */
				{
					FOR_POP(BLOWN_FOR);
					return FALSE;
				}
				assert(TRIP_REF == terminate[arg_cnt].oprclass);
				ref = terminate[arg_cnt].oprval.tref;
				if (OC_LIT != ref->opcode)
				{
					if (!TAREF1(for_temps, for_stack_level))
						TAREF1(for_temps, for_stack_level) = TRUE;
					if (OC_VAR == var_ref->exorder.fl->opcode)
					{	/* The above relies on lvn() always generating an OC_VAR triple first */
						term_ref = newtriple(OC_STOTEMP);
						term_ref->operand[0] = put_tref(ref);
						terminate[arg_cnt] = put_tref(term_ref);
					}
				}
				DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref));
				term_ref = newtriple(OC_PARAMETER);
				term_ref->operand[0] = terminate[arg_cnt];
				step_ref = newtriple(OC_PARAMETER);
				step_ref->operand[0] = increment[arg_cnt];
				step_ref->operand[1] = put_tref(term_ref);
				ref = newtriple(OC_FORINIT);
				ref->operand[0] = control_variable;
				ref->operand[1] = put_tref(step_ref);
				not_even_once_addr = newtriple(OC_JMPGTR)->operand;
			}
		}
		if ((0 < arg_cnt) || (TK_COMMA == TREF(window_token)))
		{
			if (!TAREF1(for_temps, for_stack_level))
				TAREF1(for_temps, for_stack_level) = TRUE;
			if (NOCLASS == arg_next_addr.oprclass)
				arg_next_addr = put_tref(newtriple(OC_CDADDR));
			(eval_next_addr[arg_cnt] = newtriple(OC_LDADDR))->destination = arg_next_addr;
		}
		if (TK_COMMA != TREF(window_token))
			break;
		newtriple(OC_JMP)->operand[0] = iteration_start_addr_indr;
	}
	if (not_even_once_addr)
		 FOR_END_OF_SCOPE(1, *not_even_once_addr);	/* 1 means down a level */
	forchk1opc = newtriple(OC_FORCHK1);	/* FORCHK1 is a do-nothing routine used by the out-of-band mechanism */
	*iteration_start_addr = put_tjmp(forchk1opc);
	if ((TK_EOL != TREF(window_token)) && (TK_SPACE != TREF(window_token)))
	{
		stx_error(ERR_SPOREOL);
		FOR_POP(BLOWN_FOR);
		return FALSE;
	}
	if (!linetail())
	{
		TREF(pos_in_chain) = forpos_in_chain;
		assert(TREF(source_error_found));
		stx_error(TREF(source_error_found));
		FOR_POP(BLOWN_FOR);
		return FALSE;
	}
	SAVE_FOR_OVER_ADDR();		/* stash address of next op in the for_stack array */
	if (0 < arg_cnt)
		newtriple(OC_JMPAT)->operand[0] = put_tref(eval_next_addr[0]);
	for (arg_index = 0; arg_index <= arg_cnt; ++arg_index)
	{
		if (0 < arg_cnt)
			tnxtarg(eval_next_addr[arg_index]->operand);
			if (TRUE_WITH_INDX == TAREF1(for_temps, for_stack_level))
			{	/* since it might have moved, before touching the control variable get a fix on it */
				ref = newtriple(OC_RFRSHINDX);
				ref->operand[0] = put_ilit(for_stack_level);
				ref->operand[1] = put_ilit((increment[arg_index].oprclass || terminate[arg_index].oprclass)
					? FALSE : TRUE); /* if increment rather than new value, rfrsh w/ srchindx else putindx */
				control_variable = put_tref(ref);
			} else
			{
				assert(control_ref);
				control_variable = put_mvar(&control_ref->exorder.fl->operand[0].oprval.vref->mvname);
			}
			newtriple(OC_PASSTHRU)->operand[0] = control_variable;	/* warn off optimizer */
		if (terminate[arg_index].oprclass)
		{
			term_ref = newtriple(OC_PARAMETER);
			term_ref->operand[0] = terminate[arg_index];
			step_ref = newtriple(OC_PARAMETER);
			step_ref->operand[0] = increment[arg_index];
			step_ref->operand[1] = put_tref(term_ref);
			init_ref = newtriple(OC_PARAMETER);
			init_ref->operand[0] = control_variable;
			init_ref->operand[1] = put_tref(step_ref);
			ref = newtriple(OC_FORLOOP);
			/* redirects back to forchk1, which is at the beginning of new iteration */
			ref->operand[0] = *iteration_start_addr;
			ref->operand[1] = put_tref(init_ref);
		} else if (increment[arg_index].oprclass)
		{
			step_ref = newtriple(OC_ADD);
			step_ref->operand[0] = control_variable;
			step_ref->operand[1] = increment[arg_index];
			ref = newtriple(OC_STO);
			ref->operand[0] = control_variable;
			ref->operand[1] = put_tref(step_ref);
			newtriple(OC_JMP)->operand[0] = *iteration_start_addr;
		}
		if (arg_index < arg_cnt)	/* go back and evaluate the next argument */
			newtriple(OC_JMP)->operand[0] = arg_eval_addr[arg_index + 1];
	}
	FOR_POP(GOOD_FOR);
	return TRUE;
}
コード例 #6
0
int comp_fini(int status, mstr *obj, opctype retcode, oprtype *retopr, oprtype *dst, mstr_len_t src_len)
{
	triple *ref;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if (status)
	{
		while (TK_SPACE == TREF(window_token))	/* Eat up trailing white space */
			advancewindow();
		if (TK_ERROR == TREF(window_token))
		{
			status = EXPR_FAIL;
			stx_error(ERR_INDRCOMPFAIL);
		} else if ((TK_EOL != TREF(window_token)) || (source_column < src_len))
		{
			status = EXPR_FAIL;
			stx_error(ERR_INDEXTRACHARS);
		} else
		{
			cg_phase = CGP_RESOLVE;
			assert(TREF(for_stack_ptr) == TADR(for_stack));
			if (*TREF(for_stack_ptr))
				tnxtarg(*TREF(for_stack_ptr));
			ref = newtriple(retcode);
			if (retopr)
				ref->operand[0] = *retopr;
			if (OC_IRETMVAL == retcode)
				ref->operand[1] = *dst;
			start_fetches(OC_NOOP);
			resolve_ref(0);	/* cannot fail because there are no MLAB_REF's in indirect code */
			alloc_reg();
			INVOKE_STP_GCOL(0);
			/* The above invocation of stp_gcol with a parameter of 0 is a critical part of compilation
			 * (both routine compilations and indirect dynamic compilations). This collapses the indirect
			 * (compilation) stringpool so that only the literals are left. This stringpool is then written
			 * out to the compiled object as the literal pool for that compilation. Temporary stringpool
			 * use for conversions or whatever are eliminated. Note the path is different in stp_gcol for
			 * the indirect stringpool which is only used during compilations.
			 */
			assert(indr_stringpool.base == stringpool.base);
			indr_stringpool = stringpool;
			stringpool = rts_stringpool;
			TREF(compile_time) = FALSE;
			ind_code(obj);
			indr_stringpool.free = indr_stringpool.base;
		}
	} else
	{	/* If this assert fails, it means a syntax problem could have been caught earlier. Consider placing a more useful
		 * and specific error message at that location.
		 */
		assert(FALSE);
		stx_error(ERR_INDRCOMPFAIL);
	}
	if (EXPR_FAIL == status)
	{
		assert(indr_stringpool.base == stringpool.base);
		indr_stringpool = stringpool;
		stringpool = rts_stringpool;
		indr_stringpool.free = indr_stringpool.base;
		TREF(compile_time) = FALSE;
		cg_phase = CGP_NOSTATE;
	}
	TREF(transform) = TRUE;
	COMPILE_HASHTAB_CLEANUP;
	mcfree();
	return status;
}
コード例 #7
0
ファイル: m_do.c プロジェクト: mihawk/fis-gtm
int m_do(void)
{
	int		opcd;
	oprtype		*cr;
	triple		*calltrip, *labelref, *obp, *oldchain, *ref0, *ref1, *routineref, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if ((TK_EOL == TREF(window_token)) || (TK_SPACE == TREF(window_token)))
	{
		if (!run_time)	/* DO SP SP is a noop at run time */
		{
			calltrip = newtriple(OC_CALLSP);
			calltrip->operand[0] = put_mnxl();
		}
		return TRUE;
	} else if (TK_AMPERSAND == TREF(window_token))
	{
		if (!extern_func(0))
			return FALSE;
		else
			return TRUE;
	}
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE);
	setcurtchain(oldchain);
	if (!calltrip)
		return FALSE;
	if (TK_LPAREN == TREF(window_token))
	{
		if (OC_CALL == calltrip->opcode)
		{
			assert(MLAB_REF == calltrip->operand[0].oprclass);
			calltrip->opcode = OC_EXCAL;
			ref0 = calltrip;
		} else
		{
			if (OC_EXTCALL == calltrip->opcode)
			{
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode)
					assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				else
				{
					assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode);
					assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass);
					assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode);
					assert(TRIP_REF ==
						calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass);
					DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						   operand[0].oprval.tref->opcode);
					assert((OC_ILIT == opcd) || (OC_COMINT == opcd));
					DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						   operand[0].oprval.tref->operand[0].oprclass);
					assert((ILIT_REF == opcd) || (TRIP_REF == opcd));
					/* The opcd references above added to allow an invalid syntax using indirect values for
					 * offsets while specifying a parm list to get through the above asserts (invalid syntax
					 * should not trip asserts) but it leads to the conclusion that the below test may not be
					 * robust enough since it is looking at a literal integer value when there is none so have
					 * added further checks mirroring the first checks done in the two most recent asserts to
					 * make the check more robust. [Example bad code: Do @lbl+@n^artn(arg)]
					 */
					if ((0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
					     operand[0].oprval.tref->operand[0].oprval.ilit)
					    || (OC_ILIT != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->opcode)
					    || (ILIT_REF != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->operand[0].oprclass))
					{
						stx_error (ERR_ACTOFFSET);
						return FALSE;
					}
				}
			} else
			{	/* DO _ @dlabel actuallist */
				assert(OC_COMMARG == calltrip->opcode);
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode);
				assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit);
				assert(calltrip->exorder.fl == &tmpchain);
				routineref = maketriple(OC_CURRHD);
				labelref = maketriple(OC_LABADDR);
				ref0 = maketriple(OC_PARAMETER);
				dqins(calltrip->exorder.bl, exorder, routineref);
				dqins(calltrip->exorder.bl, exorder, labelref);
				dqins(calltrip->exorder.bl, exorder, ref0);
				labelref->operand[0] = calltrip->operand[0];
				labelref->operand[1] = put_tref (ref0);
				ref0->operand[0] = calltrip->operand[1];
				ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
				ref0->operand[1] = put_tref (routineref);
				calltrip->operand[0] = put_tref(routineref);
				calltrip->operand[1] = put_tref(labelref);
			}
			calltrip->opcode = OC_EXTEXCAL;
			ref0 = newtriple(OC_PARAMETER);
			ref0->operand[0] = calltrip->operand[1];
			calltrip->operand[1] = put_tref(ref0);
		}
		if (!actuallist(&ref0->operand[1]))
			return FALSE;
	} else if (OC_CALL == calltrip->opcode)
	{
		if (TREF(for_stack_ptr) != (oprtype **)TADR(for_stack))
		{
			if (TAREF1(for_temps, (TREF(for_stack_ptr) - (oprtype **)TADR(for_stack))))
				calltrip->opcode = OC_FORLCLDO;
		}
	}
	if (TK_COLON == TREF(window_token))
	{
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr(FALSE, cr))
			return FALSE;
		if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (calltrip->opcode == OC_EXCAL)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
		}
		if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
	} else
	{
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (OC_EXCAL == calltrip->opcode)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
		}
	}
	return TRUE;
}
コード例 #8
0
ファイル: line.c プロジェクト: CeperaCPP/fis-gtm
boolean_t line(uint4 *lnc)
{
	boolean_t	success;
	int		parmcount, varnum;
	short int	dot_count;
	mlabel		*x;
	mline		*curlin;
	triple		*first_triple, *parmbase, *parmtail, *r;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	first_triple = (TREF(curtchain))->exorder.bl;
	dot_count = 0;
	parmbase = NULL;
	success = TRUE;
	curlin = (mline *)mcalloc(SIZEOF(*curlin));
	curlin->line_number = 0;
	curlin->table = FALSE;
	TREF(last_source_column) = 0;
	if (TK_INTLIT == TREF(window_token))
		int_label();
	if ((TK_IDENT == TREF(window_token)) || (cmd_qlf.qlf & CQ_LINE_ENTRY))
		start_fetches(OC_LINEFETCH);
	else
		newtriple(OC_LINESTART);
	curlin->line_number = *lnc;
	*lnc = *lnc + 1;
	curlin->table = TRUE;
	CHKTCHAIN(TREF(curtchain));
	TREF(pos_in_chain) = *(TREF(curtchain));
	if (TK_IDENT == TREF(window_token))
	{
		x = get_mladdr(&(TREF(window_ident)));
		if (x->ml)
		{
			stx_error(ERR_MULTLAB);
			success = FALSE;
		} else
		{
			assert(NO_FORMALLIST == x->formalcnt);
			x->ml = curlin;
			advancewindow();
			if (TK_COLON != TREF(window_token))
				mlmax++;
			else
			{
				x->gbl = FALSE;
				advancewindow();
			}
		}
		if (success && (TK_LPAREN == TREF(window_token)))
		{
			advancewindow();
			parmbase = parmtail = newtriple(OC_BINDPARM);
			for (parmcount = 0; TK_RPAREN != TREF(window_token); parmcount++)
			{
				if (TK_IDENT != TREF(window_token))
				{
					stx_error(ERR_NAMEEXPECTED);
					success = FALSE;
					break;
				} else
				{
					varnum = get_mvaddr(&(TREF(window_ident)))->mvidx;
					for (r = parmbase->operand[1].oprval.tref; r; r = r->operand[1].oprval.tref)
					{
						assert(TRIP_REF == r->operand[0].oprclass);
						assert(ILIT_REF == r->operand[0].oprval.tref->operand[0].oprclass);
						assert((TRIP_REF == r->operand[1].oprclass) || (0 == r->operand[1].oprclass));
						if (r->operand[0].oprval.tref->operand[0].oprval.ilit == varnum)
						{
							stx_error(ERR_MULTFORMPARM);
							success = FALSE;
							break;
						}
					}
					if (!success)
						break;
					r = newtriple(OC_PARAMETER);
					parmtail->operand[1] = put_tref(r);
					r->operand[0] = put_ilit(varnum);
					parmtail = r;
					advancewindow();
				}
				if (TK_COMMA == TREF(window_token))
					advancewindow();
				else if (TK_RPAREN != TREF(window_token))
				{
					stx_error(ERR_COMMAORRPAREXP);
					success = FALSE;
					break;
				}
			}
			if (success)
			{
				advancewindow();
				parmbase->operand[0] = put_ilit(parmcount);
				x->formalcnt = parmcount;
				assert(!mlabtab->lson);
				if ((mlabtab->rson == x) && !TREF(code_generated))
					mlabtab->formalcnt = parmcount;
			}
		}
	}
	if (success && (TK_EOL != TREF(window_token)))
	{
		if (TK_SPACE != TREF(window_token))
		{
			stx_error(ERR_LSEXPECTED);
			success = FALSE;
		} else
		{
			assert(0 == dot_count);
			for (;;)
			{
				if (TK_SPACE == TREF(window_token))
					advancewindow();
				else if (TK_PERIOD == TREF(window_token))
				{
					dot_count++;
					advancewindow();
				} else
					break;
			}
		}
		if ((block_level + 1) < dot_count)
		{
			dot_count = (block_level > 0) ? block_level : 0;
			stx_error(ERR_BLKTOODEEP);
			success = FALSE;
		}
	}
	if ((0 != parmbase) && (0 != dot_count))
	{
		stx_error(ERR_NESTFORMP);	/* Should be warning */
		success = FALSE;
		dot_count = (block_level > 0 ? block_level : 0);
	}
	if ((block_level + 1) <= dot_count)
	{
		mline_tail->child = curlin;
		curlin->parent = mline_tail;
		block_level = dot_count;
	} else
	{
		for (; dot_count < block_level; block_level--)
			mline_tail = mline_tail->parent;
		mline_tail->sibling = curlin;
		curlin->parent = mline_tail->parent;
	}
	mline_tail = curlin;
	if (success)
	{
		assert(TREF(for_stack_ptr) == TADR(for_stack));
		*(TREF(for_stack_ptr)) = NULL;
		success = linetail();
		if (success)
		{
			assert(TREF(for_stack_ptr) == TADR(for_stack));
			if (*(TREF(for_stack_ptr)))
				tnxtarg(*(TREF(for_stack_ptr)));
		}
	}
	assert(TREF(for_stack_ptr) == TADR(for_stack));
	if (first_triple->exorder.fl == TREF(curtchain))
		newtriple(OC_NOOP);			/* empty line (comment, blank, etc) */
	curlin->externalentry = first_triple->exorder.fl;
	/* First_triple points to the last triple before this line was processed.  Its forward link will point to a
	 * LINEFETCH or a LINESTART, or possibly a NOOP. It the line was a comment, there is only a LINESTART, and
	 * hence no "real" code yet.
	 */
	TREF(code_generated) = TREF(code_generated) | ((OC_NOOP != first_triple->exorder.fl->opcode)
		&& (first_triple->exorder.fl->exorder.fl != TREF(curtchain)));
	return success;
}
コード例 #9
0
gtcm_server()
{
	static readonly int4	reptim[2] = {-100000, -1};	/* 10ms */
       	static readonly int4	wait[2] =  {-1000000, -1};	/* 100ms */
	void		gtcm_ch(), gtcm_exi_handler(), gtcm_init_ast(), gtcm_int_unpack(), gtcm_mbxread_ast(),
			gtcm_neterr(), gtcm_read_ast(), gtcm_remove_from_action_queue(), gtcm_shutdown_ast(), gtcm_write_ast(),
			la_freedb();
	bool		gtcm_link_accept();
	bool		alid;
	char		buff[512];
	char		*h = NULL;
	char		*la_getdb();
	char		nbuff[256];
	char		*pak = NULL;
	char		reply;
	unsigned short	outlen;
	int4		closewait[2] = {0, -1};
	int4		inid = 0, mdl = 0, nid = 0, days = 0;
	int4		lic_status;
	int4		lic_x;
	int4		lm_mdl_nid();
	uint4		status;
	int		i, receive(), value;
	mstr		name1, name2;
	struct NTD	*cmu_ntdroot();
	connection_struct *prev_curr_entry;
	struct	dsc$descriptor_s	dprd;
	struct	dsc$descriptor_s	dver;
	$DESCRIPTOR(node_name, nbuff);
	$DESCRIPTOR(proc_name, "GTCM_SERVER");
	$DESCRIPTOR(timout, buff);
	DCL_THREADGBL_ACCESS;

	GTM_THREADGBL_INIT;
        assert(0 == EMPTY_QUEUE);       /* check so dont need gdsfhead everywhere */
	common_startup_init(GTCM_GNP_SERVER_IMAGE); /* Side-effect: Sets skip_dbtriggers to TRUE for non-trigger platforms */
	gtm_env_init();	/* read in all environment variables */
	name1.addr = "GTCMSVRNAM";
	name1.len = SIZEOF("GTCMSVRNAM") - 1;
	status = trans_log_name(&name1, &name2, nbuff);
	if (SS$_NORMAL == status)
	{
		proc_name.dsc$a_pointer = nbuff;
		proc_name.dsc$w_length = node_name.dsc$w_length = name2.len;
	} else if (SS$_NOLOGNAM == status)
	{
		MEMCPY_LIT(nbuff, "GTCMSVR");
		node_name.dsc$w_length = SIZEOF("GTCMSVR") - 1;
	} else
		rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) status);
	sys$setprn(&proc_name);
	status = lib$get_foreign(&timout, 0, &outlen, 0);
	if ((status & 1) && (6 > outlen))
	{
		for (i = 0;  i < outlen;  i++)
		{
			value = value * 10;
			if (buff[i] <= '9' && buff[i] >= '0')
				value += buff[i] - 48;
			else
				break;
		}
		if (outlen && (i == outlen))
		{
			cm_timeout = TRUE;
			closewait[0] = value * -10000000;
		}
	}
	dprd.dsc$w_length = cm_prd_len;
	dprd.dsc$b_dtype  = DSC$K_DTYPE_T;
	dprd.dsc$b_class  = DSC$K_CLASS_S;
	dprd.dsc$a_pointer= cm_prd_name;
	dver.dsc$w_length = cm_ver_len;
	dver.dsc$b_dtype  = DSC$K_DTYPE_T;
	dver.dsc$b_class  = DSC$K_CLASS_S;
	dver.dsc$a_pointer= cm_ver_name;
	ast_init();
	licensed = TRUE;
	lkid = 2;
#	ifdef NOLICENSE
	lid = 1;
#	else
	/* this code used to be scattered to discourage reverse engineering, but since it now disabled, that seems pointless */
	lic_status = ((NULL == (h = la_getdb(LMDB))) ? LP_NOCNFDB : SS$_NORMAL);
	lic_status = ((1 == (lic_status & 1)) ? lm_mdl_nid(&mdl, &nid, &inid) : lic_status);
	lic_status = ((1 == (lic_status & 1)) ? lp_licensed(h, &dprd, &dver, mdl, nid, &lid, &lic_x, &days, pak) : lic_status);
	if (LP_NOCNFDB != lic_status)
		la_freedb(h);
	if (1 == (lic_status & 1))
	{
		licensed = TRUE;
		if (days < 14)
			rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_WILLEXPIRE);
	} else
	{
		licensed = FALSE;
		sys$exit(lic_status);
	}
#	endif
	gtcm_ast_avail = astq_dyn_avail - GTCM_AST_OVRHD;
	stp_init(STP_INITSIZE);
	rts_stringpool = stringpool;
	cache_init();
	procnum = 0;
	get_proc_info(0, TADR(login_time), &image_count);
        memset(proc_to_clb, 0, SIZEOF(proc_to_clb));
	status = cmi_init(&node_name, 0, 0, gtcm_init_ast, gtcm_link_accept);
	if (!(status & 1))
	{
		rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ((status ^ 3) | 4));
		sys$exit(status);
	}
	ntd_root = cmu_ntdroot();
	ntd_root->mbx_ast =  gtcm_mbxread_ast;
	ntd_root->err = gtcm_neterr;
	gtcm_connection = FALSE;
	lib$establish(gtcm_ch);
	gtcm_exi_blk.exit_hand = &gtcm_exi_handler;
	gtcm_exi_blk.arg_cnt = 1;
	gtcm_exi_blk.cond_val = &gtcm_exi_condition;
	sys$dclexh(&gtcm_exi_blk);
	INVOKE_INIT_SECSHR_ADDRS;
	initialize_pattern_table();
	assert(run_time); /* Should have been set by common_startup_init */
	while (!cm_shutdown)
	{
		if (blkdlist)
			gtcml_chkreg();

		assert(!lib$ast_in_prog());
		status = sys$dclast(&gtcm_remove_from_action_queue, 0, 0);
		if (SS$_NORMAL != status)
			rts_error_csa(CSA_ARG(NULL) VARLSTCNT(4) CMERR_CMSYSSRV, 0, status, 0);
		if (INTERLOCK_FAIL == curr_entry)
			rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) CMERR_CMINTQUE);
		if (EMPTY_QUEUE != curr_entry)
		{
			switch (*curr_entry->clb_ptr->mbf)
			{
				case CMMS_L_LKCANALL:
					reply = gtcmtr_lkcanall();
					break;
				case CMMS_L_LKCANCEL:
					reply = gtcmtr_lkcancel();
					break;
				case CMMS_L_LKREQIMMED:
					reply = gtcmtr_lkreqimmed();
					break;
				case CMMS_L_LKREQNODE:
					reply = gtcmtr_lkreqnode();
					break;
				case CMMS_L_LKREQUEST:
					reply = gtcmtr_lkrequest();
					break;
				case CMMS_L_LKRESUME:
					reply = gtcmtr_lkresume();
					break;
				case CMMS_L_LKACQUIRE:
					reply = gtcmtr_lkacquire();
					break;
				case CMMS_L_LKSUSPEND:
					reply = gtcmtr_lksuspend();
					break;
				case CMMS_L_LKDELETE:
					reply = gtcmtr_lkdelete();
					break;
				case CMMS_Q_DATA:
					reply = gtcmtr_data();
					break;
				case CMMS_Q_GET:
					reply = gtcmtr_get();
					break;
				case CMMS_Q_KILL:
					reply = gtcmtr_kill();
					break;
				case CMMS_Q_ORDER:
					reply = gtcmtr_order();
					break;
				case CMMS_Q_PREV:
					reply = gtcmtr_zprevious();
					break;
				case CMMS_Q_PUT:
					reply = gtcmtr_put();
					break;
				case CMMS_Q_QUERY:
					reply = gtcmtr_query();
					break;
				case CMMS_Q_ZWITHDRAW:
					reply = gtcmtr_zwithdraw();
					break;
				case CMMS_S_INITPROC:
					reply = gtcmtr_initproc();
					break;
				case CMMS_S_INITREG:
					reply = gtcmtr_initreg();
					break;
				case CMMS_S_TERMINATE:
					reply = gtcmtr_terminate(TRUE);
					break;
				case CMMS_E_TERMINATE:
					reply = gtcmtr_terminate(FALSE);
					break;
				case CMMS_U_LKEDELETE:
					reply = gtcmtr_lke_clearrep(curr_entry->clb_ptr, curr_entry->clb_ptr->mbf);
					break;
				case CMMS_U_LKESHOW:
					reply = gtcmtr_lke_showrep(curr_entry->clb_ptr, curr_entry->clb_ptr->mbf);
					break;
				case CMMS_B_BUFRESIZE:
					reply = CM_WRITE;
					value = *(unsigned short *)(curr_entry->clb_ptr->mbf + 1);
					if (value > curr_entry->clb_ptr->mbl)
					{
						free(curr_entry->clb_ptr->mbf);
						curr_entry->clb_ptr->mbf = malloc(value);
					}
					*curr_entry->clb_ptr->mbf = CMMS_C_BUFRESIZE;
					curr_entry->clb_ptr->mbl = value;
					curr_entry->clb_ptr->cbl = 1;
					break;
				case CMMS_B_BUFFLUSH:
					reply = gtcmtr_bufflush();
					break;
				case CMMS_Q_INCREMENT:
					reply = gtcmtr_increment();
					break;
				default:
					reply = FALSE;
					if (SS$_NORMAL == status)
                                                rts_error_csa(CSA_ARG(NULL)
							VARLSTCNT(3) ERR_BADGTMNETMSG, 1, (int)*curr_entry->clb_ptr->mbf);
					break;
			}
			if (curr_entry)		/* curr_entry can be NULL if went through gtcmtr_terminate */
			{
				status = sys$gettim(&curr_entry->lastact[0]);
				if (SS$_NORMAL != status)
					rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) status);
				/* curr_entry is used by gtcm_mbxread_ast to determine if it needs to defer the interrupt message */
				prev_curr_entry = curr_entry;
				if (CM_WRITE == reply)
				{	/* if ast == gtcm_write_ast, let it worry */
					curr_entry->clb_ptr->ast = gtcm_write_ast;
					curr_entry = EMPTY_QUEUE;
					cmi_write(prev_curr_entry->clb_ptr);
				} else
				{
					curr_entry = EMPTY_QUEUE;
					if (1 == (prev_curr_entry->int_cancel.laflag & 1))
					{  /* valid interrupt cancel msg, handle in gtcm_mbxread_ast */
						status = sys$dclast(gtcm_int_unpack, prev_curr_entry, 0);
						if (SS$_NORMAL != status)
							rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) status);
					} else  if (CM_READ == reply)
					{
						prev_curr_entry->clb_ptr->ast = gtcm_read_ast;
						cmi_read(prev_curr_entry->clb_ptr);
					}
				}
			}
		} else  if (1 < astq_dyn_avail)
		{
#			ifdef GTCM_REPTIM
			/* if reptim is not needed - and smw doesn't know why it would be - remove this	*/
			status = sys$schdwk(0, 0, &wait[0], &reptim[0]);
#			else
			status = sys$schdwk(0, 0, &wait[0], 0);
#			endif
			sys$hiber();
			sys$canwak(0, 0);
		}
		if (cm_timeout && (0 == gtcm_users))
                        sys$setimr(efn_ignore, closewait, gtcm_shutdown_ast, &cm_shutdown, 0);
	}
}
コード例 #10
0
ファイル: gtm_trigger.c プロジェクト: h4ck3rm1k3/fis-gtm
/* Routine to eliminate the zlinked trigger code for a given trigger about to be deleted. Operations performed
 * differ depending on platform type (shared binary or not).
 */
void gtm_trigger_cleanup(gv_trigger_t *trigdsc)
{
	rtn_tabent	*rbot, *mid, *rtop;
	mident		*rtnname;
	rhdtyp		*rtnhdr;
	textElem	*telem;
	int		comp, size;
	stack_frame	*fp, *fpprev;
	mname_entry	key;
	ht_ent_mname    *tabent;
	routine_source	*src_tbl;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	/* First thing to do is release trigger source field if it exists */
	if (0 < trigdsc->xecute_str.str.len)
	{
		free(trigdsc->xecute_str.str.addr);
		trigdsc->xecute_str.str.len = 0;
		trigdsc->xecute_str.str.addr = NULL;
	}
	/* Next thing to do is find the routine header in the rtn_names list so we can remove it. */
	rtnname = &trigdsc->rtn_desc.rt_name;
	rtnhdr = trigdsc->rtn_desc.rt_adr;
	rbot = rtn_names;
	rtop = rtn_names_end;
	for (;;)
	{	/* See if routine exists in list via a binary search which reverts to serial
		   search when # of items drops below the threshold S_CUTOFF.
		*/
		if ((rtop - rbot) < S_CUTOFF)
		{
			comp = -1;
			for (mid = rbot; mid <= rtop ; mid++)
			{
				MIDENT_CMP(&mid->rt_name, rtnname, comp);
				if (0 == comp)
					break;
				if (0 < comp)
					GTMASSERT;	/* Routine should be found */
			}
			break;
		} else
		{	mid = rbot + (rtop - rbot)/2;
			MIDENT_CMP(&mid->rt_name, rtnname, comp);
			if (0 == comp)
				break;
			else if (0 > comp)
			{
				rbot = mid + 1;
				continue;
			} else
			{
				rtop = mid - 1;
				continue;
			}
		}
	}
#	ifdef DEBUG
	assert(rtnhdr == mid->rt_adr);
	/* Verify trigger routine we want to remove is not currently active. If it is, we need to GTMASSERT.
	 * Triggers are not like regular routines since they should only ever be referenced from the stack during a
	 * transaction. Likewise, we should only ever load the triggers as the first action in that transaction.
	 */
	for (fp = frame_pointer; fp ; fp = fpprev)
	{
		fpprev = fp->old_frame_pointer;
#		ifdef GTM_TRIGGER
		if (NULL != fpprev && SFT_TRIGR & fpprev->type)
			fpprev = *(stack_frame **)(fpprev + 1);
#		endif
		/* Only one possible version of a trigger routine */
		assert(USHBIN_ONLY(NULL) NON_USHBIN_ONLY(fp->rvector) == OLD_RHEAD_ADR(CURRENT_RHEAD_ADR(fp->rvector)));
		assert(fp->rvector != rtnhdr);
	}
#	endif
	/* Remove break points in this routine before rmv from rtntbl */
	zr_remove(rtnhdr, BREAKMSG);
	/* Release any $TEXT() info this trigger has loaded */
	if (NULL != (TREF(rt_name_tbl)).base)
	{
		key.var_name = mid->rt_name;
		COMPUTE_HASH_MNAME(&key);
		if (NULL != (tabent = lookup_hashtab_mname(TADR(rt_name_tbl), &key)))	/* note assignment */
		{	/* We have a hash entry. Whether it has a value or not, it has a key name (if this is
			 * the first time this trigger is being deleted) that may be pointing into the routine we
			 * are about to remove. Migrate this key name to the stringpool.
			 */
			s2pool(&tabent->key.var_name);
			if (NULL != tabent->value)
			{	/* Has value, release the source. Entries and source are malloc'd in two blocks on UNIX */
				src_tbl = (routine_source *)tabent->value;
				if (NULL != src_tbl->srcbuff)
					free(src_tbl->srcbuff);
				free(src_tbl);
				tabent->value = NULL;
			}
		}
	}
	/* Remove the routine from the rtn_table */
	size = INTCAST((char *)rtn_names_end - (char *)mid);
	if (0 < size)
		memmove((char *)mid, (char *)(mid + 1), size);	/* Remove this routine name from sorted table */
	rtn_names_end--;
	urx_remove(rtnhdr);					/* Remove any unresolved entries */
#	ifdef USHBIN_SUPPORTED
	stp_move((char *)rtnhdr->literal_text_adr,
		 (char *)(rtnhdr->literal_text_adr + rtnhdr->literal_text_len));
	GTM_TEXT_FREE(rtnhdr->ptext_adr);			/* R/O releasable section */
	free(rtnhdr->literal_adr);				/* R/W releasable section part 1 */
	free(rtnhdr->linkage_adr);				/* R/W releasable section part 2 */
	free(rtnhdr->labtab_adr);				/* Usually non-releasable but triggers don't have labels so
								 * this is just cleaning up a dangling null malloc
								 */
	free(rtnhdr);
#	else
#		if (!defined(__linux__) && !defined(__CYGWIN__)) || !defined(__i386) || !defined(COMP_GTA)
#			error Unsupported NON-USHBIN platform
#		endif
	/* For a non-shared binary platform we need to get an approximate addr range for stp_move. This is not
	 * done when a routine is replaced on these platforms but in this case we are able to due to the isolated
	 * environment if we only take the precautions of migrating potential literal text which may have been
	 * pointed to by any set environment variables.
	 * In this format, the only platform we support currently is Linux-x86 (i386) which uses GTM_TEXT_ALLOC
	 * to allocate special storage for it to put executable code in. We can access the storage header for
	 * this storage and find out how big it is and use that information to give stp_move a good range since
	 * the literal segment occurs right at the end of allocated storage (for which there is no pointer
	 * in the fileheader).
	 */
	telem = (textElem *)((char *)rtnhdr - offsetof(textElem, userStorage));
	assert(TextAllocated == telem->state);
	stp_move((char *)LNRTAB_ADR(rtnhdr) + (rtnhdr->lnrtab_len * SIZEOF(lnr_tabent)),
		 (char *)rtnhdr + telem->realLen);
	GTM_TEXT_FREE(rtnhdr);
#	endif
}
コード例 #11
0
ファイル: m_do.c プロジェクト: h4ck3rm1k3/fis-gtm
int m_do(void)
{
	triple		tmpchain, *oldchain, *obp, *ref0, *tripsize,
			*triptr, *ref1, *calltrip, *routineref, *labelref;
	oprtype		*cr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if ((TK_SPACE == window_token) || (TK_EOL == window_token))
	{
		if (!run_time)	/* DO SP SP is a noop at run time */
		{
			calltrip = newtriple(OC_CALLSP);
			calltrip->operand[0] = put_mnxl();
			calltrip->operand[1] = put_ocnt();
		}
		return TRUE;
	} else if (TK_AMPERSAND == window_token)
	{
		if (!extern_func(0))
			return FALSE;
		else
			return TRUE;
	}
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE);
	setcurtchain(oldchain);
	if (!calltrip)
		return FALSE;
	if (TK_LPAREN == window_token)
	{
		if (OC_CALL == calltrip->opcode)
		{
			assert(MLAB_REF == calltrip->operand[0].oprclass);
			calltrip->opcode = OC_EXCAL;
			ref0 = newtriple(OC_PARAMETER);
			calltrip->operand[1] = put_tref(ref0);
			ref0->operand[0] = put_tsiz();	/* parm to hold size of jump codegen */
			tripsize = ref0->operand[0].oprval.tref;
			assert(OC_TRIPSIZE == tripsize->opcode);
		} else
		{
			if (OC_EXTCALL == calltrip->opcode)
			{
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode)
					assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				else
				{
					assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode);
					assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass);
					assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode);
					assert(TRIP_REF ==
						calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass);
					assert(OC_ILIT == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->opcode);
					assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->operand[0].oprclass);
					if (0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->operand[0].oprval.ilit)
					{
						stx_error(ERR_ACTOFFSET);
						return FALSE;
					}
				}
			} else		/* DO _ @dlabel actuallist */
			{
				assert(OC_COMMARG == calltrip->opcode);
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode);
				assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit);
				assert(calltrip->exorder.fl == &tmpchain);
				routineref = maketriple(OC_CURRHD);
				labelref = maketriple(OC_LABADDR);
				ref0 = maketriple(OC_PARAMETER);
				dqins(calltrip->exorder.bl, exorder, routineref);
				dqins(calltrip->exorder.bl, exorder, labelref);
				dqins(calltrip->exorder.bl, exorder, ref0);
				labelref->operand[0] = calltrip->operand[0];
				labelref->operand[1] = put_tref(ref0);
				ref0->operand[0] = calltrip->operand[1];
				ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
				ref0->operand[1] = put_tref(routineref);
				calltrip->operand[0] = put_tref(routineref);
				calltrip->operand[1] = put_tref(labelref);
			}
			calltrip->opcode = OC_EXTEXCAL;
			ref0 = newtriple(OC_PARAMETER);
			ref0->operand[0] = calltrip->operand[1];
			calltrip->operand[1] = put_tref(ref0);
		}
		if (!actuallist(&ref0->operand[1]))
			return FALSE;
	} else if (OC_CALL == calltrip->opcode)
	{
		calltrip->operand[1] = put_ocnt();
		if (TREF(for_stack_ptr) != TADR(for_stack))
		{
			if (TAREF1(for_temps, (TREF(for_stack_ptr) - TADR(for_stack))))
				calltrip->opcode = OC_FORLCLDO;
		}
	}
	if (TK_COLON == window_token)
	{
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr((bool) FALSE, cr))
			return FALSE;
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (OC_EXCAL == calltrip->opcode)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
			tripsize->operand[0].oprval.tsize->ct = triptr;
		}
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
	} else
	{
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (OC_EXCAL == calltrip->opcode)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
			tripsize->operand[0].oprval.tsize->ct = triptr;
		}
	}
	return TRUE;
}
コード例 #12
0
ファイル: op_fnzsearch.c プロジェクト: CeperaCPP/fis-gtm
int op_fnzsearch(mval *file, mint indx, mval *ret)
{
	struct stat	statbuf;
	int		stat_res;
	parse_blk	pblk;
	plength		*plen, pret;
	char		buf1[MAX_FBUFF + 1]; /* buffer to hold translated name */
	mval		sub;
	mstr		tn;
	lv_val		*ind_tmp;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	ESTABLISH_RET(fnzsrch_ch, -1);
	TREF(fnzsearch_nullsubs_sav) = TREF(lv_null_subs);
	TREF(lv_null_subs) = LVNULLSUBS_OK;	/* $ZSearch processing depends on this */
	MV_FORCE_STR(file);
	if (file->str.len > MAX_FBUFF)
		rts_error(VARLSTCNT(4) ERR_INVSTRLEN, 2, file->str.len, MAX_FBUFF);
	MV_FORCE_MVAL(((mval *)TADR(fnzsearch_sub_mval)), indx);
	TREF(fnzsearch_lv_vars) = op_srchindx(VARLSTCNT(2) TREF(zsearch_var), (mval *)TADR(fnzsearch_sub_mval));
	if (TREF(fnzsearch_lv_vars))
	{
		assert((TREF(fnzsearch_lv_vars))->v.mvtype & MV_STR);
		if ((file->str.len != (TREF(fnzsearch_lv_vars))->v.str.len)
			|| memcmp(file->str.addr, (TREF(fnzsearch_lv_vars))->v.str.addr, file->str.len))
		{
			op_kill(TREF(fnzsearch_lv_vars));
			TREF(fnzsearch_lv_vars) = NULL;
		}
	}
	if (TREF(fnzsearch_lv_vars))
	{
		for (;;)
		{
			pret.p.pint = pop_top(TREF(fnzsearch_lv_vars), ret);	/* get next element off the top */
			if (!ret->str.len)
				break;
			memcpy(buf1, ret->str.addr, ret->str.len);
			buf1[ret->str.len] = 0;
			STAT_FILE(buf1, &statbuf, stat_res);
			if (-1 == stat_res)
			{
				if (errno == ENOENT)
					continue;
				rts_error(VARLSTCNT(1) errno);
			}
			break;
		}
	} else
	{
		memset(&pblk, 0, SIZEOF(pblk));
		pblk.buffer = buf1;
		pblk.buff_size = MAX_FBUFF;
		if (!(parse_file(&file->str, &pblk) & 1))
		{
			ret->mvtype = MV_STR;
			ret->str.len = 0;
		} else
		{
			assert(!TREF(fnzsearch_lv_vars));
			buf1[pblk.b_esl] = 0;
			/* establish new search context */
			TREF(fnzsearch_lv_vars) = op_putindx(VARLSTCNT(2) TREF(zsearch_var), TADR(fnzsearch_sub_mval));
			(TREF(fnzsearch_lv_vars))->v = *file;	/* zsearch_var(indx)=original spec */
			if (!(pblk.fnb & F_WILD))
			{
				sub.mvtype = MV_STR;
				sub.str.len = pblk.b_esl;
				sub.str.addr =  buf1;
				s2pool(&sub.str);
				ind_tmp = op_putindx(VARLSTCNT(2) TREF(fnzsearch_lv_vars), &sub);
				ind_tmp->v.mvtype = MV_STR; ind_tmp->v.str.len = 0;
				plen = (plength *)&ind_tmp->v.m[1];
				plen->p.pblk.b_esl = pblk.b_esl;
				plen->p.pblk.b_dir = pblk.b_dir;
				plen->p.pblk.b_name = pblk.b_name;
				plen->p.pblk.b_ext = pblk.b_ext;
			} else
				dir_srch(&pblk);
			for (;;)
			{
				pret.p.pint = pop_top(TREF(fnzsearch_lv_vars), ret);	/* get next element off the top */
				if (!ret->str.len)
					break;
				memcpy(buf1, ret->str.addr, ret->str.len);
				buf1[ret->str.len] = 0;
				STAT_FILE(buf1, &statbuf, stat_res);
				if (-1 == stat_res)
				{
					if (errno == ENOENT)
						continue;
					rts_error(VARLSTCNT(1) errno);
				}
				break;
			}
		}
	}
	assert((0 == ret->str.len) || (pret.p.pblk.b_esl == ret->str.len));
	TREF(lv_null_subs) = TREF(fnzsearch_nullsubs_sav);
	REVERT;
	return pret.p.pint;
}