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 (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 (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 (2505, 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 static void do_macro ()
145 {
146 MODE mode;
147 IDENT *idf = find_local (curlex, &mode);
148 if (idf == NO_IDENT) {
149 idf = add_local (curlex, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, MACRO);
150 impl_type (curlex, &idf->mode);
151 }
152 idf->line = curlin;
153 idf->source = MACRO;
154 // Skip argument pack.
155 int_4 rc = scan (EXPECT_NONE);
156 do {
157 rc = scan (EXPECT_NONE);
158 } while (rc != END_OF_LINE && ! TOKEN (")"));
159 // Check syntax.
160 if (rc == END_OF_LINE) {
161 EXPECT (2506, "=");
162 } else {
163 rc = scan (EXPECT_NONE);
164 CHECKPOINT (2507, "=");
165 skip_card (FALSE);
166 }
167 }
168
169 void decl_macros (void)
170 {
171 int_4 go_on = TRUE;
172 while (go_on) {
173 SAVE_POS (1);
174 int_4 rc = scan (EXPECT_NONE);
175 if (rc == DECLAR) {
176 skip_card (FALSE);
177 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
178 skip_card (FALSE);
179 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
180 skip_card (FALSE);
181 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
182 skip_card (FALSE);
183 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
184 skip_card (FALSE);
185 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
186 skip_card (FALSE);
187 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
188 skip_card (FALSE);
189 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
190 skip_card (FALSE);
191 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
192 skip_card (FALSE);
193 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
194 skip_card (FALSE);
195 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
196 skip_card (FALSE);
197 } else if (rc == WORD && IS_MACRO_DECLARATION) {
198 do_macro ();
199 skip_card (FALSE);
200 } else if (strlen (curlex) > 0) {
201 // Backspace and done.
202 RESTORE_POS (1);
203 go_on = FALSE;
204 }
205 }
206 }
207
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
