/*
 * Copyright (c) 2002, The Tendra Project <http://www.ten15.org/>
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice unmodified, this list of conditions, and the following
 *    disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
 * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 *
 *    		 Crown Copyright (c) 1997
 *
 *    This TenDRA(r) Computer Program is subject to Copyright
 *    owned by the United Kingdom Secretary of State for Defence
 *    acting through the Defence Evaluation and Research Agency
 *    (DERA).  It is made available to Recipients with a
 *    royalty-free licence for its use, reproduction, transfer
 *    to other parties and amendment for any purpose not excluding
 *    product development provided that any such use et cetera
 *    shall be deemed to be acceptance of the following conditions:-
 *
 *        (1) Its Recipients shall ensure that this Notice is
 *        reproduced upon any copies or amended versions of it;
 *
 *        (2) Any amended version of it shall be clearly marked to
 *        show both the nature of and the organisation responsible
 *        for the relevant amendment or amendments;
 *
 *        (3) Its onward transfer from a recipient to another
 *        party shall be deemed to be that party's acceptance of
 *        these conditions;
 *
 *        (4) DERA gives no warranty or assurance as to its
 *        quality or suitability for any purpose and DERA accepts
 *        no liability whatsoever in relation to any use to which
 *        it may be put.
 *
 * $TenDRA: tendra/src/utilities/calculus/token.c,v 1.9 2004/08/09 14:55:01 bp Exp $
 */


#include "config.h"
#include "calculus.h"
#include "code.h"
#include "common.h"
#include "lex.h"
#include "output.h"
#include "suffix.h"
#include "token.h"
#include "type_ops.h"


/*
 *    PRINT SIMPLE TOKENS
 *
 *    This routine prints the simple tokens for a type named nm with short
 *    name ns.  e is true for simply dereferenced types.
 */

static void
print_simple_tok(char *nm, char *ns, int e,
				 int lst)
{
    /* SIZE token */
    output ("%pt %xc : SIZE (%e) : SIZE_%e #\n\n", nm, ns);

    /* Assign token */
    output ("%pt PROC (\\\n");
    output ("\t%xr : PTR (%e) :,\\\n\t%xr : %e :\\\n   ) ", nm, nm);
    output (e ? "%xr : void :" : "STATEMENT");
    output (" COPY_%e #\n\n", ns);

    /* Dereference token */
    output ("%pt PROC (\\\n");
    output ("\t%xr : PTR (%e) :", nm);
    if (e) {
		output ("\\\n   ) %xr : %e :", nm);
    } else {
		output (",\\\n\t%xl : %e :\\\n   ) STATEMENT", nm);
    }
    output (" DEREF_%e #\n\n", ns);

    if (lst) {
		/* CONS token */
		output ("%pt PROC (\\\n");
		output ("\t%xr : %e :,\\\n\t%xr : LIST (%e) :,\\\n", nm, nm);
		output ("\t%xl : LIST (%e) :\\\n", nm);
		output ("   ) STATEMENT CONS_%e #\n\n", ns);

		/* UN_CONS token */
		output ("%pt PROC (\\\n");
		output ("\t%xl : %e :,\\\n", nm);
		output ("\t%xl : LIST (%e) :,\\\n", nm);
		output ("\t%xr : LIST (%e) :\\\n", nm);
		output ("   ) STATEMENT UN_CONS_%e #\n\n", ns);

		/* DESTROY_CONS token */
		output ("%pt PROC (\\\n");
		output ("\t%xr : DESTROYER :,\\\n\t%xl : %e :,\\\n", nm);
		output ("\t%xl : LIST (%e) :,\\\n", nm);
		output ("\t%xr : LIST (%e) :\\\n", nm);
		output ("   ) STATEMENT DESTROY_CONS_%e #\n\n", ns);

		if (allow_stack) {
			/* PUSH token */
			output ("%pt PROC (\\\n");
			output ("\t%xr : %e :,\\\n", nm);
			output ("\t%xl : STACK (%e) :\\\n", nm);
			output ("   ) STATEMENT PUSH_%e #\n\n", ns);

			/* POP token */
			output ("%pt PROC (\\\n");
			output ("\t%xl : %e :,\\\n", nm);
			output ("\t%xl : STACK (%e) :\\\n", nm);
			output ("   ) STATEMENT POP_%e #\n\n", ns);
		}
    }

    /* Interface commands */
    output ("%pi SIZE_%e COPY_%e DEREF_%e\n", ns, ns, ns);
    if (lst) {
		output ("%pi CONS_%e UN_CONS_%e DESTROY_CONS_%e\n", ns, ns, ns);
		if (allow_stack) output ("%pi PUSH_%e POP_%e\n", ns, ns);
    }
    output ("\n\n");
    return;
}


/*
 *    PRINT SIMPLE TOKENS FOR TYPE OPERATIONS
 *
 *    This routine prints the simple tokens for the type operation op.
 *    The tokens are named using nm.  e is true for simply dereferenced types.
 */

static void
print_type_ops_tok(char *op, char *nm, int e)
{
    /* Size token */
    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xc : SIZE (%s (t)) : SIZE_%s #\n\n", op, nm);

    /* Assign token */
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (%s (t)) : e1,\\\n", op);
    output ("\t%xr : %s (t) : e2 |\\\n", op);
    output ("\tEXP e1, EXP e2\\\n    } ");
    output (e ? "%xr : void :" : "STATEMENT");
    output (" COPY_%s #\n\n", nm);

    /* Dereference token */
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (%s (t)) : e", op);
    if (e) {
		output (" |\\\n\tEXP e\\\n");
		output ("    } %xr : %s (t) : ", op);
    } else {
		output ("1,\\\n\t%xl : %s (t) : e2 |\\\n", op);
		output ("\tEXP e1, EXP e2\\\n");
		output ("    } STATEMENT ");
    }
    output ("DEREF_%s #\n\n", nm);

    /* CONS token */
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : %s (t) : e2,\\\n", op);
    output ("\t%xr : LIST (%s (t)) : e3,\\\n", op);
    output ("\t%xl : LIST (%s (t)) : e4 |\\\n", op);
    output ("\tEXP e2, EXP e3, EXP e4\\\n");
    output ("    } STATEMENT CONS_%s #\n\n", nm);

    /* UN_CONS token */
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xl : %s (t) : e2,\\\n", op);
    output ("\t%xl : LIST (%s (t)) : e3,\\\n", op);
    output ("\t%xr : LIST (%s (t)) : e4 |\\\n", op);
    output ("\tEXP e2, EXP e3, EXP e4\\\n");
    output ("    } STATEMENT UN_CONS_%s #\n\n", nm);

    /* DESTROY_CONS token */
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : DESTROYER : e1,\\\n");
    output ("\t%xl : %s (t) : e2,\\\n", op);
    output ("\t%xl : LIST (%s (t)) : e3,\\\n", op);
    output ("\t%xr : LIST (%s (t)) : e4 |\\\n", op);
    output ("\tEXP e1, EXP e2, EXP e3, EXP e4\\\n");
    output ("    } STATEMENT DESTROY_CONS_%s #\n\n", nm);

    if (allow_stack) {
		/* PUSH token */
		output ("%pt PROC {\\\n");
		output ("\tTYPE t, %xr : %s (t) : e2,\\\n", op);
		output ("\t%xl : STACK (%s (t)) : e3 |\\\n", op);
		output ("\tEXP e2, EXP e3\\\n");
		output ("    } STATEMENT PUSH_%s #\n\n", nm);

		/* POP token */
		output ("%pt PROC {\\\n");
		output ("\tTYPE t, %xl : %s (t) : e2,\\\n", op);
		output ("\t%xl : STACK (%s (t)) : e3 |\\\n", op);
		output ("\tEXP e2, EXP e3\\\n");
		output ("    } STATEMENT POP_%s #\n\n", nm);
    }

    /* Interface commands */
    output ("%pi SIZE_%s COPY_%s DEREF_%s\n", nm, nm, nm);
    output ("%pi CONS_%s UN_CONS_%s DESTROY_CONS_%s\n", nm, nm, nm);
    if (allow_stack) output ("%pi PUSH_%s POP_%s\n", nm, nm);
    output ("\n\n");
    return;
}


/*
 *    PRINT BASIC TYPES (TOKEN VERSION)
 *
 *    This routine prints the token versions of the basic type definitions.
 */

static void
print_types_tok(void)
{
    comment ("Primitive types");
    LOOP_PRIMITIVE {
		CLASS_ID_P c = DEREF_ptr (prim_id (CRT_PRIMITIVE));
		char *pn = DEREF_string (cid_name (c));
		char *pd = DEREF_string (prim_defn (CRT_PRIMITIVE));
		if (!streq (pn, pd)) output ("typedef %PD %PN ;\n");
    }
    output ("\n\n");

    comment ("Basic types");
    output ("#ifndef %X_DESTR_DEFINED\n");
    output ("#define\t%X_DESTR_DEFINED\n");
    output ("typedef void (*DESTROYER) () ;\n");
    output ("#endif\n\n");
    output ("%pt PROC (TYPE) TYPE PTR #\n");
    output ("%pt PROC (TYPE) TYPE LIST #\n");
    if (allow_stack) {
		output ("%pt PROC (TYPE) TYPE STACK #\n");
    }
    if (allow_vec) {
		output ("%pt VARIETY %X_dim #\n");
		output ("%pt PROC (TYPE) TYPE VEC #\n");
		output ("%pt PROC (TYPE) TYPE VEC_PTR #\n");
    }
    output ("%pt PROC (TYPE) TYPE SIZE #\n\n");
    output ("%pi PTR LIST ");
    if (allow_stack) output ("STACK ");
    if (allow_vec) output ("%X_dim VEC VEC_PTR ");
    output ("SIZE\n\n\n");

    comment ("Enumeration type definitions");
    LOOP_ENUM {
		output ("%pt VARIETY %EN #\n");
		output ("%pi %EN\n");
    }
    output ("\n\n");

    comment ("Union type definitions");
    LOOP_UNION {
		output ("%pt TYPE %UN #\n");
		output ("%pi %UN\n");
    }
    output ("\n\n");

    print_struct_defn ();

    comment ("Function declarations");
    output ("extern void destroy_%X () ;\n");
    output ("extern void dummy_destroy_%X () ;\n");
    output ("#ifdef %X_IO_ROUTINES\n");
    output ("extern unsigned crt_%X_alias ;\n");
    output ("extern void clear_%X_alias(void)  ;\n");
    output ("#endif\n");
    output ("\n\n");
    return;
}


/*
 *    PRINT POINTER CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the pointer constructs.
 */

static void
print_ptr_tok(void)
{
    comment ("Pointer token specifications");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (t) : e1, %xr : SIZE (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } %xr : PTR (t) : STEP_ptr #\n\n");

    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xc : PTR (t) : NULL_ptr #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : int : IS_NULL_ptr #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (t) : e1, %xr : PTR (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } %xr : int : EQ_ptr #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : SIZE (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : PTR (t) : MAKE_ptr #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (t) : e1, %xr : SIZE (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } %xr : void : DESTROY_ptr #\n\n");

    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xr : PTR (t) : UNIQ_ptr #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : void : DESTROY_UNIQ_ptr #\n\n");

    output ("%pi STEP_ptr NULL_ptr IS_NULL_ptr EQ_ptr\n");
    output ("%pi MAKE_ptr DESTROY_ptr\n\n");

    output ("#ifdef %X_IO_ROUTINES\n");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : void * : VOIDSTAR_ptr #\n");
    output ("%pi VOIDSTAR_ptr\n");
    output ("#endif\n\n");

    print_type_ops_tok ("PTR", "ptr", 1);
    return;
}


/*
 *    PRINT LIST CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the list constructs.
 */

static void
print_list_tok(void)
{
    comment ("List token specifications");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : PTR (t) : HEAD_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : PTR (LIST (t)) : PTR_TAIL_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : LIST (t) : TAIL_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1 |\\\n");
    output ("\tEXP e1\\\n");
    output ("    } %xr : unsigned : LENGTH_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1 |\\\n");
    output ("\tEXP e1\\\n");
    output ("    } %xr : LIST (t) : END_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1 |\\\n");
    output ("\tEXP e1\\\n");
    output ("    } %xr : LIST (t) : REVERSE_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1, %xr : LIST (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } %xr : LIST (t) : APPEND_list #\n\n");

    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xc : LIST (t) : NULL_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : int : IS_NULL_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1, %xr : LIST (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } %xr : int : EQ_list #\n\n");

    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xr : LIST (t) : UNIQ_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : void : DESTROY_UNIQ_list #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1, %xr : SIZE (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } STATEMENT DESTROY_list #\n\n");

    output ("%pi HEAD_list PTR_TAIL_list TAIL_list\n");
    output ("%pi LENGTH_list END_list REVERSE_list APPEND_list\n");
    output ("%pi NULL_list IS_NULL_list EQ_list\n");
    output ("%pi UNIQ_list DESTROY_UNIQ_list DESTROY_list\n\n");

    output ("#ifdef %X_IO_ROUTINES\n");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : void * : VOIDSTAR_list #\n");
    output ("%pi VOIDSTAR_list\n");
    output ("#endif\n\n");

    print_type_ops_tok ("LIST", "list", 1);
    return;
}


/*
 *    PRINT STACK CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the stack constructs.
 */

static void
print_stack_tok(void)
{
    comment ("Stack token specifications");
    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xc : STACK (t) : NULL_stack #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : STACK (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : int : IS_NULL_stack #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : STACK (t) : e1 |\\\n");
    output ("\tEXP e1\\\n");
    output ("    } %xr : LIST (t) : LIST_stack #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : LIST (t) : e1 |\\\n");
    output ("\tEXP e1\\\n");
    output ("    } %xr : STACK (t) : STACK_list #\n\n");

    output ("%pi NULL_stack IS_NULL_stack LIST_stack STACK_list\n\n");

    print_type_ops_tok ("STACK", "stack", 1);
    return;
}


/*
 *    PRINT VECTOR CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the vector constructs.
 */

static void
print_vec_tok(void)
{
    comment ("Vector token specifications");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : VEC (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : %X_dim : DIM_vec #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (VEC (t)) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : PTR (t) : PTR_ptr_vec #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : PTR (VEC (t)) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : %X_dim : DIM_ptr_vec #\n\n");

    output ("%pt PROC (\\\n\tTYPE t\\\n");
    output ("   ) %xr : VEC (t) : NULL_vec #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : SIZE (t) : e1,\\\n");
    output ("\t%xr : %X_dim : e2,\\\n");
    output ("\t%xl : VEC (t) : e3 |\\\n");
    output ("\tEXP e1, EXP e2, EXP e3\\\n");
    output ("    } STATEMENT MAKE_vec #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : VEC (t) : e1, %xr : SIZE (t) : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } STATEMENT DESTROY_vec #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : VEC (t) : e1,\\\n");
    output ("\t%xr : SIZE (t) : e2, %xr : int : e3,\\\n");
    output ("\t%xr : int : e4, %xl : VEC (t) : e5 |\\\n");
    output ("\tEXP e1, EXP e2, EXP e3, EXP e4, EXP e5\\\n");
    output ("    } STATEMENT TRIM_vec #\n\n");

    output ("%pi DIM_vec PTR_ptr_vec DIM_ptr_vec\n");
    output ("%pi NULL_vec MAKE_vec DESTROY_vec TRIM_vec\n\n");
    print_type_ops_tok ("VEC", "vec", 0);
    return;
}


/*
 *    PRINT VECTOR POINTER CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the vector pointer
 *    constructs.
 */

static void
print_vec_ptr_tok(void)
{
    comment ("Vector pointer token specifications");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : VEC (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : VEC_PTR (t) : VEC_PTR_vec #\n\n");

    output ("%pt PROC {\\\n");
    output ("\tTYPE t, %xr : VEC_PTR (t) : e |\\\n");
    output ("\tEXP e\\\n");
    output ("    } %xr : PTR (t) : PTR_vec_ptr #\n\n");

    output ("%pi VEC_PTR_vec PTR_vec_ptr\n\n");
    print_type_ops_tok ("VEC_PTR", "vec_ptr", 0);
    return;
}


/*
 *    PRINT SIZE CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the size constructs.
 */

static void
print_size_tok(void)
{
    comment ("Size token specifications");
    output ("%pt PROC {\\\n");
    output ("\tTYPE t, VARIETY v,\\\n");
    output ("\t%xr : SIZE (t) : e1, %xr : v : e2 |\\\n");
    output ("\tEXP e1, EXP e2\\\n");
    output ("    } %xr : SIZE (t) : SCALE #\n\n");
    output ("%pi SCALE\n\n\n");
    return;
}


/*
 *    PRINT PRIMITIVE CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the primitive constructs.
 */

static void
print_prim_tok(void)
{
    comment ("Definitions for primitive %PN");
    print_simple_tok ("%PN", "%PM", 1, 1);
    return;
}


/*
 *    PRINT ENUMERATION CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the enumeration constructs.
 */

static void
print_enum_tok(void)
{
    int lst = DEREF_int (en_lists (CRT_ENUM));
    comment ("Definitions for enumeration %EN");
    print_enum_consts ();
    print_simple_tok ("%EN", "%EM", 1, lst);
    return;
}


/*
 *    PRINT STRUCTURE CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the structure constructs.
 */

static void
print_struct_tok(void)
{
    STRUCTURE_P base = DEREF_ptr (str_base (CRT_STRUCTURE));

    comment ("Definitions for structure %SN");
    LOOP_STRUCTURE_COMPONENT {
		output ("%pt PROC (%xr : PTR (%SN) :) ");
		output ("%xr : PTR (%CT) : %SM_%CN #\n");
		output ("%pi %SM_%CN\n\n");
    }
    output ("%pt PROC (\\\n");
    LOOP_STRUCTURE_COMPONENT {
		string v = DEREF_string (cmp_value (CRT_COMPONENT));
		if (v == NULL) output ("\t%xr : %CT :,\\\n");
    }
    output ("\t%xr : PTR (%SN) :\\\n");
    output ("   ) STATEMENT MAKE_%SM #\n");
    output ("%pi MAKE_%SM\n\n");

    if (!IS_NULL_ptr (base)) {
		CLASS_ID_P id = DEREF_ptr (str_id (base));
		char *nt = DEREF_string (cid_name (id));
		char *nm = DEREF_string (cid_name_aux (id));
		output ("%pt PROC (\\\n");
		output ("\t%xr : PTR (%SN) :\\\n");
		output ("   ) %xr : PTR (%s) : CONVERT_%SM_%s #\n", nt, nm);
		output ("%pi CONVERT_%SM_%s\n\n", nm);
    }

    print_simple_tok ("%SN", "%SM", 0, 1);
    return;
}


/*
 *    PRINT UNION CONSTRUCTS (TOKEN VERSION)
 *
 *    This routine prints the token versions of the union constructs.
 */

static void
print_union_tok(void)
{
    UNION_P base = DEREF_ptr (un_base (CRT_UNION));

    comment ("Definitions for union %UN");
    output ("#defineORDER_%UM ((unsigned) %UO)\n");
    output ("%pt %xc : %UN : NULL_%UM #\n");
    output ("%pt PROC (%xr : %UN :) %xr : int : IS_NULL_%UM #\n");
    output ("%pt PROC (%xr : %UN :, %xr : %UN :) ");
    output ("%xr : int : EQ_%UM #\n");
    output ("%pi NULL_%UM IS_NULL_%UM EQ_%UM\n\n");

    if (!IS_NULL_ptr (base)) {
		CLASS_ID_P id = DEREF_ptr (un_id (base));
		char *nt = DEREF_string (cid_name (id));
		char *nm = DEREF_string (cid_name_aux (id));
		output ("%pt PROC (%xr : %UN :) %xr : %s : CONVERT_%UM_%s #\n",
				nt, nm);
		output ("%pi CONVERT_%UM_%s\n\n", nm);
    }

    print_simple_tok ("%UN", "%UM", 1, 1);
    return;
}


/*
 *    PRINT THE MAIN TOKEN OUTPUT FILE
 *
 *    This routine prints the token specifications for the objects above.
 */

static void
print_main_tok(char *dir)
{
    open_file (dir, MAIN_PREFIX, MAIN_SUFFIX);
    if (extra_headers) {
		output ("#include \"%s_bscs.h\"\n\n", MAIN_PREFIX);
    }
    output ("#ifndef %X_NAME\n");
    output ("#define\t%X_NAME%t40\"%X\"\n");
    output ("#define\t%X_VERSION%t40\"%V\"\n");
    output ("#define\t%X_SPECIFICATION%t40%d\n", 1);
    output ("#define\t%X_IMPLEMENTATION%t40%d\n", 0);
    output ("#endif\n\n\n");

    print_types_tok ();
    print_ptr_tok ();
    print_list_tok ();
    if (allow_stack) {
		print_stack_tok ();
    }
    if (allow_vec) {
		print_vec_tok ();
		print_vec_ptr_tok ();
    }
    print_size_tok ();

    LOOP_PRIMITIVE print_prim_tok ();
    LOOP_ENUM print_enum_tok ();
    LOOP_STRUCTURE print_struct_tok ();
    LOOP_UNION print_union_tok ();

    if (extra_headers) {
		output ("#include \"%s_term.h\"\n\n", MAIN_PREFIX);
    }
    close_file ();
    return;
}



/*
 *    PRINT ARGUMENTS FOR A TOKENISED UNION CONSTRUCTOR
 *
 *    This routine prints the list of arguments for a tokenised union
 *    constructor and similar functions.  lv is true if all the arguments
 *    are lvalues.
 */

static void
print_cons_tok_args(int lv, int d)
{
    char *a = "%xr";
    char *b = "%xl";
    if (lv) {
		char *c = a;
		a = b;
		b = c;
    }
    LOOP_UNION_COMPONENT {
		string v = DEREF_string (cmp_value (CRT_COMPONENT));
		if (v == NULL || d == 0) output ("\\\n\t%e : %CT :,", a);
    }
    LOOP_FIELD_COMPONENT {
		string v = DEREF_string (cmp_value (CRT_COMPONENT));
		if (v == NULL || d == 0) output ("\\\n\t%e : %CT :,", a);
    }
    output ("\\\n\t%e : %UN :", b);
    return;
}


/*
 *    PRINT FIELD SELECTOR OPERATIONS
 *
 *    This routine prints the operations on field selectors (token version).
 *    rng gives the number of elements in the field set (if appropriate).
 *    al is true if the field is aliased.
 */

static void
print_field_tok(int rng, int al)
{
    char *f = (rng ? "%FN_etc" : "%FN");

    LOOP_FIELD_COMPONENT {
		output ("%pt PROC (%xr : %UN :)\\\n");
		output ("    %xr : PTR (%CT) : ");
		output ("%UM_%e_%CN #\n", f);
		output ("%pi %UM_%e_%CN\n\n", f);
    }

    /* Component constructor */
    output ("%pt PROC (");
    if (rng) output ("\\\n\t%xr : unsigned :,");
    print_cons_tok_args (0, 1);
    output ("\\\n   ) STATEMENT MAKE_%UM_%e #\n", f);
    output ("%pi MAKE_%UM_%e\n\n", f);

    /* Tag modifier */
    if (rng) {
		output ("%pt PROC (");
		output ("\\\n\t%xr : unsigned :,");
		output ("\\\n\t%xr : %UN :");
		output ("\\\n   ) STATEMENT MODIFY_%UM_%e #\n", f);
		output ("%pi MODIFY_%UM_%e\n\n", f);
    }

    /* Component deconstructor */
    if (field_not_empty ()) {
		output ("%pt PROC (");
		print_cons_tok_args (1, 0);
		output ("\\\n   ) STATEMENT DECONS_%UM_%e #\n", f);
		output ("%pi DECONS_%UM_%e\n\n", f);
    }

    /* Component destructor */
    output ("%pt PROC (");
    output ("\\\n\t%xr : DESTROYER :,");
    print_cons_tok_args (1, 0);
    output ("\\\n   ) STATEMENT DESTROY_%UM_%e #\n", f);
    output ("%pi DESTROY_%UM_%e\n\n", f);

    /* Aliasing tokens */
    if (al && !rng) {
		output ("#ifdef %X_IO_ROUTINES\n\n");
		output ("%pt PROC (\\\n");
		output ("\t%xl : %UN :,\\\n");
		output ("\t%xr : unsigned :\\\n");
		output ("   ) STATEMENT NEW_ALIAS_%UM_%FN #\n");
		output ("%pi NEW_ALIAS_%UM_%FN\n\n");

		output ("%pt PROC (%xr : %UN :)\\\n    ");
		output ("%xr : unsigned : GET_ALIAS_%UM_%FN #\n");
		output ("%pt PROC (%xr : %UN :, %xr : unsigned :)\\\n    ");
		output ("%xr : void : SET_ALIAS_%UM_%FN #\n");
		output ("%pt PROC (%xr : unsigned :)\\\n    ");
		output ("%xr : %UN : FIND_ALIAS_%UM_%FN #\n\n");
		output ("%pi GET_ALIAS_%UM_%FN SET_ALIAS_%UM_%FN ");
		output ("FIND_ALIAS_%UM_%FN\n\n");
		output ("#endif\n\n");
    }
    output ("\n");
    return;
}


/*
 *    PRINT THE UNION OPERATIONS OUTPUT FILE
 *
 *    For each union in the calculus there is an operations file.
 */

static void
print_union_ops_tok(char *dir, char *un)
{
    open_file (dir, un, OPS_SUFFIX);
    if (extra_headers) {
		output ("#include \"%s%s\"\n", MAIN_PREFIX, MAIN_SUFFIX);
		output ("#include <%s_ops.h>\n\n", MAIN_PREFIX);
    }

    comment ("Operations for union %UN");
    output ("%pt PROC (%xr : %UN :) %xr : unsigned : TAG_%UM #\n");
    output ("%pi TAG_%UM\n\n\n");

    /* Operations on common components */
    LOOP_UNION_COMPONENT {
		comment ("Operations for component %CN of union %UN");
		output ("%pt PROC (%xr : %UN :)\\\n");
		output ("    %xr : PTR (%CT) : %UM_%CN #\n");
		output ("%pi %UM_%CN\n\n");
    }

    /* Operations on field components */
    LOOP_UNION_FIELD {
		int rng = DEREF_int (fld_set (CRT_FIELD));
		int hash = DEREF_int (fld_flag (CRT_FIELD));
		int al = (hash ? 1 : 0);
		if (rng) {
			comment ("Operations for field set %FN_etc of union %UN");
			output ("%pt %xc : unsigned : %UM_%FN_etc_tag #\n");
			output ("%pt PROC (%xr : %UN :) ");
			output ("%xr : int : IS_%UM_%FN_etc #\n");
			output ("%pi %UM_%FN_etc_tag IS_%UM_%FN_etc\n\n");
			print_field_tok (rng, al);
		}

		comment ("Operations for field %FN of union %UN");
		output ("%pt %xc : unsigned : %UM_%FN_tag #\n");
		output ("%pt PROC (%xr : %UN :) %xr : int : IS_%UM_%FN #\n");
		output ("%pi %UM_%FN_tag IS_%UM_%FN\n\n");
		print_field_tok (0, al);
    }

    /* Map tables */
    LOOP_UNION_MAP {
		int hash = DEREF_int (map_flag (CRT_MAP));
		comment ("Map %MN on union %UN");
		output ("%pt PROC (\\\n");
		output ("\t%xr : %UN :");
		if (hash) output (",\\\n\t%xr : DESTROYER :");
		LOOP_MAP_ARGUMENT output (",\\\n\t%xr : %AT :");
		output ("\\\n   ) %xr : %MR : %MN_%UM #\n ");
		output ("%pi %MN_%UM\n\n\n");
    }

    /* End of file */
    close_file ();
    return;
}


/*
 *    MAIN ACTION (TOKEN VERSION)
 *
 *    This routine prints all the output files for the calculus (token
 *    version).
 */

void
main_action_tok(char *dir)
{
    int ign = 0;
    output_c_code = 2;
    print_main_tok (dir);

    LOOP_UNION {
		LIST (MAP_P) maps;
		CLASS_ID_P cid = DEREF_ptr (un_id (CRT_UNION));
		char *un = DEREF_string (cid_name_aux (cid));
		print_union_ops_tok (dir, un);
		maps = DEREF_list (un_map (CRT_UNION));
		if (!IS_NULL_list (maps)) {
			print_union_map_c (dir, un);
			print_union_hdr_c (dir, un);
			ign = 1;
        }
    }

    if (ign) {
		open_file (dir, IGNORE_PREFIX, DEF_SUFFIX);
		comment ("Map ignore macros");
		LOOP_UNION {
			LOOP_UNION_MAP output ("#define\tIGNORE_%MN_%UM%t40%d\n", 1);
		}
		output ("\n");
		close_file ();
    }

    if (extra_asserts) {
		open_file (dir, ASSERT_PREFIX, DEF_SUFFIX);
		comment ("Dummy assertion function definitions");
		close_file ();
    }
    return;
}
