
# GPC version 3.4.4 d2 for Mac OS X (10.2 or later)
# July 22, 2005

# Adriaan van Os <gpc@microbizz.nl> <www.microbizz.nl/gpc.html>

# The compiler is built with a snapshot of the GNU Pascal Compiler front-end (gpc-20050331) and
# the 3.4.4 release of the GNU Compiler Collection back-end (fsf-gcc-3.4.4) of the Free Software
# Foundation.




#---------------------------------------------
# 20050212, Adriaan van Os <gpc@microbizz.nl>
# W o r k a r o u n d  for a powerpc-apple-darwin back-end bug
# <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=10901>
# for a discussion, see <http://www.gnu-pascal.de/crystal/gpc/en/mail11324.html>


--- gcc-3.4.4-orig/gcc/p/gpc-options.h	Mon Mar 21 11:30:42 2005
+++ gcc-3.4.4/gcc/p/gpc-options.h	Tue Jul 19 11:50:59 2005
@@ -85,6 +85,9 @@
     "-fno-pedantic",
     "-ftyped-address",
     "-fassertions",
+	#if defined (__MACH__) && defined (__APPLE__) && defined (__POWERPC__)
+  	"-flongjmp-all-nonlocal-labels",
+	#endif
     "-Wwarnings",
     "-Wimplicit-abstract",
     "-Winherited-abstract",




#---------------------------------------------
# 20050719, Adriaan van Os <gpc@microbizz.nl>
# C h a n g e s  to improve the employability of the --mac-pascal dialect
# for a discussion, see <http://www.gnu-pascal.de/crystal/gpc/en/thread11305.html>


--- gcc-3.4.4-orig/gcc/p/predef.def	Mon Jul 18 22:39:20 2005
+++ gcc-3.4.4/gcc/p/predef.def	Tue Jul 19 12:41:22 2005
@@ -170,6 +170,8 @@
 PREDEF_TYPE (LongestInt,  long_long_integer_type_node,  GNU_PASCAL)
 PREDEF_TYPE (LongInt,     long_long_integer_type_node,  B_D_M_PASCAL)
 PREDEF_TYPE (Comp,        long_long_integer_type_node,  B_D_M_PASCAL)
+PREDEF_TYPE (UnsignedWord,short_unsigned_type_node,     MAC_PASCAL)
+PREDEF_TYPE (UnsignedLong,pascal_cardinal_type_node,    MAC_PASCAL)
 PREDEF_TYPE (LongestCard, long_long_unsigned_type_node, GNU_PASCAL)
 PREDEF_TYPE (LongestWord, long_long_unsigned_type_node, GNU_PASCAL)
 PREDEF_TYPE (LongCard,    long_long_unsigned_type_node, GNU_PASCAL)
@@ -344,7 +346,8 @@
 PREDEF_ALIAS   (Append, Extend,     "-F,xi|-Fsbi",   ER_IOCRITICAL, B_D_M_PASCAL)
 PREDEF_ROUTINE (Close,              "-F",            ER_IOCRITICAL, U_B_D_M_PASCAL)
 PREDEF_ROUTINE (Update,             "-F",            ER_IOCRITICAL, E_O_PASCAL)
-PREDEF_ROUTINE (Flush,              "-F",            ER_IOCRITICAL, B_D_PASCAL)
+PREDEF_ROUTINE (Flush,              "-F",            ER_IOCRITICAL, B_D_M_PASCAL)
+PREDEF_ALIAS   (PLFlush, Flush,     "-F",            ER_IOCRITICAL, MAC_PASCAL)
 PREDEF_ROUTINE (EOF,                "b,f",           ER_IOCRITICAL, ANY_PASCAL)
 PREDEF_ROUTINE (EOLn,               "b,j",           ER_IOCRITICAL, ANY_PASCAL)
 PREDEF_ROUTINE (SeekEOF,            "b,j",           ER_IOCRITICAL, B_D_M_PASCAL)
@@ -355,9 +358,11 @@
 PREDEF_ROUTINE (Page,               "-,J",           ER_IOCRITICAL, C_E_O_U_M_PASCAL)
 PREDEF_ROUTINE (Position,           "lF",            ER_IOCRITICAL, E_O_PASCAL)
 PREDEF_ROUTINE (LastPosition,       "lF",            ER_IOCRITICAL, E_O_PASCAL)
-PREDEF_ALIAS   (FilePos, Position,  "lF",            ER_IOCRITICAL, B_D_PASCAL)
+PREDEF_ALIAS   (FilePos, Position,  "lF",            ER_IOCRITICAL, B_D_M_PASCAL)
+PREDEF_ALIAS   (PLFilePos, Position,"lF",            ER_IOCRITICAL, MAC_PASCAL)
 PREDEF_ROUTINE (FileSize,           "lF",            ER_IOCRITICAL, B_D_M_PASCAL)
 PREDEF_ROUTINE (Truncate,           "-F",            ER_IOCRITICAL, B_D_M_PASCAL)
+PREDEF_ALIAS   (PLCrunch, Truncate, "-F",            ER_IOCRITICAL, MAC_PASCAL)
 PREDEF_ROUTINE (DefineSize,         "-Fl",           ER_IOCRITICAL, GNU_PASCAL)  /* from Pax */
 PREDEF_ROUTINE (SetFileTime,        "-Fll",          ER_IOCRITICAL, GNU_PASCAL)
 PREDEF_ROUTINE (Seek,               "-Fu|-Fl",       ER_IOCRITICAL, U_B_D_M_PASCAL)
@@ -429,6 +434,7 @@
 PREDEF_ROUTINE (Read,    "-,|",  ER_IOCRITICAL, ANY_PASCAL)
 PREDEF_ROUTINE (ReadLn,  "-,|",  ER_IOCRITICAL, ANY_PASCAL)
 PREDEF_ROUTINE (ReadStr, "-x,|", 0,             E_O_PASCAL)
+PREDEF_ALIAS   (ReadString, ReadStr, "-x,|", 0, MAC_PASCAL)
 PREDEF_ROUTINE_NO_ID (Read_Init,         "-Fi",  0)
 PREDEF_ROUTINE_NO_ID (ReadStr_Init,      "psi",  0)
 PREDEF_ROUTINE_NO_ID (ReadWriteStr_Done, "-F",   0)


 


#---------------------------------------------
# <http://cvs.opendarwin.org/index.cgi/dports/lang/gcc34/files/patch-darwin.h?rev=1.3>
# patch needed to bootstrap gcc-3.4 on Darwin8/Mac OS X 10.4
# apply it *only* on Darwin8/Mac OS X 10.4 


--- gcc-3.4.4-orig/gcc/config/darwin.h	Sat Sep 11 22:32:17 2004
+++ gcc-3.4.4/gcc/config/darwin.h	Tue Jul 19 14:57:39 2005
@@ -275,7 +275,7 @@
 /* Machine dependent libraries.  */
 
 #undef	LIB_SPEC
-#define LIB_SPEC "%{!static:-lSystem}"
+#define LIB_SPEC "%{!static:-lSystemStubs -lSystem}"
 
 /* We specify crt0.o as -lcrt0.o so that ld will search the library path.  */


 


#---------------------------------------------
# 20050722, Waldek Hebisch <hebisch@math.uni.wroc.pl>
# A p p a r e n t l y  dbxout.c assumes that all object look like C++ objects.
# The following backend patch should fix the crash:
# <http://www.math.uni.wroc.pl/~hebisch/gpc/dbxout.diff>


--- gcc-3.4.4-orig/gcc/dbxout.c	2005-06-14 03:33:07.000000000 +0200
+++ gcc-3.4.4/gcc/dbxout.c	2005-07-22 00:17:41.389503512 +0200
@@ -1011,13 +1011,17 @@
   tree type_encoding;
   tree fndecl;
   tree last;
+#ifndef GPC
   char formatted_type_identifier_length[16];
   int type_identifier_length;
+#endif
 
   if (methods == NULL_TREE)
     return;
 
+#ifndef GPC
   type_encoding = DECL_NAME (TYPE_NAME (type));
+#endif
 
 #if 0
   /* C++: Template classes break some assumptions made by this code about
@@ -1037,9 +1041,11 @@
   }
 #endif
 
+#ifndef GPC
   type_identifier_length = IDENTIFIER_LENGTH (type_encoding);
 
   sprintf (formatted_type_identifier_length, "%d", type_identifier_length);
+#endif
 
   if (TREE_CODE (methods) != TREE_VEC)
     fndecl = methods;


 


#---------------------------------------------
# 20050722, Waldek Hebisch <hebisch@math.uni.wroc.pl>
# <http://www.math.uni.wroc.pl/~hebisch/gpc/delphi14.diff>
# P r e l i m i n a r y  support for MacPascal & Delph style objects


--- gcc-3.4.4-orig/gcc/p/declarations.c	2005-03-31 20:04:18.000000000 +0200
+++ gcc-3.4.4/gcc/p/declarations.c	2005-07-22 02:25:02.977805512 +0200
@@ -2480,6 +2480,14 @@
   if (object_name)
     {
       tree object_type = lookup_name (object_name);
+      if (object_type && TREE_CODE (object_type) == TYPE_DECL
+          && TREE_CODE (TREE_TYPE (object_type)) == POINTER_TYPE
+          && PASCAL_TYPE_CLASS (TREE_TYPE (object_type)))
+        {
+          name = get_method_name (object_name, name);
+          DECL_CONTEXT (t) = TREE_TYPE (object_type);
+        }
+      else
       if (object_type && TREE_CODE (object_type) == TYPE_DECL && PASCAL_TYPE_OBJECT (TREE_TYPE (object_type)))
         {
           name = get_method_name (object_name, name);
@@ -2841,6 +2849,18 @@
     {
       /* Implicitly do `with Self do' */
       tree self = lookup_name (self_id), t;
+      if (self && TREE_CODE (TREE_TYPE (self)) == REFERENCE_TYPE)
+        {
+          tree stp = TYPE_POINTER_TO (TREE_TYPE (TREE_TYPE (self)));
+          if (stp && PASCAL_TYPE_CLASS (stp))
+            {
+              tree d = build_decl (CONST_DECL, self_id, stp);
+              DECL_INITIAL (d) = convert (stp, self);
+              IDENTIFIER_VALUE (self_id) = d;
+              pushdecl_nocheck (d);
+              DECL_CONTEXT (d) = current_function_decl;
+            }
+        } 
       if (self)
         shadowed = pascal_shadow_record_fields (build_indirect_ref (self, "`Self' reference"), NULL_TREE);
       /* Mark the fields as declared in the current scope (fjf280b.pas) */
@@ -3064,6 +3084,27 @@
   return decl;
 }
 
+void
+patch_type (tree type, tree otype)
+{
+  tree fwdtype = TYPE_MAIN_VARIANT (otype);
+  for (; fwdtype; fwdtype = TYPE_NEXT_VARIANT (fwdtype))
+    {
+      tree t, new_variant = p_build_type_variant (type, TYPE_READONLY (fwdtype),
+		                                  TYPE_VOLATILE (fwdtype));
+      if (new_variant == type && fwdtype != otype)
+        new_variant = build_type_copy (new_variant);
+      if (TYPE_POINTER_TO (fwdtype))
+      for (t = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (fwdtype)); t; t = TYPE_NEXT_VARIANT (t))
+        TREE_TYPE (t) = new_variant;
+      if (TYPE_REFERENCE_TO (fwdtype))
+        for (t = TYPE_MAIN_VARIANT (TYPE_REFERENCE_TO (fwdtype)); t; t = TYPE_NEXT_VARIANT (t))
+          TREE_TYPE (t) = new_variant;
+      TYPE_POINTER_TO (new_variant) = TYPE_POINTER_TO (fwdtype);
+      TYPE_REFERENCE_TO (new_variant) = TYPE_REFERENCE_TO (fwdtype);
+    }
+}
+
 /* Actually declare the types at the end of a type definition part.
    Resolve any forward types using existing types. */
 void
@@ -3073,32 +3114,54 @@
 
   /* Resolve forward types */
   for (scan = current_type_list; scan; scan = TREE_CHAIN (scan))
-    if (TREE_PURPOSE (scan) && TREE_CODE (TREE_TYPE (TREE_PURPOSE (scan))) == LANG_TYPE)
+    if (TREE_PURPOSE (scan) && (TREE_CODE (TREE_TYPE (TREE_PURPOSE (scan))) == LANG_TYPE
+          || TREE_CODE (TREE_TYPE (TREE_PURPOSE (scan))) == POINTER_TYPE
+	     && PASCAL_TYPE_CLASS (TREE_TYPE (TREE_PURPOSE (scan)))
+	     && TREE_CODE (TREE_TYPE (TREE_TYPE (TREE_PURPOSE (scan)))) == LANG_TYPE))
       {
-        tree decl = lookup_name (TREE_VALUE (scan)), fwdtype, type;
+        tree otype = TREE_TYPE (TREE_PURPOSE (scan));
+        tree decl = lookup_name (TREE_VALUE (scan)), type;
+        int is_class = TREE_CODE (otype) == POINTER_TYPE;
         if (decl && TREE_CODE (decl) == TYPE_DECL)
-          type = TREE_TYPE (decl);
-        else
+          {
+            type = TREE_TYPE (decl);
+	    if (is_class)
+              if (TREE_CODE (type) == POINTER_TYPE && PASCAL_TYPE_CLASS (type))
+		{
+	          type = TREE_TYPE (type);
+                  if (TREE_CODE (type) != LANG_TYPE)
+		    error ("duplicate forward class declaration for `%s'",
+		         IDENTIFIER_NAME (TREE_VALUE (scan)));
+                  else
+                    {
+                      error ("unresolved forward class `%s'",
+                             IDENTIFIER_NAME (TREE_VALUE (scan)));
+                      type = void_type_node;
+                    }
+		}
+	      else
+		{
+		  error ("forward class %s' redefined as non-class",
+	                 IDENTIFIER_NAME (TREE_VALUE (scan)));
+		  type = void_type_node;
+		}
+	  }
+        else if (is_class)
+	  {
+            gcc_unreachable ();
+	    error ("unresolved forward class `%s'",
+	           IDENTIFIER_NAME (TREE_VALUE (scan)));
+	    type = void_type_node;
+	  }
+	else
           {
             error ("forward referenced type `%s' undefined", IDENTIFIER_NAME (TREE_VALUE (scan)));
             type = void_type_node;  /* dwarf2out.c doesn't like error_mark_node */
           }
         /* Patch all variants. */
-        for (fwdtype = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_PURPOSE (scan)));
-             fwdtype; fwdtype = TYPE_NEXT_VARIANT (fwdtype))
-          {
-            tree t, new_variant = p_build_type_variant (type, TYPE_READONLY (fwdtype), TYPE_VOLATILE (fwdtype));
-            if (new_variant == type && fwdtype != TREE_TYPE (TREE_PURPOSE (scan)))
-              new_variant = build_type_copy (new_variant);
-            if (TYPE_POINTER_TO (fwdtype))
-              for (t = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (fwdtype)); t; t = TYPE_NEXT_VARIANT (t))
-                TREE_TYPE (t) = new_variant;
-            if (TYPE_REFERENCE_TO (fwdtype))
-              for (t = TYPE_MAIN_VARIANT (TYPE_REFERENCE_TO (fwdtype)); t; t = TYPE_NEXT_VARIANT (t))
-                TREE_TYPE (t) = new_variant;
-            TYPE_POINTER_TO (new_variant) = TYPE_POINTER_TO (fwdtype);
-            TYPE_REFERENCE_TO (new_variant) = TYPE_REFERENCE_TO (fwdtype);
-          }
+	if (is_class)
+	  otype = TREE_TYPE (otype);
+	patch_type (type, otype);
       }
 
   /* Declare the types */
@@ -3128,7 +3191,8 @@
   tree field, shadowed = NULL_TREE;
   gcc_assert (TYPE_SIZE (TREE_TYPE (element)) && !PASCAL_TYPE_UNDISCRIMINATED_SCHEMA (TREE_TYPE (element)));
   for (field = fields; field; field = TREE_CHAIN (field))
-    if (!check_private_protected (field))  /* omit forbidden fields */
+    /* omit forbidden fields */
+    if (!check_private_protected (field) && !PASCAL_FIELD_SHADOWED (field))
       {
         tree name = DECL_NAME (field), ref, ftype = TREE_TYPE (field);
         CHK_EM (ftype);
@@ -3188,6 +3252,10 @@
       element = temp_var;
     }
 #endif
+  if (TREE_CODE (TREE_TYPE (element)) == POINTER_TYPE
+           &&PASCAL_TYPE_CLASS (TREE_TYPE (element)))
+    element = build_indirect_ref (element, NULL);
+
   if (!EM (TREE_TYPE (element))
       && TREE_CODE (element) != VAR_DECL
       && TREE_CODE (element) != PARM_DECL

--- gcc-3.4.4-orig/gcc/p/doc/en/reference.texi	2005-03-31 15:34:40.000000000 +0200
+++ gcc-3.4.4/gcc/p/doc/en/reference.texi	2005-07-22 02:43:02.588679712 +0200
@@ -121,6 +121,7 @@
 * EQ::
 * EQPad::
 * Erase::
+* except::
 * Exclude::
 * Exit::
 * Exp::
@@ -138,6 +139,7 @@
 * FillChar::
 * finalization::
 * Finalize::
+* finally::
 * Flush::
 * for::
 * FormatString::
@@ -228,6 +230,7 @@
 * object::
 * Odd::
 * of::
+* on::
 * only::
 * operator::
 * or::
@@ -236,6 +239,8 @@
 * or_else::
 * otherwise::
 * Output::
+* overload::
+* override::
 * Pack::
 * packed::
 * Page::
@@ -264,6 +269,7 @@
 * published::
 * Put::
 * qualified::
+* raise::
 * Random::
 * Randomize::
 * Re::
@@ -331,6 +337,7 @@
 * True::
 * Trunc::
 * Truncate::
+* try::
 * type::
 * type of::
 * TypeOf::
@@ -4311,6 +4318,27 @@
 @c ----------------------------------------------------------------------------
 
 
+@node except
+@unnumberedsec except
+@cindex except
+
+Not yet implemented.
+
+@subheading Synopsis
+
+@subheading Conforming to
+
+@samp{except} is a Borland Delphi extension.
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
+
+@c ----------------------------------------------------------------------------
+
+
 @node Exclude
 @unnumberedsec Exclude
 @cindex Exclude
@@ -5028,6 +5056,27 @@
 @c ----------------------------------------------------------------------------
 
 
+@node finally
+@unnumberedsec finally
+@cindex finally
+
+Not yet implemented.
+
+@subheading Synopsis
+
+@subheading Conforming to
+
+@samp{finally} is a Borland Delphi extension.
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
+
+@c ----------------------------------------------------------------------------
+
+
 @node Flush
 @unnumberedsec Flush
 @cindex Flush
@@ -8420,6 +8469,27 @@
 @c ----------------------------------------------------------------------------
 
 
+@node on
+@unnumberedsec on
+@cindex on
+
+Not yet implemented.
+
+@subheading Synopsis
+
+@subheading Conforming to
+
+@samp{on} is a Borland Delphi extension.
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
+
+@c ----------------------------------------------------------------------------
+
+
 @node only
 @unnumberedsec only
 @cindex only
@@ -8821,6 +8891,52 @@
 @c ----------------------------------------------------------------------------
 
 
+@node overload
+@unnumberedsec overload
+@cindex overload
+
+Not yet implemented.
+
+@subheading Synopsis
+
+@subheading Conforming to
+
+@samp{overload} is a Borland Delphi extension.
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
+
+
+@c ----------------------------------------------------------------------------
+
+
+@node override
+@unnumberedsec override
+@cindex override
+
+(Under construction.)
+
+@subheading Synopsis
+
+@subheading Description
+
+@subheading Conforming to
+
+@samp{override} directive is defined in OOE draft and supported by
+Delphi and Mac Pascal
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
+
+@c ----------------------------------------------------------------------------
+
+
 @node Pack
 @unnumberedsec Pack
 @cindex Pack
@@ -9855,6 +9971,27 @@
 @c ----------------------------------------------------------------------------
 
 
+@node raise
+@unnumberedsec raise
+@cindex raise
+
+Not yet implemented.
+
+@subheading Synopsis
+
+@subheading Conforming to
+
+@samp{overload} is a Borland Delphi extension.
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
+
+@c ----------------------------------------------------------------------------
+
+
 @node Random
 @unnumberedsec Random
 @cindex Random
@@ -12542,6 +12679,26 @@
 
 @subheading See also
 
+@c ----------------------------------------------------------------------------
+
+
+@node try
+@unnumberedsec try
+@cindex try
+
+Not yet implemented.
+
+@subheading Synopsis
+
+@subheading Conforming to
+
+@samp{try} is a Borland Delphi extension.
+
+@subheading Example
+
+@subheading See also
+
+@ref{Keywords}.
 
 @c ----------------------------------------------------------------------------
 
--- gcc-3.4.4-orig/gcc/p/expressions.c	2005-03-31 20:04:59.000000000 +0200
+++ gcc-3.4.4/gcc/p/expressions.c	2005-07-22 02:52:11.952163768 +0200
@@ -1652,6 +1652,9 @@
   if (PASCAL_TYPE_RESTRICTED (TREE_TYPE (pointer)))
     error ("dereferencing a restricted pointer is not allowed");
 
+  if (PASCAL_TYPE_CLASS (TREE_TYPE (pointer)))
+    error ("dereferencing a class");
+
   if (PASCAL_TYPE_FILE (TREE_TYPE (pointer)))
     result = build_buffer_ref (pointer, p_LazyTryGet);
   else if (MAYBE_CALL_FUNCTION (pointer)
@@ -3563,7 +3566,6 @@
 build_iso_set_constructor (tree type, tree list, int one_el)
 {
   tree nl = NULL_TREE;
-  chk_dialect ("set constructors with type given are", E_O_PASCAL);
   if (one_el)
     {
       if ((list = strip_needless_lists (list)))
@@ -3609,9 +3611,9 @@
       error ("undiscriminated type in structured value constructor");
       return error_mark_node;
     }
+  chk_dialect ("structured value constructors are", E_O_PASCAL);
   if (TREE_CODE (type) == SET_TYPE)
     return build_iso_set_constructor (type, list, 1);
-  chk_dialect ("structured value constructors are", E_O_PASCAL);
   if (!STRUCTURED_TYPE (TREE_CODE (type)))
     error ("invalid type for structured value constructor");
   list = build_tree_list (NULL_TREE, list);

--- gcc-3.4.4-orig/gcc/p/gpc.h	2005-03-31 20:04:15.000000000 +0200
+++ gcc-3.4.4/gcc/p/gpc.h	2005-07-22 02:25:02.993803080 +0200
@@ -140,6 +140,7 @@
   U_B_D_M_O_PASCAL   = U_B_D_M_PASCAL | OBJECT_PASCAL,
   O_D_PASCAL         = OBJECT_PASCAL | BORLAND_DELPHI,
   O_B_D_PASCAL       = O_D_PASCAL | B_D_PASCAL,
+  O_D_M_PASCAL       = O_D_PASCAL | MAC_PASCAL,
   O_B_D_M_PASCAL     = O_B_D_PASCAL | MAC_PASCAL,
   E_O_PASCAL         = EXTENDED_PASCAL | OBJECT_PASCAL,
   E_O_M_PASCAL       = E_O_PASCAL | MAC_PASCAL,
@@ -436,6 +437,9 @@
 /* Set for artificial VAR_DECL nodes whose value contains side-effects. */
 #define PASCAL_HAD_SIDE_EFFECTS(expr) TREE_LANG_FLAG_5 (expr)
 
+/* Set for pointer types representing Delphi classes */
+#define PASCAL_TYPE_CLASS(type) TREE_LANG_FLAG_5 (type)
+
 /* Set for abstract methods. Used in FUNCTION_DECL nodes. */
 #define PASCAL_ABSTRACT_METHOD(decl) TREE_LANG_FLAG_6 (decl)
 
@@ -473,6 +477,15 @@
    keep a clean conscience. Used in VAR_DECL nodes. */
 #define PASCAL_DECL_TYPED_CONST(NODE) DECL_LANG_FLAG_3 (NODE)
 
+/* Set if a field is shadowed by a child method or field or a view */
+#define PASCAL_FIELD_SHADOWED(NODE) DECL_LANG_FLAG_3 (NODE)
+
+/* Set if a method is shadowed by a child method or field or a view */
+#define PASCAL_METHOD_SHADOWED(NODE) DECL_LANG_FLAG_3 (NODE)
+
+/* Set if a method has an override directive */
+#define PASCAL_METHOD_OVERRIDE(NODE) DECL_LANG_FLAG_3 (NODE)
+
 /* Set if the label has been set. Used in LABEL_DECL nodes. */
 #define PASCAL_LABEL_SET(NODE) DECL_LANG_FLAG_3 (NODE)
 
@@ -1057,6 +1070,9 @@
   /* Nonzero means to make all methods virtual. */
   int methods_always_virtual;
 
+  /* Nonzero to turn objects into references. */
+  int objects_are_references;
+
   /* Nonzero means to warn when an object type not declared `abstract' contains an abstract method. */
   int warn_implicit_abstract;
 
@@ -1172,6 +1188,7 @@
 extern void pascal_expand_goto (tree);
 extern void do_setjmp (void);
 extern tree build_type_decl (tree, tree, tree);
+extern void patch_type (tree type, tree otype);
 extern void declare_types (void);
 extern tree pascal_shadow_record_fields (tree, tree);
 extern void restore_identifiers (tree);
@@ -1416,7 +1433,7 @@
 extern tree call_method (tree, tree);
 extern tree build_inherited_method (tree);
 extern tree get_method_name (tree, tree);
-extern tree start_object_type (tree);
+extern tree start_object_type (tree, int);
 extern tree finish_object_type (tree, tree, tree, int);
 extern tree build_is_as (tree, tree, int);
 
--- gcc-3.4.4-orig/gcc/p/gpc-options.h	2005-03-21 11:30:42.000000000 +0100
+++ gcc-3.4.4/gcc/p/gpc-options.h	2005-07-22 02:25:02.993803080 +0200
@@ -118,7 +118,7 @@
      initializer doesn't compile. The limits can be increased when
      necessary. */
   const char *src[7];
-  const char *dest[25];
+  const char *dest[26];
 } lang_option_map[] =
   {
     {
@@ -193,6 +193,7 @@
         "-fno-double-quoted-strings",
         "-fno-field-widths",
         "-fno-methods-always-virtual",
+        "-fno-objects-are-references",
         "-fno-propagate-units",
         "-Wno-object-assignment",
         "-Wno-typed-const",
@@ -266,6 +267,7 @@
         "-fdouble-quoted-strings",
         "-fno-field-widths",
         "-fmethods-always-virtual",
+        "-fobjects-are-references",
         "-fpropagate-units",
         "-Wno-typed-const",
         "-Wno-cast-align",
@@ -298,6 +300,7 @@
         "-fdouble-quoted-strings",
         "-fno-field-widths",
         "-fno-methods-always-virtual",
+        "-fno-objects-are-references",
         "-fno-propagate-units",
         "-Wcast-align",
         "-Wobject-assignment",

--- gcc-3.4.4-orig/gcc/p/lang.c	2005-03-31 19:52:05.000000000 +0200
+++ gcc-3.4.4/gcc/p/lang.c	2005-07-22 02:25:02.994802928 +0200
@@ -92,6 +92,10 @@
                TREE_OPERAND (t, 1),
                TREE_OPERAND (t, 2),
                1), r, mm, em);
+  else if (TREE_CODE (t) == PASCAL_CONSTRUCTOR_CALL)
+    return expand_expr (
+             build_predef_call (p_New, TREE_OPERAND (t, 0)),
+             r, mm, em);
 
 #if 0
   if (TREE_CODE (t) == NON_RVALUE_EXPR)

--- gcc-3.4.4-orig/gcc/p/lang-options.h	2005-03-21 11:31:02.000000000 +0100
+++ gcc-3.4.4/gcc/p/lang-options.h	2005-07-22 02:25:02.994802928 +0200
@@ -304,8 +304,12 @@
            "Do not warn when a unit/module interface differs from the file name (default)")
   GPC_OPT (1, "-fmethods-always-virtual", methods_always_virtual, 1,
            "Make all methods virtual (default in `--mac-pascal')")
-  GPC_OPT (0, "-fno-methods-always-virtual", methods_always_virtual, 0,
+  GPC_OPT (1, "-fno-methods-always-virtual", methods_always_virtual, 0,
            "Do not make all methods virtual (default)")
+  GPC_OPT (1, "-fobjects-are-references", objects_are_references, 1, 
+           "Turn objects into references (default in `--mac-pascal')")
+  GPC_OPT (1, "-fno-objects-are-references", objects_are_references, 0,
+           "Do not turn objects into references (default)")
   GPC_OPT (1, "-Wimplicit-abstract", warn_implicit_abstract, 1,
            "Warn when an object type not declared `abstract' contains an abstract method (default)")
   GPC_OPT (1, "-Wno-implicit-abstract", warn_implicit_abstract, 0,

--- gcc-3.4.4-orig/gcc/p/module.c	2005-03-25 21:32:59.000000000 +0100
+++ gcc-3.4.4/gcc/p/module.c	2005-07-01 13:47:45.000000000 +0200
@@ -2012,6 +2012,7 @@
 #ifdef EGCS
       store_node (TYPE_SIZE_UNIT (t));
 #endif
+      store_node (TYPE_POINTER_TO (t));
       store_node (TYPE_GET_INITIALIZER (t));
       store_node (TYPE_MAIN_VARIANT (t) == t ? NULL_TREE : TYPE_MAIN_VARIANT (t));
       break;
@@ -2478,6 +2479,7 @@
 #ifdef EGCS
         TYPE_SIZE_UNIT (t) = load_node ();
 #endif
+        TYPE_POINTER_TO (t) = load_node ();
         tmp = load_node ();
         if (tmp)
           {

--- gcc-3.4.4-orig/gcc/p/objects.c	2005-03-30 23:20:34.000000000 +0200
+++ gcc-3.4.4/gcc/p/objects.c	2005-07-22 03:08:46.298000224 +0200
@@ -36,12 +36,14 @@
 simple_get_field (tree name, tree type, const char *descr)
 {
   tree field = TYPE_FIELDS (type);
-  while (field && DECL_NAME (field) != name)
+  while (field && (DECL_NAME (field) != name
+         || PASCAL_FIELD_SHADOWED (field)))
     field = TREE_CHAIN (field);
   if (field)
     return field;
   field = TYPE_METHODS (type);
-  while (field && DECL_NAME (field) != name)
+  while (field && (DECL_NAME (field) != name 
+         || PASCAL_METHOD_SHADOWED (field)))
     field = TREE_CHAIN (field);
   if (!descr)
     gcc_assert (field);
@@ -96,7 +98,10 @@
     {
       tree t = current_method ();
       if (t)
-        for (t = DECL_CONTEXT (t); t && t != DECL_CONTEXT (field); t = TYPE_LANG_BASE (t)) ;
+        for (t = DECL_CONTEXT (t); t && t != DECL_CONTEXT (field);
+             t = TYPE_LANG_BASE (t))
+          if (TREE_CODE (t) == POINTER_TYPE)
+            t = TREE_TYPE (t);
       if (!t)
         return "protected";
     }
@@ -107,11 +112,16 @@
 tree
 call_method (tree cref, tree args)
 {
-  int is_virtual;
+  int is_virtual, is_destructor;
   tree obj = TREE_OPERAND (cref, 0);
+  tree type = TREE_TYPE (obj);
   tree fun = TREE_OPERAND (cref, 1);
+  tree constructor_call = NULL_TREE;
 
-  if (!PASCAL_TYPE_OBJECT (TREE_TYPE (obj)))
+  if (TREE_CODE (obj) == TYPE_DECL && PASCAL_TYPE_CLASS (type))
+    type = TREE_TYPE (type);
+
+  if (!PASCAL_TYPE_OBJECT (type))
     {
       error ("calling method of something not an object");
       return error_mark_node;
@@ -129,23 +139,37 @@
         but it doesn't work (works only on scalar types I guess),
         so do it only for INDIRECT_REFs. -- Frank */
   if (TREE_CODE (obj) == INDIRECT_REF)
-    obj = build1 (INDIRECT_REF, TREE_TYPE (obj), save_expr (TREE_OPERAND (obj, 0)));
+    obj = build1 (INDIRECT_REF, type, save_expr (TREE_OPERAND (obj, 0)));
 
   is_virtual = PASCAL_VIRTUAL_METHOD (fun);
   if (TREE_CODE (obj) == TYPE_DECL)
     {
-      if (!current_method ())
+      tree cmeth = current_method ();
+      if (PASCAL_CONSTRUCTOR_METHOD (fun) 
+          && PASCAL_TYPE_CLASS (TREE_TYPE (obj)))
+        constructor_call = tree_cons (NULL_TREE, 
+                               obj, tree_cons (NULL_TREE, cref, args));
+
+      if (!cmeth)
         /* Somebody is looking for the address of this method. Give them the FUNCTION_DECL. */
-        return fun;
+        {
+          if (constructor_call)
+            return build_predef_call (p_New, constructor_call);
+          return fun;
+        }
 
       /* This is an explicit call to an ancestor's method. */
-      fun = simple_get_field (DECL_NAME (fun), TREE_TYPE (obj), "method");
+      fun = simple_get_field (DECL_NAME (fun), type, "method");
       if (!fun)
         return error_mark_node;
       obj = build_indirect_ref (lookup_name (self_id), "`Self' reference");
       is_virtual = 0;
     }
 
+  is_destructor = PASCAL_DESTRUCTOR_METHOD (fun) 
+                  && TYPE_POINTER_TO (TREE_TYPE (obj)) 
+                  && PASCAL_TYPE_CLASS (TYPE_POINTER_TO (TREE_TYPE (obj)));
+
   if (is_virtual)
     {
       tree method = NULL_TREE, type_save, vmt = get_vmt_field (obj);
@@ -174,6 +198,27 @@
   /* Check if OBJ is an lvalue and do the call */
   if (lvalue_or_else (obj, "method call"))
     fun = build_routine_call (fun, tree_cons (NULL_TREE, obj, args));
+
+  if (constructor_call)
+    return build (PASCAL_CONSTRUCTOR_CALL, TYPE_POINTER_TO (type),
+                   constructor_call, fun);
+      
+  if (is_destructor)
+    {
+      tree cmeth = current_method ();
+      tree vobj;
+      gcc_assert (TREE_CODE (obj) == INDIRECT_REF);
+      vobj = TREE_OPERAND (obj, 0);
+      if (!cmeth || !PASCAL_DESTRUCTOR_METHOD (cmeth))
+        return build_predef_call (p_Dispose, tree_cons (NULL_TREE, vobj,
+                 build_tree_list (NULL_TREE, fun)));
+      else
+        {
+          error("Delphi/OOE continuing destructor activation unsupported");
+          return error_mark_node;
+        }
+    }
+
   return fun;
 }
 
@@ -209,19 +254,42 @@
 }
 
 tree
-start_object_type (tree name)
+start_object_type (tree name, int is_class)
 {
   tree t = start_struct (RECORD_TYPE);
-  if (co->pascal_dialect & MAC_PASCAL)
-    warning ("traditional Macintosh Pascal has a different object model from what GNU Pascal supports");
+  tree res;
+  if (co->objects_are_references)
+    is_class = 1;
+  if (is_class)
+    {
+      tree s, *pscan;
+      pscan = &current_type_list;
+      for (s = current_type_list; s && TREE_VALUE (s) != name;
+           pscan = &TREE_CHAIN (s), s = TREE_CHAIN (s)) ;
+      if (s && TREE_CODE (TREE_TYPE (TREE_PURPOSE (s))) == POINTER_TYPE
+          && PASCAL_TYPE_CLASS (TREE_TYPE (TREE_PURPOSE (s)))
+	  && TREE_CODE (TREE_TYPE (TREE_TYPE (TREE_PURPOSE (s)))) == LANG_TYPE)
+        {
+	  res = TREE_TYPE (TREE_PURPOSE (s));
+	  patch_type (t, TREE_TYPE (res));
+	  *pscan = TREE_CHAIN (s);
+	}
+      else
+	{
+          res = build_pointer_type (t);
+          PASCAL_TYPE_CLASS (res) = 1;
+	}
+    }
+  else
+    res = t;
   if (!pascal_global_bindings_p ())
     error ("object type definition only allowed at top level");
   TYPE_MODE (t) = BLKmode;  /* may be used as a value parameter within its methods */
   TYPE_ALIGN (t) = BIGGEST_ALIGNMENT;
   allocate_type_lang_specific (t);
   TYPE_LANG_CODE (t) = PASCAL_LANG_OBJECT;
-  build_type_decl (name, t, NULL_TREE);
-  return t;
+  build_type_decl (name, res, NULL_TREE);
+  return res;
 }
 
 /* Finish an object type started with start_object_type. Note: Don't return
@@ -244,11 +312,35 @@
 {
   tree fields, methods, field, parm, vmt_entry, vmt_type, size, vmt_field, t;
   tree *pfields, *pmethods, cp, init, f, ti;
-  const char *object_name = IDENTIFIER_NAME (DECL_NAME (TYPE_NAME (type))), *n;
+  tree object_type_name = DECL_NAME (TYPE_NAME (type));
+  const char *object_name = IDENTIFIER_NAME (object_type_name), *n;
   int protected_private = 0, has_virtual_method = 0, has_constructor = 0, i;
+  tree parent_type = parent;
+  int is_class = 0;
+
+  if (TREE_CODE (type) == POINTER_TYPE)
+    {
+      gcc_assert (PASCAL_TYPE_CLASS (type));
+      type = TREE_TYPE (type);
+      is_class = 1;
+    }
 
   if (parent && EM (parent))
-    parent = NULL_TREE;
+    parent_type = parent = NULL_TREE;
+
+  if (parent && TREE_CODE (parent) == POINTER_TYPE
+      && PASCAL_TYPE_CLASS (parent))
+    {
+      parent = TREE_TYPE (parent);
+      if (TREE_CODE (parent) == LANG_TYPE)
+        {
+          error ("forward class used as parent");
+          parent_type = parent = NULL_TREE;
+        }
+      else
+        gcc_assert (PASCAL_TYPE_OBJECT (parent));
+    }
+
   if (parent && !PASCAL_TYPE_OBJECT (parent))
     {
       tree parent_name = TYPE_NAME (parent);
@@ -297,9 +389,9 @@
       {
         tree heading = cp, assembler_name = NULL_TREE, method, method_field;
         tree t = TREE_TYPE (heading), name = DECL_NAME (heading);
-        tree method_name = get_method_name (DECL_NAME (TYPE_NAME (type)), name);
+        tree method_name = get_method_name (object_type_name, name);
         tree args, argtypes = build_formal_param_list (DECL_ARGUMENTS (heading), type, &args);
-        int virtual = 0, n = 0;
+        int virtual = 0, nv = 0, na = 0, override = 0;
         filename_t save_input_filename = input_filename;
         int save_lineno = lineno, save_column = column;
         if (!t)
@@ -322,7 +414,7 @@
                 if (co->methods_always_virtual)
                   warning ("explicit `virtual' given with `--methods-always-virtual'");
                 virtual = 1;
-                n++;
+                nv++;
                 if (TREE_PURPOSE (cp))
                   {
                     tree t = TREE_PURPOSE (cp);
@@ -339,15 +431,23 @@
             else if (IDENTIFIER_IS_BUILT_IN (TREE_VALUE (cp), p_abstract))
               {
                 virtual = 2;
-                n++;
+                na++;
               }
             else if (IDENTIFIER_IS_BUILT_IN (TREE_VALUE (cp), p_attribute))
               routine_attributes (&method, TREE_PURPOSE (cp), &assembler_name);
+            else if (IDENTIFIER_IS_BUILT_IN (TREE_VALUE (cp), p_override))
+              override++;
             else
               error ("unknown object method directive `%s'", IDENTIFIER_NAME (TREE_VALUE (cp)));
           }
-        if (n > 1)
+        if (na > 1 || nv > 1)
           error ("duplicate `virtual' or `abstract'");
+        if (override > 1)
+          {
+            error ("duplicate `override'");
+            override = 1;
+          }
+        PASCAL_METHOD_OVERRIDE (method) = override;
         DECL_EXTERNAL (method) = 1;
         PASCAL_FORWARD_DECLARATION (method) = virtual != 2;
         PASCAL_METHOD (method) = 1;
@@ -398,7 +498,17 @@
     for (field = i ? methods : fields; field; field = TREE_CHAIN (field))
       {
         tree t;
+#if 0
         for (t = parent; t && DECL_NAME (TYPE_NAME (t)) != DECL_NAME (field); t = TYPE_LANG_BASE (t)) ;
+#else
+        t = parent_type;
+        while (t && DECL_NAME (TYPE_NAME (t)) != DECL_NAME (field))
+          {
+            if (TREE_CODE (t) == POINTER_TYPE)
+              t = TREE_TYPE (t);
+            t = TYPE_LANG_BASE (t);
+          }
+#endif
         if (t)
           {
             if (PEDANTIC (B_D_PASCAL))  /* forbidden by OOE */
@@ -411,22 +521,39 @@
   if (parent)
     {
       /* Inheritance */
-      tree parent_methods, df, pf, *dm, *pm, t;
-      for (pf = TYPE_FIELDS (parent); pf; pf = TREE_CHAIN (pf))
+      tree parent_methods, df, pf, *dm, *pm, t,
+           parent_fields = copy_list (TYPE_FIELDS (parent));
+      for (pf = parent_fields; pf; pf = TREE_CHAIN (pf))
         {
-          for (df = fields; df && DECL_NAME (df) != DECL_NAME (pf); df = TREE_CHAIN (df));
+          if (PASCAL_FIELD_SHADOWED (pf))
+            continue;
+          for (df = fields; df && DECL_NAME (df) != DECL_NAME (pf); 
+               df = TREE_CHAIN (df)) ;
           if (df)
             {
-              error ("cannot overwrite data field `%s' of parent object type", IDENTIFIER_NAME (DECL_NAME (df)));
+              if (co->pascal_dialect & BORLAND_DELPHI)
+                PASCAL_FIELD_SHADOWED (pf) = 1;
+              else
+                error ("cannot overwrite data field `%s' of parent object type", IDENTIFIER_NAME (DECL_NAME (df)));
               continue;
             }
           for (df = methods; df && DECL_NAME (df) != DECL_NAME (pf); df = TREE_CHAIN (df));
           if (df)
-            error ("method `%s' conflicts with data field of parent object type", IDENTIFIER_NAME (DECL_NAME (df)));
+            {
+              if (co->pascal_dialect & BORLAND_DELPHI)
+                PASCAL_FIELD_SHADOWED (pf) = 1;
+              else
+                error ("method `%s' conflicts with data field of parent object type", IDENTIFIER_NAME (DECL_NAME (df)));
+            }
         }
       parent_methods = copy_list (TYPE_METHODS (parent));
       for (pm = &parent_methods; *pm; )
         {
+          if (PASCAL_METHOD_SHADOWED (*pm))
+            {
+              pm = &TREE_CHAIN (*pm);
+              continue;
+            }
           for (df = fields; df && DECL_NAME (df) != DECL_NAME (*pm); df = TREE_CHAIN (df));
           if (df)
             error ("data field `%s' conflicts with method of parent object type", IDENTIFIER_NAME (DECL_NAME (df)));
@@ -437,6 +564,19 @@
                 {
                   static const char *const descr[3] = { "public", "protected", "private" };
                   int p1 = PUBLIC_PRIVATE_PROTECTED (*pm), p2 = PUBLIC_PRIVATE_PROTECTED (*dm);
+                  if (is_class && !PASCAL_METHOD_OVERRIDE (*dm))
+                    {
+                      if (co->pascal_dialect & BORLAND_DELPHI)
+                        {
+                          PASCAL_METHOD_SHADOWED (*pm) = 1;
+                          pm = &TREE_CHAIN (*pm);
+                          continue;
+                        }
+                      else
+                        error ("method `%s', overrides parent method",
+                               IDENTIFIER_NAME (DECL_NAME (*dm)));
+                    }
+                  PASCAL_METHOD_OVERRIDE (*dm) = 0;
                   if (p1 < p2)
                     {
                       if (pedantic || !(co->pascal_dialect & B_D_PASCAL))
@@ -483,7 +623,7 @@
             }
           pm = &TREE_CHAIN (*pm);
         }
-      fields = chainon (copy_list (TYPE_FIELDS (parent)), fields);
+      fields = chainon (parent_fields, fields);
       methods = chainon (parent_methods, methods);
       vmt_field = fields;  /* i.e., first field */
       gcc_assert (DECL_NAME (vmt_field) == vmt_id);
@@ -501,7 +641,7 @@
   TYPE_ALIGN (type) = BIGGEST_ALIGNMENT;
   TYPE_LANG_CODE (type) = abstract ? PASCAL_LANG_ABSTRACT_OBJECT : PASCAL_LANG_OBJECT;
   TYPE_LANG_VMT_FIELD (type) = vmt_field;
-  TYPE_LANG_BASE (type) = parent;
+  TYPE_LANG_BASE (type) = parent_type;
   TYPE_METHODS (type) = methods;
 
   init = NULL_TREE;
@@ -599,7 +739,7 @@
      for `is', `as' and explicit parent type access via VMT).
      VQ_IMPLICIT suppresses `unused variable' warning and prevents it
      from being pushed as a regular declaration (which is unnecessary). */
-  n = ACONCAT (("vmt_", IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))), NULL));
+  n = ACONCAT (("vmt_", IDENTIFIER_POINTER (object_type_name), NULL));
   TYPE_LANG_VMT_VAR (type) = declare_variable (get_identifier (n), vmt_type,
     build_tree_list (NULL_TREE, vmt_entry), VQ_IMPLICIT | VQ_CONST | (current_module->implementation ? VQ_STATIC : 0));
 
@@ -627,6 +767,16 @@
 build_is_as (tree left, tree right, int op)
 {
   const char *opname = (op == p_is) ? "is" : "as";
+  int want_class = 0;
+  tree oleft = left;
+  if (TREE_CODE (right) == POINTER_TYPE && PASCAL_TYPE_CLASS (right))
+    {
+      right = TREE_TYPE (right);
+      want_class = 1;
+    }
+  if (TREE_CODE (TREE_TYPE (left)) == POINTER_TYPE
+      && PASCAL_TYPE_CLASS (TREE_TYPE (left)))
+    left = build_indirect_ref (left, NULL);
   if (!PASCAL_TYPE_OBJECT (right))
     error ("right operand of `%s' must be an object type", opname);
   else if (!PASCAL_TYPE_OBJECT (TREE_TYPE (left)))
@@ -640,7 +790,11 @@
              || TREE_CODE (l) == NON_LVALUE_EXPR)
         l = TREE_OPERAND (l, 0);
       while (t && TYPE_MAIN_VARIANT (t) != tl)
-        t = TYPE_LANG_BASE (t);
+        {
+          t = TYPE_LANG_BASE (t);
+          if (t && TREE_CODE (t) == POINTER_TYPE)
+            t = TREE_TYPE (t);
+        }
       if (!t)
         {
           error ("right operand of `%s' must be a derived type", opname);
@@ -660,7 +814,7 @@
             {
               warning ("`as' has no effect if the right operand is");
               warning (" the declared type of the left operand");
-              return left;
+              return oleft;
             }
         }
       /* Variables, value parameters and components are not polymorphic.
@@ -706,12 +860,13 @@
                  within the RTS so the compiler can optimize a construction like
                  `if foo is bar then something (foo as bar)'. */
               p_right = build_pointer_type (right);
-              return build_indirect_ref (save_expr (
+              res = save_expr (
                        build (COMPOUND_EXPR, p_right,
                          build (COND_EXPR, void_type_node, res,
                                 convert (void_type_node, integer_zero_node),
                                 build_predef_call (p_as, NULL_TREE)),
-                         convert (p_right, build_pascal_unary_op (ADDR_EXPR, left)))), NULL);
+                         convert (p_right, build_pascal_unary_op (ADDR_EXPR, left))));
+              return want_class ? res : build_indirect_ref (res, NULL);
             }
         }
     }

--- gcc-3.4.4-orig/gcc/p/opts.sum	2005-03-21 11:30:55.000000000 +0100
+++ gcc-3.4.4/gcc/p/opts.sum	2005-07-22 02:25:02.996802624 +0200
@@ -46,6 +46,7 @@
 fnested-comments::Allow nested comments like `{ { } }' and `(* (* *) *)'
 fnonlocal-exit::Allow non-local `Exit' statements (default in `--ucsd-pascal' and `--mac-pascal')
 fobject-checking::Check for valid objects on virtual method calls (default)
+fobjects-are-references::Turn objects into references (default in `--mac-pascal')
 fpedantic::Reject everything not allowed in some dialect, e.g. redefinition of its keywords
 fpointer-arithmetic::Enable pointer arithmetic
 fpointer-checking::Validate pointers before dereferencing

--- gcc-3.4.4-orig/gcc/p/parse.y	2005-03-30 04:46:08.000000000 +0200
+++ gcc-3.4.4/gcc/p/parse.y	2005-07-22 02:32:56.657795208 +0200
@@ -132,6 +132,7 @@
   p_implementation p_import p_inherited p_initialization p_is p_near p_object
   p_only p_operator p_otherwise p_or_else p_pow p_qualified p_restricted p_shl
   p_shr p_unit p_uses p_value p_virtual p_xor p_asmname p_c p_c_language
+  p_class p_override
 
 /* Built-in identifiers with special syntax */
 %token <ttype>
@@ -735,9 +736,36 @@
   | new_identifier formal_schema_discriminants error
       { build_schema_type (error_mark_node, $2, NULL_TREE); }
   | new_identifier enable_lce equals
-      { $<ttype>$ = start_object_type ($1); }
+      { $<ttype>$ = start_object_type ($1, 0); }
     optional_abstract p_object object_parent object_field_list p_end
       { lex_const_equal = -1; finish_object_type ($<ttype>4, $7, $8, $5 != NULL_TREE); yyerrok; }
+  | new_identifier enable_lce equals
+      { $<ttype>$ = start_object_type ($1, 1); }
+    optional_abstract p_class object_parent object_field_list p_end
+      {
+        lex_const_equal = -1;
+        finish_object_type ($<ttype>4, $7, $8, $5 != NULL_TREE);
+        yyerrok;
+      }
+  | new_identifier enable_lce equals p_class object_parent
+      {
+        tree t = build_pascal_pointer_type (make_node (LANG_TYPE));
+        PASCAL_TYPE_CLASS (t) = 1;
+        build_type_decl ($1, t, NULL_TREE);
+        warning("ignored parent in Delphi forward class declaration");
+      }
+  | new_identifier enable_lce equals p_class LEX_RANGE p_end
+      {
+        tree t = build_pascal_pointer_type (make_node (LANG_TYPE));
+	PASCAL_TYPE_CLASS (t) = 1;
+	build_type_decl ($1, t, NULL_TREE); 
+      }
+  | new_identifier enable_lce equals p_object ';' p_forward
+      {
+        tree t = build_pascal_pointer_type (make_node (LANG_TYPE));
+        PASCAL_TYPE_CLASS (t) = 1;
+        build_type_decl ($1, t, NULL_TREE);
+      }
   ;
 
 formal_schema_discriminants:
@@ -1050,6 +1078,8 @@
       { $$ = build_tree_list (NULL_TREE, $1); }
   | p_virtual expression
       { $$ = build_tree_list ($2, $1); }
+  | p_override
+      { $$ = build_tree_list (NULL_TREE, $1); }
   | p_abstract
       { $$ = build_tree_list (NULL_TREE, $1); }
   | attributes
@@ -1917,7 +1947,7 @@
   | '(' bp_constructor_list ')' %dprec 2
       { PASCAL_BP_INITIALIZER_LIST (($$ = nreverse ($2))) = 1; }
   | '[' structured_constructor_list ']' %dprec 2
-      { chk_dialect ("constructors in `[]' are", E_O_PASCAL); $$ = nreverse ($2); }
+      { $$ = nreverse ($2); }
   | '[' error ']'
       { error ("invalid component value"); $$ = error_mark_node; }
   ;
@@ -2170,6 +2200,7 @@
   | p_bindable
   | p_c
   | p_c_language
+  | p_class
   | p_constructor
   | p_destructor
   | p_external
@@ -2184,6 +2215,7 @@
   | p_operator
   | p_or_else
   | p_otherwise
+  | p_override
   | p_pow
   | p_qualified
   | p_restricted

--- gcc-3.4.4-orig/gcc/p/predef.c	2005-03-31 01:15:48.000000000 +0200
+++ gcc-3.4.4/gcc/p/predef.c	2005-06-14 03:18:49.000000000 +0200
@@ -2918,7 +2918,10 @@
       tree t;
       if (r_num == p_New)
         {
-          t = TYPE_NAME (TREE_TYPE (TREE_TYPE (arg1)));
+          if (PASCAL_TYPE_CLASS (TREE_TYPE (arg1)))
+            t = TYPE_NAME (TREE_TYPE (t));
+          else
+            t = TYPE_NAME (TREE_TYPE (TREE_TYPE (arg1)));
           gcc_assert (TREE_CODE (t) == TYPE_DECL);
           t = arg2_id ? build_component_ref (t, arg2_id) : NULL_TREE;
           if (t && !EM (t) && PASCAL_CONSTRUCTOR_METHOD (TREE_OPERAND (t, 1)))

--- gcc-3.4.4-orig/gcc/p/predef.def	2005-03-30 01:04:10.000000000 +0200
+++ gcc-3.4.4/gcc/p/predef.def	2005-07-22 02:41:10.442728488 +0200
@@ -57,7 +57,7 @@
 PREDEF_KEYWORD (and,            0, ANY_PASCAL)          /* Boolean or bitwise `and' operator or part of the <and then> operator */
 PREDEF_KEYWORD (and_then,       1, E_O_PASCAL)          /* short-circuit Boolean <and> operator */
 PREDEF_KEYWORD (array,          0, ANY_PASCAL)          /* array type declaration */
-PREDEF_KEYWORD (as,             1, O_D_PASCAL)          /* object type membership test and conversion */
+PREDEF_KEYWORD (as,             1, O_D_M_PASCAL)        /* object type membership test and conversion */
 PREDEF_KEYWORD (asm,            1, B_D_PASCAL)          /* GNU style inline assembler code */
 PREDEF_KEYWORD (asmname,        1, GNU_PASCAL)          /* DEPRECATED! linker name of routines and variables */
 PREDEF_KEYWORD (attribute,      1, GNU_PASCAL)          /* attributes of routines and variables */
@@ -66,6 +66,7 @@
 PREDEF_KEYWORD (c,              1, GNU_PASCAL)          /* DEPRECATED! declaration of external routine */
 PREDEF_KEYWORD (c_language,     1, GNU_PASCAL)          /* DEPRECATED! declaration of external routine */
 PREDEF_KEYWORD (case,           0, ANY_PASCAL)          /* multi-branch conditional statement or variant <record> type */
+PREDEF_KEYWORD (class,          1, O_D_PASCAL)          /* OOE/Delphi class */
 PREDEF_KEYWORD (const,          0, ANY_PASCAL)          /* constant declaration or constant parameter declaration */
 PREDEF_KEYWORD (constructor,    1, O_B_D_PASCAL)        /* object constructor */
 PREDEF_KEYWORD (destructor,     1, O_B_D_PASCAL)        /* object destructor */
@@ -88,7 +89,7 @@
 PREDEF_KEYWORD (in,             0, ANY_PASCAL)          /* set membership test or part of a <for> loop iterating through sets */
 PREDEF_KEYWORD (inherited,      1, O_B_D_M_PASCAL)      /* reference to methods of ancestor object types */
 PREDEF_KEYWORD (initialization, 1, BORLAND_DELPHI)      /* unit initialization */
-PREDEF_KEYWORD (is,             1, O_D_PASCAL)          /* object type membership test */
+PREDEF_KEYWORD (is,             1, O_D_M_PASCAL)        /* object type membership test */
 PREDEF_KEYWORD (label,          0, ANY_PASCAL)          /* label declaration for a <goto> statement */
 PREDEF_KEYWORD (mod,            0, ANY_PASCAL)          /* integer remainder operator */
 PREDEF_KEYWORD (near,           0, B_D_PASCAL)          /* BP directive (ignored) */
@@ -121,18 +122,24 @@
 PREDEF_KEYWORD (value,          1, E_O_PASCAL)          /* variable/type initializer */
 PREDEF_KEYWORD (var,            0, ANY_PASCAL)          /* variable declaration or reference parameter declaration */
 PREDEF_KEYWORD (virtual,        1, O_B_D_M_PASCAL)      /* virtual object method declaration */
+PREDEF_KEYWORD (override,       1, O_D_M_PASCAL)        /* override directive */
 PREDEF_KEYWORD (while,          0, ANY_PASCAL)          /* loop statement */
 PREDEF_KEYWORD (with,           0, ANY_PASCAL)          /* automatic <record> or object field access */
 PREDEF_KEYWORD (xor,            1, B_D_M_PASCAL)        /* Boolean or bitwise `exclusive or' operator */
 #if 0
-PREDEF_KEYWORD (class,          1, O_D_PASCAL)          /* OOE/Delphi style object class (not yet implemented) */
+PREDEF_KEYWORD (property,       1, O_D_PASCAL)          /* OOE property classes/Delphi object properties (not yet implemented) */
+PREDEF_KEYWORD (view,           1, OBJECT_PASCAL)       /* object class view (not yet implemented) */
+PREDEF_KEYWORD (try,            1, BORLAND_DELPHI)      /* try statement */
+PREDEF_KEYWORD (except,         1, BORLAND_DELPHI)      /* exception handler */
+PREDEF_KEYWORD (finally,        1, BORLAND_DELPHI)      /* block finally */
+PREDEF_KEYWORD (overload,       1, BORLAND_DELPHI)      /* overload directive */
+PREDEF_KEYWORD (raise,          1, BORLAND_DELPHI)      /* raise statement */
+PREDEF_KEYWORD (on,             1, BORLAND_DELPHI)      /* on clause */
 PREDEF_KEYWORD (exports,        1, B_D_PASCAL)          /* library export (not yet implemented) */
 PREDEF_KEYWORD (interrupt,      1, B_D_PASCAL)          /* interrupt handler declaration (not yet implemented) */
 PREDEF_KEYWORD (library,        1, B_D_PASCAL)          /* library declaration (not yet implemented) */
-PREDEF_KEYWORD (property,       1, O_D_PASCAL)          /* object properties (not yet implemented) */
 PREDEF_KEYWORD (resident,       1, B_D_PASCAL)          /* library export specification (not yet implemented) */
 PREDEF_KEYWORD (segment,        1, UCSD_PASCAL)         /* segment specification (not yet implemented) */
-PREDEF_KEYWORD (view,           1, OBJECT_PASCAL)       /* object class view (not yet implemented) */
 #endif
 
 PREDEF_INTERFACE (StandardInput,  E_O_PASCAL)

--- gcc-3.4.4-orig/gcc/p/p-tree.def	2005-03-15 02:44:32.000000000 +0100
+++ gcc-3.4.4/gcc/p/p-tree.def	2005-07-22 02:25:02.997802472 +0200
@@ -29,6 +29,7 @@
 DEFTREECODE (INTERFACE_NAME_NODE, "interface_name_node", 'x', 3)
 DEFTREECODE (IMPORT_NODE, "import_node", 'x', 4)
 DEFTREECODE (PASCAL_BIT_FIELD_REF, "pascal_bit_field_ref", 'r', 3)
+DEFTREECODE (PASCAL_CONSTRUCTOR_CALL, "pascal_constructor_call", '2', 2)
 DEFTREECODE (POWER_EXPR, "power_expr", '2', 2)
 DEFTREECODE (POW_EXPR, "pow_expr", '2', 2)
 DEFTREECODE (SYMDIFF_EXPR, "symdiff_expr", '2', 2)
@@ -37,6 +38,7 @@
 DEFTREECODE (INTERFACE_NAME_NODE, "interface_name_node", "x", 3)
 DEFTREECODE (IMPORT_NODE, "import_node", "x", 4)
 DEFTREECODE (PASCAL_BIT_FIELD_REF, "pascal_bit_field_ref", "r", 3)
+DEFTREECODE (PASCAL_CONSTRUCTOR_CALL, "pascal_constructor_call", "2", 2)
 DEFTREECODE (POWER_EXPR, "power_expr", "2", 2)
 DEFTREECODE (POW_EXPR, "pow_expr", "2", 2)
 DEFTREECODE (SYMDIFF_EXPR, "symdiff_expr", "2", 2)

--- gcc-3.4.4-orig/gcc/p/statements.c	2005-03-31 01:57:24.000000000 +0200
+++ gcc-3.4.4/gcc/p/statements.c	2005-07-22 02:25:02.998802320 +0200
@@ -1082,6 +1082,8 @@
       t = call_method (t, NULL_TREE);
       function_called = 1;
     }
+  if (TREE_CODE (t) == PASCAL_CONSTRUCTOR_CALL)
+    t = convert (void_type_node, TREE_OPERAND (t, 1));
   if (!EM (t))
     {
       if (PASCAL_TREE_IGNORABLE (t))
@@ -1113,8 +1115,12 @@
   if (CALL_METHOD (target))
     {
       tree method_name = DECL_NAME (TREE_OPERAND (target, 1));
+      tree op0 = TREE_OPERAND (target, 0);
+      tree t = TREE_TYPE (op0);
+      if (TYPE_POINTER_TO (t) && PASCAL_TYPE_CLASS (TYPE_POINTER_TO (t)))
+        t = TYPE_POINTER_TO (t);
       target = lookup_name (get_method_name (
-        DECL_NAME (TYPE_NAME (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (target, 0))))), method_name));
+        DECL_NAME (TYPE_NAME (TYPE_MAIN_VARIANT (t))), method_name));
       if (!target)
         {
           error ("result of method `%s' assigned outside its block", IDENTIFIER_NAME (method_name));

--- gcc-3.4.4-orig/gcc/p/typecheck.c	2005-03-31 02:41:31.000000000 +0200
+++ gcc-3.4.4/gcc/p/typecheck.c	2005-07-22 02:25:03.000802016 +0200
@@ -531,8 +531,15 @@
 
   if (PASCAL_TYPE_OBJECT (lhs) && PASCAL_TYPE_OBJECT (rhs))
     for (r = rhs; r; r = TYPE_LANG_BASE (r))
-      if (TYPE_MAIN_VARIANT (lhs) == TYPE_MAIN_VARIANT (r))
-        return 1;
+      {
+        if (TREE_CODE (r) == POINTER_TYPE)
+          {
+            gcc_assert (PASCAL_TYPE_CLASS (r));
+            r = TREE_TYPE (r);
+          }
+        if (TYPE_MAIN_VARIANT (lhs) == TYPE_MAIN_VARIANT (r))
+          return 1;
+      }
   return 0;
 }
 
@@ -1401,14 +1408,29 @@
   /* Structured initializer. */
   if (TREE_CODE (type) == ARRAY_TYPE)
     {
+      int borland_list = PASCAL_BP_INITIALIZER_LIST (TREE_VALUE (init));
+      if (borland_list)
+        chk_dialect ("initializers in `()' are", B_D_M_PASCAL);
+      else
+        chk_dialect ("initializers in `[]' are", E_O_PASCAL);
       for (link = TREE_VALUE (init); link; link = TREE_CHAIN (link))
         {
           tree index = TREE_PURPOSE (link), domain = TYPE_MAIN_VARIANT (TYPE_DOMAIN (type));
+#if 0
           /* The parser can't check this because it might be an expression in `()'. */
           if (PASCAL_BP_INITIALIZER_LIST (link))
-            chk_dialect ("initializers in `()' are", B_D_M_PASCAL);
-          else if (!index)
-            chk_dialect ("omitting indices in array initializers is", B_D_M_PASCAL);
+            ; /* chk_dialect ("initializers in `()' are", B_D_M_PASCAL); */
+          else
+            {
+//              chk_dialect ("initializers in `[]' are", E_O_PASCAL);
+              if (!index)
+                chk_dialect ("omitting indices in array initializers is", B_D_M_PASCAL);
+            }
+#else
+          if (!borland_list && !index)
+            chk_dialect ("omitting indices in array initializers is",
+                           B_D_M_PASCAL);
+#endif
           while (index)
             {
               tree t = TREE_PURPOSE (index), t2 = TREE_VALUE (index);
@@ -1444,6 +1466,8 @@
     {
       if (PASCAL_BP_INITIALIZER_LIST (TREE_VALUE (init)))
         chk_dialect ("initializers in `()' are", B_D_M_PASCAL);
+      else
+        chk_dialect ("initializers in `[]' are", E_O_PASCAL);
       /* Insert `nil' for the VMT pointer (will be initialized, anyway). */
       if (PASCAL_TYPE_OBJECT (type))
         TREE_VALUE (init) = tree_cons (NULL_TREE, null_pointer_node, TREE_VALUE (init));

--- gcc-3.4.4-orig/gcc/p/types.c	2005-03-31 02:10:15.000000000 +0200
+++ gcc-3.4.4/gcc/p/types.c	2005-07-22 02:25:03.002801712 +0200
@@ -1842,9 +1842,12 @@
               }
         }
       if (!field)
-        for (kind = "method", field = TYPE_METHODS (type); field; field = TREE_CHAIN (field))
-          if (DECL_NAME (field) == component)
-            break;
+        {
+          tree fl = TYPE_METHODS (type);
+          for (kind = "method"; fl; fl = TREE_CHAIN (fl))
+            if (DECL_NAME (fl) == component)
+              field = fl;
+        }
     }
   if (!field || mode == 2)
     return field;
@@ -1861,9 +1864,12 @@
 
   if (TREE_CODE (datum) == TYPE_DECL)
     {
-      if (PASCAL_TYPE_OBJECT (TREE_TYPE (datum)))
+      if (TREE_CODE (TREE_TYPE (datum)) == POINTER_TYPE
+           && PASCAL_TYPE_CLASS (TREE_TYPE (datum)))
+        type = TREE_TYPE (type);
+      if (PASCAL_TYPE_OBJECT (type))
         {
-          field = simple_get_field (component, TREE_TYPE (datum), "");
+          field = simple_get_field (component, type, "");
           if (!field || TREE_CODE (field) != FUNCTION_DECL)
             {
               error ("object has no method named `%s'", IDENTIFIER_NAME (component));
@@ -1887,6 +1893,12 @@
       type = TREE_TYPE (datum);
     }
 
+  if (TREE_CODE (type) == POINTER_TYPE && PASCAL_TYPE_CLASS (type))
+    {
+      datum = build_indirect_ref (datum, NULL);
+      type = TREE_TYPE (datum);
+    }
+
   gcc_assert (TREE_CODE (datum) != COND_EXPR);
   if (TREE_CODE (datum) == COMPOUND_EXPR)
     {
@@ -1907,7 +1919,7 @@
       /* For Pascal: implicitly propagate to the inner layers
          of records and unions whose DECL_NAME is NULL_TREE.
          find_field() also constructs a TREE_LIST of fields and returns that. */
-      field = find_field (TREE_TYPE (datum), component, implicit);
+      field = find_field (type /* TREE_TYPE (datum) */, component, implicit);
 
       if (!field)
         {
@@ -2197,7 +2209,10 @@
 build_array_ref_or_constructor (tree t1, tree t2)
 {
   if (TREE_CODE (t1) == TYPE_DECL && TREE_CODE (TREE_TYPE (t1)) == SET_TYPE)
-    return build_iso_set_constructor (TREE_TYPE (t1), t2, 0);
+    {
+      chk_dialect ("structured value constructors are", E_O_PASCAL);
+      return build_iso_set_constructor (TREE_TYPE (t1), t2, 0);
+    }
   else
     {
       tree list = t2;

--- gcc-3.4.4-orig/gcc/p/utils/gpidump.pas	2005-03-31 01:01:01.000000000 +0200
+++ gcc-3.4.4/gcc/p/utils/gpidump.pas	2005-07-01 14:05:53.000000000 +0200
@@ -836,6 +836,7 @@
              {$ifdef EGCS}
              Ref ('size_unit');
              {$endif}
+             Ref ('pointer_to');
              OptRef ('initializer');
              OptRef ('main_variant');
            end;

--- gcc-3.4.4-orig/gcc/p/test/delphi1b.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/delphi1b.pas	2005-07-22 03:48:40.735990320 +0200
@@ -0,0 +1,38 @@
+program delphi1b;
+
+
+type
+  TAnimal = Class
+  protected
+    Procedure DoSound; virtual;
+  public
+    Constructor MakeAnimal;
+    Destructor UnMakeAnimal;
+    Procedure MakeSound;
+  end;
+
+Constructor TAnimal.MakeAnimal;
+begin
+end;
+
+Destructor TAnimal.UnMakeAnimal;
+begin
+end;
+
+Procedure TAnimal.DoSound;
+begin
+  WriteLn ('OK');
+end;
+
+Procedure TAnimal.MakeSound;
+begin
+  DoSound;
+end;
+
+VAR Animal : TAnimal;
+
+begin
+  Animal := TAnimal.MakeAnimal;
+  Animal.MakeSound;
+  Animal.UnMakeAnimal;
+end.

--- gcc-3.4.4-orig/gcc/p/test/delphi1c.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/delphi1c.pas	2005-07-22 03:48:40.735990320 +0200
@@ -0,0 +1,61 @@
+program delphi1c;
+type 
+  c1 = class
+    constructor cs;
+    destructor ds;
+    procedure p;
+    i : integer
+  end;
+  c2 = class (c1)
+    constructor cs; override;
+    cf : c1;
+  end;
+
+procedure failure;
+begin
+  writeln('failed');
+  halt
+end;
+
+var j : integer;
+    k : integer;
+constructor c1.cs;
+begin
+  i := 0;
+  if j = k then j := k + 1
+  else failure
+end;
+
+destructor c1.ds;
+begin
+  if j = 5 then j := 6
+  else failure
+end;
+
+procedure c1.p;
+begin
+  if i = j then j := j + 1
+  else failure
+end;
+
+constructor c2.cs;
+begin
+  k := 1;
+  c1.cs;
+  if j = 2 then j := 3
+  else failure;
+  k := j;
+  i := 4;
+  cf := c1.cs;
+end;
+
+var v : c2;
+begin
+  j := 1;
+  v := c2.cs;
+  v.p;
+  v.ds;
+  if j = 6 then writeln('OK')
+  else failure
+end
+.

--- gcc-3.4.4-orig/gcc/p/test/delset.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/delset.pas	2005-07-22 03:39:15.223961216 +0200
@@ -0,0 +1,8 @@
+{$delphi}
+program delset(output);
+type st = set of 0..8;
+const s1 : st = [2];
+begin
+  writeln('OK')
+end
+.

--- gcc-3.4.4-orig/gcc/p/test/fjf903c.pas	2003-07-10 18:43:24.000000000 +0200
+++ gcc-3.4.4/gcc/p/test/fjf903c.pas	2005-06-22 07:46:41.000000000 +0200
@@ -8,9 +8,8 @@
     procedure p;
   end;
 
-  pb = ^b;
   b = object (a)
-    procedure p;
+    procedure p; override;
   end;
   {$endlocal}
 
@@ -25,9 +24,9 @@
 end;
 
 var
-  v: ^a;
+  v: a;
 
 begin
-  v := New (pb);
-  v^.p
+  v := New (b);
+  v.p
 end.

--- gcc-3.4.4-orig/gcc/p/test/peter5a.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5a.pas	2005-07-22 03:48:40.735990320 +0200
@@ -0,0 +1,91 @@
+{ Mac Pascal objects }
+
+{$mac-pascal}
+
+program peter5a;
+
+        type
+                Str = String[100];
+                BaseObject = object
+                        v1: Str;
+                        function m1: Str;
+                        function m2: Str;
+                end;
+                SuperObject = object(BaseObject)
+                        v2: Str;
+                        v3: Str;
+                        function m1: Str; override;
+                        function m2: Str; override;
+                        function m3: Str;
+                end;
+
+        var
+                good: Boolean;
+
+        function BaseObject.m1: Str;
+        begin
+                return 'BaseObject.' + v1;
+        end;
+
+        function BaseObject.m2: Str;
+        begin
+                return 'BaseObject.nov2';
+        end;
+
+        function SuperObject.m1: Str;
+        begin
+                return 'SuperObject.' + (inherited m1) + '.' + v1;
+        end;
+
+        function SuperObject.m2: Str;
+        begin
+                return 'SuperObject.' + (inherited m2) + '.' + v2;
+        end;
+
+        function SuperObject.m3: Str;
+        begin
+                return 'SuperObject.' + v3;
+        end;
+
+        procedure CheckEqual( const param, s1, s2: Str );
+        begin
+                if s1 <> s2 then begin
+                        good := false;
+                        WriteLn( 'Failed: ', param, ' = ', s1, ' is not equal to ', s2 );
+                end;
+        end;
+
+        var
+                base: BaseObject;
+                super: SuperObject;
+                reallysuper: BaseObject;
+begin
+        New(base);
+        base.v1 := 'basev1';
+
+        New(super);
+        super.v1 := 'superv1';
+        super.v2 := 'superv2';
+        super.v3 := 'superv3';
+
+        reallysuper := super; { reference copy only! }
+
+        good := true;
+
+        CheckEqual( 'base.m1', base.m1, 'BaseObject.basev1' );
+        CheckEqual( 'base.m2', base.m2, 'BaseObject.nov2' );
+
+        CheckEqual( 'super.m1', super.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'super.m2', super.m2, 'SuperObject.BaseObject.nov2.superv2' );
+        CheckEqual( 'super.m3', super.m3, 'SuperObject.superv3' );
+
+        CheckEqual( 'reallysuper.m1', reallysuper.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'reallysuper.m2', reallysuper.m2, 'SuperObject.BaseObject.nov2.superv2' );
+
+        if good then begin
+                WriteLn( 'OK' );
+        end;
+
+        Dispose( base );
+        Dispose( super );
+end.

--- gcc-3.4.4-orig/gcc/p/test/peter5b.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5b.pas	2005-07-22 03:48:40.736990168 +0200
@@ -0,0 +1,94 @@
+{ Mac Pascal objects }
+
+{$mac-pascal}
+
+program peter5b;
+
+        type
+                Str = String[100];
+                BaseObject = object
+                        v1: Str;
+                        function m1: Str;
+                        function m2: Str;
+                end;
+                SuperObject = object(BaseObject)
+                        v2: Str;
+                        v3: Str;
+                        function m1: Str; override;
+                        function m2: Str; override;
+                        function m3: Str;
+                end;
+
+        var
+                good: Boolean;
+
+        function BaseObject.m1: Str;
+        begin
+                return 'BaseObject.' + v1;
+        end;
+
+        function BaseObject.m2: Str;
+        begin
+                return 'BaseObject.nov2';
+        end;
+
+        function SuperObject.m1: Str;
+        begin
+                return 'SuperObject.' + (inherited m1) + '.' + v1;
+        end;
+
+        function SuperObject.m2: Str;
+        begin
+                return 'SuperObject.' + (inherited m2) + '.' + v2;
+        end;
+
+        function SuperObject.m3: Str;
+        begin
+                return 'SuperObject.' + v3;
+        end;
+
+        procedure CheckEqual( const param, s1, s2: Str );
+        begin
+                if s1 <> s2 then begin
+                        good := false;
+                        WriteLn( 'Failed: ', param, ' = ', s1, ' is not equal to ', s2 );
+                end;
+        end;
+
+        var
+                base: BaseObject;
+                super: SuperObject;
+                reallysuper: BaseObject;
+begin
+        New(base);
+        base.v1 := 'basev1';
+
+        New(super);
+        with super do begin
+          v1 := 'superv1';
+          v2 := 'superv2';
+          v3 := 'superv3';
+        end;
+
+        reallysuper := super; { reference copy only! }
+
+        good := true;
+
+        with base do begin
+        CheckEqual( 'base.m1', m1, 'BaseObject.basev1' );
+        CheckEqual( 'base.m2', m2, 'BaseObject.nov2' );
+        end;
+        CheckEqual( 'super.m1', super.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'super.m2', super.m2, 'SuperObject.BaseObject.nov2.superv2' );
+        CheckEqual( 'super.m3', super.m3, 'SuperObject.superv3' );
+
+        CheckEqual( 'reallysuper.m1', reallysuper.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'reallysuper.m2', reallysuper.m2, 'SuperObject.BaseObject.nov2.superv2' );
+
+        if good then begin
+                WriteLn( 'OK' );
+        end;
+
+        Dispose( base );
+        Dispose( super );
+end.

--- gcc-3.4.4-orig/gcc/p/test/peter5c.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5c.pas	2005-07-22 03:48:40.736990168 +0200
@@ -0,0 +1,32 @@
+{$mac-pascal}
+program peter5c(output);
+
+   type
+     ObjectA = object
+       procedure Doit;
+     end;
+     ObjectB = object
+       obj: ObjectA;
+       function GetA: ObjectA;
+     end;
+
+   procedure ObjectA.Doit;
+   begin
+     WriteLn( 'OK' );
+   end;
+
+   function ObjectB.GetA: ObjectA;
+   begin
+     return obj;
+   end;
+
+var
+   a: ObjectA;
+   b: ObjectB;
+begin
+   New(a);
+   New(b);
+   b.obj := a;
+   b.GetA.Doit;
+end.
+

--- gcc-3.4.4-orig/gcc/p/test/peter5d.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5d.pas	2005-07-22 03:48:40.736990168 +0200
@@ -0,0 +1,21 @@
+{$mac-pascal}
+program peter5d(output);
+
+        type
+                obj = object
+                        procedure Destroy;
+                end;
+
+        procedure obj.Destroy;
+        begin
+                dispose( self );
+        end;
+
+        var
+                o: obj;
+begin
+        new(o);
+        o.Destroy;
+        WriteLn( 'OK' );
+end.
+

--- gcc-3.4.4-orig/gcc/p/test/peter5e.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5e.pas	2005-07-22 03:48:40.736990168 +0200
@@ -0,0 +1,24 @@
+{$mac-pascal}
+program peter5e(output);
+
+type
+    obj = object
+              procedure Destroy;
+          end;
+
+var dobj : obj;
+
+procedure obj.Destroy;
+begin
+    dobj := self;
+    dispose( dobj );
+end;
+
+var
+    o: obj;
+begin
+    new(o);
+    o.Destroy;
+    WriteLn( 'OK' );
+end.
+

--- gcc-3.4.4-orig/gcc/p/test/peter5f.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5f.pas	2005-07-22 03:48:40.736990168 +0200
@@ -0,0 +1,17 @@
+{$mac-pascal}
+program peter5f(output);
+
+        type
+                MyCollection = object
+                        function GetDataHandle: Integer;
+                end;
+
+        function MyCollection.GetDataHandle: Integer;
+        begin
+                GetDataHandle := 0;
+        end;
+
+begin
+        WriteLn( 'OK' );
+end.
+

--- gcc-3.4.4-orig/gcc/p/test/peter5g.pas	1970-01-01 01:00:00.000000000 +0100
+++ gcc-3.4.4/gcc/p/test/peter5g.pas	2005-07-22 03:48:40.736990168 +0200
@@ -0,0 +1,48 @@
+program peter5g(output);
+{$define member(a,b) ((a) is b)}
+{$mac-pascal}
+        type
+                ObjectBase = object
+                        procedure Doit;
+                end;
+                ObjectA = object(ObjectBase)
+                        procedure Doit; override;
+                end;
+                ObjectB = object(ObjectBase)
+                        procedure Doit; override;
+                end;
+
+{$gnu-pascal}
+        procedure ObjectBase.Doit;
+        begin
+        end;
+        procedure ObjectA.Doit;
+        begin
+        end;
+
+        procedure ObjectB.Doit;
+        begin
+        end;
+
+var
+        base, a, b: ObjectBase;
+        ao: ObjectA;
+        bo: ObjectB;
+begin
+        New(base);
+        New(ao);
+        New(bo);
+        a := ao;
+        b := bo;
+        {$local W-}
+        if member( base, ObjectBase ) and not member( base, ObjectA )
+          and not member( base, ObjectB ) and member( a, ObjectBase )
+          and member( a, ObjectA ) and not member( a, ObjectB )
+          and member( b, ObjectBase ) and not member( b, ObjectA )
+          and member( b, ObjectB ) {$endlocal} then begin
+                WriteLn( 'OK' );
+        end else begin
+                WriteLn( 'failed' );
+        end;
+end.
+
