Skip to content
GitLab
Commit 43ebd2b3 authored by Duncan White's avatar Duncan White
Browse files

removed some more m2datadec leftovers

parent 69792c72
Hide whitespace changes
Inline Side-by-side
m2decs.c deleted 100644 → 0
View file @ 69792c72
/* 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 )
{