# GPC version 3.4.4 d2 for Mac OS X (10.2 or later) # July 22, 2005 # Adriaan van Os # 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 # W o r k a r o u n d for a powerpc-apple-darwin back-end bug # # for a discussion, see --- 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 # C h a n g e s to improve the employability of the --mac-pascal dialect # for a discussion, see --- 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) #--------------------------------------------- # # 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 # 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: # --- 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 # # 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 = ¤t_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 @@ -735,9 +736,36 @@ | new_identifier formal_schema_discriminants error { build_schema_type (error_mark_node, $2, NULL_TREE); } | new_identifier enable_lce equals - { $$ = start_object_type ($1); } + { $$ = start_object_type ($1, 0); } optional_abstract p_object object_parent object_field_list p_end { lex_const_equal = -1; finish_object_type ($4, $7, $8, $5 != NULL_TREE); yyerrok; } + | new_identifier enable_lce equals + { $$ = start_object_type ($1, 1); } + optional_abstract p_class object_parent object_field_list p_end + { + lex_const_equal = -1; + finish_object_type ($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 operator */ PREDEF_KEYWORD (and_then, 1, E_O_PASCAL) /* short-circuit Boolean 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 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 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 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 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. +