%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	VTL_PUSHID(p1,p2,p3)	{ _vtl_pushid(entry,&p1,&p2); }
#define	VTL_PUSHVAL(p1,p2,p3)	{ _vtl_pushval(&p1,&p2); }
#define	VTL_PUSHEXPR(p1,p2)	{ _vtl_pushexpr(entry,p1,&p2); }

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

%}

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

%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 QUOTED
%token	<digit>	DIM
%token	<vchar>	ID
%token	<vchar>	FSPEC
%token	EOL EOS
%token	<digit>	DIGIT

%type	<expr> expr expr_elem


%% /* beginning of rules section */


prog	:	/*	*/
	|	prog	zz
	|	prog	error
	;

zz	:	ROUTINE	ID { VTL_RTNDECL($2) }
			'(' args ')'
			'{' stmt '}'
	;

args	:	VOID
	|	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
	;

stmt	:	ID '='  expr	{ VTL_PUSHEXPR(VTL_OPER_SET,$1,$3); }
	;

expr	:	/*	*/
	|	'(' expr ')'
	|	expr '+' { VTL_PUSHEXPR(VTL_OPER_ADD,$1); }	expr
	|	expr '-' { VTL_PUSHEXPR(VTL_OPER_SUB,$1); }     expr
	|	expr '*' { VTL_PUSHEXPR(VTL_OPER_MUL,$1); }     expr
	|	expr '/' { VTL_PUSHEXPR(VTL_OPER_DIV,$1); }     expr
	|	expr_elem	expr
	|	';'
	;

expr_elem:	ID	{ VTL_PUSHID($$,$1) }
	|	DIGIT	{ VTL_PUSHVAL($$,$1) }
	;




%% /* 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;
	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)) )
		{
		if ( tblock.tpb.tpa$l_param == VTL_TOK_DIGIT )
			lvalp->digit	= tblock.tpb.tpa$l_number;
		else if ( tblock.ptr && tblock.len)
			{
			lvalp->vchar.len= tblock.len;
			lvalp->vchar.ptr= tblock.ptr;
			}
		else	{
			lvalp->vchar.len= tblock.tpb.tpa$l_tokencnt;
			lvalp->vchar.ptr= 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);

	fprintf(stdout,"\n\tyylval = %d,'%.*s'\n",
			lvalp->digit,lvalp->vchar.len,lvalp->vchar.ptr);

	fflush(stdout);

	return	status;
}

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