dimension.c
1 //! @file dimension.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Compile DIMENSION.
25
26 #include <vif.h>
27
28 void get_dims (IDENT * idf, int_4 dim)
29 {
30 EXPR reg;
31 NEW_RECORD (str);
32 int_4 rc;
33 memset (®, 0, sizeof (EXPR));
34 rc = scan (EXPECT_NONE);
35 if (TOKEN ("*")) {
36 idf->lwb[idf->mode.dim] = f_stralloc ("1");
37 idf->upb[idf->mode.dim] = f_stralloc ("0");
38 idf->len[idf->mode.dim++] = f_stralloc ("VARY");
39 rc = scan (EXPECT_NONE);
40 } else {
41 macro_depth = 0;
42 express (®, INTEGER, 4);
43 if (reg.variant != EXPR_CONST) {
44 if (reg.variant == EXPR_VAR && reg.idf->arg == ARG) {
45 ;
46 } else if (reg.variant == EXPR_VAR && reg.idf->common > 0) {
47 ;
48 } else if (reg.variant == EXPR_VAR) {
49 ERROR (1201, "must be common or parameter", F_NAME (reg.idf));
50 }
51 idf->variable = TRUE;
52 idf->mode.save = AUTOMATIC;
53 }
54 rc = scan (EXPECT_NONE);
55 int varying = FALSE;
56 if (TOKEN (":")) {
57 idf->lwb[idf->mode.dim] = f_stralloc (reg.str);
58 rc = scan (EXPECT_NONE);
59 if (TOKEN ("*")) {
60 // (lwb : *)
61 idf->upb[idf->mode.dim] = f_stralloc ("0");
62 idf->len[idf->mode.dim++] = f_stralloc ("VARY");
63 varying = TRUE;
64 } else {
65 macro_depth = 0;
66 express (®, INTEGER, 4);
67 if (reg.variant != EXPR_CONST) {
68 if (reg.variant == EXPR_VAR && reg.idf->arg == ARG) {
69 ;
70 } else if (reg.variant == EXPR_VAR && reg.idf->common > 0) {
71 ;
72 } else if (reg.variant == EXPR_VAR) {
73 ERROR (1202, "must be common or parameter", F_NAME (reg.idf));
74 }
75 idf->variable = TRUE;
76 idf->mode.save = AUTOMATIC;
77 }
78 idf->upb[idf->mode.dim] = f_stralloc (reg.str);
79 }
80 rc = scan (EXPECT_NONE);
81 } else {
82 idf->lwb[idf->mode.dim] = f_stralloc ("1");
83 idf->upb[idf->mode.dim] = f_stralloc (reg.str);
84 }
85 if (! varying) {
86 NEW_RECORD (buf);
87 if (strcmp (idf->lwb[idf->mode.dim], "1") == 0) {
88 _srecordf (str, "%s", idf->upb[idf->mode.dim]);
89 } else {
90 _srecordf (str, "%s - %s + 1", idf->upb[idf->mode.dim], idf->lwb[idf->mode.dim]);
91 }
92 fold_int_4 (buf, str);
93 idf->len[idf->mode.dim++] = f_stralloc (buf);
94 }
95 }
96 if (TOKEN (",")) {
97 if (dim < MAX_DIMS) {
98 get_dims (idf, dim + 1);
99 } else {
100 ERROR (1203, "too many dimensions", NO_TEXT);
101 }
102 }
103 (void) rc;
104 }
105
106 void dimension (void)
107 {
108 int_4 rc = scan (EXPECT_NONE), set = 0;
109 while (rc != END_OF_LINE) {
110 MODE mode;
111 if (rc == WORD) {
112 if (/* reserved (curlex) */ FALSE) {
113 ERROR (1204, "reserved symbol", curlex);
114 }
115 set++;
116 IDENT *idf = void_decl (curlex, &mode);
117 rc = scan ("(");
118 if (idf != NO_IDENT) {
119 if (IS_ROW (idf->mode)) {
120 ERROR (1205, "variable already dimensioned", F_NAME (idf));
121 }
122 get_dims (idf, 1);
123 CHECKPOINT (1206, ")");
124 rc = scan (EXPECT_NONE);
125 }
126 }
127 if (TOKEN (",")) {
128 rc = scan (EXPECT_NONE);
129 if (! WITHIN) {
130 SYNTAX (1207, NO_TEXT);
131 }
132 } else {
133 if (rc != END_OF_LINE) {
134 SYNTAX (1208, NO_TEXT);
135 rc = scan (EXPECT_NONE);
136 }
137 }
138 }
139 if (set == 0) {
140 SYNTAX (1209, "dimension statement");
141 }
142 }
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|