class.jam

C++的一个好库。。。现在很流行

#  (C) Copyright David Abrahams 2002. Permission to copy, use, modify, sell and
#  distribute this software is granted provided this copyright notice appears in
#  all copies. This software is provided "as is" without express or implied
#  warranty, and with no claim as to its suitability for any purpose.

# Polymorphic class system built on top of core Jam facilities.
#
# Classes are defined by 'class' keywords::
#
#     class myclass ( arg1 )          
#     {
#         rule __init__ ( )          # constructor
#         {
#             self.attribute = $(arg1) ;
#         }
#
#         rule method1 ( )           # method
#         {
#             return [ method2 ] ;
#         }
#
#         rule method2 ( )           # method
#         {
#             return $(self.attribute) ;
#         }
#     }
#
# The __init__ rule is the constructor, and sets member variables.
#
# New instances are created by invoking [ new <class> <args...> ]::
#
#     local x = [ new myclass foo ] ;        # x is a new myclass object
#     assert.result foo : [ $(x).method1 ] ; # $(x).method1 returns "foo"
#
# Derived class are created by mentioning base classes in the declaration::
#
#     class derived : myclass 
#     {
#          rule __init__ ( arg )
#          {
#              myclass.__init__ $(arg) ;  # call base __init__
#
#          }
#
#          rule method2 ( )           # method override
#          {
#              return $(self.attribute)XXX ;
#          }
#     }
#
# All methods operate virtually, replacing behavior in the base
# classes. For example::
#
#     local y = [ new derived foo ] ;           # y is a new derived object
#     assert.result fooXXX : [ $(y).method1 ] ; # $(y).method1 returns "foo"
#
# Each class instance is its own core Jam module. All instance
# attributes and methods are accessible without additional
# qualification from within the class instance. All rules imported in
# class declaration, or visible in base classses are also visible.
# Base methods are available in qualified form: base-name.method-name.
# By convention, attribute names are prefixed with "self.".

import numbers ;
import errors : * ;
import set ;
import modules ;
import assert ;

classes = ;


rule xinit ( instance : class )
{
    module $(instance)
    {
        __class__ = $(2) ;
        __name__ = $(1) ;
    }    
}


rule new ( class args * : * )
{
    .next-instance.$(class) ?= 1 ;
    local id = object($(class))@$(.next-instance.$(class)) ;
    
    xinit $(id) : $(class) ;    
       
    INSTANCE $(id) : class@$(class) ;
    IMPORT_MODULE $(id) : ;
    $(id).__init__ $(args) : $(2) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
          
    # bump the next unique object name
    .next-instance.$(class) = [ numbers.increment $(.next-instance.$(class)) ] ;
    
    # Return the name of the new instance.
    return $(id) ;
}


rule bases ( class )
{
    #if ! ( $(class) in $(classes) )
    #{
    #    error class $(class) not defined ;
    #}
    
    module class@$(class)
    {
        return $(__bases__) ;
    }
}

rule is-derived ( class : bases + )
{
    #local all = $(class) $(bases) ;
    #if ! ( $(all) in $(classes) )
    #{
    #    error class(es) [ set.difference $(class) $(bases) : $(classes) ] not defined ;
    #}
    
    local stack = $(class) ;
    local visited found ;
    while ( ! $(found) ) && $(stack)
    {
        local top = $(stack[1]) ;
        stack = $(stack[2-]) ;
        if ! ( $(top) in $(visited) )
        {
            visited += $(top) ;
            stack += [ bases $(top) ] ;
            
            if $(bases) in $(visited)
            {
                found = true ;
            }
        }
    }
    return $(found) ;
}

# Returns true if the 'value' is a class instance.
rule is-instance ( value # The value to check 
     )
{
    return [ MATCH "^(object\\()[^@]+\\)@.*" : $(value) ] ;        
}

# Check if the given value is of the given type.
#
rule is-a (
    instance # The value to check.
    : type # The type to test for.
    )
{
    if [ is-instance $(instance) ]
    {
        return [ class.is-derived [ modules.peek $(instance) : __class__ ] : $(type) ] ;
    }
}

local rule typecheck ( x )
{
    local class-name = [ MATCH "^\\[(.*)\\]$" : [ BACKTRACE 1 ] ] ;
    if ! [ is-a $(x) : $(class-name) ]
    {
        return "Expected an instance of "$(class-name)" but got \""$(x)"\" for argument" ;
    }
}

local rule __test__ ( )
{
    import "class" : * ;
    import assert ;
    import errors : * ;

    # This will be the construction function for a class called
    # 'myclass'
    class myclass 
    {
        import assert : nonempty-variable ;        
        
        rule __init__ ( x_ * : y_ * )
        {            
            # set some instance variables
            x = $(x_) ;
            y = $(y_) ;
            foo += 10 ;
        }
        
        rule set-x ( newx * )
        {
            x = $(newx) ;
        }

        rule get-x ( )
        {
            return $(x) ;
        }

        rule set-y ( newy * )
        {
            y = $(newy) ;
        }

        rule get-y ( )
        {
            return $(y) ;
        }

        rule f ( )
        {
            return [ g $(x) ] ;
        }

        rule g ( args * )
        {
            if $(x) in $(y)
            {
                return $(x) ;
            }
            else if $(y) in $(x)
            {
                return $(y) ;
            }
            else
            {
                return ;
            }
        }

        rule get-class ( )
        {
            return $(__class__) ;
        }
        
        rule get-instance ( )
        {
            return $(__name__) ;
        }
        
        rule invariant ( )
        {
            assert.equal 1 : 1 ;
        }                
        
        rule get-foo ( )
        {
            return $(foo) ;
        }                        
    }
#    class myclass ;

    class derived1 : myclass
    {        
        rule __init__ ( z_ )
        {
            myclass.__init__ $(z_) : X ;
            z = $(z_) ;            
        }
        
        # override g
        rule g ( args * )
        {
            return derived1.g ;
        }

        rule h ( )
        {
            return derived1.h ;
        }

        rule get-z ( )
        {
            return $(z) ;
        }

        # Check that 'assert.equal' visible in base class is visible
        # here.
        rule invariant2 ( )
        {
            assert.equal 2 : 2 ;
        }                
        
        # Check that 'nonempty-variable' visible in base class is
        # visible here.
        rule invariant3 ( )
        {
            local v = 10 ;
            nonempty-variable v ;
        }                
    }
#    class derived1 : myclass ;

    class derived2 : myclass 
    {
        rule __init__ ( )
        {            
            myclass.__init__ 1 : 2 ;
        }
        
        # override g
        rule g ( args * )
        {
            return derived2.g ;
        }

         rule get-x ( )
         {
             # Test the ability to call base class functions with qualification.
             return [ myclass.get-x ] ;
         }
    }
#    class derived2 : myclass ;

    class derived2a : derived2
    {
        rule __init__ 
        {
            derived2.__init__ ;
        }                
    }
#    class derived2a : derived2 ;

    local rule expect_derived2 ( [derived2] x ) { }

    local a = [ new myclass 3 4 5 : 4 5 ] ;
    local b = [ new derived1 4 ] ;
    local b2 = [ new derived1 4 ] ;
    local c = [ new derived2 ] ;
    local d = [ new derived2 ] ;
    local e = [ new derived2a ] ;

    expect_derived2 $(d) ;
    expect_derived2 $(e) ;

    # argument checking is set up to call exit(1) directly on
    # failure, and we can't hijack that with try, so we'd better
    # not do this test by default.  We could fix this by having
    # errors look up and invoke the EXIT rule instead; EXIT can be
    # hijacked (;-)
    if --fail-typecheck in [ modules.peek : ARGV ]
    {
        try ;
        {
            expect_derived2 $(a) ;
        }
        catch
          "Expected an instance of derived2 but got" instead
          ;
    }


    #try ;
    #{
    #    new bad_subclass ;
    #}
    #catch
    #  bad_subclass.bad_subclass failed to call base class constructor myclass.__init__
    #  ;

    #try ;
    #{
    #    class bad_subclass ;
    #}
    #catch bad_subclass has already been declared ;

    assert.result 3 4 5 : $(a).get-x ;
    assert.result 4 5 : $(a).get-y ;
    assert.result 4 : $(b).get-x ;
    assert.result X : $(b).get-y ;
    assert.result 4 : $(b).get-z ;
    assert.result 1 : $(c).get-x ;
    assert.result 2 : $(c).get-y ;
    assert.result 4 5 : $(a).f ;
    assert.result derived1.g : $(b).f ;
    assert.result derived2.g : $(c).f ;
    assert.result derived2.g : $(d).f ;
    
    assert.result 10 : $(b).get-foo ;
    
    $(a).invariant ;
    $(b).invariant2 ;
    $(b).invariant3 ;
    
    # Check that the __class__  attribute is getting properly set.
    assert.result myclass : $(a).get-class ;
    assert.result derived1 : $(b).get-class ;
    assert.result $(a) : $(a).get-instance ;

    $(a).set-x a.x ;
    $(b).set-x b.x ;
    $(c).set-x c.x ;
    $(d).set-x d.x ;
    assert.result a.x : $(a).get-x ;
    assert.result b.x : $(b).get-x ;
    assert.result c.x : $(c).get-x ;
    assert.result d.x : $(d).get-x ;

    class derived3 : derived1 derived2 
    {
        rule __init__ ( )
        {
        }
    }
    

    assert.result : bases myclass ;
    assert.result myclass : bases derived1 ;
    assert.result myclass : bases derived2 ;
    assert.result derived1 derived2 : bases derived3 ;

    assert.true is-derived derived1 : myclass ;
    assert.true is-derived derived2 : myclass ;
    assert.true is-derived derived3 : derived1 ;
    assert.true is-derived derived3 : derived2 ;
    assert.true is-derived derived3 : derived1 derived2 myclass ;
    assert.true is-derived derived3 : myclass ;

    assert.false is-derived myclass : derived1 ;

    assert.true is-instance $(a) ;
    assert.false is-instance bar ;

    assert.true is-a $(a) : myclass ;
    assert.true is-a $(c) : derived2 ;
    assert.true is-a $(d) : myclass ;
    assert.false is-a literal : myclass ;
}