Commit d73272f3 authored by dcw's avatar dcw
Browse files

Initial revision

parent 8ad1cf7d
/* Generate data declarations in Modula-2 */
#include <dcw.h>
#include "struct.h"
#include "decs.h"
typedef declnlist decln; /* JUST THE FIRST */
typedef shapelist shape; /* JUST THE FIRST */
typedef paramlist param; /* JUST THE FIRST */
/*
/^#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 * , 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 printproc_header( char * );
static void printproc_body( decln );
static void print_using_case( char * , char * , shapelist );
static void print_param( param );
static void print_all_params( char * , shape );
static void write_bool( void );
static char * lookup_type( char * );
static char * lookup_print_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 printproc_header();
static void printproc_body();
static void print_using_case();
static void print_param();
static void print_all_params();
static void write_bool();
static char * lookup_type();
static char * lookup_print_proc();
static int predefined_type();
#endif
BOOL print; /* print == generate print functions */
static int numtabs = 0;
static FILE *outfile;
/* ------------------------- PUBLIC PROCEDURES --------------------------- */
void make_declns( exports, globals, d, basename ) declnlist d; char *exports, *globals, *basename;
{
printf( "m2datadec: Making data declarations in %s.{def,mod}\n",
basename );
defn_declns( exports, basename, d );
impln_declns( globals, basename, d );
}
/* ------------------------- PRIVATE PROCEDURES -------------------------- */
#define indent() numtabs++
#define outdent() numtabs--
#define nl() fputc( '\n', 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;
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();
if( *exports != '\0' )
{
line( "(* Contents of EXPORT section *)" );
line( exports );
nl();
}
line( "(* Types - declared forward *)" );
nl();
line( "TYPE" );
indent();
for( d = decs; d != NULL; d=d->next )
{
if( d->Struct )
{
line( "%s;\t(* Opaque *)", d->name );
} else
{
line( "%s\t= INTEGER;", d->name );
}
}
outdent();
nl();
for( d = decs; d != NULL; d=d->next )
{
defn_onetype( d );
}
line( "END %s.", modulename );
nl();
fclose( defnfile );
}
static void defn_onetype( d ) decln d;
{
shapelist s;
int n;
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->Defines )
{
line( "(* Deconstructed tags for %s *)", d->name );
line( "CONST" );
indent();
n = 0;
for( s = d->shapes; s; s=s->next )
{
line( "%s_is_%s = %d;",
d->name, s->name, n++ );
}
outdent();
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();
}
if( print )
{
line( "(* Print function for %s *)", d->name );
printproc_header( d->name );
nl();
}
nl();
}
/* ----------------------- Implementation module ------------------------- */
static void impln_declns( globals, modulename, d ) char *globals, *modulename; declnlist d;
{
FILE *implnfile;
char tempname[256];
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, WriteReal;" );
nl();
outdent();
line( "FROM Storage IMPORT ALLOCATE;" );
nl();
nl();
if( *globals != '\0' )
{
line( "(* Contents of GLOBAL section *)" );
line( globals );
nl();
}
for( ; d != NULL; d=d->next )
{
impln_onetype( d );
}
if( print )
{
write_bool();
}
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( "%s\t= POINTER TO %s_rec;", d->name, d->name );
nl();
line( "%s_rec = RECORD", d->name );
indent();
if( d->Union )
{
variantfields( d );
} else if( d->TagField )
{
line( "tag\t: INTEGER;" );
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->Defines )
{
deconskind_body( d );
}
for( s = d->shapes; s != NULL; s = s->next )
{
if( s->params != NULL )
{
deconsproc_body( d, s );
}
}
if( print )
{
printproc_body( d );
}
}
/* ------------------------- Fields of record ---------------------------- */
static void variantfields( d ) decln d;
{
shapelist s;
paramlist p;
line( "CASE tag : INTEGER OF" );
for( s = d->shapes; s != NULL; s=s->next )
{
line( "|%s_is_%s:", d->name, s->name );
indent();
for( p = s->params; p != NULL; p=p->next )
{
line( "%s\t: %s;", 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\t: %s;", 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 )
{
line( "RETURN %s_is_%s;", d->name, s->name );
} else
{
line( "NEW( new );", d->name );
if( d->TagField )
{
line( "new^.tag\t:= %s_is_%s;", d->name, s->name );
}
for( p=s->params; p != NULL; p=p->next )
{
line( "new^.%s\t:= %s;", 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 getkind_%s( this : %s ) : INTEGER;", name, name );
}
static void deconskind_body( d ) decln d;
{
deconskind_header( d->name );
nl();
line( "BEGIN" );
indent();
deconskind_inner( d );
outdent();
line( "END getkind_%s;", d->name );
nl();
nl();
}
static void deconskind_inner( d ) decln d;
{
shapelist s = d->shapes;
if( ! d->Struct ) /* enumerated type */
{
line( "RETURN this;" );
return;
}
if( d->UseNull )
{
line( "IF this = NIL" );
line( "THEN" );
indent();
line( "RETURN %s_is_%s;", d->name, s->name );
outdent();
line( "END; (* IF *)" );
s = s->next;
}
if( d->TagField )
{
line( "RETURN this^.tag;" );
} else
{
line( "RETURN %s_is_%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;", p->name, p->name );
}
outdent();
line( "END get_%s_%s;", d->name, s->name );
nl();
nl();
}
/* --------------------------- Print procedure --------------------------- */
static void printproc_header( name ) char *name;
{
line( "PROCEDURE print_%s( f : File; this : %s );", name, name );
}
static void printproc_body( d ) decln d;
{
shapelist s;
shapelist shapes;
printproc_header( d->name );
nl();
line( "BEGIN" );
indent();
shapes = d->shapes;
if( d->UseNull )
{
line( "IF this = NIL" );
line( "THEN" );
indent();
print_all_params( d->name, shapes );
line( "RETURN;" );
outdent();
line( "END; (* IF *)" );
shapes = shapes->next;
}
if( d->TagField )
{
print_using_case( "this^.tag", d->name, shapes );
} else if( d->Struct ) /* only one shape left */
{
print_all_params( d->name, shapes );
} else /* enumerated type */
{
print_using_case( "this", d->name, shapes );
}
outdent();
line( "END print_%s;", d->name );
nl();
}
static void print_using_case( tag, dname, s ) char *tag, *dname; shapelist s;
{
line( "CASE %s OF", tag );
for( ; s != NULL; s = s->next )
{
line( "|%s_is_%s:", dname, s->name );
indent();
print_all_params( dname, s );
outdent();
}
line( "ELSE" );
indent();
line( "Abort( \"print_%s: impossible tag\" );", dname );
outdent();
line( "END; (* CASE *)" );
}
static void print_param( p ) param p;
{
line( "%s( f, this^.%s );", lookup_print_proc(p->type), p->name );
}
static void print_all_params( dname, s ) char *dname; shape s;
{
printlist pl;
paramlist p;
if( s->pl == NULL )
{
/* No print items given - use defaults */
line( "WriteString( f, \"%s\" );", s->name );
if( s->params )
{
line( "WriteChar( f, '(' );" );
for( p = s->params; p != NULL; p = p->next )
{
print_param( p );
}
line( "WriteChar( f, ')' );" );
}
} else
{
/* Some print items given - use them */
for( pl = s->pl; pl != NULL; pl = pl->next )
{
if( pl->item->tag == printitem_is_str )
{
line( "WriteString( f, \"%s\" );",
pl->item->str );
} else
{
int n = pl->item->num;
for( p = s->