macro.c
1 //! @file macro.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 function statements.
25
26 #include <vif.h>
27
28 int_4 macro_depth, macro_nest;
29
30 static void macro_args (RECORD *name, int_4 *N)
31 {
32 int_4 rc = scan (EXPECT_NONE);
33 rc = scan (EXPECT_NONE);
34 rc = scan (EXPECT_NONE);
35 if (rc != WORD) {
36 EXPECT (2501, "variable")
37 } else {
38 int_4 go_on;
39 do {
40 if (rc != WORD) {
41 EXPECT (2502, "variable");
42 }
43 RECCPY (name[*N], curlex);
44 (*N)++;
45 rc = scan (EXPECT_NONE);
46 if (TOKEN (",")) {
47 go_on = TRUE;
48 rc = scan (EXPECT_NONE);
49 } else if (TOKEN (")")) {
50 rc = scan (EXPECT_NONE);
51 CHECKPOINT (2503, "=");
52 go_on = FALSE;
53 } else {
54 EXPECT (2504, ", or )");
55 go_on = FALSE;
56 }
57 } while (go_on);
58 }
59 }
60
61 static void macro_parms (RECORD *pack, RECORD expr, int_4 N, int_4 *M)
62 {
63 (void) scan (EXPECT_NONE);
64 if (TOKEN ("(")) {
65 macro_parms (pack, expr, N, M);
66 } else if (TOKEN (",")) {
67 macro_parms (pack, expr, N, M);
68 } else if (TOKEN (")")) {
69 return;
70 } else {
71 MODE mode;
72 EXPR reg;
73 NEW_RECORD (res);
74 int k = macro_nest;
75 memset (®, 0, sizeof (EXPR));
76 express (®, NOTYPE, 0);
77 macro_nest = k;
78 (void) add_nest (pack[*M], macro_nest, &mode);
79 _srecordf (res, "%s %s = %s; ", wtype (&mode, NOARG, NOFUN), edit_vn (pack[*M], macro_nest), reg.str);
80 (*M)++;
81 bufcat (expr, res, RECLN);
82 macro_parms (pack, expr, N, M);
83 }
84 }
85
86 void macro (EXPR *loc, IDENT *idf)
87 {
88 UNSCAN;
89 if (macro_depth++ > MAX_MACRO_DEPTH) {
90 // This could happen due to infinite recursion.
91 // A simple alternative to Warshall's algorithm.
92 FATAL (2505, "macros nested too deep", NO_TEXT);
93 }
94 int_4 savlin = curlin, savcol = curcol;
95 int_4 savesp = nlocals;
96 macro_nest++;
97 // Gather arguments.
98 curlin = idf->line;
99 curcol = 0;
100 RECORD pack[MAX_ARGS];
101 NEW_RECORD (expr);
102 bzero (pack, sizeof (pack));
103 bufcpy (expr, "({", RECLN);
104 int_4 N = 0, M = 0;
105 macro_args (pack, &N);
106 // Work out arguments.
107 curlin = savlin;
108 curcol = savcol;
109 (void) scan (EXPECT_NONE);
110 macro_parms (pack, expr, N, &M);
111 int_4 savesp2 = nlocals;
112 savlin = curlin;
113 savcol = curcol;
114 int_4 savprl = prelin;
115 int_4 savprc = precol;
116 NEW_RECORD (savlex);
117 bufcpy (savlex, curlex, RECLN);
118 // Work out macro expression.
119 curlin = idf->line;
120 curcol = 0;
121 EXPR reg, new = (EXPR) {.mode = idf->mode};
122 memset (®, 0, sizeof (reg));
123 (void) scan (EXPECT_NONE);
124 while (! TOKEN ("=")) {
125 (void) scan (EXPECT_NONE);
126 }
127 (void) scan (EXPECT_NONE);
128 express (®, NOTYPE, 0);
129 if (!coerce (&new, ®)) {
130 MODE_ERROR (2506, qtype (&(reg.mode)), qtype (&(new.mode)));
131 }
132 bufcat (expr, new.str, RECLN);
133 bufcat (expr, ";})", RECLN);
134 bufcpy (loc->str, expr, RECLN);
135 loc->variant = EXPR_OTHER;
136 loc->mode = new.mode;
137 curlin = savlin;
138 curcol = savcol;
139 prelin = savprl;
140 precol = savprc;
141 bufcpy (curlex, savlex, RECLN);
142 // Disable parms and exit.
143 for (int_4 k = savesp; k < savesp2; k++) {
144 (&locals[k])->nest = -1;
145 }
146 macro_nest--;
147 }
148
149 static void do_macro ()
150 {
151 MODE mode;
152 IDENT *idf = find_local (curlex, &mode);
153 if (idf == NO_IDENT) {
154 idf = add_local (curlex, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, MACRO);
155 impl_type (curlex, &idf->mode);
156 }
157 idf->line = curlin;
158 idf->source = MACRO;
159 // Skip argument pack.
160 int_4 rc = scan (EXPECT_NONE);
161 do {
162 rc = scan (EXPECT_NONE);
163 } while (rc != END_OF_LINE && ! TOKEN (")"));
164 // Check syntax.
165 if (rc == END_OF_LINE) {
166 EXPECT (2507, "=");
167 } else {
168 rc = scan (EXPECT_NONE);
169 CHECKPOINT (2508, "=");
170 skip_card (FALSE);
171 }
172 }
173
174 void decl_macros (void)
175 {
176 int_4 go_on = TRUE;
177 while (go_on) {
178 SAVE_POS (1);
179 int_4 rc = scan (EXPECT_NONE);
180 if (rc == DECLAR) {
181 skip_card (FALSE);
182 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
183 skip_card (FALSE);
184 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
185 skip_card (FALSE);
186 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
187 skip_card (FALSE);
188 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
189 skip_card (FALSE);
190 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
191 skip_card (FALSE);
192 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
193 skip_card (FALSE);
194 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
195 skip_card (FALSE);
196 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
197 skip_card (FALSE);
198 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
199 skip_card (FALSE);
200 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
201 skip_card (FALSE);
202 } else if (rc == WORD && IS_MACRO_DECLARATION) {
203 do_macro ();
204 skip_card (FALSE);
205 } else if (strlen (curlex) > 0) {
206 // Backspace and done.
207 RESTORE_POS (1);
208 go_on = FALSE;
209 }
210 }
211 }
212
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
