%pure_parser

%{

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

#include	<starlet.h>
#include	<libdef.h>
#include	<lib$routines.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	<tpadef.h>
#include	<vtldef.h>

#define	VTL_IDDECL(p1,p2)	{ _vtl_iddecl(&p1,vars,&p2,entry); }
#define	VTL_RTNDECL(p1)		{ _vtl_rtndecl(&p1,&ret,&entry); }
#define	VTL_RTNARGDECL(p1)	{ _vtl_rtnargdecl(entry,&p1); }

#define		YYDEBUG	1
#define		YYERROR_VERBOSE	1
#define		YYLSP_NEEDED	1
unsigned	vars = 0,
		ret = 0, Px = 0;
void	*entry = NULL;

%}

%union	{
	VTL_TOK	tok;
}

%start	prog

%token	INCLUDE DEFS CDD DEFINE ENTRY
%token	ROUTINE STRUCT TYPEDEF CONST UNSIGNED
%token	VOID BYTE WORD LONG QUAD FLOAT DOUBLE
%token	<tok>	STRING QUOTED
%token	<tok>	DIM
%token	<tok>	ID
%token	<tok>	FSPEC
%token	EOL EOS
%token	<tok>	DIGIT
%token	IF THEN ELSE ENDIF

%type	<tok>	expr
%type	<tok>	stmt


%left	'|' '&' '^' '~'
%left	'!'
%left '+' '-'
%left '*' '/' '%'


%% /* beginning of rules section */

prog	:	/*	*/
	|	prog	module
	|	prog	error
	;

module	:	/*	*/
	|	bdyprog	module
	|	hdrprog	module
	;

hdrprog	:	/*	*/
	|	INCLUDE	FSPEC
	|	DEFS	FSPEC
	|	CDD	FSPEC
	|	GLOBS
	;

bdyprog	:	/*	*/
	|	entries
	;

GLOBS	:	CONST  {vars |= TYPE_M_CONST;}	GLOBS
	|	UNSIGNED {vars |= TYPE_M_UNSIGN;} GLOBS
	|	globs2
	;

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

globs3	:	ID ';'	{ VTL_IDDECL($1,0); vars = 0; }

	|	ID ','	{ VTL_IDDECL($1,0)}
			globs3

	|	ID  '=' DIGIT ';'
			{ VTL_IDDECL($1,$3); vars = 0;}

	|	ID  '=' DIGIT ','
			{ VTL_IDDECL($1,$3);}
			globs3

	|	ID  '=' QUOTED ';'
			{ VTL_IDDECL($1,$3); vars = 0;}

	|	ID  '=' QUOTED ','
			{ VTL_IDDECL($1,$3);}
			globs3
	;

entries	:	/*	*/
	|	ROUTINE	ID { VTL_RTNDECL($2) }	'(' args
	;

args	:   	/*	*/
	|	STRING	{ TYPE_M_STRING}	args
	|	BYTE	{ TYPE_M_BYTE}	args
	|	WORD	{ TYPE_M_WORD}	args
	|	LONG	{ TYPE_M_WORD}	args
	|	QUAD	{ TYPE_M_LONG}	args
	|	FLOAT	{ TYPE_M_FLOAT}	args
	|	DOUBLE	{ TYPE_M_DOUBLE}	args
	|	','	{ 0} args
	|	')'	body
	;


body	:	'{'	body
	|	locs	body
	|	stmt	body
	|	'}'
	;

stmt	:	/*	*/
	|	ID '='  expr ';'
			{ _vtl_opencode(&$$,entry,VTL_OPER_SET,&$1,&$3); }
	|	IF expr THEN stmt ELSE stmt ENDIF
			{ _vtl_opencode(&$$,entry,VTL_OPER_IFELSE,&$2,&$6); }
	|	IF expr THEN stmt ENDIF
			{ _vtl_opencode(&$$,entry,VTL_OPER_IF,&$2,&$4); }
	;

expr	:	'(' expr ')'
	|	expr '+' expr { _vtl_opencode(&$$,entry,VTL_OPER_ADD,&$1,&$3); }
	|	expr '-' expr { _vtl_opencode(&$$,entry,VTL_OPER_SUB,&$1,&$3); }
	|	expr '*' expr { _vtl_opencode(&$$,entry,VTL_OPER_MUL,&$1,&$3); }
	|	expr '/' expr { _vtl_opencode(&$$,entry,VTL_OPER_DIV,&$1,&$3); }
	|	expr '%' expr { _vtl_opencode(&$$,entry,VTL_OPER_MOD,&$1,&$3); }
	|	expr '|' expr { _vtl_opencode(&$$,entry,VTL_OPER_OR,&$1,&$3); }
	|	expr '&' expr { _vtl_opencode(&$$,entry,VTL_OPER_AND,&$1,&$3); }
	|	expr '^' expr { _vtl_opencode(&$$,entry,VTL_OPER_XOR,&$1,&$3); }
	|	expr '!' expr { _vtl_opencode(&$$,entry,VTL_OPER_NOT,&$1,&$3); }
	|	expr '~' expr { _vtl_opencode(&$$,entry,VTL_OPER_NEG,&$1,&$3); }
	|	ID
	|	DIGIT
	|	';'
	;

locs	:	CONST	{ vars |= TYPE_M_CONST; }	locs
	|	UNSIGNED { vars |= TYPE_M_UNSIGN; }	locs
	|	locs2
	;

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

locs3	:	ID ';'	{ VTL_IDDECL($1,0); vars = 0; }
	|	ID ','	{ VTL_IDDECL($1,0)}
			locs3
	|	ID  '=' DIGIT ';'
			{ VTL_IDDECL($1,$3); vars = 0;}
	|	ID  '=' DIGIT ','
			{ VTL_IDDECL($1,$3);}
			locs3
	|	ID  '=' QUOTED ';'
			{ VTL_IDDECL($1,$3); vars = 0;}
	|	ID  '=' QUOTED ','
			{ VTL_IDDECL($1,$3);}
			locs3
	;

%% /* start of programs */
/*

*/
/*
**
**      LIB$TPARSE stuff
**
*/
extern char     ufd_state, ufd_key;
struct  tp_block {
	TPADEF 	tpb;
	unsigned 	len;
	void 	*	ptr;
	unsigned __int64 num;
        }  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
	*/
	_vtl_iddump(NULL,NULL);
	_vtl_rtndump(NULL);

	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_chadd(
	struct tp_block *tblock
		)
{
	if ( !tblock->len && !tblock->ptr )
		{
		tblock->len	= 1;
		tblock->ptr	= tblock->tpb.tpa$l_tokenptr;
		}
	else	tblock->len++;

	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;
	tblock->num	= tblock->tpb.tpa$l_number;
	return	SS$_NORMAL;
}


int	yylex (YYSTYPE *lvalp, YYLTYPE *llocp)
{
int	status;
static	flag = 0;

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

	if ( !flag )
		flag = llocp->first_line = llocp->first_column = 1;



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

	/*
	** Call parser, and return status
	*/
	if ( 1 & (status = lib$table_parse(&tblock,&ufd_state,&ufd_key)) )
		{
		lvalp->tok.tok_l_type	= TOK_M_VCHAR;

		if ( tblock.tpb.tpa$l_param == VTL_TOK_DIGIT )
			{
			lvalp->tok.tok_l_digit	= tblock.num;
			lvalp->tok.tok_l_type	= TOK_M_DIGIT;
			}
		else if ( tblock.ptr && tblock.len )
			{
			lvalp->tok.tok_l_type	= TOK_M_ID;
			lvalp->tok.tok_l_vchar= tblock.len;
			lvalp->tok.tok_a_vchar= tblock.ptr;
			}
		else	{
			lvalp->tok.tok_l_vchar= tblock.tpb.tpa$l_tokencnt;
			lvalp->tok.tok_a_vchar= tblock.tpb.tpa$l_tokenptr;
			}

		status  = tblock.tpb.tpa$l_param?tblock.tpb.tpa$l_param:
			tblock.tpb.tpa$l_char;
		}

	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);

	fflush(stdout);

	return	status;
}

yyerror	(char *s)
{
	if ( s && (*s) )
	        fprintf(stderr, "\t---- Error: '%s' ----\n", s);
}