/*
 * Copyright (C) 1984 by Eric C. Cooper.
 * All rights reserved.
 */
#ifndef lint
static char RCSid[] = "$Header: typecode.c,v 2.0 85/11/21 07:21:47 jqj Exp $";
#endif

/* $Log:	typecode.c,v $
 * Revision 2.0  85/11/21  07:21:47  jqj
 * 4.3BSD standard release
 * 
 * Revision 1.6  85/05/23  06:20:12  jqj
 * *** empty log message ***
 * 
 * Revision 1.6  85/05/23  06:20:12  jqj
 * Public Beta-test version, released 24 May 1985
 * 
 * Revision 1.5  85/05/06  08:13:43  jqj
 * Almost Beta-test version.
 * 
 * Revision 1.4  85/03/26  06:10:42  jqj
 * Revised public alpha-test version, released 26 March 1985
 * 
 * Revision 1.3  85/03/11  16:40:21  jqj
 * Public alpha-test version, released 11 March 1985
 * 
 * Revision 1.2  85/02/21  11:06:11  jqj
 * alpha test version
 * 
 * Revision 1.1  85/02/15  13:55:45  jqj
 * Initial revision
 * 
 */

#include "compiler.h"

#define candidate_name(str)	(str)

/*
 * This function is used to cope with the fact that C passes arrays
 * by reference but all other types by value.
 * The argument should be a base type.
 */
char *
refstr(typtr)
	struct type *typtr;
{
/*	if (typtr->o_class != O_TYPE)
		error(FATAL, "internal error (refstr): not a type");
 */
	return (typtr->type_constr == C_ARRAY ? "" : "&");
}

/*
 * Names of translation functions for types.
 * Warning: returns pointer to a static buffer.
 */
char *
xfn(kind, typtr)
	enum translation kind;
	struct type *typtr;
{
	static char buf[MAXSTR];
	char *name;

	switch (kind) {
	    case EXTERNALIZE:
		name = "externalize";
		break;
	    case INTERNALIZE:
		name = "internalize";
		break;
	}
	(void) sprintf(buf, "%s_%s", name, typtr->type_name);
	return (buf);
}

/*
 * Print the heading for a type externalizing or internalizing function.
 */
xfn_header(kind, typtr, ptr_type)
	enum translation kind;
	struct type *typtr, *ptr_type;
{
	FILE *f;

	switch (kind) {
	    case EXTERNALIZE:
		f = support1; break;
	    case INTERNALIZE:
		f = support2; break;
	}
	fprintf(f,
"\n\
int\n\
%s(p, buf)\n\
\tregister %s *p;\n\
\tregister Unspecified *buf;\n",
		xfn(kind, typtr), typename(ptr_type));
}

/*
 * create an alias for a type's datastructures.  Note that caller must
 * create the alias for the typedef name itself.
 */
copy_typefns(headerfile,new,old)
	FILE *headerfile; 
	char *new, *old;
{
	fprintf(headerfile,
"#define sizeof_%s sizeof_%s\n\
#define clear_%s clear_%s\n\
#define externalize_%s externalize_%s\n\
#define internalize_%s internalize_%s\n\n",
			new, old, new, old, new, old, new, old);
}


define_enumeration_type(typtr)
	struct type *typtr;
{
	list p,q;

	typtr->type_xsize = 1;
	if (recursive_flag)
		return;
	/*
	 * Print a C definition for the enumeration.
	 */
	fprintf(header, "\ntypedef enum {\n");
	for (p = typtr->type_list; p != NIL; p = cdr(p)) {
		q=car(p);
		fprintf(header, "\t%s = %s", name_of(car(q)),
				((char *) cdr(q)) );
		if (cdr(p) != NIL)
			fprintf(header, ",\n");
		else
			fprintf(header, "\n");
	}
	fprintf(header, "} %s;\n", typename(typtr));
	/*
	 * We use the same sizeof and translation functions
	 * for all enumerated types.
	 */
	copy_typefns(header,typename(typtr),"enumeration");
}


define_record_type(typtr)
	struct type *typtr;
{
	struct type *bt;
	list p, q;
	int fixed_size;
	char *format, *ref, *member;

	/*
	 * Make sure all subtypes are defined and have sizes
	 */
	for (p = typtr->type_list; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		if (typename(bt) == NULL) {
			struct object *name;
			name = make_symbol(gensym("T_r"),CurrentProgram);
			define_type(name,bt);
		}
	}
	/*
	 * Generate size field.
	 * The size is equal to the sum of the sizes of each field.
	 */
	fixed_size = 0;
	typtr->type_xsize = 0;
	for (p = typtr->type_list; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		if (bt->type_xsize == -1)
			typtr->type_xsize = -1;
		else
			fixed_size += bt->type_xsize;
	}
	if (typtr->type_xsize != -1)
		typtr->type_xsize = fixed_size;
	if (recursive_flag)
		return;
	/*
	 * Print a C definition for the record.
	 */
	fprintf(header, "\ntypedef struct {\n");
	for (p = typtr->type_list; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		q = caar(p);
		member = (char *) car(q);
		fprintf(header, "\t%s %s;\n", typename(bt), member);
	}
	fprintf(header, "} %s;\n", typename(typtr));
	/*
	 * Generate sizeof and free functions for the record.
	 */
	if (typtr->type_xsize != -1) {
		/*
		 * The record is fixed-size, so just define a macro.
		 */
		fprintf(header,
"\n\
#define sizeof_%s(p) %d\n\
\n\
#define clear_%s(p)\n",
			typename(typtr), typtr->type_xsize,
			typename(typtr));
	} else {
		/*
		 * There are some variable-size fields, so define functions.
		 */
		fprintf(support1,
"\n\
int\n\
sizeof_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tregister int size = %d;\n\
\n",
			typename(typtr), typename(typtr), fixed_size);
		for (p = typtr->type_list; p != NIL; p = cdr(p)) {
			bt = (struct type *) cdar(p);
			if (bt->type_xsize != -1)
				continue;
			ref = refstr(bt);
			q = caar(p);
			member = (char *) car(q);
			fprintf(support1,
"\tsize += sizeof_%s(%sp->%s);\n",
				typename(bt), ref, member);
		}
		fprintf(support1,
"\treturn (size);\n\
}\n"
			);
		fprintf(support1,
"\n\
int\n\
clear_%s(p)\n\
\tregister %s *p;\n\
{\n\
\n",
			typename(typtr), typename(typtr));
		for (p = typtr->type_list; p != NIL; p = cdr(p)) {
			bt = (struct type *) cdar(p);
			if (bt->type_xsize != -1)
				continue;
			ref = refstr(bt);
			q = caar(p);
			member = (char *) car(q);
			fprintf(support1,
"\tclear_%s(%sp->%s);\n",
				typename(bt), ref, member);
		}
		fprintf(support1, "}\n" );
	}
	/*
	 * Define translation functions.
	 */
	xfn_header(EXTERNALIZE, typtr, typtr);
	xfn_header(INTERNALIZE, typtr, typtr);
	format =
"{\n\
\tregister Unspecified *bp;\n\
\n\
\tbp = buf;\n";
	fprintf(support1, format);
	fprintf(support2, format);
	format =
"\tbp += %s(%sp->%s, bp);\n";
	for (p = typtr->type_list; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		ref = refstr(bt);
		q = caar(p);
		member = (char *) car(q);
		fprintf(support1, format,
			xfn(EXTERNALIZE, bt), ref, member);
		fprintf(support2, format,
			xfn(INTERNALIZE, bt), ref, member);
	}
	format =
"\treturn (bp - buf);\n\
}\n";
	fprintf(support1, format);
	fprintf(support2, format);
}

define_array_type(typtr)
	struct type *typtr;
{
	struct type *bt;
	int true_size;
	char *ref, *format;

	bt = typtr->type_basetype;
	/*
	 * Make sure the component type is defined and sized
	 */
	if (typename(bt) == NULL) {
		struct object *name;
		name = make_symbol(gensym("T_a"),CurrentProgram);
		define_type(name,bt);
	}
	ref = refstr(bt);
	true_size = typtr->type_size;
	if (bt->type_xsize != -1)
		typtr->type_xsize = true_size * bt->type_xsize;
	else
		typtr->type_xsize = -1;
	if (recursive_flag)
		return;
	/*
	 * Print a C definition for the array.
	 */
	fprintf(header, "\ntypedef %s %s[%d];\n",
		typename(bt), typename(typtr), true_size);
	/*
	 * Generate a sizeof and free functions for the array.
	 * The size is equal to the sum of the sizes of each element.
	 */
	if (bt->type_xsize != -1) {
		/*
		 * The element type, and hence the array, is fixed-size,
		 * so just define a macro.
		 */
		fprintf(header,
"\n\
#define sizeof_%s(p) %d\n\
\n\
#define clear_%s(p)\n",
			typename(typtr), typtr->type_xsize,
			typename(typtr));
	} else {
		/*
		 * The element type is variable-size, so define a function.
		 */
		fprintf(support1,
"\n\
int\n\
sizeof_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tregister int size = 0;\n\
\tregister int i;\n\
\n\
\tfor (i = 0; i < %d; i += 1)\n\
\t\tsize += sizeof_%s(%sp[i]);\n\
\treturn (size);\n\
}\n",
			typename(typtr), typename(bt), true_size,
			typename(bt), ref);
		fprintf(support1,
"\n\
clear_%s(p)\n\
\t%s *p;\n\
{\n\
\tregister int i;\n\
\n\
\tfor (i = 0; i < %d; i += 1)\n\
\t\tclear_%s(%sp[i]);\n\
}\n",
			typename(typtr), typename(bt), true_size,
			typename(bt), ref);
	}
	/*
	 * Define translation functions.
	 */
	xfn_header(EXTERNALIZE, typtr, bt);
	xfn_header(INTERNALIZE, typtr, bt);
	format =
"{\n\
\tregister Unspecified *bp;\n\
\tregister int i;\n\
\n\
\tbp = buf;\n\
\tfor (i = 0; i < %d; i += 1)\n\
\t\tbp += %s(%sp[i], bp);\n\
\treturn (bp - buf);\n\
}\n";
	fprintf(support1, format,
		true_size, xfn(EXTERNALIZE, bt), ref);
	fprintf(support2, format,
		true_size, xfn(INTERNALIZE, bt), ref);
}

define_sequence_type(typtr)
	struct type *typtr;
{
	struct type *bt;
	char *ref, *format;

	typtr->type_xsize = -1;
	bt = typtr->type_basetype;
	/*
	 * Make sure the component type is defined
	 */
	if (typename(bt) == NULL) {
		struct object *name;
		name = make_symbol(gensym("T_s"),CurrentProgram);
		define_type(name,bt);
	}
	if (recursive_flag)
		return;
	/*
	 * Print a C definition for the sequence.
	 */
	fprintf(header,
"\n\
typedef struct {\n\
\tCardinal length;\n\
\t%s *sequence;\n\
} %s;\n",
		typename(bt), typename(typtr));
	/*
	 * Generate sizeof and free functions for the sequence.
	 * The size is equal to 1 (for the length word)
	 * plus the sum of the sizes of each element.
	 */
	bt = typtr->type_basetype;
	ref = refstr(bt);
	if (bt->type_xsize != -1) {
		/*
		 * The element type is fixed-size, so just define a macro.
		 */
		fprintf(header,
"\n\
#define sizeof_%s(p) (1 + (p)->length * %d)\n",
			typename(typtr), bt->type_xsize);
		fprintf(support1,
"\n\
clear_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tDeallocate((Unspecified*) p->sequence);\n\
\tp->length = 0;  p->sequence = (%s*) 0;\n\
}\n",
			typename(typtr), typename(typtr),
			typename(bt) );
	} else {
		/*
		 * The element type is variable-size, so define a function.
		 */
		fprintf(support1,
"\n\
int\n\
sizeof_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tregister int size = 1;\n\
\tregister int i;\n\
\n\
\tif (p->sequence == (%s*) 0) return(size);\n\
\tfor (i = 0; i < p->length; i += 1)\n\
\t\tsize += sizeof_%s(%sp->sequence[i]);\n\
\treturn (size);\n\
}\n",
			typename(typtr), typename(typtr), typename(bt),
			typename(bt), ref);
		fprintf(support1,
"\n\
clear_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tregister int i;\n\
\n\
\tif (p->sequence != (%s*) 0) for (i = 0; i < p->length; i += 1)\n\
\t\tclear_%s(%sp->sequence[i]);\n\
\tDeallocate((Unspecified*) p->sequence);\n\
\tp->length = 0;  p->sequence = (%s*) 0;\n\
}\n",
			typename(typtr), typename(typtr), typename(bt),
			typename(bt), ref,
			typename(bt) );

	}
	/*
	 * Define translation functions.
	 */
	xfn_header(EXTERNALIZE, typtr, typtr);
	xfn_header(INTERNALIZE, typtr, typtr);
	/*
	 * The externalize function (trivially) checks its pointer
	 * for consistency.
	 */
	fprintf(support1,
"{\n\
\tregister Unspecified *bp;\n\
\tregister int i;\n\
\n\
\tif (p->sequence == (%s*)0) p->length = 0;\n\
\tbp = buf + %s(&p->length, buf);\n",
		typename(bt),
		xfn(EXTERNALIZE, Cardinal_type));
	/*
	 * The internalize function needs to allocate space
	 * for the sequence elements dynamically.
	 */
	fprintf(support2,
"{\n\
\tregister Unspecified *bp;\n\
\tregister int i;\n\
\n\
\tbp = buf + %s(&p->length, buf);\n\
\tp->sequence = (%s *)\n\
\t\tAllocate(p->length * sizeof(%s)/sizeof(Cardinal));\n",
		xfn(INTERNALIZE, Cardinal_type),
		typename(bt), typename(bt));
	format =
"\tfor (i = 0; i < p->length; i++)\n\
\t\tbp += %s(%sp->sequence[i], bp);\n\
\treturn (bp - buf);\n\
}\n";
	fprintf(support1, format, xfn(EXTERNALIZE, bt), ref);
	fprintf(support2, format, xfn(INTERNALIZE, bt), ref);
}

define_choice_type(typtr)
	struct type *typtr;
{
	struct type *designator, *bt;
	list p,q,candidates;
	char *format, *ref, *member;

	typtr->type_xsize = -1;

	designator = typtr->type_designator;
	candidates = typtr->type_candidates;
	if (! recursive_flag)
		fprintf(header,
"\n\
extern struct %s;\n\
typedef struct %s %s;\n",
			typename(typtr), typename(typtr), typename(typtr));
	/*
	 * Make sure each arm type is defined
	 */
	for (p = candidates; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		if (typename(bt) == NULL) {
			struct object *name;
			name = make_symbol(gensym("T_c"),CurrentProgram);
			define_type(name,bt);
		}
	}
	if (recursive_flag)
		return;
	/*
	 * Print a C definition for the choice.
	 * First, be prepared for recursive references of the SEQUENCE OF form
	 */
	fprintf(header,
"\n\
struct %s {\n\
\t%s designator;\n\
\tunion {\n",
		typename(typtr), typename(designator));
	for (p = candidates; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		for (q = caar(p); q != NIL; q = cdr(q)) {
			member = name_of(caar(q));
			fprintf(header,
"\t\t%s u_%s;\n\
#define %s_case u.u_%s\n",
				typename(bt), member,
				candidate_name(member), member);
		}
	}
	fprintf(header,
"\t} u;\n\
};\n" );
	/*
	 * Generate a sizeof function for the choice.
	 * The size is equal to 1 (for the designator word)
	 * plus the size of the corresponding candidate.
	 * We could check if all the candidates happen to be the same size,
	 * but we don't bother and always call it variable-size.
	 */
	fprintf(support1,
"\n\
int\n\
sizeof_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tregister int size = 1;\n\
\n\
\tswitch (p->designator) {\n",
		typename(typtr), typename(typtr));
	for (p = candidates; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		ref = refstr(bt);
		for (q = caar(p); q != NIL; q = cdr(q)) {
			member = name_of(caar(q));
			fprintf(support1,
"\t    case %s:\n\
\t\tsize += sizeof_%s(%sp->%s_case);\n\
\t\tbreak;\n",
				member, typename(bt), ref, 
				candidate_name(member));
		}
	}
	fprintf(support1,
"\t}\n\
\treturn (size);\n\
}\n"
		);
	/*
	 * Now generate the freeing function.  Here we do bother
	 * not to free constant-sized structures, just for kicks.
	 * However, we always generate a freeing function, even if
	 * all the arms of the choice are constant sized.
	 */
	fprintf(support1,
"\n\
clear_%s(p)\n\
\tregister %s *p;\n\
{\n\
\tswitch (p->designator) {\n",
		typename(typtr), typename(typtr));
	for (p = candidates; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		ref = refstr(bt);
		for (q = caar(p); q != NIL; q = cdr(q)) {
			member = name_of(caar(q));
			if (bt->type_xsize == -1)
				fprintf(support1,
"\t    case %s:\n\
\t\tbreak;\n",
					member);
			else
				fprintf(support1,
"\t    case %s:\n\
\t\tclear_%s(%sp->%s_case);\n\
\t\tbreak;\n",
					member, typename(bt), ref, 
					candidate_name(member));
		}
	}
	fprintf(support1,
"\t}\n\
}\n"
		);
	/*
	 * Define translation functions.
	 */
	xfn_header(EXTERNALIZE, typtr, typtr);
	xfn_header(INTERNALIZE, typtr, typtr);
	format =
"{\n\
\tregister Unspecified *bp;\n\
\n\
\tbp = buf + %s(&p->designator, buf);\n\
\tswitch (p->designator) {\n";
	fprintf(support1, format, xfn(EXTERNALIZE, designator));
	fprintf(support2, format, xfn(INTERNALIZE, designator));
	format =
"\t    case %s:\n\
\t\tbp += %s(%sp->%s_case, bp);\n\
\t\tbreak;\n";
	for (p = candidates; p != NIL; p = cdr(p)) {
		bt = (struct type *) cdar(p);
		ref = refstr(bt);
		for (q = caar(p); q != NIL; q = cdr(q)) {
			member = name_of(caar(q));
			fprintf(support1, format,
				member, xfn(EXTERNALIZE, bt),
				ref, candidate_name(member));
			fprintf(support2, format,
				member, xfn(INTERNALIZE, bt),
				ref, candidate_name(member));
		}
	}
	format =
"\t}\n\
\treturn (bp - buf);\n\
}\n";
	fprintf(support1, format);
	fprintf(support2, format);
}

/*
 * Generate a new full name of the form <module><version>_<name>
 */
char *
make_full_name(module,version,name)
	char *module;
	int version;
	char *name;
{
	char buf[MAXSTR];
	sprintf(buf,"%s%d_%s",module,version,name);
	return(copy(buf));
}

/*
 * Generate defininitions for named types
 * and their size and translation functions.
 * We assume that each type with a type_name field has already been
 * generated.
 */
define_type(name, typtr)
	struct object *name;
	struct type *typtr;
{
	char *fullname;
	/*
	 * create the symbol -- it has already been made via make_symbol()
	 * which, along with allocating an object, set o_name
	 */
	name->o_class = O_TYPE;
	name->o_type = typtr;
	fullname = make_full_name(name->o_module, name->o_modversion,
			name_of(name));
	code_type(fullname, typtr);
	if (!recursive_flag) {
		/* widen scope */
		fprintf(header1, "typedef %s %s;\n",
			fullname, name_of(name));
		copy_typefns(header1,name_of(name),fullname);
	}
}

/*
 * Actually generate some code.  This routine may be called recursively
 * if subtypes have no name.
 */
code_type(name, typtr)
	char *name;
	struct type *typtr;
{
	/*
	 * check for simple case of "foo: TYPE = bar;" rename
	 */
	if (typename(typtr) != NULL) {
		if (!recursive_flag) {
			/* create alias for typedef */
			fprintf(header,"typedef %s %s;\n",
				typename(typtr), name);
			copy_typefns(header,name, typename(typtr));
		}
		return;
	}
	/*
	 * general case:  "foo: TYPE = <type>;"
	 * actually generate some code
	 */
	switch (typtr->type_constr) {
	case C_PROCEDURE:
		/* no code gets generated for these Types */
		typename(typtr) = name;
		break;
	case C_NUMERIC:
	case C_BOOLEAN:
	case C_STRING:
		/* create alias for typedef */
		fprintf(header,"typedef %s %s;\n",
			typename(typtr), name);
		copy_typefns(header,name,typename(typtr));
		typename(typtr) = name;
		break;
	case C_ENUMERATION:
		typename(typtr) = name;
		define_enumeration_type(typtr);
		break;
	case C_ARRAY:
		typename(typtr) = name;
		define_array_type(typtr);
		break;
	case C_SEQUENCE:
		typename(typtr) = name;
		define_sequence_type(typtr);
		break;
	case C_RECORD:
		typename(typtr) = name;
		define_record_type(typtr);
		break;
	case C_CHOICE:
		typename(typtr) = name;
		define_choice_type(typtr);
		break;
	case C_ERROR:
		typename(typtr) = name;
		if (typtr->type_list != NIL)
			define_record_type(typtr);
		break;
	}
	return;
}