slice.c
1 //! @file slice.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 array slices.
25
26 #include <vif.h>
27
28 void code_index (RECORD index, IDENT * idf, int_4 dim)
29 {
30 NEW_RECORD (str);
31 EXPR reg;
32 express (®, INTEGER, 4);
33 if (EQUAL (idf->lwb[dim], "0")) {
34 if (dim == 0) {
35 _srecordf (str, "%s", reg.str);
36 } else {
37 _srecordf (str, "(%s)", reg.str);
38 }
39 } else {
40 NEW_RECORD (buf);
41 _srecordf (str, "%s - %s", reg.str, idf->lwb[dim]);
42 fold_int_4 (buf, str);
43 if (dim == 0) {
44 _srecordf (str, "%s", buf);
45 } else {
46 _srecordf (str, "(%s)", buf);
47 }
48 }
49 (void) scan (EXPECT_NONE);
50 if (TOKEN (":")) {
51 SYNTAX (2901, "range not allowed");
52 } else if (TOKEN (",")) {
53 NEW_RECORD (deep);
54 (void) scan (EXPECT_NONE);
55 code_index (deep, idf, dim + 1);
56 if (strcmp (idf->len[dim], "VARY") == 0) {
57 ERROR (2902, "dimension cannot vary", NO_TEXT);
58 }
59 NEW_RECORD (prod); NEW_RECORD (fact);
60 _srecordf (prod, "(%s) * (%s)", idf->len[dim], deep);
61 fold_int_4 (fact, prod);
62 if (strcmp (fact, "0") == 0) {
63 _srecordf (index, "%s", str);
64 } else {
65 _srecordf (index, "%s + %s", str, fact);
66 }
67 } else if (TOKEN (")")) {
68 bufcpy (index, str, RECLN);
69 return;
70 }
71 }
72
73 void code_store_index (EXPR *loc, RECORD index, IDENT * idf, int_4 dim)
74 {
75 RECCLR (index);
76 code_index (index, idf, 0);
77 // Sanity check.
78 int_4 value;
79 if (is_int4 (index, &value) && value < 0) {
80 ERROR (2903, "index out of range", FTN_NAME (idf));
81 }
82 // FORTRAN code, like m[(i + W1 * (j * W2 * k)]
83 fold_int_4 (loc->elem, index);
84 }
85
86 void factor_slice_char (EXPR *loc, IDENT *idf)
87 {
88 NEW_RECORD (ldf);
89 NEW_RECORD (index);
90 // Code identifier name.
91 (void) idf_full_c_name (ldf, idf);
92 //
93 if (IS_ROW (idf->mode)) {
94 // Assume idf(i1, .., iN) possibly followed by (lwb : upb)
95 (void) scan (EXPECT_NONE);
96 code_store_index (loc, index, idf, 0);
97 _srecordf (ldf, "%s[%s]", ldf, index);
98 (void) scan (EXPECT_NONE); // Skip ")"
99 if (!TOKEN ("(")) {
100 // idf(i1, ..., iN), no substring.
101 UNSCAN;
102 bufcpy (loc->str, ldf, RECLN);
103 loc->variant = EXPR_SLICE;
104 loc->idf = idf;
105 loc->mode = idf->mode;
106 return;
107 }
108 }
109 // The trimmer (lwb : upb)
110 EXPR ini, fin;
111 int_4 denot = (IS_SCALAR (idf->mode));
112 (void) scan (EXPECT_NONE);
113 if (TOKEN (":")) {
114 _srecordf (ini.str, "1");
115 ini.mode.type = INTEGER;
116 ini.mode.len = 4;
117 ini.variant = EXPR_CONST;
118 } else {
119 express (&ini, INTEGER, 4);
120 denot &= (ini.variant == EXPR_CONST);
121 (void) scan (EXPECT_NONE);
122 }
123 CHECKPOINT (2904, ":");
124 // ldf(lwb : upb)
125 (void) scan (EXPECT_NONE);
126 if (TOKEN (")")) {
127 UNSCAN;
128 _srecordf (fin.str, "%d", idf->mode.len);
129 fin.mode.type = INTEGER;
130 fin.mode.len = 4;
131 fin.variant = EXPR_CONST;
132 } else {
133 express (&fin, INTEGER, 4);
134 denot &= (fin.variant == EXPR_CONST);
135 }
136 if (lhs_factor) { // A permanent stub ...
137 bufcat (ini.str, " - 1", RECLN);
138 (void) fold_expr (&ini, INTEGER);
139 _srecordf (loc->str, "(char *) &(%s[%s])", ldf, ini.str);
140 loc->variant = EXPR_SUBSTR;
141 loc->idf = idf;
142 loc->mode = idf->mode;
143 } else {
144 // Optimize substring with all constant parameters.
145 denot &= (idf->parm != NO_TEXT);
146 if (denot) {
147 NEW_RECORD (cdf); NEW_RECORD (sub); NEW_RECORD (tmp);
148 get_uniq_str (idf->parm, cdf);
149 _srecordf (sub, "\"%s\"", _bufsub (tmp, cdf, atoi (ini.str), atoi (fin.str)));
150 _srecordf (cdf, "_dc_%d", code_uniq_str (sub));
151 _srecordf (loc->str, "%s", cdf);
152 loc->mode = (MODE) {.type = CHARACTER, .len = strlen (sub) - 2, .dim = 0};
153 loc->variant = EXPR_CONST;
154 } else {
155 // General form of substring.
156 NEW_RECORD (tmp);
157 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
158 if (idf->mode.len > 0) {
159 add_local (tmp, idf->mode.type, idf->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
160 } else { // Should not copy into zero-length string.
161 add_local (tmp, idf->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
162 }
163 // _bufsub returns buffer address, so no gcc statement expression needed.
164 _srecordf (loc->str, "_bufsub ((char *) %s, (char *) %s, %s, %s)", tmp, ldf, ini.str, fin.str);
165 loc->variant = EXPR_SUBSTR;
166 loc->idf = idf;
167 loc->mode = idf->mode;
168 }
169 }
170 (void) scan (")");
171 }
172
173 void factor_slice (EXPR *loc, IDENT *idf)
174 {
175 NEW_RECORD (index);
176 (void) idf_full_c_name (loc->str, idf);
177 (void) scan (EXPECT_NONE);
178 code_store_index (loc, index, idf, 0);
179 bufcat (loc->str, "[", RECLN);
180 bufcat (loc->str, loc->elem, RECLN);
181 bufcat (loc->str, "]", RECLN);
182 loc->variant = EXPR_SLICE;
183 loc->idf = idf;
184 loc->mode = idf->mode;
185 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
