#pragma module	VTL_ACT	"VTL_ACT-1-X"

/*
**++
**  FACILITY:  VMS Tool Language
**
**  MODULE DESCRIPTION:
**
**
**  AUTHORS:
**
**      Ruslan R. Laishev
**
**  CREATION DATE:   19-MAR-2009
**
**  DESIGN ISSUES:
**
**      This module contains an action routines supposed to be used by preprocessor/parser
**	procedures to producing a byte-code (P-code).
**
**
**  MODIFICATION HISTORY:
**
**      {@tbs@}...
**--
*/

/*
**
**  INCLUDE FILES
**
*/
#include	<starlet.h>
#include	<libdef.h>
#include	<lib$routines.h>
#include	<tpadef.h>
#include	<string.h>
#include	<iledef.h>
#include	<ssdef.h>
#include	<rms.h>
#include	<stdlib.h>
#include	<stdio.h>
#include	<secdef.h>
#include	<psldef.h>
#include	<descrip.h>
#include	<stdarg.h>
#include	<libvmdef.h>

#define	__NEW_STARLET	1

/*
**
**	VTL	DEFINITONS
**
*/
#include	"vtldef.h"
#include	"vtl_msg.h"

#define	INIT_SDESC(dsc, len, ptr)	{(dsc).dsc$b_dtype = DSC$K_DTYPE_T;\
			(dsc).dsc$b_class = DSC$K_CLASS_S; (dsc).dsc$w_length = (short) (len);\
			(dsc).dsc$a_pointer = (char *) (ptr);}

#define INIT_DDESC(dsc)	{(dsc).dsc$b_dtype = DSC$K_DTYPE_T;\
			(dsc).dsc$b_class = DSC$K_CLASS_D;(dsc).dsc$w_length = 0;\
			(dsc).dsc$a_pointer = NULL;}

#define	$min(x,y)	((x > y)?y:x)
#define	$max(x,y)	((x < y)?y:x)

$DESCRIPTOR(VMZoneName_GLOBS,	"VTL globals");
$DESCRIPTOR(VMZoneName_RTNREF,	"VTL references");
$DESCRIPTOR(VMZoneName_EXPR,	"VTL expressions");
int	VMZoneId_GLOBS,VMZoneId_RTNREF,VMZoneId_EXPR,VMZoneDetail=3;
int	RETRY_COUNT = -1;

void	* tree_globs = NULL,
	* tree_rtnref = NULL;

int	tree_node_flag = 0;

/*
**++
**  FUNCTIONAL DESCRIPTION:
**
**      Put formated message to standard output device (SYS$OUTPUT).
**
**  FORMAL PARAMETERS:
**
**	ctx:	A session context
**      msgid:	VMS condition code
**              variable agriments list
**
**  RETURN VALUE:
**
**      VMS condition code
**
**
**--
*/
int	_vtl_log	(
			int	msgid,
			...
			)
{
long	status,retvalue = msgid;
va_list	ap;
char	buf[1024] = {"!%D "},outadr[4],msg_buf[1024];
struct	dsc$descriptor	opr_dsc,buf_dsc,fao_dsc;
int	argc,argl[32],idx,flag=15,lvl;

	/*
	** Get a message text with given msgid
	*/
	INIT_SDESC(fao_dsc,sizeof(buf)-4,&buf[4]);
	if ( !(1 & (status =  sys$getmsg (msgid,&fao_dsc.dsc$w_length,&fao_dsc,flag,&outadr))) )
		lib$signal(status);
	
	/*
	** Reorganize parameters list for $FAOL
	*/
	va_start(ap,msgid);
	argl[0] = 0;
	for (idx = 1,va_count(argc);idx < argc;idx++)
		argl[idx] = va_arg(ap,unsigned);
        va_end((char *) msgid);

	/*
	** Format a message, put it to SYS$OUTPUT
	*/
	fao_dsc.dsc$a_pointer -=4;
	fao_dsc.dsc$w_length  +=4;
	INIT_SDESC(buf_dsc, sizeof(msg_buf),msg_buf);
	if ( !(1 & (status = sys$faol(&fao_dsc,&buf_dsc.dsc$w_length,&buf_dsc,argl))) )
		lib$signal(status);

	lib$put_output(&buf_dsc);

	return	retvalue;
}

static int	__vtl_cmp	(
		VTL_KEY		*akey,
		VTL_NODE	*node,
			void	*dummy
                        )
{
int     result;
VTL_KEY	*bkey = (VTL_KEY *) node->tree_a_ptr;

        if ( result = memcmp(akey->key_t_sts,bkey->key_t_sts,
                        $min(akey->key_b_len,bkey->key_b_len)) )
                return result;

        return (akey->key_b_len - bkey->key_b_len);
}

static	int	__vtl_getvm	(
		VTL_KEY		*key,
		VTL_NODE *	*node,
                void            *data
                        )
{
int     status,sz = sizeof(VTL_NODE);

        if ( !(1 & (status = lib$get_vm(&sz,node))) )
                return status;
	memset(*node,0,sizeof(VTL_NODE));

        (*node)->tree_a_ptr = data;

        return  status;
}

int	_vtl_iddump	(
			VTL_NODE	*node,
			void	*	tree
			)
{
char	buf [ 132 ];
short	sz = 0;
VTL_ID	*glb;

	if ( !tree )
		tree	= tree_globs;

	if ( !node ) 
		return  lib$traverse_tree (&tree,_vtl_iddump,tree);

	glb	= (VTL_ID *) node->tree_a_ptr;

	sz = sprintf(buf,"\n  @%08.8p  %.*s",glb,glb->id_b_len,glb->id_t_name);
	sz += sprintf(&buf[sz],"\t%08X",glb->id_r_type);
	sz += sprintf(&buf[sz],"\t[%u]/%u",glb->id_w_dim,glb->id_w_sz);

	if ( glb->id_r_type.type_v_const )
		sz += sprintf(&buf[sz],"const");

	if ( glb->id_r_type.type_v_string )
		sz += sprintf(&buf[sz],"\tstring");
	else	if ( glb->id_r_type.type_v_unsign )
		sz += sprintf(&buf[sz]," unsigned");

	if ( glb->id_r_type.type_v_string )
		sz += sprintf(&buf[sz],"\t %.*s",glb->id_w_sz,glb->id_t_val);
	else	sz += sprintf(&buf[sz],"\t %d",glb->id_l_val);

	fprintf(stdout,buf);

	return	SS$_NORMAL;
}
                                               
int	_vtl_rtndecl	(
		VTL_TOK	*	rtn,
		VTL_TYPE *	type,
		VTL_RTN * *	entry
			)
{
unsigned	status,sz = sizeof(VTL_RTN);
VTL_RTN		*rtnp = NULL;
VTL_NODE	*node= NULL;

	/*
	** Allocate a memory for new global variable
	*/
	if ( !(1 & (status = lib$get_vm(&sz,&rtnp))) )
		return status;
	memset(rtnp,0,sizeof(VTL_RTN));

	/*
	** Copy variable name
	*/
	rtnp->rtn_b_len	= $min(rtn->tok_l_vchar,sizeof(rtnp->rtn_t_name));
	memcpy(rtnp->rtn_t_name,rtn->tok_a_vchar,rtnp->rtn_b_len);

	/*
	** Set type & dimension
	*/
	rtnp->rtn_r_ret	 = *type;

	if ( !(1 & (status = lib$insert_tree (&tree_rtnref,&rtnp->rtn_r_name,
			&tree_node_flag,__vtl_cmp,__vtl_getvm,&node,rtnp))) )
		lib$signal(status);
	else if ( status == LIB$_KEYALRINS )
		return	_vtl_log(VTL_DUPLID,&rtnp->rtn_r_name);

	*entry	= rtnp;	

	return	SS$_NORMAL;
}

int	_vtl_rtndump	(
			VTL_NODE	*node
			)
{
char	buf [ 132 ];
short	sz = 0;
VTL_RTN	*	rtn;
VTL_INSTR *	instr;

	/*
	** Start a recursion
	*/
	if ( !node ) 
		return  lib$traverse_tree (&tree_rtnref,_vtl_rtndump);

	/*
	** Display a routne information
	*/
	rtn	= (VTL_RTN *) node->tree_a_ptr;

	sz = sprintf(buf,"\nEntry: %.*s",rtn->rtn_b_len,rtn->rtn_t_name);
	sz += sprintf(&buf[sz],"\t%08X",rtn->rtn_l_ret);

	if ( rtn->rtn_l_ret & TYPE_M_STRING )
		sz += sprintf(&buf[sz]," string");
	else	if ( rtn->rtn_l_ret & TYPE_M_UNSIGN )
		sz += sprintf(&buf[sz]," unsigned");

	fprintf(stdout,buf);

	/*
	** Display routine's variables
	*/
	if ( rtn->rtn_a_vars )
		_vtl_iddump(NULL,rtn->rtn_a_vars);

	/*
	** Display routine's expression list
	*/
	while ( 1 & lib$remqti(&rtn->rtn_r_instr,&instr,&RETRY_COUNT) )
		_vtl_opdecode(instr);

	return	SS$_NORMAL;
}

int	_vtl_iddecl	(
		VTL_TOK	*	var,
		unsigned	type,
		VTL_TOK	*	val,
		VTL_RTN	*	entry
			)
{
unsigned	status,sz;
VTL_ID		*id = NULL;
VTL_NODE	*node= NULL;
void	* 	*ptr;

	/*
	** Allocate a memory for new id variable
	*/
	sz	= sizeof(VTL_ID);
	if ( type & TYPE_M_STRING )	
		sz	+= val->tok_l_vchar - sizeof(id->id_r_val);

	if ( !(1 & (status = lib$get_vm(&sz,&id))) )
		return status;

	/*
	** Copy variable name
	*/
	id->id_b_len	= $min(var->tok_l_vchar,sizeof(id->id_t_name));
	memcpy(id->id_t_name,var->tok_a_vchar,id->id_b_len);

	/*
	** Set type & dimension
	*/
	id->id_l_type	= type;
	id->id_w_sz	= type & 0x7f;
	id->id_w_dim	= 0;

	/*
	**
	*/
	ptr	= entry?(&entry->rtn_a_vars):(&tree_globs);

	if ( !(1 & (status = lib$insert_tree(ptr,
			&id->id_r_name,&tree_node_flag,__vtl_cmp,__vtl_getvm,&node,id))) )
		lib$signal(status);
	else if ( status == LIB$_KEYALRINS )
		return	_vtl_log(VTL_DUPLID,&id->id_r_name);
	
	/*
	** Set an initial value
	*/
	if ( (type & TYPE_M_STRING) && val && val->tok_l_vchar && val->tok_a_vchar )
		{
		id->id_w_sz	= (unsigned short) val->tok_l_vchar;
		memcpy(&id->id_t_val,val->tok_a_vchar,id->id_w_sz);
		}
	else	id->id_l_val	= val->tok_l_digit;

	return	SS$_NORMAL;
}

//----------------------------------------------------------

int	_vtl_getinstr	(
		VTL_INSTR	**	instr
			)
{
int     status;
static int VMZoneAlg = LIB$K_VM_FIXED,
        VMZoneFlags = LIB$M_VM_EXTEND_AREA | LIB$M_VM_GET_FILL0,
        VMZoneBlockSz = sizeof(VTL_INSTR)*4,VMZoneSz = sizeof(VTL_INSTR);

	/*
	** At first call initalize the Expression VM Zone
	*/
	if ( !VMZoneId_EXPR && !(1 & (status = lib$create_vm_zone(&VMZoneId_EXPR,
				&VMZoneAlg,&VMZoneBlockSz,&VMZoneFlags,0,
                                &VMZoneSz,0,0,0,0,&VMZoneName_EXPR,0,0))) )
		lib$signal(status);

	/*
	** Allocate a memory for new expresions
	*/
        if ( !(1 & (status = lib$get_vm(&VMZoneSz,instr,&VMZoneId_EXPR))) )
		lib$signal(status);

	return	status;
}


int	_vtl_opencode	(
		VTL_TOK *	$$,
		VTL_RTN	*	rtn,
		unsigned	opcode,
		VTL_TOK	*	op1,
		VTL_TOK *	op2
			)
{
int     status;
VTL_ID	*id = NULL;
VTL_NODE *node;
VTL_KEY	 key;
VTL_INSTR *instr;

	/*
	** Allocate a memory for new expresions
	*/
        if ( !(1 & (status = _vtl_getinstr(&instr))) )
		lib$signal(status);

	/*
	** Insert new expression at top of expression list
	** (at top of expressions' stack)
	*/
	if ( !(1 & (status = lib$insqhi(instr,&rtn->rtn_r_instr,&RETRY_COUNT))) )
		lib$signal(status);

	/*
	** Set expression Operation Code
	*/
	instr->instr_w_opcode	= opcode;
	instr->instr_l_lbl	= rtn->rtn_l_instrc++;

	$$->tok_a_instr	= instr;
	$$->tok_l_type	= TOK_M_INSTR;

	if ( op1 && op1->tok_v_digit )
		{
		instr->op1_l_type	= TYPE_M_LONG;
		instr->op1_l_op1	= op1->tok_l_digit;
		}
	else if ( op1 && op1->tok_v_id )
		{
		/*
		** Form key structure
		*/
		key.key_b_len	= $min(op1->tok_l_vchar,sizeof(key.key_t_sts));
		memcpy(key.key_t_sts,op1->tok_a_vchar,key.key_b_len);

		/*
		** Look firstly the variable name in the current routine
		*/
		if ( rtn && rtn->rtn_a_vars )
			status = lib$lookup_tree(&rtn->rtn_a_vars,&key,__vtl_cmp,&node);
	
		/*
		** If we did not found the variable try to look at globals
		*/
		if ( !(1 & status) &&
			!(1 & (status = lib$lookup_tree(&tree_globs,&key,__vtl_cmp,&node))) )
				return	_vtl_log(VTL_UNKNID,&key.key_b_len);

		id = (VTL_ID *) node->tree_a_ptr;

		if ( !(id->id_l_type & TYPE_M_STRING)
			&& (id->id_l_type & TYPE_M_CONST) )
			{
			instr->op1_l_type	= id->id_l_type;
			instr->op1_l_op1	= id->id_l_val;
			}
		else	{
			instr->op1_l_type	= TYPE_M_ID;
			instr->op1_a_op1	= id;
			}
		}

	if ( op2 && op2->tok_v_digit )
		{
		instr->op2_l_type	= TYPE_M_LONG | TYPE_M_UNSIGN;
		instr->op2_l_op2	= op2->tok_l_digit;
		}
	else if ( op2 && op2->tok_v_id )
		{
		/*
		** Form key structure
		*/
		key.key_b_len	= $min(op2->tok_l_vchar,sizeof(key.key_t_sts));
		memcpy(key.key_t_sts,op2->tok_a_vchar,key.key_b_len);

		/*
		** Look firstly the variable name in the current routine
		*/
		if ( rtn && rtn->rtn_a_vars )
			status = lib$lookup_tree(&rtn->rtn_a_vars,&key,__vtl_cmp,&node);
	
		/*
		** If we did not found the variable try to look at globals
		*/
		if ( !(1 & status) &&
			!(1 & (status = lib$lookup_tree(&tree_globs,&key,__vtl_cmp,&node))) )
				return	_vtl_log(VTL_UNKNID,&key.key_b_len);

		id = (VTL_ID *) node->tree_a_ptr;

		if ( !(id->id_l_type & TYPE_M_STRING)
			&& (id->id_l_type & TYPE_M_CONST) )
			{
			instr->op2_l_type	= id->id_l_type;
			instr->op2_l_op2	= id->id_l_val;
			}
		else	{
			instr->op2_l_type	= TYPE_M_ID;
			instr->op2_a_op2	= id;
			}
		}


	return	status;
}

int	_vtl_opdecode	(
			VTL_INSTR	*instr
			)
{
int	status,sz = 0;
char	buf [ 1024];
struct dsc$descriptor buf_dsc;
$DESCRIPTOR(fao_dsc,	"SP + !8UL (!XL)!_OPCODE:!_!XW");
$DESCRIPTOR(fao3_dsc,	"!_OP:!UL !_!AC (%x!XL)");
$DESCRIPTOR(fao4_dsc,	"!_OP:!UL (TYPE=%x!XL) %x!XL");
VTL_ID *id;

	/*
	** Display instruction code & mnemonic
	*/
	INIT_SDESC(buf_dsc,sizeof(buf),buf);
	status = sys$fao(&fao_dsc,&buf_dsc,&buf_dsc.dsc$w_length,instr->instr_l_lbl,instr,
		instr->instr_w_opcode);

	sz	+= buf_dsc.dsc$w_length;
	buf_dsc.dsc$a_pointer	 += buf_dsc.dsc$w_length;
	buf_dsc.dsc$w_length	 = sizeof(buf) - sz;

	/*
	** Decode operands
	*/
	if ( instr->op1_l_type )
		{
		if ( instr->op1_l_type	& TYPE_M_ID )
			{
			id = (VTL_ID *) instr->op1_a_op1;
			status = sys$fao(&fao3_dsc,&buf_dsc,&buf_dsc.dsc$w_length,
				1,&id->id_r_name,id->id_l_val);
			}
                else	status = sys$fao(&fao4_dsc,&buf_dsc,&buf_dsc.dsc$w_length,
				1,instr->op1_l_type,instr->op1_l_op1);

		sz	+= buf_dsc.dsc$w_length;
		buf_dsc.dsc$a_pointer	 += buf_dsc.dsc$w_length;
		buf_dsc.dsc$w_length	 = sizeof(buf) - sz;
		}


	if ( instr->op2_l_type )
		{
		status = sys$fao(&fao4_dsc,&buf_dsc,&buf_dsc.dsc$w_length,
			2,instr->op2_l_type,instr->op2_l_op2);

		sz	+= buf_dsc.dsc$w_length;
		buf_dsc.dsc$a_pointer	 += buf_dsc.dsc$w_length;
		buf_dsc.dsc$w_length	 = sizeof(buf) - sz;
		}


	INIT_SDESC(buf_dsc,sz,buf);

	lib$put_output(&buf_dsc);
}