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-03 17:35:10 +00:00
parent e7f9a7ea33
commit 2b8e163a10
7 changed files with 641 additions and 817 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
harbour/ChangeLog
View File

@@ -1,3 +1,10 @@
19990603-18:30 CET Eddie Runia
* source/rtl/classes.c; source/rtl/tclass.prg; source/rtl/arrays.c
* include/ctoharb.h; include/extend.h
New class module added with lots of commands and alphabetic order.
aClone() no longer necessary for super casting
ctoharb.h updated so the forward declarations could be removed.
19990603-16:00 CET Eddie Runia
* source/rtl/classes.c
wLimit bug resolved

2
harbour/include/ctoharb.h
View File

@@ -5,6 +5,7 @@
/* Calling Harbour from C code */
/* executing Harbour code from C */
void Message( PSYMBOL );
void PushSymbol( PSYMBOL pSym ); /* pushes a function pointer onto the stack */
void Push( PITEM pItem ); /* pushes any item to the stack */
void PushNil( void ); /* in this case it places nil at self */
@@ -13,6 +14,7 @@ void PushInteger( int iNumber );
void PushLong( long lNumber );
void PushDouble( double dNumber, WORD wDec );
void PushString( char * szText, WORD wLength ); /* pushes a string on to the stack */
void PushSymbol( PSYMBOL );
void Do( WORD wParams ); /* invokes the virtual machine */
void Function( WORD wParams ); /* invokes the virtual machine */
void StackShow( void );

1
harbour/include/extend.h
View File

@@ -80,6 +80,7 @@ typedef struct
ULONG ulLen; /* number of items in the array */
WORD wHolders; /* number of holders of this array */
WORD wClass; /* offset to the classes base if it is an object */
WORD wSuperCast; /* is it a super cast ? */
} BASEARRAY, * PBASEARRAY;
typedef struct /* stack managed by the virtual machine */

12
harbour/source/rtl/arrays.c
View File

@@ -36,6 +36,7 @@ void hb_arrayNew( PITEM pItem, ULONG ulLen ) /* creates a new array */
pBaseArray->ulLen = ulLen;
pBaseArray->wHolders = 1;
pBaseArray->wClass = 0;
pBaseArray->wSuperCast = FALSE;
for( ul = 0; ul < ulLen; ul++ )
( pBaseArray->pItems + ul )->wType = IT_NIL;
@@ -465,11 +466,14 @@ void hb_arrayRelease( PITEM pArray )
ULONG ul, ulLen = hb_arrayLen( pArray );
PBASEARRAY pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray;
for ( ul = 0; ul < ulLen; ul ++ )
ItemRelease( pBaseArray->pItems + ul );
if( !pBaseArray->wSuperCast )
{
for ( ul = 0; ul < ulLen; ul ++ )
ItemRelease( pBaseArray->pItems + ul );
if( pBaseArray->pItems )
_xfree( pBaseArray->pItems );
if( pBaseArray->pItems )
_xfree( pBaseArray->pItems );
}
_xfree( pBaseArray );
pArray->wType = IT_NIL;

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

File diff suppressed because it is too large Load Diff

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

@@ -42,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, "xSuper", 8, MET_DATA )
ClassAdd( hClass, "_xSuper", 8, MET_DATA )
ClassAdd( hClass, "cSuper", 8, MET_DATA )
ClassAdd( hClass, "_cSuper", 8, MET_DATA )
endif
return ClassInstance( hClass )
//----------------------------------------------------------------------------//
static function New( cClassName, xSuper )
static function New( cClassName, cSuper )
local Self := QSelf()
@@ -60,8 +60,8 @@ static function New( cClassName, xSuper )
::aClsDatas = {}
::aInlines = {}
::aVirtuals = {}
if ValType( xSuper ) $ "CA"
::xSuper = xSuper
if ValType( cSuper ) == "C"
::cSuper = cSuper
endif
return Self
@@ -79,30 +79,14 @@ static function Create()
local hSuper
local ahSuper := {}
if ::xSuper == NIL
if ::cSuper == NIL
hClass := ClassCreate( ::cName, nLenDatas )
elseif ValType(::xSuper) == "A" // Multiple inheritance
ahSuper := {}
nLen := Len( ::xSuper )
for n := 1 to nLen
aAdd( ahSuper, __InstSuper( Upper( ::xSuper[ n ] ) ) )
next n
hClass := ClassCreate( ::cName, nLenDatas, ahSuper )
for n := 1 to nLen
ClassAdd( hClass, Upper( ::xSuper[ n ] ), ahSuper[ n ], MET_SUPER )
nDataBegin += __WDatas( ahSuper[ n ] ) // Calc offset for new DATAs
next n
ClassAdd( hClass, "SUPER", aTail( ahSuper ), MET_SUPER )
// Last super is the SUPER
elseif ValType(::xSuper) == "C" // Single inheritance
hSuper := __InstSuper( Upper( ::xSuper ) )
else // Single inheritance
hSuper := __InstSuper( Upper( ::cSuper ) )
hClass := ClassCreate( ::cName, nLenDatas, hSuper )
// Add class casts
ClassAdd( hClass, Upper( ::xSuper ), hSuper, MET_SUPER )
ClassAdd( hClass, Upper( ::cSuper ), hSuper, MET_SUPER )
ClassAdd( hClass, "SUPER", hSuper, MET_SUPER )
nDataBegin := __WDatas( hSuper ) // Get offset for new DATAs

307
harbour/tests/working/multinh.prg
View File

@@ -1,307 +0,0 @@
#include "set.ch"
//
// MultInh
//
// First step to multiple inheritage
//
// Date : 01/06/1999
//
function Main()
local oFrom
local oTo
local cOut
set( _SET_EXACT, .T.)
oFrom := TOnTop() :New( "hello.prg", "R" )
oTo := TTextFile():New( "hello.out", "W" )
QOut( "What's in oFrom" )
HBDebug( { oFrom, aoMethod( oFrom ) } )
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()
QOut( cOut )
oTo:Run( cOut )
enddo
oFrom:Dispose()
oTo:Dispose()
return nil
//
// Generic Empty Class
//
function TEmpty()
static oEmpty
if oEmpty == NIL
oEmpty := TClass():New( "TEmpty" ) // Create a new class def
oEmpty:AddInline( "New", {|self|self} )
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", "Hi there" ) // Test command
oEmpty:AddVirtual( "Dispose" ) // Clean up code
oEmpty:Create()
endif
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 Text file handler
//
function TTextFile()
static oFile
if oFile == NIL
oFile := TClass():New( "TTextFile", "TEmpty" )
// Create a new class def
// from TEmpty class
oFile:AddData( "cFileName" ) // Filename spec. by user
oFile:AddData( "hFile" ) // File handle
oFile:AddData( "nLine" ) // Current linenumber
oFile:AddData( "nError" ) // Last error
oFile:AddData( "lEoF" ) // End of file
oFile:AddData( "cBlock" ) // Storage block
oFile:AddData( "nBlockSize" ) // Size of read-ahead buffer
oFile:AddData( "cMode" ) // Mode of file use
// R = read, W = write
oFile:AddMethod( "New" , @New() ) // Constructor
oFile:AddMethod( "Run" , @Run() ) // Get/set data
oFile:AddMethod( "Dispose", @Dispose() ) // Clean up code
oFile:AddMethod( "Read" , @Read() ) // Read line
oFile:AddMethod( "WriteLn", @WriteLn() ) // Write line
oFile:AddMethod( "Write" , @Write() ) // Write without CR
oFile:AddMethod( "Goto" , @Goto() ) // Go to line
oFile:Create()
endif
return oFile:Instance()
//
// Method TextFile:New -> Create a new text file
//
// <cFile> file name. No wild characters
// <cMode> mode for opening. Default "R"
// <nBlockSize> Optional maximum blocksize
//
function New( cFileName, cMode, nBlock )
local self := QSelf() // Get self
::nLine := 0
::lEoF := .F.
::cBlock := ""
::cFileName := cFileName
::cMode := Default( cMode, "R" )
if ::cMode == "R"
::hFile := fOpen( cFileName )
elseif ::cMode == "W"
::hFile := fCreate( cFileName )
else
QOut( "DosFile Init: Unknown file mode:", ::cMode )
endif
::nError := fError()
if ::nError != 0
::lEoF := .T.
QOut( "Error ", ::nError)
endif
::nBlockSize := Default( nBlock, 4096 )
return self
function Run( xTxt, lCRLF )
local self := QSelf()
local xRet
if ::cMode == "R"
xRet := ::Read()
else
xRet := ::WriteLn( xTxt, lCRLF )
endif
return xRet
//
// Dispose -> Close the file handle
//
function Dispose()
local self := QSelf()
::cBlock := NIL
if ::hFile != -1
if ::cMode == "W" .and. ::nError != 0
::Write( Chr(26) ) // Do not forget EOF marker
endif
if !fClose(::hFile)
::nError := fError()
QOut( "Dos Error closing ", ::cFileName, " Code ", ::nError)
endif
endif
return self
//
// Read a single line
//
function Read()
local self := QSelf()
local cRet := ""
local cBlock
local nCrPos
local nEoFPos
local nRead
if ::hFile == -1
QOut( "DosFile:Read : No file open" )
elseif ::cMode != "R"
QOut( "File ", cFileName, " not open for reading" )
elseif !::lEoF
if Len(::cBlock) == 0 // Read new block
cBlock := fReadStr( ::hFile, ::nBlockSize )
if len(cBlock) == 0
::nError := fError() // Error or EOF
::lEoF := .T.
else
::cBlock := cBlock
endif
endif
if !::lEoF
::nLine++
nCRPos := At(Chr(10), ::cBlock)
if nCRPos != 0 // More than one line read
cRet := Substr( ::cBlock, 1, nCRPos - 1)
::cBlock := Substr( ::cBlock, nCRPos + 1)
else // No complete line
cRet := ::cBlock
::cBlock := ""
cRet += ::Read() // Read the rest
if !::lEoF
::nLine-- // Adjust erroneous line count
endif
endif
nEoFPos := At( Chr(26), cRet )
if nEoFPos != 0 // End of file read
cRet := Substr( cRet, 1, nEoFPos-1 )
::lEoF := .T.
endif
cRet := Strtran( cRet, Chr(13), "" ) // Remove CR
endif
endif
return cRet
//
// WriteLn -> Write a line to a file
//
// <xTxt> Text to write. May be any type. May also be an array containing
// one or more strings
// <lCRLF> End with Carriage Return/Line Feed (Default == TRUE)
//
function WriteLn( xTxt, lCRLF )
local self := QSelf()
local cBlock
if ::hFile == -1
QOut( "DosFile:Write : No file open" )
elseif ::cMode != 'W'
QOut( "File ",cFileName," not opened for writing" )
else
cBlock := ToChar( xTxt ) // Convert to string
if Default( lCRLF, .T. )
cBlock += Chr(10) // +chr(13) ??
endif
fWrite( ::hFile, cBlock, len(cBlock) )
if fError() != 0
::nError := fError() // Not completely written !
endif
::nLine := ::nLine + 1
endif
return self
function Write( xTxt )
local self := QSelf()
return ::WriteLn( xTxt, .F. )
//
// Go to a specified line number
//
static function Goto( nLine )
local self := QSelf()
local nWhere := 1
if Empty(::hFile)
QOut( "DosFile:Goto : No file open" )
elseif ::cMode != "R"
QOut( "File ", cName, " not open for reading" )
else
::lEoF := .F. // Clear (old) End of file
::nLine := 0 // Start at beginning
::cBlock := ""
fSeek(::hFile, 0) // Go top
do while !::lEoF .and. nWhere < nLine
nWhere++
::Read()
enddo
endif
return !lEoF