m2decs.c

/* Generate data declarations in Modula-2 */


#include <dcw.h>
#include <string.h>
#include "struct.h"
#include "decs.h"


/*
/^#ifdef HASPROTOS
!/endif$
stat %
*/

#ifdef HASPROTOS
static void line( char * , long , long , long , long );
static void defn_declns( char * , char * , declnlist );
static void defn_onetype( decln );
static void impln_declns( char * , char * , char * , declnlist );
static void impln_onetype( decln );
static void variantfields( decln );
static void normalfields( decln );
static void consproc_header( char * , shape );
static void consproc_body( decln , shape );
static void deconskind_header( char * );
static void deconskind_body( decln );
static void deconskind_inner( decln );
static void deconsproc_header( char * , shape );
static void deconsproc_body( decln , shape );
static void writeproc_header( char * );
static void writeproc_body( decln );
static void write_using_case( char * , char * , shapelist );
static void write_all_params( char * , shape );
static void write_default_printlist( shape );
static void write_printlist( shape , char * );
static void write_param( char * , param );
static void outstring( char * );
static void write_bool( void );
static char * lookup_type( char * );
static char * lookup_write_proc( char * );
static int predefined_type( char * );
#else
static void line();
static void defn_declns();
static void defn_onetype();
static void impln_declns();
static void impln_onetype();
static void variantfields();
static void normalfields();
static void consproc_header();
static void consproc_body();
static void deconskind_header();
static void deconskind_body();
static void deconskind_inner();
static void deconsproc_header();
static void deconsproc_body();
static void writeproc_header();
static void writeproc_body();
static void write_using_case();
static void write_all_params();
static void write_default_printlist();
static void write_printlist();
static void write_param();
static void outstring();
static void write_bool();
static char * lookup_type();
static char * lookup_write_proc();
static int predefined_type();
#endif


/* ------------------------- PUBLIC PROCEDURES --------------------------- */


void make_declns( exports, globals, begin, d, base ) declnlist d; char *exports, *globals, *begin, *base;
{
	printf( "m2datadec: Making data declarations in %s.{def,mod}\n", base );

	defn_declns( exports, base, d );

	impln_declns( globals, begin, base, d );
}


/* ------------------------- PRIVATE PROCEDURES -------------------------- */


static int numtabs = 0;
static FILE *outfile;


#define indent() numtabs++
#define outdent() numtabs--

#define nl()		fputc( '\n', outfile )
#define outchar(c)	fputc( c, outfile )
#define usefile(f)	outfile = f, numtabs = 0


/*VARARGS*/
static void line( fmt, a, b, c, d ) char *fmt; long a, b, c, d;
{
	int i;

	for( i=numtabs; i; i-- ) fputc( '\t', outfile );
	fprintf( outfile, fmt, a, b, c, d );
	nl();
}


/* ------------------------- Definition module --------------------------- */


static void defn_declns( exports, modulename, decs ) char *exports, *modulename; declnlist decs;
{
	FILE		*defnfile;
        char		tempname[256];
	declnlist	d;
	char		*exportptr;

        sprintf( tempname, "%s.def", modulename );
        defnfile = fopen( tempname, "w" );
        ASSERT( defnfile != NULL, ("m2datadec: can't create '%s'\n",tempname) );

	usefile( defnfile );

	line( "DEFINITION MODULE %s ;", modulename );
	nl();
	line( "(*" );
	line( " * Automatically Generated by M2DataDec" );
	line( " *)" );
	nl();
	nl();
	line( "FROM FIO IMPORT File;" );
	nl();
	nl();

	exportptr=exports;
	if( *exports != '\0' )
	{
		int i;

		line( "(* Contents of EXPORT section *)" );
		for( ; *exportptr; exportptr++ )
		{
			if( *exportptr == '@' && exportptr[1] == '@'
			&&   exportptr[2] == '\n' )
			{
				exportptr += 2;
				break;
			}
			outchar( *exportptr );
		}

		nl();
		nl();
	}

	line( "(* Types - declared forward *)" );
	nl();
	line( "TYPE" );
	indent();
	for( d = decs; d != NULL; d=d->next )
	{
		if( d->Struct )
		{
			line( "%s;", d->name );
		} else
		{
			line( "%s\t= INTEGER;", d->name );
		}
	}
	outdent();
	nl();

	for( d = decs; d != NULL; d=d->next )
	{
		defn_onetype( d );
	}

	if( *exportptr != '\0' )
	{
		nl();
		line( "(* Remaining contents of EXPORT section *)" );
		line( exportptr );
		nl();
	}

	line( "END %s.", modulename );
	nl();
	fclose( defnfile );
}


static void defn_onetype( d ) decln d;
{
	shapelist	s;
	BOOL		first;

	line( "(* ----------- Type %s ----------- *)", d->name );
	nl();

	line( "(* Constructor functions for %s *)", d->name );
	for( s = d->shapes; s != NULL; s = s->next )
	{
		consproc_header( d->name, s );
	}
	nl();

	if( d->ManyShapes )
	{
		line( "(* Kind of %s *)", d->name );
		line( "TYPE" );
		fprintf( outfile, "\tKindOf%s = ( ", d->name );
		first = TRUE;
		for( s = d->shapes; s; s=s->next )
		{
			if( !first ) fputs( ", ", outfile );
			fprintf( outfile, "%sIs%s", d->name, s->name );
			first = FALSE;
		}
		fprintf( outfile, " );\n" );
		nl();
		line( "(* Deconstructor kind function for %s *)",
			d->name );
		deconskind_header( d->name );
		nl();
	}

	if( d->Struct )
	{
		line( "(* Deconstructor functions for %s *)", d->name );

		for( s = d->shapes; s != NULL; s = s->next )
		{
			if( s->params != NULL )
			{
				deconsproc_header( d->name, s );
			}
		}
		nl();
	}

	line( "(* write function for %s *)", d->name );
	writeproc_header( d->name );
	nl();
	nl();
}


/* ----------------------- Implementation module ------------------------- */


static void impln_declns( globals, begin, modulename, decs ) char *globals, *begin, *modulename; declnlist decs;
{
	FILE		*implnfile;
        char		tempname[256];
	declnlist	d;
	char		*globalptr;

        sprintf( tempname, "%s.mod", modulename );
        implnfile = fopen( tempname, "w" );
        ASSERT( implnfile!=NULL, ("m2datadec: can't create '%s'\n",tempname) );

	usefile( implnfile );

	line( "IMPLEMENTATION MODULE %s ;", modulename );
	nl();
	line( "(*" );
	line( " * Automatically Generated by M2DataDec" );
	line( " *)" );
	nl();
	nl();
	line( "FROM Assertions IMPORT Assert, Abort;" );
	nl();
	line( "FROM FIO IMPORT" );
	indent();
	line( "File, WriteString, WriteChar, WriteInteger," );
	line( "WriteCardinal, WriteReal, WriteLine, WriteLn;" );
	nl();
	outdent();
	line( "FROM Storage IMPORT ALLOCATE;" );
	nl();
	nl();

	globalptr = globals;
	if( *globals != '\0' )
	{
		line( "(* Contents of GLOBAL section *)" );
		for( ; *globalptr; globalptr++ )
		{
			if( *globalptr == '@' && globalptr[1] == '@'
			&&   globalptr[2] == '\n' )
			{
				globalptr += 2;
				break;
			}
			outchar( *globalptr );
		}

		nl();
	}

	line( "(* Pointer type declarations *)" );
	line( "TYPE" );
	indent();
	for( d = decs; d != NULL; d=d->next )
	{
		if( d->Struct )
		{
			line( "%s\t= POINTER TO %sRec;", d->name, d->name );
			nl();
		}
	}
	outdent();

	for( d = decs; d != NULL; d=d->next )
	{
		impln_onetype( d );
	}
	write_bool();

	if( *globalptr != '\0' )
	{
		nl();
		nl();
		line( "(* Remaining contents of GLOBAL section *)" );
		line( globalptr );
		nl();
	}

	line( "BEGIN" );
	if( *begin != '\0' )
	{
		line( "\t(* Contents of BEGIN section *)" );
		line( begin );
	}
	line( "END %s.", modulename );
	fclose( implnfile );
}


static void impln_onetype( d ) decln d;
{
	shapelist s;

	nl();
	line( "(* ---- Type %s ---- *)", d->name );
	nl();

	if( d->Struct )
	{
		line( "TYPE" );
		indent();
		line( "%sRec = RECORD", d->name );
		indent();

		if( d->Union )
		{
			variantfields( d );
		} else if( d->TagField )
		{
			line( "tag\t: KindOf%s;", d->name );
			normalfields( d );
		} else
		{
			normalfields( d );
		}
		outdent();
		line( "END;" );
		nl();

		outdent();
	}
	nl();

	for( s = d->shapes; s != NULL; s = s->next )
	{
		consproc_body( d, s );
	}

	if( d->ManyShapes )
	{
		deconskind_body( d );
	}

	for( s = d->shapes; s != NULL; s = s->next )
	{
		if( s->params != NULL )
		{
			deconsproc_body( d, s );
		}
	}

	writeproc_body( d );
}


/* ------------------------- Fields of record ---------------------------- */


static void variantfields( d ) decln d;
{
	shapelist	s;
	paramlist	p;

	line( "CASE tag : KindOf%s OF", d->name );

	for( s = d->shapes; s != NULL; s=s->next )
	{
		line( "|%sIs%s:", d->name, s->name );
		indent();
		for( p = s->params; p != NULL; p=p->next )
		{
			line( "%s%s\t: %s;", s->name, p->name,
			      lookup_type(p->type) );
		}
		outdent();
	}

	line( "END;" );
}


static void normalfields( d ) decln d;
{
	shapelist	s;
	paramlist	p;

	for( s = d->shapes; s != NULL; s=s->next )
	{
		for( p = s->params; p != NULL; p=p->next )
		{
			line( "%s%s\t: %s;", s->name, p->name,
			      lookup_type(p->type) );
		}
	}
}


/* ----------------------- Construction procedures ----------------------- */


static void consproc_header( name, s ) char *name; shape s;
{
	paramlist	p;
	BOOL		first;

	fprintf( outfile, "PROCEDURE %s%s( ", name, s->name );
	first = TRUE;
	for( p = s->params; p != NULL ; p = p->next )
	{
		if( !first ) fputs( "; ", outfile );
		fprintf( outfile, "%s : %s ",
			 p->name, lookup_type(p->type) );
		first = FALSE;
	}
	fprintf( outfile, ") : %s;\n", name );
}


static void consproc_body( d, s ) decln d; shape s;
{
	paramlist p;

	consproc_header( d->name, s );
	nl();

	if( d->Struct && ! ( d->UseNull && d->shapes == s ) )
	{
		line( "VAR\tnew : %s;", d->name );
		nl();
	}
	line( "BEGIN" );
	indent();

	if( d->UseNull && d->shapes == s )
	{
		line( "RETURN NIL;" );
	} else if( ! d->Struct )
	{
		if( d->ManyShapes )
		{
			line( "RETURN %s( ORD(%sIs%s) );",
				d->name, d->name, s->name );
		} else
		{
			line( "RETURN %s( 0 );", d->name );
		}
	} else
	{
		line( "NEW( new );", d->name );
		if( d->TagField )
		{
			line( "new^.tag\t:= %sIs%s;", d->name, s->name );
		}
		for( p=s->params; p != NULL; p=p->next )
		{
			line( "new^.%s%s\t:= %s;", s->name, p->name, p->name );
		}
		line( "RETURN new;" );
	}

	outdent();
	line( "END %s%s;", d->name, s->name );
	nl();
	nl();
}


/* -------------------- Deconstruction Kind procedure -------------------- */


static void deconskind_header( name ) char *name;
{
	line( "PROCEDURE %sKind( this : %s ) : KindOf%s;", name, name, name );
}


static void deconskind_body( d ) decln d;
{
	deconskind_header( d->name );
	nl();
	line( "BEGIN" );
	indent();
	deconskind_inner( d );
	outdent();
	line( "END %sKind;", d->name );
	nl();
	nl();
}


static void deconskind_inner( d ) decln d;
{
	shapelist s = d->shapes;

	if( ! d->Struct )		/* enumerated type */
	{
		line( "RETURN VAL(KindOf%s, this);", d->name );
		return;
	}
	if( d->UseNull )
	{
		line( "IF this = NIL" );
		line( "THEN" );
		indent();
		line( "RETURN %sIs%s;", d->name, s->name );
		outdent();
		line( "END; (* IF *)" );
		s = s->next;
	}
	if( d->TagField )
	{
		line( "RETURN this^.tag;" );
	} else
	{
		line( "RETURN %sIs%s;", d->name, s->name );
	}
}


/* ---------------------- Deconstruction procedures ---------------------- */


static void deconsproc_header( name, s ) char *name; shape s;
{
	paramlist	p;

	fprintf( outfile, "PROCEDURE Get%s%s( this : %s ", name, s->name,
		 	  name );

	for( p = s->params; p != NULL ; p=p->next )
	{
		fprintf( outfile, "; VAR %s : %s ", p->name,
			 lookup_type(p->type) );
	}
	fprintf( outfile, ");\n" );
}


static void deconsproc_body( d, s ) decln d; shape s;
{
	paramlist p;

	deconsproc_header( d->name, s );
	nl();
	line( "BEGIN" );
	indent();

	for( p=s->params; p != NULL; p=p->next )
	{
		line( "%s\t:= this^.%s%s;", p->name, s->name, p->name );
	}

	outdent();
	line( "END Get%s%s;", d->name, s->name );
	nl();
	nl();
}


/* --------------------------- Write procedure --------------------------- */


static void writeproc_header( name ) char *name;
{
	line( "PROCEDURE Write%s( f : File; this : %s );", name, name );
}


static void writeproc_body( d ) decln d;
{
	shapelist shapes;

	writeproc_header( d->name );
	nl();

	if( d->PutLoop )
	{
		line( "VAR over : BOOLEAN;" );
		nl();
	}

	line( "BEGIN" );
	indent();

	if( d->PutLoop )
	{
		line( "REPEAT" );
		indent();
		line( "over := TRUE;" );
		nl();
	}

	shapes = d->shapes;
	if( d->UseNull )
	{
		line( "IF this = NIL" );
		line( "THEN" );
		indent();
		write_all_params( d->name, /* first */ shapes );
		outdent();
		line( "ELSE" );
		indent();
		shapes = shapes->next;
	}

	if( d->TagField )
	{
		write_using_case( "this^.tag", d->name, shapes );
	} else if( d->Struct )	/* only one shape left */
	{
		write_all_params( d->name, shapes );
	} else			/* enumerated type */
	{
		char tag[256];

		if( d->ManyShapes )
		{
			sprintf( tag, "VAL(KindOf%s, this)", d->name );
			write_using_case( tag, d->name, shapes );
		} else
		{
			line( "WriteString( f, \"%s\" );", shapes->name );
		}
	}
	if( d->UseNull )
	{
		outdent();
		line( "END; (* IF *)" );
	}

	if( d->PutLoop )
	{
		outdent();
		line( "UNTIL over;" );
	}
	outdent();
	line( "END Write%s;", d->name );
	nl();
}


static void write_using_case( tag, dname, s ) char *tag, *dname; shapelist s;
{
	line( "CASE %s OF", tag );
	for( ; s != NULL; s = s->next )
	{
		line( "|%sIs%s:", dname, s->name );
		indent();
		write_all_params( dname, s );
		outdent();
	}
	line( "ELSE" );
	indent();
	line( "Abort( \"Write%s: impossible tag\" );", dname );
	outdent();
	line( "END; (* CASE *)" );
}


static void write_all_params( dname, s ) char *dname; shape s;
{
	if( s->pl == NULL )
	{
		write_default_printlist( s );
	} else
	{
		write_printlist( s, dname );
	}
}


static void write_default_printlist( s ) shape s;
{
	BOOL		first;
	paramlist	p = s->params;

	/* No print items given - use defaults */

	if( p )
	{
		line( "WriteString( f, \"%s(\" );", s->name );
		for( first = TRUE; p != NULL; p = p->next )
		{
			if( ! first ) line( "WriteChar( f, \",\" );" );
			first = FALSE;
			write_param( s->name, p );
		}
		line( "WriteChar( f, ')' );" );
	} else
	{
		line( "WriteString( f, \"%s\" );", s->name );
	}
}


static void write_printlist( s, dname ) shape s; char *dname;
{
	/* Some print items given - use them */

	printlist	pl;
	param		p;
	int		n;

	/* All but the last item */

	for( pl = s->pl; pl->next != NULL; pl = pl->next )
	{
		if( pl->item->tag == printitem_is_str )
		{
			outstring( pl->item->str );
		} else
		{
			p = findnthparam( pl->item->num, s->params,
					  s->name, dname );
			write_param( s->name, p );
		}
	}

	/* Last item */

	if( pl->item->tag == printitem_is_str )
	{
		outstring( pl->item->str );
	} else
	{
		p = findnthparam( pl->item->num, s->params, s->name, dname );
		if( streq( p->type, dname ) )
		{
			line( "this := this^.%s%s;", s->name, p->name );
			line( "over := FALSE;" );
		} else
		{
			write_param( s->name, p );
		}
	}
}


static void write_param( sname, p ) char *sname; param p;
{
	line( "%s( f, this^.%s%s );",
	      lookup_write_proc(p->type), sname, p->name );
}


static void outstring( str ) char *str;
{
	char *p;
	BOOL over = FALSE;

	while( ! over )
	{
		p = strstr( str, "\\n" );
		if( p == NULL )
		{
			line( "WriteString( f, \"%s\" );", str );
			over = TRUE;
		} else
		{
			if( p == str )
			{
				line( "WriteLine( f );" );
			} else
			{
				line( "WriteLn( f, \"%.*s\" );", (p-str), str );
			}
			if( *(p+2) != '\0' )
			{
				str = p + 2;
			} else
			{
				over = TRUE;
			}
		}
	}
}


static void write_bool()
{
	line( "PROCEDURE WriteBool( f : File; bool : BOOLEAN );" );
	nl();
	line( "BEGIN" );
	indent();
	line( "IF bool" );
	line( "THEN" );
	indent();
	line( "WriteString( f, \"TRUE\" );" );
	outdent();
	line( "ELSE" );
	indent();
	line( "WriteString( f, \"FALSE\" );" );
	outdent();
	line( "END;" );
	outdent();
	line( "END WriteBool;" );
}


/* --------------------- Predefined type lookup system  ------------------ */


struct typelookup
{
	char	*name;
	char	*type_name;
	char	*write_name;
};


static struct typelookup lookup[] = {
	"int",		"INTEGER",	"WriteInteger",	
	"Int",		"INTEGER",	"WriteInteger",	
	"INT",		"INTEGER",	"WriteInteger",	
	"INTEGER",	"INTEGER",	"WriteInteger",	
	"card",		"CARDINAL",	"WriteCardinal",	
	"Card",		"CARDINAL",	"WriteCardinal",	
	"CARD",		"CARDINAL",	"WriteCardinal",	
	"CARDINAL",	"CARDINAL",	"WriteCardinal",	
	"string",	"string",	"WriteString",	
	"String",	"String",	"WriteString",	
	"real",		"REAL",		"WriteReal",	
	"Real",		"REAL",		"WriteReal",	
	"REAL",		"REAL",		"WriteReal",	
	"float",	"REAL",		"WriteReal",	
	"Float",	"REAL",		"WriteReal",	
	"char",		"CHAR",		"WriteChar",	
	"Char",		"CHAR",		"WriteChar",	
	"CHAR",		"CHAR",		"WriteChar",	
	"bool",		"BOOLEAN",	"WriteBool",	
	"Bool",		"BOOLEAN",	"WriteBool",	
	"BOOL",		"BOOLEAN",	"WriteBool",	
	"BOOLEAN",	"BOOLEAN",	"WriteBool",
};

#define NUM_LOOKUP_TYPES	(sizeof(lookup)/sizeof(lookup[0]))


static char *lookup_type( typename ) char *typename;
{
	int	predef;

	predef = predefined_type( typename );
	return (predef == -1) ? typename : lookup[predef].type_name;
}


static char *lookup_write_proc( typename ) char *typename;
{
	int	predef;
	static  char tmp[256];

	predef = predefined_type( typename );
	if( predef == -1 )
	{
		sprintf( tmp, "Write%s", typename );
		return tmp;
	} else
	{
		return lookup[predef].write_name;
	}
}


static int predefined_type( typename ) char *typename;
{
	int i;

	for( i=0; i<NUM_LOOKUP_TYPES; i++ )
	{
		if( streq( lookup[i].name, typename ) )
		{
			return i;
		}
	}
	return -1;
}