Skip to content
Browse files

Initial revision

  • Loading branch information...
0 parents commit cf201eaa4a2d42e45873d2dc36f485603a0f3f04 andyv committed Sep 24, 2000
Showing with 19,312 additions and 0 deletions.
  1. +50 −0 BUGS
  2. +36 −0 CONTRIB
  3. +340 −0 COPYING
  4. +4 −0 MANIFEST
  5. +27 −0 Makefile
  6. +969 −0 arith.c
  7. +925 −0 array.c
  8. +1,867 −0 decl.c
  9. +593 −0 error.c
  10. +1,426 −0 expr.c
  11. +600 −0 format.c
  12. +1,209 −0 g95.h
  13. +605 −0 interface.c
  14. +1,680 −0 intrinsic.c
  15. +1,155 −0 io.c
  16. +2,456 −0 match.c
  17. +524 −0 matchexp.c
  18. +269 −0 misc.c
  19. +141 −0 module.c
  20. +1,916 −0 parse.c
  21. +1,500 −0 primary.c
  22. +747 −0 scanner.c
  23. +273 −0 select.c
Sorry, we could not display the entire diff because it was too big.
50 BUGS
@@ -0,0 +1,50 @@
+
+In a constant format string given to a data transfer statement, the
+locus of any problems in the string isn't guaranteed to come out
+right, because there is not a 1:1 correspondence between source
+characters and characters in the string. This scheme totally doesn't
+work for format strings that are longer than a physical line.
+
+Fix IMPLICIT to allow forward references of derived types.
+
+Add binary tree to SELECT statement to detect overlapping cases
+
+Add parsing of substrings
+
+Array issues in expressions and intrinsics
+
+USE statement
+ Writing a module's namespace to disk
+ Reading symbols into the current namespace
+ Renaming of symbols
+
+Resolve scoping issues
+
+ Create symbols in correct namespaces
+
+
+Pointer resolution
+
+Require intents to be done correctly
+
+Finish resolution phase
+
+Finish compiler side of intrinsic functions (Katherine)
+
+Allow init exprs to be numbers raised to integer powers (negative too)
+
+See about making emacs-parsable error messages.
+
+
+Biggies:
+--------
+Interface to code generator
+
+Runtime Library
+
+
+Known bugs:
+---------------------
+
+Failure to set the expr_locus field in g95_expr structures.
+
36 CONTRIB
@@ -0,0 +1,36 @@
+ Contributors to G95
+
+If I have left anyone out, please let me know.
+
+
+Major code contributors
+----------------------------------
+Katherine Holcomb
+Niels Kristian Bech Jensen
+Tobi Schlueter
+Andy Vaught
+
+
+
+Small patches (no copyright assignment)
+----------------------------------
+Steven Johnson
+Toon Moene
+
+
+
+Helpful comments
+----------------------------------
+Erik Schnetter
+
+
+
+Snide comments
+----------------------------------
+
+
+
+
+Dumb looks
+----------------------------------
+
340 COPYING
@@ -0,0 +1,340 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19yy name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
4 MANIFEST
@@ -0,0 +1,4 @@
+arith.c error.c expr.c intrinsic.c match.c parse.c scanner.c st.c symbol.c
+array.c misc.c decl.c interface.c select.c io.c format.c matchexp.c module.c
+primary.c g95.h
+CONTRIB COPYING MANIFEST BUGS Makefile doc
27 Makefile
@@ -0,0 +1,27 @@
+CC=gcc
+CFLAGS=-c -g -pedantic -Wall -pipe
+GMPDIR=gmp
+LDFLAGS=-g
+LIBS=-lgmp
+RM=rm -f
+
+EXE=g95
+
+OBJS=module.o matchexp.o format.o io.o scanner.o error.o parse.o expr.o \
+ primary.o symbol.o arith.o match.o st.o intrinsic.o array.o interface.o \
+ misc.o decl.o select.o
+
+%.o: %.c g95.h
+ $(CC) $(CFLAGS) -I$(GMPDIR) $<
+
+g95: $(OBJS)
+ $(CC) $(LDFLAGS) -o $@ $(OBJS) -L$(GMPDIR)/.libs $(LIBS)
+
+clean:
+ $(RM) $(EXE) *.o
+
+distclean: clean
+ $(RM) core *~ *.orig *.rej doc/*~
+
+package:
+ tar cvzf g95.tgz `cat MANIFEST`
969 arith.c
@@ -0,0 +1,969 @@
+/* Compiler arithmetic
+ Copyright (C) 2000 Free Software Foundation, Inc.
+ Contributed by Andy Vaught
+
+This file is part of GNU G95.
+
+GNU G95 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, or (at your option)
+any later version.
+
+GNU G95 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 GNU G95; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* arith.c-- Since target arithmetic must be done on the host, there
+ * has to be some way of evaluating arithmetic expressions as the host
+ * would evaluate them. We use the Gnu MP library to do arithmetic,
+ * and this file provides the interface. */
+
+#include "g95.h"
+#include <string.h>
+
+/* The g95_integer_kinds[] structure has everything the front end
+ * needs to know about integers on the target. The other members of
+ * the structure are calculated. The first entry is the default kind,
+ * the second entry of the real structure is the default double kind. */
+
+struct {
+ int kind;
+ char *max;
+ int range;
+ mpz_t maxval, minval; } g95_integer_kinds[] = {
+ { 4, "2147483647", 9 }, /* Default kind is first */
+ { 8, "9223372036854775807", 18 },
+ { 2, "32767", 4 },
+ { 1, "127", 2 },
+ { 0, NULL, 0 } };
+
+struct {
+ int kind;
+ char *max, *eps;
+ int precision, range; /* decimal digits, decimal exponent range */
+ mpf_t maxval, epsilon; } g95_real_kinds[] = {
+ /* max = 2**(128) - 2**(104), eps = 2**(-149) */
+ { 4, "3.40282346638528860e+38", "1.40129846432481707e-45", 6, 37 },
+ /* max = 2**(1024) - 2**(971), eps = 2**(-1074) */
+ { 8, "1.79769313486231571e+308", "4.94065645841246544e-324", 15, 307 },
+ { 0, NULL, NULL } };
+
+/* g95_arith_error()-- Given an arithmetic error code, return a
+ * pointer to a string that explains the error. */
+
+char *g95_arith_error(arith code) {
+char *p;
+
+ switch(code) {
+ case ARITH_OK: p = "Arithmetic OK"; break;
+ case ARITH_OVERFLOW: p = "Arithmetic overflow"; break;
+ case ARITH_UNDERFLOW: p = "Arithmetic underflow"; break;
+ case ARITH_DIV0: p = "Division by zero"; break;
+ case ARITH_0TO0: p = "Indeterminate form 0 ** 0"; break;
+ default: g95_internal_error("g95_arith_error(): Bad error code");
+ }
+
+ return p;
+}
+
+
+/* g95_arith_init_1()-- Get things ready to do math. */
+
+void g95_arith_init_1(void) {
+int i;
+
+/* Convert the minimum/maximum values for each kind into their Gnu MP
+ * representation. */
+
+ for(i=0; g95_integer_kinds[i].kind != 0; i++) {
+ mpz_init_set_str(g95_integer_kinds[i].maxval,
+ g95_integer_kinds[i].max, 10);
+
+ mpz_init(g95_integer_kinds[i].minval);
+ mpz_neg(g95_integer_kinds[i].minval, g95_integer_kinds[i].maxval);
+ }
+
+ mpf_set_default_prec(G95_REAL_BITS);
+
+ for(i=0; g95_real_kinds[i].kind != 0; i++) {
+ mpf_init_set_str(g95_real_kinds[i].maxval, g95_real_kinds[i].max, 10);
+ mpf_init_set_str(g95_real_kinds[i].epsilon, g95_real_kinds[i].eps, 10);
+ }
+}
+
+
+/* g95_default_*_kind()-- Return default kinds */
+
+int g95_default_integer_kind(void) { return g95_integer_kinds[0].kind; }
+
+int g95_default_real_kind(void) { return g95_real_kinds[0].kind; }
+
+int g95_default_double_kind(void) { return g95_real_kinds[1].kind; }
+
+int g95_default_character_kind(void) { return 1; }
+
+int g95_default_logical_kind(void) { return 4; }
+
+int g95_default_complex_kind(void) { return g95_default_real_kind(); }
+
+
+
+/* validate_integer()-- Make sure that a valid kind is present.
+ * Returns an index into the g95_integer_kinds array, -1 if the kind
+ * is not present. */
+
+static int validate_integer(int kind) {
+int i;
+
+ for(i=0;; i++) {
+ if (g95_integer_kinds[i].kind == 0) { i = -1; break; }
+ if (g95_integer_kinds[i].kind == kind) break;
+ }
+
+ return i;
+}
+
+
+static int validate_real(int kind) {
+int i;
+
+ for(i=0;; i++) {
+ if (g95_real_kinds[i].kind == 0) { i = -1; break; }
+ if (g95_real_kinds[i].kind == kind) break;
+ }
+
+ return i;
+}
+
+
+static int validate_logical(int kind) {
+
+ if (kind == 1) return 0;
+ return -1;
+}
+
+
+static int validate_character(int kind) {
+
+ if (kind == 1) return 0;
+ return -1;
+}
+
+
+/* g95_validate_kind()-- Validate a kind given a basic type. The
+ * return value is the same for the child functions, with -1
+ * indicating nonexistence of the type */
+
+int g95_validate_kind(bt type, int kind) {
+int rc;
+
+ switch(type) {
+ case BT_REAL: /* Fall through */
+ case BT_COMPLEX: rc = validate_real(kind); break;
+ case BT_INTEGER: rc = validate_integer(kind); break;
+ case BT_LOGICAL: rc = validate_logical(kind); break;
+ case BT_CHARACTER: rc = validate_character(kind); break;
+
+ default:
+ g95_internal_error("g95_validate_kind(): Got bad type");
+ }
+
+ return rc;
+}
+
+
+/* g95_check_integer_range()-- Given an integer and a kind, make sure
+ * that the integer lies within the range of the kind. Returns
+ * ARITH_OK or ARITH_OVERFLOW. */
+
+arith g95_check_integer_range(mpz_t p, int kind) {
+int i;
+
+ i = validate_integer(kind);
+ if (i == -1) g95_internal_error("g95_check_integer_range(): Bad kind");
+
+ if ((mpz_cmp(p, g95_integer_kinds[i].maxval) == 1) ||
+ (mpz_cmp(p, g95_integer_kinds[i].minval) == -1)) return ARITH_OVERFLOW;
+
+ return ARITH_OK;
+}
+
+
+/* g95_check_real_range()-- Given a real and a kind, make sure that
+ * the real lies within the range of the kind. Returns ARITH_OK,
+ * ARITH_OVERFLOW or ARITH_UNDERFLOW. */
+
+arith g95_check_real_range(mpf_t p, int kind) {
+arith retval;
+mpf_t q;
+int i;
+
+ mpf_init(q);
+
+ if (mpf_sgn(p) >= 0) mpf_set(q, p);
+ else mpf_neg(q, p);
+
+ i = validate_real(kind);
+ if (i == -1) g95_internal_error("g95_check_real_range(): Bad kind");
+
+ retval = ARITH_OK;
+ if (mpf_sgn(q) == 0) goto done;
+
+ if (mpf_cmp(q, g95_real_kinds[i].maxval) == 1) {
+ retval = ARITH_OVERFLOW;
+ goto done;
+ }
+
+ if (mpf_cmp(q, g95_real_kinds[i].epsilon) == -1) retval = ARITH_UNDERFLOW;
+
+done:
+ mpf_clear(q);
+
+ return retval;
+}
+
+
+
+/* Generic functions that call more specific ones based on the type. */
+
+arith g95_arith_uminus(g95_expr *op1, g95_expr *result) {
+arith rc;
+
+ switch(op1->ts.type) {
+ case BT_INTEGER:
+ mpz_init(result->value.integer);
+ mpz_neg(result->value.integer, op1->value.integer);
+ rc = ARITH_OK;
+ break;
+
+ case BT_REAL:
+ mpf_init(result->value.real);
+ mpf_neg(result->value.real, op1->value.real);
+ rc = ARITH_OK;
+ break;
+
+ case BT_COMPLEX:
+ mpf_init(result->value.complex.r);
+ mpf_neg(result->value.complex.r, op1->value.complex.r);
+
+ mpf_init(result->value.complex.i);
+ mpf_neg(result->value.complex.i, op1->value.complex.i);
+ break;
+
+ default:
+ g95_internal_error("g95_arith_uminus(): Bad basic type");
+ }
+
+ return rc;
+}
+
+
+arith g95_arith_plus(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+arith rc;
+
+ switch(op1->ts.type) {
+ case BT_INTEGER:
+ mpz_init(result->value.integer);
+ mpz_add(result->value.integer, op1->value.integer, op2->value.integer);
+ rc = g95_check_integer_range(result->value.integer, result->ts.kind);
+ break;
+
+ case BT_REAL:
+ mpf_init(result->value.real);
+ mpf_add(result->value.real, op1->value.real, op2->value.real);
+ rc = g95_check_real_range(result->value.real, result->ts.kind);
+ break;
+
+ case BT_COMPLEX:
+ mpf_init(result->value.complex.r);
+ mpf_init(result->value.complex.i);
+
+ mpf_add(result->value.complex.r, op1->value.complex.r,
+ op2->value.complex.r);
+
+ mpf_add(result->value.complex.i, op1->value.complex.i,
+ op2->value.complex.i);
+
+ rc = g95_check_real_range(result->value.complex.r, result->ts.kind);
+ if (rc == ARITH_OK)
+ rc = g95_check_real_range(result->value.complex.i, result->ts.kind);
+
+ break;
+
+ default:
+ g95_internal_error("g95_arith_plus(): Bad basic type");
+ }
+
+ return rc;
+}
+
+
+arith g95_arith_minus(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+arith rc;
+
+ switch(op1->ts.type) {
+ case BT_INTEGER:
+ mpz_init(result->value.integer);
+ mpz_sub(result->value.integer, op1->value.integer, op2->value.integer);
+ rc = g95_check_integer_range(result->value.integer, result->ts.kind);
+ break;
+
+ case BT_REAL:
+ mpf_init(result->value.real);
+ mpf_sub(result->value.real, op1->value.real, op2->value.real);
+ rc = g95_check_real_range(result->value.real, result->ts.kind);
+ break;
+
+ case BT_COMPLEX:
+ mpf_init(result->value.complex.r);
+ mpf_init(result->value.complex.i);
+
+ mpf_sub(result->value.complex.r, op1->value.complex.r,
+ op2->value.complex.r);
+
+ mpf_sub(result->value.complex.i, op1->value.complex.i,
+ op2->value.complex.i);
+
+ rc = g95_check_real_range(result->value.complex.r, result->ts.kind);
+ if (rc == ARITH_OK)
+ rc = g95_check_real_range(result->value.complex.i, result->ts.kind);
+
+ break;
+
+ default:
+ g95_internal_error("g95_arith_minus(): Bad basic type");
+ }
+
+ return rc;
+}
+
+
+arith g95_arith_times(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+mpf_t x, y;
+arith rc;
+
+ switch(op1->ts.type) {
+ case BT_INTEGER:
+ mpz_init(result->value.integer);
+ mpz_mul(result->value.integer, op1->value.integer, op2->value.integer);
+ rc = g95_check_integer_range(result->value.integer, result->ts.kind);
+ break;
+
+ case BT_REAL:
+ mpf_init(result->value.real);
+ mpf_mul(result->value.real, op1->value.real, op2->value.real);
+ rc = g95_check_real_range(result->value.real, result->ts.kind);
+ break;
+
+ case BT_COMPLEX:
+ mpf_init(result->value.complex.r);
+ mpf_init(result->value.complex.i);
+
+ mpf_init(x);
+ mpf_init(y);
+
+ mpf_mul(x, op1->value.complex.r, op2->value.complex.r);
+ mpf_mul(y, op1->value.complex.i, op2->value.complex.i);
+ mpf_sub(result->value.complex.r, x, y);
+
+ mpf_mul(x, op1->value.complex.r, op2->value.complex.i);
+ mpf_mul(y, op1->value.complex.i, op2->value.complex.r);
+ mpf_add(result->value.complex.i, x, y);
+
+ mpf_clear(x);
+ mpf_clear(y);
+
+ rc = g95_check_real_range(result->value.complex.r, result->ts.kind);
+ if (rc == ARITH_OK)
+ rc = g95_check_real_range(result->value.complex.i, result->ts.kind);
+
+ break;
+
+ default:
+ g95_internal_error("g95_arith_times(): Bad basic type");
+ }
+
+ return rc;
+}
+
+
+arith g95_arith_divide(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+mpf_t x, y, div;
+arith rc;
+
+ switch(op1->ts.type) {
+ case BT_INTEGER:
+ if (mpz_sgn(op2->value.integer) == 0) {
+ rc = ARITH_DIV0;
+ break;
+ }
+
+ mpz_init(result->value.integer);
+ mpz_tdiv_q(result->value.integer, op1->value.integer,
+ op2->value.integer);
+
+ rc = g95_check_integer_range(result->value.integer, result->ts.kind);
+ break;
+
+ case BT_REAL:
+ if (mpf_sgn(op2->value.real) == 0) {
+ rc = ARITH_DIV0;
+ break;
+ }
+
+ mpf_init(result->value.real);
+ mpf_div(result->value.real, op1->value.real, op2->value.real);
+ rc = g95_check_real_range(result->value.real, result->ts.kind);
+ break;
+
+ case BT_COMPLEX:
+ if (mpf_sgn(op2->value.complex.r) == 0 &&
+ mpf_sgn(op2->value.complex.i) == 0) {
+ rc = ARITH_DIV0;
+ break;
+ }
+
+ mpf_init(result->value.complex.r);
+ mpf_init(result->value.complex.i);
+
+ mpf_init(x);
+ mpf_init(y);
+ mpf_init(div);
+
+ mpf_mul(x, op2->value.complex.r, op2->value.complex.r);
+ mpf_mul(y, op2->value.complex.i, op2->value.complex.i);
+ mpf_add(div, x, y);
+
+ mpf_mul(x, op1->value.complex.r, op2->value.complex.r);
+ mpf_mul(y, op1->value.complex.i, op2->value.complex.i);
+ mpf_add(result->value.complex.r, x, y);
+ mpf_div(result->value.complex.r, result->value.complex.r, div);
+
+ mpf_mul(x, op1->value.complex.i, op2->value.complex.r);
+ mpf_mul(y, op1->value.complex.r, op2->value.complex.i);
+ mpf_sub(result->value.complex.r, x, y);
+ mpf_div(result->value.complex.r, result->value.complex.r, div);
+
+ mpf_clear(x);
+ mpf_clear(y);
+ mpf_clear(div);
+
+ break;
+
+ default:
+ g95_internal_error("g95_arith_divide(): Bad basic type");
+ }
+
+ return rc;
+}
+
+
+/* g95_arith_power()-- Raise a number to an integer power */
+
+arith g95_arith_power(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+//g95_expr *prod;
+int ipower;
+arith rc;
+
+ rc = ARITH_OK;
+
+#if 0
+ if (g95_extract_int(op2, &power) != NULL) return ARITH0TO0; /* Fix */
+
+ if (prod == 0) {
+ }
+
+ prod = g95_copy_expr(op1);
+
+ if (prod > 0) {
+ }
+#endif
+
+ switch(mpz_sgn(op2->value.integer)) {
+ case -1:
+ mpz_init_set_ui(result->value.integer, 0);
+ break;
+
+ case 0:
+ if (mpz_sgn(op1->value.integer) == 0) rc = ARITH_0TO0;
+ break;
+
+ case 1: /* Doesn't handle a**b for 0<=a<=1 and b > 100000 correctly */
+ if (mpz_cmp_si(op2->value.integer, 100000) == 1)
+ rc = ARITH_OVERFLOW;
+ else {
+ ipower = mpz_get_si(op2->value.integer);
+ mpz_init(result->value.integer);
+ mpz_pow_ui(result->value.integer, op1->value.integer, ipower);
+ rc = g95_check_integer_range(result->value.integer, result->ts.kind);
+ }
+
+ break;
+ }
+
+ return rc;
+}
+
+
+/* g95_arith_concat()-- Concatenate two string constants */
+
+arith g95_arith_concat(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+int len;
+
+ len = op1->value.character.length + op2->value.character.length;
+
+ result->value.character.string = g95_getmem(len+1);
+ result->value.character.length = len;
+
+ memcpy(result->value.character.string, op1->value.character.string,
+ op1->value.character.length);
+
+ memcpy(result->value.character.string + op1->value.character.length,
+ op2->value.character.string, op2->value.character.length);
+
+ result->value.character.string[len] = '\0';
+
+ return ARITH_OK;
+}
+
+
+
+/* g95_compare_expr()-- Comparison operators. Assumes that the two
+ * expression nodes contain two constants of the same type. */
+
+int g95_compare_expr(g95_expr *op1, g95_expr *op2) {
+int rc;
+
+ switch(op1->ts.type) {
+ case BT_INTEGER:
+ rc = mpz_cmp(op1->value.integer, op2->value.integer);
+ break;
+
+ case BT_REAL:
+ rc = mpf_cmp(op1->value.real, op2->value.real);
+ break;
+
+ default: g95_internal_error("g95_compare_expr(): Bad basic type");
+ }
+
+ return rc;
+}
+
+
+/* compare_complex()-- Compare a pair of complex numbers. Naturally,
+ * this is only for equality/nonequality. */
+
+static int compare_complex(g95_expr *op1, g95_expr *op2) {
+
+ return (mpf_cmp(op1->value.complex.r, op2->value.complex.r) == 0 &&
+ mpf_cmp(op1->value.complex.i, op2->value.complex.i) == 0);
+}
+
+
+/* Specific comparison subroutines */
+
+void g95_arith_eq(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+
+ result->value.logical = (op1->ts.type == BT_COMPLEX) ?
+ compare_complex(op1, op2) : (g95_compare_expr(op1, op2) == 0);
+}
+
+
+void g95_arith_ne(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+
+ result->value.logical = (op1->ts.type == BT_COMPLEX) ?
+ !compare_complex(op1, op2) : (g95_compare_expr(op1, op2) != 0);
+}
+
+
+void g95_arith_gt(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+
+ result->value.logical = (g95_compare_expr(op1, op2) > 0);
+}
+
+
+void g95_arith_ge(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+
+ result->value.logical = (g95_compare_expr(op1, op2) >= 0);
+}
+
+
+void g95_arith_lt(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+
+ result->value.logical = (g95_compare_expr(op1, op2) < 0);
+}
+
+
+void g95_arith_le(g95_expr *op1, g95_expr *op2, g95_expr *result) {
+
+ result->value.logical = (g95_compare_expr(op1, op2) <= 0);
+}
+
+
+/* g95_convert_integer()-- Convert an integer string to an expression
+ * node */
+
+g95_expr *g95_convert_integer(char *buffer, int kind, int radix) {
+g95_expr *e;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->rank = 0;
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = kind;
+
+ mpz_init_set_str(e->value.integer, buffer, radix);
+
+ return e;
+}
+
+
+/* g95_convert_real()-- Convert a real string to an expression node. */
+
+g95_expr *g95_convert_real(char *buffer, int kind) {
+g95_expr *e;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->rank = 0;
+ e->ts.type = BT_REAL;
+ e->ts.kind = kind;
+
+ mpf_init_set_str(e->value.real, buffer, 10);
+
+ return e;
+}
+
+
+/* g95_convert_complex()-- Convert a pair of real, constant expression
+ * nodes to a single complex expression node. */
+
+g95_expr *g95_convert_complex(g95_expr *real, g95_expr *imag, int kind) {
+g95_expr *e;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->rank = 0;
+ e->ts.type = BT_COMPLEX;
+ e->ts.kind = kind;
+
+ mpf_init_set(e->value.complex.r, real->value.real);
+ mpf_init_set(e->value.complex.i, imag->value.real);
+
+ return e;
+}
+
+
+/******* Simplification of intrinsic functions with constant arguments *****/
+
+/* g95_int2real()-- Convert default integer to default real */
+
+arith g95_int2real(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+arith rv;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_REAL;
+ e->ts.kind = g95_default_real_kind();
+
+ mpf_init(e->value.real);
+ mpf_set_z(e->value.real, src->value.integer);
+
+ rv = g95_check_real_range(e->value.real, e->ts.kind);
+
+ if (rv == ARITH_OK)
+ *dest = e;
+ else {
+ g95_error("Overflow converting INTEGER to REAL at %L", e->where);
+ g95_free_expr(e);
+ }
+
+ return rv;
+}
+
+
+/* g95_int2complex()-- Convert default integer to default complex */
+
+arith g95_int2complex(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+arith rv;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_COMPLEX;
+ e->ts.kind = g95_default_complex_kind();
+
+ mpf_init(e->value.real);
+ mpf_set_z(e->value.complex.r, src->value.integer);
+ mpf_init_set_ui(e->value.complex.i, 0L);
+
+ rv = g95_check_real_range(e->value.complex.i, e->ts.kind);
+
+ if (rv == ARITH_OK)
+ *dest = e;
+ else {
+ g95_error("Overflow converting INTEGER to COMPLEX at %L", e->where);
+ g95_free_expr(e);
+ }
+
+ return rv;
+}
+
+
+/* g95_real2int()-- Convert default real to default integer */
+
+arith g95_real2int(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+arith rv;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = g95_default_integer_kind();
+
+ mpz_init(e->value.integer);
+ mpz_set_f(e->value.integer, src->value.real);
+
+ rv = g95_check_integer_range(e->value.integer, e->ts.kind);
+
+ if (rv == ARITH_OK)
+ *dest = e;
+ else {
+ g95_error("Overflow converting REAL to INTEGER at %L", e->where);
+ g95_free_expr(e);
+ }
+
+ return rv;
+}
+
+
+/* g95_real2complex()-- Convert default real to default complex.
+ * Because complex components are real numbers, this can't fail. */
+
+arith g95_real2complex(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_COMPLEX;
+ e->ts.kind = g95_default_complex_kind();
+
+ mpf_init(e->value.real);
+ mpf_init_set(e->value.complex.r, src->value.real);
+ mpf_init_set_ui(e->value.complex.i, 0);
+
+ *dest = e;
+ return ARITH_OK;
+}
+
+
+/* g95_complex2int()-- Convert default complex to default integer */
+
+arith g95_complex2int(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+arith rv;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = g95_default_integer_kind();
+
+ mpz_init(e->value.integer);
+ mpz_set_f(e->value.integer, src->value.complex.r);
+
+ rv = g95_check_integer_range(e->value.integer, e->ts.kind);
+
+ if (rv == ARITH_OK)
+ *dest = e;
+ else {
+ g95_error("Overflow converting COMPLEX to INTEGER at %L", e->where);
+ g95_free_expr(e);
+ }
+
+ return rv;
+}
+
+
+/* g95_complex2real()-- Convert default complex to default real.
+ * Because complex components are real numbers, this can't fail. */
+
+arith g95_complex2real(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_REAL;
+ e->ts.kind = g95_default_real_kind();
+
+ mpf_init_set(e->value.real, src->value.complex.r);
+
+ *dest = e;
+ return ARITH_OK;
+}
+
+
+/* g95_double2real()-- Convert the double kind to default real kind */
+
+arith g95_double2real(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+arith rv;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_REAL;
+ e->ts.kind = g95_default_real_kind();
+
+ mpf_init_set(e->value.real, src->value.real);
+
+ rv = g95_check_real_range(e->value.real, e->ts.kind);
+
+ if (rv == ARITH_OK)
+ *dest = e;
+ else {
+ g95_error("Overflow converting DOUBLE to REAL at %L", e->where);
+ g95_free_expr(e);
+ }
+
+ return rv;
+}
+
+
+/* g95_real2double()-- Convert the double kind to default real kind */
+
+arith g95_real2double(g95_expr **dest, g95_expr *src) {
+g95_expr *e;
+
+ e = g95_get_expr();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->where = src->where;
+
+ e->ts.type = BT_REAL;
+ e->ts.kind = g95_default_real_kind();
+
+ mpf_init_set(e->value.real, src->value.real);
+
+ return ARITH_OK;
+}
+
+
+#define FIRST_ARG(e) (e->value.function.actual->expr)
+#define SECOND_ARG(e) (e->value.function.actual->next->expr)
+
+try g95_simplify_selected_int_kind(g95_expr *e) {
+int i, kind, range;
+g95_expr *arg;
+
+ arg = FIRST_ARG(e);
+
+ if (arg->expr_type != EXPR_CONSTANT) return FAILURE;
+
+ if (g95_extract_int(arg, &range) != NULL) return FAILURE;
+
+ kind = INT_MAX;
+ for (i=0; g95_integer_kinds[i].kind!=0; i++) {
+ if (g95_integer_kinds[i].range >= range &&
+ g95_integer_kinds[i].kind < kind) {
+ kind = g95_integer_kinds[i].kind;
+ }
+ }
+
+ if (kind == INT_MAX) {
+ kind = -1;
+ g95_warning("Range %d exceeds all integer kinds at %L",
+ range, &arg->where);
+ }
+
+ g95_replace_expr(e, g95_constant_expr(BT_INTEGER, kind, NULL));
+ return SUCCESS;
+}
+
+
+try g95_simplify_selected_real_kind(g95_expr *e) {
+int range, precision, i, kind, foundprecision, foundrange;
+g95_expr *arg1, *arg2;
+
+ arg1 = FIRST_ARG(e);
+ arg2 = SECOND_ARG(e);
+
+ if (arg1 == NULL && arg2 == NULL)
+ g95_internal_error("SELECTED_REAL_KIND without argument at %L should not "
+ "go through g95_simplify_selected_real_kind",
+ &e->where);
+
+ if (arg1 != NULL) {
+ if (arg1->expr_type != EXPR_CONSTANT) return FAILURE;
+ precision = mpz_get_si(arg1->value.integer);
+ } else
+ precision = 0;
+
+ if (arg2 != NULL) {
+ if (arg2->expr_type != EXPR_CONSTANT) return FAILURE;
+ range = mpz_get_si(arg2->value.integer);
+ } else
+ range = 0;
+
+ kind = INT_MAX;
+ foundprecision = 0;
+ foundrange = 0;
+
+ for (i=0; g95_real_kinds[i].kind!=0; i++) {
+ if (g95_real_kinds[i].precision >= precision)
+ foundprecision = 1;
+ if (g95_real_kinds[i].range >= range)
+ foundrange = 1;
+ if (g95_real_kinds[i].precision >= precision &&
+ g95_real_kinds[i].range >= range &&
+ g95_real_kinds[i].kind < kind)
+ kind = g95_real_kinds[i].kind;
+ }
+
+ if (kind == INT_MAX) {
+ kind = 0;
+ if (!foundprecision) {
+ g95_warning("Specified precision %d exceeds all REAL kinds at %L",
+ precision, &arg1->where);
+ kind = -1;
+ }
+
+ if (!foundrange) {
+ g95_warning("Specified exponent range %d exceeds all REAL kinds at %L",
+ range, &arg2->where);
+ kind -= 2;
+ }
+ }
+
+ g95_replace_expr(e, g95_constant_expr(BT_INTEGER, kind, NULL));
+ return SUCCESS;
+}
925 array.c
@@ -0,0 +1,925 @@
+/* Array things
+ Copyright (C) 2000 Free Software Foundation, Inc.
+ Contributed by Andy Vaught
+
+This file is part of GNU G95.
+
+GNU G95 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, or (at your option)
+any later version.
+
+GNU G95 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 GNU G95; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+#include "g95.h"
+
+/**************** Array reference matching subroutines *****************/
+
+/* g95_free_array_ref()-- Free an array reference structure and
+ * everything it points to. */
+
+void g95_free_array_ref(g95_array_ref *ar) {
+int i;
+
+ for(i=0; i<G95_MAX_DIMENSIONS; i++) {
+ g95_free_expr(ar->shape[i].start);
+ g95_free_expr(ar->shape[i].end);
+ g95_free_expr(ar->shape[i].stride);
+ }
+
+ g95_free(ar);
+}
+
+
+/* g95_copy_array_ref()-- Copy an array reference structure */
+
+g95_array_ref *g95_copy_array_ref(g95_array_ref *src) {
+g95_array_ref *dest;
+int i;
+
+ dest = g95_get_array_ref();
+
+ dest->type = src->type;
+ dest->rank = src->rank;
+
+ for(i=0; i<G95_MAX_DIMENSIONS; i++) {
+ dest->shape[i].start = g95_copy_expr(src->shape[i].start);
+ dest->shape[i].end = g95_copy_expr(src->shape[i].end);
+ dest->shape[i].stride = g95_copy_expr(src->shape[i].stride);
+ }
+
+ dest->offset = g95_copy_expr(src->offset);
+
+ return dest;
+}
+
+
+/* g95_show_array_ref()-- Show an array reference */
+
+void g95_show_array_ref(g95_array_ref *ar) {
+int i;
+
+ g95_status_char('(');
+
+ switch(ar->type) {
+ case AR_FULL:
+ g95_status("FULL");
+ break;
+
+ case AR_SECTION:
+ for(i=0; i<ar->rank; i++) {
+ if (ar->shape[i].start != NULL)
+ g95_show_expr(ar->shape[i].start);
+
+ g95_status_char(':');
+
+ if (ar->shape[i].end != NULL)
+ g95_show_expr(ar->shape[i].end);
+
+ if (ar->shape[i].stride != NULL) {
+ g95_status_char(':');
+ g95_show_expr(ar->shape[i].stride);
+ }
+
+ if (i != ar->rank-1) g95_status(" , ");
+ }
+ break;
+
+ case AR_ELEMENT:
+ for(i=0; i<ar->rank; i++) {
+ g95_show_expr(ar->shape[i].start);
+ if (i != ar->rank - 1) g95_status(" , ");
+ }
+ break;
+
+ default: g95_internal_error("g95_show_array_ref(): Unknown array reference");
+ }
+
+ g95_status_char(')');
+}
+
+
+
+/* check_dimension()-- Compare a single dimension of array reference
+ * to array specification. */
+
+static try check_dimension(int i, g95_array_ref *ar, g95_array_spec *as) {
+int start_v, end_v, stride_v, lower_v, upper_v, start, end, stride,
+ lower, upper;
+g95_expr *e;
+
+ lower = as->shape[i].lower != NULL &&
+ as->shape[i].lower->expr_type == EXPR_CONSTANT;
+
+ upper = as->shape[i].upper != NULL &&
+ (((i+1 == as->rank && as->type == AS_ASSUMED_SIZE)) ? 0
+ : as->shape[i].upper->expr_type == EXPR_CONSTANT);
+
+ e = ar->shape[i].start;
+ start = (e != NULL) && (e->expr_type == EXPR_CONSTANT);
+
+ e = ar->shape[i].end;
+ end = (e != NULL) && (e->expr_type == EXPR_CONSTANT);
+
+ e = ar->shape[i].stride;
+ stride = (e != NULL) && (e->expr_type == EXPR_CONSTANT);
+
+ if (lower && g95_extract_int(as->shape[i].lower, &lower_v) != NULL)
+ goto oops;
+
+ if (upper && g95_extract_int(as->shape[i].upper, &upper_v) != NULL)
+ goto oops;
+
+ if (start && g95_extract_int(ar->shape[i].start, &start_v) != NULL)
+ goto oops;
+
+ if (end && g95_extract_int(ar->shape[i].end, &end_v) != NULL) goto oops;
+
+ if (stride && g95_extract_int(ar->shape[i].stride, &stride_v) != NULL)
+ goto oops;
+
+/* Given start, end and stride values, calculate the minimum and
+ * maximum referenced indexes. */
+
+ switch(ar->type) {
+ case AR_FULL:
+ break;
+
+ case AR_ELEMENT:
+ if (lower && start && start_v < lower_v) goto bound;
+ if (upper && start && start_v > upper_v) goto bound;
+ break;
+
+ case AR_SECTION:
+ if (stride && stride_v == 0) {
+ g95_error("Illegal stride of zero at %L", &ar->shape[i].where);
+ return FAILURE;
+ }
+
+ break;
+ }
+
+ return SUCCESS;
+
+bound:
+ g95_warning("Array reference at %L is out of bounds", &ar->shape[i].where);
+ return FAILURE;
+
+oops:
+ g95_internal_error("match_subscript(): Bad integer conversion");
+ return FAILURE;
+}
+
+
+/* compare_spec_to_ref()-- Compare an array reference with an
+ * array specification. */
+
+try compare_spec_to_ref(g95_array_ref *ar, g95_array_spec *as) {
+try t;
+int i;
+
+ if (as->rank != ar->rank) {
+ g95_error("Array reference at %L is of rank %d but specified as rank %d",
+ &ar->where, ar->rank, as->rank);
+ return FAILURE;
+ }
+
+ t = SUCCESS;
+
+ for(i=0; i<as->rank; i++)
+ if (check_dimension(i, ar, as) == FAILURE) {
+ t = FAILURE;
+ break;
+ }
+
+ return t;
+}
+
+
+/* match_subscript()-- Match a single dimension of an array reference.
+ * This can be a single element or an array section. Any
+ * modifications we've made to the ar structure are cleaned up by the
+ * caller. */
+
+static match match_subscript(g95_array_ref *ar) {
+g95_expr *e;
+match m;
+int i;
+
+ i = ar->rank;
+
+ ar->shape[i].where = *g95_current_locus();
+ ar->shape[i].start = ar->shape[i].end = ar->shape[i].stride = NULL;
+
+ if (g95_match(" :") == MATCH_YES) goto end_element;
+
+ /* Get start element */
+
+ m = g95_match(" %E", &ar->shape[i].start);
+ if (m == MATCH_NO) g95_error("Expected array subscript at %C");
+ if (m != MATCH_YES) return MATCH_ERROR;
+
+ e = ar->shape[i].start;
+ if (e->ar != NULL) {
+ if (e->ar->rank != 1) {
+ g95_error("Vector subscript at %C must have rank of one");
+ return MATCH_ERROR;
+ }
+
+ ar->type = AR_SECTION;
+ return MATCH_YES;
+ }
+
+ if (g95_match(" :") == MATCH_NO) goto done;
+
+/* Get an optional end element */
+
+end_element:
+ ar->type = AR_SECTION;
+
+ m = g95_match(" %e", &ar->shape[i].end);
+ if (m == MATCH_ERROR) return MATCH_ERROR;
+
+// Build UBOUND expression
+
+/* See if we have an optional stride */
+
+ if (g95_match(" :") == MATCH_NO)
+ ar->shape[i].stride = g95_constant_expr(BT_INTEGER, 1, NULL);
+ else {
+ m = g95_match(" %e", &ar->shape[i].stride);
+ if (m == MATCH_NO) g95_error("Expected array subscript stride at %C");
+ if (m != MATCH_YES) return MATCH_ERROR;
+ }
+
+done:
+ return MATCH_YES;
+}
+
+
+/* g95_match_array_ref()-- Match an array reference, whether it is the
+ * whole array or a particular elements or a section. */
+
+match g95_match_array_ref(g95_array_ref *ar) {
+match m;
+
+ ar->where = *g95_current_locus();
+
+ if (g95_match(" (") != MATCH_YES) {
+ ar->type = AR_FULL;
+ return MATCH_YES;
+ }
+
+/* The type gets changed by match_subscript() if it finds a section
+ * reference */
+
+ ar->type = AR_ELEMENT;
+
+ for(ar->rank=0; ar->rank<G95_MAX_DIMENSIONS; ar->rank++) {
+ m = match_subscript(ar);
+ if (m == MATCH_ERROR) goto error;
+
+ if (g95_match(" )") == MATCH_YES) goto matched;
+
+ if (g95_match(" ,") != MATCH_YES) {
+ g95_error("Invalid form of array reference at %C");
+ goto error;
+ }
+ }
+
+ g95_error("Array reference at %C cannot have more than "
+ stringize(G95_MAX_DIMENSIONS) " dimensions");
+
+error:
+ return MATCH_ERROR;
+
+matched:
+ ar->rank++;
+
+ return MATCH_YES;
+}
+
+
+
+/* resolve_index()-- Resolve a single array index */
+
+static try resolve_index(g95_expr *index) {
+
+ if (g95_resolve_expr(index) == FAILURE) return FAILURE;
+
+ if (index != NULL && index->ts.type != BT_INTEGER) {
+ g95_error("Array index at %C must of type INTEGER", &index->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* g95_resolve_array_ref()-- Resolve an array reference */
+
+try g95_resolve_array_ref(g95_array_ref *ar, g95_array_spec *as) {
+try t;
+int i;
+
+ t = SUCCESS;
+ for(i=0; i<G95_MAX_DIMENSIONS; i++) {
+ if (resolve_index(ar->shape[i].start) == FAILURE) t = FAILURE;
+ if (resolve_index(ar->shape[i].end) == FAILURE) t = FAILURE;
+ if (resolve_index(ar->shape[i].stride) == FAILURE) t = FAILURE;
+ }
+
+ if (compare_spec_to_ref(ar, as) == FAILURE) t = FAILURE;
+
+ return t;
+}
+
+
+/************** Array specification matching subroutines ***************/
+
+/* g95_free_array_spec()-- Free all of the expressions associated with
+ * array bounds specifications */
+
+void g95_free_array_spec(g95_array_spec *a) {
+int i;
+
+ for(i=0; i<a->rank; i++) {
+ g95_free_expr(a->shape[i].lower);
+ g95_free_expr(a->shape[i].upper);
+
+ a->shape[i].lower = NULL;
+ a->shape[i].upper = NULL;
+ }
+
+ a->rank = 0;
+}
+
+
+/* g95_resolve_array_spec()-- Takes an array specification, resolves
+ * the expressions that make up the shape and make sure everything is
+ * integral. */
+
+void g95_resolve_array_spec(g95_array_spec *as) {
+g95_expr *e;
+int i;
+
+ for(i=0; i<as->rank; i++) {
+ e = as->shape[i].lower;
+
+ if (e != NULL) {
+ g95_resolve_expr(e);
+ if (e->ts.type != BT_INTEGER)
+ g95_error("Array specification at %L must be of INTEGER type",
+ &e->where);
+ }
+
+ e = as->shape[i].upper;
+
+ if (e != NULL) {
+ g95_resolve_expr(e);
+ if (e->ts.type != BT_INTEGER)
+ g95_error("Array specification at %L must be of INTEGER type",
+ &e->where);
+ }
+ }
+}
+
+
+/* match_array_element_spec()-- Match a single array element
+ * specification. The return values as well as the upper and lower
+ * bounds of the array spec are filled in according to what we see on
+ * the input. The caller makes sure individual specifications make
+ * sense as a whole.
+ *
+ * Parsed Lower Upper Returned
+ * ------------------------------------
+ * : NULL NULL AS_DEFERRED
+ * x 1 x AS_EXPLICIT
+ * x: x NULL AS_ASSUMED_SHAPE
+ * x:y x y AS_EXPLICIT
+ * x:* x NULL AS_ASSUMED_SIZE
+ * * 1 NULL AS_ASSUMED_SIZE
+ * Anything else AS_UNKNOWN */
+
+static array_type match_array_element_spec(g95_array_spec *as) {
+g95_expr **upper, **lower;
+match m;
+
+ lower = &as->shape[as->rank - 1].lower;
+ upper = &as->shape[as->rank - 1].upper;
+
+ if (g95_match(" *") == MATCH_YES) {
+ *lower = g95_constant_expr(BT_INTEGER, 1, NULL);
+ return AS_ASSUMED_SIZE;
+ }
+
+ if (g95_match(" :") == MATCH_YES) return AS_DEFERRED;
+
+ m = g95_match(" %e", upper);
+ if (m == MATCH_NO) g95_error("Expected expression in array "
+ "specification at %C");
+ if (m != MATCH_YES) return AS_UNKNOWN;
+
+ if (g95_match(" :") == MATCH_NO) {
+ *lower = g95_constant_expr(BT_INTEGER, 1, NULL);
+ return AS_EXPLICIT;
+ }
+
+ *lower = *upper;
+ *upper = NULL;
+
+ if (g95_match(" *") == MATCH_YES) return AS_ASSUMED_SIZE;
+
+ m = g95_match(" %e", upper);
+ if (m == MATCH_ERROR) {
+ g95_free_expr(*lower);
+ return AS_UNKNOWN;
+ }
+
+ if (m == MATCH_NO) return AS_ASSUMED_SIZE;
+
+ return AS_EXPLICIT;
+}
+
+
+/* g95_match_array_spec()-- Matches an array specification,
+ * incidentally figuring out what sort it is. */
+
+match g95_match_array_spec(g95_array_spec *as) {
+array_type current_type;
+int i;
+
+ if (g95_match(" (") != MATCH_YES) return MATCH_NO;
+
+ for(i=0; i<G95_MAX_DIMENSIONS; i++) {
+ as->shape[i].lower = NULL;
+ as->shape[i].upper = NULL;
+ }
+
+ as->rank = 1;
+
+ for(;;) {
+ current_type = match_array_element_spec(as);
+
+ if (as->rank == 1) {
+ if (current_type == AS_UNKNOWN) goto cleanup;
+ as->type = current_type;
+ } else
+ switch(as->type) { /* See how current spec meshes with the existing */
+ case AS_UNKNOWN:
+ goto cleanup;
+
+ case AS_EXPLICIT:
+ if (current_type == AS_ASSUMED_SIZE) {
+ as->type = AS_ASSUMED_SIZE;
+ break;
+ }
+
+ if (current_type == AS_EXPLICIT) break;
+
+ g95_error("Bad array specification for an explicitly shaped array"
+ " at %C");
+
+ goto cleanup;
+
+ case AS_ASSUMED_SHAPE:
+ if ((current_type == AS_ASSUMED_SHAPE) ||
+ (current_type == AS_DEFERRED)) break;
+
+ g95_error("Bad array specification for assumed shape array at %C");
+ goto cleanup;
+
+ case AS_DEFERRED:
+ if (current_type == AS_DEFERRED) break;
+
+ if (current_type == AS_ASSUMED_SHAPE) {
+ as->type = AS_ASSUMED_SHAPE;
+ break;
+ }
+
+ g95_error("Bad specification for deferred shape array at %C");
+ goto cleanup;
+
+ case AS_ASSUMED_SIZE:
+ g95_error("Bad specification for assumed size array at %C");
+ goto cleanup;
+ }
+
+ if (g95_match(" )") == MATCH_YES) break;
+
+ if (g95_match(" ,") != MATCH_YES) {
+ g95_error("Expected another dimension in array declaration at %C");
+ goto cleanup;
+ }
+
+ if (as->rank == G95_MAX_DIMENSIONS) {
+ g95_error("Array specification at %C has more than "
+ stringize(G95_MAX_DIMENSIONS) " dimensions");
+ goto cleanup;
+ }
+
+ as->rank++;
+ }
+
+/* If a lower bounds of an assumed shape array is blank, put in one. */
+
+ if (as->type == AS_ASSUMED_SHAPE) {
+ for(i=0; i<as->rank; i++) {
+ if (as->shape[i].lower == NULL)
+ as->shape[i].lower = g95_constant_expr(BT_INTEGER, 1, NULL);
+ }
+ }
+
+ return MATCH_YES;
+
+/* Something went wrong */
+
+cleanup:
+ g95_free_array_spec(as);
+ return MATCH_ERROR;
+}
+
+
+
+/* g95_set_array_spec()-- Given a symbol and an array specification,
+ * modify the symbol to have array specification. The error locus is
+ * needed in case something goes wrong. The array specification is
+ * copied verbatim. On failure, the caller must free the spec. */
+
+try g95_set_array_spec(g95_symbol *sym, g95_array_spec *as, locus *error_loc) {
+int i;
+
+ if (as->rank == 0) return SUCCESS;
+
+ if (g95_add_dimension(&sym->attr, error_loc) == FAILURE) return FAILURE;
+
+ if (as->type == AS_ASSUMED_SIZE && sym->attr.dummy == 0) {
+ g95_error("Assumed size array at %L must be a dummy argument", error_loc);
+ return FAILURE;
+ }
+
+ sym->as = *as;
+
+/* Clear the original array spec so that freeing it doesn't cause problems */
+
+ as->rank = 0;
+ as->type = AS_UNKNOWN;
+
+ for(i=0; i<G95_MAX_DIMENSIONS; i++) {
+ as->shape[i].lower = NULL;
+ as->shape[i].upper = NULL;
+ }
+
+ return SUCCESS;
+}
+
+
+/* copy_array_spec()-- Copy an array specification. */
+
+void g95_copy_array_spec(g95_array_spec *dest, g95_array_spec *src) {
+int i;
+
+ *dest = *src;
+
+ for(i=0; i<dest->rank; i++) {
+ dest->shape[i].lower = g95_copy_expr(dest->shape[i].lower);
+ dest->shape[i].upper = g95_copy_expr(dest->shape[i].upper);
+ }
+}
+
+
+
+static mstring array_specs[] = {
+ minit("AS_EXPLICIT", AS_EXPLICIT),
+ minit("AS_ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
+ minit("AS_DEFERRED", AS_DEFERRED),
+ minit("AS_ASSUMED_SIZE", AS_ASSUMED_SIZE),
+ minit(NULL, 0) };
+
+void g95_show_array_spec(g95_array_spec *as) {
+int i;
+
+ g95_status("(%d", as->rank);
+
+ if (as->rank != 0) {
+ g95_status(" %s ", g95_code2string(array_specs, as->type));
+
+ for(i=0; i<2*as->rank; i++) {
+ g95_show_expr(as->shape[i].lower);
+ g95_status_char(' ');
+ g95_show_expr(as->shape[i].upper);
+ }
+ }
+
+ g95_status(")");
+}
+
+
+/* g95_compare_array_spec()-- Does what it says. MATCH_ERROR is never
+ * returned. */
+
+match g95_compare_array_spec(g95_array_spec *as1, g95_array_spec *as2) {
+int i, a1, a2;
+
+ if (as1->rank != as2->rank) return MATCH_NO;
+
+ if (as1->rank == 0) return MATCH_YES;
+
+ if (as1->type != as2->type) return MATCH_NO;
+
+ if (as1->type == AS_EXPLICIT)
+ for(i=0; i<as1->rank; i++) {
+ if (g95_extract_int(as1->shape[i].lower, &a1) != NULL) goto error;
+ if (g95_extract_int(as2->shape[i].lower, &a2) != NULL) goto error;
+ if (a1 != a2) return MATCH_NO;
+
+ if (g95_extract_int(as1->shape[i].upper, &a1) != NULL) goto error;
+ if (g95_extract_int(as2->shape[i].upper, &a2) != NULL) goto error;
+ if (a1 != a2) return MATCH_NO;
+ }
+
+ return MATCH_YES;
+
+error:
+ g95_internal_error("g95_compare_type(): Array spec clobbered");
+ return MATCH_ERROR; /* Keep the compiler happy */
+}
+
+
+/* g95_free_constructor()-- Free a chains of g95_constructor structures */
+
+void g95_free_constructor(g95_constructor *p) {
+g95_constructor *next;
+
+ if (p == NULL) return;
+
+ for(;p ;p=next) {
+ next = p->next;
+
+ g95_free_constructor(p->child);
+ g95_free_expr(p->expr);
+ if (p->iter != NULL) g95_free_iterator(p->iter, 1);
+ g95_free(p);
+ }
+}
+
+
+/* match_array_list()-- Match a list of array elements. */
+
+static match match_array_cons_element(g95_constructor **);
+
+static match match_array_list(g95_constructor **result) {
+g95_constructor *p, *head, *tail, *new;
+g95_iterator iter;
+locus old_loc;
+match m;
+
+ old_loc = *g95_current_locus();
+
+ if (g95_match(" (") == MATCH_NO) return MATCH_NO;
+
+ memset(&iter, '\0', sizeof(g95_iterator));
+
+ m = match_array_cons_element(&head);
+ if (m != MATCH_YES) return m;
+
+ tail = head;
+
+ if (g95_match(" ,") != MATCH_YES) {
+ g95_free_constructor(head);
+ g95_set_locus(&old_loc);
+ return MATCH_NO;
+ }
+
+ for(;;) {
+ m = g95_match_iterator(&iter);
+ if (m == MATCH_YES) break;
+ if (m == MATCH_ERROR) goto cleanup;
+
+ m = match_array_cons_element(&new);
+ if (m == MATCH_ERROR) goto cleanup;
+ if (m == MATCH_NO) goto syntax;
+
+ tail->next = new;
+ tail = new;
+
+ if (g95_match(" ,") != MATCH_YES) break;
+ }
+
+ if (g95_match(" )") != MATCH_YES) goto syntax;
+
+ p = g95_get_constructor();
+ p->iter = g95_get_iterator();
+ *p->iter = iter;
+
+ p->child = head;
+ *result = p;
+
+ return MATCH_YES;
+
+syntax:
+ g95_error("Syntax error in array constructor at %C");
+
+cleanup:
+ g95_free_constructor(head);
+ g95_free_iterator(&iter, 0);
+ return MATCH_ERROR;
+}
+
+
+/* match_array_cons_element()-- match a single element of an array
+ * constructor, which can be a single expression or a list of
+ * elements. */
+
+static match match_array_cons_element(g95_constructor **result) {
+g95_constructor *p;
+g95_expr *expr;
+match m;
+
+ m = match_array_list(result);
+ if (m != MATCH_NO) return m;
+
+ m = g95_match_expr(&expr);
+ if (m != MATCH_YES) return m;
+
+ p = g95_get_constructor();
+ p->expr = expr;
+
+ *result = p;
+ return MATCH_YES;
+}
+
+
+/* g95_match_array_constructor()-- Match an array constructor */
+
+match g95_match_array_constructor(g95_expr **result) {
+g95_constructor *head, *tail, *new;
+g95_expr *expr;
+locus where;
+match m;
+
+ if (g95_match(" (/") == MATCH_NO) return MATCH_NO;
+
+ where = *g95_current_locus();
+ head = NULL;
+
+ if (g95_match(" /)") == MATCH_YES) goto empty; /* Special case */
+
+ for(;;) {
+ m = match_array_cons_element(&new);
+ if (m == MATCH_ERROR) goto cleanup;
+ if (m == MATCH_NO) goto syntax;
+
+ if (head == NULL)
+ head = new;
+ else
+ tail->next = new;
+
+ tail = new;
+
+ if (g95_match(" ,") == MATCH_NO) break;
+ }
+
+ if (g95_match(" /)") == MATCH_NO) goto syntax;
+
+empty:
+ expr = g95_get_expr();
+
+ expr->expr_type = EXPR_ARRAY;
+ expr->rank = 1;
+ expr->value.constructor = head;
+ expr->where = where;
+
+ *result = expr;
+ return MATCH_YES;
+
+syntax:
+ g95_error("Syntax error in array constructor at %C");
+
+cleanup:
+ g95_free_constructor(head);
+ return MATCH_ERROR;
+}
+
+
+/* resolve_array_list()-- Recursive array list resolution function.
+ * All of the elements must be of the same type. */
+
+static try resolve_array_list(g95_constructor *p, g95_typespec *ts) {
+try t;
+
+ for(;p ;p=p->next) {
+
+ if (p->child != NULL) {
+ if (resolve_array_list(p->child, ts) == FAILURE) t = FAILURE;
+ if (g95_resolve_iterator(p->iter) == FAILURE) t = FAILURE;
+ }
+
+ if (p->expr == NULL) continue;
+
+ if (g95_resolve_expr(p->expr) == FAILURE) {
+ t = FAILURE;
+ continue;
+ }
+
+ if (ts->type == BT_UNKNOWN) { /* First element of constructor */
+ *ts = p->expr->ts;
+ continue;
+ }
+
+ if (ts->type != p->expr->ts.type) {
+ g95_error("Element in %s array constructor at %L is %s",
+ g95_typename(ts->type), &p->expr->where,
+ g95_typename(p->expr->ts.type));
+
+ t = FAILURE;
+ continue;
+ }
+
+ if (ts->type == BT_DERIVED) {
+ if (ts->derived != p->expr->ts.derived) {
+ g95_error("Element in DERIVED %s array constructor at %L is "
+ "DERIVED %s", ts->derived->name, &p->expr->where,
+ p->expr->ts.derived->name);
+
+ t = FAILURE;
+ }
+ } else {
+
+ if (ts->kind != p->expr->ts.kind) {
+ g95_error("Element in %s kind %d array constructor at %L is "
+ "%s kind %d", g95_typename(ts->type), ts->kind,
+ &p->expr->where,
+ g95_typename(p->expr->ts.type), p->expr->ts.kind);
+ t = FAILURE;
+ }
+ }
+ }
+
+ return t;
+}
+
+
+/* g95_resolve_array_constructor()-- Resolve all of the expressions in
+ * an array list. TODO: String lengths. */
+
+try g95_resolve_array_constructor(g95_expr *expr) {
+g95_typespec ts;
+try t;
+
+ ts.type = BT_UNKNOWN;
+ ts.kind = 0;
+
+ t = resolve_array_list(expr->value.constructor, &ts);
+
+ expr->ts = ts;
+ expr->expr_type = EXPR_ARRAY;
+
+ return t;
+}
+
+
+/* copy_iterator()-- Copy an iterator structure */
+
+static g95_iterator *copy_iterator(g95_iterator *src) {
+g95_iterator *dest;
+
+ if (src == NULL) return NULL;
+
+ dest = g95_get_iterator();
+
+ dest->var = g95_copy_expr(src->var);
+ dest->start = g95_copy_expr(src->start);
+ dest->end = g95_copy_expr(src->end);
+ dest->step = g95_copy_expr(src->step);
+
+ return dest;
+}
+
+
+/* g95_copy_constructor()-- Copy a constructor structure. */
+
+g95_constructor *g95_copy_constructor(g95_constructor *src) {
+g95_constructor *dest;
+
+ if (src == NULL) return NULL;
+
+ dest = g95_get_constructor();
+ dest->expr = g95_copy_expr(src->expr);
+
+ dest->iter = copy_iterator(src->iter);
+
+ dest->next = g95_copy_constructor(src->next);
+ dest->child = g95_copy_constructor(dest->child);
+
+ return dest;
+}
+
1,867 decl.c
@@ -0,0 +1,1867 @@
+/* Declaration statement matcher
+ Copyright (C) 2000 Free Software Foundation, Inc.
+ Contributed by Andy Vaught
+
+This file is part of GNU G95.
+
+GNU G95 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, or (at your option)
+any later version.
+
+GNU G95 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 GNU G95; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+/* decl.c -- Declaration statement matcher. */
+
+#include "g95.h"
+
+
+/* This flag is set if a an old-style length selector is matched
+ * during an type-declaration statement. */
+
+static int old_char_selector;
+
+/* When variables aquire types and attributes from a declaration
+ * statement, they get them from the following static variables. The
+ * first part of a declaration sets these variables and the second
+ * part copies these into symbol structures. */
+
+static g95_typespec current_ts;
+
+static symbol_attribute current_attr;
+static g95_array_spec current_as;
+static int colon_seen;
+
+/* g95_new_block points to the symbol of a newly matched block. */
+
+g95_symbol *g95_new_block;
+
+
+/* match_intent_spec()-- Match an intent specification. Since this
+ * can only happen after an INTENT word, a legal intent-spec must
+ * follow. */
+
+static sym_intent match_intent_spec(void) {
+
+ if (g95_match(" ( in out )") == MATCH_YES) return INTENT_INOUT;
+ if (g95_match(" ( in )") == MATCH_YES) return INTENT_IN;
+ if (g95_match(" ( out )") == MATCH_YES) return INTENT_OUT;
+
+ g95_error("Bad INTENT specification at %C");
+ return INTENT_UNKNOWN;
+}
+
+
+/* char_len_param_value()-- Matches a character length specification,
+ * which is either a specification expression or a '*'. */
+
+static match char_len_param_value(g95_expr **exp) {
+
+ if (g95_match(" *") == MATCH_YES) {
+ exp = NULL;
+ return MATCH_YES;
+ }
+
+ return g95_match(" %e", exp);
+}
+
+
+/* match_char_length()-- A character length is a '*' followed by a
+ * literal integer or a char_len_param_value in parenthesis. */
+
+static match match_char_length(g95_expr **exp) {
+int length;
+match m;
+
+ m = g95_match(" *");
+ if (m != MATCH_YES) return m;
+
+ m = g95_match_small_literal_int(&length);
+ if (m == MATCH_ERROR) return m;
+
+ if (m == MATCH_YES) {
+ *exp = g95_constant_expr(BT_INTEGER, length, NULL);
+ return m;
+ }
+
+ if (g95_match(" (") == MATCH_NO) goto syntax;
+
+ m = char_len_param_value(exp);
+ if (m == MATCH_ERROR) return m;
+ if (m == MATCH_NO) goto syntax;
+
+ if (g95_match(" )") == MATCH_NO) {
+ g95_free_expr(*exp);
+ *exp = NULL;
+ goto syntax;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ g95_error("Syntax error in character length specification at %C");
+ return MATCH_ERROR;
+}
+
+
+/* find_special()-- Special subroutine for finding a symbol. If we're
+ * compiling a function or subroutine and the parent compilation unit
+ * is an interface, then check to see if the name we've been given is
+ * the name of the interface (located in another namespace). If so,
+ * return that symbol. If not, use g95_get_symbol(). */
+
+static g95_symbol *find_special(char *name) {
+g95_state_data *s;
+
+ if (g95_current_state() != COMP_SUBROUTINE &&
+ g95_current_state() != COMP_FUNCTION) goto normal;
+
+ s = g95_state_stack->previous;
+ if (s == NULL) goto normal;
+
+ if (s->state != COMP_INTERFACE) goto normal;
+ if (s->sym == NULL) goto normal; /* Nameless interface */
+
+ if (strcmp(name, s->sym->name ) == 0) return s->sym;
+
+normal:
+ return g95_get_symbol(name, NULL);
+}
+
+
+/* build_sym()-- Function called by variable_decl() that adds a name
+ * to the symbol table. */
+
+static try build_sym(char *name, g95_charlen *cl, g95_expr **initp,
+ g95_array_spec *as, locus *var_locus) {
+symbol_attribute attr;
+g95_symbol *sym;
+g95_expr *init;
+
+ init = *initp;
+ sym = find_special(name);
+
+/* Start updating the symbol table. Add basic type attribute if present */
+
+ if (current_ts.type != BT_UNKNOWN) {
+ if (sym->ts.type != BT_UNKNOWN) {
+ g95_error("Symbol at %L already has basic type of %s", var_locus,
+ g95_typename(sym->ts.type));
+ return FAILURE;
+ }
+
+ sym->ts = current_ts;
+ }
+
+ if (sym->ts.type == BT_CHARACTER) sym->ts.cl = cl;
+
+/* Add dimension attribute if present. */
+
+ if (as->rank != 0 && g95_set_array_spec(sym, as, var_locus) == FAILURE)
+ return FAILURE;
+
+/* Add attribute to symbol. The copy is so that we can reset the
+ * dimension attribute. */
+
+ attr = current_attr;
+ attr.dimension = 0;
+
+ if (g95_copy_attr(&sym->attr, &attr, var_locus) == FAILURE) return FAILURE;
+
+/* Add initializer, required for PARAMETERs. */
+
+ if (init == NULL) {
+ if (sym->attr.flavor == FL_PARAMETER) {
+ g95_error("PARAMETER at %L is missing an initializer", var_locus);
+ return FAILURE;
+ }
+ } else {
+ if (g95_check_assign_symbol(sym, init) == FAILURE) return FAILURE;
+
+ if (init->expr_type != EXPR_CONSTANT) {
+ g95_error("Initialization value must be constant for symbol at %L",
+ var_locus);
+ return FAILURE;
+ }
+
+ sym->value = init;
+ *initp = NULL;
+ }
+
+ return SUCCESS;
+}
+
+
+/* build_struct()-- Function called by variable_decl() that adds a
+ * name to a structure being built. */
+
+static try build_struct(char *name, g95_charlen *cl, g95_expr **init,
+ g95_array_spec *as) {
+g95_component *c;
+
+ if ((current_ts.type == BT_DERIVED) &&
+ (current_ts.derived == g95_current_block()) &&
+ (current_attr.pointer == 0)) {
+ g95_error("Component at %C must have the POINTER attribute");
+ return FAILURE;
+ }
+
+ if (g95_current_block()->attr.pointer && as->rank != 0) {
+ if (as->type != AS_DEFERRED && as->type != AS_EXPLICIT) {
+ g95_error("Array component of structure at %C must have explicit "
+ "or deferred shape");
+ return FAILURE;
+ }
+ }
+
+ if (g95_add_component(g95_current_block(), name, &c) == FAILURE)
+ return FAILURE;
+
+ c->ts = current_ts;
+ c->ts.cl = cl;
+ c->attr = current_attr;
+
+ c->initializer = *init;
+ *init = NULL;
+
+ g95_copy_array_spec(&c->as, as);
+
+ return SUCCESS;
+}
+
+
+/* variable_decl()-- Match a variable name with an optional
+ * initializer. When this subroutine is called, a variable is
+ * expected to be parsed next. Depending on what is happening at the
+ * moment, updates either the symbol table or the current
+ * interface. */
+
+static match variable_decl(void) {
+char name[G95_MAX_SYMBOL_LEN+1];
+g95_expr *initializer, *char_len;
+g95_array_spec as;
+g95_charlen *cl;