fixed a syntax error introduced by 210eea23

.//============================================================================
.// $RCSfile: q.class.pei.arc,v $
.//
.// Description:
.// This archetype file contains the functions for generating
.// preexisting instances initialization code.
.//
.// Notice:
.// (C) Copyright 1998-2013 Mentor Graphics Corporation
.//     All rights reserved.
.//
.// This document contains confidential and proprietary information and
.// property of Mentor Graphics Corp.  No part of this document may be
.// reproduced without the express written permission of Mentor Graphics Corp.
.//============================================================================
.//
.//
.//============================================================================
.// Initialize the instance subsystem.
.// Update the instance and link records with array index values
.// and container counts.
.// The mapping of the instances to a particular array index is
.// arbitrary.
.//============================================================================
.function PEIInstanceSubsystemInit
  .param inst_ref_set o_objs
  .//
  .for each o_obj in o_objs
    .select many i_inss related by o_obj->CSME_CIE[R2961]->I_INS[R2962]
    .// Check for preexisting instance population requirement.
    .// The class must have instances and also be colored.
    .assign i = cardinality i_inss
    .select one te_class related by o_obj->TE_CLASS[R2019]
    .if ( ( i > 0 ) and ( te_class.PEIsDefinedInData ) )
      .assign te_class.PEIsDefinedInData = TRUE
    .else
      .assign te_class.PEIsDefinedInData = FALSE
    .end if
    .//
    .assign i = 0
    .for each i_ins in i_inss
      .assign i_ins.Name = "${i}"
      .assign i = i + 1
    .end for
  .end for
.end function
.//
.//
.//============================================================================
.// Count the preexisting instances of the given type.
.// Return the number of preexisting instances for obj.
.//============================================================================
.function PEINumberOfPreexistingInstances
  .param inst_ref o_obj
  .select many i_inss related by o_obj->CSME_CIE[R2961]->I_INS[R2962]
  .assign attr_result = cardinality i_inss
  .// .assign msg =       "PEINumberOfPreexistingInstances is ${attr_result} "
  .// .assign msg = msg + "for ${o_obj.Name} (${o_obj.Key_Lett})"
  .// .print "${msg}"
.end function
.//
.//
.//=============================================================================
.// Generate initializers for preexisting instances.
.// We generate the initializers in array index order.  C initializers
.// will assume sequential ordering.
.//=============================================================================
.function PEIRenderInitializers
  .param inst_ref o_obj
  .assign attr_assset = ""
  .select any te_set from instances of TE_SET
  .select one te_class related by o_obj->TE_CLASS[R2019]
  .if ( te_class.PEIsDefinedInData )
    .assign inst_count = 0
    .select many i_inss related by o_obj->CSME_CIE[R2961]->I_INS[R2962]
    .assign i_inss_cardinality = cardinality i_inss
    .while ( inst_count < i_inss_cardinality )
      .for each i_ins in i_inss
        .if ( i_ins.Name == "$t{inst_count}" )
          .invoke initializercode = PEIRenderInitializerBody( i_ins, o_obj )
          .assign attr_assset = attr_assset + initializercode.assset
  { ${initializercode.result} }\
          .if ( last i_inss )

          .else
,
          .end if
          .break for
        .end if
      .end for
      .assign inst_count = inst_count + 1
    .end while .// inst_count
    .// If there is a need for relationship set containers, build them up.
    .if ( attr_assset != "" )
      .invoke rel_set_name = PEIGetRelationshipSetContainerName( te_class )
      .assign attr_assset = "static ${te_set.element_type} ${rel_set_name.result}[] = {\n" + attr_assset
      .assign attr_assset = "/* PEI relationship set containers.  */\n" + attr_assset
      .assign attr_assset = attr_assset + "\n};\n"
    .end if
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate body of one preexisting instance initializer.
.// First, the initial state initializer is output.
.// The class instance attribute data variable values are generated
.// in the same order in which they appear in the application analysis OIM.
.// The relationship optimization initializers are then generated.
.//=============================================================================
.function PEIRenderInitializerBody
  .param inst_ref i_ins
  .param inst_ref o_obj
  .assign attr_result = ""
  .assign attr_assset = ""
  .//
  .// Generate state machine state (if needed).
  .//
  .invoke cs_init = PEIRenderInitializerBodyCurrentState( i_ins, o_obj )
  .assign attr_result = attr_result + cs_init.result
  .if ( "" != attr_result )
    .assign attr_result = attr_result + ", "
  .end if
  .//
  .// Generate the attribute value initializers.
  .//
  .select any te_attr related by o_obj->TE_CLASS[R2019]->TE_ATTR[R2061] where ( selected.prevID == 0 )
  .if ( not_empty te_attr )
    .select one o_attr related by te_attr->O_ATTR[R2033]
    .while ( not_empty te_attr )
      .if ( te_attr.translate )
        .select any i_avl related by i_ins->I_AVL[R2909] where ( selected.Attr_ID == o_attr.Attr_ID )
        .invoke avlcode = PEIRenderInitializerBodyAttribute( o_attr, i_avl )
        .assign attr_result = attr_result + avlcode.result
      .end if
      .//
      .// Advance to the next object attribute, if any.
      .select one te_attr related by te_attr->TE_ATTR[R2087.'succeeds']
      .//
      .// Generate comma separator.
      .if ( not_empty te_attr )
        .if ( te_attr.translate )
          .assign attr_result = attr_result + ", "
        .end if
      .end if
    .end while
  .end if
  .//
  .// Generate the association linkage (if needed).
  .//
  .invoke ass_init = PEIRenderInitializerBodyAssociation( i_ins, o_obj )
  .assign attr_result = attr_result + ass_init.result
  .assign attr_assset = attr_assset + ass_init.assset
  .//
.end function
.//
.//
.//=============================================================================
.// Generate initialization for a single attribute value.
.// Return the value as a string quoted correctly (if needed).
.//=============================================================================
.function PEIRenderInitializerBodyAttribute
  .param inst_ref o_attr
  .param inst_ref i_avl
  .assign attr_result = "0"
  .// Get the attribute data type.  Strings need to be quoted.
  .invoke r = GetAttributeCodeGenType( o_attr )
  .assign te_dt = r.result
  .if ( 4 == te_dt.Core_Typ )
    .// string
    .if ( empty i_avl )
      .// In absence of a populated attribute, use the attribute default value.
      .if ( "" != o_attr.DefaultValue )
        .assign attr_result = o_attr.DefaultValue
      .else
        .assign attr_result = """"""
      .end if
    .else
      .assign attr_result = """${i_avl.Value}"""
    .end if
  .else
    .if ( empty i_avl )
      .assign attr_result = "0"
    .else
      .assign attr_result = i_avl.Value
    .end if
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate the optimized association linkage for this instance.
.// Select the relationship set for this object.  Loop through each one
.// generating linkage anywhere storage is provided (for pointer refs).
.// Get the multiplicity so we know whether we need sets or simple
.// pointers.
.// Do the right thing for each flavor of association, simple, reflexive,
.// associative and sub/super.
.// Return the static initializer body material.
.//=============================================================================
.function PEIRenderInitializerBodyAssociation
  .param inst_ref i_ins
  .param inst_ref o_obj
  .//
  .assign multiplicity = 0
  .assign attr_assset = ""
  .assign attr_result = ""
  .select many te_rels related by o_obj->R_OIR[R201]->R_REL[R201]->TE_REL[R2034]
  .if ( not_empty te_rels )
    .// Pre-order the relationships ascending by their relationship number.
    .// Note:  This decouples code generation from SQL table
    .//        insertion ordering internals.
    .invoke SortSetAscendingByAttr_Numb( te_rels )
    .assign rel_count = 0
    .assign rel_cardinality = cardinality te_rels
    .//
    .while ( rel_count < rel_cardinality )
      .for each te_rel in te_rels
        .if ( te_rel.Order == rel_count )
          .select one rel related by te_rel->R_REL[R2034]
          .if ( not te_rel.storage_needed )
            .break for
          .end if
          .// Simple relationship?
          .select one simple_rel related by rel->R_SIMP[R206]
          .if ( not_empty simple_rel )
            .select one participant related by simple_rel->R_PART[R207]
            .select one formalizer related by simple_rel->R_FORM[R208]
            .if ( empty formalizer )
              .print "\n\tRelationship R${rel.Numb} is not formalized!\n"
              .exit 101
            .end if
            .// Deal with reflexives.
            .if ( participant.Obj_ID == formalizer.Obj_ID )
              .invoke s = PEIRelInitSimpleReflexive( i_ins, o_obj, rel, participant, formalizer )
              .assign attr_result = attr_result + s.result
              .assign attr_assset = attr_assset + s.assset
            .else
              .// Get multiplicity to pass to the code generator.
              .if ( o_obj.Obj_ID == participant.Obj_ID )
                .assign multiplicity = formalizer.Mult
              .else
                .assign multiplicity = participant.Mult
              .end if
              .invoke s = PEIRelInitSimple( i_ins, o_obj, rel, multiplicity )
              .assign attr_result = attr_result + s.result
              .assign attr_assset = attr_assset + s.assset
            .end if .// reflexive
          .else
            .// elif Subtype-Supertype relationship?
            .select one r_subsup related by rel->R_SUBSUP[R206]
            .if ( not_empty r_subsup )
              .invoke s = PEIRelInitSubSuper( i_ins, o_obj, rel, r_subsup )
              .assign attr_result = attr_result + s.result
          .else
            .// elif Associative relationship?
            .select one assrel related by rel->R_ASSOC[R206]
            .if ( not_empty assrel )
              .invoke s = PEIRelInitAssociative( i_ins, o_obj, rel, assrel )
              .assign attr_result = attr_result + s.result
              .assign attr_assset = attr_assset + s.assset
          .else
            .// elif Composed relationship?
            .select one composed_rel related by rel->R_COMP[R206]
            .if ( not_empty composed_rel )
              .print "\nWARNING:  R${rel.Numb} is COMPOSITION - No code generated.\n"
              .invoke s = PEIRelInitComposed( o_obj, rel )
              .assign attr_result = attr_result + s.result
          .else
            .// elif Error: New subtype of R_REL or a corrupted model SQL...
            .print "ERROR:  Unknown association type:R${rel.Numb} for class '${o_obj.Name}' (${o_obj.Key_Lett})"
            .exit 101
          .end if  .// not_empty composed_rel
          .end if  .// not_empty associative_rel
          .end if  .// not_empty subtype_supertype_rel
          .end if  .// not_empty simp_rel
          .break for
        .end if
      .end for
      .assign rel_count = rel_count + 1
    .end while .// rel_count < rel_cardinality
  .end if .// not_empty rel_set
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a simple association.
.// of multiplicity ONE.
.//=============================================================================
.function PEIRelInitSimple
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param integer multiplicity
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select any related_i_ins from instances of I_INS
  .//
  .// Find related instance index.
  .// Traverse the instance to link to instance chain
  .// to get the instance ArrayIndex.
  .if ( multiplicity == 0 )
    .// ONE
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
    .if ( empty related_i_ins )
      .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
      .select one related_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
    .end if
    .if ( not_empty related_i_ins )
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .assign attr_result = ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// not participating
      .assign attr_result = ", 0"
    .end if  .// not empty
  .else
    .// MANY
    .// Build linked list of containers pointing to related instances.
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related1_i_ins related by i_lnks->I_LIP[R2901]->I_INS[R2958]
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related2_i_inss related by i_lnks->I_LIP[R2902]->I_INS[R2958]
    .assign related_i_inss = related1_i_ins | related2_i_inss
    .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
    .assign attr_result = attr_result + s.result
    .assign attr_assset = attr_assset + s.assset
  .end if
  .//
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a simple reflexive
.// association.
.// In the reflexive case, the part and form are aligned with R2901 and R2902.
.//=============================================================================
.function PEIRelInitSimpleReflexive
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref r_part
  .param inst_ref r_form
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select one related_te_class related by o_obj->TE_CLASS[R2019]
  .select any related_i_ins from instances of I_INS
  .//
  .// Link the formalizer to the participant.
  .//
  .if ( r_part.Mult == 0 )
    .// ONE
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
    .if ( not_empty related_i_ins )
      .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// Not participating.
      .assign attr_result = attr_result + ", 0"
    .end if
  .else
    .// MANY
    .// Build linked list of containers pointing to related instances.
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related_i_inss related by i_lnks->I_LIP[R2901]->I_INS[R2958]
    .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
    .assign attr_result = attr_result + s.result
    .assign attr_assset = attr_assset + s.assset
  .end if
  .//
  .// Now link the participant to the formalizer(s).
  .//
  .if ( r_form.Mult == 0 )
    .// ONE
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
    .if ( not_empty related_i_ins )
      .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// Not participating.
      .assign attr_result = attr_result + ", 0"
    .end if
  .else
    .// MANY
    .// Build linked list of containers pointing to related instances.
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related_i_inss related by i_lnks->I_LIP[R2902]->I_INS[R2958]
    .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
    .assign attr_result = attr_result + s.result
    .assign attr_assset = attr_assset + s.assset
  .end if
  .//
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for an associative
.// relationship.
.// In the reflexive case, R2901 and R2902 will jive with AONE and AOTH.
.// In the non-reflexive, we compare the instance Obj_ID with the
.// AONE/AOTH Obj_ID.
.//=============================================================================
.function PEIRelInitAssociative
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref r_assoc
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select one aone related by r_assoc->R_AONE[R209]
  .select one aoth related by r_assoc->R_AOTH[R210]
  .select one assr related by r_assoc->R_ASSR[R211]
  .//
  .// The other associated instance.
  .//
  .if ( o_obj.Obj_ID == aoth.Obj_ID )
    .// Optimize relationship to associator.
    .if ( ( aone.Mult == 0 ) and ( assr.Mult == 0 ) )
      .// ONE
      .select any i_lnk from instances of I_LNK where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .// reflexive
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
        .if ( empty i_lnk )
          .select one related_o_obj related by i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
          .if ( related_o_obj.Obj_ID == aoth.Obj_ID )
            .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
          .end if
        .end if  .// not empty
      .end if .// reflexive
      .if ( not_empty i_lnk )
        .select one related_i_ins related by i_lnk->I_LIP[R2903]->I_INS[R2958]
        .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
        .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
      .else
        .// not participating
        .assign attr_result = attr_result + ", 0"
      .end if  .// not empty
    .else
      .// MANY
      .// Build linked list of containers pointing to related instances.
      .select many i_lnks from instances of I_LNK where ( false )
      .select many related_i_inss from instances of I_INS where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .// reflexive
        .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select many one_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
        .select many two_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
        .assign i_lnks = one_i_lnks | two_i_lnks
      .end if
      .select many related_i_inss related by i_lnks->I_LIP[R2903]->I_INS[R2958]
      .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
      .assign attr_result = attr_result + s.result
      .assign attr_assset = attr_assset + s.assset
    .end if
  .end if
  .//
  .// The one associated instance.
  .//
  .if ( o_obj.Obj_ID == aone.Obj_ID )
    .// Optimize relationship to associator.
    .if ( ( aoth.Mult == 0 ) and ( assr.Mult == 0 ) )
      .// ONE
      .select any i_lnk from instances of I_LNK where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .// reflexive
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
        .if ( empty i_lnk )
          .select one related_o_obj related by i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
          .if ( related_o_obj.Obj_ID == aone.Obj_ID )
            .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
          .end if
        .end if
      .end if .// reflexive
      .if ( not_empty i_lnk )
        .select one related_i_ins related by i_lnk->I_LIP[R2903]->I_INS[R2958]
        .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
        .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
      .else
        .// not participating
        .assign attr_result = attr_result + ", 0"
      .end if  .// not empty
    .else
      .// MANY
      .// Build linked list of containers pointing to related instances.
      .select many i_lnks from instances of I_LNK where ( false )
      .select many related_i_inss from instances of I_INS where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select many one_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
        .select many two_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
        .assign i_lnks = one_i_lnks | two_i_lnks
      .end if
      .select many related_i_inss related by i_lnks->I_LIP[R2903]->I_INS[R2958]
      .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
      .assign attr_result = attr_result + s.result
      .assign attr_assset = attr_assset + s.assset
    .end if
  .end if
  .//
  .// The associative instance.
  .//
  .if ( o_obj.Obj_ID == assr.Obj_ID )
    .// Optimize relationship to both associates.
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2903] where ( selected.Rel_ID == r_rel.Rel_ID )
    .if ( not_empty i_lnk )
      .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .select one related2_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
      .select one related2_o_obj related by related2_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related2_te_class related by related2_o_obj->TE_CLASS[R2019]
      .if ( ( aone.Obj_ID == aoth.Obj_ID ) or ( related2_o_obj.Obj_ID == aone.Obj_ID ) )
        .assign attr_result = attr_result + ", &${related2_te_class.GeneratedName}_instances[${related2_i_ins.Name}]"
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
      .else
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
        .assign attr_result = attr_result + ", &${related2_te_class.GeneratedName}_instances[${related2_i_ins.Name}]"
      .end if
    .else
      .// not participating
      .assign attr_result = attr_result + ", 0, 0"
    .end if  .// not empty
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a Subtype/Supertype
.// association.
.//=============================================================================
.function PEIRelInitSubSuper
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref r_subsup
  .assign attr_result = ""
  .//
  .// Find related instance index.
  .// Traverse the instance to link to instance chain
  .// to get the instance ArrayIndex.
  .select one super related by r_subsup->R_SUPER[R212]
  .if ( o_obj.Obj_ID == super.Obj_ID )
    .// Supertype
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
    .if ( empty i_lnk )
      .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
      .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
    .end if
    .if ( not_empty i_lnk )
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .assign attr_result = ", (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], ${related_te_class.system_class_number}"
    .else
      .// not participating
      .assign attr_result = ", 0, 0"
    .end if
  .else
    .// Subtype
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .if ( not_empty i_lnk )
      .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .assign attr_result = ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// not participating
      .assign attr_result = ", 0"
    .end if
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a composed association.
.//=============================================================================
.function PEIRelInitComposed
  .param inst_ref o_obj
  .param inst_ref r_rel
  .assign attr_result = ""
.end function
.//
.//
.//=============================================================================
.// Generate an initializer for the current state attribute if needed.
.//=============================================================================
.function PEIRenderInitializerBodyCurrentState
  .param inst_ref i_ins
  .param inst_ref o_obj
  .assign attr_result = ""
  .select one te_state related by i_ins->SM_STATE[R2915]->TE_STATE[R2037]
  .if ( not_empty te_state )
    .assign attr_result = te_state.enumerator
  .end if
.end function
.//
.//
.//=============================================================================
.// Render relationship MANY optimization.
.// This helper is used to render the code used to optimize a relationship
.// set.  The set variable is generated for inside the instance structure.
.// The linked list body pointing to related instances is also generated.
.//=============================================================================
.function PEIRenderRelationshipManyOptimization
  .param inst_ref_set i_inss
  .param inst_ref o_obj
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select any te_sys from instances of TE_SYS
  .// i_inss, o_obj
  .assign instance_count = cardinality i_inss
  .if ( instance_count > 0 )
    .select one te_class related by o_obj->TE_CLASS[R2019]
    .assign ContainerIndex = te_class.ContainerIndex
    .// A container index starting greater than zero means we are not the
    .// first (instance) to be adding linked lists.  Precede with comma.
    .if ( ContainerIndex > 0 )
      .assign attr_assset = ",\n"
    .end if
    .invoke rel_set_name = PEIGetRelationshipSetContainerName( te_class )
    .assign attr_result = ", { &${rel_set_name.result}[${ContainerIndex}] }"
    .for each related_i_ins in i_inss
      .assign ContainerIndex = ContainerIndex + 1
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .if ( last i_inss )
        .if ( te_sys.CollectionsFlavor == 20 )
          .assign icount = cardinality i_inss
          .if ( icount > 1 )
            .assign attr_assset = attr_assset + "  { 0, (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], &${rel_set_name.result}[${ContainerIndex} - 2] }"
          .else
            .assign attr_assset = attr_assset + "  { 0, (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], 0 }"
          .end if .// cardinality i_inss > 1
        .else
          .assign attr_assset = attr_assset + "  { 0, (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}] }"
        .end if
      .elif ( first i_inss )
        .if ( te_sys.CollectionsFlavor == 20 )
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], 0 },\n"
        .else
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}] },\n"
        .end if
      .else
        .if ( te_sys.CollectionsFlavor == 20 )
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], &${rel_set_name.result}[${ContainerIndex} - 2] },\n"
        .else
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}] },\n"
        .end if
      .end if
    .end for
    .assign te_class.ContainerIndex = ContainerIndex
  .else
    .// Empty relationship set.
    .assign attr_result = ", { 0 }"
  .end if
.end function
.//

.//============================================================================
.// $RCSfile: q.class.pei.arc,v $
.//
.// Description:
.// This archetype file contains the functions for generating
.// preexisting instances initialization code.
.//
.// Notice:
.// (C) Copyright 1998-2013 Mentor Graphics Corporation
.//     All rights reserved.
.//
.// This document contains confidential and proprietary information and
.// property of Mentor Graphics Corp.  No part of this document may be
.// reproduced without the express written permission of Mentor Graphics Corp.
.//============================================================================
.//
.//
.//============================================================================
.// Initialize the instance subsystem.
.// Update the instance and link records with array index values
.// and container counts.
.// The mapping of the instances to a particular array index is
.// arbitrary.
.//============================================================================
.function PEIInstanceSubsystemInit
  .param inst_ref_set o_objs
  .//
  .for each o_obj in o_objs
    .select many i_inss related by o_obj->CSME_CIE[R2961]->I_INS[R2962]
    .// Check for preexisting instance population requirement.
    .// The class must have instances and also be colored.
    .assign i = cardinality i_inss
    .select one te_class related by o_obj->TE_CLASS[R2019]
    .if ( ( i > 0 ) and ( te_class.PEIsDefinedInData ) )
      .assign te_class.PEIsDefinedInData = TRUE
    .else
      .assign te_class.PEIsDefinedInData = FALSE
    .end if
    .//
    .assign i = 0
    .for each i_ins in i_inss
      .assign i_ins.Name = "${i}"
      .assign i = i + 1
    .end for
  .end for
.end function
.//
.//
.//============================================================================
.// Count the preexisting instances of the given type.
.// Return the number of preexisting instances for obj.
.//============================================================================
.function PEINumberOfPreexistingInstances
  .param inst_ref o_obj
  .select many i_inss related by o_obj->CSME_CIE[R2961]->I_INS[R2962]
  .assign attr_result = cardinality i_inss
  .// .assign msg =       "PEINumberOfPreexistingInstances is ${attr_result} "
  .// .assign msg = msg + "for ${o_obj.Name} (${o_obj.Key_Lett})"
  .// .print "${msg}"
.end function
.//
.//
.//=============================================================================
.// Generate initializers for preexisting instances.
.// We generate the initializers in array index order.  C initializers
.// will assume sequential ordering.
.//=============================================================================
.function PEIRenderInitializers
  .param inst_ref o_obj
  .assign attr_assset = ""
  .select any te_set from instances of TE_SET
  .select one te_class related by o_obj->TE_CLASS[R2019]
  .if ( te_class.PEIsDefinedInData )
    .assign inst_count = 0
    .select many i_inss related by o_obj->CSME_CIE[R2961]->I_INS[R2962]
    .assign i_inss_cardinality = cardinality i_inss
    .while ( inst_count < i_inss_cardinality )
      .for each i_ins in i_inss
        .if ( i_ins.Name == "$t{inst_count}" )
          .invoke initializercode = PEIRenderInitializerBody( i_ins, o_obj )
          .assign attr_assset = attr_assset + initializercode.assset
  { ${initializercode.result} }\
          .if ( last i_inss )

          .else
,
          .end if
          .break for
        .end if
      .end for
      .assign inst_count = inst_count + 1
    .end while .// inst_count
    .// If there is a need for relationship set containers, build them up.
    .if ( attr_assset != "" )
      .invoke rel_set_name = PEIGetRelationshipSetContainerName( te_class )
      .assign attr_assset = "static ${te_set.element_type} ${rel_set_name.result}[] = {\n" + attr_assset
      .assign attr_assset = "/* PEI relationship set containers.  */\n" + attr_assset
      .assign attr_assset = attr_assset + "\n};\n"
    .end if
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate body of one preexisting instance initializer.
.// First, the initial state initializer is output.
.// The class instance attribute data variable values are generated
.// in the same order in which they appear in the application analysis OIM.
.// The relationship optimization initializers are then generated.
.//=============================================================================
.function PEIRenderInitializerBody
  .param inst_ref i_ins
  .param inst_ref o_obj
  .assign attr_result = ""
  .assign attr_assset = ""
  .//
  .// Generate state machine state (if needed).
  .//
  .invoke cs_init = PEIRenderInitializerBodyCurrentState( i_ins, o_obj )
  .assign attr_result = attr_result + cs_init.result
  .if ( "" != attr_result )
    .assign attr_result = attr_result + ", "
  .end if
  .//
  .// Generate the attribute value initializers.
  .//
  .select any te_attr related by o_obj->TE_CLASS[R2019]-TE_ATTR[R2061] where ( selected.prevID == 0 )
  .if ( not_empty te_attr )
    .select one o_attr related by te_attr->O_ATTR[R2033]
    .while ( not_empty te_attr )
      .if ( te_attr.translate )
        .select any i_avl related by i_ins->I_AVL[R2909] where ( selected.Attr_ID == o_attr.Attr_ID )
        .invoke avlcode = PEIRenderInitializerBodyAttribute( o_attr, i_avl )
        .assign attr_result = attr_result + avlcode.result
      .end if
      .//
      .// Advance to the next object attribute, if any.
      .select one te_attr related by te_attr->TE_ATTR[R2087.'succeeds']
      .//
      .// Generate comma separator.
      .if ( not_empty te_attr )
        .if ( te_attr.translate )
          .assign attr_result = attr_result + ", "
        .end if
      .end if
    .end while
  .end if
  .//
  .// Generate the association linkage (if needed).
  .//
  .invoke ass_init = PEIRenderInitializerBodyAssociation( i_ins, o_obj )
  .assign attr_result = attr_result + ass_init.result
  .assign attr_assset = attr_assset + ass_init.assset
  .//
.end function
.//
.//
.//=============================================================================
.// Generate initialization for a single attribute value.
.// Return the value as a string quoted correctly (if needed).
.//=============================================================================
.function PEIRenderInitializerBodyAttribute
  .param inst_ref o_attr
  .param inst_ref i_avl
  .assign attr_result = "0"
  .// Get the attribute data type.  Strings need to be quoted.
  .invoke r = GetAttributeCodeGenType( o_attr )
  .assign te_dt = r.result
  .if ( 4 == te_dt.Core_Typ )
    .// string
    .if ( empty i_avl )
      .// In absence of a populated attribute, use the attribute default value.
      .if ( "" != o_attr.DefaultValue )
        .assign attr_result = o_attr.DefaultValue
      .else
        .assign attr_result = """"""
      .end if
    .else
      .assign attr_result = """${i_avl.Value}"""
    .end if
  .else
    .if ( empty i_avl )
      .assign attr_result = "0"
    .else
      .assign attr_result = i_avl.Value
    .end if
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate the optimized association linkage for this instance.
.// Select the relationship set for this object.  Loop through each one
.// generating linkage anywhere storage is provided (for pointer refs).
.// Get the multiplicity so we know whether we need sets or simple
.// pointers.
.// Do the right thing for each flavor of association, simple, reflexive,
.// associative and sub/super.
.// Return the static initializer body material.
.//=============================================================================
.function PEIRenderInitializerBodyAssociation
  .param inst_ref i_ins
  .param inst_ref o_obj
  .//
  .assign multiplicity = 0
  .assign attr_assset = ""
  .assign attr_result = ""
  .select many te_rels related by o_obj->R_OIR[R201]->R_REL[R201]->TE_REL[R2034]
  .if ( not_empty te_rels )
    .// Pre-order the relationships ascending by their relationship number.
    .// Note:  This decouples code generation from SQL table
    .//        insertion ordering internals.
    .invoke SortSetAscendingByAttr_Numb( te_rels )
    .assign rel_count = 0
    .assign rel_cardinality = cardinality te_rels
    .//
    .while ( rel_count < rel_cardinality )
      .for each te_rel in te_rels
        .if ( te_rel.Order == rel_count )
          .select one rel related by te_rel->R_REL[R2034]
          .if ( not te_rel.storage_needed )
            .break for
          .end if
          .// Simple relationship?
          .select one simple_rel related by rel->R_SIMP[R206]
          .if ( not_empty simple_rel )
            .select one participant related by simple_rel->R_PART[R207]
            .select one formalizer related by simple_rel->R_FORM[R208]
            .if ( empty formalizer )
              .print "\n\tRelationship R${rel.Numb} is not formalized!\n"
              .exit 101
            .end if
            .// Deal with reflexives.
            .if ( participant.Obj_ID == formalizer.Obj_ID )
              .invoke s = PEIRelInitSimpleReflexive( i_ins, o_obj, rel, participant, formalizer )
              .assign attr_result = attr_result + s.result
              .assign attr_assset = attr_assset + s.assset
            .else
              .// Get multiplicity to pass to the code generator.
              .if ( o_obj.Obj_ID == participant.Obj_ID )
                .assign multiplicity = formalizer.Mult
              .else
                .assign multiplicity = participant.Mult
              .end if
              .invoke s = PEIRelInitSimple( i_ins, o_obj, rel, multiplicity )
              .assign attr_result = attr_result + s.result
              .assign attr_assset = attr_assset + s.assset
            .end if .// reflexive
          .else
            .// elif Subtype-Supertype relationship?
            .select one r_subsup related by rel->R_SUBSUP[R206]
            .if ( not_empty r_subsup )
              .invoke s = PEIRelInitSubSuper( i_ins, o_obj, rel, r_subsup )
              .assign attr_result = attr_result + s.result
          .else
            .// elif Associative relationship?
            .select one assrel related by rel->R_ASSOC[R206]
            .if ( not_empty assrel )
              .invoke s = PEIRelInitAssociative( i_ins, o_obj, rel, assrel )
              .assign attr_result = attr_result + s.result
              .assign attr_assset = attr_assset + s.assset
          .else
            .// elif Composed relationship?
            .select one composed_rel related by rel->R_COMP[R206]
            .if ( not_empty composed_rel )
              .print "\nWARNING:  R${rel.Numb} is COMPOSITION - No code generated.\n"
              .invoke s = PEIRelInitComposed( o_obj, rel )
              .assign attr_result = attr_result + s.result
          .else
            .// elif Error: New subtype of R_REL or a corrupted model SQL...
            .print "ERROR:  Unknown association type:R${rel.Numb} for class '${o_obj.Name}' (${o_obj.Key_Lett})"
            .exit 101
          .end if  .// not_empty composed_rel
          .end if  .// not_empty associative_rel
          .end if  .// not_empty subtype_supertype_rel
          .end if  .// not_empty simp_rel
          .break for
        .end if
      .end for
      .assign rel_count = rel_count + 1
    .end while .// rel_count < rel_cardinality
  .end if .// not_empty rel_set
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a simple association.
.// of multiplicity ONE.
.//=============================================================================
.function PEIRelInitSimple
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param integer multiplicity
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select any related_i_ins from instances of I_INS
  .//
  .// Find related instance index.
  .// Traverse the instance to link to instance chain
  .// to get the instance ArrayIndex.
  .if ( multiplicity == 0 )
    .// ONE
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
    .if ( empty related_i_ins )
      .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
      .select one related_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
    .end if
    .if ( not_empty related_i_ins )
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .assign attr_result = ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// not participating
      .assign attr_result = ", 0"
    .end if  .// not empty
  .else
    .// MANY
    .// Build linked list of containers pointing to related instances.
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related1_i_ins related by i_lnks->I_LIP[R2901]->I_INS[R2958]
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related2_i_inss related by i_lnks->I_LIP[R2902]->I_INS[R2958]
    .assign related_i_inss = related1_i_ins | related2_i_inss
    .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
    .assign attr_result = attr_result + s.result
    .assign attr_assset = attr_assset + s.assset
  .end if
  .//
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a simple reflexive
.// association.
.// In the reflexive case, the part and form are aligned with R2901 and R2902.
.//=============================================================================
.function PEIRelInitSimpleReflexive
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref r_part
  .param inst_ref r_form
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select one related_te_class related by o_obj->TE_CLASS[R2019]
  .select any related_i_ins from instances of I_INS
  .//
  .// Link the formalizer to the participant.
  .//
  .if ( r_part.Mult == 0 )
    .// ONE
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
    .if ( not_empty related_i_ins )
      .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// Not participating.
      .assign attr_result = attr_result + ", 0"
    .end if
  .else
    .// MANY
    .// Build linked list of containers pointing to related instances.
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related_i_inss related by i_lnks->I_LIP[R2901]->I_INS[R2958]
    .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
    .assign attr_result = attr_result + s.result
    .assign attr_assset = attr_assset + s.assset
  .end if
  .//
  .// Now link the participant to the formalizer(s).
  .//
  .if ( r_form.Mult == 0 )
    .// ONE
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
    .if ( not_empty related_i_ins )
      .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// Not participating.
      .assign attr_result = attr_result + ", 0"
    .end if
  .else
    .// MANY
    .// Build linked list of containers pointing to related instances.
    .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select many related_i_inss related by i_lnks->I_LIP[R2902]->I_INS[R2958]
    .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
    .assign attr_result = attr_result + s.result
    .assign attr_assset = attr_assset + s.assset
  .end if
  .//
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for an associative
.// relationship.
.// In the reflexive case, R2901 and R2902 will jive with AONE and AOTH.
.// In the non-reflexive, we compare the instance Obj_ID with the
.// AONE/AOTH Obj_ID.
.//=============================================================================
.function PEIRelInitAssociative
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref r_assoc
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select one aone related by r_assoc->R_AONE[R209]
  .select one aoth related by r_assoc->R_AOTH[R210]
  .select one assr related by r_assoc->R_ASSR[R211]
  .//
  .// The other associated instance.
  .//
  .if ( o_obj.Obj_ID == aoth.Obj_ID )
    .// Optimize relationship to associator.
    .if ( ( aone.Mult == 0 ) and ( assr.Mult == 0 ) )
      .// ONE
      .select any i_lnk from instances of I_LNK where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .// reflexive
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
        .if ( empty i_lnk )
          .select one related_o_obj related by i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
          .if ( related_o_obj.Obj_ID == aoth.Obj_ID )
            .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
          .end if
        .end if  .// not empty
      .end if .// reflexive
      .if ( not_empty i_lnk )
        .select one related_i_ins related by i_lnk->I_LIP[R2903]->I_INS[R2958]
        .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
        .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
      .else
        .// not participating
        .assign attr_result = attr_result + ", 0"
      .end if  .// not empty
    .else
      .// MANY
      .// Build linked list of containers pointing to related instances.
      .select many i_lnks from instances of I_LNK where ( false )
      .select many related_i_inss from instances of I_INS where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .// reflexive
        .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select many one_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
        .select many two_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
        .assign i_lnks = one_i_lnks | two_i_lnks
      .end if
      .select many related_i_inss related by i_lnks->I_LIP[R2903]->I_INS[R2958]
      .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
      .assign attr_result = attr_result + s.result
      .assign attr_assset = attr_assset + s.assset
    .end if
  .end if
  .//
  .// The one associated instance.
  .//
  .if ( o_obj.Obj_ID == aone.Obj_ID )
    .// Optimize relationship to associator.
    .if ( ( aoth.Mult == 0 ) and ( assr.Mult == 0 ) )
      .// ONE
      .select any i_lnk from instances of I_LNK where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .// reflexive
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
        .if ( empty i_lnk )
          .select one related_o_obj related by i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
          .if ( related_o_obj.Obj_ID == aone.Obj_ID )
            .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
          .end if
        .end if
      .end if .// reflexive
      .if ( not_empty i_lnk )
        .select one related_i_ins related by i_lnk->I_LIP[R2903]->I_INS[R2958]
        .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
        .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
      .else
        .// not participating
        .assign attr_result = attr_result + ", 0"
      .end if  .// not empty
    .else
      .// MANY
      .// Build linked list of containers pointing to related instances.
      .select many i_lnks from instances of I_LNK where ( false )
      .select many related_i_inss from instances of I_INS where ( false )
      .if ( aone.Obj_ID == aoth.Obj_ID )
        .select many i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
      .else
        .select many one_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
        .select many two_i_lnks related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
        .assign i_lnks = one_i_lnks | two_i_lnks
      .end if
      .select many related_i_inss related by i_lnks->I_LIP[R2903]->I_INS[R2958]
      .invoke s = PEIRenderRelationshipManyOptimization( related_i_inss, o_obj )
      .assign attr_result = attr_result + s.result
      .assign attr_assset = attr_assset + s.assset
    .end if
  .end if
  .//
  .// The associative instance.
  .//
  .if ( o_obj.Obj_ID == assr.Obj_ID )
    .// Optimize relationship to both associates.
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2903] where ( selected.Rel_ID == r_rel.Rel_ID )
    .if ( not_empty i_lnk )
      .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .select one related2_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
      .select one related2_o_obj related by related2_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related2_te_class related by related2_o_obj->TE_CLASS[R2019]
      .if ( ( aone.Obj_ID == aoth.Obj_ID ) or ( related2_o_obj.Obj_ID == aone.Obj_ID ) )
        .assign attr_result = attr_result + ", &${related2_te_class.GeneratedName}_instances[${related2_i_ins.Name}]"
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
      .else
        .assign attr_result = attr_result + ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
        .assign attr_result = attr_result + ", &${related2_te_class.GeneratedName}_instances[${related2_i_ins.Name}]"
      .end if
    .else
      .// not participating
      .assign attr_result = attr_result + ", 0, 0"
    .end if  .// not empty
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a Subtype/Supertype
.// association.
.//=============================================================================
.function PEIRelInitSubSuper
  .param inst_ref i_ins
  .param inst_ref o_obj
  .param inst_ref r_rel
  .param inst_ref r_subsup
  .assign attr_result = ""
  .//
  .// Find related instance index.
  .// Traverse the instance to link to instance chain
  .// to get the instance ArrayIndex.
  .select one super related by r_subsup->R_SUPER[R212]
  .if ( o_obj.Obj_ID == super.Obj_ID )
    .// Supertype
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2901] where ( selected.Rel_ID == r_rel.Rel_ID )
    .select one related_i_ins related by i_lnk->I_LIP[R2902]->I_INS[R2958]
    .if ( empty i_lnk )
      .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
      .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
    .end if
    .if ( not_empty i_lnk )
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .assign attr_result = ", (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], ${related_te_class.system_class_number}"
    .else
      .// not participating
      .assign attr_result = ", 0, 0"
    .end if
  .else
    .// Subtype
    .select any i_lnk related by i_ins->I_LIP[R2958]->I_LNK[R2902] where ( selected.Rel_ID == r_rel.Rel_ID )
    .if ( not_empty i_lnk )
      .select one related_i_ins related by i_lnk->I_LIP[R2901]->I_INS[R2958]
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .assign attr_result = ", &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}]"
    .else
      .// not participating
      .assign attr_result = ", 0"
    .end if
  .end if
.end function
.//
.//
.//=============================================================================
.// Generate the optimized relationship linkage for a composed association.
.//=============================================================================
.function PEIRelInitComposed
  .param inst_ref o_obj
  .param inst_ref r_rel
  .assign attr_result = ""
.end function
.//
.//
.//=============================================================================
.// Generate an initializer for the current state attribute if needed.
.//=============================================================================
.function PEIRenderInitializerBodyCurrentState
  .param inst_ref i_ins
  .param inst_ref o_obj
  .assign attr_result = ""
  .select one te_state related by i_ins->SM_STATE[R2915]->TE_STATE[R2037]
  .if ( not_empty te_state )
    .assign attr_result = te_state.enumerator
  .end if
.end function
.//
.//
.//=============================================================================
.// Render relationship MANY optimization.
.// This helper is used to render the code used to optimize a relationship
.// set.  The set variable is generated for inside the instance structure.
.// The linked list body pointing to related instances is also generated.
.//=============================================================================
.function PEIRenderRelationshipManyOptimization
  .param inst_ref_set i_inss
  .param inst_ref o_obj
  .//
  .assign attr_result = ""
  .assign attr_assset = ""
  .select any te_sys from instances of TE_SYS
  .// i_inss, o_obj
  .assign instance_count = cardinality i_inss
  .if ( instance_count > 0 )
    .select one te_class related by o_obj->TE_CLASS[R2019]
    .assign ContainerIndex = te_class.ContainerIndex
    .// A container index starting greater than zero means we are not the
    .// first (instance) to be adding linked lists.  Precede with comma.
    .if ( ContainerIndex > 0 )
      .assign attr_assset = ",\n"
    .end if
    .invoke rel_set_name = PEIGetRelationshipSetContainerName( te_class )
    .assign attr_result = ", { &${rel_set_name.result}[${ContainerIndex}] }"
    .for each related_i_ins in i_inss
      .assign ContainerIndex = ContainerIndex + 1
      .select one related_o_obj related by related_i_ins->CSME_CIE[R2962]->O_OBJ[R2961]
      .select one related_te_class related by related_o_obj->TE_CLASS[R2019]
      .if ( last i_inss )
        .if ( te_sys.CollectionsFlavor == 20 )
          .assign icount = cardinality i_inss
          .if ( icount > 1 )
            .assign attr_assset = attr_assset + "  { 0, (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], &${rel_set_name.result}[${ContainerIndex} - 2] }"
          .else
            .assign attr_assset = attr_assset + "  { 0, (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], 0 }"
          .end if .// cardinality i_inss > 1
        .else
          .assign attr_assset = attr_assset + "  { 0, (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}] }"
        .end if
      .elif ( first i_inss )
        .if ( te_sys.CollectionsFlavor == 20 )
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], 0 },\n"
        .else
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}] },\n"
        .end if
      .else
        .if ( te_sys.CollectionsFlavor == 20 )
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}], &${rel_set_name.result}[${ContainerIndex} - 2] },\n"
        .else
          .assign attr_assset = attr_assset + "  { &${rel_set_name.result}[${ContainerIndex}], (void *) &${related_te_class.GeneratedName}_instances[${related_i_ins.Name}] },\n"
        .end if
      .end if
    .end for
    .assign te_class.ContainerIndex = ContainerIndex
  .else
    .// Empty relationship set.
    .assign attr_result = ", { 0 }"
  .end if
.end function
.//


lib/coro.arc: add instability warning

lib/coro.arc: add instability warning

; I haven't thought deeply enough about the proper semantics here, so please
; don't rely on this library. - rntz <daekharel@gmail.com> (2010-01-01)

(require "lib/util.arc")
(require "lib/extend.arc")

; simpler than point and robust against changes in it, given that 'point
; indicates that the form it produces must only be used as an escape procedure.
(mac lcc (var . body)
  " Binds the current contination to `var' within `body'.
    See also [[point]] "
  `(ccc (fn (,var) ,@body)))

(def yielder (update consume)
  " Returns a fn that, when called, captures and calls `update' on its
    continuation, then applies `consume' to its arguments. A building block
    for coroutines in arc.
    See also [[cowrap]] "
  (fn args
    (lcc cont
      (update cont)
      (apply consume args))))

(def cowrap (func (o end nilfn))
  " `func' is called with a fn `yield' to produce a fn `inner'. 'cowrap returns
    a fn `wrapped' that, when called with input, gives it to `inner', then
    returns what `inner' subsequently calls `yield' with. If `inner' does not
    call `yield', `wrapped' returns the result of calling `end' on the input
    instead.
    See also [[yielder]] [[ccc]] "
  (let (enter exit done) nil
    (withs (yield (yielder (fn (k) (assign enter k))
                           (fn args (apply exit args)))
            outer (yielder (fn (k) (assign exit k))
                           (fn input
                             (assign done (fn () (apply end input)))
                             (apply enter input)
                             ; inner did not call yield.
                             ; can't just use compose without wrapping in fn
                             ; because values of 'exit and 'done can change.
                             ((= enter (fn _ (exit:done)))))))
      (= enter (func yield))
      outer)))

(mac cofn (name args . body)
  " Creates a coroutine which yields via `name', takes `args' as initial input,
    and executes `body'.
    See also [[yfn]] [[cowrap]] [[cofngen]] "
  `(cowrap (fn (,name) (fn ,args ,@body))))

(mac yfn (args . body)
  " Creates a coroutine which yields via 'yield, takes `args' as initial input,
    and executes `body'.
    See also [[cofn]] [[cowrap]] [[yfngen]] "
  `(cofn yield ,args ,@body))

(mac cofngen (name args . body)
  " Creates a coroutine generator which takes `args' and returns a coroutine
    which yields via `name', takes no initial input, and executes `body'.
    See also [[cofn]] [[yfngen]] "
  `(fn ,args (cofn ,name () ,@body)))

(mac yfngen (args . body)
  " Creaes a coroutine generator which takes `args' and returns a coroutine
    which yields via 'yield, takes no initial input, and executes `body'.
    See also [[yfn]] [[cofngen]] "
  `(cofngen yield ,args ,@body))

(mac coro (name args . body)
  " Defines a coroutine-generator `name' which takes `args' and returns a
    coroutine that yields via 'yield, takes no initial input, and executes
    `body'.
    See also [[yfn]] [[yfngen]] [[cowrap]] "
  `(def ,name ,args
     (yfn () ,@body)))

; generators - coroutines which take no input and can be iterated over
(def genwrap (func (o default-sym))
  " Returns a generator `gen'. When called, `gen' calls `func' with a `yield' fn
    and returns whatever `func' calls `yield' with. Successive calls continue
    `func' and return the results of `func''s successive calls to `yield'. `gen'
    may also be passed an argument; if `func' terminates, this argument is
    returned instead of nil.

    Generators can be iterated over with 'walk and 'each.

    See also [[cowrap]] [[cofngen]] "
  (annotate 'generator
            (cowrap (fn (yield) (fn _ (func yield)))
                    (fn ((o endsym default-sym)) endsym))))

(set-coercer 'fn 'generator rep)

(extend walk generator
  (fn (seq . _) (isa seq 'generator))
  (fn (gtor func) (w/uniq done
                    (afnwith ()
                      (let x (gtor done)
                        (unless (is x done)
                          (func x)
                          (self)))))))

(mac ngen (name . body)
  " Creates a generator executing `body' which uses `name' to yield.
    See also [[gen]] [[genwrap]] "
  `(genwrap (fn (,name) ,@body)))

(mac gen body
  " Creates a generator executing `body' which uses 'yield to yield.
    See also [[ngen]] [[genwrap]]"
  `(ngen yield ,@body))

(mac defgen (name args . body)
  " Defines a function `name' which returns a generator executing `body' that
    uses 'yield to yield.
    See also [[gen]] [[genwrap]] [[coro]] "
  `(def ,name ,args
     (gen ,@body)))

(defgen genwalk (l)
  " Turns anything that can be `walk'ed into a generator.
    See also [[walk]] [[gen]] [[genwrap]] "
  (walk l yield))


hl2b/compiler.arc: some comments

hl2b/compiler.arc: some comments

; front end to the bytecode compiler
; loads all the files and defines an entry function

; define the <hl> package and import functions and macros needed
; by the compiler from <arc>v3
; TODO: move in a file conditionally loaded only when bootstrapping
;       using hl-arc-f
(in-package hl)
(using <arc>v3)
; Should really use <hl>def, not just def, because def in this
; context will be <arc>def.  Same with <hl>type etc.
; Please see http://hl.webhop.net/item?id=103 ; I recommended
; using 3 sections, and specified which ones should specify
; specific packages, and which ones just use <arc> packages.
(interface v0 def mac if and no or each load string unpkg prn = w/infile
              let with withs fn afn require w/uniq coerce + push listtab
              givens make-br-fn ++ acons ssyntax isnt caris _ in type isa
              alist err is car cons cdr map orf awhen do trav+ when ontable
              list aif zap self makeproper rfn pos complement dotted len on
              index
              ; types
              int table string sym)

(set <hl>unpkg <arc>unpkg)
(set <hl>ssyntax <arc>ssyntax)
(set <hl>pos <arc>pos)

; the compiler package
(in-package compiler)
(using <hl>v0)

(interface v0 compile)

; strictly, "compiled-and-executed-files"
(set files* '("structs.hl" "bytecodegen.hl"
              "quote-lift.hl" "utils.hl" "closures.hl" "cps.hl"
              "sharedvars.hl"  "xe.hl"))
; need also *another* set of files for "compiled-only-but-not-executed-files"

; load all the files
(each f files*
  (load f))

; entry point
; return a 0 arg function that executes expr
(def compile (expr)
  (<axiom>assemble (compile-to-bytecode expr)))
; above doesn't actually make sense from within
; Arc-F, because Arc-F doesn't support <axiom>assemble.
; Maybe should be in the "compiled-but-not-executed"
; set of files

; front end to the bytecode compiler
; loads all the files and defines an entry function

; define the <hl> package and import functions and macros needed
; by the compiler from <arc>v3
; TODO: move in a file conditionally loaded only when bootstrapping
;       using hl-arc-f
(in-package hl)
(using <arc>v3)
(interface v0 def mac if and no or each load string unpkg prn = w/infile
              let with withs fn afn require w/uniq coerce + sym push listtab
              givens make-br-fn ++ acons ssyntax isnt caris _ in type isa
              alist err is car cons cdr map)

(set <hl>unpkg <arc>unpkg)
(set <hl>ssyntax <arc>ssyntax)

; the compiler package
(in-package compiler)
(using <hl>v0)

(interface v0 compile)

; strictly, "compiled-and-executed-files"
(set files* '("structs.hl" "bytecodegen.hl"
              "quote-lift.hl" "utils.hl" "closures.hl" "cps.hl"
              "sharedvars.hl"  "xe.hl"))
; need also *another* set of files for "compiled-only-but-not-executed-files"

; load all the files
(each f files*
  (load f))

; entry point
; return a 0 arg function that executes expr
(def compile (expr)
  (<axiom>assemble (compile-to-bytecode expr)))
; above doesn't actually make sense from within
; Arc-F, because Arc-F doesn't support <axiom>assemble.
; Maybe should be in the "compiled-but-not-executed"
; set of files


codegen: C-side execute() now accepts pc as a parameter (complete log for more)

  Should make threading, when added later (necessary for the server! ^^)
  much easier to implement: just spawn a new thread which execute() the
  correct fn.  Although potential problems in getting access to closures?

  TODO: move stack, closure and sp inside execute(), but this requires
  that PR() and other functions to be given access to TOS().  Maybe
  change PR() to PR_fun() and create a PR() C-macro to encapsulate away.

;------------------------------------------------------------------------------

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [let i lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count) i]
     ; private functions
     code-gen nil
     compile-all-lambdas nil)

  (= code-gen (fn (ast stack-env)
    (let (cg-list cg-args access-var cg) nil
      (= cg-list (fn (asts vars stack-env sep k)
        (if (no asts)
          (k "" stack-env)
          (let x (code-gen (car asts) stack-env)
            (cg-list (cdr asts) (cdr vars) (cons (car vars) stack-env) sep (fn (code stack-env) (k (list x sep code) stack-env)))))))

      (= cg-args (fn (args stack-env)
        (cg-list args (range 1 (len args)) stack-env "" (fn (code stack-env) code))))

      (= access-var (fn (var stack-env)
        (if (aglobal var)
          (let i (pos var global-vars)
            (list "GLOBAL(" i "/*" var!uid "*/)"))
          (let i (- (len stack-env) (pos var stack-env) 1)
            (list "LOCAL(" i "/*" var!uid "*/)")))))

      (= cg (fn (ast)
        (if
          (alit ast)
            (let val ast!val
              (if
                (no val) (list " PUSH(NILOBJ);")
                (is val t) (list " PUSH(TOBJ);")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (list " PUSH(SYM2OBJ(\"" (car ast!subx) "\"));")
          (aref ast)
            (list " PUSH(" (access-var ast!var stack-env) ");")
          (aset ast)
            (list (cg (car ast!subx)) " " (access-var ast!var stack-env) " = TOS();")
          (acnd ast)
            (let x (map cg ast!subx)
              (list (car x) "\n if (POP() != NILOBJ) {\n" (cadr x) "\n } else {\n" (car:cddr x) "\n }"))
          (aprim ast)
            (let args ast!subx
              (if
                (is ast!op '%cons) (list (cg-args args stack-env) " CONS();")
                (is ast!op '%car) (list (cg-args args stack-env) " CAR();")
                (is ast!op '%cdr) (list (cg-args args stack-env) " CDR();")
                (is ast!op '%type) (list (cg-args args stack-env) " TYPE();")
                (is ast!op '%is) (list (cg-args args stack-env) " EQ();")
                (is ast!op '%isnt) (list (cg-args args stack-env) " NEQ();")
                (is ast!op '%<) (list (cg-args args stack-env) " LT();")
                (is ast!op '%>) (list (cg-args args stack-env) " GT();")
                (is ast!op '%<=) (list (cg-args args stack-env) " LE();")
                (is ast!op '%>=) (list (cg-args args stack-env) " GE();")
                (is ast!op '%+) (list (cg-args args stack-env) " ADD();")
                (is ast!op '%-) (list (cg-args args stack-env) " SUB();")
                (is ast!op '%*) (list (cg-args args stack-env) " MUL();")
                (is ast!op '%pr) (list (cg-args args stack-env) " PR();")
                (is ast!op '%prn) (list (cg-args args stack-env) " PRN();")
                (is ast!op '%halt) (list (cg-args args stack-env) " HALT();")
                (is ast!op '%closure)
                  (withs
                    (i (add-lambda (car args))
                     n (len (cdr args))
                     s (list "CLOSURE(" i "," n ");"))
                    (list (cg-args (cdr args) stack-env) " BEGIN_" s (map [list " INICLO(" _ ");"] (rev:range 1 n)) " END_" s))
                (is ast!op '%closure-ref)
                  (let i ((cadr args) 'val)
                    (list (cg (car args)) " TOS() = CLOSURE_REF(TOS()," i ");"))
                (err "unknown primitive" ast!op)))
          (anapp ast)
            (withs
              (fun (car ast!subx)
               args (cdr ast!subx)
               n (len args))
              (if (alam fun)
                (cg-list args fun!params stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
                (cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
                  (with
                    (start (len stack-env)
                     s (list "JUMP(" n ");"))
                    (list code " BEGIN_" s (map [list " PUSH(LOCAL(" (+ _ start) "));"] (range 0 (- n 1))) " END_" s))))))
          (alam ast) ; this case is impossible after CPS-conversion
            (list " PUSH(FIX2OBJ(" (add-lambda ast) "));")
          (aseq ast) ; this case is impossible after CPS-conversion
            (map [list (cg _) "DROP();"] ast!subx)
            (err "unknown ast" ast))))

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            (code-gen (car ast!subx) (rev ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 10000 "\n" code-prefix*)
      code
      code-suffix*))))

(= code-prefix* "

#define GC_DEBUG

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>

#define MAX_SYMS 1000000
#define T_PAIR 0
#define T_SYM  1

typedef long obj;

typedef struct {
  long type; /* T_PAIR */
  obj car;
  obj cdr;
} pair;

typedef struct {
  long type; /* T_SYM */
  char * value;
} symbol;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj * closure;
obj * sp;
symbol * syms[MAX_SYMS]; /* To be replaced by a hash table */
int nsyms;

#define AFIX(o) ((o) & 1)     /* the last bit is 0 : it's a fixnum */
#define APTR(o) (!((o) & 1))  /* It's not a fixnum : it's a ref to something else */
#define ASYM(o) (((obj*)(o))[0] == T_SYM)
#define APAIR(o) (((obj*)(o))[0] == T_PAIR)

#define FIX2OBJ(n) (((n) << 1) + 1)
#define OBJ2FIX(o) ((o) >> 1)

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) ((obj *)(self))[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = TOS() == y ? TOBJ : NILOBJ; }
#define NEQ() { obj y = POP(); TOS() = TOS() != y ? TOBJ : NILOBJ; }

#define TYPE() { obj * p; obj y = TOS();\\
  if (AFIX(y))\\
    TOS() = SYM2OBJ(\"int\");\\
  else{\\
    p = (obj *) y;\\
    switch ((char) *p){\\
      case T_PAIR: TOS() = SYM2OBJ(\"cons\"); break;\\
      case T_SYM: TOS() = SYM2OBJ(\"sym\"); break;\\
    }\\
  }\\
}

#define LT() { obj y = POP(); TOS() = TOS() < y ? TOBJ : NILOBJ; }
#define GT() { obj y = POP(); TOS() = TOS() > y ? TOBJ : NILOBJ; }
#define LE() { obj y = POP(); TOS() = TOS() <= y ? TOBJ : NILOBJ; }
#define GE() { obj y = POP(); TOS() = TOS() >= y ? TOBJ : NILOBJ; }
#define ADD() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) + y); }
#define SUB() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) - y); }
#define MUL() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) * y); }

#define CONS() { pair * p = GC_MALLOC (sizeof(pair)); p->type = T_PAIR ; p->cdr = POP(); p->car = POP(); PUSH((obj)p); }
#define CAR() { pair * p = (pair *) POP(); PUSH((obj)(p->car)); }
#define CDR() { pair * p = (pair *) POP(); PUSH((obj)(p->cdr)); }

#define PRN() { PR(); printf (\"\\n\");}

void PR(){
  pair * p;
  symbol * s;
  obj y = TOS();

  if (AFIX(y))
    printf (\"%ld\", OBJ2FIX(y));
  else if (ASYM(y)){
    s = (symbol *) y;
    printf (\"%s\", s->value);
  }
  else if (APAIR(y)){
    p = (pair *) y;
    printf (\"( \");
    PUSH(p->car); PR(); POP();
    printf (\" . \");
    PUSH(p->cdr); PR(); POP();
    printf (\" )\");
  }
}

#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH((obj)closure);

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = ((obj *)LOCAL(0))[0]; goto jump;

obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
  int i;

  for (i = 0 ; i < nsyms ; i++)
    if (strcmp (s, syms[i]->value) == 0) /* found it */
      return (obj) syms[i];

  if (nsyms == MAX_SYMS){ /* Bad luck, really... */
    fprintf (stderr, \"Sorry, we just ran out of symbols. Please come back later...\\n\");
    exit (1);
  }

  syms[nsyms]        = malloc (sizeof(symbol)); /* Symbols never go away, then can be malloc-ed */
  syms[nsyms]->type  = T_SYM;
  syms[nsyms]->value = (char *) malloc (strlen (s) + 1);
  strcpy (syms[nsyms]->value, s);

  return (obj) syms[nsyms++];
}

obj execute (int pc)
{
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");

  jump: switch (pc) {

")

(= code-suffix* "  }
  return POP();
}

int main (int argc, char * argv[]) {
  GC_INIT();
  execute(0);
  return 0;
}
")

;------------------------------------------------------------------------------

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (cons 'quote ast!subx)
      ; if unknown AST, then probably still in list form
      ; (cref driver)
      ast))

(def ds (ast)
   (if
      (alit ast)
          (cons 'lit ast!val)
      (aref ast)
         (cons 'ref ((ast 'var) 'uid))
      (aset ast)
         (cons 'set (list 'set ((ast 'var) 'uid) (ds (car ast!subx))))
      (acnd ast)
         (cons 'cnd (cons 'if (map ds ast!subx)))
      (aprim ast)
         (cons 'prim (cons ast!op (map ds ast!subx)))
      (anapp ast)
      (cons 'app
         (if (alam (car ast!subx))
            (list 'let (map (fn (p a) (list p!uid (ds a))) ((car ast!subx) 'params) (cdr ast!subx)) (ds (car ((car ast!subx) 'subx))))
            (map ds ast!subx)))
      (alam ast)
         (cons 'lam (list 'fn (map [_ 'uid] ast!params) (ds (car ast!subx))))
      (aseq ast)
         (cons 'seq (cons 'do (map ds ast!subx)))
         ast))

; abstract away avoiding ' and the quoted parts of `
; body *must* return the value in 'var if it won't
; change anything
(mac code-walk (var code . body)
  (w/uniq usercode
    `(let ,usercode (fn (,var) ,@body)
       (*code-walk-internal ,usercode ,code))))

(def *code-walk-internal (usercode code)
  (let pass-to-user
       (fn (c)
         (let new-code (usercode c)
           (if (isnt new-code c)
               ; if change, rewalk the new code
               ; (don't move on unless code is stable)
               (*code-walk-internal usercode new-code)
               (if (acons new-code)
                   (map [*code-walk-internal usercode _] new-code)
                   new-code))))
    (if (acons code)
        (if
          (is (car code) 'quote)
            code
          (is (car code) 'quasiquote)
            (list 'quasiquote
               ((rfn quasiwalk (code)
                   (if (acons code)
                       (if
                         (is (car code) 'unquote)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         (is (car code) 'unquote-splicing)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         ; else
                           (map quasiwalk code))
                       code))
                 (cadr code)))
          ; else
            (pass-to-user code))
        (pass-to-user code))))

(def to-3-if (l)
  (code-walk code l
    (if
      (and (caris code 'if) (len> code 4))
        (let (_ c v . rest) code
          `(if ,c ,v (if ,@rest)))
      ; else
        code)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def symbol-syntax (l)
  (code-walk code l
    (if
      (and (acons code) (ssyntax:car code))
        (let (fun . args) code
          (zap ssexpand fun)
          (if (caris fun 'compose)
              ((afn ((fun . rest))
                 (if rest
                     `(,fun ,(self rest))
                     `(,fun ,@args)))
               (cdr fun))
              `(,fun ,@args)))
      (ssyntax code)
        (ssexpand code)
      code)))

; handles (toplevel) 'load and 'require
; inefficiency note: allocs a lot of cons cells
(def include-files (l)
  (mappend
    (fn (e)
      ; if it's a 'load or 'require, include it
      (if (and (acons e) (in (car e) 'load 'require))
          (let (_ file . oops) e
            (when oops
              (err:string "Too many parameters to: " (car e)))
            ; make sure to recursively handle including files
            (include-files
              (w/infile s file
                (readall s (list 'detect-eof)))))
          (list e)))
    l))

;------------------------------------------------------------------------------

(def strip-ext (filename)
  (cut filename 0 (pos #\. filename)))

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (cons 'do (readall s (list 'detect-eof))))
         chain
         `(
            ; --------List form
            (,include-files "FILE INCLUSION")
            ; NOTE: all the 'code-walk passes might be
            ; better off in a single pass (just use a large
            ; 'if block).  Especially with regards to macros
            ; and symbol syntax: a ssyntax might emit a macro,
            ; which might emit a ssyntax, which might emit
            ; a macro... 'code-walk can actually handle this
            ; but only if macros and ssyntax expansion are
            ; in the same 'code-walk block
            (,symbol-syntax "ssyntax TRANSFORMATION")
            (,to-3-if "3-arg-if TRANSFORMATION")
            ; --------AST form
            (,[xe _ ()] "AST TRANSFORMATION")
            (,cps-convert "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= xe-global-cte* (make-initial-cte))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d (f old-d)
                  (when debugmode
                    (prn "------------------------------ " desc)
                    (prn (source new-d)))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))

;------------------------------------------------------------------------------

; code generation

(def code-generate (ast)
  (withs
    (lambda-todo '()
     lambda-count 0
     global-vars (fv ast)
     add-lambda [let i lambda-count (push (cons lambda-count _) lambda-todo) (++ lambda-count) i]
     ; private functions
     code-gen nil
     compile-all-lambdas nil)

  (= code-gen (fn (ast stack-env)
    (let (cg-list cg-args access-var cg) nil
      (= cg-list (fn (asts vars stack-env sep k)
        (if (no asts)
          (k "" stack-env)
          (let x (code-gen (car asts) stack-env)
            (cg-list (cdr asts) (cdr vars) (cons (car vars) stack-env) sep (fn (code stack-env) (k (list x sep code) stack-env)))))))

      (= cg-args (fn (args stack-env)
        (cg-list args (range 1 (len args)) stack-env "" (fn (code stack-env) code))))

      (= access-var (fn (var stack-env)
        (if (aglobal var)
          (let i (pos var global-vars)
            (list "GLOBAL(" i "/*" var!uid "*/)"))
          (let i (- (len stack-env) (pos var stack-env) 1)
            (list "LOCAL(" i "/*" var!uid "*/)")))))

      (= cg (fn (ast)
        (if
          (alit ast)
            (let val ast!val
              (if
                (no val) (list " PUSH(NILOBJ);")
                (is val t) (list " PUSH(TOBJ);")
                (list " PUSH(FIX2OBJ(" val "));")))
          (aquote ast)
            (list " PUSH(SYM2OBJ(\"" (car ast!subx) "\"));")
          (aref ast)
            (list " PUSH(" (access-var ast!var stack-env) ");")
          (aset ast)
            (list (cg (car ast!subx)) " " (access-var ast!var stack-env) " = TOS();")
          (acnd ast)
            (let x (map cg ast!subx)
              (list (car x) "\n if (POP() != NILOBJ) {\n" (cadr x) "\n } else {\n" (car:cddr x) "\n }"))
          (aprim ast)
            (let args ast!subx
              (if
                (is ast!op '%cons) (list (cg-args args stack-env) " CONS();")
                (is ast!op '%car) (list (cg-args args stack-env) " CAR();")
                (is ast!op '%cdr) (list (cg-args args stack-env) " CDR();")
                (is ast!op '%type) (list (cg-args args stack-env) " TYPE();")
                (is ast!op '%is) (list (cg-args args stack-env) " EQ();")
                (is ast!op '%isnt) (list (cg-args args stack-env) " NEQ();")
                (is ast!op '%<) (list (cg-args args stack-env) " LT();")
                (is ast!op '%>) (list (cg-args args stack-env) " GT();")
                (is ast!op '%<=) (list (cg-args args stack-env) " LE();")
                (is ast!op '%>=) (list (cg-args args stack-env) " GE();")
                (is ast!op '%+) (list (cg-args args stack-env) " ADD();")
                (is ast!op '%-) (list (cg-args args stack-env) " SUB();")
                (is ast!op '%*) (list (cg-args args stack-env) " MUL();")
                (is ast!op '%pr) (list (cg-args args stack-env) " PR();")
                (is ast!op '%prn) (list (cg-args args stack-env) " PRN();")
                (is ast!op '%halt) (list (cg-args args stack-env) " HALT();")
                (is ast!op '%closure)
                  (withs
                    (i (add-lambda (car args))
                     n (len (cdr args))
                     s (list "CLOSURE(" i "," n ");"))
                    (list (cg-args (cdr args) stack-env) " BEGIN_" s (map [list " INICLO(" _ ");"] (rev:range 1 n)) " END_" s))
                (is ast!op '%closure-ref)
                  (let i ((cadr args) 'val)
                    (list (cg (car args)) " TOS() = CLOSURE_REF(TOS()," i ");"))
                (err "unknown primitive" ast!op)))
          (anapp ast)
            (withs
              (fun (car ast!subx)
               args (cdr ast!subx)
               n (len args))
              (if (alam fun)
                (cg-list args fun!params stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
                (cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
                  (with
                    (start (len stack-env)
                     s (list "JUMP(" n ");"))
                    (list code " BEGIN_" s (map [list " PUSH(LOCAL(" (+ _ start) "));"] (range 0 (- n 1))) " END_" s))))))
          (alam ast) ; this case is impossible after CPS-conversion
            (list " PUSH(FIX2OBJ(" (add-lambda ast) "));")
          (aseq ast) ; this case is impossible after CPS-conversion
            (map [list (cg _) "DROP();"] ast!subx)
            (err "unknown ast" ast))))

      (cg ast))))

  (= compile-all-lambdas (fn ()
    (if (no lambda-todo)
      ""
      (withs
        (x (car lambda-todo)
         ast (cdr x))
        (pop lambda-todo)
          (list
            "case " (car x) ":\n\n"
            (code-gen (car ast!subx) (rev ast!params))
            "\n\n"
            (compile-all-lambdas))))))

  (add-lambda ast)

  (let code (compile-all-lambdas)
    (list
      (list "#define NB_GLOBALS " (len global-vars) "\n"  "#define MAX_STACK " 10000 "\n" code-prefix*)
      code
      code-suffix*))))

(= code-prefix* "

#define GC_DEBUG

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gc.h>

#define MAX_SYMS 1000000
#define T_PAIR 0
#define T_SYM  1

typedef long obj;

typedef struct {
  long type; /* T_PAIR */
  obj car;
  obj cdr;
} pair;

typedef struct {
  long type; /* T_SYM */
  char * value;
} symbol;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj * closure;
obj * sp;
symbol * syms[MAX_SYMS]; /* To be replaced by a hash table */
int nsyms;

#define AFIX(o) ((o) & 1)     /* the last bit is 0 : it's a fixnum */
#define APTR(o) (!((o) & 1))  /* It's not a fixnum : it's a ref to something else */
#define ASYM(o) (((obj*)(o))[0] == T_SYM)
#define APAIR(o) (((obj*)(o))[0] == T_PAIR)

#define FIX2OBJ(n) (((n) << 1) + 1)
#define OBJ2FIX(o) ((o) >> 1)

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) ((obj *)(self))[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = TOS() == y ? TOBJ : NILOBJ; }
#define NEQ() { obj y = POP(); TOS() = TOS() != y ? TOBJ : NILOBJ; }

#define TYPE() { obj * p; obj y = TOS();\\
  if (AFIX(y))\\
    TOS() = SYM2OBJ(\"int\");\\
  else{\\
    p = (obj *) y;\\
    switch ((char) *p){\\
      case T_PAIR: TOS() = SYM2OBJ(\"cons\"); break;\\
      case T_SYM: TOS() = SYM2OBJ(\"sym\"); break;\\
    }\\
  }\\
}

#define LT() { obj y = POP(); TOS() = TOS() < y ? TOBJ : NILOBJ; }
#define GT() { obj y = POP(); TOS() = TOS() > y ? TOBJ : NILOBJ; }
#define LE() { obj y = POP(); TOS() = TOS() <= y ? TOBJ : NILOBJ; }
#define GE() { obj y = POP(); TOS() = TOS() >= y ? TOBJ : NILOBJ; }
#define ADD() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) + y); }
#define SUB() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) - y); }
#define MUL() { long y = OBJ2FIX(POP()); TOS() = FIX2OBJ(OBJ2FIX(TOS()) * y); }

#define CONS() { pair * p = GC_MALLOC (sizeof(pair)); p->type = T_PAIR ; p->cdr = POP(); p->car = POP(); PUSH((obj)p); }
#define CAR() { pair * p = (pair *) POP(); PUSH((obj)(p->car)); }
#define CDR() { pair * p = (pair *) POP(); PUSH((obj)(p->cdr)); }

#define PRN() { PR(); printf (\"\\n\");}

void PR(){
  pair * p;
  symbol * s;
  obj y = TOS();

  if (AFIX(y))
    printf (\"%ld\", OBJ2FIX(y));
  else if (ASYM(y)){
    s = (symbol *) y;
    printf (\"%s\", s->value);
  }
  else if (APAIR(y)){
    p = (pair *) y;
    printf (\"( \");
    PUSH(p->car); PR(); POP();
    printf (\" . \");
    PUSH(p->cdr); PR(); POP();
    printf (\" )\");
  }
}

#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH((obj)closure);

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = ((obj *)LOCAL(0))[0]; goto jump;

obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
  int i;

  for (i = 0 ; i < nsyms ; i++)
    if (strcmp (s, syms[i]->value) == 0) /* found it */
      return (obj) syms[i];

  if (nsyms == MAX_SYMS){ /* Bad luck, really... */
    fprintf (stderr, \"Sorry, we just ran out of symbols. Please come back later...\\n\");
    exit (1);
  }

  syms[nsyms]        = malloc (sizeof(symbol)); /* Symbols never go away, then can be malloc-ed */
  syms[nsyms]->type  = T_SYM;
  syms[nsyms]->value = (char *) malloc (strlen (s) + 1);
  strcpy (syms[nsyms]->value, s);

  return (obj) syms[nsyms++];
}

obj execute (void)
{
  int pc     = 0;
  sp         = stack;
  obj NILOBJ = SYM2OBJ (\"nil\");
  obj TOBJ   = SYM2OBJ (\"t\");

  jump: switch (pc) {

")

(= code-suffix* "  }
  return POP();
}

int main (int argc, char * argv[]) {
  GC_INIT();
  execute();
  return 0;
}
")

;------------------------------------------------------------------------------

; debugging

(def source (ast)
  (if
    (alit ast)
       ast!val
    (aref ast)
      ((ast 'var) 'uid)
    (aset ast)
      (list 'set ((ast 'var) 'uid) (source (car ast!subx)))
    (acnd ast)
      (cons 'if (map source ast!subx))
    (aprim ast)
      (cons ast!op (map source ast!subx))
    (anapp ast)
      (if (alam (car ast!subx))
        (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
        (map source ast!subx))
    (alam ast)
      (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
    (aseq ast)
      (cons 'do (map source ast!subx))
    (aquote ast)
      (cons 'quote ast!subx)
      ; if unknown AST, then probably still in list form
      ; (cref driver)
      ast))

(def ds (ast)
   (if
      (alit ast)
          (cons 'lit ast!val)
      (aref ast)
         (cons 'ref ((ast 'var) 'uid))
      (aset ast)
         (cons 'set (list 'set ((ast 'var) 'uid) (ds (car ast!subx))))
      (acnd ast)
         (cons 'cnd (cons 'if (map ds ast!subx)))
      (aprim ast)
         (cons 'prim (cons ast!op (map ds ast!subx)))
      (anapp ast)
      (cons 'app
         (if (alam (car ast!subx))
            (list 'let (map (fn (p a) (list p!uid (ds a))) ((car ast!subx) 'params) (cdr ast!subx)) (ds (car ((car ast!subx) 'subx))))
            (map ds ast!subx)))
      (alam ast)
         (cons 'lam (list 'fn (map [_ 'uid] ast!params) (ds (car ast!subx))))
      (aseq ast)
         (cons 'seq (cons 'do (map ds ast!subx)))
         ast))

; abstract away avoiding ' and the quoted parts of `
; body *must* return the value in 'var if it won't
; change anything
(mac code-walk (var code . body)
  (w/uniq usercode
    `(let ,usercode (fn (,var) ,@body)
       (*code-walk-internal ,usercode ,code))))

(def *code-walk-internal (usercode code)
  (let pass-to-user
       (fn (c)
         (let new-code (usercode c)
           (if (isnt new-code c)
               ; if change, rewalk the new code
               ; (don't move on unless code is stable)
               (*code-walk-internal usercode new-code)
               (if (acons new-code)
                   (map [*code-walk-internal usercode _] new-code)
                   new-code))))
    (if (acons code)
        (if
          (is (car code) 'quote)
            code
          (is (car code) 'quasiquote)
            (list 'quasiquote
               ((rfn quasiwalk (code)
                   (if (acons code)
                       (if
                         (is (car code) 'unquote)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         (is (car code) 'unquote-splicing)
                           (list 'unquote (*code-walk-internal usercode
                                                               (cadr code)))
                         ; else
                           (map quasiwalk code))
                       code))
                 (cadr code)))
          ; else
            (pass-to-user code))
        (pass-to-user code))))

(def to-3-if (l)
  (code-walk code l
    (if
      (and (caris code 'if) (len> code 4))
        (let (_ c v . rest) code
          `(if ,c ,v (if ,@rest)))
      ; else
        code)))

; When self-compiling, probably need to define
; ssyntax and ssexpand lib functions
(def symbol-syntax (l)
  (code-walk code l
    (if
      (and (acons code) (ssyntax:car code))
        (let (fun . args) code
          (zap ssexpand fun)
          (if (caris fun 'compose)
              ((afn ((fun . rest))
                 (if rest
                     `(,fun ,(self rest))
                     `(,fun ,@args)))
               (cdr fun))
              `(,fun ,@args)))
      (ssyntax code)
        (ssexpand code)
      code)))

; handles (toplevel) 'load and 'require
; inefficiency note: allocs a lot of cons cells
(def include-files (l)
  (mappend
    (fn (e)
      ; if it's a 'load or 'require, include it
      (if (and (acons e) (in (car e) 'load 'require))
          (let (_ file . oops) e
            (when oops
              (err:string "Too many parameters to: " (car e)))
            ; make sure to recursively handle including files
            (include-files
              (w/infile s file
                (readall s (list 'detect-eof)))))
          (list e)))
    l))

;------------------------------------------------------------------------------

(def strip-ext (filename)
  (cut filename 0 (pos #\. filename)))

(def compile-file (filename (o debugmode t))
  (with (d (w/infile s filename (cons 'do (readall s (list 'detect-eof))))
         chain
         `(
            ; --------List form
            (,include-files "FILE INCLUSION")
            ; NOTE: all the 'code-walk passes might be
            ; better off in a single pass (just use a large
            ; 'if block).  Especially with regards to macros
            ; and symbol syntax: a ssyntax might emit a macro,
            ; which might emit a ssyntax, which might emit
            ; a macro... 'code-walk can actually handle this
            ; but only if macros and ssyntax expansion are
            ; in the same 'code-walk block
            (,symbol-syntax "ssyntax TRANSFORMATION")
            (,to-3-if "3-arg-if TRANSFORMATION")
            ; --------AST form
            (,[xe _ ()] "AST TRANSFORMATION")
            (,cps-convert "CPS-CONVERSION")
            (,closure-convert "CLOSURE-CONVERSION")))
    (= xe-global-cte* (make-initial-cte))
    (= d
      (reduce (fn (old-d (f desc))
                (let new-d (f old-d)
                  (when debugmode
                    (prn "------------------------------ " desc)
                    (prn (source new-d)))
                  new-d))
              chain d))
    (w/outfile f (+ (strip-ext filename) ".c")
      (w/stdout f
        (prn:liststr:code-generate d)))))