fpc/compiler/pexpr.pas
florian 20b1e3af78 Merging of generics branch of Sven Barth
------------------------------------------------------------------------
r19731 | svenbarth | 2011-12-03 11:53:02 +0100 (Sa, 03 Dez 2011) | 2 lines

pexpr.pas, post_comp_expr_gendef:
This is not the result you are looking for: The result of "postfixoperators" is only set to true if either "again" was "true" once or the node was changed to an errornode. So using the result for deciding whether we overwrite the def or not is incorrect. So just call "postfixoperators" and process the returned node accordingly.
------------------------------------------------------------------------
r19723 | svenbarth | 2011-12-02 15:28:23 +0100 (Fr, 02 Dez 2011) | 1 line

Added a few more tests. All except tgeneric65.pp (object inside generic record) and tgeneric68.pp (object inside generic object) are successfully compiled.
------------------------------------------------------------------------
r19722 | svenbarth | 2011-12-02 15:12:42 +0100 (Fr, 02 Dez 2011) | 1 line

Fix a remaining artefact from the overloaded symbols approach (just a comment, but nevertheless a change...)
------------------------------------------------------------------------
r19721 | svenbarth | 2011-12-02 15:11:56 +0100 (Fr, 02 Dez 2011) | 3 lines

ptype.pas, read_named_type, expr_type:
* Adjust a comment.
* Add an additional check for the owning symtable of the dummy symbol and the current_structdef just to be on the save side (it's not needed inside specializations)
------------------------------------------------------------------------
r19720 | svenbarth | 2011-12-02 15:11:06 +0100 (Fr, 02 Dez 2011) | 1 line

Fix the test. It's mode Delphi, but does not compile in Delphi, because "TSomeRecord" and "TSomeRecord<T>" are different identifiers.
------------------------------------------------------------------------
r19719 | svenbarth | 2011-12-02 15:10:06 +0100 (Fr, 02 Dez 2011) | 18 lines

Fix introduced regressions.

pgenutil.pas, generate_specialization:
* If we are parsing the result type of a function or operator that belongs to a generic (parse_generic is true) we need to accept also "_LT" and "_GT" as for this the "block_type" is NOT set to one of "bt_type", "bt_var_type", "bt_const_type" and only there "_LSHARPBRACKET" and "_RSHARPBRACKET" are returned by the scanner. This is part of the fix for webtbs\tw18567.pp.
* In non—Delphi modes if we encounter a specialization of the currently parsed class/record (using "specialization"!) the given "tt" will be an errordef (because the def of the generic's symbol was not yet set to "current_structdef"). To solve this we check in this case whether the calculated generic name is equal to that of the "current_structdef" and simply return that as specialized def. This fixes test\tgeneric11.pp.
* When searching for the generic symbol search if the generic belongs to a class or record then we need to search for it in the class or record. This fixes webtbs\tw16090.pp.

ptype.pas
* parse_nested_types: We now return the generic defs for specializations inside generics instead of an undefined def, so we must also parse nested type usages correctly, so that type checks don't fail (undefined defs circumvent them mostly). This fixes webtbs\tw10247.pp.
* single_type: We need to allow _LT as an indication for a Delphi specialization as return types are parsed with block_type not in "bt_type", "bt_var_type", "bt_const_type". This is also a fix a part of the fix for webtbs\tw18567.pp.
* read_named_type, expr_type:
Fixes for test\tgeneric17.pp and test\tgeneric22.pp:
(a) In non-Delphi modes we might encounter usages of the generic dummy symbol inside the generic class belonging to it. This is basically a specialization, but as the reference from the dummy symbol to the "current_structdef" is not yet established (this is done after "read_named_type" in "types_dec" returns) we need to use other ways to check for the valid use of the dummy symbol (basically we check whether the name of the dummy symbol and the name of the current_structdef without the type count match)
(b) For specializations we can check whether the genericdef of the currently parsed structdef (the specialization) is the same as the typedef of the encountered dummy symbol.

pexpr.pas, factor, factor_read_id:
Fixes for test\tgeneric17.pp and test\tgeneric22.pp:
To allow the mentioned fixes in ptype for the same tests to be usable at all we must not return an "identifier not found" error if we encounter such a valid use of a generic dummy symbol.
------------------------------------------------------------------------
r19718 | svenbarth | 2011-12-02 15:08:46 +0100 (Fr, 02 Dez 2011) | 3 lines

generate_specialization:
* Remove some unused variables
* Fix a comment
------------------------------------------------------------------------
r19685 | svenbarth | 2011-11-25 16:25:10 +0100 (Fr, 25 Nov 2011) | 1 line

Incorporate the changes from trunk into "postfixoperators" and "handle_factor_typenode". The latter needed to be extended by a parameter "typeonly" which is "false" in almost all calls except the one inside "factor_read_id" where the "typeonly" parameter of "factor" is used.
------------------------------------------------------------------------
r19676 | svenbarth | 2011-11-24 17:48:47 +0100 (Do, 24 Nov 2011) | 4 lines

Rebase to revision 19673

pexpr.pas: Changes in postfixoperators and the base of handle_factor_typenode not yet incorporated (the code from trunk was simply commented for now)

------------------------------------------------------------------------
r19675 | svenbarth | 2011-11-24 15:42:42 +0100 (Do, 24 Nov 2011) | 11 lines

Somehow the changes regarding tf_methods_specialized weren't commited, thus here they are again:
* symconst.pas: remove tf_methods_specialized
* psub.pas: remove check for/inclusion of tf_methods_specialized as this isn't needed anymore since the generic is specialized in a temporary symtable

pgenutil.pas: remove merge artifacts

pdecl.pas: fix compilation ("s" was duplicate)

pexpr.pas:
* fix calling of generate_specialization
* disable the goto in sub_expr for now; this will be enabled again once right hand sides work as well
------------------------------------------------------------------------
r19674 | svenbarth | 2011-11-24 11:19:57 +0100 (Do, 24 Nov 2011) | 3 lines

Rebase to revision 19078 (directly before the merge of cpstrnew)

The changes regarding pretty names for generics and token buffer endianess were integrated into my changes. Not every call to generate_specialization is fixed though, so compilation will fail.
------------------------------------------------------------------------
r19671 | svenbarth | 2011-11-23 18:25:09 +0100 (Mi, 23 Nov 2011) | 79 lines

Merge branch 'unique-syms'

Conflicts:
	compiler/pdecl.pas
	compiler/pexpr.pas
	compiler/pgenutil.pas
	compiler/ptype.pas

The original log messages as git was a bit forgetting here :( (newest at the top):

?commit 7ef252de8023494ee6d39910e289f9e31658d47b
Author: Sven Barth <pascaldragon@minerva>
Date:   Mon Nov 21 17:13:36 2011 +0100

    Fix the compilation of inline specializations of which the generic is derived from another generic.
    
    pgenutil.pas, generate_specialization:
    * Set the "block_type" to "bt_type" when parsing the type parameters, so that the nodes are returned as "ttypenode" instead of e.g. "tloadvmtaddrnode" in case of classes outside of type sections.
    * Set the "block_type" to "bt_type" before calling "read_name_type", so that no unexpected sideeffects happen, because types like classes normally only are declared inside type sections (e.g. for the case a generic class is derived from another generic class a classrefdef for the specialized parent class will be created inside the derived specialized class if the block type is not a type one).

commit 1041a8f7a3a41f4fdf2975ce40055c698281ce71
Author: Sven Barth <pascaldragon@minerva>
Date:   Fri Nov 18 19:03:50 2011 +0100

    Improve inline specializations a bit, so now expressions like "TSomeGeneric<TSomeType>.SomeClassProc OP SomeNonGeneric" is possible. Using another class function of a generic as the right side is not yet working (that still needs some thinking).
    
    To achive this the generalization code must basically continue directly after the "factor" call, so that the operator and the right side are correctly parsed when walking up the call stack. This is done by jumping from the end of the specialization code in the "<"-case to the start of "sub_expr". The freshly generated node (in the above example a callnode) will be passed down the callstack through a new parameter "factornode". If that is set (currently only in the case of a specialization on the left side) "factor" won't be called and the right side will be parsed with the "factornode" as the left side. If it is not set (which is the case for all other calls to "sub_expr" in the unit) then the usual call to "factor" will be done and the result will be used as the left side.

commit a01ccd265f8d6cc5a2f3e88e23afbcd3d5960afb
Author: Sven Barth <pascaldragon@minerva>
Date:   Fri Nov 18 18:37:04 2011 +0100

    Fix compilation of ppudump.
    
    symconst.pas:
    * Remove sto_has_generic, which was the last remainer of my "overloaded type symbols" approach.
    * Remove df_methods_specialized, as it isn't needed anymore with the recent "temporary symtable" solution.
    
    psub.pas, specialize_objectdefs, process_abstractrecorddef:
    Remove the checks for/inclusion of df_methods_specialized.
    
    utils/ppudump.pp:
    Add "sp_generic_dummy" to the symbol options.

commit d16deac060e65d4b53e8fe9c27fe7e1f6d00a416
Author: Sven Barth <pascaldragon@minerva>
Date:   Wed Nov 16 16:34:51 2011 +0100

    Fix compilation of "gset.pp" from fcl-stl.
    
    nld.pas:
    Extend ttypenode by a reference to the type symbol. Normally this is simply the typesym of the given def, but for specializations in type sections of generics this is not the case, because generate_specialization will return a reference to the generic definition and not the new one (thus the symbol will be wrong).
    
    ppu.pas:
    Increase PPU version because of the extension of ttypenode.
    
    pexpr.pas:
    * handle_factor_typenode: Extend the function by a "sym" parameter which will normally be "nil". In that case it is set to the def's typesym. The "typesym" field of the created type node is then set to this sym.
    * For now pass nearly always "nil" for the above mentioned sym except inside factor_read_id when we've encountered a typesym.
    
    ptype.pas, read_named_type, expr_type:
    Exchange the "is_owned_by" check with a "sym_is_owned_by" check so that we can correctly detect that we are using a specialized type declaration inside a generic (once nested generic are allowed this condition needs to be checked).

commit 23668d2fc9070afc26b4288ed0db9a8eaf6f40e6
Author: Sven Barth <pascaldragon@minerva>
Date:   Wed Nov 16 07:51:12 2011 +0100

    psub.pas:
    * tcgprocinfo.parse_body: Methods of generic classes need to set "parse_generic" as well, so that variables for "stacked generics" (generic array => generic record) inside the method body are handled correctly.
    * specialize_objectdefs: Don't try to generate method bodies for abstract methods.
    
    pdecvar.pas, read_property_dec:
    Allow specializations for the return types of properties (should they be allowed for index types as well?).
    
    symtable.pas:
    Add a new class "tspecializesymtable" which is basically a globalsymtable but is always assuming to be the current unit. This symtable is used in "generate_specializations" (see below) and is needed to allow visibilty checks for "private", etc. to succeed.
    
    pgenutil.pas, generate_specializations:
    Instead of hackily pushing a symtable that may contain conflicting symbols onto the symtable stack for the specialization, a temporary global symtable using the above mentioned "tspecializesymtable" is created and pushed. After the specialization is done all symbols and defs that were added to the temporary symtable are moved to their final symtable (either the global- or localsymtable of the unit, depending on the current position of compilation). This way symbols are correctly added to a top level symtable, but without potential side effects like resolving the wrong symbol.
------------------------------------------------------------------------
r19435 | svenbarth | 2011-10-09 18:16:19 +0200 (So, 09 Okt 2011) | 1 line

Set "current_structdef", "current_genericdef" and "current_specializedef" to values that were valid during the declaration of the generic  when specializing it ("current_genericdef" and "current_specializedef" might need to still be corrected though)
------------------------------------------------------------------------
r19434 | svenbarth | 2011-10-09 18:15:26 +0200 (So, 09 Okt 2011) | 2 lines

Arrays and procvars inside a generic declaration are not declared as generic/specialization anymore (this partly reverts a previous commit). This reduces the problematic cases in the check whether a found def was specialized inside the class (the changed check in read_named_type.expr_type).
It's still not an ideal solution as the usage of generic classes/records (without specialization!) that are declared inside the current parsed class/record will compromise this check again.
------------------------------------------------------------------------
r19433 | svenbarth | 2011-10-09 18:14:33 +0200 (So, 09 Okt 2011) | 1 line

Extend the test with a usage of "TTestInteger" and correct the comments a bit.
------------------------------------------------------------------------
r19432 | svenbarth | 2011-10-09 18:13:30 +0200 (So, 09 Okt 2011) | 9 lines

We need to flag specializations of record-/objectdef once we have generated their methods otherwise an interesting situation might occur:
The classes in "fgl.pas" implement an enumerator in the generic class "TFPGListEnumerator" and "specialize" that inside themselves. If we now specialize one of the generic classes (e.g. "TFPGList") the "TFPGListEnumerator" is really specialized as well. That means a def is added to the global symtable (the local one in case of a program or library file). If we now use the enumerator class in the same file (e.g. by using a "for ... in", which has a temporary variable of that type) then the methods of the enumerator are specialized again (the def itself is not). To avoid this (and time consuming searches for existing method specializations) we flag the specialized def as "done" once we're finished.

symconst.pas
  * add a new flag "df_methods_specialized" to the "tdefoption" enumeration

psub.pas, process_abstractrecorddef
  * check the def for the "df_methods_specialized" flag and continue only if that is not set
  * set the "df_methods_specialized" flag before leaving the function
------------------------------------------------------------------------
r19431 | svenbarth | 2011-10-09 18:12:25 +0200 (So, 09 Okt 2011) | 1 line

This check was commited by accident; it was a remain from an experimental solution to the "fix compilation of fgl"-problem.
------------------------------------------------------------------------
r19430 | svenbarth | 2011-10-09 18:11:31 +0200 (So, 09 Okt 2011) | 19 lines

Fix compilation of unit "fgl.pp" and of test "tests/test/tgeneric29.pp".

symtable.pas:
  * reduce the "childdef" parameter of "is_owned_by" from "tabstractrecorddef" to "tdef", so that more primitive defs can be checked as well
  * add a new function "sym_is_owned_by" which is similar to "is_owned_by", but takes a symbol and a symtable as parameter; the owner chain of the symtable is checked until a non-object- and non-record-symtable is reached

ptype.pas:
  * extend "id_type", so that the symbol and the symtable that belongs to the returned def is returned as well
  * this is needed to check inside "single_type" whether a def that is a generic was specialized inside another generic, because in that case the genericdef is returned by "generate_specialization" and not a new specialized def, but the corresponding type symbol (which is different from "hdef.typesym") belongs to the class itself; I need to admit that this solution isn't very clean and one could try to circumvent some of the checks, so I need to find a better detection for such a case (concrete example: the enumerator specialization inside the classes of "fgl.pas")
  * in "read_named_type.expr_type" the check for "df_generic" is extended analogous to the previous change, but instead of relying on the symbol it uses the def. This is needed so that types like method pointers that are defined inside the current generic are not disallowed as they contain the "df_generic" flag as well; like the previous change this change isn't clean either and maybe it's better to remove the inclusion of the "df_generic" flag from everything except records and "objects" inside records/"objects" again. Such a solution will "only" reduce the problem to records and "objects" though...

pgenutil.pas:
  * only add a new undefined def if we're not parsing the parent class or interfaces ("parse_class_parent" is true), otherwise the InternalError regarding the "equal count of defs" will trigger
  * there are now two cases where we need to return a generic def instead of a undefined one when we're parsing a generic:
    a) we have the previously mentioned case that "parse_class_parent" is true
    b) an undefined def was added, but we need to return a generic def, so that checks can be passed
  * use the correct variable when building the generic name, otherwise we get errors like "identifier '$1' not found"
  * don't push the symtable if we're currently parsing the list of interfaces or the parent class, because then e.g. a generic interface will be included in the symtable of the implementing class which isn't what we want; the current solution is not clean though, so this needs to be investigated more
  * Note: In the current state of "generate_specialization" the function could be simplyfied a bit more; this will be done when the implementation is satisfactory enough
------------------------------------------------------------------------
r19429 | svenbarth | 2011-10-09 18:10:28 +0200 (So, 09 Okt 2011) | 20 lines

Allow generics to be overloaded by variables.

* symconst.pas:
   add an entry for the generic dummy symbol to the symbol options enumeration
* pgenutil.pas:
   - extend "generate_specialization" by the possibility to pass a symbol name instead of a def
   - if "symname" is given that is used; otherwise "genericdef" or "tt" is used
* pexpr.pas:
   - in case of "<" we are trying to receive a generic dummy symbol from the left node (new function "getgenericsym")
   - it's name is then passed to "generate_specialization" which in turn fills genericdef
   - adjust call to "generate_specialization"
* pdecl.pas:
   - we can now check for "sp_generic_dummy instead of "not sp_generic_para" to check whether we've found the dummy symbol of a previous generic declaration
   - if a new dummy symbol is created we need to include "sp_generic_dummy"
   - if we've found a non-generic symbol with the same name we need to include the "sp_generic_dummy" flag as well
* symtable.pas
   - add a new function "searchsym_with_symoption" that more or less works the same as "searchsym", but only returns successfully if the found symbol contains the given flag
   - "searchsym_with_symoption" and "searchsym" are based on the same function "maybe_searchsym_with_symoption" which is the extended implementation of "searchsym" (note: object symtables are not yet searched if a symoption is to be looked for)
   - add a function "handle_generic_dummysym" which can be used to hide the undefineddef symbol in a symtable
   - correctly handle generic dummy symbols in case of variables in "tstaticsymtable.checkduplicate"
------------------------------------------------------------------------
r19428 | svenbarth | 2011-10-09 18:09:09 +0200 (So, 09 Okt 2011) | 3 lines

types_dec:
   - fix a comment
   - the created undefineddef must not be freed, as the count of the list the def is contained in, is used to find other defs again
------------------------------------------------------------------------
r19427 | svenbarth | 2011-10-09 18:08:15 +0200 (So, 09 Okt 2011) | 14 lines

Corrected the handling of hint directives.

pgenutils.pas/generate_specialization:
- parse hint directives of the generic if they are recorded
- output hint messages of the generic after the ">" is successfully parsed

pexpr.pas:
- factor: don't display hints of a potential generic type if the next token is a "<"
- sub_expr:
 * added two inline methods which
    a) checks whether a node is a typenode or a loadvmtaddrnode with a typenode
    b) returns the typedef of such a node
 * check hint directives for the first parsed type argument of a specialization
 * in the case of parsing a non-generic type the hints of the left and right node of the resulting "<" node need to be checked (the right ones only if another "<" is following)
------------------------------------------------------------------------
r19426 | svenbarth | 2011-10-09 18:07:22 +0200 (So, 09 Okt 2011) | 5 lines

generate_specialization needs to return the correct generic def if the parent classes are parsed, so that that the usage of generic interfaces is allowed.

This fixes the compilation of test tests\test\tgeneric29.pp and the reminder in pdecobj.pas is not needed anymore.

Note: Perhaps this behavior should be enabled in general if "parse_generic" is true (and not only if parse_parent_class if true as well).
------------------------------------------------------------------------
r19425 | svenbarth | 2011-10-09 18:06:31 +0200 (So, 09 Okt 2011) | 1 line

Added two reminders for me
------------------------------------------------------------------------
r19424 | svenbarth | 2011-10-09 18:05:31 +0200 (So, 09 Okt 2011) | 32 lines

Switching from overloaded type symbol to unique symbol per generic.

Reasons for the "unique symbol" approach:
- no special search operations for cross unit search needed (which is supported by Delphi) => less performance impact
- no special care needed to really find the correct generic => less increase of parser complexity

Currently all generic tests except tgeneric29.pp compile and inline specializations work as well.

The changes in detail:
* pdecl.pas/types_dec:
- The variables used to hold the final name of the symbol are now prefixed with "gen". In case of non-generics the prefixed ones are equal to the non-prefixed ones (e.g. orgtypename=genorgtypename). In case of a generic symbol the "gen"-variants contain the type parameter count suffix (e.g. '$1' in case of 'TTest<T>') as well.
- The unmodified pattern is used to insert and detect a dummy symbol with that name, so that type declarations and - more important - inline specializations can find that symbol.
- In non-Delphi modes this symbol is also used to detect whether we have a type redefinition which is not allowed currently; its typedef points to the generic def.
- In mode Delphi the def of that dummy symbol (which contains an undefineddef) is modified when a corresponding non-generic type is parsed, so that it contains the def of the real type.

* pdecsub.pas/parse_proc_head
- consume_generic_type_parameter now only parses the type parameters and picks the generic with the correct amount of parameters. The verification of the order and names of the parameters needs to be added again.
- it also does not use "def" anymore, but it sets "srsym"
- in parse_proc_head the symbol (srsym) is only searched if the symbol isn't assigned already; in case of a generic in mode FPC it will find the dummy symbol that points to the generic def

* pexpr.pas
- in factor_read_id there are three cases to handle:
 + the symbol is not assigned => error
 + a possible generic symbol (either an undefined def or the non-generic variant) => no error and no hints
 + a non-generic symbol => hints
 Point 1 is handled correctly, point 2 and 3 aren't currently and also they might be needed to be moved somewhere else
- sub_expr:
 + a node can be a tloadvmtaddrnode as well if the non-generic variant of a generic symbol is a class
 + we can only check afterwards whether the specialization was successful

* pgenutil.pas/generate_specialization
using the count of the parsed types the correct symbol can be found easily
------------------------------------------------------------------------
r18005 | svenbarth | 2011-07-16 18:19:33 +0200 (Sa, 16 Jul 2011) | 1 line

Rebase to revision 18000
------------------------------------------------------------------------
r18004 | svenbarth | 2011-07-16 16:13:56 +0200 (Sa, 16 Jul 2011) | 1 line

pexpr.pas, sub_expr: Added support for "as" and "is" operators if the right hand side is an inline specialization (currently detected by the next token being a "<"). This could potentially introduce some problems if the right hand side isn't a specialization but a "<" comparison together with some overloaded operators (I still need to find a case for such a problem)...
------------------------------------------------------------------------
r18003 | svenbarth | 2011-07-16 16:13:11 +0200 (Sa, 16 Jul 2011) | 5 lines

factor_read_id:
don't accept the generic dummy symbol if the next token isn't a "<"

sub_expr:
generate an error if we had a normal "<" comparison containing the dummy symbol on the left side instead of a specialization
------------------------------------------------------------------------
r18002 | svenbarth | 2011-07-16 16:12:25 +0200 (Sa, 16 Jul 2011) | 17 lines

Implement support for nested non-generic types inside generic types. This is mostly for records, classes and objects ("structures") as those didn't work at all, but the others (arrays, procvars) weren't done cleanly either.

pobjdec.pas (object_dec) / ptype.pas (record_dec, array_dec, procvar_dec):
- enable "parse_generic" if a nested type is parsed and we're already inside a generic (this prevents code to be generated for the nested type's methods)
- set the "df_specialization" flag so that the code for generating the methods (and thus resolving the forwards declarations) is called for this symbol

pexpr.pas:
add "post_comp_expr_gendef" which basically calls "handle_factor_typenode" and "postfixoperators" as those aren't exported from the unit themselves

ptype.pas, read_named_type.expr_type:
- use "post_comp_expr_gendef" to parse the use of nested types (e.g. "var t: TTest<T>.TTestSub")

psub.pas, specialize_objectdefs:
implement the generation of the method bodies for nested structures (resolves the forward declarations)

pdecl.pas, types_dec:
when we encounter a nested structure inside a specialization of a structure, we need to find the corresponding generic definition so that the generic can be correctly parsed later on.
------------------------------------------------------------------------
r18001 | svenbarth | 2011-07-16 16:11:31 +0200 (Sa, 16 Jul 2011) | 1 line

Finally fixed the handling of hint directives and added a comment explaining the situation in the context of generics.
------------------------------------------------------------------------
r17999 | svenbarth | 2011-07-16 16:10:34 +0200 (Sa, 16 Jul 2011) | 2 lines

* Reordered the conditions for the inline spezialization as the "isgeneric" boolean is not needed
* As "handle_factor_typenode" is now available the classrefdef wrapper is not needed anymore
------------------------------------------------------------------------
r17998 | svenbarth | 2011-07-16 16:09:38 +0200 (Sa, 16 Jul 2011) | 1 line

Removed the remaining traces of the type overloads and increased PPU version to differ from trunk.
------------------------------------------------------------------------
r17997 | svenbarth | 2011-07-16 16:08:49 +0200 (Sa, 16 Jul 2011) | 1 line

Integrated the changes from trunks's postfixoperators into my own and removed the local version again.
------------------------------------------------------------------------
r17996 | svenbarth | 2011-07-16 16:08:03 +0200 (Sa, 16 Jul 2011) | 5 lines

generate_specialization needs to return the correct generic def if the parent classes are parsed, so that that the usage of generic interfaces is allowed.

This fixes the compilation of test tests\test\tgeneric29.pp and the reminder in pdecobj.pas is not needed anymore.

Note: Perhaps this behavior should be enabled in general if "parse_generic" is true (and not only if parse_parent_class if true as well).
------------------------------------------------------------------------
r17995 | svenbarth | 2011-07-16 16:07:20 +0200 (Sa, 16 Jul 2011) | 1 line

Added two reminders for me
------------------------------------------------------------------------
r17547 | svenbarth | 2011-05-23 22:52:51 +0200 (Mo, 23 Mai 2011) | 1 line

Rebase to revision 17533
------------------------------------------------------------------------
r17542 | svenbarth | 2011-05-23 21:47:09 +0200 (Mo, 23 Mai 2011) | 4 lines

Added some tests for:
- multiple symbols with a similar name
- hint directives
- inline specializations
------------------------------------------------------------------------
r17541 | svenbarth | 2011-05-23 21:19:12 +0200 (Mo, 23 Mai 2011) | 3 lines

Allow typecasts to inline specializations as well.

For this the code which handles this inside factor_read_id had to be moved to local unit scope and is named handle_factor_typenode.
------------------------------------------------------------------------
r17540 | svenbarth | 2011-05-23 21:17:53 +0200 (Mo, 23 Mai 2011) | 1 line

Remove the (now) non-functional check for inline specialization.
------------------------------------------------------------------------
r17539 | svenbarth | 2011-05-23 21:16:39 +0200 (Mo, 23 Mai 2011) | 14 lines

Corrected the handling of hint directives.

pgenutils.pas/generate_specialization:
- parse hint directives of the generic if they are recorded
- output hint messages of the generic after the ">" is successfully parsed

pexpr.pas:
- factor: don't display hints of a potential generic type if the next token is a "<"
- sub_expr:
 * added two inline methods which
    a) checks whether a node is a typenode or a loadvmtaddrnode with a typenode
    b) returns the typedef of such a node
 * check hint directives for the first parsed type argument of a specialization
 * in the case of parsing a non-generic type the hints of the left and right node of the resulting "<" node need to be checked (the right ones only if another "<" is following)
------------------------------------------------------------------------
r17538 | svenbarth | 2011-05-23 21:15:36 +0200 (Mo, 23 Mai 2011) | 5 lines

generate_specialization needs to return the correct generic def if the parent classes are parsed, so that that the usage of generic interfaces is allowed.

This fixes the compilation of test tests\test\tgeneric29.pp and the reminder in pdecobj.pas is not needed anymore.

Note: Perhaps this behavior should be enabled in general if "parse_generic" is true (and not only if parse_parent_class if true as well).
------------------------------------------------------------------------
r17537 | svenbarth | 2011-05-23 21:14:33 +0200 (Mo, 23 Mai 2011) | 1 line

Added two reminders for me
------------------------------------------------------------------------
r17536 | svenbarth | 2011-05-23 21:13:51 +0200 (Mo, 23 Mai 2011) | 1 line

This test does not need to be run
------------------------------------------------------------------------
r17535 | svenbarth | 2011-05-23 21:12:50 +0200 (Mo, 23 Mai 2011) | 32 lines

Switching from overloaded type symbol to unique symbol per generic.

Reasons for the "unique symbol" approach:
- no special search operations for cross unit search needed (which is supported by Delphi) => less performance impact
- no special care needed to really find the correct generic => less increase of parser complexity

Currently all generic tests except tgeneric29.pp compile and inline specializations work as well.

The changes in detail:
* pdecl.pas/types_dec:
- The variables used to hold the final name of the symbol are now prefixed with "gen". In case of non-generics the prefixed ones are equal to the non-prefixed ones (e.g. orgtypename=genorgtypename). In case of a generic symbol the "gen"-variants contain the type parameter count suffix (e.g. '$1' in case of 'TTest<T>') as well.
- The unmodified pattern is used to insert and detect a dummy symbol with that name, so that type declarations and - more important - inline specializations can find that symbol.
- In non-Delphi modes this symbol is also used to detect whether we have a type redefinition which is not allowed currently; its typedef points to the generic def.
- In mode Delphi the def of that dummy symbol (which contains an undefineddef) is modified when a corresponding non-generic type is parsed, so that it contains the def of the real type.

* pdecsub.pas/parse_proc_head
- consume_generic_type_parameter now only parses the type parameters and picks the generic with the correct amount of parameters. The verification of the order and names of the parameters needs to be added again.
- it also does not use "def" anymore, but it sets "srsym"
- in parse_proc_head the symbol (srsym) is only searched if the symbol isn't assigned already; in case of a generic in mode FPC it will find the dummy symbol that points to the generic def

* pexpr.pas
- in factor_read_id there are three cases to handle:
 + the symbol is not assigned => error
 + a possible generic symbol (either an undefined def or the non-generic variant) => no error and no hints
 + a non-generic symbol => hints
 Point 1 is handled correctly, point 2 and 3 aren't currently and also they might be needed to be moved somewhere else
- sub_expr:
 + a node can be a tloadvmtaddrnode as well if the non-generic variant of a generic symbol is a class
 + we can only check afterwards whether the specialization was successful

* pgenutil.pas/generate_specialization
using the count of the parsed types the correct symbol can be found easily
------------------------------------------------------------------------
r17534 | svenbarth | 2011-05-23 21:11:50 +0200 (Mo, 23 Mai 2011) | 1 line

This fixes an access violation when compiling tests\test\tgeneric30.pp
------------------------------------------------------------------------
r17405 | svenbarth | 2011-05-04 12:43:13 +0200 (Mi, 04 Mai 2011) | 11 lines

*pexpr.pas:
- moved "postfixoperators" from local declaration of "factor" to implementation declarations of the unit, so it can be used in "sub_expr"
- for this a parameter "getaddr:boolean" needed to be added, because it used the parameter that was defined by "factor"
=> adjustments inside "factor" for calls to "postfixoperators"
- extended the "_LT" ("<") case of "sub_expr" with handling of inline generic specializations. If a potential generic is detected (Delphi mode, left and right node are type nodes, next token is ">" or ",") it is tried to parse the generic declaration and generate a specialization. If this succeeds, potential postfix operators are parsed and a node <> caddnode is returned.

*pgenutil.pas:
"generate_specialization" was extended so that the first type identifer can already have been parsed (which is the case in inline specializations)

*ptype.pas
adjustments because of the extension of "generate_specialization"
------------------------------------------------------------------------
r17404 | svenbarth | 2011-05-04 12:40:07 +0200 (Mi, 04 Mai 2011) | 1 line

Moved "parse_generic_parameters" and "insert_generic_parameter_types" from "pdecl.pas" to "pgenutil.pas"
------------------------------------------------------------------------
r17403 | svenbarth | 2011-05-04 12:35:23 +0200 (Mi, 04 Mai 2011) | 1 line

Moved "generate_specialization" from "ptype.pas" to "pgenutil.pas"
------------------------------------------------------------------------
r17397 | svenbarth | 2011-05-02 22:22:41 +0200 (Mo, 02 Mai 2011) | 3 lines

Added a file which will hold the various functions related to generic parsing. The header copyright notice and the info comment might not yet be final.

Note: I've added this mostly empty, because I used SVN instead of GIT SVN, as I don't know whether it would handle the properties for this new file correctly.
------------------------------------------------------------------------
r17396 | svenbarth | 2011-05-02 21:47:53 +0200 (Mo, 02 Mai 2011) | 6 lines

consume_generic_type_parameter now parses the available parameters first before deciding which generic def is the correct one (this is stored in the "def" variable of the parent frame). The count of the parameters and the order is checked.

parse_proc_head itself uses the correct def (the def found by consume_generic_type_parameter in mode Delphi and the first generic def of the symbol in the other modes) which is available in the "def" variable.

Status of generics:
Non-Delphi generics now work as before and declarations of Delphi generics work as well. Inline specialisations don't work currently.
------------------------------------------------------------------------
r17395 | svenbarth | 2011-05-02 21:46:41 +0200 (Mo, 02 Mai 2011) | 1 line

Added two TODOs for places that I'll need to adjust for inline specializations.
------------------------------------------------------------------------
r17394 | svenbarth | 2011-05-02 21:45:34 +0200 (Mo, 02 Mai 2011) | 12 lines

* ptype.pas:
"generate_specialization" now parses the generic parameters without verifying them. The verification is done after their count is known and thus the correct generic def can be determined.

Note: It does currently only work with the first found symbol, the extended lookup needs to be implemented yet (including the unit name works though)

* pexpr.pas:
In "factor_read_id" an "identifer not found" error is generated if the undefined non-generic def is used (e.g. as a type for a variable)

Note: This check needs to be adjusted for the case "typeonly=false".

Status of generics:
Specializations can now be parsed, but declarations containing methods are still broken, because the correct def is not yet resolved (not even talking about inline specializations yet ;) )
------------------------------------------------------------------------
r17393 | svenbarth | 2011-05-02 21:44:14 +0200 (Mo, 02 Mai 2011) | 9 lines

*type symbol overloads are only allowed in mode Delphi
*a check for overloads with the same count of arguments is not yet in place
*in non-Delphi modes overloads need to be checked for non-generics as well, e.g. "TTest<T>" is already defined and now a "TTest" is declared
*when a generic is encountered and the symbol does not yet exist, a new symbol with an undefineddef is added and the generic def is added as an overload; if the symbol already exists, the generic is just added
*if a non-generic is parsed and the symbol is already defined (but the typedef is still an undefineddef) then the typedef is updated
*the symtable tree (up to the unit symtable (global or local)) gets the "sto_has_generic" flag which will be used when searching generics with the same name, but different parameter counts in different units

State of generics:
broken, because the generic defs are not yet searched/found
------------------------------------------------------------------------
r17392 | svenbarth | 2011-05-02 21:42:40 +0200 (Mo, 02 Mai 2011) | 1 line

Extend ttypesym by a list that will contain all generic "overloads" of this symbol.
------------------------------------------------------------------------
r17341 | svenbarth | 2011-04-18 23:15:52 +0200 (Mo, 18 Apr 2011) | 1 line

Rebase to revision 17340
------------------------------------------------------------------------
r17316 | svenbarth | 2011-04-14 09:11:07 +0200 (Do, 14 Apr 2011) | 1 line

Created a branch for working on various aspects of generics
------------------------------------------------------------------------

git-svn-id: trunk@19763 -
2011-12-06 21:29:42 +00:00

3430 lines
133 KiB
ObjectPascal

{
Copyright (c) 1998-2002 by Florian Klaempfl
Does parsing of expression for Free Pascal
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit pexpr;
{$i fpcdefs.inc}
interface
uses
symtype,symdef,symbase,
node,ncal,
tokens,globtype,globals,constexp;
{ reads a whole expression }
function expr(dotypecheck:boolean) : tnode;
{ reads an expression without assignements and .. }
function comp_expr(accept_equal,typeonly:boolean):tnode;
{ reads a single factor }
function factor(getaddr,typeonly:boolean) : tnode;
procedure string_dec(var def: tdef; allowtypedef: boolean);
function parse_paras(__colon,__namedpara : boolean;end_of_paras : ttoken) : tnode;
{ the ID token has to be consumed before calling this function }
procedure do_member_read(structh:tabstractrecorddef;getaddr:boolean;sym:tsym;var p1:tnode;var again:boolean;callflags:tcallnodeflags);
function get_intconst:TConstExprInt;
function get_stringconst:string;
{ Does some postprocessing for a generic type (especially when nested types
of the specialization are used) }
procedure post_comp_expr_gendef(var def: tdef);
implementation
uses
{ common }
cutils,
{ global }
verbose,
systems,widestr,
{ symtable }
symconst,symtable,symsym,defutil,defcmp,
{ module }
fmodule,ppu,
{ pass 1 }
pass_1,htypechk,
nmat,nadd,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
{ parser }
scanner,
pbase,pinline,ptype,pgenutil,
{ codegen }
cgbase,procinfo,cpuinfo
;
{ sub_expr(opmultiply) is need to get -1 ** 4 to be
read as - (1**4) and not (-1)**4 PM }
type
Toperator_precedence=(opcompare,opaddition,opmultiply,oppower);
const
highest_precedence = oppower;
function sub_expr(pred_level:Toperator_precedence;accept_equal,typeonly:boolean;factornode:tnode):tnode;forward;
const
{ true, if the inherited call is anonymous }
anon_inherited : boolean = false;
{ last def found, only used by anon. inherited calls to insert proper type casts }
srdef : tdef = nil;
procedure string_dec(var def:tdef; allowtypedef: boolean);
{ reads a string type with optional length }
{ and returns a pointer to the string }
{ definition }
var
p : tnode;
begin
def:=cshortstringtype;
consume(_STRING);
if token=_LECKKLAMMER then
begin
if not(allowtypedef) then
Message(parser_e_no_local_para_def);
consume(_LECKKLAMMER);
p:=comp_expr(true,false);
if not is_constintnode(p) then
begin
Message(parser_e_illegal_expression);
{ error recovery }
consume(_RECKKLAMMER);
end
else
begin
if (tordconstnode(p).value<=0) then
begin
Message(parser_e_invalid_string_size);
tordconstnode(p).value:=255;
end;
if tordconstnode(p).value>255 then
begin
{ longstring is currently unsupported (CEC)! }
{ t:=tstringdef.createlong(tordconstnode(p).value))}
Message(parser_e_invalid_string_size);
tordconstnode(p).value:=255;
def:=tstringdef.createshort(int64(tordconstnode(p).value));
end
else
if tordconstnode(p).value<>255 then
def:=tstringdef.createshort(int64(tordconstnode(p).value));
consume(_RECKKLAMMER);
end;
p.free;
end
else
begin
if cs_ansistrings in current_settings.localswitches then
def:=getansistringdef
else
def:=cshortstringtype;
end;
end;
function parse_paras(__colon,__namedpara : boolean;end_of_paras : ttoken) : tnode;
var
p1,p2,argname : tnode;
prev_in_args,
old_named_args_allowed,
old_allow_array_constructor : boolean;
begin
if token=end_of_paras then
begin
parse_paras:=nil;
exit;
end;
{ save old values }
prev_in_args:=in_args;
old_allow_array_constructor:=allow_array_constructor;
old_named_args_allowed:=named_args_allowed;
{ set para parsing values }
in_args:=true;
named_args_allowed:=false;
allow_array_constructor:=true;
p2:=nil;
repeat
if __namedpara then
begin
if token=_COMMA then
begin
{ empty parameter }
p2:=ccallparanode.create(cnothingnode.create,p2);
end
else
begin
named_args_allowed:=true;
p1:=comp_expr(true,false);
named_args_allowed:=false;
if found_arg_name then
begin
argname:=p1;
p1:=comp_expr(true,false);
p2:=ccallparanode.create(p1,p2);
tcallparanode(p2).parametername:=argname;
end
else
p2:=ccallparanode.create(p1,p2);
found_arg_name:=false;
end;
end
else
begin
p1:=comp_expr(true,false);
p2:=ccallparanode.create(p1,p2);
end;
{ it's for the str(l:5,s); }
if __colon and (token=_COLON) then
begin
consume(_COLON);
p1:=comp_expr(true,false);
p2:=ccallparanode.create(p1,p2);
include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
if try_to_consume(_COLON) then
begin
p1:=comp_expr(true,false);
p2:=ccallparanode.create(p1,p2);
include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
end
end;
until not try_to_consume(_COMMA);
allow_array_constructor:=old_allow_array_constructor;
in_args:=prev_in_args;
named_args_allowed:=old_named_args_allowed;
parse_paras:=p2;
end;
function gen_c_style_operator(ntyp:tnodetype;p1,p2:tnode) : tnode;
var
hp : tnode;
hdef : tdef;
temp : ttempcreatenode;
newstatement : tstatementnode;
begin
{ Properties are not allowed, because the write can
be different from the read }
if (nf_isproperty in p1.flags) then
begin
Message(type_e_variable_id_expected);
{ We can continue with the loading,
it'll not create errors. Only the expected
result can be wrong }
end;
hp:=p1;
while assigned(hp) and
(hp.nodetype in [derefn,subscriptn,vecn,typeconvn]) do
hp:=tunarynode(hp).left;
if not assigned(hp) then
internalerror(200410121);
if (hp.nodetype=calln) then
begin
typecheckpass(p1);
result:=internalstatements(newstatement);
hdef:=tpointerdef.create(p1.resultdef);
temp:=ctempcreatenode.create(hdef,sizeof(pint),tt_persistent,false);
addstatement(newstatement,temp);
addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(temp),caddrnode.create_internal(p1)));
addstatement(newstatement,cassignmentnode.create(
cderefnode.create(ctemprefnode.create(temp)),
caddnode.create(ntyp,
cderefnode.create(ctemprefnode.create(temp)),
p2)));
addstatement(newstatement,ctempdeletenode.create(temp));
end
else
result:=cassignmentnode.create(p1,caddnode.create(ntyp,p1.getcopy,p2));
end;
function statement_syssym(l : byte) : tnode;
var
p1,p2,paras : tnode;
err,
prev_in_args : boolean;
begin
prev_in_args:=in_args;
case l of
in_new_x :
begin
if afterassignment or in_args then
statement_syssym:=new_function
else
statement_syssym:=new_dispose_statement(true);
end;
in_dispose_x :
begin
statement_syssym:=new_dispose_statement(false);
end;
in_ord_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
consume(_RKLAMMER);
p1:=geninlinenode(in_ord_x,false,p1);
statement_syssym := p1;
end;
in_exit :
begin
if try_to_consume(_LKLAMMER) then
begin
if not (m_mac in current_settings.modeswitches) then
begin
if not(try_to_consume(_RKLAMMER)) then
begin
p1:=comp_expr(true,false);
consume(_RKLAMMER);
if (not assigned(current_procinfo) or
is_void(current_procinfo.procdef.returndef)) then
begin
Message(parser_e_void_function);
{ recovery }
p1.free;
p1:=nil;
end;
end
else
p1:=nil;
end
else
begin
if not (current_procinfo.procdef.procsym.name = pattern) then
Message(parser_e_macpas_exit_wrong_param);
consume(_ID);
consume(_RKLAMMER);
p1:=nil;
end
end
else
p1:=nil;
statement_syssym:=cexitnode.create(p1);
end;
in_break :
begin
statement_syssym:=cbreaknode.create
end;
in_continue :
begin
statement_syssym:=ccontinuenode.create
end;
in_leave :
begin
if m_mac in current_settings.modeswitches then
statement_syssym:=cbreaknode.create
else
begin
Message1(sym_e_id_not_found, orgpattern);
statement_syssym:=cerrornode.create;
end;
end;
in_cycle :
begin
if m_mac in current_settings.modeswitches then
statement_syssym:=ccontinuenode.create
else
begin
Message1(sym_e_id_not_found, orgpattern);
statement_syssym:=cerrornode.create;
end;
end;
in_typeof_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
consume(_RKLAMMER);
if p1.nodetype=typen then
ttypenode(p1).allowed:=true;
{ Allow classrefdef, which is required for
Typeof(self) in static class methods }
if not(is_objc_class_or_protocol(p1.resultdef)) and
((p1.resultdef.typ = objectdef) or
(assigned(current_procinfo) and
((po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions)) and
(p1.resultdef.typ=classrefdef))) then
statement_syssym:=geninlinenode(in_typeof_x,false,p1)
else
begin
Message(parser_e_class_id_expected);
p1.destroy;
statement_syssym:=cerrornode.create;
end;
end;
in_sizeof_x,
in_bitsizeof_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
consume(_RKLAMMER);
if ((p1.nodetype<>typen) and
(
(is_object(p1.resultdef) and
(oo_has_constructor in tobjectdef(p1.resultdef).objectoptions)) or
is_open_array(p1.resultdef) or
is_array_of_const(p1.resultdef) or
is_open_string(p1.resultdef)
)) or
{ keep the function call if it is a type parameter to avoid arithmetic errors due to constant folding }
(p1.resultdef.typ=undefineddef) then
begin
statement_syssym:=geninlinenode(in_sizeof_x,false,p1);
{ no packed bit support for these things }
if (l = in_bitsizeof_x) then
statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sinttype,true));
end
else
begin
{ allow helpers for SizeOf and BitSizeOf }
if p1.nodetype=typen then
ttypenode(p1).helperallowed:=true;
if (p1.resultdef.typ=forwarddef) then
Message1(type_e_type_is_not_completly_defined,tforwarddef(p1.resultdef).tosymname^);
if (l = in_sizeof_x) or
(not((p1.nodetype = vecn) and
is_packed_array(tvecnode(p1).left.resultdef)) and
not((p1.nodetype = subscriptn) and
is_packed_record_or_object(tsubscriptnode(p1).left.resultdef))) then
begin
statement_syssym:=cordconstnode.create(p1.resultdef.size,sinttype,true);
if (l = in_bitsizeof_x) then
statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sinttype,true));
end
else
statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,true);
{ p1 not needed !}
p1.destroy;
end;
end;
in_typeinfo_x,
in_objc_encode_x :
begin
if (l=in_typeinfo_x) or
(m_objectivec1 in current_settings.modeswitches) then
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
{ When reading a class type it is parsed as loadvmtaddrn,
typeinfo only needs the type so we remove the loadvmtaddrn }
if p1.nodetype=loadvmtaddrn then
begin
p2:=tloadvmtaddrnode(p1).left;
tloadvmtaddrnode(p1).left:=nil;
p1.free;
p1:=p2;
end;
if p1.nodetype=typen then
begin
ttypenode(p1).allowed:=true;
{ allow helpers for TypeInfo }
if l=in_typeinfo_x then
ttypenode(p1).helperallowed:=true;
end;
{ else
begin
p1.destroy;
p1:=cerrornode.create;
Message(parser_e_illegal_parameter_list);
end;}
consume(_RKLAMMER);
p2:=geninlinenode(l,false,p1);
statement_syssym:=p2;
end
else
begin
Message1(sym_e_id_not_found, orgpattern);
statement_syssym:=cerrornode.create;
end;
end;
in_unaligned_x :
begin
err:=false;
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p2:=ccallparanode.create(p1,nil);
p2:=geninlinenode(in_unaligned_x,false,p2);
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_assigned_x :
begin
err:=false;
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
{ When reading a class type it is parsed as loadvmtaddrn,
typeinfo only needs the type so we remove the loadvmtaddrn }
if p1.nodetype=loadvmtaddrn then
begin
p2:=tloadvmtaddrnode(p1).left;
tloadvmtaddrnode(p1).left:=nil;
p1.free;
p1:=p2;
end;
if not codegenerror then
begin
case p1.resultdef.typ of
procdef, { procvar }
pointerdef,
procvardef,
classrefdef : ;
objectdef :
if not is_implicit_pointer_object_type(p1.resultdef) then
begin
Message(parser_e_illegal_parameter_list);
err:=true;
end;
arraydef :
if not is_dynamic_array(p1.resultdef) then
begin
Message(parser_e_illegal_parameter_list);
err:=true;
end;
else
if p1.resultdef.typ<>undefineddef then
begin
Message(parser_e_illegal_parameter_list);
err:=true;
end;
end;
end
else
err:=true;
if not err then
begin
p2:=ccallparanode.create(p1,nil);
p2:=geninlinenode(in_assigned_x,false,p2);
end
else
begin
p1.free;
p2:=cerrornode.create;
end;
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_addr_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p1:=caddrnode.create(p1);
consume(_RKLAMMER);
statement_syssym:=p1;
end;
in_ofs_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p1:=caddrnode.create(p1);
do_typecheckpass(p1);
{ Ofs() returns a cardinal/qword, not a pointer }
p1.resultdef:=uinttype;
consume(_RKLAMMER);
statement_syssym:=p1;
end;
in_seg_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p1:=geninlinenode(in_seg_x,false,p1);
consume(_RKLAMMER);
statement_syssym:=p1;
end;
in_high_x,
in_low_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p2:=geninlinenode(l,false,p1);
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_succ_x,
in_pred_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p2:=geninlinenode(l,false,p1);
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_inc_x,
in_dec_x :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
if try_to_consume(_COMMA) then
p2:=ccallparanode.create(comp_expr(true,false),nil)
else
p2:=nil;
p2:=ccallparanode.create(p1,p2);
statement_syssym:=geninlinenode(l,false,p2);
consume(_RKLAMMER);
end;
in_slice_x:
begin
if not(in_args) then
begin
message(parser_e_illegal_slice);
consume(_LKLAMMER);
in_args:=true;
comp_expr(true,false).free;
if try_to_consume(_COMMA) then
comp_expr(true,false).free;
statement_syssym:=cerrornode.create;
consume(_RKLAMMER);
end
else
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
Consume(_COMMA);
if not(codegenerror) then
p2:=ccallparanode.create(comp_expr(true,false),nil)
else
p2:=cerrornode.create;
p2:=ccallparanode.create(p1,p2);
statement_syssym:=geninlinenode(l,false,p2);
consume(_RKLAMMER);
end;
end;
in_initialize_x:
begin
statement_syssym:=inline_initialize;
end;
in_finalize_x:
begin
statement_syssym:=inline_finalize;
end;
in_copy_x:
begin
statement_syssym:=inline_copy;
end;
in_concat_x :
begin
consume(_LKLAMMER);
in_args:=true;
{ Translate to x:=x+y[+z]. The addnode will do the
type checking }
p2:=nil;
repeat
p1:=comp_expr(true,false);
if p2<>nil then
p2:=caddnode.create(addn,p2,p1)
else
begin
{ Force string type if it isn't yet }
if not(
(p1.resultdef.typ=stringdef) or
is_chararray(p1.resultdef) or
is_char(p1.resultdef)
) then
inserttypeconv(p1,cshortstringtype);
p2:=p1;
end;
until not try_to_consume(_COMMA);
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_read_x,
in_readln_x,
in_readstr_x:
begin
if try_to_consume(_LKLAMMER) then
begin
paras:=parse_paras(false,false,_RKLAMMER);
consume(_RKLAMMER);
end
else
paras:=nil;
p1:=geninlinenode(l,false,paras);
statement_syssym := p1;
end;
in_setlength_x:
begin
statement_syssym := inline_setlength;
end;
in_objc_selector_x:
begin
if (m_objectivec1 in current_settings.modeswitches) then
begin
consume(_LKLAMMER);
in_args:=true;
{ don't turn procsyms into calls (getaddr = true) }
p1:=factor(true,false);
p2:=geninlinenode(l,false,p1);
consume(_RKLAMMER);
statement_syssym:=p2;
end
else
begin
Message1(sym_e_id_not_found, orgpattern);
statement_syssym:=cerrornode.create;
end;
end;
in_length_x:
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
p2:=geninlinenode(l,false,p1);
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_write_x,
in_writeln_x,
in_writestr_x :
begin
if try_to_consume(_LKLAMMER) then
begin
paras:=parse_paras(true,false,_RKLAMMER);
consume(_RKLAMMER);
end
else
paras:=nil;
p1 := geninlinenode(l,false,paras);
statement_syssym := p1;
end;
in_str_x_string :
begin
consume(_LKLAMMER);
paras:=parse_paras(true,false,_RKLAMMER);
consume(_RKLAMMER);
p1 := geninlinenode(l,false,paras);
statement_syssym := p1;
end;
in_val_x:
Begin
consume(_LKLAMMER);
in_args := true;
p1:= ccallparanode.create(comp_expr(true,false), nil);
consume(_COMMA);
p2 := ccallparanode.create(comp_expr(true,false),p1);
if try_to_consume(_COMMA) then
p2 := ccallparanode.create(comp_expr(true,false),p2);
consume(_RKLAMMER);
p2 := geninlinenode(l,false,p2);
statement_syssym := p2;
End;
in_include_x_y,
in_exclude_x_y :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
consume(_COMMA);
p2:=comp_expr(true,false);
statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
consume(_RKLAMMER);
end;
in_pack_x_y_z,
in_unpack_x_y_z :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
consume(_COMMA);
p2:=comp_expr(true,false);
consume(_COMMA);
paras:=comp_expr(true,false);
statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,ccallparanode.create(paras,nil))));
consume(_RKLAMMER);
end;
in_assert_x_y :
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true,false);
if try_to_consume(_COMMA) then
p2:=comp_expr(true,false)
else
begin
{ then insert an empty string }
p2:=cstringconstnode.createstr('');
end;
statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
consume(_RKLAMMER);
end;
in_get_frame:
begin
statement_syssym:=geninlinenode(l,false,nil);
end;
(*
in_get_caller_frame:
begin
if try_to_consume(_LKLAMMER) then
begin
{You used to call get_caller_frame as get_caller_frame(get_frame),
however, as a stack frame may not exist, it does more harm than
good, so ignore it.}
in_args:=true;
p1:=comp_expr(true,false);
p1.destroy;
consume(_RKLAMMER);
end;
statement_syssym:=geninlinenode(l,false,nil);
end;
*)
else
internalerror(15);
end;
in_args:=prev_in_args;
end;
function maybe_load_methodpointer(st:TSymtable;var p1:tnode):boolean;
begin
maybe_load_methodpointer:=false;
if not assigned(p1) then
begin
case st.symtabletype of
withsymtable :
begin
if (st.defowner.typ=objectdef) then
p1:=tnode(twithsymtable(st).withrefnode).getcopy;
end;
ObjectSymtable,
recordsymtable:
begin
{ We are calling from the static class method which has no self node }
if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))
else
p1:=load_self_node;
{ We are calling a member }
maybe_load_methodpointer:=true;
end;
end;
end;
end;
{ reads the parameter for a subroutine call }
procedure do_proc_call(sym:tsym;st:TSymtable;obj:tabstractrecorddef;getaddr:boolean;var again : boolean;var p1:tnode;callflags:tcallnodeflags);
var
membercall,
prevafterassn : boolean;
i : integer;
para,p2 : tnode;
currpara : tparavarsym;
aprocdef : tprocdef;
begin
prevafterassn:=afterassignment;
afterassignment:=false;
membercall:=false;
aprocdef:=nil;
{ when it is a call to a member we need to load the
methodpointer first
}
membercall:=maybe_load_methodpointer(st,p1);
{ When we are expecting a procvar we also need
to get the address in some cases }
if assigned(getprocvardef) then
begin
if (block_type=bt_const) or
getaddr then
begin
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
getaddr:=true;
end
else
if (m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches) then
begin
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
if assigned(aprocdef) then
getaddr:=true;
end;
end;
{ only need to get the address of the procedure? }
if getaddr then
begin
{ Retrieve info which procvar to call. For tp_procvar the
aprocdef is already loaded above so we can reuse it }
if not assigned(aprocdef) and
assigned(getprocvardef) then
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
{ generate a methodcallnode or proccallnode }
{ we shouldn't convert things like @tcollection.load }
p2:=cloadnode.create_procvar(sym,aprocdef,st);
if assigned(p1) then
begin
{ for loading methodpointer of an inherited function
we use self as instance and load the address of
the function directly and not through the vmt (PFV) }
if (cnf_inherited in callflags) then
begin
include(tloadnode(p2).loadnodeflags,loadnf_inherited);
p1.free;
p1:=load_self_node;
end;
if (p1.nodetype<>typen) then
tloadnode(p2).set_mp(p1)
else
p1.free;
end;
p1:=p2;
{ no postfix operators }
again:=false;
end
else
begin
para:=nil;
if anon_inherited then
begin
if not assigned(current_procinfo) then
internalerror(200305054);
for i:=0 to current_procinfo.procdef.paras.count-1 do
begin
currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
if not(vo_is_hidden_para in currpara.varoptions) then
begin
{ inheritance by msgint? }
if assigned(srdef) then
{ anonymous inherited via msgid calls only require a var parameter for
both methods, so we need some type casting here }
para:=ccallparanode.create(ctypeconvnode.create_internal(ctypeconvnode.create_internal(
cloadnode.create(currpara,currpara.owner),cformaltype),tparavarsym(tprocdef(srdef).paras[i]).vardef),
para)
else
para:=ccallparanode.create(cloadnode.create(currpara,currpara.owner),para);
end;
end;
end
else
begin
if try_to_consume(_LKLAMMER) then
begin
para:=parse_paras(false,false,_RKLAMMER);
consume(_RKLAMMER);
end;
end;
{ indicate if this call was generated by a member and
no explicit self is used, this is needed to determine
how to handle a destructor call (PFV) }
if membercall then
include(callflags,cnf_member_call);
if assigned(obj) then
begin
if not (st.symtabletype in [ObjectSymtable,recordsymtable]) then
internalerror(200310031);
p1:=ccallnode.create(para,tprocsym(sym),obj.symtable,p1,callflags);
end
else
p1:=ccallnode.create(para,tprocsym(sym),st,p1,callflags);
end;
afterassignment:=prevafterassn;
end;
procedure handle_procvar(pv : tprocvardef;var p2 : tnode);
var
hp,hp2 : tnode;
hpp : ^tnode;
currprocdef : tprocdef;
begin
if not assigned(pv) then
internalerror(200301121);
if (m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches) then
begin
hp:=p2;
hpp:=@p2;
while assigned(hp) and
(hp.nodetype=typeconvn) do
begin
hp:=ttypeconvnode(hp).left;
{ save orignal address of the old tree so we can replace the node }
hpp:=@hp;
end;
if (hp.nodetype=calln) and
{ a procvar can't have parameters! }
not assigned(tcallnode(hp).left) then
begin
currprocdef:=tcallnode(hp).symtableprocentry.Find_procdef_byprocvardef(pv);
if assigned(currprocdef) then
begin
hp2:=cloadnode.create_procvar(tprocsym(tcallnode(hp).symtableprocentry),currprocdef,tcallnode(hp).symtableproc);
if (po_methodpointer in pv.procoptions) then
tloadnode(hp2).set_mp(tcallnode(hp).methodpointer.getcopy);
hp.destroy;
{ replace the old callnode with the new loadnode }
hpp^:=hp2;
end;
end;
end;
end;
{ checks whether sym is a static field and if so, translates the access
to the appropriate node tree }
function handle_staticfield_access(sym: tsym; nested: boolean; var p1: tnode): boolean;
var
static_name: shortstring;
srsymtable: tsymtable;
begin
result:=false;
{ generate access code }
if (sp_static in sym.symoptions) then
begin
result:=true;
if not nested then
static_name:=lower(sym.owner.name^)+'_'+sym.name
else
static_name:=lower(generate_nested_name(sym.owner,'_'))+'_'+sym.name;
if sym.owner.defowner.typ=objectdef then
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable,true)
else
searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
if assigned(sym) then
check_hints(sym,sym.symoptions,sym.deprecatedmsg);
p1.free;
p1:=nil;
{ static syms are always stored as absolutevarsym to handle scope and storage properly }
propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
end;
end;
{ the following procedure handles the access to a property symbol }
procedure handle_propertysym(propsym : tpropertysym;st : TSymtable;var p1 : tnode);
var
paras : tnode;
p2 : tnode;
membercall : boolean;
callflags : tcallnodeflags;
propaccesslist : tpropaccesslist;
sym: tsym;
begin
{ property parameters? read them only if the property really }
{ has parameters }
paras:=nil;
if (ppo_hasparameters in propsym.propoptions) then
begin
if try_to_consume(_LECKKLAMMER) then
begin
paras:=parse_paras(false,false,_RECKKLAMMER);
consume(_RECKKLAMMER);
end;
end;
{ indexed property }
if (ppo_indexed in propsym.propoptions) then
begin
p2:=cordconstnode.create(propsym.index,propsym.indexdef,true);
paras:=ccallparanode.create(p2,paras);
end;
{ we need only a write property if a := follows }
{ if not(afterassignment) and not(in_args) then }
if token=_ASSIGNMENT then
begin
if getpropaccesslist(propsym,palt_write,propaccesslist) then
begin
sym:=propaccesslist.firstsym^.sym;
case sym.typ of
procsym :
begin
callflags:=[];
{ generate the method call }
membercall:=maybe_load_methodpointer(st,p1);
if membercall then
include(callflags,cnf_member_call);
p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
addsymref(sym);
paras:=nil;
consume(_ASSIGNMENT);
{ read the expression }
if propsym.propdef.typ=procvardef then
getprocvardef:=tprocvardef(propsym.propdef);
p2:=comp_expr(true,false);
if assigned(getprocvardef) then
handle_procvar(getprocvardef,p2);
tcallnode(p1).left:=ccallparanode.create(p2,tcallnode(p1).left);
{ mark as property, both the tcallnode and the real call block }
include(p1.flags,nf_isproperty);
getprocvardef:=nil;
end;
fieldvarsym :
begin
{ generate access code }
if not handle_staticfield_access(sym,false,p1) then
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
consume(_ASSIGNMENT);
{ read the expression }
p2:=comp_expr(true,false);
p1:=cassignmentnode.create(p1,p2);
end
else
begin
p1:=cerrornode.create;
Message(parser_e_no_procedure_to_access_property);
end;
end;
end
else
begin
p1:=cerrornode.create;
Message(parser_e_no_procedure_to_access_property);
end;
end
else
begin
if getpropaccesslist(propsym,palt_read,propaccesslist) then
begin
sym := propaccesslist.firstsym^.sym;
case sym.typ of
fieldvarsym :
begin
{ generate access code }
if not handle_staticfield_access(sym,false,p1) then
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
end;
procsym :
begin
callflags:=[];
{ generate the method call }
membercall:=maybe_load_methodpointer(st,p1);
if membercall then
include(callflags,cnf_member_call);
p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
paras:=nil;
include(p1.flags,nf_isproperty);
end
else
begin
p1:=cerrornode.create;
Message(type_e_mismatch);
end;
end;
end
else
begin
{ error, no function to read property }
p1:=cerrornode.create;
Message(parser_e_no_procedure_to_access_property);
end;
end;
{ release paras if not used }
if assigned(paras) then
paras.free;
end;
{ the ID token has to be consumed before calling this function }
procedure do_member_read(structh:tabstractrecorddef;getaddr:boolean;sym:tsym;var p1:tnode;var again:boolean;callflags:tcallnodeflags);
var
isclassref:boolean;
begin
if sym=nil then
begin
{ pattern is still valid unless
there is another ID just after the ID of sym }
Message1(sym_e_id_no_member,orgpattern);
p1.free;
p1:=cerrornode.create;
{ try to clean up }
again:=false;
end
else
begin
if assigned(p1) then
begin
if not assigned(p1.resultdef) then
do_typecheckpass(p1);
isclassref:=(p1.resultdef.typ=classrefdef);
end
else
isclassref:=false;
{ we assume, that only procsyms and varsyms are in an object }
{ symbol table, for classes, properties are allowed }
case sym.typ of
procsym:
begin
do_proc_call(sym,sym.owner,structh,
(getaddr and not(token in [_CARET,_POINT])),
again,p1,callflags);
{ we need to know which procedure is called }
do_typecheckpass(p1);
{ calling using classref? }
if isclassref and
(p1.nodetype=calln) and
assigned(tcallnode(p1).procdefinition) and
not(po_classmethod in tcallnode(p1).procdefinition.procoptions) and
not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) then
Message(parser_e_only_class_members_via_class_ref);
end;
fieldvarsym:
begin
if not handle_staticfield_access(sym,true,p1) then
begin
if isclassref then
if assigned(p1) and
(
is_self_node(p1) or
(assigned(current_procinfo) and (current_procinfo.procdef.no_self_node) and
(current_procinfo.procdef.struct=structh))) then
Message(parser_e_only_class_members)
else
Message(parser_e_only_class_members_via_class_ref);
p1:=csubscriptnode.create(sym,p1);
end;
end;
propertysym:
begin
if isclassref and not (sp_static in sym.symoptions) then
Message(parser_e_only_class_members_via_class_ref);
handle_propertysym(tpropertysym(sym),sym.owner,p1);
end;
typesym:
begin
p1.free;
if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true,false);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,ttypesym(sym).typedef);
end
else
begin
p1:=ctypenode.create(ttypesym(sym).typedef);
if (is_class(ttypesym(sym).typedef) or is_objcclass(ttypesym(sym).typedef)) and
not(block_type in [bt_type,bt_const_type,bt_var_type]) then
p1:=cloadvmtaddrnode.create(p1);
end;
end;
constsym:
begin
p1.free;
p1:=genconstsymtree(tconstsym(sym));
end;
staticvarsym:
begin
{ typed constant is a staticvarsym
now they are absolutevarsym }
p1.free;
p1:=cloadnode.create(sym,sym.Owner);
end;
absolutevarsym:
begin
p1.free;
p1:=nil;
{ typed constants are absolutebarsyms now to handle storage properly }
propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
end
else
internalerror(16);
end;
end;
end;
function handle_factor_typenode(hdef:tdef;getaddr:boolean;var again:boolean;sym:tsym;typeonly:boolean):tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
if sym=nil then
sym:=hdef.typesym;
{ allow Ordinal(Value) for type declarations since it
can be an enummeration declaration or a set lke:
(OrdinalType(const1)..OrdinalType(const2) }
if (not typeonly or is_ordinal(hdef))and try_to_consume(_LKLAMMER) then
begin
result:=comp_expr(true,false);
consume(_RKLAMMER);
{ type casts to class helpers aren't allowed }
if is_objectpascal_helper(hdef) then
Message(parser_e_no_category_as_types)
{ recovery by not creating a conversion node }
else
result:=ctypeconvnode.create_explicit(result,hdef);
end
else { not LKLAMMER }
if (token=_POINT) and
(is_object(hdef) or is_record(hdef)) then
begin
consume(_POINT);
{ handles calling methods declared in parent objects
using "parentobject.methodname()" }
if assigned(current_structdef) and
not(getaddr) and
current_structdef.is_related(hdef) then
begin
result:=ctypenode.create(hdef);
ttypenode(result).typesym:=sym;
{ search also in inherited methods }
searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,true);
if assigned(srsym) then
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
do_member_read(tabstractrecorddef(hdef),false,srsym,result,again,[]);
end
else
begin
{ handles:
* @TObject.Load
* static methods and variables }
result:=ctypenode.create(hdef);
ttypenode(result).typesym:=sym;
{ TP allows also @TMenu.Load if Load is only }
{ defined in an anchestor class }
srsym:=search_struct_member(tabstractrecorddef(hdef),pattern);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
do_member_read(tabstractrecorddef(hdef),getaddr,srsym,result,again,[]);
end
else
Message1(sym_e_id_no_member,orgpattern);
end;
end
else
begin
{ Normally here would be the check against the usage
of "TClassHelper.Something", but as that might be
used inside of system symbols like sizeof and
typeinfo this check is put into ttypenode.pass_1
(for "TClassHelper" alone) and tcallnode.pass_1
(for "TClassHelper.Something") }
{ class reference ? }
if is_class(hdef) or
is_objcclass(hdef) then
begin
if getaddr and (token=_POINT) then
begin
consume(_POINT);
{ allows @Object.Method }
{ also allows static methods and variables }
result:=ctypenode.create(hdef);
ttypenode(result).typesym:=sym;
{ TP allows also @TMenu.Load if Load is only }
{ defined in an anchestor class }
srsym:=search_struct_member(tobjectdef(hdef),pattern);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
do_member_read(tabstractrecorddef(hdef),getaddr,srsym,result,again,[]);
end
else
begin
Message1(sym_e_id_no_member,orgpattern);
consume(_ID);
end;
end
else
begin
result:=ctypenode.create(hdef);
ttypenode(result).typesym:=sym;
{ For a type block we simply return only
the type. For all other blocks we return
a loadvmt node }
if not(block_type in [bt_type,bt_const_type,bt_var_type]) then
result:=cloadvmtaddrnode.create(result);
end;
end
else
begin
result:=ctypenode.create(hdef);
ttypenode(result).typesym:=sym;
end;
end;
end;
{****************************************************************************
Factor
****************************************************************************}
{---------------------------------------------
PostFixOperators
---------------------------------------------}
{ returns whether or not p1 has been changed }
function postfixoperators(var p1:tnode;var again:boolean;getaddr:boolean): boolean;
{ tries to avoid syntax errors after invalid qualifiers }
procedure recoverconsume_postfixops;
begin
repeat
if not try_to_consume(_CARET) then
if try_to_consume(_POINT) then
try_to_consume(_ID)
else if try_to_consume(_LECKKLAMMER) then
begin
repeat
comp_expr(true,false);
until not try_to_consume(_COMMA);
consume(_RECKKLAMMER);
end
else if try_to_consume(_LKLAMMER) then
begin
repeat
comp_expr(true,false);
until not try_to_consume(_COMMA);
consume(_RKLAMMER);
end
else
break;
until false;
end;
procedure handle_variantarray;
var
p4 : tnode;
newstatement : tstatementnode;
tempresultvariant,
temp : ttempcreatenode;
paras : tcallparanode;
newblock : tnode;
countindices : aint;
begin
{ create statements with call initialize the arguments and
call fpc_dynarr_setlength }
newblock:=internalstatements(newstatement);
{ get temp for array of indicies,
we set the real size later }
temp:=ctempcreatenode.create(s32inttype,4,tt_persistent,false);
addstatement(newstatement,temp);
countindices:=0;
repeat
p4:=comp_expr(true,false);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create_offset(temp,countindices*s32inttype.size),p4));
inc(countindices);
until not try_to_consume(_COMMA);
{ set real size }
temp.size:=countindices*s32inttype.size;
consume(_RECKKLAMMER);
{ we need only a write access if a := follows }
if token=_ASSIGNMENT then
begin
consume(_ASSIGNMENT);
p4:=comp_expr(true,false);
{ create call to fpc_vararray_put }
paras:=ccallparanode.create(cordconstnode.create
(countindices,s32inttype,true),
ccallparanode.create(caddrnode.create_internal
(ctemprefnode.create(temp)),
ccallparanode.create(ctypeconvnode.create_internal(p4,cvarianttype),
ccallparanode.create(ctypeconvnode.create_internal(p1,cvarianttype)
,nil))));
addstatement(newstatement,ccallnode.createintern('fpc_vararray_put',paras));
addstatement(newstatement,ctempdeletenode.create(temp));
end
else
begin
{ create temp for result }
tempresultvariant:=ctempcreatenode.create(cvarianttype,cvarianttype.size,tt_persistent,true);
addstatement(newstatement,tempresultvariant);
{ create call to fpc_vararray_get }
paras:=ccallparanode.create(cordconstnode.create
(countindices,s32inttype,true),
ccallparanode.create(caddrnode.create_internal
(ctemprefnode.create(temp)),
ccallparanode.create(p1,
ccallparanode.create(
ctemprefnode.create(tempresultvariant)
,nil))));
addstatement(newstatement,ccallnode.createintern('fpc_vararray_get',paras));
addstatement(newstatement,ctempdeletenode.create(temp));
{ the last statement should return the value as
location and type, this is done be referencing the
temp and converting it first from a persistent temp to
normal temp }
addstatement(newstatement,ctempdeletenode.create_normal_temp(tempresultvariant));
addstatement(newstatement,ctemprefnode.create(tempresultvariant));
end;
p1:=newblock;
end;
function parse_array_constructor(arrdef:tarraydef): tnode;
var
newstatement,assstatement:tstatementnode;
arrnode:ttempcreatenode;
temp2:ttempcreatenode;
assnode:tnode;
paracount:integer;
begin
result:=internalstatements(newstatement);
{ create temp for result }
arrnode:=ctempcreatenode.create(arrdef,arrdef.size,tt_persistent,true);
addstatement(newstatement,arrnode);
paracount:=0;
{ check arguments and create an assignment calls }
if try_to_consume(_LKLAMMER) then
begin
assnode:=internalstatements(assstatement);
repeat
{ arr[i] := param_i }
addstatement(assstatement,
cassignmentnode.create(
cvecnode.create(
ctemprefnode.create(arrnode),
cordconstnode.create(paracount,arrdef.rangedef,false)),
comp_expr(true,false)));
inc(paracount);
until not try_to_consume(_COMMA);
consume(_RKLAMMER);
end
else
assnode:=nil;
{ get temp for array of lengths }
temp2:=ctempcreatenode.create(sinttype,sinttype.size,tt_persistent,false);
addstatement(newstatement,temp2);
{ one dimensional }
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create_offset(temp2,0),
cordconstnode.create
(paracount,s32inttype,true)));
{ create call to fpc_dynarr_setlength }
addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',
ccallparanode.create(caddrnode.create_internal
(ctemprefnode.create(temp2)),
ccallparanode.create(cordconstnode.create
(1,s32inttype,true),
ccallparanode.create(caddrnode.create_internal
(crttinode.create(tstoreddef(arrdef),initrtti,rdt_normal)),
ccallparanode.create(
ctypeconvnode.create_internal(
ctemprefnode.create(arrnode),voidpointertype),
nil))))
));
{ add assignment statememnts }
addstatement(newstatement,ctempdeletenode.create(temp2));
if assigned(assnode) then
addstatement(newstatement,assnode);
{ the last statement should return the value as
location and type, this is done be referencing the
temp and converting it first from a persistent temp to
normal temp }
addstatement(newstatement,ctempdeletenode.create_normal_temp(arrnode));
addstatement(newstatement,ctemprefnode.create(arrnode));
end;
var
protsym : tpropertysym;
p2,p3 : tnode;
srsym : tsym;
srsymtable : TSymtable;
structh : tabstractrecorddef;
{ shouldn't be used that often, so the extra overhead is ok to save
stack space }
dispatchstring : ansistring;
nodechanged : boolean;
calltype: tdispcalltype;
label
skipreckklammercheck;
begin
result:=false;
again:=true;
while again do
begin
{ we need the resultdef }
do_typecheckpass_changed(p1,nodechanged);
result:=result or nodechanged;
if codegenerror then
begin
recoverconsume_postfixops;
exit;
end;
{ handle token }
case token of
_CARET:
begin
consume(_CARET);
{ support tp/mac procvar^ if the procvar returns a
pointer type }
if ((m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches)) and
(p1.resultdef.typ=procvardef) and
(tprocvardef(p1.resultdef).returndef.typ=pointerdef) then
begin
p1:=ccallnode.create_procvar(nil,p1);
typecheckpass(p1);
end;
if (p1.resultdef.typ<>pointerdef) then
begin
{ ^ as binary operator is a problem!!!! (FK) }
again:=false;
Message(parser_e_invalid_qualifier);
recoverconsume_postfixops;
p1.destroy;
p1:=cerrornode.create;
end
else
p1:=cderefnode.create(p1);
end;
_LECKKLAMMER:
begin
if is_class_or_interface_or_object(p1.resultdef) or
is_dispinterface(p1.resultdef) or is_record(p1.resultdef) then
begin
{ default property }
protsym:=search_default_property(tabstractrecorddef(p1.resultdef));
if not(assigned(protsym)) then
begin
p1.destroy;
p1:=cerrornode.create;
again:=false;
message(parser_e_no_default_property_available);
end
else
begin
{ The property symbol is referenced indirect }
protsym.IncRefCount;
handle_propertysym(protsym,protsym.owner,p1);
end;
end
else
begin
consume(_LECKKLAMMER);
repeat
{ in all of the cases below, p1 is changed }
case p1.resultdef.typ of
pointerdef:
begin
{ support delphi autoderef }
if (tpointerdef(p1.resultdef).pointeddef.typ=arraydef) and
(m_autoderef in current_settings.modeswitches) then
p1:=cderefnode.create(p1);
p2:=comp_expr(true,false);
{ Support Pbytevar[0..9] which returns array [0..9].}
if try_to_consume(_POINTPOINT) then
p2:=crangenode.create(p2,comp_expr(true,false));
p1:=cvecnode.create(p1,p2);
end;
variantdef:
begin
handle_variantarray;
{ the RECKKLAMMER is already read }
goto skipreckklammercheck;
end;
stringdef :
begin
p2:=comp_expr(true,false);
{ Support string[0..9] which returns array [0..9] of char.}
if try_to_consume(_POINTPOINT) then
p2:=crangenode.create(p2,comp_expr(true,false));
p1:=cvecnode.create(p1,p2);
end;
arraydef:
begin
p2:=comp_expr(true,false);
{ support SEG:OFS for go32v2 Mem[] }
if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
(p1.nodetype=loadn) and
assigned(tloadnode(p1).symtableentry) and
assigned(tloadnode(p1).symtableentry.owner.name) and
(tloadnode(p1).symtableentry.owner.name^='SYSTEM') and
((tloadnode(p1).symtableentry.name='MEM') or
(tloadnode(p1).symtableentry.name='MEMW') or
(tloadnode(p1).symtableentry.name='MEML')) then
begin
if try_to_consume(_COLON) then
begin
p3:=caddnode.create(muln,cordconstnode.create($10,s32inttype,false),p2);
p2:=comp_expr(true,false);
p2:=caddnode.create(addn,p2,p3);
if try_to_consume(_POINTPOINT) then
{ Support mem[$a000:$0000..$07ff] which returns array [0..$7ff] of memtype.}
p2:=crangenode.create(p2,caddnode.create(addn,comp_expr(true,false),p3.getcopy));
p1:=cvecnode.create(p1,p2);
include(tvecnode(p1).flags,nf_memseg);
include(tvecnode(p1).flags,nf_memindex);
end
else
begin
if try_to_consume(_POINTPOINT) then
{ Support mem[$80000000..$80000002] which returns array [0..2] of memtype.}
p2:=crangenode.create(p2,comp_expr(true,false));
p1:=cvecnode.create(p1,p2);
include(tvecnode(p1).flags,nf_memindex);
end;
end
else
begin
if try_to_consume(_POINTPOINT) then
{ Support arrayvar[0..9] which returns array [0..9] of arraytype.}
p2:=crangenode.create(p2,comp_expr(true,false));
p1:=cvecnode.create(p1,p2);
end;
end;
else
begin
if p1.resultdef.typ<>undefineddef then
Message(parser_e_invalid_qualifier);
p1.destroy;
p1:=cerrornode.create;
comp_expr(true,false);
again:=false;
end;
end;
do_typecheckpass(p1);
until not try_to_consume(_COMMA);
consume(_RECKKLAMMER);
{ handle_variantarray eats the RECKKLAMMER and jumps here }
skipreckklammercheck:
end;
end;
_POINT :
begin
consume(_POINT);
if (p1.resultdef.typ=pointerdef) and
(m_autoderef in current_settings.modeswitches) and
{ don't auto-deref objc.id, because then the code
below for supporting id.anyobjcmethod isn't triggered }
(p1.resultdef<>objc_idtype) then
begin
p1:=cderefnode.create(p1);
do_typecheckpass(p1);
end;
{ procvar.<something> can never mean anything so always
try to call it in case it returns a record/object/... }
maybe_call_procvar(p1,false);
case p1.resultdef.typ of
recorddef:
begin
if token=_ID then
begin
structh:=tabstractrecorddef(p1.resultdef);
searchsym_in_record(structh,pattern,srsym,srsymtable);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
do_member_read(structh,getaddr,srsym,p1,again,[]);
end
else
begin
Message1(sym_e_id_no_member,orgpattern);
p1.destroy;
p1:=cerrornode.create;
{ try to clean up }
consume(_ID);
end;
end
else
consume(_ID);
end;
enumdef:
begin
if token=_ID then
begin
srsym:=tsym(tenumdef(p1.resultdef).symtable.Find(pattern));
p1.destroy;
if assigned(srsym) and (srsym.typ=enumsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
p1:=genenumnode(tenumsym(srsym));
end
else
begin
Message1(sym_e_id_no_member,orgpattern);
p1:=cerrornode.create;
end;
end;
consume(_ID);
end;
arraydef:
begin
if is_dynamic_array(p1.resultdef) then
begin
if token=_ID then
begin
if pattern='CREATE' then
begin
consume(_ID);
p2:=parse_array_constructor(tarraydef(p1.resultdef));
p1.destroy;
p1:=p2;
end
else
begin
Message2(scan_f_syn_expected,'CREATE',pattern);
p1.destroy;
p1:=cerrornode.create;
consume(_ID);
end;
end;
end
else
begin
Message(parser_e_invalid_qualifier);
p1.destroy;
p1:=cerrornode.create;
consume(_ID);
end;
end;
variantdef:
begin
{ dispatch call? }
{ lhs := v.ident[parameters] -> property get
lhs := v.ident(parameters) -> method call
v.ident[parameters] := rhs -> property put
v.ident(parameters) := rhs -> also property put }
if token=_ID then
begin
dispatchstring:=orgpattern;
consume(_ID);
calltype:=dct_method;
if try_to_consume(_LKLAMMER) then
begin
p2:=parse_paras(false,true,_RKLAMMER);
consume(_RKLAMMER);
end
else if try_to_consume(_LECKKLAMMER) then
begin
p2:=parse_paras(false,true,_RECKKLAMMER);
consume(_RECKKLAMMER);
calltype:=dct_propget;
end
else
p2:=nil;
{ property setter? }
if (token=_ASSIGNMENT) and not(afterassignment) then
begin
consume(_ASSIGNMENT);
{ read the expression }
p3:=comp_expr(true,false);
{ concat value parameter too }
p2:=ccallparanode.create(p3,p2);
p1:=translate_disp_call(p1,p2,dct_propput,dispatchstring,0,voidtype);
end
else
{ this is only an approximation
setting useresult if not necessary is only a waste of time, no more, no less (FK) }
if afterassignment or in_args or (token<>_SEMICOLON) then
p1:=translate_disp_call(p1,p2,calltype,dispatchstring,0,cvarianttype)
else
p1:=translate_disp_call(p1,p2,calltype,dispatchstring,0,voidtype);
end
else { Error }
Consume(_ID);
end;
classrefdef:
begin
if token=_ID then
begin
structh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
do_member_read(structh,getaddr,srsym,p1,again,[]);
end
else
begin
Message1(sym_e_id_no_member,orgpattern);
p1.destroy;
p1:=cerrornode.create;
{ try to clean up }
consume(_ID);
end;
end
else { Error }
Consume(_ID);
end;
objectdef:
begin
if token=_ID then
begin
structh:=tobjectdef(p1.resultdef);
searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
consume(_ID);
do_member_read(structh,getaddr,srsym,p1,again,[]);
end
else
begin
Message1(sym_e_id_no_member,orgpattern);
p1.destroy;
p1:=cerrornode.create;
{ try to clean up }
consume(_ID);
end;
end
else { Error }
Consume(_ID);
end;
pointerdef:
begin
if (p1.resultdef=objc_idtype) then
begin
{ objc's id type can be used to call any
Objective-C method of any Objective-C class
type that's currently in scope }
if search_objc_method(pattern,srsym,srsymtable) then
begin
consume(_ID);
do_proc_call(srsym,srsymtable,nil,
(getaddr and not(token in [_CARET,_POINT])),
again,p1,[cnf_objc_id_call]);
{ we need to know which procedure is called }
do_typecheckpass(p1);
end
else
begin
consume(_ID);
Message(parser_e_methode_id_expected);
end;
end
else
begin
Message(parser_e_invalid_qualifier);
if tpointerdef(p1.resultdef).pointeddef.typ in [recorddef,objectdef,classrefdef] then
Message(parser_h_maybe_deref_caret_missing);
end
end;
else
begin
if p1.resultdef.typ<>undefineddef then
Message(parser_e_invalid_qualifier);
p1.destroy;
p1:=cerrornode.create;
{ Error }
consume(_ID);
end;
end;
end;
else
begin
{ is this a procedure variable ? }
if assigned(p1.resultdef) and
(p1.resultdef.typ=procvardef) then
begin
{ Typenode for typecasting or expecting a procvar }
if (p1.nodetype=typen) or
(
assigned(getprocvardef) and
equal_defs(p1.resultdef,getprocvardef)
) then
begin
if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true,false);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,p1.resultdef);
end
else
again:=false
end
else
begin
if try_to_consume(_LKLAMMER) then
begin
p2:=parse_paras(false,false,_RKLAMMER);
consume(_RKLAMMER);
p1:=ccallnode.create_procvar(p2,p1);
{ proc():= is never possible }
if token=_ASSIGNMENT then
begin
Message(parser_e_illegal_expression);
p1.free;
p1:=cerrornode.create;
again:=false;
end;
end
else
again:=false;
end;
end
else
again:=false;
end;
end;
{ we only try again if p1 was changed }
if again or
(p1.nodetype=errorn) then
result:=true;
end; { while again }
end;
function is_member_read(sym: tsym; st: tsymtable; var p1: tnode;
out memberparentdef: tdef): boolean;
var
hdef : tdef;
begin
result:=true;
memberparentdef:=nil;
case st.symtabletype of
ObjectSymtable,
recordsymtable:
begin
memberparentdef:=tdef(st.defowner);
exit;
end;
WithSymtable:
begin
if assigned(p1) then
internalerror(2007012002);
hdef:=tnode(twithsymtable(st).withrefnode).resultdef;
p1:=tnode(twithsymtable(st).withrefnode).getcopy;
if not(hdef.typ in [objectdef,classrefdef]) then
exit;
if (hdef.typ=classrefdef) then
hdef:=tclassrefdef(hdef).pointeddef;
memberparentdef:=hdef;
end;
else
result:=false;
end;
end;
{$maxfpuregisters 0}
function factor(getaddr,typeonly:boolean) : tnode;
{---------------------------------------------
Factor_read_id
---------------------------------------------}
procedure factor_read_id(out p1:tnode;var again:boolean);
var
srsym : tsym;
srsymtable : TSymtable;
hdef : tdef;
orgstoredpattern,
storedpattern : string;
callflags: tcallnodeflags;
t : ttoken;
unit_found : boolean;
begin
{ allow post fix operators }
again:=true;
{ first check for identifier }
if token<>_ID then
begin
srsym:=generrorsym;
srsymtable:=nil;
consume(_ID);
end
else
begin
if typeonly then
searchsym_type(pattern,srsym,srsymtable)
else
searchsym(pattern,srsym,srsymtable);
{ handle unit specification like System.Writeln }
unit_found:=try_consume_unitsym(srsym,srsymtable,t,true);
storedpattern:=pattern;
orgstoredpattern:=orgpattern;
consume(t);
{ named parameter support }
found_arg_name:=false;
if not(unit_found) and
named_args_allowed and
(token=_ASSIGNMENT) then
begin
found_arg_name:=true;
p1:=cstringconstnode.createstr(storedpattern);
consume(_ASSIGNMENT);
exit;
end;
{ check hints, but only if it isn't a potential generic symbol;
that is checked in sub_expr if it isn't a generic }
if assigned(srsym) and
not (
(srsym.typ=typesym) and
(ttypesym(srsym).typedef.typ in [recorddef,objectdef,arraydef,procvardef,undefineddef]) and
not (sp_generic_para in srsym.symoptions) and
(token in [_LT, _LSHARPBRACKET])
) then
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
{ if nothing found give error and return errorsym }
if not assigned(srsym) or
{ is this a generic dummy symbol? }
((srsym.typ=typesym) and
assigned(ttypesym(srsym).typedef) and
(ttypesym(srsym).typedef.typ=undefineddef) and
not (sp_generic_para in srsym.symoptions) and
not (token in [_LT, _LSHARPBRACKET]) and
not (
{ in non-Delphi modes the generic class' name without a
"specialization" or "<T>" may be used to identify the
current class }
(sp_generic_dummy in srsym.symoptions) and
assigned(current_structdef) and
(df_generic in current_structdef.defoptions) and
not (m_delphi in current_settings.modeswitches) and
(upper(srsym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1))
)) then
begin
identifier_not_found(orgstoredpattern);
srsym:=generrorsym;
srsymtable:=nil;
end;
end;
{ Access to funcret or need to call the function? }
if (srsym.typ in [absolutevarsym,localvarsym,paravarsym]) and
(vo_is_funcret in tabstractvarsym(srsym).varoptions) and
{ result(x) is not allowed }
not(vo_is_result in tabstractvarsym(srsym).varoptions) and
(
(token=_LKLAMMER) or
(
(
(m_tp7 in current_settings.modeswitches) or
(m_delphi in current_settings.modeswitches)
) and
(afterassignment or in_args)
)
) then
begin
hdef:=tdef(srsym.owner.defowner);
if assigned(hdef) and
(hdef.typ=procdef) then
srsym:=tprocdef(hdef).procsym
else
begin
Message(parser_e_illegal_expression);
srsym:=generrorsym;
end;
srsymtable:=srsym.owner;
end;
begin
case srsym.typ of
absolutevarsym :
begin
if (tabsolutevarsym(srsym).abstyp=tovar) then
begin
p1:=nil;
propaccesslist_to_node(p1,nil,tabsolutevarsym(srsym).ref);
p1:=ctypeconvnode.create(p1,tabsolutevarsym(srsym).vardef);
include(p1.flags,nf_absolute);
end
else
p1:=cloadnode.create(srsym,srsymtable);
end;
staticvarsym,
localvarsym,
paravarsym,
fieldvarsym :
begin
{ check if we are reading a field of an object/class/ }
{ record. is_member_read() will deal with withsymtables }
{ if needed. }
p1:=nil;
if is_member_read(srsym,srsymtable,p1,hdef) then
begin
{ if the field was originally found in an }
{ objectsymtable, it means it's part of self }
{ if only method from which it was called is }
{ not class static }
if (srsymtable.symtabletype in [ObjectSymtable,recordsymtable]) then
{ if we are accessing a owner procsym from the nested }
{ class we need to call it as a class member }
if assigned(current_structdef) and (current_structdef<>hdef) and is_owned_by(current_structdef,hdef) then
p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
else
if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))
else
p1:=load_self_node;
{ now, if the field itself is part of an objectsymtab }
{ (it can be even if it was found in a withsymtable, }
{ e.g., "with classinstance do field := 5"), then }
{ let do_member_read handle it }
if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[])
else
{ otherwise it's a regular record subscript }
p1:=csubscriptnode.create(srsym,p1);
end
else
{ regular non-field load }
p1:=cloadnode.create(srsym,srsymtable);
end;
syssym :
begin
p1:=statement_syssym(tsyssym(srsym).number);
end;
typesym :
begin
hdef:=ttypesym(srsym).typedef;
if not assigned(hdef) then
begin
again:=false;
end
else
begin
{ We need to know if this unit uses Variants }
if (hdef=cvarianttype) and
not(cs_compilesystem in current_settings.moduleswitches) then
current_module.flags:=current_module.flags or uf_uses_variants;
p1:=handle_factor_typenode(hdef,getaddr,again,srsym,typeonly);
end;
end;
enumsym :
begin
p1:=genenumnode(tenumsym(srsym));
end;
constsym :
begin
if tconstsym(srsym).consttyp=constresourcestring then
begin
p1:=cloadnode.create(srsym,srsymtable);
do_typecheckpass(p1);
p1.resultdef:=getansistringdef;
end
else
p1:=genconstsymtree(tconstsym(srsym));
end;
procsym :
begin
p1:=nil;
{ check if it's a method/class method }
if is_member_read(srsym,srsymtable,p1,hdef) then
begin
{ if we are accessing a owner procsym from the nested }
{ class we need to call it as a class member }
if (srsymtable.symtabletype in [ObjectSymtable,recordsymtable]) and
assigned(current_structdef) and (current_structdef<>hdef) and is_owned_by(current_structdef,hdef) then
p1:=cloadvmtaddrnode.create(ctypenode.create(hdef));
{ not srsymtable.symtabletype since that can be }
{ withsymtable as well }
if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[])
else
{ no procsyms in records (yet) }
internalerror(2007012006);
end
else
begin
{ regular procedure/function call }
if not unit_found then
callflags:=[]
else
callflags:=[cnf_unit_specified];
do_proc_call(srsym,srsymtable,nil,
(getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER])),
again,p1,callflags);
end;
end;
propertysym :
begin
p1:=nil;
{ property of a class/object? }
if is_member_read(srsym,srsymtable,p1,hdef) then
begin
if (srsymtable.symtabletype in [ObjectSymtable,recordsymtable]) then
{ if we are accessing a owner procsym from the nested }
{ class we need to call it as a class member }
if assigned(current_structdef) and (current_structdef<>hdef) and is_owned_by(current_structdef,hdef) then
p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
else
if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
{ no self node in static class methods }
p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
else
p1:=load_self_node;
{ not srsymtable.symtabletype since that can be }
{ withsymtable as well }
if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[])
else
{ no propertysyms in records (yet) }
internalerror(2009111510);
end
else
{ no method pointer }
begin
handle_propertysym(tpropertysym(srsym),srsymtable,p1);
end;
end;
labelsym :
begin
{ Support @label }
if getaddr then
begin
if srsym.owner<>current_procinfo.procdef.localst then
CGMessage(parser_e_label_outside_proc);
p1:=cloadnode.create(srsym,srsym.owner)
end
else
begin
consume(_COLON);
if tlabelsym(srsym).defined then
Message(sym_e_label_already_defined);
if symtablestack.top.symtablelevel<>srsymtable.symtablelevel then
begin
tlabelsym(srsym).nonlocal:=true;
exclude(current_procinfo.procdef.procoptions,po_inline);
end;
if tlabelsym(srsym).nonlocal and
(current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
Message(sym_e_interprocgoto_into_init_final_code_not_allowed);
tlabelsym(srsym).defined:=true;
p1:=clabelnode.create(nil,tlabelsym(srsym));
tlabelsym(srsym).code:=p1;
end;
end;
errorsym :
begin
p1:=cerrornode.create;
if try_to_consume(_LKLAMMER) then
begin
parse_paras(false,false,_RKLAMMER);
consume(_RKLAMMER);
end;
end;
else
begin
p1:=cerrornode.create;
Message(parser_e_illegal_expression);
end;
end; { end case }
end;
end;
{---------------------------------------------
Factor_Read_Set
---------------------------------------------}
{ Read a set between [] }
function factor_read_set:tnode;
var
p1,p2 : tnode;
lastp,
buildp : tarrayconstructornode;
old_allow_array_constructor : boolean;
begin
buildp:=nil;
{ be sure that a least one arrayconstructn is used, also for an
empty [] }
if token=_RECKKLAMMER then
buildp:=carrayconstructornode.create(nil,buildp)
else
repeat
{ nested array constructors are not allowed, see also tests/webtbs/tw17213.pp }
old_allow_array_constructor:=allow_array_constructor;
allow_array_constructor:=false;
p1:=comp_expr(true,false);
if try_to_consume(_POINTPOINT) then
begin
p2:=comp_expr(true,false);
p1:=carrayconstructorrangenode.create(p1,p2);
end;
{ insert at the end of the tree, to get the correct order }
if not assigned(buildp) then
begin
buildp:=carrayconstructornode.create(p1,nil);
lastp:=buildp;
end
else
begin
lastp.right:=carrayconstructornode.create(p1,nil);
lastp:=tarrayconstructornode(lastp.right);
end;
allow_array_constructor:=old_allow_array_constructor;
{ there could be more elements }
until not try_to_consume(_COMMA);
factor_read_set:=buildp;
end;
{---------------------------------------------
Factor (Main)
---------------------------------------------}
var
l : longint;
ic : int64;
qc : qword;
p1 : tnode;
code : integer;
srsym : tsym;
srsymtable : TSymtable;
pd : tprocdef;
hclassdef : tobjectdef;
d : bestreal;
cur : currency;
hs,hsorg : string;
hdef : tdef;
filepos : tfileposinfo;
callflags : tcallnodeflags;
again,
updatefpos,
nodechanged : boolean;
begin
{ can't keep a copy of p1 and compare pointers afterwards, because
p1 may be freed and reallocated in the same place! }
updatefpos:=false;
p1:=nil;
filepos:=current_tokenpos;
again:=false;
if token=_ID then
begin
again:=true;
{ Handle references to self }
if (idtoken=_SELF) and
not(block_type in [bt_const,bt_type,bt_const_type,bt_var_type]) and
assigned(current_structdef) then
begin
p1:=load_self_node;
consume(_ID);
again:=true;
end
else
factor_read_id(p1,again);
if assigned(p1) then
begin
{ factor_read_id will set the filepos to after the id,
and in case of _SELF the filepos will already be the
same as filepos (so setting it again doesn't hurt). }
p1.fileinfo:=filepos;
filepos:=current_tokenpos;
end;
{ handle post fix operators }
updatefpos:=postfixoperators(p1,again,getaddr);
end
else
begin
updatefpos:=true;
case token of
_RETURN :
begin
consume(_RETURN);
if not(token in [_SEMICOLON,_ELSE,_END]) then
p1 := cexitnode.create(comp_expr(true,false))
else
p1 := cexitnode.create(nil);
end;
_INHERITED :
begin
again:=true;
consume(_INHERITED);
if assigned(current_procinfo) and
assigned(current_structdef) and
(current_structdef.typ=objectdef) then
begin
{ for record helpers in mode Delphi "inherited" is not
allowed }
if is_objectpascal_helper(current_structdef) and
(m_delphi in current_settings.modeswitches) and
is_record(tobjectdef(current_structdef).extendeddef) then
Message(parser_e_inherited_not_in_record);
hclassdef:=tobjectdef(current_structdef).childof;
{ Objective-C categories *replace* methods in the class
they extend, or add methods to it. So calling an
inherited method always calls the method inherited from
the parent of the extended class }
if is_objccategory(current_structdef) then
hclassdef:=hclassdef.childof;
{ if inherited; only then we need the method with
the same name }
if token <> _ID then
begin
hs:=current_procinfo.procdef.procsym.name;
hsorg:=current_procinfo.procdef.procsym.realname;
anon_inherited:=true;
{ For message methods we need to search using the message
number or string }
pd:=tprocdef(tprocsym(current_procinfo.procdef.procsym).ProcdefList[0]);
srdef:=nil;
if (po_msgint in pd.procoptions) then
searchsym_in_class_by_msgint(hclassdef,pd.messageinf.i,srdef,srsym,srsymtable)
else
if (po_msgstr in pd.procoptions) then
searchsym_in_class_by_msgstr(hclassdef,pd.messageinf.str^,srsym,srsymtable)
else
{ helpers have their own ways of dealing with inherited }
if is_objectpascal_helper(current_structdef) then
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
else
searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
end
else
begin
hs:=pattern;
hsorg:=orgpattern;
consume(_ID);
anon_inherited:=false;
{ helpers have their own ways of dealing with inherited }
if is_objectpascal_helper(current_structdef) then
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
else
searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
end;
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
{ load the procdef from the inherited class and
not from self }
case srsym.typ of
procsym:
begin
if is_objectpascal_helper(current_structdef) then
begin
{ for a helper load the procdef either from the
extended type, from the parent helper or from
the extended type of the parent helper
depending on the def the found symbol belongs
to }
if (srsym.Owner.defowner.typ=objectdef) and
is_objectpascal_helper(tobjectdef(srsym.Owner.defowner)) then
if current_structdef.is_related(tdef(srsym.Owner.defowner)) and
assigned(tobjectdef(current_structdef).childof) then
hdef:=tobjectdef(current_structdef).childof
else
hdef:=tobjectdef(srsym.Owner.defowner).extendeddef
else
hdef:=tdef(srsym.Owner.defowner);
end
else
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=tclassrefdef.create(hdef);
p1:=ctypenode.create(hdef);
{ we need to allow helpers here }
ttypenode(p1).helperallowed:=true;
end;
propertysym:
;
else
begin
Message(parser_e_methode_id_expected);
p1:=cerrornode.create;
end;
end;
callflags:=[cnf_inherited];
if anon_inherited then
include(callflags,cnf_anon_inherited);
do_member_read(hclassdef,getaddr,srsym,p1,again,callflags);
end
else
begin
if anon_inherited then
begin
{ For message methods we need to call DefaultHandler }
if (po_msgint in pd.procoptions) or
(po_msgstr in pd.procoptions) then
begin
searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable,true);
if not assigned(srsym) or
(srsym.typ<>procsym) then
internalerror(200303171);
p1:=nil;
do_proc_call(srsym,srsym.owner,hclassdef,false,again,p1,[]);
end
else
begin
{ we need to ignore the inherited; }
p1:=cnothingnode.create;
end;
end
else
begin
Message1(sym_e_id_no_member,hsorg);
p1:=cerrornode.create;
end;
again:=false;
end;
{ turn auto inheriting off }
anon_inherited:=false;
end
else
begin
{ in case of records we use a more clear error message }
if assigned(current_structdef) and
(current_structdef.typ=recorddef) then
Message(parser_e_inherited_not_in_record)
else
Message(parser_e_generic_methods_only_in_methods);
again:=false;
p1:=cerrornode.create;
end;
postfixoperators(p1,again,getaddr);
end;
_INTCONST :
begin
{Try first wether the value fits in an int64.}
val(pattern,ic,code);
if code=0 then
begin
consume(_INTCONST);
int_to_type(ic,hdef);
p1:=cordconstnode.create(ic,hdef,true);
end
else
begin
{ try qword next }
val(pattern,qc,code);
if code=0 then
begin
consume(_INTCONST);
int_to_type(qc,hdef);
p1:=cordconstnode.create(qc,hdef,true);
end;
end;
if code<>0 then
begin
{ finally float }
val(pattern,d,code);
if code<>0 then
begin
Message(parser_e_invalid_integer);
consume(_INTCONST);
l:=1;
p1:=cordconstnode.create(l,sinttype,true);
end
else
begin
consume(_INTCONST);
p1:=crealconstnode.create(d,pbestrealtype^);
end;
end
else
{ the necessary range checking has already been done by val }
tordconstnode(p1).rangecheck:=false;
end;
_REALNUMBER :
begin
val(pattern,d,code);
if code<>0 then
begin
Message(parser_e_error_in_real);
d:=1.0;
end;
consume(_REALNUMBER);
{$ifdef FPC_REAL2REAL_FIXED}
if current_settings.fputype=fpu_none then
Message(parser_e_unsupported_real);
if (current_settings.minfpconstprec=s32real) and
(d = single(d)) then
p1:=crealconstnode.create(d,s32floattype)
else if (current_settings.minfpconstprec=s64real) and
(d = double(d)) then
p1:=crealconstnode.create(d,s64floattype)
else
{$endif FPC_REAL2REAL_FIXED}
p1:=crealconstnode.create(d,pbestrealtype^);
{$ifdef FPC_HAS_STR_CURRENCY}
val(pattern,cur,code);
if code=0 then
trealconstnode(p1).value_currency:=cur;
{$endif FPC_HAS_STR_CURRENCY}
end;
_STRING :
begin
string_dec(hdef,true);
{ STRING can be also a type cast }
if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true,false);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,hdef);
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators(p1,again,getaddr);
end
else
p1:=ctypenode.create(hdef);
end;
_FILE :
begin
hdef:=cfiletype;
consume(_FILE);
{ FILE can be also a type cast }
if try_to_consume(_LKLAMMER) then
begin
p1:=comp_expr(true,false);
consume(_RKLAMMER);
p1:=ctypeconvnode.create_explicit(p1,hdef);
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators(p1,again,getaddr);
end
else
begin
p1:=ctypenode.create(hdef);
end;
end;
_CSTRING :
begin
p1:=cstringconstnode.createpchar(ansistring2pchar(cstringpattern),length(cstringpattern));
consume(_CSTRING);
end;
_CCHAR :
begin
p1:=cordconstnode.create(ord(pattern[1]),cchartype,true);
consume(_CCHAR);
end;
_CWSTRING:
begin
p1:=cstringconstnode.createwstr(patternw);
consume(_CWSTRING);
end;
_CWCHAR:
begin
p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true);
consume(_CWCHAR);
end;
_KLAMMERAFFE :
begin
consume(_KLAMMERAFFE);
got_addrn:=true;
{ support both @<x> and @(<x>) }
if try_to_consume(_LKLAMMER) then
begin
p1:=factor(true,false);
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again,getaddr);
end
else
consume(_RKLAMMER);
end
else
p1:=factor(true,false);
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again,getaddr);
end;
got_addrn:=false;
p1:=caddrnode.create(p1);
p1.fileinfo:=filepos;
if cs_typed_addresses in current_settings.localswitches then
include(p1.flags,nf_typedaddr);
{ Store the procvar that we are expecting, the
addrn will use the information to find the correct
procdef or it will return an error }
if assigned(getprocvardef) and
(taddrnode(p1).left.nodetype = loadn) then
taddrnode(p1).getprocvardef:=getprocvardef;
end;
_LKLAMMER :
begin
consume(_LKLAMMER);
p1:=comp_expr(true,false);
consume(_RKLAMMER);
{ it's not a good solution }
{ but (a+b)^ makes some problems }
if token in [_CARET,_POINT,_LECKKLAMMER] then
begin
again:=true;
postfixoperators(p1,again,getaddr);
end;
end;
_LECKKLAMMER :
begin
consume(_LECKKLAMMER);
p1:=factor_read_set;
consume(_RECKKLAMMER);
end;
_PLUS :
begin
consume(_PLUS);
p1:=factor(false,false);
p1:=cunaryplusnode.create(p1);
end;
_MINUS :
begin
consume(_MINUS);
if (token = _INTCONST) and not(m_isolike_unary_minus in current_settings.modeswitches) then
begin
{ ugly hack, but necessary to be able to parse }
{ -9223372036854775808 as int64 (JM) }
pattern := '-'+pattern;
p1:=sub_expr(oppower,false,false,nil);
{ -1 ** 4 should be - (1 ** 4) and not
(-1) ** 4
This was the reason of tw0869.pp test failure PM }
if p1.nodetype=starstarn then
begin
if tbinarynode(p1).left.nodetype=ordconstn then
begin
tordconstnode(tbinarynode(p1).left).value:=-tordconstnode(tbinarynode(p1).left).value;
p1:=cunaryminusnode.create(p1);
end
else if tbinarynode(p1).left.nodetype=realconstn then
begin
trealconstnode(tbinarynode(p1).left).value_real:=-trealconstnode(tbinarynode(p1).left).value_real;
trealconstnode(tbinarynode(p1).left).value_currency:=-trealconstnode(tbinarynode(p1).left).value_currency;
p1:=cunaryminusnode.create(p1);
end
else
internalerror(20021029);
end;
end
else
begin
if m_isolike_unary_minus in current_settings.modeswitches then
p1:=sub_expr(opmultiply,false,false,nil)
else
p1:=sub_expr(oppower,false,false,nil);
p1:=cunaryminusnode.create(p1);
end;
end;
_OP_NOT :
begin
consume(_OP_NOT);
p1:=factor(false,false);
p1:=cnotnode.create(p1);
end;
_TRUE :
begin
consume(_TRUE);
p1:=cordconstnode.create(1,pasbool8type,false);
end;
_FALSE :
begin
consume(_FALSE);
p1:=cordconstnode.create(0,pasbool8type,false);
end;
_NIL :
begin
consume(_NIL);
p1:=cnilnode.create;
{ It's really ugly code nil^, but delphi allows it }
if token in [_CARET] then
begin
again:=true;
postfixoperators(p1,again,getaddr);
end;
end;
_OBJCPROTOCOL:
begin
{ The @protocol keyword is used in two ways in Objective-C:
1) to declare protocols (~ Object Pascal interfaces)
2) to obtain the metaclass (~ Object Pascal) "class of")
of a declared protocol
This code is for handling the second case. Because of 1),
we cannot simply use a system unit symbol.
}
consume(_OBJCPROTOCOL);
consume(_LKLAMMER);
p1:=factor(false,false);
consume(_RKLAMMER);
p1:=cinlinenode.create(in_objc_protocol_x,false,p1);
end;
else
begin
Message(parser_e_illegal_expression);
p1:=cerrornode.create;
{ recover }
consume(token);
end;
end;
end;
{ generate error node if no node is created }
if not assigned(p1) then
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'factor: p1=nil');
{$endif}
p1:=cerrornode.create;
updatefpos:=true;
end;
{ get the resultdef for the node }
if (not assigned(p1.resultdef)) then
begin
do_typecheckpass_changed(p1,nodechanged);
updatefpos:=updatefpos or nodechanged;
end;
if assigned(p1) and
updatefpos then
p1.fileinfo:=filepos;
factor:=p1;
end;
{$maxfpuregisters default}
procedure post_comp_expr_gendef(var def: tdef);
var
p1 : tnode;
again : boolean;
begin
if not assigned(def) then
internalerror(2011053001);
again:=false;
{ handle potential typecasts, etc }
p1:=handle_factor_typenode(def,false,again,nil,false);
{ parse postfix operators }
postfixoperators(p1,again,false);
if assigned(p1) and (p1.nodetype=typen) then
def:=ttypenode(p1).typedef
else
def:=generrordef;
end;
{****************************************************************************
Sub_Expr
****************************************************************************}
const
{ Warning these stay be ordered !! }
operator_levels:array[Toperator_precedence] of set of NOTOKEN..last_operator=
([_LT,_LTE,_GT,_GTE,_EQ,_NE,_OP_IN],
[_PLUS,_MINUS,_OP_OR,_PIPE,_OP_XOR],
[_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH,
_OP_AS,_OP_IS,_OP_AND,_AMPERSAND,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR],
[_STARSTAR] );
function sub_expr(pred_level:Toperator_precedence;accept_equal,typeonly:boolean;factornode:tnode):tnode;
{Reads a subexpression while the operators are of the current precedence
level, or any higher level. Replaces the old term, simpl_expr and
simpl2_expr.}
function istypenode(n:tnode):boolean;inline;
{ Checks whether the given node is a type node or a VMT node containing a
typenode. This is used in the code for inline specializations in the
_LT branch below }
begin
result:=assigned(n) and
(
(n.nodetype=typen) or
(
(n.nodetype=loadvmtaddrn) and
(tloadvmtaddrnode(n).left.nodetype=typen)
)
);
end;
function gettypedef(n:tnode):tdef;inline;
{ This returns the typedef that belongs to the given typenode or
loadvmtaddrnode. n must not be Nil! }
begin
if n.nodetype=typen then
result:=ttypenode(n).typedef
else
result:=ttypenode(tloadvmtaddrnode(n).left).typedef;
end;
function getgenericsym(n:tnode;out srsym:tsym):boolean;
var
srsymtable : tsymtable;
begin
srsym:=nil;
case n.nodetype of
typen:
srsym:=ttypenode(n).typedef.typesym;
loadvmtaddrn:
srsym:=ttypenode(tloadvmtaddrnode(n).left).typedef.typesym;
loadn:
if not searchsym_with_symoption(tloadnode(n).symtableentry.Name,srsym,srsymtable,sp_generic_dummy) then
srsym:=nil;
{ TODO : handle const nodes }
end;
result:=assigned(srsym);
end;
label
SubExprStart;
var
p1,p2 : tnode;
oldt : Ttoken;
filepos : tfileposinfo;
again : boolean;
gendef,parseddef : tdef;
gensym : tsym;
begin
SubExprStart:
if pred_level=highest_precedence then
begin
if factornode=nil then
p1:=factor(false,typeonly)
else
p1:=factornode;
end
else
p1:=sub_expr(succ(pred_level),true,typeonly,factornode);
repeat
if (token in [NOTOKEN..last_operator]) and
(token in operator_levels[pred_level]) and
((token<>_EQ) or accept_equal) then
begin
oldt:=token;
filepos:=current_tokenpos;
consume(token);
if pred_level=highest_precedence then
p2:=factor(false,false)
else
p2:=sub_expr(succ(pred_level),true,typeonly,nil);
case oldt of
_PLUS :
p1:=caddnode.create(addn,p1,p2);
_MINUS :
p1:=caddnode.create(subn,p1,p2);
_STAR :
p1:=caddnode.create(muln,p1,p2);
_SLASH :
p1:=caddnode.create(slashn,p1,p2);
_EQ:
p1:=caddnode.create(equaln,p1,p2);
_GT :
p1:=caddnode.create(gtn,p1,p2);
_LT :
begin
{ we need to decice whether we have an inline specialization
(type nodes to the left and right of "<", mode Delphi and
">" or "," following) or a normal "<" comparison }
{ TODO : p1 could be a non type if e.g. a variable with the
same name is defined in the same unit where the
generic is defined (though "same unit" is not
necessarily needed) }
if getgenericsym(p1,gensym) and
{ Attention: when nested specializations are supported
p2 could be a loadn if a "<" follows }
istypenode(p2) and
(m_delphi in current_settings.modeswitches) and
{ TODO : add _LT, _LSHARPBRACKET for nested specializations }
(token in [_GT,_RSHARPBRACKET,_COMMA]) then
begin
{ this is an inline specialization }
{ retrieve the defs of two nodes }
gendef:=nil;
parseddef:=gettypedef(p2);
if parseddef.typesym.typ<>typesym then
Internalerror(2011051001);
{ check the hints for parseddef }
check_hints(parseddef.typesym,parseddef.typesym.symoptions,parseddef.typesym.deprecatedmsg);
{ generate the specialization }
generate_specialization(gendef,false,'',parseddef,gensym.RealName);
{ we don't need the old left and right nodes anymore }
p1.Free;
p2.Free;
{ in case of a class or a record the specialized generic
is always a classrefdef }
again:=false;
{ handle potential typecasts, etc }
p1:=handle_factor_typenode(gendef,false,again,nil,false);
{ parse postfix operators }
if postfixoperators(p1,again,false) then
if assigned(p1) then
p1.fileinfo:=filepos
else
p1:=cerrornode.create;
{ with p1 now set we are in reality directly behind the
call to "factor" thus we need to call down to that
again }
{ This is disabled until specializations on the right
hand side work as well, because
"not working expressions" is better than "half working
expressions" }
{factornode:=p1;
goto SubExprStart;}
end
else
begin
{ this is a normal "<" comparison }
{ potential generic types that are followed by a "<" }
{ a) are not checked whether they are an undefined def,
but not a generic parameter }
if (p1.nodetype=typen) and
(ttypenode(p1).typedef.typ=undefineddef) and
assigned(ttypenode(p1).typedef.typesym) and
not (sp_generic_para in ttypenode(p1).typedef.typesym.symoptions) then
begin
identifier_not_found(ttypenode(p1).typedef.typesym.RealName);
p1.Free;
p1:=cerrornode.create;
end;
{ b) don't have their hints checked }
if istypenode(p1) then
begin
gendef:=gettypedef(p1);
if gendef.typ in [objectdef,recorddef,arraydef,procvardef] then
check_hints(gendef.typesym,gendef.typesym.symoptions,gendef.typesym.deprecatedmsg);
end;
{ Note: the second part of the expression will be needed
for nested specializations }
if istypenode(p2) {and
not (token in [_LT, _LSHARPBRACKET])} then
begin
gendef:=gettypedef(p2);
if gendef.typ in [objectdef,recorddef,arraydef,procvardef] then
check_hints(gendef.typesym,gendef.typesym.symoptions,gendef.typesym.deprecatedmsg);
end;
{ create the comparison node for "<" }
p1:=caddnode.create(ltn,p1,p2)
end;
end;
_GTE :
p1:=caddnode.create(gten,p1,p2);
_LTE :
p1:=caddnode.create(lten,p1,p2);
_SYMDIF :
p1:=caddnode.create(symdifn,p1,p2);
_STARSTAR :
p1:=caddnode.create(starstarn,p1,p2);
_OP_AS,
_OP_IS :
begin
if token in [_LT, _LSHARPBRACKET] then
begin
{ for now we're handling this as a generic declaration;
there could be cases though (because of operator
overloading) where this is the wrong decision... }
{ TODO : here the same note as in _LT applies as p2 could
point to a variable, etc }
gendef:=gettypedef(p2);
if gendef.typesym.typ<>typesym then
Internalerror(2011071401);
{ generate the specialization }
generate_specialization(gendef,false,'',nil,'');
{ we don't need the old p2 anymore }
p2.Free;
again:=false;
{ handle potential typecasts, etc }
p2:=handle_factor_typenode(gendef,false,again,nil,false);
{ parse postfix operators }
if postfixoperators(p2,again,false) then
if assigned(p2) then
p2.fileinfo:=filepos
else
p2:=cerrornode.create;
{ here we don't need to call back down to "factor", thus
no "goto" }
end;
{ now generate the "is" or "as" node }
case oldt of
_OP_AS:
p1:=casnode.create(p1,p2);
_OP_IS:
p1:=cisnode.create(p1,p2);
end;
end;
_OP_IN :
p1:=cinnode.create(p1,p2);
_OP_OR,
_PIPE {macpas only} :
begin
p1:=caddnode.create(orn,p1,p2);
if (oldt = _PIPE) then
include(p1.flags,nf_short_bool);
end;
_OP_AND,
_AMPERSAND {macpas only} :
begin
p1:=caddnode.create(andn,p1,p2);
if (oldt = _AMPERSAND) then
include(p1.flags,nf_short_bool);
end;
_OP_DIV :
p1:=cmoddivnode.create(divn,p1,p2);
_OP_NOT :
p1:=cnotnode.create(p1);
_OP_MOD :
begin
p1:=cmoddivnode.create(modn,p1,p2);
if m_iso in current_settings.modeswitches then
include(p1.flags,nf_isomod);
end;
_OP_SHL :
p1:=cshlshrnode.create(shln,p1,p2);
_OP_SHR :
p1:=cshlshrnode.create(shrn,p1,p2);
_OP_XOR :
p1:=caddnode.create(xorn,p1,p2);
_ASSIGNMENT :
p1:=cassignmentnode.create(p1,p2);
_NE :
p1:=caddnode.create(unequaln,p1,p2);
end;
p1.fileinfo:=filepos;
end
else
break;
until false;
sub_expr:=p1;
end;
function comp_expr(accept_equal,typeonly:boolean):tnode;
var
oldafterassignment : boolean;
p1 : tnode;
begin
oldafterassignment:=afterassignment;
afterassignment:=true;
p1:=sub_expr(opcompare,accept_equal,typeonly,nil);
{ get the resultdef for this expression }
if not assigned(p1.resultdef) then
do_typecheckpass(p1);
afterassignment:=oldafterassignment;
comp_expr:=p1;
end;
function expr(dotypecheck : boolean) : tnode;
var
p1,p2 : tnode;
filepos : tfileposinfo;
oldafterassignment,
updatefpos : boolean;
begin
oldafterassignment:=afterassignment;
p1:=sub_expr(opcompare,true,false,nil);
{ get the resultdef for this expression }
if not assigned(p1.resultdef) and
dotypecheck then
do_typecheckpass(p1);
filepos:=current_tokenpos;
if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
afterassignment:=true;
updatefpos:=true;
case token of
_POINTPOINT :
begin
consume(_POINTPOINT);
p2:=sub_expr(opcompare,true,false,nil);
p1:=crangenode.create(p1,p2);
end;
_ASSIGNMENT :
begin
consume(_ASSIGNMENT);
if assigned(p1.resultdef) and (p1.resultdef.typ=procvardef) then
getprocvardef:=tprocvardef(p1.resultdef);
p2:=sub_expr(opcompare,true,false,nil);
if assigned(getprocvardef) then
handle_procvar(getprocvardef,p2);
getprocvardef:=nil;
p1:=cassignmentnode.create(p1,p2);
end;
_PLUSASN :
begin
consume(_PLUSASN);
p2:=sub_expr(opcompare,true,false,nil);
p1:=gen_c_style_operator(addn,p1,p2);
end;
_MINUSASN :
begin
consume(_MINUSASN);
p2:=sub_expr(opcompare,true,false,nil);
p1:=gen_c_style_operator(subn,p1,p2);
end;
_STARASN :
begin
consume(_STARASN );
p2:=sub_expr(opcompare,true,false,nil);
p1:=gen_c_style_operator(muln,p1,p2);
end;
_SLASHASN :
begin
consume(_SLASHASN );
p2:=sub_expr(opcompare,true,false,nil);
p1:=gen_c_style_operator(slashn,p1,p2);
end;
else
updatefpos:=false;
end;
{ get the resultdef for this expression }
if not assigned(p1.resultdef) and
dotypecheck then
do_typecheckpass(p1);
afterassignment:=oldafterassignment;
if updatefpos then
p1.fileinfo:=filepos;
expr:=p1;
end;
function get_intconst:TConstExprInt;
{Reads an expression, tries to evalute it and check if it is an integer
constant. Then the constant is returned.}
var
p:tnode;
begin
result:=0;
p:=comp_expr(true,false);
if not codegenerror then
begin
if (p.nodetype<>ordconstn) or
not(is_integer(p.resultdef)) then
Message(parser_e_illegal_expression)
else
result:=tordconstnode(p).value;
end;
p.free;
end;
function get_stringconst:string;
{Reads an expression, tries to evaluate it and checks if it is a string
constant. Then the constant is returned.}
var
p:tnode;
begin
get_stringconst:='';
p:=comp_expr(true,false);
if p.nodetype<>stringconstn then
begin
if (p.nodetype=ordconstn) and is_char(p.resultdef) then
get_stringconst:=char(int64(tordconstnode(p).value))
else
Message(parser_e_illegal_expression);
end
else
get_stringconst:=strpas(tstringconstnode(p).value_str);
p.free;
end;
end.