* most of the Object Pascal stuff moved to the system unit

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

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

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.  }

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

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
+
+}

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
+
+}

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

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

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

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
+  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;
 
     type
        { first, in object pascal, the types must be redefined }
        smallint = system.integer;
        integer  = system.longint;
 
-       { some pointer definitions }
+       { the compiler searches in the objpas unit for the tvarrec symbol }       
-       pshortstring = ^shortstring;
+       TVarRec = System.TVarRec;
-       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
        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;const Name:string);
-Procedure AssignFile(Var f:File;p:pchar);
+     Procedure AssignFile(Var f:File;p:pchar);
-Procedure AssignFile(Var f:File;c:char);
+     Procedure AssignFile(Var f:File;c:char);
-Procedure CloseFile(Var f:File);
+     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);
+     { Typed file supoort }
-Procedure AssignFile(Var t:Text;p:pchar);
-Procedure AssignFile(Var t:Text;c:char);
-Procedure CloseFile(Var t:Text);
 
-{ Typed file supoort }
+     Procedure AssignFile(Var f:TypedFile;const Name:string);
-
+     Procedure AssignFile(Var f:TypedFile;p:pchar);
-Procedure AssignFile(Var f:TypedFile;const Name:string);
+     Procedure AssignFile(Var f:TypedFile;c:char);
-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
+                             Compatibility routines.
-****************************************************************************}
-
-    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.
 ****************************************************************************}
 
 { 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

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
+
+}

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

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