From e905aeea04bdc37032ae3d7874eae4b62142f312 Mon Sep 17 00:00:00 2001 From: florian Date: Mon, 17 May 1999 21:52:33 +0000 Subject: [PATCH] * most of the Object Pascal stuff moved to the system unit --- rtl/go32v2/system.pp | 10 +- rtl/inc/astrings.inc | 12 +- rtl/inc/graph/graph.pp | 2 +- rtl/inc/heap.inc | 7 +- rtl/inc/objpas.inc | 331 +++++++++++++++++++++++++ rtl/inc/objpash.inc | 199 +++++++++++++++ rtl/inc/system.inc | 10 +- rtl/inc/systemh.inc | 11 +- rtl/linux/syslinux.pp | 6 +- rtl/objpas/objpas.pp | 532 ++--------------------------------------- rtl/os2/sysos2.pas | 11 +- rtl/palmos/syspalm.pp | 11 +- rtl/win32/syswin32.pp | 6 +- 13 files changed, 619 insertions(+), 529 deletions(-) create mode 100644 rtl/inc/objpas.inc create mode 100644 rtl/inc/objpash.inc diff --git a/rtl/go32v2/system.pp b/rtl/go32v2/system.pp index 071209a4fe..50437b7f5b 100644 --- a/rtl/go32v2/system.pp +++ b/rtl/go32v2/system.pp @@ -1225,15 +1225,14 @@ Begin { to test stack depth } loweststack:=maxlongint; { Setup heap } - InitHeap; - + InitHeap; {$ifdef MT} { before this, you can't use thread vars !!!! } { threadvarblocksize is calculate before the initialization } { of the system unit } getmem(mainprogramthreadblock,threadvarblocksize); {$endif MT} - + InitExceptions; { Setup stdin, stdout and stderr } OpenStdIO(Input,fmInput,StdInputHandle); OpenStdIO(Output,fmOutput,StdOutputHandle); @@ -1251,7 +1250,10 @@ Begin End. { $Log$ - Revision 1.11 1999-05-04 23:28:40 pierre + Revision 1.12 1999-05-17 21:52:33 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.11 1999/05/04 23:28:40 pierre SYSTEM_DEBUG_STARTUP used to output args and env at start Revision 1.10 1999/04/28 11:42:45 peter diff --git a/rtl/inc/astrings.inc b/rtl/inc/astrings.inc index 6eff42f90b..b91ad5e14b 100644 --- a/rtl/inc/astrings.inc +++ b/rtl/inc/astrings.inc @@ -150,16 +150,16 @@ begin end; -function AnsiStr_Concat (S1,S2 : Pointer) : pointer;[Public, alias: 'FPC_ANSISTR_CONCAT']; +Procedure AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_ANSISTR_CONCAT']; { Concatenates 2 AnsiStrings : S1+S2. Result Goes to S3; } Var Size,Location : Longint; - S3 : pointer; + begin - S3:=nil; + DisposeAnsiString(S3); if (S1=Nil) then AnsiStr_Assign(S3,S2) else @@ -173,7 +173,6 @@ begin Move (S1^,S3^,Location); Move (S2^,(S3+location)^,Size+1); end; - AnsiStr_Concat:=S3; end; @@ -771,7 +770,10 @@ end; { $Log$ - Revision 1.23 1999-05-06 09:05:11 peter + Revision 1.24 1999-05-17 21:52:35 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.23 1999/05/06 09:05:11 peter * generic write_float str_float Revision 1.22 1999/04/22 10:51:17 peter diff --git a/rtl/inc/graph/graph.pp b/rtl/inc/graph/graph.pp index 93b38f9beb..0623202eb9 100644 --- a/rtl/inc/graph/graph.pp +++ b/rtl/inc/graph/graph.pp @@ -10,7 +10,7 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} -Unit Graph2; +Unit Graph; {-------------------------------------------------------} { Differences with TP Graph unit: } { - default putimage and getimage only support a max. } diff --git a/rtl/inc/heap.inc b/rtl/inc/heap.inc index 54bec1c173..4fcbdd5951 100644 --- a/rtl/inc/heap.inc +++ b/rtl/inc/heap.inc @@ -37,8 +37,6 @@ const maxblock = max_size div 8; type - ppointer = ^pointer; - pfreerecord = ^tfreerecord; tfreerecord = record next : pfreerecord; @@ -1091,7 +1089,10 @@ end; { $Log$ - Revision 1.9 1999-04-19 11:53:13 pierre + Revision 1.10 1999-05-17 21:52:36 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.9 1999/04/19 11:53:13 pierre * error 204 if trying to free too much memory of heap top ! Revision 1.8 1999/04/19 11:11:39 pierre diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc new file mode 100644 index 0000000000..80777c669e --- /dev/null +++ b/rtl/inc/objpas.inc @@ -0,0 +1,331 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1998,99 by the Free Pascal development team + + This unit makes Free Pascal as much as possible Delphi compatible + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{**************************************************************************** + Internal Routines called from the Compiler +****************************************************************************} + + { the reverse order of the parameters make code generation easier } + function int_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; + begin + int_do_is:=aobject.inheritsfrom(aclass); + end; + + + { the reverse order of the parameters make code generation easier } + procedure int_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS']; + begin + if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then + handleerror(219); + end; + + +{**************************************************************************** + TOBJECT +****************************************************************************} + + constructor TObject.Create; + + begin + end; + + destructor TObject.Destroy; + + begin + end; + + procedure TObject.Free; + + begin + // the call via self avoids a warning + if self<>nil then + self.destroy; + end; + + class function TObject.InstanceSize : LongInt; + + type + plongint = ^longint; + + begin + { type of self is class of tobject => it points to the vmt } + { the size is saved at offset 0 } + InstanceSize:=plongint(self)^; + end; + + class function TObject.InitInstance(instance : pointer) : tobject; + + begin + fillchar(instance^,self.instancesize,0); + { insert VMT pointer into the new created memory area } + { (in class methods self contains the VMT!) } + ppointer(instance)^:=pointer(self); + InitInstance:=TObject(Instance); + end; + + class function TObject.ClassParent : tclass; + + begin + { type of self is class of tobject => it points to the vmt } + { the parent vmt is saved at offset vmtParent } + classparent:=(pclass(self)+vmtParent)^; + end; + + class function TObject.NewInstance : tobject; + + var + p : pointer; + + begin + getmem(p,instancesize); + InitInstance(p); + NewInstance:=TObject(p); + end; + + procedure TObject.FreeInstance; + + var + p : Pointer; + + begin + CleanupInstance; + + { self is a register, so we can't pass it call by reference } + p:=Pointer(Self); + FreeMem(p,InstanceSize); + end; + + function TObject.ClassType : TClass; + + begin + ClassType:=TClass(Pointer(Self)^) + end; + + class function TObject.MethodAddress(const name : shortstring) : pointer; + + begin + methodaddress:=nil; + end; + + class function TObject.MethodName(address : pointer) : shortstring; + + begin + methodname:=''; + end; + + function TObject.FieldAddress(const name : shortstring) : pointer; + + begin + fieldaddress:=nil; + end; + + function TObject.SafeCallException(exceptobject : tobject; + exceptaddr : pointer) : longint; + + begin + safecallexception:=0; + end; + + class function TObject.ClassInfo : pointer; + + begin + ClassInfo:=(PPointer(self)+vmtTypeInfo)^; + end; + + class function TObject.ClassName : ShortString; + + begin + ClassName:=PShortString((PPointer(Self)+vmtClassName)^)^; + end; + + class function TObject.ClassNameIs(const name : string) : boolean; + + begin + ClassNameIs:=ClassName=name; + end; + + class function TObject.InheritsFrom(aclass : TClass) : Boolean; + + var + c : tclass; + + begin + c:=self; + while assigned(c) do + begin + if c=aclass then + begin + InheritsFrom:=true; + exit; + end; + c:=c.ClassParent; + end; + InheritsFrom:=false; + end; + + class function TObject.stringmessagetable : pstringmessagetable; + + type + pdword = ^dword; + + begin + stringmessagetable:=pstringmessagetable((pdword(Self)+vmtMsgStrPtr)^); + end; + + procedure TObject.Dispatch(var message); + + type + tmsgtable = record + index : dword; + method : pointer; + end; + + pmsgtable = ^tmsgtable; + + pdword = ^dword; + + var + index : dword; + count,i : longint; + msgtable : pmsgtable; + p : pointer; + vmt : tclass; + + begin + index:=dword(message); + vmt:=ClassType; + while assigned(vmt) do + begin + msgtable:=pmsgtable((pdword(vmt)+vmtDynamicTable)^+4); + count:=pdword((pdword(vmt)+vmtDynamicTable)^)^; + { later, we can implement a binary search here } + for i:=0 to count-1 do + begin + if index=msgtable[i].index then + begin + p:=msgtable[i].method; + asm + pushl message + pushl %esi + movl p,%edi +{$ifdef ver0_99_10} + call %edi +{$else ver0_99_10} + call *%edi +{$endif ver0_99_10} + end; + exit; + end; + end; + vmt:=vmt.ClassParent; + end; + DefaultHandler(message); + end; + + procedure TObject.DispatchStr(var message); + + type + pdword = ^dword; + + var + name : shortstring; + count,i : longint; + msgstrtable : pmsgstrtable; + p : pointer; + vmt : tclass; + + begin + name:=pshortstring(message)^; + vmt:=ClassType; + while assigned(vmt) do + begin + count:=pdword((pdword(vmt)+vmtMsgStrPtr)^)^; + msgstrtable:=pmsgstrtable((pdword(vmt)+vmtMsgStrPtr)^+4); + { later, we can implement a binary search here } + for i:=0 to count-1 do + begin + if name=msgstrtable[i].name^ then + begin + p:=msgstrtable[i].method; + asm + pushl message + pushl %esi + movl p,%edi +{$ifdef ver0_99_10} + call %edi +{$else ver0_99_10} + call *%edi +{$endif ver0_99_10} + end; + exit; + end; + end; + vmt:=vmt.ClassParent; + end; + DefaultHandlerStr(message); + end; + + procedure TObject.DefaultHandler(var message); + + begin + end; + + procedure TObject.DefaultHandlerStr(var message); + + begin + end; + + procedure TObject.CleanupInstance; + + var + vmt : tclass; + + begin + vmt:=ClassType; + while vmt<>nil do + begin + if Assigned(Pointer((Pointer(vmt)+vmtInitTable)^)) then + Finalize(Pointer(Self),Pointer((Pointer(vmt)+vmtInitTable)^)); + vmt:=vmt.ClassParent; + end; + end; + + procedure TObject.AfterConstruction; + + begin + end; + + procedure TObject.BeforeDestruction; + + begin + end; + +{**************************************************************************** + Exception Support +****************************************************************************} + +{$i except.inc} + +{**************************************************************************** + Initialize +****************************************************************************} + +{ + $Log$ + Revision 1.3 1999-05-17 21:52:37 florian + * most of the Object Pascal stuff moved to the system unit + +} diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc new file mode 100644 index 0000000000..b85b2bb12d --- /dev/null +++ b/rtl/inc/objpash.inc @@ -0,0 +1,199 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1998,99 by the Free Pascal development team + + This unit makes Free Pascal as much as possible Delphi compatible + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{***************************************************************************** + Basic Types/constants +*****************************************************************************} + + const + // vmtSelfPtr = -36; { not implemented yet } + vmtMsgStrPtr = -36; + vmtIntfTable = -32; + vmtAutoTable = -28; + vmtInitTable = -24; + vmtTypeInfo = -20; + vmtFieldTable = -16; + vmtMethodTable = -12; + vmtDynamicTable = -8; + vmtClassName = -4; + vmtInstanceSize = 0; + vmtParent = 8; + vmtDestroy = 12; + vmtNewInstance = 16; + vmtFreeInstance = 20; + vmtSafeCallException = 24; + vmtDefaultHandler = 28; + vmtAfterConstruction = 32; + vmtBeforeDestruction = 36; + vmtDefaultHandlerStr = 40; + + type + { some pointer definitions } + pshortstring = ^shortstring; + plongstring = ^longstring; + pansistring = ^ansistring; + pwidestring = ^widestring; + // pstring = pansistring; + pextended = ^extended; + ppointer = ^pointer; + + { now the let's declare the base classes for the class object } + { model } + tobject = class; + tclass = class of tobject; + pclass = ^tclass; + + + { to access the message table from outside } + tmsgstrtable = record + name : pshortstring; + method : pointer; + end; + + pmsgstrtable = ^tmsgstrtable; + + tstringmessagetable = record + count : dword; + msgstrtable : array[0..0] of tmsgstrtable; + end; + + pstringmessagetable = ^tstringmessagetable; + + tobject = class + { please don't change the order of virtual methods, because } + { their vmt offsets are used by some assembler code which uses } + { hard coded addresses (FK) } + constructor create; + { the virtual procedures must be in THAT order } + destructor destroy;virtual; + class function newinstance : tobject;virtual; + procedure freeinstance;virtual; + function safecallexception(exceptobject : tobject; + exceptaddr : pointer) : longint;virtual; + procedure defaulthandler(var message);virtual; + + procedure free; + class function initinstance(instance : pointer) : tobject; + procedure cleanupinstance; + function classtype : tclass; + class function classinfo : pointer; + class function classname : shortstring; + class function classnameis(const name : string) : boolean; + class function classparent : tclass; + class function instancesize : longint; + class function inheritsfrom(aclass : tclass) : boolean; + class function stringmessagetable : pstringmessagetable; + { message handling routines } + procedure dispatch(var message); + procedure dispatchstr(var message); + + class function methodaddress(const name : shortstring) : pointer; + class function methodname(address : pointer) : shortstring; + function fieldaddress(const name : shortstring) : pointer; + + { new since Delphi 4 } + procedure AfterConstruction;virtual; + procedure BeforeDestruction;virtual; + + { new for gtk, default handler for text based messages } + procedure DefaultHandlerStr(var message);virtual; + + { interface functions, I don't know if we need this } + { + function getinterface(const iid : tguid;out obj) : boolean; + class function getinterfaceentry(const iid : tguid) : pinterfaceentry; + class function getinterfacetable : pinterfacetable; + } + end; + + TExceptProc = Procedure (Obj : TObject; Addr: Pointer); + + Const + ExceptProc : Pointer {TExceptProc} = Nil; + + +{***************************************************************************** + Variant Type +*****************************************************************************} + + Const + varEmpty = $0000; + varNull = $0001; + varSmallint = $0002; + varInteger = $0003; + varSingle = $0004; + varDouble = $0005; + varCurrency = $0006; + varDate = $0007; + varOleStr = $0008; + varDispatch = $0009; + varError = $000A; + varBoolean = $000B; + varVariant = $000C; + varUnknown = $000D; + varByte = $0011; + varString = $0100; + varAny = $0101; + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + + Type + PVarRec = ^TVarRec; + TVarRec = record + case VType : Longint of + vtInteger : (VInteger: Longint); + vtBoolean : (VBoolean: Boolean); + vtChar : (VChar: Char); + vtExtended : (VExtended: PExtended); + vtString : (VString: PShortString); + vtPointer : (VPointer: Pointer); + vtPChar : (VPChar: PChar); + vtObject : (VObject: TObject); + vtClass : (VClass: TClass); +// vtWideChar : (VWideChar: WideChar); +// vtPWideChar : (VPWideChar: PWideChar); + vtAnsiString : (VAnsiString: Pointer); +// vtCurrency : (VCurrency: PCurrency); +// vtVariant : (VVariant: PVariant); +// vtInterface : (VInterface: Pointer); + vtWideString : (VWideString: Pointer); +// vtInt64 : (VInt64: PInt64); + end; +{ + $Log$ + Revision 1.3 1999-05-17 21:52:38 florian + * most of the Object Pascal stuff moved to the system unit + +} diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 25895a3570..bc2e7fba12 100644 --- a/rtl/inc/system.inc +++ b/rtl/inc/system.inc @@ -539,10 +539,18 @@ end; {$i setjump.inc} +{***************************************************************************** + Object Pascal support +*****************************************************************************} + +{$i objpas.inc} { $Log$ - Revision 1.57 1999-04-17 13:10:25 peter + Revision 1.58 1999-05-17 21:52:39 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.57 1999/04/17 13:10:25 peter * addr() internal Revision 1.56 1999/04/15 12:20:01 peter diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index 2fa0676145..f582b96047 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -25,6 +25,7 @@ ****************************************************************************} {$I-,Q-,H-,R-,V-} +{$mode objfpc} { needed for insert,delete,readln } {$P+} @@ -458,9 +459,17 @@ const {$i setjumph.inc} +{***************************************************************************** + Object Pascal support +*****************************************************************************} +{$i objpash.inc} + { $Log$ - Revision 1.56 1999-05-06 09:05:14 peter + Revision 1.57 1999-05-17 21:52:40 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.56 1999/05/06 09:05:14 peter * generic write_float str_float Revision 1.55 1999/04/17 13:10:26 peter diff --git a/rtl/linux/syslinux.pp b/rtl/linux/syslinux.pp index 40c8a77e77..84ac23019d 100644 --- a/rtl/linux/syslinux.pp +++ b/rtl/linux/syslinux.pp @@ -723,6 +723,7 @@ Begin InstallSignals; { Setup heap } InitHeap; + InitExceptions; { Setup stdin, stdout and stderr } OpenStdIO(Input,fmInput,StdInputHandle); OpenStdIO(Output,fmOutput,StdOutputHandle); @@ -734,7 +735,10 @@ End. { $Log$ - Revision 1.23 1999-04-08 12:23:04 peter + Revision 1.24 1999-05-17 21:52:42 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.23 1999/04/08 12:23:04 peter * removed os.inc Revision 1.22 1999/01/18 10:05:53 pierre diff --git a/rtl/objpas/objpas.pp b/rtl/objpas/objpas.pp index 0c8deff6aa..0e955d7d13 100644 --- a/rtl/objpas/objpas.pp +++ b/rtl/objpas/objpas.pp @@ -1,7 +1,7 @@ { $Id$ This file is part of the Free Pascal run time library. - Copyright (c) 1998 by the Free Pascal development team + Copyright (c) 1998,99 by the Free Pascal development team This unit makes Free Pascal as much as possible Delphi compatible @@ -13,519 +13,47 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} -unit objpas; - {$Mode ObjFpc} {$I-,S-} +unit objpas; -interface - -{***************************************************************************** - Basic Types/constants -*****************************************************************************} - - const - // vmtSelfPtr = -36; { not implemented yet } - vmtMsgStrPtr = -36; - vmtIntfTable = -32; - vmtAutoTable = -28; - vmtInitTable = -24; - vmtTypeInfo = -20; - vmtFieldTable = -16; - vmtMethodTable = -12; - vmtDynamicTable = -8; - vmtClassName = -4; - vmtInstanceSize = 0; - vmtParent = 8; - vmtDestroy = 12; - vmtNewInstance = 16; - vmtFreeInstance = 20; - vmtSafeCallException = 24; - vmtDefaultHandler = 28; - vmtAfterConstruction = 32; - vmtBeforeDestruction = 36; - vmtDefaultHandlerStr = 40; + interface type { first, in object pascal, the types must be redefined } smallint = system.integer; integer = system.longint; - { some pointer definitions } - pshortstring = ^shortstring; - plongstring = ^longstring; - pansistring = ^ansistring; - pwidestring = ^widestring; - // pstring = pansistring; - pextended = ^extended; - ppointer = ^pointer; - - { now the let's declare the base classes for the class object } - { model } - tobject = class; - tclass = class of tobject; - pclass = ^tclass; - - - { to access the message table from outside } - tmsgstrtable = record - name : pshortstring; - method : pointer; - end; - - pmsgstrtable = ^tmsgstrtable; - - tstringmessagetable = record - count : dword; - msgstrtable : array[0..0] of tmsgstrtable; - end; - - pstringmessagetable = ^tstringmessagetable; - - tobject = class - { please don't change the order of virtual methods, because } - { their vmt offsets are used by some assembler code which uses } - { hard coded addresses (FK) } - constructor create; - { the virtual procedures must be in THAT order } - destructor destroy;virtual; - class function newinstance : tobject;virtual; - procedure freeinstance;virtual; - function safecallexception(exceptobject : tobject; - exceptaddr : pointer) : integer;virtual; - procedure defaulthandler(var message);virtual; - - procedure free; - class function initinstance(instance : pointer) : tobject; - procedure cleanupinstance; - function classtype : tclass; - class function classinfo : pointer; - class function classname : shortstring; - class function classnameis(const name : string) : boolean; - class function classparent : tclass; - class function instancesize : longint; - class function inheritsfrom(aclass : tclass) : boolean; - class function stringmessagetable : pstringmessagetable; - { message handling routines } - procedure dispatch(var message); - procedure dispatchstr(var message); - - class function methodaddress(const name : shortstring) : pointer; - class function methodname(address : pointer) : shortstring; - function fieldaddress(const name : shortstring) : pointer; - - { new since Delphi 4 } - procedure AfterConstruction;virtual; - procedure BeforeDestruction;virtual; - - { new for gtk, default handler for text based messages } - procedure DefaultHandlerStr(var message);virtual; - - { interface functions, I don't know if we need this } - { - function getinterface(const iid : tguid;out obj) : boolean; - class function getinterfaceentry(const iid : tguid) : pinterfaceentry; - class function getinterfacetable : pinterfacetable; - } - end; - - TExceptProc = Procedure (Obj : TObject; Addr: Pointer); - - Const - ExceptProc : Pointer {TExceptProc} = Nil; - - -{***************************************************************************** - Variant Type -*****************************************************************************} - - Const - varEmpty = $0000; - varNull = $0001; - varSmallint = $0002; - varInteger = $0003; - varSingle = $0004; - varDouble = $0005; - varCurrency = $0006; - varDate = $0007; - varOleStr = $0008; - varDispatch = $0009; - varError = $000A; - varBoolean = $000B; - varVariant = $000C; - varUnknown = $000D; - varByte = $0011; - varString = $0100; - varAny = $0101; - varTypeMask = $0FFF; - varArray = $2000; - varByRef = $4000; - - vtInteger = 0; - vtBoolean = 1; - vtChar = 2; - vtExtended = 3; - vtString = 4; - vtPointer = 5; - vtPChar = 6; - vtObject = 7; - vtClass = 8; - vtWideChar = 9; - vtPWideChar = 10; - vtAnsiString = 11; - vtCurrency = 12; - vtVariant = 13; - vtInterface = 14; - vtWideString = 15; - vtInt64 = 16; - - Type + { the compiler searches in the objpas unit for the tvarrec symbol } + TVarRec = System.TVarRec; PVarRec = ^TVarRec; - TVarRec = record - case VType : Longint of - vtInteger : (VInteger: Integer); - vtBoolean : (VBoolean: Boolean); - vtChar : (VChar: Char); - vtExtended : (VExtended: PExtended); - vtString : (VString: PShortString); - vtPointer : (VPointer: Pointer); - vtPChar : (VPChar: PChar); - vtObject : (VObject: TObject); - vtClass : (VClass: TClass); -// vtWideChar : (VWideChar: WideChar); -// vtPWideChar : (VPWideChar: PWideChar); - vtAnsiString : (VAnsiString: Pointer); -// vtCurrency : (VCurrency: PCurrency); -// vtVariant : (VVariant: PVariant); -// vtInterface : (VInterface: Pointer); - vtWideString : (VWideString: Pointer); -// vtInt64 : (VInt64: PInt64); - end; - {**************************************************************************** - Compatibiity routines. + Compatibility routines. ****************************************************************************} -{ Untyped file support } + { Untyped file support } -Procedure AssignFile(Var f:File;const Name:string); -Procedure AssignFile(Var f:File;p:pchar); -Procedure AssignFile(Var f:File;c:char); -Procedure CloseFile(Var f:File); + Procedure AssignFile(Var f:File;const Name:string); + Procedure AssignFile(Var f:File;p:pchar); + Procedure AssignFile(Var f:File;c:char); + Procedure CloseFile(Var f:File); -{ Text file support } + { Text file support } + Procedure AssignFile(Var t:Text;const s:string); + Procedure AssignFile(Var t:Text;p:pchar); + Procedure AssignFile(Var t:Text;c:char); + Procedure CloseFile(Var t:Text); -Procedure AssignFile(Var t:Text;const s:string); -Procedure AssignFile(Var t:Text;p:pchar); -Procedure AssignFile(Var t:Text;c:char); -Procedure CloseFile(Var t:Text); + { Typed file supoort } -{ Typed file supoort } - -Procedure AssignFile(Var f:TypedFile;const Name:string); -Procedure AssignFile(Var f:TypedFile;p:pchar); -Procedure AssignFile(Var f:TypedFile;c:char); + Procedure AssignFile(Var f:TypedFile;const Name:string); + Procedure AssignFile(Var f:TypedFile;p:pchar); + Procedure AssignFile(Var f:TypedFile;c:char); implementation - Procedure HandleError (Errno : longint);external name 'FPC_HANDLEERROR'; - {**************************************************************************** - Internal Routines called from the Compiler -****************************************************************************} - - procedure finalize(data,typeinfo : pointer);external name 'FPC_FINALIZE'; - - - { the reverse order of the parameters make code generation easier } - function int_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; - begin - int_do_is:=aobject.inheritsfrom(aclass); - end; - - - { the reverse order of the parameters make code generation easier } - procedure int_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS']; - begin - if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then - handleerror(219); - end; - - -{**************************************************************************** - TOBJECT -****************************************************************************} - - constructor TObject.Create; - - begin - end; - - destructor TObject.Destroy; - - begin - end; - - procedure TObject.Free; - - begin - // the call via self avoids a warning - if self<>nil then - self.destroy; - end; - - class function TObject.InstanceSize : LongInt; - - type - plongint = ^longint; - - begin - { type of self is class of tobject => it points to the vmt } - { the size is saved at offset 0 } - InstanceSize:=plongint(self)^; - end; - - class function TObject.InitInstance(instance : pointer) : tobject; - - begin - fillchar(instance^,self.instancesize,0); - { insert VMT pointer into the new created memory area } - { (in class methods self contains the VMT!) } - ppointer(instance)^:=pointer(self); - InitInstance:=TObject(Instance); - end; - - class function TObject.ClassParent : tclass; - - begin - { type of self is class of tobject => it points to the vmt } - { the parent vmt is saved at offset vmtParent } - classparent:=(pclass(self)+vmtParent)^; - end; - - class function TObject.NewInstance : tobject; - - var - p : pointer; - - begin - getmem(p,instancesize); - InitInstance(p); - NewInstance:=TObject(p); - end; - - procedure TObject.FreeInstance; - - var - p : Pointer; - - begin - CleanupInstance; - - { self is a register, so we can't pass it call by reference } - p:=Pointer(Self); - FreeMem(p,InstanceSize); - end; - - function TObject.ClassType : TClass; - - begin - ClassType:=TClass(Pointer(Self)^) - end; - - class function TObject.MethodAddress(const name : shortstring) : pointer; - - begin - methodaddress:=nil; - end; - - class function TObject.MethodName(address : pointer) : shortstring; - - begin - methodname:=''; - end; - - function TObject.FieldAddress(const name : shortstring) : pointer; - - begin - fieldaddress:=nil; - end; - - function TObject.SafeCallException(exceptobject : tobject; - exceptaddr : pointer) : integer; - - begin - safecallexception:=0; - end; - - class function TObject.ClassInfo : pointer; - - begin - ClassInfo:=(PPointer(self)+vmtTypeInfo)^; - end; - - class function TObject.ClassName : ShortString; - - begin - ClassName:=PShortString((PPointer(Self)+vmtClassName)^)^; - end; - - class function TObject.ClassNameIs(const name : string) : boolean; - - begin - ClassNameIs:=ClassName=name; - end; - - class function TObject.InheritsFrom(aclass : TClass) : Boolean; - - var - c : tclass; - - begin - c:=self; - while assigned(c) do - begin - if c=aclass then - begin - InheritsFrom:=true; - exit; - end; - c:=c.ClassParent; - end; - InheritsFrom:=false; - end; - - class function TObject.stringmessagetable : pstringmessagetable; - - type - pdword = ^dword; - - begin - stringmessagetable:=pstringmessagetable((pdword(Self)+vmtMsgStrPtr)^); - end; - - procedure TObject.Dispatch(var message); - - type - tmsgtable = record - index : dword; - method : pointer; - end; - - pmsgtable = ^tmsgtable; - - pdword = ^dword; - - var - index : dword; - count,i : longint; - msgtable : pmsgtable; - p : pointer; - vmt : tclass; - - begin - index:=dword(message); - vmt:=ClassType; - while assigned(vmt) do - begin - msgtable:=pmsgtable((pdword(vmt)+vmtDynamicTable)^+4); - count:=pdword((pdword(vmt)+vmtDynamicTable)^)^; - { later, we can implement a binary search here } - for i:=0 to count-1 do - begin - if index=msgtable[i].index then - begin - p:=msgtable[i].method; - asm - pushl message - pushl %esi - movl p,%edi - call *%edi - end; - exit; - end; - end; - vmt:=vmt.ClassParent; - end; - DefaultHandler(message); - end; - - procedure TObject.DispatchStr(var message); - - type - pdword = ^dword; - - var - name : shortstring; - count,i : longint; - msgstrtable : pmsgstrtable; - p : pointer; - vmt : tclass; - - begin - name:=pshortstring(message)^; - vmt:=ClassType; - while assigned(vmt) do - begin - count:=pdword((pdword(vmt)+vmtMsgStrPtr)^)^; - msgstrtable:=pmsgstrtable((pdword(vmt)+vmtMsgStrPtr)^+4); - { later, we can implement a binary search here } - for i:=0 to count-1 do - begin - if name=msgstrtable[i].name^ then - begin - p:=msgstrtable[i].method; - asm - pushl message - pushl %esi - movl p,%edi - call *%edi - end; - exit; - end; - end; - vmt:=vmt.ClassParent; - end; - DefaultHandlerStr(message); - end; - - procedure TObject.DefaultHandler(var message); - - begin - end; - - procedure TObject.DefaultHandlerStr(var message); - - begin - end; - - procedure TObject.CleanupInstance; - - var - vmt : tclass; - - begin - vmt:=ClassType; - while vmt<>nil do - begin - if Assigned(Pointer((Pointer(vmt)+vmtInitTable)^)) then - Finalize(Pointer(Self),Pointer((Pointer(vmt)+vmtInitTable)^)); - vmt:=vmt.ClassParent; - end; - end; - - procedure TObject.AfterConstruction; - - begin - end; - - procedure TObject.BeforeDestruction; - - begin - end; - -{**************************************************************************** - Compatibiity routines. + Compatibility routines. ****************************************************************************} { Untyped file support } @@ -600,23 +128,13 @@ begin system.Assign (F,C); end; -{**************************************************************************** - Exception Support -****************************************************************************} - -{$i except.inc} - - -{**************************************************************************** - Initialize -****************************************************************************} - -begin - InitExceptions; end. { $Log$ - Revision 1.23 1999-05-13 21:54:28 peter + Revision 1.24 1999-05-17 21:52:43 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.23 1999/05/13 21:54:28 peter * objpas fixes Revision 1.22 1999/04/16 20:47:20 florian diff --git a/rtl/os2/sysos2.pas b/rtl/os2/sysos2.pas index 303c82da21..52a65b780b 100644 --- a/rtl/os2/sysos2.pas +++ b/rtl/os2/sysos2.pas @@ -726,6 +726,9 @@ begin {Initialize the heap.} initheap; + { ... and exceptions } + InitExceptions; + { to test stack depth } loweststack:=maxlongint; @@ -734,6 +737,12 @@ begin OpenStdIO(StdOut,fmOutput,StdOutputHandle); OpenStdIO(StdErr,fmOutput,StdErrorHandle); - { kein Ein- Ausgabefehler } + { no I/O-Error } inoutres:=0; end. +{ + $Log$ + Revision 1.15 1999-05-17 21:52:44 florian + * most of the Object Pascal stuff moved to the system unit + +} diff --git a/rtl/palmos/syspalm.pp b/rtl/palmos/syspalm.pp index 0d74d6d456..e29d831288 100644 --- a/rtl/palmos/syspalm.pp +++ b/rtl/palmos/syspalm.pp @@ -59,7 +59,7 @@ Unit SysPalm; var ExitCode : DWord; - { this variables are passed to PilotMain } + { this variables are passed to PilotMain by the PalmOS } cmd : Word; cmdPBP : Ptr; launchFlags : Word; @@ -67,7 +67,7 @@ Unit SysPalm; implementation { mimic the C start code } - function _PilotMain(_cmd : Word;_cmdPBP : Ptr;_launchFlags : Word) : DWord;cdecl;public; + function PilotMain(_cmd : Word;_cmdPBP : Ptr;_launchFlags : Word) : DWord;cdecl;public; begin cmd:=_cmd; @@ -76,7 +76,7 @@ Unit SysPalm; asm bsr PASCALMAIN end; - _PilotMain:=ExitCode; + PilotMain:=ExitCode; end; {***************************************************************************** @@ -92,7 +92,10 @@ end. { $Log$ - Revision 1.4 1999-01-18 10:05:56 pierre + Revision 1.5 1999-05-17 21:52:46 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.4 1999/01/18 10:05:56 pierre + system_exit procedure added Revision 1.3 1998/08/31 12:18:37 peter diff --git a/rtl/win32/syswin32.pp b/rtl/win32/syswin32.pp index 619a251e07..e162802657 100644 --- a/rtl/win32/syswin32.pp +++ b/rtl/win32/syswin32.pp @@ -997,6 +997,7 @@ begin { stacklimit := setupstack; } { Setup heap } InitHeap; + InitExceptions; { Setup stdin, stdout and stderr } StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE)); StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE)); @@ -1015,7 +1016,10 @@ end. { $Log$ - Revision 1.38 1999-04-28 11:42:53 peter + Revision 1.39 1999-05-17 21:52:47 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.38 1999/04/28 11:42:53 peter + FileNameCaseSensetive boolean Revision 1.37 1999/04/08 12:23:11 peter