/* ---rgf, 97-08-25     */


classes = "META1 META2 META3 META4 /" ,
          "A1  B1  C1  D1  E1 /" ,
          "A1m B1m C1m D1m E1m "

DO WHILE classes <> ""
   PARSE VAR classes tmpString classes
   IF tmpString = "/" THEN
   DO
      SAY ; SAY LEFT( "", 79, "*" ); SAY LEFT( "", 79, "*" ); SAY LEFT( "", 79, "*" ); SAY
      ITERATE
   END


   INTERPRET "tmpClass = ." || tmpString
   tmp= pp( tmpClass ~ ID ) "-->",
       "SUPERC[1]=" || pp( tmpClass ~ Superclasses[ 1 ] ~ ID ) ,
       "METAC="       || pp( tmpClass ~ Metaclass ~ ID ) ,
       "CLASS="           || pp( tmpClass ~ class ~ ID ) ,
       "BASEC="       || pp( tmpClass ~ baseclass ~ ID )

   IF ( tmpClass ~ Metaclass ~ ID ) <> ( tmpClass ~ class ~ ID ) THEN
      tmp = tmp "?*"

   SAY tmp
END

SAY; SAY; SAY ; SAY LEFT( "", 79, "*" ); SAY LEFT( "", 79, "*" ); SAY LEFT( "", 79, "*" ); SAY; SAY; SAY

        /* create instances     */
instances = "META1 META2 META3 META4 /" ,
          "A1  B1  C1  D1  E1 /" ,
          "A1m B1m C1m D1m E1m "

DO WHILE instances <> ""
   PARSE VAR instances tmpString instances
   IF tmpString = "/" THEN
   DO
      SAY ; SAY LEFT( "", 79, "*" ); SAY LEFT( "", 79, "*" ); SAY LEFT( "", 79, "*" ); SAY
      ITERATE
   END

   SAY LEFT("", 79, "=" )
   bCreateMeta = ( POS( "META", tmpString ) > 0 ) | ( POS( "1m", tmpString ) > 0 )

   IF bCreateMeta THEN exeString = "anObj = ." || tmpString || " ~ new(' " tmpString "instance 2' )"
                  ELSE exeString = "anObj = ." || tmpString || " ~ new"
   INTERPRET exeString

   CALL dump anObj              /* dump the instance    */

level = 1
do forever
   IF anObj ~ hasmethod( "NEW" ) THEN           /* "NEW" is a class method, hence a class object in hand */
   DO
      bDumpMeta =  ( anObj ~ class <> .class )
      metaClassObj = anObj ~ class              /* get metaclass-object                 */
   END
   ELSE
   DO
      metaClassObj = anObj ~ class ~ class      /* get metaclass-object                 */
      bDumpMeta =  ( anObj ~ class ~ class <> .class  )   /* meta class of object class instance  */
   END

   IF bDumpMeta THEN                            /* using a user defined meta-class ?    */
   DO
      SAY CENTER( "+++ +++ user defined metaclass +++ +++ level" level, 80 )
      CALL dump metaClassObj, ">", "<"
   END
else leave

anObj = metaClassObj    /* dump metaclass */
level = level + 1

end

END


EXIT

dump : PROCEDURE
   USE ARG anObj, filler1, filler2

   IF \ VAR( "FILLER1" ) THEN filler1 = "/"
   IF \ VAR( "FILLER2" ) THEN filler2 = "\"

   SAY
   SAY "anObj ~ rgf" pp2( anObj )
   SAY LEFT("", 50, filler1 )
   anObj ~ rgf
   SAY LEFT("", 50, filler1 )

   SAY
   SAY "anObj ~ class ~ rgf" pp2( anObj ~ class )
   SAY LEFT("", 50, filler2 )

   IF anObj ~ class = .class THEN
      SAY "... metaclass is ORX's .class ... NOP ..."
   ELSE
      anobj ~ class ~ rgf

   SAY "( anObj ~ class ~ class:" anObj ~ class ~ class ")"
   SAY LEFT("", 50, filler2 )
   SAY
   RETURN


pp : RETURN LEFT( "[" || ARG( 1 ) || "]", 8 )
pp2: RETURN       "[" || ARG( 1 ) || "]"

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

:: CLASS META1  SUBCLASS Class
   :: METHOD rgf CLASS
      IF super ~ HASMETHOD( "RGF" )
           THEN DO; SAY "META1::RGF::CLASS    invoked ..."; FORWARD CLASS( super ); END;
           ELSE     SAY "META1::RGF::CLASS    invoked (no FORWARDING ANYMORE )"

   :: METHOD rgf
      IF super ~ HASMETHOD( "RGF" )
           THEN DO; SAY "META1::RGF::INSTANCE invoked ..."; FORWARD CLASS( super ); END;
           ELSE     SAY "META1::RGF::INSTANCE invoked (no FORWARDING ANYMORE )"

:: CLASS META2  SUBCLASS META1
   :: METHOD rgf CLASS ; SAY "META2::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "META2::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS META3  SUBCLASS META2  METACLASS META1
   :: METHOD rgf CLASS ; SAY "META3::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "META3::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS META4  SUBCLASS META3
   :: METHOD rgf CLASS ; SAY "META4::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "META4::RGF::INSTANCE invoked..."; FORWARD CLASS( super )



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

:: CLASS A1
   :: METHOD rgf CLASS
      IF super ~ HASMETHOD( "RGF" )
           THEN DO; SAY "A1::RGF::CLASS       invoked .."; FORWARD CLASS( super ); END;
           ELSE     SAY "A1::RGF::CLASS       invoked (no FORWARDING ANYMORE )"

   :: METHOD rgf ;
      IF super ~ HASMETHOD( "RGF" )
           THEN DO; SAY "A1::RGF::INSTANCE    invoked .."; FORWARD CLASS( super ); END;
           ELSE     SAY "A1::RGF::INSTANCE    invoked (no FORWARDING ANYMORE )"

:: CLASS B1     MIXINCLASS A1   METACLASS META2
   :: METHOD rgf CLASS ; SAY "B1::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "B1::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS C1     MIXINCLASS B1
   :: METHOD rgf CLASS ; SAY "C1::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "C1::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS D1     MIXINCLASS A1     METACLASS META3
   :: METHOD rgf CLASS ; SAY "D1::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "D1::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS E1     MIXINCLASS D1
   :: METHOD rgf CLASS ; SAY "E1::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "E1::RGF::INSTANCE invoked..."; FORWARD CLASS( super )


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


:: CLASS A1m     SUBCLASS Class
   :: METHOD rgf CLASS
      IF super ~ HASMETHOD( "RGF" )
           THEN DO; SAY "A1m::RGF::CLASS       invoked .."; FORWARD CLASS( super ); END;
           ELSE     SAY "A1m::RGF::CLASS       invoked (no FORWARDING ANYMORE )"

   :: METHOD rgf ;
      IF super ~ HASMETHOD( "RGF" )
           THEN DO; SAY "A1m::RGF::INSTANCE    invoked .."; FORWARD CLASS( super ); END;
           ELSE     SAY "A1m::RGF::INSTANCE    invoked (no FORWARDING ANYMORE )"

:: CLASS B1m     MIXINCLASS A1m   METACLASS META2
   :: METHOD rgf CLASS ; SAY "B1m::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "B1m::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS C1m     MIXINCLASS B1m
   :: METHOD rgf CLASS ; SAY "C1m::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "C1m::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS D1m     MIXINCLASS A1m     METACLASS META3
   :: METHOD rgf CLASS ; SAY "D1m::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "D1m::RGF::INSTANCE invoked..."; FORWARD CLASS( super )

:: CLASS E1m     MIXINCLASS D1m
   :: METHOD rgf CLASS ; SAY "E1m::RGF::CLASS    invoked..."; FORWARD CLASS( super )
   :: METHOD rgf ;       SAY "E1m::RGF::INSTANCE invoked..."; FORWARD CLASS( super )




/*
      :: CLASS META1  SUBCLASS Class
      :: CLASS META2  SUBCLASS META1
      :: CLASS META3  SUBCLASS META2  METACLASS META1
      :: CLASS META4  SUBCLASS META3

      :: CLASS A1
      :: CLASS B1     MIXINCLASS A1   METACLASS META2
      :: CLASS C1     MIXINCLASS B1
      :: CLASS D1     MIXINCLASS A1   METACLASS META3
      :: CLASS E1     MIXINCLASS D1

      :: CLASS A1m    SUBCLASS Class
      :: CLASS B1m    MIXINCLASS A1m  METACLASS META2
      :: CLASS C1m    MIXINCLASS B1m
      :: CLASS D1m    MIXINCLASS A1m  METACLASS META3
      :: CLASS E1m    MIXINCLASS D1m
*/