/* generate a REXX-program, testing classes */

/* generating a program with simple inheritance */

PARSE ARG outFile


/* define structure of classes */
stru. = ""
i = 0

/* define metaclass tree */
i = i + 1
stru.i.class                    = "Meta_Class"  /* name of class                   */
stru.i.subclass                 = "class"       /* subclassing                     */
stru.i.classTop                 = .true         /* top level no forwarding anymore */
stru.i.instanceTop              = .true         /* top level no forwarding anymore */

i = i + 1
stru.i.class                    = "Meta_Class_Sub1"
stru.i.subclass                 = "Meta_Class"

i = i + 1
stru.i.class                    = "Meta_Class_Sub2"
stru.i.subclass                 = "Meta_Class"

i = i + 1
stru.i.class                    = "Meta_Class_Sub1_1"
stru.i.subclass                 = "Meta_Class_Sub1"   
stru.i.metaclass                = "Meta_Class_Sub2"   /* ! */

i = i + 1
stru.i.class                    = "Meta_Class_Sub1_1_1"
stru.i.subclass                 = "Meta_Class_Sub1_1"

i = i + 1
stru.i.class                    = "Meta_Class_Sub3"
stru.i.subclass                 = "Meta_Class"



/* define object class tree */

i = i + 1
stru.i.class                    = "B_Object_Class"
stru.i.mixinclass               = "Object"
stru.i.metaclass                = "Meta_Class_Sub1"   /* ! */
stru.i.instanceTop              = .true         /* top level no forwarding anymore */

i = i + 1
stru.i.class                    = "C1_Object_Class"
stru.i.metaclass                = "Meta_Class_Sub3"   /* ! */
stru.i.mixinclass               = "B_Object_Class"

stru.0 = i                      /* total entries into stem */

/* ------------------------------------------------------------------------- */

CALL STREAM outFile, "C", "OPEN REPLACE"

CALL build_top stru., outFile           /* build head of program */
CALL build_classes stru., outFile       /* build classes */


CALL STREAM outFile, "C", "CLOSE"       /* close file */
EXIT


BUILD_TOP : PROCEDURE                   /* build head of program */
   USE ARG stru., outFile

   CALL LINEOUT outFile, "/*" DATE("S") TIME() "*/"
   CALL LINEOUT outFile, "SAY"
   CALL LINEOUT outfile, "SAY CENTER( ' initialization ended ', 79, '=' )"
   CALL LINEOUT outFile, "SAY"
   CALL LINEOUT outFile, "SAY"
   CALL LINEOUT outFile, ""
   DO i = 1 TO stru.0           /* build code to create an instance */
      CALL LINEOUT outfile, ""
      CALL LINEOUT outfile, "/* ------------------------------------------------------------- */"
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "SAY LEFT( '', 79, 'v') "
      CALL LINEOUT outfile, ""
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "SAY 'creating an instance (abc) of class" pp( stru.i.class ) || ":'"
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "abc = ." || stru.i.class || " ~ new( .true ) "
      CALL LINEOUT outfile, ""
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "SAY '*** running: abc ~ rgf (of class" pp( stru.i.class ) || "):'"
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "abc ~ rgf"
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "SAY LEFT( '', 40, '-') "
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "SAY '*** running: abc ~ class ~ rgf ( of class' pp( ."stru.i.class" )'):'"
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "abc ~ class ~ rgf"
      CALL LINEOUT outfile, "SAY"
      CALL LINEOUT outfile, "SAY LEFT( '', 79, '^') "
      CALL LINEOUT outfile, "SAY"
   END

   CALL LINEOUT outfile, ""
   CALL LINEOUT outfile, ""
   CALL LINEOUT outfile, ":: ROUTINE pp; RETURN '[' || ARG( 1 ) || ']' "
   CALL LINEOUT outfile, ""
   RETURN


BUILD_CLASSES : PROCEDURE               /* build classes */
   USE ARG stru., outFile

   maxLength = 0                        /* determine maximum length of class name */
   DO i = 1 TO Stru.0
      maxLength = MAX( maxLength, LENGTH( stru.i.class ) )
   END 

   DO i = 1 TO Stru.0
      CALL LINEOUT outFile, "/*" CENTER( '' , 70, '*' ) "*/"
      CALL LINEOUT outFile, "/*" CENTER( ' defining class ' pp( stru.i.class) , 70 ) "*/"
      CALL LINEOUT outFile, "/*" CENTER( '' , 70 ) "*/"

      tmpString = ":: CLASS" LEFT( stru.i.class, maxLength )

      IF stru.i.subclass = "" & stru.i.mixinclass = "" THEN
         tmpString = tmpString "SUBCLASS  " LEFT( "object", maxLength )
      ELSE
      DO
         IF stru.i.subclass <> "" THEN tmpString = tmpString "SUBCLASS  " LEFT( stru.i.subclass, maxLength )
                                  ELSE tmpString = tmpString "MIXINCLASS" LEFT( stru.i.mixinclass, maxLength )
      END

      IF stru.i.metaclass <> ""   THEN tmpString = tmpString "METACLASS" LEFT( stru.i.metaclass, maxLength )
                                  ELSE tmpString = tmpString "         " LEFT( ""              , maxLength )

      IF stru.i.inherit <> ""     THEN tmpString = tmpString "INHERIT" stru.i.inherit 

      CALL LINEOUT outfile, tmpString   /* write class definition */
      CALL LINEOUT outfile, ""

      CALL buildMethods stru., i, outFile, tmpString  /* build methods */

      CALL LINEOUT outfile, ""
      CALL LINEOUT outfile, ""
      CALL LINEOUT outfile, ""
   END
   RETURN


 

BUILDMETHODS : PROCEDURE
   USE ARG stru., index, outFile, classDefinition

   class = stru.index.class             /* get class */

   scope = .array ~ of( "CLASS", "" )   /* CLASS and instance scope */
   scopeName = .array ~ of( "CLASS", "INSTANCE" )

   DO methName OVER .methods            /* loop over .methods methods */
      bStop = ABBREV( methName, "STOP" )        /* stop-method in hand (no forwarding) ? */

      PARSE VAR methName . "_" trueName /* extract desired method name */

      DO i = 1 TO 2
         IF i = 1    /* class level */ THEN
         DO
            IF stru.index.classTop    = .true & \ bStop THEN ITERATE
            IF stru.index.classTop    = ""    & bStop   THEN ITERATE
         END
         ELSE        /* instance level */
         DO
            IF stru.index.instanceTop = .true & \ bStop THEN ITERATE
            IF stru.index.instanceTop = ""    & bStop   THEN ITERATE
         END

         CALL LINEOUT outFile, ":: METHOD" trueName scope[ i ]

         tmpArray = .methods ~ entry( methName ) ~ source       /* get source */

         DO j = 1 TO tmpArray ~ items
            tmp = tmpArray[ j ]
            tmp = xlate( tmp, "?CLASS?", class )                /* replace placeholders */
            tmp = xlate( tmp, "?SCOPE?", scopeName[ i ] )
            tmp = xlate( tmp, "?METHOD?", trueName )
            tmp = xlate( tmp, "?CLASS_DEF?", classDefinition )

            CALL LINEOUT outfile, tmp           /* write line */
         END
         CALL LINEOUT outfile, ""
         CALL LINEOUT outfile, "/*" LEFT( "", 40, "-" ) "*/"
         CALL LINEOUT outfile, ""
      END
   END

   RETURN

xlate : procedure
   USE ARG string, from, to
   RETURN CHANGESTR( from, string, to )




:: ROUTINE PP   
   RETURN "[" || ARG( 1 ) || "]"

/* "template" methods, 
    ?CLASS?             ... class in hand
    ?CLASS_DEF?         ... full class definition
    ?METHOD?            ... method in hand
    ?SCOPE?             ... scope (class/instance) method is executing at
*/

/* ---------------------------------------------------------- */
:: METHOD start_init

   IF .local ~ level = .nil THEN .local ~ level = 0
   IF .level = 0 THEN           /* start initializing a new class */
   DO
      SAY
      SAY CENTER( "Begin of initializing" pp( '?CLASS?' ) "at scope" pp( '?SCOPE?' ), "79", "*" )
      SAY "( CLASS definition:" pp( STRIP( "?CLASS_DEF?" ) ) ")"
      SAY
   END
   .local ~ level = .level + 1  

   /* forward up to next class */
   SAY ">>>      in " pp( "?CLASS?::?METHOD?::?SCOPE?" ) ", doing a: 'FORWARD CLASS( super )' ..."
   FORWARD CLASS( super ) ARRAY ( .false )  CONTINUE
   SAY "<<< back in " pp( "?CLASS?::?METHOD?::?SCOPE?" ) 


   /* at instance level do a cross-call, but only for the initial class */
   IF "?SCOPE?" = "INSTANCE" & .level = 0 THEN  
   DO
      SAY
      SAY "    now cross calling: .?CLASS? ~ rgf at" pp( "?CLASS?::?METHOD?::?SCOPE?" )
      SAY
      .?CLASS? ~ rgf
      SAY
      SAY "    back from  x-call: .?CLASS? ~ rgf at" pp( "?CLASS?::?METHOD?::?SCOPE?" )
      SAY
   END
   SAY "--- end of  " pp( "?CLASS?::?METHOD?::?SCOPE?" ) 

   .local ~ level = .level - 1
   IF .level = 0 THEN
   DO
      SAY
      SAY CENTER( "end of initializing" pp( '?CLASS?' ) "at scope" pp( '?SCOPE?' ), "79", "*" )
      SAY
   END
   SAY


/* ---------------------------------------------------------- */
:: METHOD stop_init

   IF .local ~ level = .nil THEN .local ~ level = 0
   IF .level = 0 THEN
   DO
      SAY
      SAY CENTER( "Begin of initializing" pp( '?CLASS?' ) "at scope" pp( '?SCOPE?' ), "79", "*" )
      SAY "( CLASS definition:" pp( STRIP( "?CLASS_DEF?" ) ) ")"
      SAY
   END
   .local ~ level = .level + 1

   SAY ">>>      in " pp( "?CLASS?::?METHOD?::?SCOPE?" ) ", no more forwarding (top level) !"
   SAY "--- end of  " pp( "?CLASS?::?METHOD?::?SCOPE?" ) 
   SAY

   .local ~ level = .level - 1
   IF .level = 0 THEN
   DO
      SAY
      SAY CENTER( "end of initializing" pp( '?CLASS?' ) "at scope" pp( '?SCOPE?' ), "79", "*" )
      SAY
   END
   SAY


/* ---------------------------------------------------------- */
:: METHOD start_rgf

   SAY "-->      in " pp( "?CLASS?::?METHOD?::?SCOPE?" ) ", doing a: 'FORWARD CLASS( super )' ..."
   FORWARD CLASS( super ) CONTINUE
   SAY "<-- back in " pp( "?CLASS?::?METHOD?::?SCOPE?" )
   SAY "--- end of  " pp( "?CLASS?::?METHOD?::?SCOPE?" )
   SAY LEFT( "", 79, "." )


/* ---------------------------------------------------------- */
:: METHOD stop_rgf

   SAY "-->      in " pp( "?CLASS?::?METHOD?::?SCOPE?" ) ", no more forwarding (top level) !"
   SAY "<-- end of  " pp( "?CLASS?::?METHOD?::?SCOPE?" )
   SAY