%{

#include        <builtins.h>
#define alloca  __ALLOCA
#define ALLOCA  __ALLOCA

#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	<ctype.h>

#define	__NEW_STARLET	1
#include	<vtldef.h>

#define	VTL_DEBUG	lib$signal(SS$_DEBUG);

#define	VTL_GLBADD(v,vv)	{ _vtl_glbadd(&v,vars,vard,&vv); }

#define		YYDEBUG	1
#define		YYERROR_VERBOSE	1

unsigned	glbi = 0,vars = 0,vard  = 0;
VTL_ID		glbs [ 512 ];

unsigned	rtni = 0,args = 0;
VTL_RTN		rtns [ 512 ];

%}

%union	{
	struct	vchar	{
		int	len;
		char	*ptr;
	} vchar;
	int	digit;
}

%start	prog

%token	INCLUDE DEFS CDD DEFINE ENTRY
%token	ROUTINE STRUCT TYPEDEF CONST UNSIGNED
%token	VOID BYTE WORD LONG QUAD FLOAT DOUBLE
%token	<vchar>	STRING
%token	<digit>	DIM
%token	<vchar>	ID
%token	<vchar>	FSPEC
%token	EOL EOS
%token	<digit>	DIGIT

%left '|'
%left '&'
%left '+' '-'
%left '*' '/' '%'
%left UMINUS   /* supplies precedence for unary minus */

%% /* beginning of rules section */

prog	:	/* empty */
	|	prog proghdr
	|	error
	;

proghdr	:	INCLUDE	FSPEC
	|	DEFS	FSPEC
	|	CDD	FSPEC
	|	ROUTINES
	|	DECL_VARS
	;

DECL_VARS:	CONST  {vars |= TYPE_M_CONST;}	DECL_VARS
	|	UNSIGNED {vars |= TYPE_M_UNSIGN;}	DECL_VARS
	|	decl_vars3
	;

decl_vars3:	BYTE	{ vars |= TYPE_M_BYTE} decl_vars4
	|	WORD	{ vars |= TYPE_M_WORD} decl_vars4
	|	LONG	{ vars |= TYPE_M_LONG} decl_vars4
	|	QUAD	{ vars |= TYPE_M_QUAD} decl_vars4
	|	FLOAT	{ vars |= TYPE_M_FLOAT} decl_vars4
	|	DOUBLE	{ vars |= TYPE_M_DOUBLE} decl_vars4
	|	STRING	{ vars |= TYPE_M_STRING} decl_vars4
	;

decl_vars4:	ID decl_dim ';'	{ VTL_GLBADD($1,0); vard = vars = 0; }
	|	ID decl_dim ','	{ VTL_GLBADD($1,0)}
			decl_vars4
	|	ID decl_dim '=' DIGIT ';'
			{ VTL_GLBADD($1,$4); vard = vars = 0;}
	|	ID decl_dim '=' DIGIT ','
			{ VTL_GLBADD($1,$4);}
			decl_vars4
	;

decl_dim:	/*	*/
	|	'[' DIGIT ']'	{ vard = $2;}
	;


ROUTINES:	ROUTINE	ID args
	|	'{' body '}'
	;

args	:	'('	args
	|	BYTE	{ args = TYPE_M_BYTE}	args
	|	WORD	{ args = TYPE_M_WORD}	args
	|	LONG	{ args = TYPE_M_WORD}	args
	|	QUAD	{ args = TYPE_M_LONG}	args
	|	FLOAT	{ args = TYPE_M_FLOAT}	args
	|	DOUBLE	{ args = TYPE_M_DOUBLE}	args
	|	','	{ args = 0} args
	|	')'
	;

body	:       /*	*/
	|	expr
	;

expr	:	'(' expr ')'
	|	expr '+' expr
	|	expr '-' expr
	|	expr '*' expr
	|	expr '/' expr
	|	expr '%' expr
	|	expr '&' expr
	|	expr '|' expr
	|	'-' expr %prec UMINUS
	|	ID
	|	DIGIT
	;


%% /* start of programs */

/*
**
**      LIB$TPARSE stuff
**
*/
extern char     ufd_state, ufd_key;
struct  tp_block {
        struct  tpadef  tpb;
        unsigned        mask,
			len;
	void 	*	ptr;
	unsigned __int64 num;
	
//        }  tblock = {{TPA$K_COUNT0}};
        }  tblock = {{TPA$K_COUNT0,TPA$M_BLANKS}};


char	vtlfn [] = "test.vtl";

#define P0SPACE ((void*)0x0200)

struct  {
        void    *start,
                *end;
        } inadr = {P0SPACE,P0SPACE},retadr= {NULL,NULL};

int	main	(void)
{
unsigned	status;
struct	FAB	fab;
struct	XABFHC	fhc;

	/*
	** Mapping a file to the Private Section
	*/
	fab = cc$rms_fab;
	fhc = cc$rms_xabfhc;
        fab.fab$l_xab = &fhc;
	fab.fab$b_fac = FAB$M_GET;
	fab.fab$b_shr = FAB$M_UPI | FAB$M_SHRGET | FAB$M_NQL;
	fab.fab$l_fop = FAB$M_UFO;
	fab.fab$l_fna = &vtlfn;
	fab.fab$b_fns = sizeof(vtlfn)-1;
	fab.fab$l_dna = ".VTL";
	fab.fab$b_dns = 4;

	/*
	** Open an .VTL module
	*/
	if ( !(1 & (status = sys$open(&fab))) )
                {int msgvec[] = {2,status,fab.fab$l_stv}; sys$putmsg(&msgvec,0,0,0);
                return  status;
                }

	/*
	** SYS$CRMPSC [inadr] ,[retadr] ,[acmode] ,[flags] ,[gsdnam] ,
	** [ident] ,[relpag] ,[chan] ,[pagcnt] ,[vbn] ,[prot] ,[pfc]
	*/
	tblock.tpb.tpa$l_stringcnt = inadr.end = 512*fhc.xab$l_ebk + fhc.xab$w_ffb;
	if ( !(1 & (status = sys$crmpsc(&inadr,&retadr,0,SEC$M_EXPREG,0,
			0,0,fab.fab$l_stv,fhc.xab$l_ebk,0,0,0))) )
		return	status;

	tblock.tpb.tpa$l_stringptr = retadr.start;

	yydebug	= 1;
	yyparse();

	/*
	** Display global variables/constant
	*/
	fprintf(stdout," --------- Args ------- \n");

	for (int i = 0; i < glbi;i++)
		{
		if ( glbs[i].id_r_type.type_v_const )
			fprintf(stdout,"const");
		if ( glbs[i].id_r_type.type_v_unsign )
			fprintf(stdout," unsigned");

		if ( glbs[i].id_r_type.type_v_string )
			fprintf(stdout," string");

		if ( glbs[i].id_l_dim )
			fprintf(stdout,"\t\t%.*s[%u] (type=%0x) = %u;\n",
				glbs[i].id_b_len,glbs[i].id_t_name,
				glbs[i].id_l_dim,
				glbs[i].id_r_type,
				glbs[i].id_l_val);
		else	fprintf(stdout,"\t\t%.*s (type=%0x) = %u;\n",
			glbs[i].id_b_len,glbs[i].id_t_name,
			glbs[i].id_r_type,
			glbs[i].id_l_val);
		}
	fprintf(stdout," --------- Args ------- \n");
	

	return	status;
}

/*
**++
**  FUNCTIONAL DESCRIPTION:
**
**      An action routine called from LIB$TPARSE stuff, store Token Id.
**
**  FORMAL PARAMETERS:
**
**     	tblock:	A pointer to the TPARSE block
**
**  RETURN VALUE:
**
**	VMS condition code
**
**--
*/
int	tok_id	(
	struct tp_block *tblock
		)
{
int	status = SS$_NORMAL;
	tblock->mask	= tblock->tpb.tpa$l_param;
	return	SS$_NORMAL;
}
int	tok_or	(
	struct tp_block *tblock
		)
{
	tblock->tpb.tpa$l_param	|= tblock->mask;
	return	SS$_NORMAL;
}
int	tok_unwind(
	struct tp_block *tblock
		)
{
	tblock->tpb.tpa$l_stringcnt++;
	tblock->tpb.tpa$l_stringptr--;
	return	SS$_NORMAL;
}

int	tok_val(
	struct tp_block *tblock
		)
{
	tblock->len	= tblock->tpb.tpa$l_tokencnt;
	tblock->ptr	= tblock->tpb.tpa$l_tokenptr;
	return	SS$_NORMAL;
}

int	yylex	(void)
{
int	status;

	if ( !tblock.tpb.tpa$l_stringcnt )
		return	VTL_TOK_EOS;

 	tblock.tpb.tpa$l_param = tblock.tpb.tpa$l_number = 0;

	/*
	** Call parser, and return status
	*/
	if ( 1 & (status = lib$table_parse(&tblock,&ufd_state,&ufd_key)) )
		{
		if ( tblock.tpb.tpa$l_param == VTL_TOK_DIGIT )
			yylval.digit	= tblock.tpb.tpa$l_number;
		else if ( tblock.ptr && tblock.len)
			{
			yylval.vchar.len= tblock.len;
			yylval.vchar.ptr= tblock.ptr;
			}
		else	{
			yylval.vchar.len= tblock.tpb.tpa$l_tokencnt;
			yylval.vchar.ptr= tblock.tpb.tpa$l_tokenptr;
			}

		status	= tblock.tpb.tpa$l_param;
		}

	fprintf(stdout,"\n\tTokId = %d,Val = '%.*s',Num = %d\n",status,
		tblock.tpb.tpa$l_tokencnt,tblock.tpb.tpa$l_tokenptr,
		tblock.tpb.tpa$l_number);

//	lib$signal(SS$_DEBUG);

 
	return	status;
}

yyerror(char *s)
{  
	fprintf(stderr, "%s\n", s);
}