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_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 (2401, "variable")
37 } else {
38 int_4 go_on;
39 do {
40 if (rc != WORD) {
41 EXPECT (2402, "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 (2403, "=");
52 go_on = FALSE;
53 } else {
54 EXPECT (2404, ", 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 (void) 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 int_4 savlin = curlin, savcol = curcol;
90 int_4 savesp = nlocals;
91 macro_nest++;
92 // Gather arguments.
93 curlin = idf->line;
94 curcol = 0;
95 RECORD pack[MAX_ARGS];
96 NEW_RECORD (expr);
97 bzero (pack, sizeof (pack));
98 bufcpy (expr, "({", RECLN);
99 int_4 N = 0, M = 0;
100 macro_args (pack, &N);
101 // Work out arguments.
102 curlin = savlin;
103 curcol = savcol;
104 (void) scan (EXPECT_NONE);
105 macro_parms (pack, expr, N, &M);
106 int_4 savesp2 = nlocals;
107 savlin = curlin;
108 savcol = curcol;
109 int_4 savprl = prelin;
110 int_4 savprc = precol;
111 NEW_RECORD (savlex);
112 bufcpy (savlex, curlex, RECLN);
113 // Work out macro expression.
114 curlin = idf->line;
115 curcol = 0;
116 EXPR reg, new = (EXPR) {.mode = idf->mode};
117 memset (®, 0, sizeof (reg));
118 (void) scan (EXPECT_NONE);
119 while (! TOKEN ("=")) {
120 (void) scan (EXPECT_NONE);
121 }
122 (void) scan (EXPECT_NONE);
123 express (®, NOTYPE, 0);
124 if (!coerce (&new, ®)) {
125 MODE_ERROR (2405, qtype (&(reg.mode)), qtype (&(new.mode)));
126 }
127 bufcat (expr, new.str, RECLN);
128 bufcat (expr, ";})", RECLN);
129 bufcpy (loc->str, expr, RECLN);
130 loc->variant = EXPR_OTHER;
131 loc->mode = new.mode;
132 curlin = savlin;
133 curcol = savcol;
134 prelin = savprl;
135 precol = savprc;
136 bufcpy (curlex, savlex, RECLN);
137 // Disable parms and exit.
138 for (int_4 k = savesp; k < savesp2; k++) {
139 (&locals[k])->nest = -1;
140 }
141 macro_nest--;
142 }
143
144 logical_4 is_macro_decl (char *name)
145 {
146 if (reserved (name)) {
147 return FALSE;
148 } else {
149 MODE mode;
150 IDENT *idf = find_local (name, &mode);
151 if (lookahead ("(")) {
152 if (idf == NO_IDENT || (!idf->external && !idf->parm && !IS_ROW (idf->mode))) {
153 return TRUE;
154 }
155 }
156 return FALSE;
157 }
158 }
159
160 static void do_macro ()
161 {
162 MODE mode;
163 IDENT *idf = find_local (curlex, &mode);
164 if (idf == NO_IDENT) {
165 idf = add_local (curlex, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, MACRO);
166 impl_type (curlex, &idf->mode);
167 }
168 idf->line = curlin;
169 idf->source = MACRO;
170 // Skip argument pack.
171 int_4 rc = scan (EXPECT_NONE);
172 do {
173 rc = scan (EXPECT_NONE);
174 } while (rc != END_OF_LINE && ! TOKEN (")"));
175 // Check syntax.
176 if (rc == END_OF_LINE) {
177 EXPECT (2406, "=");
178 } else {
179 rc = scan (EXPECT_NONE);
180 CHECKPOINT (2407, "=");
181 skip_card (FALSE);
182 }
183 }
184
185 void decl_macros (void)
186 {
187 int_4 go_on = TRUE;
188 while (go_on) {
189 SAVE_POS;
190 int_4 rc = scan (EXPECT_NONE);
191 if (rc == DECLAR) {
192 skip_card (FALSE);
193 } else if (TOKEN ("implicit")) {
194 skip_card (FALSE);
195 } else if (TOKEN ("save")) {
196 skip_card (FALSE);
197 } else if (TOKEN ("automatic")) {
198 skip_card (FALSE);
199 } else if (TOKEN ("parameter")) {
200 skip_card (FALSE);
201 } else if (TOKEN ("common")) {
202 skip_card (FALSE);
203 } else if (TOKEN ("dimension")) {
204 skip_card (FALSE);
205 } else if (TOKEN ("equivalence")) {
206 skip_card (FALSE);
207 } else if (TOKEN ("external")) {
208 skip_card (FALSE);
209 } else if (TOKEN ("intrinsic")) {
210 skip_card (FALSE);
211 } else if (TOKEN ("data")) {
212 skip_card (FALSE);
213 } else if (rc == WORD && is_macro_decl (curlex)) {
214 do_macro ();
215 skip_card (FALSE);
216 } else if (strlen (curlex) > 0) {
217 // Backspace and done.
218 RESTORE_POS;
219 go_on = FALSE;
220 }
221 }
222 }
223
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
