fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

see changelog

Browse Source
This commit is contained in:
Eddie Runia
1999-06-01 17:27:54 +00:00
parent 8cf924a706
commit 700a198a27
5 changed files with 98 additions and 46 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
harbour/ChangeLog
View File

@@ -1,3 +1,7 @@
19990601-18:15 CET Eddie Runia
* tests/working/inherit.prg, source/rtl/classes.c, source/rtl/tclass.prg
version correct release (+ super )
19990601-12:00 EDT David G. Holm <dholm@jsd-llc.com>
* makefile.b31
- Ran into problems using GT API with tests\working\mathtest, so removed

17
harbour/source/rtl/classes.c
View File

@@ -17,6 +17,7 @@ void Function( WORD wParams );
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#define MET_SUPER 5
typedef struct
{
@@ -217,6 +218,17 @@ static HARBOUR Virtual( void )
_ret();
}
static HARBOUR SelectSuper( void )
{
PITEM pObject = stack.pBase + 1;
PITEM pSuper = hb_arrayClone( pObject );
WORD wSuperCls = pMethod->wData;
ItemCopy( &stack.Return, pSuper );
( (PBASEARRAY) (stack.Return.value.pBaseArray) )->wClass = wSuperCls;
hb_itemRelease( pSuper );
}
static HARBOUR ClassName( void )
{
WORD wClass = IS_ARRAY( stack.pBase + 1 ) ?
@@ -398,6 +410,11 @@ HARBOUR CLASSADD() /* hClass, cMessage, pFunction, nType, xInit */
pClass->pMethods[ wAt ].pFunction = Virtual;
break;
case MET_SUPER:
pClass->pMethods[ wAt ].wData = _parnl( 3 );
pClass->pMethods[ wAt ].pFunction = SelectSuper;
break;
default:
printf( "Invalid method type from ClassAdd\n" );
exit( 1 );

37
harbour/source/rtl/tclass.prg
View File

@@ -5,6 +5,7 @@
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#define MET_SUPER 5
#define DAT_SYMBOL 1
#define DAT_INITVAL 2
@@ -41,15 +42,15 @@ function TClass()
ClassAdd( hClass, "_aInlines", 6, MET_DATA )
ClassAdd( hClass, "aVirtuals", 7, MET_DATA )
ClassAdd( hClass, "_aVirtuals", 7, MET_DATA )
ClassAdd( hClass, "hSuper", 8, MET_DATA )
ClassAdd( hClass, "_hSuper", 8, MET_DATA )
ClassAdd( hClass, "xSuper", 8, MET_DATA )
ClassAdd( hClass, "_xSuper", 8, MET_DATA )
endif
return ClassInstance( hClass )
//----------------------------------------------------------------------------//
static function New( cClassName, cSuperClass )
static function New( cClassName, xSuper )
local Self := QSelf()
@@ -59,11 +60,8 @@ static function New( cClassName, cSuperClass )
::aClsDatas = {}
::aInlines = {}
::aVirtuals = {}
if ValType( cSuperClass ) != "C"
::hSuper = 0
else
::hSuper = __InstSuper( Upper ( cSuperClass ) )
// Instance super class and return class handle
if ValType( xSuper ) $ "CA"
::xSuper = xSuper
endif
return Self
@@ -74,13 +72,28 @@ static function Create()
local Self := QSelf()
local n, nLen := Len( ::aDatas )
local hClass := ClassCreate( ::cName, nLen, ::hSuper )
local nDataBegin := If( !Empty( ::hSuper ), __WDatas( ::hSuper ), 0 )
local hClass
local nDataBegin := 0
local hSuper
if ::xSuper == NIL
hClass := ClassCreate( ::cName, nLen )
elseif ValType(::xSuper) == "A" // Multiple inheritance
QOut( "Sorry, not supported yet :-)" )
elseif ValType(::xSuper) == "C" // Single inheritance
hSuper := __InstSuper( Upper( ::xSuper ) )
hClass := ClassCreate( ::cName, nLen, hSuper )
// Add class casts
ClassAdd( hClass, Upper( ::xSuper ), hSuper, MET_SUPER )
ClassAdd( hClass, "SUPER", hSuper, MET_SUPER )
nDataBegin := __WDatas( hSuper ) // Get offset for new DATAs
endif
::hClass = hClass
for n = 1 to nLen
ClassAdd( hClass, ::aDatas[ n ][ DAT_SYMBOL ], n + nDataBegin, MET_DATA, ;
::aDatas[ n ][ DAT_INITVAL ] )

82
harbour/tests/working/inherit.prg
View File

@@ -8,32 +8,43 @@
// Date : 30/05/1999
//
function Main( cFrom, cTo )
function Main()
local oFrom
local oTo
local cOut
set( _SET_EXACT, .T.)
cFrom := Default( cFrom, "strip.prg" )
cTo := Default( cTo, "strip.out" )
oFrom := TTextFile():New( cFrom, "R" )
oFrom := TOnTop() :New( "hello.prg", "R" )
oTo := TTextFile():New( "hello.out", "W" )
QOut( "What's in oFrom" )
HBDebug( { oFrom, aoMethod( oFrom ) } )
// oFrom:Super:Run()
oFrom:Set( "DoIt !" )
QOut( oFrom:Out )
oTo := TTextFile():New( cTo, "W" )
QOut()
QOut( "What's in oFrom:TEmpty" )
HBDebug( { oFrom:TEmpty, aoMethod( oFrom:TEmpty ) } )
QOut()
QOut( "Let's call Run() from TEmpty : " )
oFrom:TEmpty:Run()
QOut()
QOut( "Let's call a method from TEmpty and one from TOnTop" )
oFrom:Set( "Done !" )
oFrom:Say( "Out" )
QOut()
QOut( "Basic copy loop using the default Run() from TTextFile" )
do while !oFrom:lEoF
cOut := oFrom:Run()
if alltrim(cOut) != ""
oTo:Run( cOut )
endif
QOut( cOut )
oTo:Run( cOut )
enddo
QOut( "Number of lines", oTo:nLine )
oFrom:Dispose()
oTo:Dispose()
return nil
//
@@ -44,16 +55,14 @@ function TEmpty()
static oEmpty
if oEmpty == NIL
QOut( "I am being called indirectly" )
oEmpty := TClass():New( "TEmpty" ) // Create a new class def
oEmpty:AddInline( "New", {|self|self} )
oEmpty:AddInline( "Run", {||QOut( "Run!" ) } ) // Test command
oEmpty:AddInline( "Run", {||QOut( "Run !" )}) // Test command
// oEmpty:AddInline( "Set", {|self,xParam|::Out := xParam } )
oEmpty:AddInline( "Set", {|self,xParam| oSend(self,"_Out",xParam) } )
oEmpty:AddData( "Out", 1 ) // Test command
oEmpty:AddData( "Out", "Hi there" ) // Test command
oEmpty:AddVirtual( "Dispose" ) // Clean up code
oEmpty:Create()
@@ -61,9 +70,23 @@ function TEmpty()
return oEmpty:Instance()
//
// Let's add another one on top
//
function TOnTop()
static oOnTop
if oOnTop == NIL
oOnTop := TClass():New( "TOnTop", "TTextFile" )
oOnTop:AddInline( "Say", {|self, cArg| QOut( oSend(self, cArg) ) } )
oOnTop:Create()
endif
return oOnTop:Instance()
//
// Generic DOS file handler
// Generic Text file handler
//
function TTextFile()
@@ -90,7 +113,6 @@ function TTextFile()
oFile:AddMethod( "Read" , @Read() ) // Read line
oFile:AddMethod( "WriteLn", @WriteLn() ) // Write line
oFile:AddMethod( "Write" , @Write() ) // Write without CR
// oFile:AddMethod( "EoF" , @EoF() ) // End of file as function
oFile:AddMethod( "Goto" , @Goto() ) // Go to line
oFile:Create()
@@ -105,7 +127,7 @@ return oFile:Instance()
// <cMode> mode for opening. Default "R"
// <nBlockSize> Optional maximum blocksize
//
static function New( cFileName, cMode, nBlock )
function New( cFileName, cMode, nBlock )
local self := QSelf() // Get self
@@ -133,7 +155,7 @@ static function New( cFileName, cMode, nBlock )
return self
static function Run( xTxt, lCRLF )
function Run( xTxt, lCRLF )
local self := QSelf()
local xRet
@@ -149,7 +171,7 @@ return xRet
//
// Dispose -> Close the file handle
//
static function Dispose()
function Dispose()
local self := QSelf()
@@ -169,7 +191,7 @@ return self
//
// Read a single line
//
static function Read()
function Read()
local self := QSelf()
local cRet := ""
@@ -195,7 +217,7 @@ static function Read()
endif
if !::lEoF
::nLine := ::nLine + 1 // ++ not available
::nLine++
nCRPos := At(Chr(10), ::cBlock)
if nCRPos != 0 // More than one line read
cRet := Substr( ::cBlock, 1, nCRPos - 1)
@@ -205,7 +227,7 @@ static function Read()
::cBlock := ""
cRet += ::Read() // Read the rest
if !::lEoF
::nLine := ::nLine - 1 // Adjust erroneous line count
::nLine-- // Adjust erroneous line count
endif
endif
nEoFPos := At( Chr(26), cRet )
@@ -226,7 +248,7 @@ return cRet
// one or more strings
// <lCRLF> End with Carriage Return/Line Feed (Default == TRUE)
//
static function WriteLn( xTxt, lCRLF )
function WriteLn( xTxt, lCRLF )
local self := QSelf()
local cBlock
@@ -249,19 +271,13 @@ static function WriteLn( xTxt, lCRLF )
return self
static function Write( xTxt )
function Write( xTxt )
local self := QSelf()
return ::WriteLn( xTxt, .F. )
//function EoF()
//
// local self := QSelf()
//return ::lEoF
//
// Go to a specified line number
//
@@ -281,7 +297,7 @@ static function Goto( nLine )
fSeek(::hFile, 0) // Go top
do while !::lEoF .and. nWhere < nLine
nWhere++
::Run()
::Read()
enddo
endif
return !lEoF

4
harbour/tests/working/run_exp.h
View File

@@ -130,6 +130,7 @@ HARBOUR HB_FEOF();
HARBOUR HB_FREADLN();
HARBOUR HB_FSKIP();
HARBOUR GETENV();
HARBOUR DIRECTORY();
/* Same story.
@@ -262,7 +263,8 @@ static SYMBOL symbols[] = {
{ "HB_FEOF", FS_PUBLIC, HB_FEOF , 0 },
{ "HB_FREADLN", FS_PUBLIC, HB_FREADLN , 0 },
{ "HB_FSKIP", FS_PUBLIC, HB_FSKIP , 0 },
{ "GETENV", FS_PUBLIC, GETENV , 0 }
{ "GETENV", FS_PUBLIC, GETENV , 0 },
{ "DIRECTORY", FS_PUBLIC, DIRECTORY , 0 }
};